!####################################################################### ! ! MDF - Multiple Data Format ! ! NAME ! MDF - generic interface to a number of scientific data formats ! ! ! BACKGROUND ! ! Single interface to multipe file formats. ! From 'multiple' it should evolve into 'many' and preferably 'most'. ! ! This module is intended to replace an older f90 interface to HDF4 ! called 'file_hdf'. ! ! Creation of file follows the steps similar to writing a NetCDF file: ! o opening of the file ! o (global attributes) ! o definition of dimensions (plus attributes) ! o definition of variables (plus attributes) ! o end of definition phase ! o write one or more time records ! o close file ! ! ! PROCEDURES ! ! ! ! ! module initialisation ! ! ! ! subroutine MDF_Init( status ) ! integer, intent(out) :: status ! ! ! ! ! write data ! ! ! ! ! create a new file for output: ! subroutine MDF_Create( filename, ftype, cmode, hid, status ) ! character(len=*), intent(in) :: filename ! integer, intent(in) :: ftype ! integer, intent(in) :: cmode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! ! ! ... or create more than one with different formats; ! ! specify a single base name and an equal number of extensions and type: ! subroutine MDF_Create( basename, exts, ftypes, cmode, hid, status ) ! character(len=*), intent(in) :: basename ! character(len=*), intent(in) :: exts(:) ! integer, intent(in) :: ftypes(:) ! integer, intent(in) :: cmode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! ! subroutine MDF_Def_Dim( hid, name, length, dimid, status ) ! integer, intent(in) :: hid ! character(len=*), intent(in) :: name ! integer, intent(in) :: length ! integer, intent(out) :: dimid ! integer, intent(out) :: status ! ! subroutine MDF_Def_Var( hid, name, xtype, dimids, varid, status, & ! compression, deflate_level ) ! integer, intent(in) :: hid ! character(len=*), intent(in) :: name ! integer, intent(in) :: xtype ! integer, intent(in) :: dimids(:) ! integer, intent(out) :: varid ! integer, intent(out) :: status ! integer, intent(in), optional :: compression ! integer, intent(in), optional :: deflate_level ! 0-9 ! ! subroutine MDF_Put_Att( hid, varid, name, values, status ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! character(len=*), intent(in) :: name ! , intent(in) :: value(s) ! integer, intent(out) :: status ! ! subroutine MDF_EndDef( hid, status ) ! integer, intent(in) :: hid ! integer, intent(out) :: status ! ! ! put variable: ! subroutine MDF_Put_Var( hid, varid, values, status, & ! start, count, stride, map ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! , intent(in) :: values() ! integer, intent(out) :: status ! integer, intent(in), optional :: start(:) ! (/1,1,..,1/) ! integer, intent(in), optional :: count(:) ! integer, intent(in), optional :: stride(:) ! integer, intent(in), optional :: map(:) ! ! ! close file(s): ! subroutine MDF_Close( hid, status ) ! integer, intent(out) :: hid ! integer, intent(out) :: status ! ! ! ! ! read file ! ! ! ! ! open single file: ! subroutine MDF_Open( filename, ftype, mode, hid, status ) ! character(len=*), intent(in) :: filename ! integer, intent(in) :: ftype ! integer, intent(in) :: mode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! ! subroutine MDF_Inquire( hid, status, & ! nDimensions, nVariables, nAttributes ) ! integer, intent(in) :: hid ! integer, intent(out) :: status ! integer, intent(out), optional :: nDimensions ! integer, intent(out), optional :: nVariables ! integer, intent(out), optional :: nAttributes ! ! subroutine MDF_Inq_DimID( hid, name, dimid, status ) ! integer, intent(in) :: hid ! character(len=*), intent(in) :: name ! integer, intent(out) :: dimid ! integer, intent(out) :: status ! ! subroutine MDF_Inquire_Dimension( hid, dimid, status, name, length, unlimited ) ! integer, intent(in) :: hid ! integer, intent(in) :: dimid ! integer, intent(out) :: status ! character(len=*), intent(out), optional :: name ! integer, intent(out), optional :: length ! logical, intent(out), optional :: unlimited ! ! subroutine MDF_Inq_VarID( hid, name, varid, status ) ! integer, intent(in) :: hid ! character(len=*), intent(in) :: name ! integer, intent(out) :: varid ! integer, intent(out) :: status ! ! subroutine MDF_Inquire_Variable( hid, varid, status, & ! name, xtype, ndims, dimids, natts ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! integer, intent(out) :: status ! character(len=*), intent(out), optional :: name ! integer, intent(out), optional :: xtype ! integer, intent(out), optional :: ndims ! integer, intent(out), optional :: dimids(:) ! integer, intent(out), optional :: natts ! ! subroutine MDF_Get_Var( hid, varid, values, status, & ! start, count, stride, map ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! , intent(out) :: values() ! integer, intent(out) :: status ! integer, intent(in), optional :: start (:) ! integer, intent(in), optional :: count (:) ! integer, intent(in), optional :: stride(:) ! integer, intent(in), optional :: map (:) ! ! subroutine MDF_Inq_AttName( hid, varid, attnum, name, status ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! integer, intent(in) :: attnum ! character(len=*), intent(out) :: name ! integer, intent(out) :: status ! ! subroutine MDF_Inquire_Attribute( hid, varid, name, status, xtype, length ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! character(len=*), intent(out) :: name ! integer, intent(out) :: status ! integer, intent(out), optional :: xtype ! integer, intent(out), optional :: length ! ! subroutine MDF_Get_Att( hid, varid, name, values, status ) ! integer, intent(in) :: hid ! integer, intent(in) :: varid ! character(len=*), intent(in) :: name ! , intent(out) :: value(s) ! integer, intent(out) :: status ! ! ! close file: ! subroutine MDF_Close( hid, status ) ! integer, intent(out) :: hid ! integer, intent(out) :: status ! ! ! ! ! parallel access ! ! ! ! ! create a new file for output: ! subroutine MDF_Create( filename, ftype, cmode, hid, status, & ! mpi_comm=comm, mpi_info=MPI_INFO_NULL ) ! character(len=*), intent(in) :: filename ! integer, intent(in) :: cmode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! integer, intent(in), optional :: mpi_comm ! integer, intent(in), optional :: mpi_info ! ! ! ... or create more than one with different formats; ! ! specify a single base name and an equal number of extensions and type: ! subroutine MDF_Create( basename, exts, ftypes, cmode, hid, status, & ! mpi_comm=comm, mpi_info=MPI_INFO_NULL ) ! character(len=*), intent(in) :: basename ! character(len=*), intent(in) :: exts(:) ! integer, intent(in) :: ftypes(:) ! integer, intent(in) :: cmode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! integer, intent(in), optional :: mpi_comm ! integer, intent(in), optional :: mpi_info ! ! ! open single file: ! subroutine MDF_Open( filename, ftype, mode, hid, status, & ! mpi_comm=comm, mpi_info=MPI_INFO_NULL ) ! character(len=*), intent(in) :: filename ! integer, intent(in) :: ftype ! integer, intent(in) :: mode ! integer, intent(out) :: hid ! integer, intent(out) :: status ! integer, intent(in), optional :: mpi_comm ! integer, intent(in), optional :: mpi_info ! ! ! parallel access mode (see NetCDF4 manual): ! subroutine MDF_Var_Par_Access( hid, varid, par_access_mode, status ) ! integer, intent(in) :: hid ! integer, intent(out) :: varid ! integer, intent(in) :: par_access_mode ! integer, intent(out) :: status ! ! ! ! ! show file content ! ! ! ! ! show file headers similar to 'ncdump -h' ; ! ! file type is guessed from extension if not specified directly: ! subroutine MDF_Show( filename, status [,filetype=MDF_NETCDF4|MDF_HDF|...] ) ! character(len=*), intent(in) :: filename ! integer, intent(out) :: status ! integer, intent(in), optional :: filetype ! integer, intent(out) :: status ! ! ! ! ! end module access ! ! ! ! ! done with module: ! subroutine MDF_Done( status ) ! integer, intent(out) :: status ! ! ! CREATION AND OPEN MODES ! ! MDF_NEW : new file, error if already present ! MDF_REPLACE : new file, overwrite older file if necessary ! MDF_READ : open existing file for reading ! MDF_WRITE : open existing file for writing ! ! ! FILE TYPES ! ! MDF_HDF4 : HDF4 ! MDF_NETCDF : NetCDF (clasical format ; via NetCDF-3 or NetCDF-4 library) ! MDF_NETCDF4 : NetCDF4 (HDF5 format ; via NetCDF-4 library with NetCDF-4 features enabled; ! requires linking with HDF5 library too) ! ! ! GLOBAL ATTRIBUTES ! ! To write global attributes, use the constant 'MDF_GLOBAL' as variable id. ! ! ! UNLIMITED DIMENSION ! ! To define an unlimited dimension, use the constant 'MDF_UNLIMITED' ! as dimension length. ! ! ! DATA TYPES ! ! MDF_CHAR ! MDF_BYTE ! MDF_SHORT ! MDF_INT ! MDF_FLOAT ! MDF_DOUBLE ! ! ! PARALLEL ACCESS MODES ! ! MDF_INDEPENDENT ! independent data mode (one processor at a time can read/write) ! MDF_COLLECTIVE ! collective data mode (several processors can do I/O simultaneously ) ! ! ! FPP MACRO'S ! ! The following fpp macro's might be defined to compile only certain parts of the code: ! ! with_hdf4 : compile with calls to HDF (=HDF4) library ! with_netcdf : compile with calls to NetCDF library ! with_netcdf4 : compile with calls to NetCDF-4 library with NetCDF-4 features enabled; ! automatically defines 'with_netcdf' ! with_netcdf4_par : compile with calls to NetCDF-4 library with NetCDF-4 and parallel ! features enabled; automatically defines 'with_netcdf4' ! ! with_go : GO module is availble. ! If this macro is not set, the required parts of GO are simulated. ! ! ! PARALLEL I/O FOR DIFFERENT NETCDF4 VERSIONS ! ! From NetCDF version 4.1 onwards it seems necessary to use a special creation mode ! named 'MPIIO' to open a file for parallel I/O : ! ! status = NF90_Create( 'test.nc', NF90_NETCDF4+NF90_MPIIO, ncid,& ! comm=MPI_COMM_WORLD, info=MPI_INFO_NULL ) ! ! The following errors are related to this creation mode: ! o In version 4.0.1, there is no parameter 'NF90_MPIIO' yet. ! o In version 4.1.2, when 'NF90_MPIIO' is not used then the first call to a ! parallel i/o routine will raise: ! "Parallel operation on file opened for non-parallel acces" ! o In version 4.1.3, when 'NF90_Create' is called with 'comm' and 'info' arguments ! but not with creation mode 'NF90_MPIIO' : ! "Invalid argument" on create if opened with comm/info but not with creation mode NF90_MPIIO ! ! To handle the 'NF90_MPIIO' behaviour correctly, the MDF module checks the NetCDF library ! version and uses hardcoded values to set the creation mode. If a version is not supported yet, ! an error message is raised and the user is suggested to add a new line to the code to support ! the new version. ! !### macro's ########################################################### ! #define TRACEBACK write (gol,'("in ",a," (",a,i6,")")') rname, __FILE__, __LINE__ ; call goErr ! #define IF_NOT_OK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if ! #define IF_NF90_NOT_OK_RETURN(action) if (status/=NF90_NOERR) then; gol=NF90_StrError(status); call goErr; TRACEBACK; action; return; end if ! ! macro's: #include "mdf.inc" ! !####################################################################### ! netcdf4_par interface includes netcdf4 ... #ifdef with_netcdf4_par #define with_netcdf4 #endif ! netcdf4 interface includes netcdf3 ... #ifdef with_netcdf4 #define with_netcdf #endif module MDF #ifdef with_go use GO, only : gol, goPr, goErr #endif #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T #endif #ifdef with_netcdf use NETCDF, only : NF90_NOERR, NF90_StrError #endif implicit none ! --- in/out --------------------------------------- private public :: MDF_Init, MDF_Done public :: MDF_Create, MDF_Open, MDF_Close public :: MDF_EndDef public :: MDF_Inquire public :: MDF_Def_Dim public :: MDF_Inq_DimID public :: MDF_Inquire_Dimension public :: MDF_Def_Var public :: MDF_Var_Par_Access public :: MDF_Inq_VarID public :: MDF_Inquire_Variable public :: MDF_Put_Var public :: MDF_Get_Var public :: MDF_Put_Att public :: MDF_Get_Att public :: MDF_Show public :: MDF_NONE public :: MDF_NEW public :: MDF_REPLACE public :: MDF_READ public :: MDF_WRITE public :: MDF_HDF4 public :: MDF_HDF5 public :: MDF_NETCDF public :: MDF_NETCDF4 public :: MDF_CHAR public :: MDF_BYTE public :: MDF_SHORT public :: MDF_INT public :: MDF_FLOAT public :: MDF_DOUBLE public :: MDF_DATATYPE_NAME public :: MDF_DEFLATE public :: MDF_INDEPENDENT, MDF_COLLECTIVE public :: MDF_GLOBAL public :: MDF_UNLIMITED ! --- const ---------------------------------------- character(len=*), parameter :: mname = 'MDF' ! ! creation modes ! integer, parameter :: MDF_NEW = 1 integer, parameter :: MDF_REPLACE = 2 integer, parameter :: MDF_READ = 3 integer, parameter :: MDF_WRITE = 4 ! integer, parameter :: MDF_CMODE_MAX = MDF_WRITE character(len=*), parameter :: MDF_CMODE_NAME(1:MDF_CMODE_MAX) = & (/ 'new ', 'replace', 'read ', 'write ' /) ! ! file types ! integer, parameter :: MDF_HDF4 = 1 integer, parameter :: MDF_HDF5 = 2 integer, parameter :: MDF_NETCDF = 3 integer, parameter :: MDF_NETCDF4 = 4 ! integer, parameter :: MDF_FILETYPE_MAX = MDF_NETCDF4 character(len=*), parameter :: MDF_FILETYPE_NAME(1:MDF_FILETYPE_MAX) = & (/ 'HDF4 ', 'HDF5 ', 'NetCDF ', 'NetCDF4' /) ! ! data types ! integer, parameter :: MDF_CHAR = 1 ! character integer, parameter :: MDF_BYTE = 2 ! integer(1) integer, parameter :: MDF_SHORT = 3 ! integer(2) integer, parameter :: MDF_INT = 4 ! integer(4) integer, parameter :: MDF_FLOAT = 5 ! real(4) integer, parameter :: MDF_DOUBLE = 6 ! real(8) ! integer, parameter :: MDF_DATATYPE_MAX = MDF_DOUBLE character(len=*), parameter :: MDF_DATATYPE_NAME(1:MDF_DATATYPE_MAX) = & (/ 'char ','byte ','short ','int ','float ', 'double' /) ! ! compression ! integer, parameter :: MDF_DEFLATE = 1 ! integer, parameter :: MDF_COMPRESSION_MAX = MDF_DEFLATE character(len=*), parameter :: MDF_COMPRESSION_NAME(1:MDF_COMPRESSION_MAX) = & (/ 'deflate' /) ! ! parallel access ! integer, parameter :: MDF_INDEPENDENT = 1 integer, parameter :: MDF_COLLECTIVE = 2 ! integer, parameter :: MDF_PARALLEL_ACCESS_MAX = MDF_INDEPENDENT character(len=*), parameter :: MDF_PARALLEL_ACCESS_NAME(1:MDF_PARALLEL_ACCESS_MAX) = & (/ 'independent' /) ! ! special parameters ! ! dummy ... integer, parameter :: MDF_NONE = -100 ! special 'variable id' to add global attributes: integer, parameter :: MDF_GLOBAL = -101 ! special dimension 'length' to denote unlimited dimension: integer, parameter :: MDF_UNLIMITED = -102 #ifdef with_hdf4 ! ! hdf4 parameters ! ! library constants constants include "hdf.f90" ! working precision of hdf library, used for handles: integer, parameter :: hdf4_wpi = 4 #endif ! ! internal ! ! maximum rank of Fortran arrays: integer, parameter :: MAX_RANK = 7 ! maximum length for variable names etc: integer, parameter :: LEN_NAME = 64 integer, parameter :: LEN_FILE = 512 integer, parameter :: LEN_LINE = 4000 ! --- types ---------------------------------------- ! interface to MDF dimension type MDF_Dim ! standard fields: character(len=LEN_NAME) :: name integer :: length logical :: unlimited logical :: named ! dimension id's #ifdef with_netcdf integer :: netcdf_dimid #endif end type MDF_Dim ! Define a structure with a pointer to the type; ! this is necessary to create a list of pointers: type P_MDF_Dim type(MDF_Dim), pointer :: p end type P_MDF_Dim ! define storage type for list with pointers: type MDF_Dim_List ! array of pointers; flexible size, increased if necessary type(P_MDF_Dim), pointer :: item(:) ! maximum number of filled items: integer :: maxitem ! actual number of filled items: integer :: nitem end type MDF_Dim_List ! interface to MDF variable type MDF_Var ! standard fields: character(len=LEN_NAME) :: name integer :: xtype integer :: xkind integer :: ndim integer :: dimids(MAX_RANK) integer :: shp(MAX_RANK) integer :: natt #ifdef with_hdf4 integer :: hdf4_sdid integer :: hdf4_xtype #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_dataset_id character(len=LEN_NAME) :: hdf5_name integer(HSIZE_T) :: hdf5_dims (MAX_RANK) integer(HSIZE_T) :: hdf5_maxdims (MAX_RANK) integer(HSIZE_T) :: hdf5_chunkdims(MAX_RANK) logical :: hdf5_chunked #endif #ifdef with_netcdf integer :: netcdf_varid #endif end type MDF_Var ! Define a structure with a pointer to the type; ! this is necessary to create a list of pointers: type P_MDF_Var type(MDF_Var), pointer :: p end type P_MDF_Var ! define storage type for list with pointers: type MDF_Var_List ! array of pointers; flexible size, increased if necessary type(P_MDF_Var), pointer :: item(:) ! maximum number of filled items: integer :: maxitem ! actual number of filled items: integer :: nitem end type MDF_Var_List ! interface to io file type MDF_File ! name of the file or basename of multiple files: character(len=LEN_FILE) :: filename ! creation mode: integer :: cmode ! parallel i/o ? logical :: parallel ! dimensions: type(MDF_Dim_List) :: Dim_List ! variables: type(MDF_Var_List) :: Var_List ! number of global attributes: integer :: natt ! file types: integer :: nftype integer :: ftypes(1:MDF_FILETYPE_MAX) ! access to file types: #ifdef with_hdf4 character(len=LEN_FILE) :: hdf4_fname integer :: hdf4_id #endif #ifdef with_hdf5_beta character(len=LEN_FILE) :: hdf5_fname integer(HID_T) :: hdf5_file_id #endif #ifdef with_netcdf character(len=LEN_FILE) :: netcdf_fname integer :: netcdf_id #endif end type MDF_File ! Define a structure with a pointer to the type; ! this is necessary to create a list of pointers: type P_MDF_File type(MDF_File), pointer :: p end type P_MDF_File ! define storage type for list with pointers: type MDF_File_List ! array of pointers; flexible size, increased if necessary type(P_MDF_File), pointer :: item(:) ! maximum number of filled items: integer :: maxitem ! actual number of filled items: integer :: nitem end type MDF_File_List ! --- interfaces ----------------------------------- interface MDF_Create module procedure MDF_Create_one module procedure MDF_Create_more end interface MDF_Create interface MDF_Put_Var module procedure MDF_Put_Var_c1_1d module procedure MDF_Put_Var_c1_2d module procedure MDF_Put_Var_c1_3d module procedure MDF_Put_Var_c1_4d module procedure MDF_Put_Var_c1_5d module procedure MDF_Put_Var_c1_6d module procedure MDF_Put_Var_c1_7d ! module procedure MDF_Put_Var_i1_1d module procedure MDF_Put_Var_i1_2d module procedure MDF_Put_Var_i1_3d module procedure MDF_Put_Var_i1_4d module procedure MDF_Put_Var_i1_5d module procedure MDF_Put_Var_i1_6d module procedure MDF_Put_Var_i1_7d ! module procedure MDF_Put_Var_i2_1d module procedure MDF_Put_Var_i2_2d module procedure MDF_Put_Var_i2_3d module procedure MDF_Put_Var_i2_4d module procedure MDF_Put_Var_i2_5d module procedure MDF_Put_Var_i2_6d module procedure MDF_Put_Var_i2_7d ! module procedure MDF_Put_Var_i4_1d module procedure MDF_Put_Var_i4_2d module procedure MDF_Put_Var_i4_3d module procedure MDF_Put_Var_i4_4d module procedure MDF_Put_Var_i4_5d module procedure MDF_Put_Var_i4_6d module procedure MDF_Put_Var_i4_7d ! module procedure MDF_Put_Var_r4_1d module procedure MDF_Put_Var_r4_2d module procedure MDF_Put_Var_r4_3d module procedure MDF_Put_Var_r4_4d module procedure MDF_Put_Var_r4_5d module procedure MDF_Put_Var_r4_6d module procedure MDF_Put_Var_r4_7d ! module procedure MDF_Put_Var_r8_1d module procedure MDF_Put_Var_r8_2d module procedure MDF_Put_Var_r8_3d module procedure MDF_Put_Var_r8_4d module procedure MDF_Put_Var_r8_5d module procedure MDF_Put_Var_r8_6d module procedure MDF_Put_Var_r8_7d end interface interface MDF_Get_Var module procedure MDF_Get_Var_c1_1d module procedure MDF_Get_Var_c1_2d module procedure MDF_Get_Var_c1_3d module procedure MDF_Get_Var_c1_4d module procedure MDF_Get_Var_c1_5d module procedure MDF_Get_Var_c1_6d module procedure MDF_Get_Var_c1_7d ! module procedure MDF_Get_Var_i1_1d module procedure MDF_Get_Var_i1_2d module procedure MDF_Get_Var_i1_3d module procedure MDF_Get_Var_i1_4d module procedure MDF_Get_Var_i1_5d module procedure MDF_Get_Var_i1_6d module procedure MDF_Get_Var_i1_7d ! module procedure MDF_Get_Var_i2_1d module procedure MDF_Get_Var_i2_2d module procedure MDF_Get_Var_i2_3d module procedure MDF_Get_Var_i2_4d module procedure MDF_Get_Var_i2_5d module procedure MDF_Get_Var_i2_6d module procedure MDF_Get_Var_i2_7d ! module procedure MDF_Get_Var_i4_1d module procedure MDF_Get_Var_i4_2d module procedure MDF_Get_Var_i4_3d module procedure MDF_Get_Var_i4_4d module procedure MDF_Get_Var_i4_5d module procedure MDF_Get_Var_i4_6d module procedure MDF_Get_Var_i4_7d ! module procedure MDF_Get_Var_r4_1d module procedure MDF_Get_Var_r4_2d module procedure MDF_Get_Var_r4_3d module procedure MDF_Get_Var_r4_4d module procedure MDF_Get_Var_r4_5d module procedure MDF_Get_Var_r4_6d module procedure MDF_Get_Var_r4_7d ! module procedure MDF_Get_Var_r8_1d module procedure MDF_Get_Var_r8_2d module procedure MDF_Get_Var_r8_3d module procedure MDF_Get_Var_r8_4d module procedure MDF_Get_Var_r8_5d module procedure MDF_Get_Var_r8_6d module procedure MDF_Get_Var_r8_7d end interface interface MDF_Put_Att module procedure MDF_Put_Att_c1_0d module procedure MDF_Put_Att_i1_0d module procedure MDF_Put_Att_i1_1d module procedure MDF_Put_Att_i2_0d module procedure MDF_Put_Att_i2_1d module procedure MDF_Put_Att_i4_0d module procedure MDF_Put_Att_i4_1d module procedure MDF_Put_Att_r4_0d module procedure MDF_Put_Att_r4_1d module procedure MDF_Put_Att_r8_0d module procedure MDF_Put_Att_r8_1d end interface interface MDF_Get_Att module procedure MDF_Get_Att_c1_0d module procedure MDF_Get_Att_i1_0d module procedure MDF_Get_Att_i1_1d module procedure MDF_Get_Att_i2_0d module procedure MDF_Get_Att_i2_1d module procedure MDF_Get_Att_i4_0d module procedure MDF_Get_Att_i4_1d module procedure MDF_Get_Att_r4_0d module procedure MDF_Get_Att_r4_1d module procedure MDF_Get_Att_r8_0d module procedure MDF_Get_Att_r8_1d end interface ! --- var ------------------------------------------ #ifndef with_go ! message line: character(len=1024) :: gol #endif ! define lists: type(MDF_File_List) :: File_List contains #ifndef with_go ! ******************************************************************** ! *** ! *** GO surrogate ! *** ! ******************************************************************** ! substitutes for message routines from GO modules ! display message: subroutine goPr write (*,'(a)') trim(gol) end subroutine goPr ! display error message: subroutine goErr write (*,'("ERROR - ",a)') trim(gol) end subroutine goErr ! free file unit: subroutine goGetFU( fu, status ) integer, intent(out) :: fu integer, intent(out) :: status logical :: opened fu = 456 do inquire( unit=fu, opened=opened ) if ( .not. opened ) exit fu = fu + 1 end do status = 0 end subroutine goGetFU #endif ! ******************************************************************** ! *** ! *** MDF_Dim procedures ! *** ! ******************************************************************** ! ! Initialise a list. ! subroutine MDF_Dim_List_Init( list, status ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(out) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Init' ! --- begin -------------------------------------- ! empty list: nullify( list%item ) ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_Dim_List_Init ! *** ! ! Clear list, deallocate content. ! subroutine MDF_Dim_List_Done( list, status ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(inout) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Done' ! --- local -------------------------------------- integer :: i ! --- begin -------------------------------------- ! list defined ? if ( associated(list%item) ) then ! loop over all possible indices: do i = 1, list%maxitem ! filled ? if ( associated(list%item(i)%p) ) then ! remove structure, reset to save value: deallocate( list%item(i)%p ) nullify( list%item(i)%p ) end if end do ! clear, reset to save value: deallocate( list%item ) nullify( list%item ) end if ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_Dim_List_Done ! *** ! ! Add new item to list, return id number. ! subroutine MDF_Dim_List_New_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(inout) :: list integer, intent(out) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_New_Item' ! --- local -------------------------------------- integer :: i type(P_MDF_Dim), pointer :: item_new(:) ! --- begin -------------------------------------- ! free item available ? if ( list%nitem < list%maxitem ) then ! search first empty item: hid = -1 do i = 1, list%maxitem if ( .not. associated(list%item(i)%p) ) then hid = i exit end if end do ! not found ? if ( hid < 0 ) then write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr write (gol,'(" nitem : ",i6)') list%nitem; call goErr TRACEBACK; status=1; return end if else ! allocate extra space: allocate( item_new(1:list%maxitem+100) ) ! copy old pointers: do i = 1, list%maxitem item_new(i)%p => list%item(i)%p end do ! init new pointers: do i = list%maxitem+1, size(item_new) nullify(item_new(i)%p) end do ! first empty item: hid = list%maxitem+1 ! clear old list if necessary: if ( associated(list%item) ) deallocate( list%item ) ! point to new list: list%item => item_new ! reset size counter: list%maxitem = size(list%item) ! clear: nullify( item_new ) end if ! allocate structure: allocate( list%item(hid)%p ) ! increase counter: list%nitem = list%nitem + 1 ! ok status = 0 end subroutine MDF_Dim_List_New_Item ! *** ! ! Remove item with given id from list. ! subroutine MDF_Dim_List_Clear_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(inout) :: list integer, intent(inout) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Clear_Item' ! --- local -------------------------------------- ! --- begin -------------------------------------- ! check index in list ... if ( (hid < 0) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check ... if ( .not. associated(list%item(hid)%p) ) then write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return end if ! clear structure: deallocate( list%item(hid)%p ) ! reset pointer to save value: nullify( list%item(hid)%p ) ! reset counter: list%nitem = list%nitem - 1 ! ok status = 0 end subroutine MDF_Dim_List_Clear_Item ! *** ! ! Return pointer to user type given id. ! Status -1 if id is not in use. ! subroutine MDF_Dim_List_Get_Pointer( list, hid, p, status, silent ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(inout) :: list integer, intent(in) :: hid type(MDF_Dim), pointer :: p integer, intent(out) :: status logical, intent(in), optional :: silent ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Get_Pointer' ! --- local -------------------------------------- logical :: shout ! --- begin -------------------------------------- ! messages ? shout = .true. if ( present(silent) ) shout = .not. silent ! check index in list ... if ( (hid < 1) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check if handle is in use ... if ( .not. associated(list%item(hid)%p) ) then ! error or warning ? if ( shout ) then ! error status: write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return else ! warning status; this routine is used to test if a handle is in use: nullify( p ) status = -1 ; return end if end if ! set shorthand: p => list%item(hid)%p ! ok status = 0 end subroutine MDF_Dim_List_Get_Pointer ! *** ! ! Return information: ! n ! Number of elements in use. ! maxid ! Current possible upper value for id's. ! Not all id's in {1,..,maxid} are in use. ! Usefull to implement a loop over all possible items. ! subroutine MDF_Dim_List_Inquire( list, status, & n, maxid ) ! --- in/out ------------------------------------- type(MDF_Dim_List), intent(inout) :: list integer, intent(out) :: status integer, intent(out), optional :: n integer, intent(out), optional :: maxid ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Dim_List_Inquire' ! --- begin -------------------------------------- ! set values ? if ( present(n ) ) n = list%nitem if ( present(maxid) ) maxid = list%maxitem ! ok status = 0 end subroutine MDF_Dim_List_Inquire ! ******************************************************************** ! *** ! *** MDF_Var procedures ! *** ! ******************************************************************** ! ! Initialise a list. ! subroutine MDF_Var_List_Init( list, status ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(out) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_Init' ! --- begin -------------------------------------- ! empty list: nullify( list%item ) ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_Var_List_Init ! *** ! ! Clear list, deallocate content. ! subroutine MDF_Var_List_Done( list, status ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(inout) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_Done' ! --- local -------------------------------------- integer :: i ! --- begin -------------------------------------- ! list defined ? if ( associated(list%item) ) then ! loop over all possible indices: do i = 1, list%maxitem ! filled ? if ( associated(list%item(i)%p) ) then ! remove structure, reset to save value: deallocate( list%item(i)%p ) nullify( list%item(i)%p ) end if end do ! clear, reset to save value: deallocate( list%item ) nullify( list%item ) end if ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_Var_List_Done ! *** ! ! Add new item to list, return id number. ! subroutine MDF_Var_List_New_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(inout) :: list integer, intent(out) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_New_Item' ! --- local -------------------------------------- integer :: i type(P_MDF_Var), pointer :: item_new(:) ! --- begin -------------------------------------- ! free item available ? if ( list%nitem < list%maxitem ) then ! search first empty item: hid = -1 do i = 1, list%maxitem if ( .not. associated(list%item(i)%p) ) then hid = i exit end if end do ! not found ? if ( hid < 0 ) then write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr write (gol,'(" nitem : ",i6)') list%nitem; call goErr TRACEBACK; status=1; return end if else ! allocate extra space: allocate( item_new(1:list%maxitem+100) ) ! copy old pointers: do i = 1, list%maxitem item_new(i)%p => list%item(i)%p end do ! init new pointers: do i = list%maxitem+1, size(item_new) nullify(item_new(i)%p) end do ! first empty item: hid = list%maxitem+1 ! clear old list if necessary: if ( associated(list%item) ) deallocate( list%item ) ! point to new list: list%item => item_new ! reset size counter: list%maxitem = size(list%item) ! clear: nullify( item_new ) end if ! allocate structure: allocate( list%item(hid)%p ) ! increase counter: list%nitem = list%nitem + 1 ! ok status = 0 end subroutine MDF_Var_List_New_Item ! *** ! ! Remove item with given id from list. ! subroutine MDF_Var_List_Clear_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(inout) :: list integer, intent(inout) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_Clear_Item' ! --- local -------------------------------------- ! --- begin -------------------------------------- ! check index in list ... if ( (hid < 0) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check ... if ( .not. associated(list%item(hid)%p) ) then write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return end if ! clear structure: deallocate( list%item(hid)%p ) ! reset pointer to save value: nullify( list%item(hid)%p ) ! reset counter: list%nitem = list%nitem - 1 ! ok status = 0 end subroutine MDF_Var_List_Clear_Item ! *** ! ! Return pointer to user type given id. ! Status -1 if id is not in use. ! subroutine MDF_Var_List_Get_Pointer( list, hid, p, status, silent ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(inout) :: list integer, intent(in) :: hid type(MDF_Var), pointer :: p integer, intent(out) :: status logical, intent(in), optional :: silent ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_Get_Pointer' ! --- local -------------------------------------- logical :: shout ! --- begin -------------------------------------- ! messages ? shout = .true. if ( present(silent) ) shout = .not. silent ! check index in list ... if ( (hid < 1) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check if handle is in use ... if ( .not. associated(list%item(hid)%p) ) then ! error or warning ? if ( shout ) then ! error status: write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return else ! warning status; this routine is used to test if a handle is in use: nullify( p ) status = -1 ; return end if end if ! set shorthand: p => list%item(hid)%p ! ok status = 0 end subroutine MDF_Var_List_Get_Pointer ! *** ! ! Return information: ! n ! Number of elements in use. ! maxid ! Current possible upper value for id's. ! Not all id's in {1,..,maxid} are in use. ! Usefull to implement a loop over all possible items. ! subroutine MDF_Var_List_Inquire( list, status, & n, maxid ) ! --- in/out ------------------------------------- type(MDF_Var_List), intent(inout) :: list integer, intent(out) :: status integer, intent(out), optional :: n integer, intent(out), optional :: maxid ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Var_List_Inquire' ! --- begin -------------------------------------- ! set values ? if ( present(n ) ) n = list%nitem if ( present(maxid) ) maxid = list%maxitem ! ok status = 0 end subroutine MDF_Var_List_Inquire ! ******************************************************************** ! *** ! *** MDF procedures ! *** ! ******************************************************************** ! ! Initialise a list. ! subroutine MDF_File_List_Init( list, status ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(out) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_Init' ! --- begin -------------------------------------- ! empty list: nullify( list%item ) ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_File_List_Init ! *** ! ! Clear list, deallocate content. ! subroutine MDF_File_List_Done( list, status ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(inout) :: list integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_Done' ! --- local -------------------------------------- integer :: i ! --- begin -------------------------------------- ! list defined ? if ( associated(list%item) ) then ! loop over all possible indices: do i = 1, list%maxitem ! filled ? if ( associated(list%item(i)%p) ) then ! remove structure, reset to save value: deallocate( list%item(i)%p ) nullify( list%item(i)%p ) end if end do ! clear, reset to save value: deallocate( list%item ) nullify( list%item ) end if ! set counters: list%maxitem = 0 list%nitem = 0 ! ok status = 0 end subroutine MDF_File_List_Done ! *** ! ! Add new item to list, return id number. ! subroutine MDF_File_List_New_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(inout) :: list integer, intent(out) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_New_Item' ! --- local -------------------------------------- integer :: i type(P_MDF_File), pointer :: item_new(:) ! --- begin -------------------------------------- ! free item available ? if ( list%nitem < list%maxitem ) then ! search first empty item: hid = -1 do i = 1, list%maxitem if ( .not. associated(list%item(i)%p) ) then hid = i exit end if end do ! not found ? if ( hid < 0 ) then write (gol,'("all items seem to be associated while counters suggest something else ...")'); call goErr write (gol,'(" maxitem : ",i6)') list%maxitem; call goErr write (gol,'(" nitem : ",i6)') list%nitem; call goErr TRACEBACK; status=1; return end if else ! allocate extra space: allocate( item_new(1:list%maxitem+100) ) ! copy old pointers: do i = 1, list%maxitem item_new(i)%p => list%item(i)%p end do ! init new pointers: do i = list%maxitem+1, size(item_new) nullify(item_new(i)%p) end do ! first empty item: hid = list%maxitem+1 ! clear old list if necessary: if ( associated(list%item) ) deallocate( list%item ) ! point to new list: list%item => item_new ! reset size counter: list%maxitem = size(list%item) ! clear: nullify( item_new ) end if ! allocate structure: allocate( list%item(hid)%p ) ! increase counter: list%nitem = list%nitem + 1 ! ok status = 0 end subroutine MDF_File_List_New_Item ! *** ! ! Remove item with given id from list. ! subroutine MDF_File_List_Clear_Item( list, hid, status ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(inout) :: list integer, intent(inout) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_Clear_Item' ! --- local -------------------------------------- ! --- begin -------------------------------------- ! check index in list ... if ( (hid < 0) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check ... if ( .not. associated(list%item(hid)%p) ) then write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return end if ! clear structure: deallocate( list%item(hid)%p ) ! reset pointer to save value: nullify( list%item(hid)%p ) ! reset counter: list%nitem = list%nitem - 1 ! ok status = 0 end subroutine MDF_File_List_Clear_Item ! *** ! ! Return pointer to user type given id. ! Status -1 if id is not in use. ! subroutine MDF_File_List_Get_Pointer( list, hid, p, status, silent ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(inout) :: list integer, intent(in) :: hid type(MDF_File), pointer :: p integer, intent(out) :: status logical, intent(in), optional :: silent ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_Get_Pointer' ! --- local -------------------------------------- logical :: shout ! --- begin -------------------------------------- ! messages ? shout = .true. if ( present(silent) ) shout = .not. silent ! check index in list ... if ( (hid < 1) .or. (hid > list%maxitem) ) then write (gol,'("handle outside range:")'); call goErr write (gol,'(" handle : ",i6)') hid; call goErr write (gol,'(" range : ",2i6)') 1, list%maxitem; call goErr TRACEBACK; status=1; return end if ! check if handle is in use ... if ( .not. associated(list%item(hid)%p) ) then ! error or warning ? if ( shout ) then ! error status: write (gol,'("handle not in use: ",i6)') hid; call goErr TRACEBACK; status=1; return else ! warning status; this routine is used to test if a handle is in use: nullify( p ) status = -1 ; return end if end if ! set shorthand: p => list%item(hid)%p ! ok status = 0 end subroutine MDF_File_List_Get_Pointer ! *** ! ! Return information: ! n ! Number of elements in use. ! maxid ! Current possible upper value for id's. ! Not all id's in {1,..,maxid} are in use. ! Usefull to implement a loop over all possible items. ! subroutine MDF_File_List_Inquire( list, status, & n, maxid ) ! --- in/out ------------------------------------- type(MDF_File_List), intent(inout) :: list integer, intent(out) :: status integer, intent(out), optional :: n integer, intent(out), optional :: maxid ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_File_List_Inquire' ! --- begin -------------------------------------- ! set values ? if ( present(n ) ) n = list%nitem if ( present(maxid) ) maxid = list%maxitem ! ok status = 0 end subroutine MDF_File_List_Inquire ! ******************************************************************** ! *** ! *** tools ! *** ! ******************************************************************** subroutine MDF_Get_Kind( xtype, xkind, status ) ! --- in/out ------------------------------------- integer, intent(in) :: xtype integer, intent(out) :: xkind integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Kind' ! --- begin -------------------------------------- ! set kind value given type: select case ( xtype ) case ( MDF_CHAR ) ; xkind = 1 case ( MDF_BYTE ) ; xkind = 1 case ( MDF_SHORT ) ; xkind = 2 case ( MDF_INT ) ; xkind = 4 case ( MDF_FLOAT ) ; xkind = 4 case ( MDF_DOUBLE ) ; xkind = 8 case default write (gol,'("do not know kind for variable type : ",i6)') xtype; call goPr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Kind ! *** #ifdef with_hdf5_beta subroutine HDF5_Get_MDF_Type( hdf5_type_id, mdf_type, status ) use HDF5, only : HID_T use HDF5, only : H5TGet_Class_f, H5TGet_Size_f, H5TClose_f use HDF5, only : H5T_STRING_F, H5T_INTEGER_F, H5T_FLOAT_F ! --- in/out ------------------------------------- integer(HID_T), intent(in) :: hdf5_type_id integer, intent(out) :: mdf_type integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/HDF5_Get_MDF_Type' ! --- local -------------------------------------- integer :: hdf5_typeclass, hdf5_typesize ! --- begin -------------------------------------- ! get class: call H5TGet_Class_f( hdf5_type_id, hdf5_typeclass, status ) IF_NOT_OK_RETURN(status=1) ! split: if ( hdf5_typeclass == H5T_STRING_F ) then mdf_type = MDF_CHAR else if ( hdf5_typeclass == H5T_INTEGER_F ) then call H5TGet_Size_f( hdf5_type_id, hdf5_typesize, status ) IF_NOT_OK_RETURN(status=1) select case ( hdf5_typesize ) case ( 1 ) ; mdf_type = MDF_BYTE case ( 2 ) ; mdf_type = MDF_SHORT case ( 4 ) ; mdf_type = MDF_INT case default write (gol,'("unsupported hdf5 type integer class size : ",i6)') hdf5_typesize; call goErr TRACEBACK; status=1; return end select else if ( hdf5_typeclass == H5T_FLOAT_F ) then call H5TGet_Size_f( hdf5_type_id, hdf5_typesize, status ) IF_NOT_OK_RETURN(status=1) select case ( hdf5_typesize ) case ( 4 ) ; mdf_type = MDF_FLOAT case ( 8 ) ; mdf_type = MDF_DOUBLE case default write (gol,'("unsupported hdf5 type float class size : ",i6)') hdf5_typesize; call goErr TRACEBACK; status=1; return end select else write (gol,'("unsupported hdf5 type class : ",i6)') hdf5_typeclass; call goErr TRACEBACK; status=1; return end if ! ok status = 0 end subroutine HDF5_Get_MDF_Type #endif #ifdef with_netcdf subroutine NetCDF_Get_FileType( fname, ncformat, status ) use NetCDF, only : NF90_Open, NF90_Close, NF90_Inquire use NetCDF, only : NF90_NOWRITE use NetCDF, only : NF90_FORMAT_CLASSIC, NF90_FORMAT_64BIT, NF90_FORMAT_NETCDF4, NF90_FORMAT_NETCDF4_CLASSIC ! --- in/out --------------------------------- character(len=*), intent(in) :: fname character(len=*), intent(out) :: ncformat integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/NetCDF_Get_FileType' ! --- local ---------------------------------- logical :: exist integer :: ncid integer :: formatNum ! --- begin ---------------------------------- ! check ... inquire( file=trim(fname), exist=exist ) if ( .not. exist ) then write (gol,'("file to be opened not found : ",a)') trim(fname); call goErr TRACEBACK; status=1; return end if ! open file for reading: status = NF90_Open( trim(fname), NF90_NOWRITE, ncid ) IF_NF90_NOT_OK_RETURN(status=1) ! get format number: status = NF90_Inquire( ncid, formatNum=formatNum ) IF_NF90_NOT_OK_RETURN(status=1) ! translate ... select case ( formatNum ) case ( NF90_FORMAT_CLASSIC ) ; ncformat = 'netcdf_classic' case ( NF90_FORMAT_64BIT ) ; ncformat = 'netcdf_64bit' case ( NF90_FORMAT_NETCDF4 ) ; ncformat = 'netcdf4' case ( NF90_FORMAT_NETCDF4_CLASSIC ) ; ncformat = 'netcdf4_classic' case default ; ncformat = 'netcdf_unknown' end select ! close file: status = NF90_Close( ncid ) IF_NF90_NOT_OK_RETURN(status=1) ! ok status = 0 end subroutine NetCDF_Get_FileType #endif ! ******************************************************************** ! *** ! *** module init/done ! *** ! ******************************************************************** subroutine MDF_Init( status, loglevel ) #ifdef with_hdf5_beta use HDF5, only : H5Open_f #endif ! --- in/out ------------------------------------- integer, intent(out) :: status integer, intent(in), optional :: loglevel ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Init' ! --- local -------------------------------------- integer :: loglev ! --- begin -------------------------------------- ! log level ... loglev = 0 ! no messages if ( present(loglevel) ) loglev = loglevel ! info ... if (loglev>0) then; write (gol,'("initialize MDF module ...")'); call goPr; end if #ifdef with_hdf4 ! info ... if (loglev>0) then; write (gol,'(" HDF4 interface enabled ...")'); call goPr; end if #else ! info ... if (loglev>0) then; write (gol,'(" HDF4 interface disabled ...")'); call goPr; end if #endif #ifdef with_hdf5_beta ! initialize Fortran interface: call H5Open_f( status ) IF_NOT_OK_RETURN(status=1) ! info ... if (loglev>0) then; write (gol,'(" HDF5 interface enabled ...")'); call goPr; end if #endif #ifdef with_netcdf ! info ... if (loglev>0) then; write (gol,'(" NetCDF interface enabled ...")'); call goPr; end if #ifdef with_netcdf4 if (loglev>0) then; write (gol,'(" NetCDF4 interface enabled ...")'); call goPr; end if #else if (loglev>0) then; write (gol,'(" NetCDF4 interface disabled ...")'); call goPr; end if #endif #else ! info ... if (loglev>0) then; write (gol,'(" NetCDF interface disabled ...")'); call goPr; end if #endif ! setup empty list: call MDF_File_List_Init( File_List, status ) IF_NOT_OK_RETURN(status=1) ! ok status = 0 end subroutine MDF_Init ! *** subroutine MDF_Done( status ) #ifdef with_hdf5_beta use HDF5, only : H5Close_f #endif ! --- in/out ------------------------------------- integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Done' ! --- local -------------------------------------- integer :: maxid integer :: id type(MDF_File), pointer :: filep integer :: nerror ! --- begin -------------------------------------- ! no errors yet ... nerror = 0 ! get maximum id number: call MDF_File_List_Inquire( File_List, status, maxid=maxid ) IF_NOT_OK_RETURN(status=1) ! loop over all possible id's: do id = 1, maxid ! get pointer to file structure; status -1 if not in use: call MDF_File_List_Get_Pointer( File_List, id, filep, status, silent=.true. ) if ( status == -1 ) cycle IF_NOT_OK_RETURN(status=1) ! error ... write (gol,'("Called MDF_Done but file still in use: ",a)') trim(filep%filename); call goErr nerror = nerror + 1 !! done with variables: !call MDF_Var_List_Done( filep%Var_List, status ) !IF_NOT_OK_RETURN(status=1) !! done with dimensions: !call MDF_Dim_List_Done( filep%Dim_List, status ) !IF_NOT_OK_RETURN(status=1) end do ! clear list: call MDF_File_List_Done( File_List, status ) IF_NOT_OK_RETURN(status=1) #ifdef with_hdf5_beta ! done with Fortran interface: call H5Close_f( status ) IF_NOT_OK_RETURN(status=1) #endif ! ok status = nerror end subroutine MDF_Done ! ******************************************************************** ! *** ! *** file create/close ! *** ! ******************************************************************** subroutine MDF_Create_one( filename, ftype, cmode, hid, status, mpi_comm, mpi_info ) ! --- in/out ------------------------------------- character(len=*), intent(in) :: filename integer, intent(in) :: ftype integer, intent(in) :: cmode integer, intent(out) :: hid integer, intent(out) :: status integer, intent(in), optional :: mpi_comm integer, intent(in), optional :: mpi_info ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Create_one' ! --- local -------------------------------------- ! --- begin -------------------------------------- ! special case of more than one .... call MDF_Create_more( filename, (/''/), (/ftype/), cmode, hid, status, & mpi_comm, mpi_info ) IF_NOT_OK_RETURN(status=1) ! ok status = 0 end subroutine MDF_Create_one ! *** subroutine MDF_Create_more( basename, exts, ftypes, cmode, hid, status, & mpi_comm, mpi_info ) #ifdef with_hdf5_beta use HDF5, only : H5F_ACC_EXCL_F, H5F_ACC_TRUNC_F use HDF5, only : H5FCreate_f #endif #ifdef with_netcdf use NetCDF, only : NF90_CLOBBER, NF90_NOCLOBBER use NetCDF, only : NF90_Create #ifdef with_netcdf4 use NetCDF, only : NF90_CLASSIC_MODEL, NF90_NETCDF4 use NetCDF, only : NF90_Inq_LibVers ! This parameter does not exist for library versions prior to 4.1 ; ! only enable for testing it's value in your version to hardcode ! the correct creation mode for parallel i/o : !use NetCDF, only : NF90_MPIIO #endif #endif ! --- in/out ------------------------------------- character(len=*), intent(in) :: basename character(len=*), intent(in) :: exts(:) integer, intent(in) :: ftypes(:) integer, intent(in) :: cmode integer, intent(out) :: hid integer, intent(out) :: status integer, intent(in), optional :: mpi_comm integer, intent(in), optional :: mpi_info ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Create_more' ! --- external ---------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfStart #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_amode #endif #ifdef with_hdf5_beta integer :: hdf5_amode #endif #ifdef with_netcdf integer :: netcdf_cmode character(len=80) :: netcdf_version #endif ! --- begin -------------------------------------- ! new file: call MDF_File_List_New_Item( File_List, hid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! store filename stuff: filep%filename = trim(basename) ! store creation mode: filep%cmode = cmode ! parallel i/o ? filep%parallel = present(mpi_comm) .or. present(mpi_info) ! check ... if ( filep%parallel ) then if ( .not. all((/present(mpi_comm),present(mpi_info)/)) ) then write (gol,'("Only one of the arguments `mpi_comm` or `mpi_info` provided, that is not enough!")'); call goErr TRACEBACK; status=1; return end if end if ! check ... if ( size(exts) /= size(ftypes) ) then write (gol,'("number of specified extensions should equal number of specfied file types:")'); call goErr write (gol,'(" number of specified extensions : ",i6)') size(exts); call goErr write (gol,'(" number of specified file types : ",i6)') size(ftypes); call goErr TRACEBACK; status=1; return end if ! check ... if ( size(ftypes) > MDF_FILETYPE_MAX ) then write (gol,'("more file types specified than supported")'); call goErr write (gol,'(" maximum number : ",i6)') MDF_FILETYPE_MAX; call goErr write (gol,'(" specified : ",i6)') size(ftypes); call goErr TRACEBACK; status=1; return end if ! store file types: filep%nftype = size(ftypes) filep%ftypes(1:filep%nftype) = ftypes ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( filep%parallel ) then write (gol,'("HDF4 files could not be created in parallel")'); call goErr TRACEBACK; status=1; return end if ! full file name: filep%hdf4_fname = trim(filep%filename)//trim(exts(iftype)) ! write to an new file (remove if exist) hdf4_amode = DFACC_CREATE ! open file: filep%hdf4_id = sfStart( trim(filep%hdf4_fname), hdf4_amode ) if ( filep%hdf4_id == FAIL ) then write (gol,'("from creating hdf4 file:")'); call goErr write (gol,'(" ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" does directory exist ?")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( filep%parallel ) then write (gol,'("MDF/HDF5 not implemented for parallel creation yet")'); call goErr TRACEBACK; status=1; return end if ! full file name: filep%hdf5_fname = trim(filep%filename)//trim(exts(iftype)) ! initial access mode: hdf5_amode = 0 ! set access mode: select case ( cmode ) case ( MDF_NEW ) hdf5_amode = hdf5_amode + H5F_ACC_EXCL_F ! complain if already present case ( MDF_REPLACE ) hdf5_amode = hdf5_amode + H5F_ACC_TRUNC_F ! overwrite if necessary case default write (gol,'("unsupported creation mode : ",i6)') cmode; call goErr TRACEBACK; status=1; return end select ! open file: call H5FCreate_f( trim(filep%hdf5_fname), hdf5_amode, filep%hdf5_file_id, status ) if (status/=0) then write (gol,'("from creating hdf5 file:")'); call goErr write (gol,'(" ",a)') trim(filep%hdf5_fname); call goErr write (gol,'(" does directory exist ?")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! full file name: filep%netcdf_fname = trim(filep%filename)//trim(exts(iftype)) ! initial creation mode: netcdf_cmode = 0 ! set creation mode: select case ( cmode ) case ( MDF_NEW ) netcdf_cmode = netcdf_cmode + NF90_NOCLOBBER ! complain if already present case ( MDF_REPLACE ) netcdf_cmode = netcdf_cmode + NF90_CLOBBER ! overwrite if necessary case default write (gol,'("unsupported creation mode : ",i6)') cmode; call goErr TRACEBACK; status=1; return end select ! latest format ? #ifdef with_netcdf4 if ( ftype == MDF_NETCDF4 ) then !netcdf_cmode = netcdf_cmode + NF90_HDF5 netcdf_cmode = netcdf_cmode + NF90_NETCDF4 else netcdf_cmode = netcdf_cmode + NF90_CLASSIC_MODEL end if #else if ( ftype == MDF_NETCDF4 ) then write (gol,'("could not write NetCDF-4 file without `with_netcdf4` defined ...")'); call goErr TRACEBACK; status=1; return end if #endif ! create in parallel ? if ( filep%parallel ) then ! check ... if ( ftype /= MDF_NETCDF4 ) then write (gol,'("Creation of NetCDF file in parallel requires NETCDF4 file type.")'); call goErr TRACEBACK; status=1; return end if #ifdef with_netcdf4_par ! Creation mode MPIIO is needed for parallel i/o for NetCDF library 4.1 onwards. ! But since the parameter is not available for older versions, it can not used ! permantently to avoid errors about undevined variables. ! Instead, the value of MPIIO is hardcoded here for a number of library versions; ! please extend for your version if the error traceback has brought you here. ! First get library version: netcdf_version = trim(NF90_Inq_LibVers()) ! switch: if ( (netcdf_version(1:5) == '4.0.1') ) then ! no NF90_MPIIO needed for this version ... else if ( (netcdf_version(1:5) == '4.1.1') .or. & (netcdf_version(1:5) == '4.1.2') .or. & (netcdf_version(1:5) == '4.1.3') .or. & (netcdf_version(1:3) == '4.2' ) ) then ! add value of NF90_MPIIO to creation mode: netcdf_cmode = netcdf_cmode + 8192 !else if ( netcdf_version(1:3) == '4.x' ) then ! ! show value ; need to uncomment the 'use' statement in the top of this routine: ! write (gol,'("Value of NF90_MPIIO : ",i6)') NF90_MPIIO; call goErr ! ! add value of NF90_MPIIO to creation mode: ! netcdf_cmode = netcdf_cmode + 0 else write (gol,'("Please implement NF90_MPIIO behaviour for your NetCDF library version:")'); call goErr write (gol,'(" ",a)') trim(netcdf_version); call goErr TRACEBACK; status=1; return end if ! create file, provide communicator and info: status = NF90_Create( trim(filep%netcdf_fname), netcdf_cmode, filep%netcdf_id, & comm=mpi_comm, info=mpi_info ) if (status/=NF90_NOERR) then gol = trim(NF90_StrError(status)); call goErr write (gol,'("from creating netcdf4 file :")'); call goErr write (gol,'(" ",a)') trim(filep%netcdf_fname); call goErr write (gol,'(" does directory exist ?")'); call goErr TRACEBACK; status=1; return end if #else write (gol,'("Parallel creation of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr TRACEBACK; status=1; return #endif else ! create file: status = NF90_Create( trim(filep%netcdf_fname), netcdf_cmode, filep%netcdf_id ) if (status/=NF90_NOERR) then gol = trim(NF90_StrError(status)); call goErr write (gol,'("from creating netcdf4 file :")'); call goErr write (gol,'(" ",a)') trim(filep%netcdf_fname); call goErr write (gol,'(" ",a)') netcdf_cmode; call goErr write (gol,'(" does directory exist ?")'); call goErr TRACEBACK; status=1; return end if end if #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! init dimension list: call MDF_Dim_List_Init( filep%Dim_List, status ) IF_NOT_OK_RETURN(status=1) ! init variable list: call MDF_Var_List_Init( filep%Var_List, status ) IF_NOT_OK_RETURN(status=1) ! no global attributes yet: filep%natt = 0 ! ok status = 0 end subroutine MDF_Create_more ! *** subroutine MDF_Open( filename, ftype, mode, hid, status, & mpi_comm, mpi_info ) #ifdef with_hdf5_beta use HDF5, only : SIZE_T, HSIZE_T use HDF5, only : H5FOpen_f use HDF5, only : H5F_ACC_RDONLY_F use HDF5, only : H5AGet_Num_Attrs_f use HDF5, only : H5GOpen_f, H5GClose_f, H5GN_Members_f, H5GGet_Obj_Info_Idx_f use HDF5, only : H5G_DATASET_F, H5G_LINK_F, H5G_GROUP_F, H5G_TYPE_F use HDF5, only : H5DOpen_f, H5DGet_Type_f, H5DGet_Space_f use HDF5, only : H5TClose_f use HDF5, only : H5SClose_f, H5SGet_Simple_Extent_Dims_f use HDF5, only : H5S_UNLIMITED_F #endif #ifdef with_netcdf use NetCDF, only : NF90_WRITE, NF90_NOWRITE use NetCDF, only : NF90_Open use NetCDF, only : NF90_Inquire use NetCDF, only : NF90_Inquire_Dimension use NetCDF, only : NF90_Inquire_Variable use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE #ifdef with_netcdf4_par use NetCDF, only : NF90_Open_Par,NF90_Inq_LibVers #endif #endif ! --- in/out ------------------------------------- character(len=*), intent(in) :: filename integer, intent(in) :: ftype integer, intent(in) :: mode integer, intent(out) :: hid integer, intent(out) :: status integer, intent(in), optional :: mpi_comm integer, intent(in), optional :: mpi_info ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Open' ! --- external ---------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfStart integer(hdf4_wpi), external :: sfFInfo integer(hdf4_wpi), external :: sfGInfo integer(hdf4_wpi), external :: sfGDInfo integer(hdf4_wpi), external :: sfSelect integer(hdf4_wpi), external :: sfDimID #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Dim), pointer :: dimp type(MDF_Var), pointer :: varp logical :: exist #ifdef with_hdf4 integer :: hdf4_amode integer :: hdf4_varind integer :: hdf4_xtype integer :: hdf4_dimind integer :: hdf4_dimid #endif #ifdef with_hdf5_beta integer :: hdf5_amode integer(HID_T) :: hdf5_grp_id character(len=LEN_NAME) :: hdf5_obj_name integer :: hdf5_obj_type integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_space_id character(len=6) :: snr #endif #ifdef with_netcdf integer :: netcdf_mode integer :: netcdf_xtype integer :: unlimid #endif integer :: ndim, idim, dimid integer :: nvar, ivar, varid integer :: natt character(len=LEN_NAME) :: name integer :: length integer :: dimids(MAX_RANK) integer :: shp(MAX_RANK) integer :: k, n character(len=80) :: netcdf_version ! --- begin -------------------------------------- ! new file: call MDF_File_List_New_Item( File_List, hid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! init dimension list: call MDF_Dim_List_Init( filep%Dim_List, status ) IF_NOT_OK_RETURN(status=1) ! init variable list: call MDF_Var_List_Init( filep%Var_List, status ) IF_NOT_OK_RETURN(status=1) ! store filename stuff: filep%filename = trim(filename) ! store dummy creation mode: filep%cmode = -1 ! parallel i/o ? filep%parallel = present(mpi_comm) .or. present(mpi_info) ! check ... if ( filep%parallel ) then if ( .not. all((/present(mpi_comm),present(mpi_info)/)) ) then write (gol,'("Only one of the arguments `mpi_comm` or `mpi_info` provided, that is not enough!")'); call goErr TRACEBACK; status=1; return end if end if ! store file type: filep%nftype = 1 filep%ftypes(1) = ftype ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( filep%parallel ) then write (gol,'("HDF4 files could not be opened in parallel")'); call goErr TRACEBACK; status=1; return end if ! full file name: filep%hdf4_fname = trim(filep%filename) ! check ... inquire( file=trim(filep%hdf4_fname), exist=exist ) if ( .not. exist ) then write (gol,'("file to be opened not found : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! set access mode: select case ( mode ) case ( MDF_READ ) hdf4_amode = DFACC_READ case ( MDF_WRITE ) hdf4_amode = DFACC_WRITE case default write (gol,'("unsupported open mode : ",i6)') mode; call goErr TRACEBACK; status=1; return end select ! open file: filep%hdf4_id = sfStart( trim(filep%hdf4_fname), hdf4_amode ) if ( filep%hdf4_id == FAIL ) then write (gol,'("from starting access to hdf file:")'); call goErr write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" access mode : CREATE")'); call goErr TRACEBACK; status=1; return end if ! get number of data sets and number of global attributes: status = sfFInfo( filep%hdf4_id, nvar, filep%natt ) if ( status == FAIL ) then write (gol,'("from sfFInfo :")'); call goErr write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! loop over variables: do ivar = 1, nvar ! new variable: call MDF_Var_List_New_Item( filep%Var_List, varid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! hdf variable index in 0,..,nvar-1 hdf4_varind = ivar - 1 ! get variable id: varp%hdf4_sdid = sfSelect( filep%hdf4_id, hdf4_varind ) if ( varp%hdf4_sdid == FAIL ) then write (gol,'("unable to locate data set with index ",i6)') hdf4_varind; call goErr write (gol,'(" hdf file name : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! get info: status = sfGInfo( varp%hdf4_sdid, name, ndim, shp, varp%hdf4_xtype, varp%natt ) if ( status /= SUCCEED ) then write (gol,'("getting info")'); call goErr TRACEBACK; status=1; return end if ! store name: varp%name = trim(name) ! convert type: select case ( varp%hdf4_xtype ) case ( DFNT_CHAR ) ; varp%xtype = MDF_CHAR case ( DFNT_INT8 ) ; varp%xtype = MDF_BYTE case ( DFNT_INT16 ) ; varp%xtype = MDF_SHORT case ( DFNT_INT32 ) ; varp%xtype = MDF_INT case ( DFNT_FLOAT32 ) ; varp%xtype = MDF_FLOAT case ( DFNT_FLOAT64 ) ; varp%xtype = MDF_DOUBLE case default write (gol,'("unsupported data type : ",i6)') varp%hdf4_xtype; call goErr TRACEBACK; status=1; return end select ! set kind given type: call MDF_Get_Kind( varp%xtype, varp%xkind, status ) IF_NOT_OK_RETURN(status=1) ! store number of dimensions: varp%ndim = ndim ! init arrays: varp%dimids = -1 varp%shp = -1 ! loop over dimensions: do idim = 1, ndim ! hdf4 dimension index in 0,..,ndim-1 hdf4_dimind = idim - 1 ! get hdf4 dimension id: hdf4_dimid = sfDimID( varp%hdf4_sdid, hdf4_dimind ) if ( hdf4_dimid == FAIL ) then write (gol,'("error selecting dimension id :")'); call goErr write (gol,'(" index : ",i6)') hdf4_dimind; call goErr write (gol,'(" variable name : ",a)') trim(varp%name); call goErr write (gol,'(" hdf name : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! extract dimension info; ! data type is only usefull if a 'scale' is assigned to the dimension ! length might be SD_UNLIMITED, so use shp from sfGInfo for actual length status = sfGDInfo( hdf4_dimid, name, length, hdf4_xtype, natt ) if ( hdf4_dimid == FAIL ) then write (gol,'("error getting dimension info :")'); call goErr write (gol,'(" index : ",i6)') hdf4_dimind; call goErr write (gol,'(" variable name : ",a)') trim(varp%name); call goErr write (gol,'(" hdf name : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! check if dimension is already defined ...; ! current number of defined dimensions: call MDF_Dim_List_Inquire( filep%Dim_List, status, n=n ) IF_NOT_OK_RETURN(status=1) ! loop over current dimensions: dimid = -1 do k = 1, n ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, k, dimp, status ) IF_NOT_OK_RETURN(status=1) ! compare: if ( trim(dimp%name) == trim(name) ) then ! check ... if ( dimp%length /= shp(idim) ) then write (gol,'("length of dimension is different from previous defined length:")'); call goErr write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" variable name : ",a)') trim(varp%name); call goErr write (gol,'(" dimension name : ",a)') trim(name); call goErr write (gol,'(" length : ",i6)') shp(idim); call goErr write (gol,'(" defined length : ",i6)') dimp%length; call goErr TRACEBACK; status=1; return end if ! ok; stop searching: dimid = k exit end if end do ! not found ? then new dimension should be defined: if ( dimid < 0 ) then ! new dimension: call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! fill mdf dimension info: dimp%named = name(1:7) /= 'fakeDim' dimp%name = trim(name) dimp%unlimited = length == SD_UNLIMITED dimp%length = shp(idim) ! shp extraced via sfGInfo end if ! fill variable dimension info: varp%dimids(idim) = dimid varp%shp (idim) = dimp%length end do ! dimensions end do ! variables #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( filep%parallel ) then write (gol,'("MDF/HDF5 not implemented for parallel open yet")'); call goErr TRACEBACK; status=1; return end if ! full file name: filep%hdf5_fname = trim(filep%filename) ! check ... inquire( file=trim(filep%hdf5_fname), exist=exist ) if ( .not. exist ) then write (gol,'("file to be opened not found : ",a)') trim(filep%hdf5_fname); call goErr TRACEBACK; status=1; return end if ! set access mode: select case ( mode ) case ( MDF_READ ) hdf5_amode = H5F_ACC_RDONLY_F ! read-only case default write (gol,'("unsupported open mode : ",i6)') mode; call goErr TRACEBACK; status=1; return end select ! open file: call H5FOpen_f( trim(filep%hdf5_fname), hdf5_amode, filep%hdf5_file_id, status ) IF_NOT_OK_RETURN(status=1) ! get number of global attributes: call H5AGet_Num_Attrs_f( filep%hdf5_file_id, filep%natt, status ) IF_NOT_OK_RETURN(status=1) ! open group: call H5GOpen_f( filep%hdf5_file_id, '/', hdf5_grp_id, status ) IF_NOT_OK_RETURN(status=1) ! get number of members: call H5GN_Members_f( hdf5_grp_id, '.', nvar, status ) IF_NOT_OK_RETURN(status=1) ! loop over group members: do ivar = 1, nvar ! get group info: call H5GGet_Obj_Info_Idx_f( hdf5_grp_id, '.', ivar-1, hdf5_obj_name, hdf5_obj_type, status ) IF_NOT_OK_RETURN(status=1) ! what ? if ( hdf5_obj_type == H5G_DATASET_F ) then ! new variable: call MDF_Var_List_New_Item( filep%Var_List, varid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! store full hdf5 name: varp%hdf5_name = trim(hdf5_obj_name) ! store variable name: varp%name = trim(hdf5_obj_name) ! open data set: call H5DOpen_f( hdf5_grp_id, trim(hdf5_obj_name), varp%hdf5_dataset_id, status ) IF_NOT_OK_RETURN(status=1) ! get type id: call H5DGet_Type_f( varp%hdf5_dataset_id, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! convert to mdf type code: call HDF5_Get_MDF_Type( hdf5_type_id, varp%xtype, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! get data space id: call H5DGet_Space_f( varp%hdf5_dataset_id, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! get dimensions: call H5SGet_Simple_Extent_Dims_f( hdf5_space_id, varp%hdf5_dims, varp%hdf5_maxdims, status ) if ( status < 0 ) then ! something went wrong ... write (gol,'("could not extract dimensions for attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return else ! number of dimensions: ndim = status end if ! store number of dimensions in variable structure: varp%ndim = status ! init arrays: varp%dimids = -1 varp%shp = -1 ! loop over dimensions: do idim = 1, ndim ! current length: length = varp%hdf5_dims(idim) ! new dimension: call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! store current length: dimp%length = length ! unlimitted ? dimp%unlimited = varp%hdf5_maxdims(idim) == H5S_UNLIMITED_F ! dummy name ... dimp%named = .false. write (snr,'(i6)') length dimp%name = 'fakeDime'//adjustl(snr) ! fill variable dimension info: varp%dimids(idim) = dimid varp%shp (idim) = dimp%length end do ! dimensions ! release: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! get number of global attributes: call H5AGet_Num_Attrs_f( varp%hdf5_dataset_id, varp%natt, status ) IF_NOT_OK_RETURN(status=1) else if ( hdf5_obj_type == H5G_LINK_F ) then write (gol,'("WARNING - HDF5 links not supported yet: ",a)') trim(hdf5_obj_name); call goPr else if ( hdf5_obj_type == H5G_GROUP_F ) then write (gol,'("WARNING - HDF5 groups not supported yet: ",a)') trim(hdf5_obj_name); call goPr else if ( hdf5_obj_type == H5G_TYPE_F ) then write (gol,'("WARNING - HDF5 types not supported yet: ",a)') trim(hdf5_obj_name); call goPr else write (gol,'("unsupported hdf5_obj_type ",i6)') hdf5_obj_type; call goErr TRACEBACK; status=1; return end if end do ! group members ! release group: call H5GClose_f( hdf5_grp_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! full file name: filep%netcdf_fname = trim(filep%filename) ! check ... inquire( file=trim(filep%netcdf_fname), exist=exist ) if ( .not. exist ) then write (gol,'("file to be opened not found : ",a)') trim(filep%netcdf_fname); call goErr TRACEBACK; status=1; return end if ! set open mode: select case ( mode ) case ( MDF_READ ) netcdf_mode = NF90_NOWRITE case ( MDF_WRITE ) netcdf_mode = NF90_WRITE case default write (gol,'("unsupported creation mode : ",i6)') mode; call goErr TRACEBACK; status=1; return end select ! open in parallel ? if ( filep%parallel ) then ! open file in parallel: #ifdef with_netcdf4_par ! Creation mode MPIIO is needed for parallel i/o for NetCDF library 4.1 onwards. ! But since the parameter is not available for older versions, it can not used ! permantently to avoid errors about undevined variables. ! Instead, the value of MPIIO is hardcoded here for a number of library versions; ! please extend for your version if the error traceback has brought you here. ! First get library version: netcdf_version = trim(NF90_Inq_LibVers()) ! switch: if ( (netcdf_version(1:5) == '4.0.1') ) then ! no NF90_MPIIO needed for this version ... else if ( (netcdf_version(1:5) == '4.1.1') .or. & (netcdf_version(1:5) == '4.1.2') .or. & (netcdf_version(1:5) == '4.1.3') .or. & (netcdf_version(1:3) == '4.2' ) ) then ! add value of NF90_MPIIO to creation mode: netcdf_mode = netcdf_mode + 8192 !else if ( netcdf_version(1:3) == '4.x' ) then ! ! show value ; need to uncomment the 'use' statement in the top of this routine: ! write (gol,'("Value of NF90_MPIIO : ",i6)') NF90_MPIIO; call goErr ! ! add value of NF90_MPIIO to creation mode: ! netcdf_cmode = netcdf_cmode + 0 else write (gol,'("Please implement NF90_MPIIO behaviour for your NetCDF library version:")'); call goErr write (gol,'(" ",a)') trim(netcdf_version); call goErr TRACEBACK; status=1; return end if status = NF90_Open_Par( trim(filep%netcdf_fname), netcdf_mode, & mpi_comm, mpi_info, filep%netcdf_id ) IF_NF90_NOT_OK_RETURN(status=1) #else write (gol,'("Parallel open of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr TRACEBACK; status=1; return #endif else ! open file: status = NF90_Open( trim(filep%netcdf_fname), netcdf_mode, filep%netcdf_id ) IF_NF90_NOT_OK_RETURN(status=1) end if ! get number of global attributes: status = NF90_Inquire( filep%netcdf_id, nAttributes=filep%natt ) IF_NF90_NOT_OK_RETURN(status=1) ! get number of dimensions and (dummy) id of unlimitted dimension: status = NF90_Inquire( filep%netcdf_id, nDimensions=ndim, unlimitedDimID=unlimid ) IF_NF90_NOT_OK_RETURN(status=1) ! loop over dimensions: do idim = 1, ndim ! new dimension: call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! netcdf dimension id is number from 1..ndim dimp%netcdf_dimid = idim ! get info: status = NF90_Inquire_Dimension( filep%netcdf_id, dimp%netcdf_dimid, & name=name, len=length ) IF_NF90_NOT_OK_RETURN(status=1) ! store: dimp%named = .true. dimp%name = trim(name) dimp%length = length dimp%unlimited = dimp%netcdf_dimid == unlimid end do ! get number of variables: status = NF90_Inquire( filep%netcdf_id, nVariables=nvar ) IF_NF90_NOT_OK_RETURN(status=1) ! loop over variables: do ivar = 1, nvar ! new variable: call MDF_Var_List_New_Item( filep%Var_List, varid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! netcdf variable id is number from 1..nvar varp%netcdf_varid = ivar ! get info: status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, & name=name, xtype=netcdf_xtype, ndims=ndim ) IF_NF90_NOT_OK_RETURN(status=1) ! store name: varp%name = trim(name) ! convert type: select case ( netcdf_xtype ) case ( NF90_CHAR ) ; varp%xtype = MDF_CHAR case ( NF90_BYTE ) ; varp%xtype = MDF_BYTE case ( NF90_SHORT ) ; varp%xtype = MDF_SHORT case ( NF90_INT ) ; varp%xtype = MDF_INT case ( NF90_FLOAT ) ; varp%xtype = MDF_FLOAT case ( NF90_DOUBLE ) ; varp%xtype = MDF_DOUBLE case default write (gol,'("unsupported data type : ",i6)') netcdf_xtype; call goErr TRACEBACK; status=1; return end select ! set kind given type: call MDF_Get_Kind( varp%xtype, varp%xkind, status ) IF_NOT_OK_RETURN(status=1) ! store number of dimensions: varp%ndim = ndim ! get netcdf dimension id's now that number is known: status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, dimids=dimids(1:ndim) ) IF_NF90_NOT_OK_RETURN(status=1) ! init arrays: varp%dimids = -1 varp%shp = -1 ! loop over dimensions: do idim = 1, ndim ! mdf dimension id is the same as the netcdf dimension id, ! both are numbers 1,..,maxdim : dimid = dimids(idim) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! store: varp%dimids(idim) = dimid varp%shp (idim) = dimp%length end do ! get number of variable attributes: status = NF90_Inquire_Variable( filep%netcdf_id, varp%netcdf_varid, nAtts=varp%natt ) IF_NF90_NOT_OK_RETURN(status=1) end do ! variables #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr if ((ftype>=1).and.(ftype<=MDF_FILETYPE_MAX)) then write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr end if write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Open ! *** subroutine MDF_Close( hid, status ) #ifdef with_hdf5_beta use HDF5, only : H5FClose_f use HDF5, only : H5DClose_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Close #endif ! --- in/out ------------------------------------- integer, intent(inout) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Close' ! --- external ---------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfEnd #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: iftype integer :: ftype integer :: ivar, nvar type(MDF_Var), pointer :: varp ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! close file: status = sfEnd( filep%hdf4_id ) if ( status == FAIL ) then write (gol,'("while closing HDF4 file:")'); call goErr write (gol,'(" file name : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! get number of elements in variable list: call MDF_Var_List_Inquire( filep%Var_List, status, n=nvar ) IF_NOT_OK_RETURN(status=1) ! list variables ? if ( nvar > 0 ) then ! loop over variables: do ivar = 1, nvar ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, ivar, varp, status ) IF_NOT_OK_RETURN(status=1) ! close data set: call H5DClose_f( varp%hdf5_dataset_id, status ) IF_NOT_OK_RETURN(status=1) end do ! variables end if ! nvar > 0 ! close file: call H5FClose_f( filep%hdf5_file_id, status ) if ( status /= 0 ) then write (gol,'("while closing HDF5 file:")'); call goErr write (gol,'(" file name : ",a)') trim(filep%hdf5_fname); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! close file: status = NF90_Close( filep%netcdf_id ) if ( status /= NF90_NOERR ) then write (gol,'("while closing NetCDF4 file:")'); call goErr write (gol,'(" file name : ",a)') trim(filep%netcdf_fname); call goErr TRACEBACK; status=1; return end if #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! done with variable list: call MDF_Var_List_Done( filep%Var_List, status ) IF_NOT_OK_RETURN(status=1) ! done with dimension list: call MDF_Dim_List_Done( filep%Dim_List, status ) IF_NOT_OK_RETURN(status=1) ! remove item: call MDF_File_List_Clear_Item( File_List, hid, status ) IF_NOT_OK_RETURN(status=1) ! ok status = 0 end subroutine MDF_Close ! ******************************************************************** ! *** ! *** end of definition phase ! *** ! ******************************************************************** subroutine MDF_EndDef( hid, status ) #ifdef with_netcdf use NetCDF, only : NF90_EndDef #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_EndDef' ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: iftype integer :: ftype ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! nothing required for this format ... #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! nothing required for this format ... #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! end of definition phase: status = NF90_EndDef( filep%netcdf_id ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_EndDef ! ******************************************************************** ! *** ! *** dimensions ! *** ! ******************************************************************** subroutine MDF_Def_Dim( hid, name, length, dimid, status ) #ifdef with_netcdf use NetCDF, only : NF90_Def_Dim, NF90_UNLIMITED #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid character(len=*), intent(in) :: name integer, intent(in) :: length integer, intent(out) :: dimid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Def_Dim' ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Dim), pointer :: dimp integer :: iftype integer :: ftype #ifdef with_netcdf integer :: netcdf_length #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! new dimension: call MDF_Dim_List_New_Item( filep%Dim_List, dimid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! store: dimp%name = trim(name) dimp%length = length ! unlimited length ? dimp%unlimited = length == MDF_UNLIMITED ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Dimensions in HDF4 are no special entities in the file, ! but part of each variable . ! The arguments stored in the dimension structure will ! be used to define the shape of new variables. #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! Dimensions in HDF5 are no special entities in the file, ! but stored in the 'data space' part of each variable . ! The arguments stored in the dimension structure will ! be used to define the shape of new variables. #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set dimension length: if ( dimp%unlimited ) then netcdf_length = NF90_UNLIMITED else netcdf_length = length end if ! define dimension: status = NF90_Def_Dim( filep%netcdf_id, trim(name), netcdf_length, dimp%netcdf_dimid ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Def_Dim ! ******************************************************************** ! *** ! *** variables ! *** ! ******************************************************************** subroutine MDF_Def_Var( hid, name, xtype, dimids, varid, status, & compression, deflate_level ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TClose_f!, H5TSet_Size_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_UNLIMITED_F use HDF5, only : H5PCreate_f, H5PClose_f, H5P_DATASET_CREATE_F use HDF5, only : H5PSet_Chunk_f, H5PSet_Deflate_f use HDF5, only : H5DCreate_f #endif #ifdef with_netcdf use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE use NetCDF, only : NF90_Def_Var #ifdef with_netcdf4 use NetCDF, only : NF90_Def_Var_Deflate #endif #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid character(len=*), intent(in) :: name integer, intent(in) :: xtype integer, intent(in) :: dimids(:) integer, intent(out) :: varid integer, intent(out) :: status integer, intent(in), optional :: compression integer, intent(in), optional :: deflate_level ! 0-9 ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Def_Var' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfCreate integer(hdf4_wpi), external :: sfDimID integer(hdf4_wpi), external :: sfSDmName integer(hdf4_wpi), external :: sfsCompress #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Dim), pointer :: dimp type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype integer :: idim #ifdef with_hdf4 integer :: hdf4_xtype integer :: hdf4_shape(MAX_RANK) integer :: hdf4_dimid integer :: hdf4_comp_type integer :: hdf4_comp_prm(1) #endif #ifdef with_hdf5_beta integer :: hdf5_xtype integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_dcpl_id integer :: hdf5_deflate_level #endif #ifdef with_netcdf integer :: netcdf_xtype integer :: netcdf_dimids(MAX_RANK) integer :: netcdf_deflate_level #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! new variable: call MDF_Var_List_New_Item( filep%Var_List, varid, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! store name; varp%name = trim(name) ! store type: varp%xtype = xtype ! set kind value given type: call MDF_Get_Kind( varp%xtype, varp%xkind, status ) IF_NOT_OK_RETURN(status=1) ! number of dimensions: varp%ndim = size(dimids) ! dimension id's : varp%dimids(1:varp%ndim) = dimids ! fill shape: do idim = 1, varp%ndim ! pointer to dimension type: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status ) IF_NOT_OK_RETURN(status=1) ! copy dimension id: varp%shp(idim) = dimp%length end do ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set data type: select case ( xtype ) case ( MDF_CHAR ) ; hdf4_xtype = DFNT_CHAR case ( MDF_BYTE ) ; hdf4_xtype = DFNT_INT8 case ( MDF_SHORT ) ; hdf4_xtype = DFNT_INT16 case ( MDF_INT ) ; hdf4_xtype = DFNT_INT32 case ( MDF_FLOAT ) ; hdf4_xtype = DFNT_FLOAT32 case ( MDF_DOUBLE ) ; hdf4_xtype = DFNT_FLOAT64 case default write (gol,'("unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select ! extract dimensions: do idim = 1, varp%ndim ! pointer to dimension type: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status ) IF_NOT_OK_RETURN(status=1) ! fill dimension: if ( dimp%length == MDF_UNLIMITED ) then hdf4_shape(idim) = SD_UNLIMITED else hdf4_shape(idim) = dimp%length end if end do ! define variable: status = sfCreate( filep%hdf4_id, trim(name), hdf4_xtype, & varp%ndim, hdf4_shape(1:varp%ndim) ) if ( status == FAIL ) then write (gol,'("from sfCreate :")'); call goErr write (gol,'(" name : ",a)') trim(name); call goErr write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if ! store varp%hdf4_sdid = status ! loop over dimension indices: do idim = 1, varp%ndim ! pointer to dimension type: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status ) IF_NOT_OK_RETURN(status=1) ! select dimension with zero based index: status = sfDimID( varp%hdf4_sdid, idim-1 ) if ( status == FAIL ) then write (gol,'("from sfDimID :")'); call goErr write (gol,'(" dimension index : ",i6)') idim; call goErr write (gol,'(" variable name : ",a)') trim(name); call goErr write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if hdf4_dimid = status ! set dimension name status = sfSDmName( hdf4_dimid, trim(dimp%name) ) if ( status == FAIL ) then write (gol,'("setting dimension name :")'); call goErr write (gol,'(" dim name : ",a)') trim(dimp%name); call goErr write (gol,'(" dimension index : ",i6)') idim; call goErr write (gol,'(" variable name : ",a)') trim(name); call goErr write (gol,'(" hdf file : ",a)') trim(filep%hdf4_fname); call goErr TRACEBACK; status=1; return end if end do ! dimensions ! compression specified ? if ( present(compression) ) then ! apply ? if ( compression /= MDF_NONE ) then ! check ... if ( any( varp%shp == MDF_UNLIMITED ) ) then write (gol,'("HDF4 does not allow compresion of data sets with an unlimitted dimension ...")'); call goErr TRACEBACK; status=1; return end if ! which one ? select case ( compression ) ! deflation (=zlib) case ( MDF_DEFLATE ) ! set compression type: hdf4_comp_type = COMP_CODE_DEFLATE ! set deflation level: if ( present(deflate_level) ) then hdf4_comp_prm(1) = deflate_level else hdf4_comp_prm(1) = 6 end if case default write (gol,'("unsupported compression type : ",i6)') compression; call goErr TRACEBACK; status=1; return end select ! call HDF routine: status = sfsCompress( varp%hdf4_sdid, hdf4_comp_type, hdf4_comp_prm ) if ( status == FAIL ) then write (gol,'("from sfsCompress : ")'); call goErr write (gol,'(" compression index : ",i6)') compression; call goErr write (gol,'(" compression name : ",a)') trim(MDF_COMPRESSION_NAME(compression)); call goErr write (gol,'(" hdf4 compress type : ",i6)') hdf4_comp_type; call goErr write (gol,'(" hdf4 compress param : ",i6)') hdf4_comp_prm; call goErr write (gol,'(" return status : ",i6)') status; call goErr TRACEBACK; status=1; return end if end if ! apply ? end if ! compression ? #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set data type: select case ( xtype ) case ( MDF_CHAR ) ; hdf5_xtype = H5T_NATIVE_CHARACTER case ( MDF_BYTE ) ; hdf5_xtype = H5T_STD_I8LE case ( MDF_SHORT ) ; hdf5_xtype = H5T_STD_I16LE case ( MDF_INT ) ; hdf5_xtype = H5T_NATIVE_INTEGER case ( MDF_FLOAT ) ; hdf5_xtype = H5T_NATIVE_REAL case ( MDF_DOUBLE ) ; hdf5_xtype = H5T_NATIVE_DOUBLE case default write (gol,'("unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select ! data type: call H5TCopy_f( hdf5_xtype, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) !! set length for characters ? !call H5TSet_Size_f( hdf5_type_id, len(values), status ) !IF_NOT_OK_RETURN(status=1) ! extract dimensions: do idim = 1, varp%ndim ! pointer to dimension type: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status ) IF_NOT_OK_RETURN(status=1) ! fill dimension: if ( dimp%length == MDF_UNLIMITED ) then varp%hdf5_dims (idim) = 0 varp%hdf5_maxdims (idim) = H5S_UNLIMITED_F varp%hdf5_chunkdims(idim) = 1 varp%hdf5_chunked = .true. else varp%hdf5_dims (idim) = dimp%length varp%hdf5_maxdims (idim) = dimp%length varp%hdf5_chunkdims(idim) = dimp%length varp%hdf5_chunked = .false. end if end do ! create data space: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_space_id, status, & maxdims=varp%hdf5_maxdims(1:varp%ndim) ) IF_NOT_OK_RETURN(status=1) ! dataset creation property list: call H5PCreate_f( H5P_DATASET_CREATE_F, hdf5_dcpl_id, status ) IF_NOT_OK_RETURN(status=1) ! for unlimited dimensions ... if ( varp%hdf5_chunked ) then call H5PSet_Chunk_f( hdf5_dcpl_id, varp%ndim, varp%hdf5_chunkdims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! compression specified ? if ( present(compression) ) then ! which one ? select case ( compression ) ! no compression ... case ( MDF_NONE ) ! nothing to be done ! deflation (=gzip) case ( MDF_DEFLATE ) ! set deflation level: if ( present(deflate_level) ) then hdf5_deflate_level = deflate_level else hdf5_deflate_level = 0 end if ! add filter to property list: call H5PSet_Deflate_f( hdf5_dcpl_id, hdf5_deflate_level, status ) IF_NOT_OK_RETURN(status=1) case default write (gol,'("unsupported compression type : ",i6)') compression; call goErr TRACEBACK; status=1; return end select end if ! compression ? ! store name: varp%hdf5_name = trim(name) ! define variable: call H5DCreate_f( filep%hdf5_file_id, trim(name), hdf5_type_id, hdf5_space_id, varp%hdf5_dataset_id, status, & dcpl_id=hdf5_dcpl_id ) IF_NOT_OK_RETURN(status=1) ! close property list: call H5PClose_f( hdf5_dcpl_id, status ) IF_NOT_OK_RETURN(status=1) ! close data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! close data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set data type: select case ( xtype ) case ( MDF_CHAR ) ; netcdf_xtype = NF90_CHAR case ( MDF_BYTE ) ; netcdf_xtype = NF90_BYTE case ( MDF_SHORT ) ; netcdf_xtype = NF90_SHORT case ( MDF_INT ) ; netcdf_xtype = NF90_INT case ( MDF_FLOAT ) ; netcdf_xtype = NF90_FLOAT case ( MDF_DOUBLE ) ; netcdf_xtype = NF90_DOUBLE case default write (gol,'("unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select ! extract dimensions: do idim = 1, varp%ndim ! pointer to dimension type: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimids(idim), dimp, status ) IF_NOT_OK_RETURN(status=1) ! copy dimension id: netcdf_dimids(idim) = dimp%netcdf_dimid end do ! define variable: status = NF90_Def_Var( filep%netcdf_id, trim(name), netcdf_xtype, & netcdf_dimids(1:varp%ndim), varp%netcdf_varid ) IF_NF90_NOT_OK_RETURN(status=1) ! compression specified ? if ( present(compression) ) then ! which one ? select case ( compression ) ! no compression ... case ( MDF_NONE ) ! nothing to be done #ifdef with_netcdf4 ! deflation (=zlib) case ( MDF_DEFLATE ) ! set deflation level: if ( present(deflate_level) ) then netcdf_deflate_level = deflate_level else netcdf_deflate_level = 0 end if ! set parameters (without shuffle, with deflate) status = NF90_Def_Var_Deflate( filep%netcdf_id, varp%netcdf_varid, 0, 1, netcdf_deflate_level ) IF_NF90_NOT_OK_RETURN(status=1) #endif case default write (gol,'("unsupported compression type : ",i6)') compression; call goErr write (gol,'("(might be necessary to compile with macro `with_netcdf4` defined)")'); call goErr TRACEBACK; status=1; return end select end if ! compression ? #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! no attributes yet: varp%natt = 0 ! ok status = 0 end subroutine MDF_Def_Var ! *** !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: MDF_Var_Par_Access ! ! !DESCRIPTION: Wrapper around NF90_Var_Par_Access. It changes whether read ! /write operations on a parallel file system are performed ! collectively or independently (the default) on the variable. !\\ !\\ ! !INTERFACE: ! subroutine MDF_Var_Par_Access( hid, varid, par_access_mode, status ) ! ! !USES: ! #ifdef with_netcdf4_par use NetCDF, only : NF90_INDEPENDENT, NF90_COLLECTIVE use NetCDF, only : NF90_Var_Par_Access #endif ! ! !INPUT PARAMETERS: ! integer, intent(in) :: hid integer, intent(in) :: varid integer, intent(in) :: par_access_mode ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 13 Jan 2012 - Philippe Le Sager - added COLLECTIVE case ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/MDF_Var_Par_Access' ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_netcdf4_par integer :: netcdf_par_access_mode #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! opened for parallel i/o ? if ( filep%parallel ) then ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_netcdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ #ifdef with_netcdf4_par ! set mode: select case ( par_access_mode ) case ( MDF_INDEPENDENT ) ; netcdf_par_access_mode = NF90_INDEPENDENT case ( MDF_COLLECTIVE ) ; netcdf_par_access_mode = NF90_COLLECTIVE case default write (gol,'("unsupported parallel access mode : ",i6)') par_access_mode; call goErr TRACEBACK; status=1; return end select ! set access mode: status = NF90_Var_Par_Access( filep%netcdf_id, varp%netcdf_varid, netcdf_par_access_mode ) IF_NF90_NOT_OK_RETURN(status=1) #else write (gol,'("Parallel access of NetCDF requires compilation with `with_netcdf4_par` macro defined.")'); call goErr TRACEBACK; status=1; return #endif #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types end if ! parallel i/o ! ok status = 0 end subroutine MDF_Var_Par_Access !EOC ! *** subroutine MDF_Put_Var_c1_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = (/len(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = (/len(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_1d ! *** subroutine MDF_Get_Var_c1_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = (/ len(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_1d ! *** subroutine MDF_Put_Var_c1_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_2d ! *** subroutine MDF_Get_Var_c1_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_2d ! *** subroutine MDF_Put_Var_c1_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_3d ! *** subroutine MDF_Get_Var_c1_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_3d ! *** subroutine MDF_Put_Var_c1_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_4d ! *** subroutine MDF_Get_Var_c1_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_4d ! *** subroutine MDF_Put_Var_c1_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_5d ! *** subroutine MDF_Get_Var_c1_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_5d ! *** subroutine MDF_Put_Var_c1_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_6d ! *** subroutine MDF_Get_Var_c1_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_6d ! *** subroutine MDF_Put_Var_c1_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_c1_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = (/len(values),shape(values)/) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! write: status = sfWData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = (/len(values),shape(values)/) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_CHARACTER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_c1_7d ! *** subroutine MDF_Get_Var_c1_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_c1_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = (/ len(values), shape(values) /) ! read: status = sfRData( varp%hdf4_sdid, hdf4_offset, hdf4_stride, hdf4_count, values ) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_c1_7d ! *** subroutine MDF_Put_Var_i1_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_1d ! *** subroutine MDF_Get_Var_i1_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_1d ! *** subroutine MDF_Put_Var_i1_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_2d ! *** subroutine MDF_Get_Var_i1_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_2d ! *** subroutine MDF_Put_Var_i1_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_3d ! *** subroutine MDF_Get_Var_i1_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_3d ! *** subroutine MDF_Put_Var_i1_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_4d ! *** subroutine MDF_Get_Var_i1_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_4d ! *** subroutine MDF_Put_Var_i1_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_5d ! *** subroutine MDF_Get_Var_i1_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_5d ! *** subroutine MDF_Put_Var_i1_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_6d ! *** subroutine MDF_Get_Var_i1_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_6d ! *** subroutine MDF_Put_Var_i1_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(in) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i1_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i1_7d ! *** subroutine MDF_Get_Var_i1_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(1), intent(out) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i1_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i1_7d ! *** subroutine MDF_Put_Var_i2_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_1d ! *** subroutine MDF_Get_Var_i2_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_1d ! *** subroutine MDF_Put_Var_i2_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_2d ! *** subroutine MDF_Get_Var_i2_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_2d ! *** subroutine MDF_Put_Var_i2_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_3d ! *** subroutine MDF_Get_Var_i2_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_3d ! *** subroutine MDF_Put_Var_i2_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_4d ! *** subroutine MDF_Get_Var_i2_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_4d ! *** subroutine MDF_Put_Var_i2_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_5d ! *** subroutine MDF_Get_Var_i2_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_5d ! *** subroutine MDF_Put_Var_i2_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_6d ! *** subroutine MDF_Get_Var_i2_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_6d ! *** subroutine MDF_Put_Var_i2_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(in) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i2_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, int(values), & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i2_7d ! *** subroutine MDF_Get_Var_i2_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(2), intent(out) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i2_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i2_7d ! *** subroutine MDF_Put_Var_i4_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_1d ! *** subroutine MDF_Get_Var_i4_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_1d ! *** subroutine MDF_Put_Var_i4_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_2d ! *** subroutine MDF_Get_Var_i4_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_2d ! *** subroutine MDF_Put_Var_i4_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_3d ! *** subroutine MDF_Get_Var_i4_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_3d ! *** subroutine MDF_Put_Var_i4_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_4d ! *** subroutine MDF_Get_Var_i4_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_4d ! *** subroutine MDF_Put_Var_i4_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_5d ! *** subroutine MDF_Get_Var_i4_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_5d ! *** subroutine MDF_Put_Var_i4_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_6d ! *** subroutine MDF_Get_Var_i4_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_6d ! *** subroutine MDF_Put_Var_i4_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(in) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_i4_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_INTEGER, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_i4_7d ! *** subroutine MDF_Get_Var_i4_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer(4), intent(out) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_i4_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_i4_7d ! *** subroutine MDF_Put_Var_r4_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_1d ! *** subroutine MDF_Get_Var_r4_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_1d ! *** subroutine MDF_Put_Var_r4_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_2d ! *** subroutine MDF_Get_Var_r4_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_2d ! *** subroutine MDF_Put_Var_r4_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_3d ! *** subroutine MDF_Get_Var_r4_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_3d ! *** subroutine MDF_Put_Var_r4_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_4d ! *** subroutine MDF_Get_Var_r4_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_4d ! *** subroutine MDF_Put_Var_r4_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_5d ! *** subroutine MDF_Get_Var_r4_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_5d ! *** subroutine MDF_Put_Var_r4_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_6d ! *** subroutine MDF_Get_Var_r4_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_6d ! *** subroutine MDF_Put_Var_r4_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(in) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r4_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_REAL, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r4_7d ! *** subroutine MDF_Get_Var_r4_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(4), intent(out) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r4_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r4_7d ! *** subroutine MDF_Put_Var_r8_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:1) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:1) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_1d ! *** subroutine MDF_Get_Var_r8_1d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_1d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:1) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_1d ! *** subroutine MDF_Put_Var_r8_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:2) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:2) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_2d ! *** subroutine MDF_Get_Var_r8_2d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_2d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:) integer(2), allocatable :: values_int2(:,:) integer(4), allocatable :: values_int4(:,:) integer(8), allocatable :: values_int8(:,:) real(4), allocatable :: values_real4(:,:) real(8), allocatable :: values_real8(:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:2) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_2d ! *** subroutine MDF_Put_Var_r8_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:3) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:3) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_3d ! *** subroutine MDF_Get_Var_r8_3d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_3d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:) integer(2), allocatable :: values_int2(:,:,:) integer(4), allocatable :: values_int4(:,:,:) integer(8), allocatable :: values_int8(:,:,:) real(4), allocatable :: values_real4(:,:,:) real(8), allocatable :: values_real8(:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:3) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_3d ! *** subroutine MDF_Put_Var_r8_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:4) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:4) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_4d ! *** subroutine MDF_Get_Var_r8_4d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_4d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:4) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_4d ! *** subroutine MDF_Put_Var_r8_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:5) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:5) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_5d ! *** subroutine MDF_Get_Var_r8_5d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_5d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:5) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_5d ! *** subroutine MDF_Put_Var_r8_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:6) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:6) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_6d ! *** subroutine MDF_Get_Var_r8_6d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_6d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:6) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_6d ! *** subroutine MDF_Put_Var_r8_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_Simple_f, H5SClose_f, H5SSelect_Hyperslab_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F, H5S_SELECT_SET_F use HDF5, only : H5DWrite_f, H5DSet_Extent_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(in) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Var_r8_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfWData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) #endif #ifdef with_hdf5_beta !integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_file_space_id integer(HSIZE_T) :: hdf5_offset(MAX_RANK) integer(HSIZE_T) :: hdf5_stride(MAX_RANK) integer(HSIZE_T) :: hdf5_count (MAX_RANK) #endif integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be written exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!) and stride with default values: hdf4_offset = 0 hdf4_stride = 1 ! count is by default the shape; padd with singleton dimensions: hdf4_count = 1; hdf4_count(1:7) = shape(values) ! replace by optional arguments if necessary: if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride if ( present(count ) ) hdf4_count (1:varp%ndim) = count ! test target type; ! convert to required kind before entering sfWData, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = sfWData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), & hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("writing hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i12)') size(values); call goErr write (gol,'("(writing a slice to a compressed data set ?)")'); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF5")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf5_offset = 0; if ( present(start ) ) hdf5_offset(1:varp%ndim) = start-1 hdf5_stride = 1; if ( present(stride) ) hdf5_stride(1:varp%ndim) = stride hdf5_count = 1 ! default singleton dimension if ( present(count) ) then hdf5_count(1:varp%ndim) = count else hdf5_count(1:7) = shape(values) end if ! new dimension: varp%hdf5_dims = max( varp%hdf5_dims, hdf5_offset+hdf5_count ) ! target data space in file: call H5SCreate_Simple_f( varp%ndim, varp%hdf5_dims(1:varp%ndim), hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) ! chunked dataset ? if ( varp%hdf5_chunked ) then ! reset extend: call H5DSet_Extent_f( varp%hdf5_dataset_id, varp%hdf5_dims(1:varp%ndim), status ) IF_NOT_OK_RETURN(status=1) end if ! select hyperslab: call H5SSelect_Hyperslab_f( hdf5_file_space_id, H5S_SELECT_SET_F, & hdf5_offset(1:varp%ndim), hdf5_count(1:varp%ndim), status, & stride=hdf5_stride(1:varp%ndim) ) ! write data: call H5DWrite_f( varp%hdf5_dataset_id, H5T_NATIVE_DOUBLE, values, & int(shape(values),kind=HSIZE_T), status, & file_space_id=hdf5_file_space_id ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_file_space_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! test target type: ! convert to required kind before entering NF90_Put_Var, ! otherwise segmentation faults on some machines ... select case ( varp%xtype ) case ( MDF_BYTE ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int1 = int(values,kind=1) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int1, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int1 ) case ( MDF_SHORT ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int2 = int(values,kind=2) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int2, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int2 ) case ( MDF_INT ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_int4 = int(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_int4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_int4 ) case ( MDF_FLOAT ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real4 = real(values,kind=4) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real4, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real4 ) case ( MDF_DOUBLE ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) values_real8 = real(values,kind=8) status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values_real8, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) deallocate( values_real8 ) case default write (gol,'("not implemented yet for output type : ",i6)') varp%xtype; call goPr TRACEBACK; status=1; return end select ! just put; let netcdf library convert the right kind: !status = NF90_Put_Var( filep%netcdf_id, varp%netcdf_varid, values, & ! start, count, stride, map ) !IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Var_r8_7d ! *** subroutine MDF_Get_Var_r8_7d( hid, varid, values, status, & start, count, stride, map ) #ifdef with_netcdf use NetCDF, only : NF90_Get_Var #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid real(8), intent(out) :: values(:,:,:,:,:,:,:) integer, intent(out) :: status integer, intent(in), optional :: start (:) integer, intent(in), optional :: count (:) integer, intent(in), optional :: stride(:) integer, intent(in), optional :: map (:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Var_r8_7d' ! --- external ----------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfRData #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_offset(MAX_RANK) integer :: hdf4_stride(MAX_RANK) integer :: hdf4_count(MAX_RANK) integer(1), allocatable :: values_int1(:,:,:,:,:,:,:) integer(2), allocatable :: values_int2(:,:,:,:,:,:,:) integer(4), allocatable :: values_int4(:,:,:,:,:,:,:) integer(8), allocatable :: values_int8(:,:,:,:,:,:,:) real(4), allocatable :: values_real4(:,:,:,:,:,:,:) real(8), allocatable :: values_real8(:,:,:,:,:,:,:) #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( size(shape(values)) > varp%ndim ) then write (gol,'("Rank of values to be read exceeds variable dimension:")'); call goErr write (gol,'(" rank values : ",i6)') size(shape(values)); call goErr write (gol,'(" variable dimension : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if ! check ... if ( present(start ) ) then if ( size(start ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size start : ",i6)') size(start ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(count ) ) then if ( size(count ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size count : ",i6)') size(count ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(stride ) ) then if ( size(stride ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size stride : ",i6)') size(stride ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if if ( present(map ) ) then if ( size(map ) /= varp%ndim ) then write (gol,'("Size of position argument not equal to variable dimension:")'); call goErr write (gol,'(" size map : ",i6)') size(map ); call goErr write (gol,'(" var dim : ",i6)') varp%ndim; call goErr TRACEBACK; status=1; return end if end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! check ... if ( present(map ) ) then write (gol,'("argument `map` not supported for HDF4")'); call goErr TRACEBACK; status=1; return end if ! fill offset (zero based!), stride, and count : hdf4_offset = 0; if ( present(start ) ) hdf4_offset(1:varp%ndim) = start-1 hdf4_stride = 1; if ( present(stride) ) hdf4_stride(1:varp%ndim) = stride hdf4_count = 1 ! default singleton dimension hdf4_count(1:7) = shape(values) ! test source type: select case ( varp%hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(size(values,1),size(values,2),size(values,3),size(values,4),size(values,5),size(values,6),size(values,7)) ) status = sfRData( varp%hdf4_sdid, hdf4_offset(1:varp%ndim), hdf4_stride(1:varp%ndim), hdf4_count(1:varp%ndim), values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("unsupported hdf4 variable type : ",i6)') varp%hdf4_xtype; call goPr TRACEBACK; status=1; return end select if ( status == FAIL ) then write (gol,'("reading hdf4 data set:")'); call goErr write (gol,'(" file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" data set : ",a)') trim(varp%name); call goErr write (gol,'(" offset : ",100i4)') hdf4_offset(1:varp%ndim); call goErr write (gol,'(" stride : ",100i4)') hdf4_stride(1:varp%ndim); call goErr write (gol,'(" count : ",100i4)') hdf4_count (1:varp%ndim); call goErr write (gol,'(" size : ",i6)') size(values); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! read values, converted automatically: status = NF90_Get_Var( filep%netcdf_id, varp%netcdf_varid, values, & start, count, stride, map ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Get_Var_r8_7d ! *** ! ******************************************************************** ! *** ! *** attributes ! *** ! ******************************************************************** subroutine MDF_Put_Att_c1_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name character(len=*), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_c1_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store character attribute: status = sfSCAtt( hdf4_id, trim(name), DFNT_CHAR, len(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_CHARACTER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! set length: call H5TSet_Size_f( hdf5_type_id, len(values), status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, hdf5_type_id, values, int((/len(values)/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_c1_0d ! *** subroutine MDF_Get_Att_c1_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name character(len=*), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_c1_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! check ... if ( hdf4_length > len(values) ) then write (gol,'("length of character attribute `",a,"` (",i6,") exceeds output length (",i6,") ;")') & trim(name), hdf4_length, len(values); call goErr TRACEBACK; status=1; return end if ! read character attribute: status = sfRCAtt( hdf4_id, hdf4_iatt, values ) if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if ! truncate ... values = values(1:hdf4_length) #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_CHARACTER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! set length: call H5TSet_Size_f( hdf5_type_id, len(values), status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read: call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/len(values)/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_c1_0d subroutine MDF_Put_Att_i1_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(1), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i1_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT8, 1, values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i1_0d ! *** subroutine MDF_Get_Att_i1_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(1), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i1_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1) :: values_int1 integer(2) :: values_int2 integer(4) :: values_int4 integer(8) :: values_int8 real(4) :: values_real4 real(8) :: values_real8 #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4) :: hdf5_values_int4 #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=1) case ( DFNT_INT16 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=1) case ( DFNT_INT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=1) case ( DFNT_INT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=1) case ( DFNT_FLOAT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=1) case ( DFNT_FLOAT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=1) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i1_0d subroutine MDF_Put_Att_i1_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(1), intent(in) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i1_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! strore numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT8, size(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! set extent of the data space: call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i1_1d ! *** subroutine MDF_Get_Att_i1_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(1), intent(out) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i1_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4), allocatable :: hdf5_values_int4(:) #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=1) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=1) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=1) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=1) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=1) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=1) deallocate( values_real8 ) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_STD_I8LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! storage: allocate( hdf5_values_int4(size(values)) ) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,1) ! clear: deallocate( hdf5_values_int4 ) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i1_1d subroutine MDF_Put_Att_i2_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(2), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i2_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT16, 1, values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i2_0d ! *** subroutine MDF_Get_Att_i2_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(2), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i2_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1) :: values_int1 integer(2) :: values_int2 integer(4) :: values_int4 integer(8) :: values_int8 real(4) :: values_real4 real(8) :: values_real8 #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4) :: hdf5_values_int4 #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=2) case ( DFNT_INT16 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=2) case ( DFNT_INT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=2) case ( DFNT_INT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=2) case ( DFNT_FLOAT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=2) case ( DFNT_FLOAT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=2) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,2) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i2_0d subroutine MDF_Put_Att_i2_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(2), intent(in) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i2_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! strore numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT16, size(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! set extent of the data space: call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i2_1d ! *** subroutine MDF_Get_Att_i2_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(2), intent(out) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i2_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4), allocatable :: hdf5_values_int4(:) #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=2) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=2) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=2) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=2) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=2) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=2) deallocate( values_real8 ) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_STD_I16LE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! storage: allocate( hdf5_values_int4(size(values)) ) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,2) ! clear: deallocate( hdf5_values_int4 ) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i2_1d subroutine MDF_Put_Att_i4_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(4), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i4_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT32, 1, values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int((/1/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i4_0d ! *** subroutine MDF_Get_Att_i4_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(4), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i4_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1) :: values_int1 integer(2) :: values_int2 integer(4) :: values_int4 integer(8) :: values_int8 real(4) :: values_real4 real(8) :: values_real8 #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4) :: hdf5_values_int4 #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=4) case ( DFNT_INT16 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=4) case ( DFNT_INT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=4) case ( DFNT_INT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=4) case ( DFNT_FLOAT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=4) case ( DFNT_FLOAT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=4) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int((/1/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,4) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i4_0d subroutine MDF_Put_Att_i4_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(4), intent(in) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_i4_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! strore numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_INT32, size(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! set extent of the data space: call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_INTEGER, int(values), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_i4_1d ! *** subroutine MDF_Get_Att_i4_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer(4), intent(out) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_i4_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(4), allocatable :: hdf5_values_int4(:) #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = int(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = int(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = int(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = int(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = int(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = int(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_INTEGER, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! storage: allocate( hdf5_values_int4(size(values)) ) ! read into integer(4), since no specific routines for kinds 1 and 2 seem available:: call H5ARead_f( hdf5_attr_id, H5T_NATIVE_INTEGER, hdf5_values_int4, int(shape(values),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! convert: values = int(hdf5_values_int4,4) ! clear: deallocate( hdf5_values_int4 ) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_i4_1d subroutine MDF_Put_Att_r4_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(4), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r4_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT32, 1, values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_REAL, values, int((/1/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_r4_0d ! *** subroutine MDF_Get_Att_r4_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(4), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r4_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1) :: values_int1 integer(2) :: values_int2 integer(4) :: values_int4 integer(8) :: values_int8 real(4) :: values_real4 real(8) :: values_real8 #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = real(values_int1,kind=4) case ( DFNT_INT16 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = real(values_int2,kind=4) case ( DFNT_INT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = real(values_int4,kind=4) case ( DFNT_INT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = real(values_int8,kind=4) case ( DFNT_FLOAT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = real(values_real4,kind=4) case ( DFNT_FLOAT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = real(values_real8,kind=4) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read: call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/1/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_r4_0d subroutine MDF_Put_Att_r4_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(4), intent(in) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r4_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! strore numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT32, size(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! set extent of the data space: call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_REAL, values, int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_r4_1d ! *** subroutine MDF_Get_Att_r4_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(4), intent(out) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r4_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = real(values_int1,kind=4) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = real(values_int2,kind=4) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = real(values_int4,kind=4) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = real(values_int8,kind=4) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = real(values_real4,kind=4) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = real(values_real8,kind=4) deallocate( values_real8 ) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_REAL, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read: call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int(shape(values),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_r4_1d subroutine MDF_Put_Att_r8_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(8), intent(in) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r8_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! store numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT64, 1, values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SCALAR_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_DOUBLE, values, int((/1/),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_r8_0d ! *** subroutine MDF_Get_Att_r8_0d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(8), intent(out) :: values integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r8_0d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1) :: values_int1 integer(2) :: values_int2 integer(4) :: values_int4 integer(8) :: values_int8 real(4) :: values_real4 real(8) :: values_real8 #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = real(values_int1,kind=8) case ( DFNT_INT16 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = real(values_int2,kind=8) case ( DFNT_INT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = real(values_int4,kind=8) case ( DFNT_INT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = real(values_int8,kind=8) case ( DFNT_FLOAT32 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = real(values_real4,kind=8) case ( DFNT_FLOAT64 ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = real(values_real8,kind=8) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read: call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int((/1/),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_r8_0d subroutine MDF_Put_Att_r8_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HID_T, HSIZE_T use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE use HDF5, only : H5SCreate_f, H5SClose_f, H5SSet_Extent_Simple_f use HDF5, only : H5S_SCALAR_F, H5S_SIMPLE_F use HDF5, only : H5ACreate_f, H5AClose_f, H5AWrite_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Put_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(8), intent(in) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Put_Att_r8_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfSCAtt integer(hdf4_wpi), external :: sfSNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: iftype integer :: ftype #ifdef with_hdf4 integer :: hdf4_id #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_space_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! increase counter: filep%natt = filep%natt + 1 else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! increase counter: varp%natt = varp%natt + 1 end if ! loop over file types: do iftype = 1, filep%nftype ! current type: ftype = filep%ftypes(iftype) ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! strore numerical attribute: status = sfSNAtt( hdf4_id, trim(name), DFNT_FLOAT64, size(values), values ) if ( status /= SUCCEED ) then write (*,'("writing attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf5_loc_id = filep%hdf5_file_id else hdf5_loc_id = varp%hdf5_dataset_id end if ! data type: call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! data space: call H5SCreate_f( H5S_SIMPLE_F, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! set extent of the data space: call H5SSet_Extent_Simple_f( hdf5_space_id, 1, int(shape(values),kind=HSIZE_T), int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! create attribute; type in file is same as type provided to this routine: call H5ACreate_f( hdf5_loc_id, trim(name), hdf5_type_id, hdf5_space_id, hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! write attribute values: call H5AWrite_f( hdf5_attr_id, H5T_NATIVE_DOUBLE, values, int(shape(values),kind=HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release attribute: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! release data space: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! release data type: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! write attribute: status = NF90_Put_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end do ! file types ! ok status = 0 end subroutine MDF_Put_Att_r8_1d ! *** subroutine MDF_Get_Att_r8_1d( hid, varid, name, values, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f, H5ARead_f use HDF5, only : H5TCopy_f, H5TSet_Size_f, H5TClose_f use HDF5, only : H5T_NATIVE_CHARACTER use HDF5, only : H5T_STD_I8LE, H5T_STD_I16LE, H5T_NATIVE_INTEGER, H5T_STD_I64LE use HDF5, only : H5T_NATIVE_REAL, H5T_NATIVE_DOUBLE #endif #ifdef with_netcdf use NetCDF, only : NF90_Get_Att, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name real(8), intent(out) :: values(:) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Att_r8_1d' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo integer(hdf4_wpi), external :: sfRCAtt integer(hdf4_wpi), external :: sfRNAtt #endif ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp integer :: ftype #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_iatt character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype integer :: hdf4_length integer(1), allocatable :: values_int1(:) integer(2), allocatable :: values_int2(:) integer(4), allocatable :: values_int4(:) integer(8), allocatable :: values_int8(:) real(4), allocatable :: values_real4(:) real(8), allocatable :: values_real8(:) #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id #endif #ifdef with_netcdf integer :: netcdf_varid #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure if possible: if ( varid /= MDF_GLOBAL ) then call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) end if ! select appropriate routine for each type: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then hdf4_id = filep%hdf4_id else hdf4_id = varp%hdf4_sdid end if ! get attribute index given name: hdf4_iatt = sfFAttr( hdf4_id , trim(name) ) if ( hdf4_iatt == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return end if ! get type and length: status = sfGAInfo( hdf4_id, hdf4_iatt, hdf4_name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info")') trim(name); call goErr TRACEBACK; status=1; return end if ! read numerical attribute: select case ( hdf4_xtype ) case ( DFNT_INT8 ) allocate( values_int1(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int1 ) values = real(values_int1,kind=8) deallocate( values_int1 ) case ( DFNT_INT16 ) allocate( values_int2(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int2 ) values = real(values_int2,kind=8) deallocate( values_int2 ) case ( DFNT_INT32 ) allocate( values_int4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int4 ) values = real(values_int4,kind=8) deallocate( values_int4 ) case ( DFNT_INT64 ) allocate( values_int8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_int8 ) values = real(values_int8,kind=8) deallocate( values_int8 ) case ( DFNT_FLOAT32 ) allocate( values_real4(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real4 ) values = real(values_real4,kind=8) deallocate( values_real4 ) case ( DFNT_FLOAT64 ) allocate( values_real8(hdf4_length) ) status = sfRNAtt( hdf4_id, hdf4_iatt, values_real8 ) values = real(values_real8,kind=8) deallocate( values_real8 ) case default write (gol,'("not implemented for hdf4 data type ",i6)') hdf4_xtype TRACEBACK; status=1; return end select if ( status /= SUCCEED ) then write (*,'("reading attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! file id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! data type: call H5TCopy_f( H5T_NATIVE_DOUBLE, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! read: call H5ARead_f( hdf5_attr_id, hdf5_type_id, values, int(shape(values),HSIZE_T), status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! set variable id: if ( varid == MDF_GLOBAL ) then netcdf_varid = NF90_GLOBAL else netcdf_varid = varp%netcdf_varid end if ! read attribute: status = NF90_Get_Att( filep%netcdf_id, netcdf_varid, trim(name), values ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Get_Att_r8_1d ! ******************************************************************** ! *** ! *** inquire ! *** ! ******************************************************************** subroutine MDF_Get_Type( hid, ftype, status ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(out) :: ftype integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Get_Type' ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: iftype ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! check ... if ( filep%nftype /= 1 ) then write (gol,'("mdf file not defined for single type but for ",i6," ...")') filep%nftype; call goErr do iftype = 1, filep%nftype select case ( filep%ftypes(iftype) ) #ifdef with_hdf4 case ( MDF_HDF4 ) write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr #endif #ifdef with_netcdf case ( MDF_NETCDF, MDF_NETCDF4 ) write (gol,'(" netcdf file : ",a)') trim(filep%netcdf_fname); call goErr #endif case default write (gol,'(" (unsupported type)")'); call goErr end select end do TRACEBACK; status=1; return end if ! return single type: ftype = filep%ftypes(1) ! ok status = 0 end subroutine MDF_Get_Type ! *** subroutine MDF_Inquire( hid, status, & nDimensions, nVariables, nAttributes ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(out) :: status integer, intent(out), optional :: nDimensions integer, intent(out), optional :: nVariables integer, intent(out), optional :: nAttributes ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inquire' ! --- local -------------------------------------- type(MDF_File), pointer :: filep ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! return number of dimensions ? if ( present(nDimensions) ) then ! get number of elements in list: call MDF_Dim_List_Inquire( filep%Dim_List, status, n=nDimensions ) IF_NOT_OK_RETURN(status=1) end if ! return number of variables ? if ( present(nVariables) ) then ! get number of elements in list: call MDF_Var_List_Inquire( filep%Var_List, status, n=nVariables ) IF_NOT_OK_RETURN(status=1) end if ! return number of global attributes ? if ( present(nAttributes) ) then ! copy from structure: nAttributes = filep%natt end if ! ok status = 0 end subroutine MDF_Inquire ! *** subroutine MDF_Inq_DimID( hid, name, dimid, status ) ! --- in/out ------------------------------------- integer, intent(in) :: hid character(len=*), intent(in) :: name integer, intent(out) :: dimid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inq_DimID' ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: ndim, idim character(len=LEN_NAME) :: dimname ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! dummy ... dimid = -1 ! number of variables: call MDF_Inquire( hid, status, ndimensions=ndim ) IF_NOT_OK_RETURN(status=1) ! list variables ? if ( ndim > 0 ) then ! loop over variables: do idim = 1, ndim ! get name: call MDF_Inquire_Dimension( hid, idim, status, name=dimname ) IF_NOT_OK_RETURN(status=1) ! similar ? if ( trim(name) == trim(dimname) ) then ! store current id: dimid = idim ! leave: exit end if end do ! variables end if ! check ... if ( dimid < 0 ) then write (gol,'("no dimension `",a,"` found in file : ",a)') trim(name), trim(filep%filename); call goErr TRACEBACK; status=1; return end if ! ok status = 0 end subroutine MDF_Inq_DimID ! *** subroutine MDF_Inquire_Dimension( hid, dimid, status, name, length, unlimited, named ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: dimid integer, intent(out) :: status character(len=*), intent(out), optional :: name integer, intent(out), optional :: length logical, intent(out), optional :: unlimited logical, intent(out), optional :: named ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inquire_Dimension' ! --- local -------------------------------------- type(MDF_File), pointer :: filep type(MDF_Dim), pointer :: dimp ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to dimension structure: call MDF_Dim_List_Get_Pointer( filep%Dim_List, dimid, dimp, status ) IF_NOT_OK_RETURN(status=1) ! return value ? if ( present(name ) ) name = trim(dimp%name) if ( present(length ) ) length = dimp%length if ( present(unlimited) ) unlimited = dimp%unlimited if ( present(named ) ) named = dimp%named ! ok status = 0 end subroutine MDF_Inquire_Dimension ! *** subroutine MDF_Inq_VarID( hid, name, varid, status ) ! --- in/out ------------------------------------- integer, intent(in) :: hid character(len=*), intent(in) :: name integer, intent(out) :: varid integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inq_VarID' ! --- local -------------------------------------- type(MDF_File), pointer :: filep integer :: nvar, ivar character(len=LEN_NAME) :: varname ! --- begin -------------------------------------- ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! dummy ... varid = -1 ! number of variables: call MDF_Inquire( hid, status, nVariables=nvar ) IF_NOT_OK_RETURN(status=1) ! list variables ? if ( nvar > 0 ) then ! loop over variables: do ivar = 1, nvar ! get name: call MDF_Inquire_Variable( hid, ivar, status, name=varname ) IF_NOT_OK_RETURN(status=1) ! similar ? if ( trim(name) == trim(varname) ) then ! store current id: varid = ivar ! leave: exit end if end do ! variables end if ! check ... if ( varid < 0 ) then write (gol,'("no variable `",a,"` found in file : ",a)') trim(name), trim(filep%filename); call goErr TRACEBACK; status=varid; return end if ! ok status = 0 end subroutine MDF_Inq_VarID ! *** subroutine MDF_Inquire_Variable( hid, varid, status, & name, xtype, ndims, dimids, natts, & shp ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer, intent(out) :: status character(len=*), intent(out), optional :: name integer, intent(out), optional :: xtype integer, intent(out), optional :: ndims integer, intent(out), optional :: dimids(:) integer, intent(out), optional :: natts integer, intent(out), optional :: shp(:) ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inquire_Variable' ! --- local -------------------------------------- integer :: ftype type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! return value ? if ( present(name ) ) name = trim(varp%name) if ( present(xtype ) ) xtype = varp%xtype if ( present(ndims ) ) ndims = varp%ndim if ( present(dimids ) ) then if ( size(dimids) /= varp%ndim ) then write (gol,'("size of dimension id array (",i6,") should equal number of dimensions (",i6,")")') size(dimids), varp%ndim; call goErr TRACEBACK; status=1; return end if dimids = varp%dimids(1:varp%ndim) end if if ( present(natts) ) then natts = varp%natt end if ! special: if ( present(shp) ) then if ( size(shp) /= varp%ndim ) then write (gol,'("size of shape array (",i6,") should equal number of dimensions (",i6,")")') size(shp), varp%ndim; call goErr TRACEBACK; status=1; return end if shp = varp%shp(1:varp%ndim) end if ! ok status = 0 end subroutine MDF_Inquire_Variable ! *** subroutine MDF_Inquire_Attribute( hid, varid, name, status, xtype, length ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AOpen_By_Name_f, H5AClose_f use HDF5, only : H5AGet_Type_f use HDF5, only : H5TGet_Native_Type_f, H5TClose_f use HDF5, only : H5T_DIR_ASCEND_F use HDF5, only : H5AGet_Space_f use HDF5, only : H5SGet_Simple_Extent_Dims_f, H5SClose_f #endif #ifdef with_netcdf use NetCDF, only : NF90_Inquire_Attribute use NetCDF, only : NF90_GLOBAL use NetCDF, only : NF90_CHAR, NF90_BYTE, NF90_SHORT, NF90_INT, NF90_FLOAT, NF90_DOUBLE #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid character(len=*), intent(in) :: name integer, intent(out) :: status integer, intent(out), optional :: xtype integer, intent(out), optional :: length ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inquire_Attribute' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfFAttr integer(hdf4_wpi), external :: sfGAInfo #endif ! --- local -------------------------------------- integer :: ftype type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp #ifdef with_hdf4 integer :: hdf4_id integer :: hdf4_attind character(len=LEN_NAME) :: hdf4_name integer :: hdf4_xtype #endif #ifdef with_hdf5_beta integer(HID_T) :: hdf5_loc_id character(len=LEN_NAME) :: hdf5_obj_name integer(HID_T) :: hdf5_attr_id integer(HID_T) :: hdf5_type_id integer(HID_T) :: hdf5_space_id integer(HSIZE_T) :: hdf5_dims(MAX_RANK) integer(HSIZE_T) :: hdf5_maxdims(MAX_RANK) integer :: hdf5_rank #endif #ifdef with_netcdf integer :: netcdf_id #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! select appropriate routine: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! file id: hdf4_id = filep%hdf4_id else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! variable id: hdf4_id = varp%hdf4_sdid end if ! get attribute number given name: hdf4_attind = sfFAttr( hdf4_id, trim(name) ) if ( hdf4_attind == FAIL ) then write (gol,'("finding attribute `",a,"`")') trim(name); call goErr TRACEBACK; status=1; return status=-1; return end if ! extract info: status = sfGAInfo( hdf4_id, hdf4_attind, hdf4_name, hdf4_xtype, length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info:")'); call goErr write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr if ( varid /= MDF_GLOBAL ) then write (gol,'(" variable name : ",a)') trim(varp%name); call goErr end if write (gol,'(" hdf4 attribute index : ",i6)') hdf4_attind; call goErr TRACEBACK; status=1; return end if ! return type ? if ( present(xtype) ) then ! convert: select case ( hdf4_xtype ) case ( DFNT_CHAR ) ; xtype = MDF_CHAR case ( DFNT_INT8 ) ; xtype = MDF_BYTE case ( DFNT_INT16 ) ; xtype = MDF_SHORT case ( DFNT_INT32 ) ; xtype = MDF_INT case ( DFNT_FLOAT32 ) ; xtype = MDF_FLOAT case ( DFNT_FLOAT64 ) ; xtype = MDF_DOUBLE case default write (gol,'("unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! file id: hdf5_loc_id = filep%hdf5_file_id hdf5_obj_name = '.' else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! dataset id: hdf5_loc_id = varp%hdf5_dataset_id hdf5_obj_name = '.' end if ! open attribute: call H5AOpen_By_Name_f( hdf5_loc_id, hdf5_obj_name, trim(name), hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) ! get type ? if ( present(xtype) ) then ! get data type id: call H5AGet_Type_f( hdf5_attr_id, hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) ! convert to mdf type code: call HDF5_Get_MDF_Type( hdf5_type_id, xtype, status ) IF_NOT_OK_RETURN(status=1) ! release: call H5TClose_f( hdf5_type_id, status ) IF_NOT_OK_RETURN(status=1) end if ! return length ? if ( present(length) ) then ! get data space id: call H5AGet_Space_f( hdf5_attr_id, hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) ! get dimensions: call H5SGet_Simple_Extent_Dims_f( hdf5_space_id, hdf5_dims, hdf5_maxdims, status ) if ( status < 0 ) then write (gol,'("could not extract dimensions for attribute : ",a)') trim(name); call goErr TRACEBACK; status=1; return else hdf5_rank = status end if ! extract length: if ( hdf5_rank == 0 ) then length = 1 ! scalar else if ( hdf5_rank == 1 ) then length = hdf5_dims(1) ! 1d array else write (gol,'("hdf5 attributes not supported for rank ",i6)') hdf5_rank; call goErr TRACEBACK; status=1; return endif ! release: call H5SClose_f( hdf5_space_id, status ) IF_NOT_OK_RETURN(status=1) end if ! release: call H5AClose_f( hdf5_attr_id, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! global or variable attribute ? if ( varid == MDF_GLOBAL ) then ! file id: netcdf_id = NF90_GLOBAL else ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! variable id: netcdf_id = varp%netcdf_varid end if ! get type etc: status = NF90_Inquire_Attribute( filep%netcdf_id, netcdf_id, trim(name), & xtype=xtype, len=length ) IF_NF90_NOT_OK_RETURN(status=1) ! return type ? if ( present(xtype) ) then ! convert: select case ( xtype ) case ( NF90_CHAR ) ; xtype = MDF_CHAR case ( NF90_BYTE ) ; xtype = MDF_BYTE case ( NF90_SHORT ) ; xtype = MDF_SHORT case ( NF90_INT ) ; xtype = MDF_INT case ( NF90_FLOAT ) ; xtype = MDF_FLOAT case ( NF90_DOUBLE ) ; xtype = MDF_DOUBLE case default write (gol,'("unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select end if #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Inquire_Attribute ! *** subroutine MDF_Inq_AttName( hid, varid, attnum, name, status ) #ifdef with_hdf5_beta use HDF5, only : HSIZE_T use HDF5, only : H5AGet_Name_By_Idx_f use HDF5, only : H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F #endif #ifdef with_netcdf use NetCDF, only : NF90_Inq_AttName, NF90_GLOBAL #endif ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: varid integer, intent(in) :: attnum ! 1,..,natt character(len=*), intent(out) :: name integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Inq_AttName' ! --- external ------------------------------- #ifdef with_hdf4 integer(hdf4_wpi), external :: sfGAInfo #endif ! --- local -------------------------------------- integer :: ftype type(MDF_File), pointer :: filep type(MDF_Var), pointer :: varp #ifdef with_hdf4 integer :: hdf4_xtype integer :: hdf4_length #endif #ifdef with_hdf5_beta integer(HSIZE_T) :: hdf5_idx #endif ! --- begin -------------------------------------- ! single type: call MDF_Get_Type( hid, ftype, status ) IF_NOT_OK_RETURN(status=1) ! pointer to file structure: call MDF_File_List_Get_Pointer( File_List, hid, filep, status ) IF_NOT_OK_RETURN(status=1) ! global attribute ? if ( varid == MDF_GLOBAL ) then ! select appropriate routine: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! extract info: status = sfGAInfo( filep%hdf4_id, attnum-1, name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info:")'); call goErr write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" attribute number : ",i6)') attnum; call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! open attribute: call H5AGet_Name_By_Idx_f( filep%hdf5_file_id, '.', & H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, int(attnum-1,HSIZE_T), & name, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! get name: status = NF90_Inq_AttName( filep%netcdf_id, NF90_GLOBAL, attnum, name ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select else ! variable attribute ! pointer to variable structure: call MDF_Var_List_Get_Pointer( filep%Var_List, varid, varp, status ) IF_NOT_OK_RETURN(status=1) ! select appropriate routine: select case ( ftype ) #ifdef with_hdf4 ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! extract info: status = sfGAInfo( varp%hdf4_sdid, attnum-1, name, hdf4_xtype, hdf4_length ) if ( status /= SUCCEED ) then write (gol,'("getting attribute info:")'); call goErr write (gol,'(" hdf4 file : ",a)') trim(filep%hdf4_fname); call goErr write (gol,'(" variable name : ",a)') trim(varp%name); call goErr write (gol,'(" attribute number : ",i6)') attnum; call goErr TRACEBACK; status=1; return end if #endif #ifdef with_hdf5_beta ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_HDF5 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! index number: hdf5_idx = attnum-1 ! open attribute: call H5AGet_Name_By_Idx_f( varp%hdf5_dataset_id, '.', & H5_INDEX_CRT_ORDER_F, H5_ITER_NATIVE_F, hdf5_idx, & name, status ) IF_NOT_OK_RETURN(status=1) #endif #ifdef with_netcdf ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case ( MDF_NETCDF, MDF_NETCDF4 ) ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ ! get name: status = NF90_Inq_AttName( filep%netcdf_id, varp%netcdf_varid, attnum, name ) IF_NF90_NOT_OK_RETURN(status=1) #endif ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ case default ! ~~~~~~~~~~~~~~~~~~~~~~~~~~ write (gol,'("unsupported filetype : ",i6)') ftype; call goErr write (gol,'(" filetype name : ",a)') trim(MDF_FILETYPE_NAME(ftype)); call goErr write (gol,'(" compiled without macro `with_*` defined ?")'); call goErr TRACEBACK; status=1; return end select end if ! global or variable attribute ! ok status = 0 end subroutine MDF_Inq_AttName ! ******************************************************************** ! *** ! *** show content ! *** ! ******************************************************************** subroutine MDF_Show( filename, status, filetype, show_data ) ! --- in/out ------------------------------------- character(len=*), intent(in) :: filename integer, intent(out) :: status integer, intent(in), optional :: filetype logical, intent(in), optional :: show_data ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Show' ! --- local -------------------------------------- integer :: l integer :: ftype logical :: do_show_data integer :: hid integer :: ndim, idim integer :: nvar, ivar integer :: natt logical :: named character(len=LEN_NAME) :: ftype_name character(len=LEN_NAME) :: name integer :: length logical :: unlimited logical :: isfirst integer :: xtype integer :: dimids(MAX_RANK) integer :: shp(MAX_RANK) character(len=LEN_LINE) :: line character(len=LEN_NAME) :: val ! --- begin -------------------------------------- ! show data ? do_show_data = .false. if ( present(show_data) ) do_show_data = show_data ! guess file type by default, or set to optional argument: ftype = MDF_NONE if ( present(filetype) ) ftype = filetype ! guess file type ? if ( ftype == MDF_NONE ) then ! length of filename: l = len_trim(filename) ! guess ... if ( (l > 3) .and. (filename(l-2:l) == '.nc') ) then ftype = MDF_NETCDF else if ( (l > 3) .and. (filename(l-2:l) == '.h5') ) then ftype = MDF_HDF5 else if ( (l > 4) .and. (filename(l-3:l) == '.hdf') ) then ftype = MDF_HDF4 else write (gol,'("could not guess file type from file name:")'); call goErr write (gol,'(" ",a)') trim(filename); call goErr TRACEBACK; status=1; return end if end if ! filetype name: ftype_name = trim(MDF_FILETYPE_NAME(ftype)) #ifdef with_netcdf if ( ftype == MDF_NETCDF ) then call NetCDF_Get_FileType( trim(filename), ftype_name, status ) IF_NOT_OK_RETURN(status=1) end if #endif ! open file: call MDF_Open( trim(filename), ftype, MDF_READ, hid, status ) IF_NOT_OK_RETURN(status=1) ! header line: ! { write (gol,'(a," ",a," {")') trim(ftype_name), trim(filename); call goPr ! number of dimensions: call MDF_Inquire( hid, status, nDimensions=ndim ) IF_NOT_OK_RETURN(status=1) ! list dimensions ? if ( ndim > 0 ) then ! init flag: isfirst = .true. ! loop over dimensions: do idim = 1, ndim ! write lines: ! x = 4 ; ! t = UNLIMITED ; // (5 currently) ! ... ! get name and length: call MDF_Inquire_Dimension( hid, idim, status, name=name, named=named, & length=length, unlimited=unlimited ) IF_NOT_OK_RETURN(status=1) ! skip ? if ( .not. named ) cycle ! display header ? if ( isfirst ) then write (gol,'("dimensions:")'); call goPr isfirst = .false. end if ! display: if ( unlimited ) then write (val,*) length val = adjustl(val) write (gol,'(" ",a," = UNLIMITED ; // (",a," currently)")') trim(name), trim(val); call goPr else if ( named ) then write (gol,'(" ",a," = ",i6," ;")') trim(name), length; call goPr end if end do ! dimensions end if ! ndim > 0 ! number of variables: call MDF_Inquire( hid, status, nVariables=nvar ) IF_NOT_OK_RETURN(status=1) ! list variables ? if ( nvar > 0 ) then ! start: write (gol,'("variables:")'); call goPr ! loop over variables: do ivar = 1, nvar ! write lines: ! float afield(y, x) ; ! afield:unit = "m" ; ! ... ! get name etc: call MDF_Inquire_Variable( hid, ivar, status, name=name, xtype=xtype, ndims=ndim, natts=natt ) IF_NOT_OK_RETURN(status=1) ! get dimension id's now the number is known: call MDF_Inquire_Variable( hid, ivar, status, dimids=dimids(1:ndim) ) IF_NOT_OK_RETURN(status=1) ! start line with type and variable name: write (line,'(" ",a," ",a,"(")') trim(MDF_DATATYPE_NAME(xtype)), trim(name) ! loop over dimensions: shp = 1 do idim = 1, ndim ! get dimension name: call MDF_Inquire_Dimension( hid, dimids(idim), status, name=name, named=named, & length=length, unlimited=unlimited ) IF_NOT_OK_RETURN(status=1) ! add to line: if ( idim > 1 ) line = trim(line)//',' ! name or number ... if ( named ) then line = trim(line)//' '//trim(name) else write (val,*) length line = trim(line)//' '//adjustl(val) if (unlimited) line = trim(line)//'/Inf' end if ! store for show_data: shp(idim) = length end do ! close line: line = trim(line)//' ) ;' ! display dimension name(dims) line: write (gol,'(a)') trim(line); call goPr ! write attributes: call MDF_Show_Attributes( hid, ivar, natt, status ) IF_NOT_OK_RETURN(status=1) ! show data ? if ( do_show_data ) then ! display data: call MDF_Show_Data( hid, ivar, xtype, ndim, shp, status ) IF_NOT_OK_RETURN(status=1) end if end do ! variables end if ! nvar > 0 ! number of global attributes: call MDF_Inquire( hid, status, nAttributes=natt ) IF_NOT_OK_RETURN(status=1) ! global attributes ? if ( natt > 0 ) then ! intro: write (gol,'("")'); call goPr write (gol,'("// global attributes:")'); call goPr ! display attributes: call MDF_Show_Attributes( hid, MDF_GLOBAL, natt, status ) IF_NOT_OK_RETURN(status=1) end if ! closure: ! } write (gol,'("}")'); call goPr ! close file: call MDF_Close( hid, status ) IF_NOT_OK_RETURN(status=1) ! ok status = 0 end subroutine MDF_Show ! *** subroutine MDF_Show_Attributes( hid, ivar, natt, status ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: ivar integer, intent(in) :: natt integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Show_Attributes' ! --- local -------------------------------------- integer :: l integer :: iatt character(len=LEN_NAME) :: name integer :: length integer :: xtype character(len=LEN_LINE) :: line character(len=LEN_NAME) :: val integer :: ival integer(4), allocatable :: values_i4(:) real(8), allocatable :: values_r8(:) ! --- begin -------------------------------------- ! loop over attributes: do iatt = 1, natt ! get name: call MDF_Inq_AttName( hid, ivar, iatt, name, status ) IF_NOT_OK_RETURN(status=1) ! get type and length: call MDF_Inquire_Attribute( hid, ivar, name, status, xtype=xtype, length=length ) IF_NOT_OK_RETURN(status=1) !! info ... !write (gol,'(" ",a," <",a,"> ",i4," ;")') trim(name), trim(MDF_DATATYPE_NAME(xtype)), length; call goPr ! different per type ... select case ( xtype ) !character values case ( MDF_CHAR ) ! get value: call MDF_Get_Att( hid, ivar, name, line, status ) if (status/=0) then ! somthing went wrong (attribute too large ?) line = '...' else ! ok; but not too much to the screen ... if ( len_trim(line) > 400 ) line = line(1:400)//'...' end if ! display .. ! variable rank etc: write (gol,'(" ",a," = """,a,""" ;")') trim(name), trim(line); call goPr !integer values case ( MDF_BYTE, MDF_SHORT, MDF_INT ) ! storage: allocate( values_i4(length) ) ! fill: call MDF_Get_Att( hid, ivar, name, values_i4, status ) if (status/=0) then ! somthing went wrong (attribute too large ?) line = '...' else ! loop over values: line = '' do ival = 1, min(length,50) ! add seperation if necessary: if ( ival > 1 ) line = trim(line)//',' ! dump value: write (val,*) values_i4(ival) ! shift to left: val = adjustl(val) ! add to line: line = trim(line)//' '//trim(val) ! add type indicator if necessary: if ( xtype == MDF_BYTE ) line = trim(line)//'b' if ( xtype == MDF_SHORT ) line = trim(line)//'s' end do if ( ival < length ) line=trim(line)//' ...' end if ! display: write (gol,'(" ",a," =",a)') trim(name), trim(line); call goPr ! clear: deallocate( values_i4 ) !floating point values case ( MDF_FLOAT, MDF_DOUBLE ) ! storage: allocate( values_r8(length) ) ! fill: call MDF_Get_Att( hid, ivar, name, values_r8, status ) if (status/=0) then ! somthing went wrong (attribute too large ?) line = '...' else ! loop over values: line = '' do ival = 1, min(length,50) ! add seperation if necessary: if ( ival > 1 ) line = trim(line)//',' ! dump value: write (val,*) values_r8(ival) ! remove tailing zeros: do l = len_trim(val), 1, -1 if ( val(l:l) /= '0' ) exit val(l:l) = ' ' end do ! shift to left: val = adjustl(val) ! add to line: line = trim(line)//' '//trim(val) ! add type indicator if necessary: if ( xtype == MDF_FLOAT ) line = trim(line)//'f' end do if ( ival < length ) line=trim(line)//' ...' end if ! display: write (gol,'(" ",a," =",a)') trim(name), trim(line); call goPr ! clear: deallocate( values_r8 ) !other ... case default write (gol,'("INTERNAL - unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select end do ! ok status = 0 end subroutine MDF_Show_Attributes ! *** subroutine MDF_Show_Data( hid, ivar, xtype, rank, shp, status ) ! --- in/out ------------------------------------- integer, intent(in) :: hid integer, intent(in) :: ivar integer, intent(in) :: xtype integer, intent(in) :: rank integer, intent(in) :: shp(MAX_RANK) integer, intent(out) :: status ! --- const -------------------------------------- character(len=*), parameter :: rname = mname//'/MDF_Show_Data' ! --- local -------------------------------------- character(len=LEN_LINE) :: line character(len=LEN_NAME) :: val integer :: l integer :: i1,i2,i3,i4,i5,i6,i7 integer(4), allocatable :: values_i4(:,:,:,:,:,:,:) real(8), allocatable :: values_r8(:,:,:,:,:,:,:) character(len=shp(1)), allocatable :: values_c (:,:,:,:,:,:) ! --- begin -------------------------------------- ! per type: select case ( xtype ) ! character values: case ( MDF_CHAR ) ! storage: allocate( values_c(shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status ) IF_NOT_OK_RETURN(status=1) ! read: select case ( rank ) case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_c(1,1,1,1,1,1), status, count=shp(1:rank) ) case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_c(:,1,1,1,1,1), status, count=shp(1:rank) ) case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,1,1,1,1), status, count=shp(1:rank) ) case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,1,1,1), status, count=shp(1:rank) ) case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,1,1), status, count=shp(1:rank) ) case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,:,1), status, count=shp(1:rank) ) case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_c(:,:,:,:,:,:), status, count=shp(1:rank) ) case default write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr TRACEBACK; status=1; return end select IF_NOT_OK_RETURN(status=1) ! loop over higher dimensions: do i7 = 1, shp(7) do i6 = 1, shp(6) do i5 = 1, shp(5) do i4 = 1, shp(4) do i3 = 1, shp(3) ! plot index of higer dimensions ? if ( rank > 2 ) then line = ' (:,:' if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3 if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4 if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5 if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6 if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7 line = trim(line)//')' write (gol,'(a)') trim(line); call goPr end if ! display matrix: do i2 = 1, shp(2) ! copy value: line = values_c(i2,i3,i4,i5,i6,i7) ! display: write (gol,'(" `",a,"` ;")') trim(line); call goPr end do ! i2 end do ! i3 end do ! i4 end do ! i5 end do ! i6 end do ! i7 ! clear: deallocate( values_c, stat=status ) IF_NOT_OK_RETURN(status=1) ! integer values: case ( MDF_BYTE, MDF_SHORT, MDF_INT ) ! storage: allocate( values_i4(shp(1),shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status ) IF_NOT_OK_RETURN(status=1) ! read: select case ( rank ) case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,1,1,1,1,1,1), status ) case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,1,1,1,1,1), status ) case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,1,1,1,1), status ) case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,1,1,1), status ) case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,1,1), status ) case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,:,1), status ) case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_i4(:,:,:,:,:,:,:), status ) case default write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr TRACEBACK; status=1; return end select IF_NOT_OK_RETURN(status=1) ! loop over higher dimensions: do i7 = 1, shp(7) do i6 = 1, shp(6) do i5 = 1, shp(5) do i4 = 1, shp(4) do i3 = 1, shp(3) ! plot index of higer dimensions ? if ( rank > 2 ) then line = ' (:,:' if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3 if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4 if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5 if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6 if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7 line = trim(line)//')' write (gol,'(a)') trim(line); call goPr end if ! display matrix: do i2 = 1, shp(2) line = '' do i1 = 1, shp(1) !! not all ? !if ( i1 > 10 ) then ! line = trim(line)//' ...' ! exit !end if ! add seperation if necessary: if ( i1 > 1 ) line = trim(line)//',' ! dump value: write (val,*) values_i4(i1,i2,i3,i4,i5,i6,i7) ! shift to left: val = adjustl(val) ! add to line: line = trim(line)//' '//trim(val) ! add type indicator if necessary: if ( xtype == MDF_BYTE ) line = trim(line)//'b' if ( xtype == MDF_SHORT ) line = trim(line)//'s' ! line too long already ? if ( len_trim(line) > 72 ) then ! display: write (gol,'(" ",a," ;")') trim(line); call goPr ! empty: line = '' end if end do ! i1 ! display: if ( len_trim(line) > 0 ) then write (gol,'(" ",a," ;")') trim(line); call goPr end if end do ! i2 end do ! i3 end do ! i4 end do ! i5 end do ! i6 end do ! i7 ! clear: deallocate( values_i4, stat=status ) IF_NOT_OK_RETURN(status=1) ! real values: case ( MDF_FLOAT, MDF_DOUBLE ) ! storage: allocate( values_r8(shp(1),shp(2),shp(3),shp(4),shp(5),shp(6),shp(7)), stat=status ) IF_NOT_OK_RETURN(status=1) ! read: select case ( rank ) case ( 1 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,1,1,1,1,1,1), status ) case ( 2 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,1,1,1,1,1), status ) case ( 3 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,1,1,1,1), status ) case ( 4 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,1,1,1), status ) case ( 5 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,1,1), status ) case ( 6 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,:,1), status ) case ( 7 ) ; call MDF_Get_Var( hid, ivar, values_r8(:,:,:,:,:,:,:), status ) case default write (gol,'("INTERNAL - unsupported rank : ",i6)') rank; call goErr TRACEBACK; status=1; return end select IF_NOT_OK_RETURN(status=1) ! loop over higher dimensions: do i7 = 1, shp(7) do i6 = 1, shp(6) do i5 = 1, shp(5) do i4 = 1, shp(4) do i3 = 1, shp(3) ! plot index of higer dimensions ? if ( rank > 2 ) then line = ' (:,:' if ( rank >= 3 ) write (line,'(a,",",i4)') trim(line), i3 if ( rank >= 4 ) write (line,'(a,",",i4)') trim(line), i4 if ( rank >= 5 ) write (line,'(a,",",i4)') trim(line), i5 if ( rank >= 6 ) write (line,'(a,",",i4)') trim(line), i6 if ( rank >= 7 ) write (line,'(a,",",i4)') trim(line), i7 line = trim(line)//')' write (gol,'(a)') trim(line); call goPr end if ! display matrix: do i2 = 1, shp(2) line = '' do i1 = 1, shp(1) !! not all ? !if ( i1 > 10 ) then ! line = trim(line)//' ...' ! exit !end if ! add seperation if necessary: if ( i1 > 1 ) line = trim(line)//',' ! dump value: write (val,*) values_r8(i1,i2,i3,i4,i5,i6,i7) ! remove tailing zeros: do l = len_trim(val), 1, -1 if ( val(l:l) /= '0' ) exit val(l:l) = ' ' end do ! shift to left: val = adjustl(val) ! add to line: line = trim(line)//' '//trim(val) ! add type indicator if necessary: if ( xtype == MDF_FLOAT ) line = trim(line)//'f' ! line too long already ? if ( len_trim(line) > 72 ) then ! display: write (gol,'(" ",a," ;")') trim(line); call goPr ! empty: line = '' end if end do ! i1 ! display: if ( len_trim(line) > 0 ) then write (gol,'(" ",a," ;")') trim(line); call goPr end if end do ! i2 end do ! i3 end do ! i4 end do ! i5 end do ! i6 end do ! i7 ! clear: deallocate( values_r8, stat=status ) IF_NOT_OK_RETURN(status=1) case default write (gol,'("INTERNAL - unsupported data type : ",i6)') xtype; call goErr TRACEBACK; status=1; return end select ! ok status = 0 end subroutine MDF_Show_Data end module MDF