! $Id: cx_hdf4_mod.f90 3400 2019-07-05 20:47:31Z heidinger $ !-------------------------------------------------------------------------------------- ! Clouds from AVHRR Extended (CLAVR-x) 1b PROCESSING SOFTWARE Version 6.0 ! ! NAME: hdf_params.f90 (src) ! HDF_PARAMS (program) ! ! PURPOSE: This module contains routines used to read and write to the hdf ! output files from CLAVR-X ! ! DESCRIPTION: ! ! AUTHORS: ! Andrew Heidinger, Andrew.Heidinger@noaa.gov ! ! COPYRIGHT ! (c) This code is copyrighted by the author and all NOAA restrictions apply ! ! Dependencies: (The following are names of other CLAVR-x modules) ! CONSTANTS_MOD ! HDF_MOD ! SCALING_PARAMETERS_MOD ! ! Calling Sequence: ! use HDF_PARAMS ! ! Public Routines within this module ! SCALE_VECTOR_I1_RANK1 ! SCALE_VECTOR_I1_RANK2 ! SCALE_VECTOR_I1_RANK3 ! SCALE_VECTOR_I2_RANK1 ! SCALE_VECTOR_I2_RANK2 ! SCALE_VECTOR_I2_RANK3 ! UNSCALE_VECTOR_I1_RANK1 ! WRITE_CLAVRX_HDF4_SDS ! HDF_TSTAMP ! WRITE_CLAVRX_HDF_GLOBAL_ATTRIBUTES ! READ_CLAVRX_HDF_GLOBAL_ATTRIBUTES ! READ_CLAVRX_HDF4_SDS_RANK1 ! !-------------------------------------------------------------------------------------- module CX_HDF4_MOD use HDF, only: & DFNT_INT16 & , DFNT_CHAR8 & , DFNT_FLOAT32 & , DFNT_FLOAT64 & , DFNT_INT32 & , DFNT_INT8 & , DFACC_READ & , FAIL & , SUCCEED & , MAX_RANK_HDF & , DFNT_CHAR & , DFNT_FLOAT64 & , DFNT_UINT8 & , DFNT_UINT16 & , DFNT_UINT32 implicit none private private:: CHECK_EDGE_VS_OUTPUT_SHAPE public:: SCALE_VECTOR_I1_RANK1, & SCALE_VECTOR_I1_RANK2, & SCALE_VECTOR_I1_RANK3, & SCALE_VECTOR_I2_RANK1, & SCALE_VECTOR_I2_RANK2, & SCALE_VECTOR_I2_RANK3, & UNSCALE_VECTOR_I1_RANK1, & WRITE_CLAVRX_HDF4_SDS, & READ_CLAVRX_HDF4_SDS_RANK1 public:: OPEN_FILE_HDF_READ public:: HDF_SDS_DIMENSIONS_READER public:: HDF_SDS_READER public:: HDF_SDS_ATTRIBUTE_READER public:: CLOSE_FILE_HDF_READ public:: READ_CLAVRX_HDF_SDS_1D public:: READ_CLAVRX_HDF_SDS_2D !public:: READ_CLAVRX_HDF_SDS_3D public:: WRITE_CLAVRX_HDF_SDS_1D public:: WRITE_CLAVRX_HDF_SDS_2D public:: WRITE_CLAVRX_HDF_SDS_3D public:: READ_HDF_GLOBAL_ATTRIBUTE_NUM public:: READ_HDF_GLOBAL_ATTRIBUTE_STR interface HDF_SDS_READER module procedure READ_HDF_SDS_INT8_1D, & READ_HDF_SDS_INT16_1D, & READ_HDF_SDS_INT32_1D, & READ_HDF_SDS_FLOAT32_1D, & READ_HDF_SDS_FLOAT64_1D, & READ_HDF_SDS_INT8_2D, & READ_HDF_SDS_INT16_2D, & READ_HDF_SDS_INT32_2D, & READ_HDF_SDS_FLOAT32_2D, & READ_HDF_SDS_FLOAT64_2D, & READ_HDF_SDS_INT8_3D, & READ_HDF_SDS_INT16_3D, & READ_HDF_SDS_INT32_3D, & READ_HDF_SDS_FLOAT32_3D, & READ_HDF_SDS_FLOAT64_3D end interface interface HDF_SDS_ATTRIBUTE_READER module procedure READ_HDF_ATTRIBUTE_CHAR8_SCALAR, & READ_HDF_ATTRIBUTE_INT8_SCALAR, & READ_HDF_ATTRIBUTE_INT16_SCALAR, & READ_HDF_ATTRIBUTE_INT32_SCALAR, & READ_HDF_ATTRIBUTE_FLOAT32_SCALAR, & READ_HDF_ATTRIBUTE_FLOAT64_SCALAR, & READ_HDF_ATTRIBUTE_INT8_VECTOR, & READ_HDF_ATTRIBUTE_INT16_VECTOR, & READ_HDF_ATTRIBUTE_INT32_VECTOR, & READ_HDF_ATTRIBUTE_FLOAT32_VECTOR, & READ_HDF_ATTRIBUTE_FLOAT64_VECTOR end interface interface WRITE_CLAVRX_HDF4_SDS module procedure & WRITE_CLAVRX_HDF4_SDS_RANK1, & WRITE_CLAVRX_HDF4_SDS_RANK2, & WRITE_CLAVRX_HDF4_SDS_RANK3 end interface interface WRITE_CLAVRX_HDF_SDS module procedure & WRITE_CLAVRX_HDF_SDS_1D, & WRITE_CLAVRX_HDF_SDS_2D, & WRITE_CLAVRX_HDF_SDS_3D end interface !---- begin module variable definition character(len=256), save, public:: renav_data_from character(len=11), parameter :: EXE_PROMPT = 'CX_HDF4_MOD' !---- CONSTANTS_MOD integer, parameter, public:: int1 = selected_int_kind(1) integer, parameter, public:: int2 = selected_int_kind(3) integer, parameter, public:: int4 = selected_int_kind(8) integer, parameter, public:: int8 = selected_int_kind(10) integer, parameter, public:: real4 = selected_real_kind(6,37) integer, parameter, public:: real8 = selected_real_kind(15,307) real (kind=real4), parameter, public:: Missing_Value_Real4 = -999.0 real (kind=real8), parameter, public:: Missing_Value_Real8 = -999.0 integer(kind=int1), parameter, public:: Missing_Value_Int1 = -128!_int1 integer(kind=int2), parameter, public:: Missing_Value_Int2 = -32768!_int2 integer(kind=int4), parameter, public:: Missing_Value_Int4 = -999!_int4 real(kind=real4), parameter, public:: No_Attribute_Missing_Value = -888.0 integer(kind=int4), parameter, public:: one_byte_max = 127, & !(2**8)/2 -1 one_byte_min = -127 !-(2**8)/2 integer(kind=int4), parameter, public:: two_byte_max = 32767, & !(2**15)/2 - 1 two_byte_min = -32767 !-(2**15)/2 !--- scaling options integer(kind=int1), parameter, public:: NO_SCALING = 0_int1 integer(kind=int1), parameter, public:: LINEAR_SCALING = 1_int1 integer(kind=int1), parameter, public:: LOG10_SCALING = 2_int1 integer(kind=int1), parameter, public:: SQUARE_ROOT_SCALING = 3_int1 real, parameter, private:: DEFAULT_MISSING_VALUE= MISSING_VALUE_real4 ! HDF function declarations integer(kind=int4), external:: sfcreate, sfdimid, sfsdmname, sfwdata, sfendacc, & sfscatt, sfsnatt, sfschnk, sfselect, sfn2index, & sfrnatt,sfrcatt,sffattr,sfrdata,sfginfo, sfstart, & sfend contains !----------------------------------------------------------------------------------------------------- ! VECTOR SCALING ROUTINES ! ! iscaled = 0 = no scaling ! 1 = linear ! 2 = log10 ! 3 = sqrt !----------------------------------------------------------------------------------------------------- subroutine SCALE_VECTOR_I1_RANK1(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i1) real, dimension(:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int1), dimension(:), intent(out):: temp_i1 real, dimension(size(temp_r4,1)):: scratch_r4 scratch_r4 = 0.0 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + scratch_r4 * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where temp_i1 = int(real(ONE_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + sqrt(scratch_r4) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i1 = MISSING_VALUE_INT1 endwhere end subroutine SCALE_VECTOR_I1_RANK1 subroutine SCALE_VECTOR_I1_RANK2(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i1) real, dimension(:,:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int1), dimension(:,:), intent(out):: temp_i1 real, dimension(size(temp_r4,1),size(temp_r4,2)):: scratch_r4 scratch_r4 = 0.0 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + scratch_r4 * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where temp_i1 = int(real(ONE_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + sqrt(scratch_r4) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i1 = MISSING_VALUE_INT1 endwhere end subroutine SCALE_VECTOR_I1_RANK2 subroutine SCALE_VECTOR_I1_RANK3(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i1) real, dimension(:,:,:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int1), dimension(:,:,:), intent(out):: temp_i1 real, dimension(size(temp_r4,1),size(temp_r4,2),size(temp_r4,3)):: scratch_r4 scratch_r4 = 0.0 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + scratch_r4 * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where temp_i1 = int(real(ONE_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i1 = int(real(ONE_BYTE_MIN) + sqrt(scratch_r4) * real(ONE_BYTE_MAX - ONE_BYTE_MIN),kind=int1) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i1 = MISSING_VALUE_INT1 endwhere end subroutine SCALE_VECTOR_I1_RANK3 subroutine SCALE_VECTOR_I2_RANK1(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i2) real, dimension(:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int2), dimension(:), intent(out):: temp_i2 real, dimension(size(temp_r4,1)):: scratch_r4 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + scratch_r4 * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where temp_i2 = int(real(TWO_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + sqrt(scratch_r4) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i2 = MISSING_VALUE_INT2 endwhere end subroutine SCALE_VECTOR_I2_RANK1 subroutine SCALE_VECTOR_I2_RANK2(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i2) real, dimension(:,:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int2), dimension(:,:), intent(out):: temp_i2 real, dimension(size(temp_r4,1),size(temp_r4,2)):: scratch_r4 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + scratch_r4 * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where !temp_i2 = TWO_BYTE_MIN + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & ! (unscaled_max - unscaled_min)) * (TWO_BYTE_MAX - TWO_BYTE_MIN) temp_i2 = int(real(TWO_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + sqrt(scratch_r4) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i2 = MISSING_VALUE_INT2 endwhere end subroutine SCALE_VECTOR_I2_RANK2 subroutine SCALE_VECTOR_I2_RANK3(temp_r4,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_i2) real, dimension(:,:,:), intent(in):: temp_r4 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int2), dimension(:,:,:), intent(out):: temp_i2 real, dimension(size(temp_r4,1),size(temp_r4,2),size(temp_r4,3)):: scratch_r4 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + scratch_r4 * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- log10 if (iscaled == 2) then scratch_r4 = unscaled_missing where(temp_r4 > 0.0) scratch_r4 = log10(temp_r4) end where temp_i2 = int(real(TWO_BYTE_MIN) + ((max(unscaled_min,min(unscaled_max,scratch_r4)) - unscaled_min)/ & (unscaled_max - unscaled_min)) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,(temp_r4 - unscaled_min)/(unscaled_max - unscaled_min))) temp_i2 = int(real(TWO_BYTE_MIN) + sqrt(scratch_r4) * real(TWO_BYTE_MAX - TWO_BYTE_MIN),kind=int2) endif !--- set scaled missing values where (temp_r4 .eq. unscaled_missing) temp_i2 = MISSING_VALUE_INT2 endwhere end subroutine SCALE_VECTOR_I2_RANK3 !----------------------------------------------------------------------------------------------------- ! VECTOR UNSCALING ROUTINES !----------------------------------------------------------------------------------------------------- subroutine UNSCALE_VECTOR_I1_RANK1(temp_i1,iscaled,unscaled_min,unscaled_max,unscaled_missing,temp_r4) integer(kind=int1), dimension(:), intent(in):: temp_i1 integer(kind=int1), intent(in):: iscaled real, intent(in):: unscaled_min, unscaled_max, unscaled_missing real, dimension(:), intent(out):: temp_r4 real, dimension(size(temp_r4,1)):: scratch_r4 integer (kind=int1):: scaled_min,scaled_max,scaled_missing scaled_min = int(ONE_BYTE_MIN,kind=int1) scaled_max = int(ONE_BYTE_MAX,kind=int1) scaled_missing = MISSING_VALUE_INT1 scratch_r4 = 0.0 !---- linear if (iscaled == 1) then scratch_r4 = min(1.0,max(0.0,real(temp_i1 - scaled_min)/real(scaled_max - scaled_min))) temp_r4 = unscaled_min + scratch_r4 * (unscaled_max - unscaled_min) endif !---- log10 if (iscaled == 2) then scratch_r4 = min(1.0,max(0.0,real(temp_i1 - scaled_min)/real(scaled_max - scaled_min))) temp_r4 = unscaled_min + scratch_r4 * (unscaled_max - unscaled_min) temp_r4 = 10**(temp_r4) endif !---- square root if (iscaled == 3) then scratch_r4 = min(1.0,max(0.0,real(temp_i1 - scaled_min)/real(scaled_max - scaled_min))) temp_r4 = unscaled_min + (scratch_r4**2) * (unscaled_max - unscaled_min) endif !--- set scaled missing values where (temp_i1 == scaled_missing) temp_r4 = unscaled_missing endwhere end subroutine UNSCALE_VECTOR_I1_RANK1 !---------------------------------------------------------------------------------------------------- ! HDF4 WRITE ROUTINES !----------------------------------------------------------------------------------------------------- subroutine WRITE_CLAVRX_HDF4_SDS_RANK1(Sd_Id,sds_data,Sds_Name,Sds_Type,scaled,sds_min,sds_max,& sds_units,sds_missing,sds_dim1,compress_flag,Istatus) real, intent(in), dimension(:):: sds_data real, intent(in):: sds_min, sds_max,sds_missing integer, intent(in):: Sd_Id,Sds_Type,compress_flag integer(kind=int1), intent(in):: scaled character(len=*), intent(in):: Sds_Name, sds_units,sds_dim1 integer, intent(out):: Istatus integer:: scaled_min, scaled_max, scaled_missing integer:: sds_rank,units_len integer, dimension(1):: sds_dims,sds_edge,sds_chunk_size integer:: Sds_Id integer(kind=int4), dimension(2):: comp_prm integer(kind=int4):: comp_type integer(kind=int1),dimension(size(sds_data,1)):: temp_i1 integer(kind=int2),dimension(size(sds_data,1)):: temp_i2 integer(kind=int4),dimension(size(sds_data,1)):: temp_i4 integer(kind=int4):: i,n ! HDF function declarations integer:: sfcreate, sfdimid, sfsdmname, sfwdata, sfendacc, & sfscatt, sfsnatt, sfschnk n = size(sds_data,1) sds_rank = 1 sds_dims(1) = n sds_edge(1) = n units_len = len_trim(sds_units) Istatus = 0 !------------------------------------------------------------- ! define compression here !------------------------------------------------------------- sds_chunk_size(1) = size(sds_data,1) comp_type = 0 !no compression comp_prm(1) = 0 comp_prm(2) = 0 if (compress_flag == 1) then !gzip compression comp_type = 4 comp_prm(1) = 6 comp_prm(2) = 0 endif if (compress_flag == 2) then !szip compression comp_type = 5 comp_prm(1) = 32 comp_prm(2) = 2 endif !---------------------------------------------------------------------------- ! create sds !---------------------------------------------------------------------------- !-- write initial sds attributes Sds_Id = sfcreate(Sd_Id,Sds_Name,Sds_Type,sds_rank,sds_dims) Istatus = sfscatt(Sds_Id, "UNITS", DFNT_CHAR8, units_len, sds_units) Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, scaled) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MISSING", DFNT_FLOAT32, 1, sds_missing) + Istatus Istatus = sfsdmname(sfdimid(Sds_Id,0),sds_dim1) !--- compression and chunking Istatus = sfschnk(Sds_Id,sds_chunk_size,comp_type,comp_prm)+Istatus !--- determined if a scaled sds, if so write needed attributes for scaling if (scaled > 0) then !--- determine scaled ranges based on Sds_Type if (Sds_Type == DFNT_INT8) then scaled_min = ONE_BYTE_MIN scaled_max = ONE_BYTE_MAX scaled_missing = MISSING_VALUE_INT1 elseif (Sds_Type == DFNT_INT16) then scaled_min = TWO_BYTE_MIN scaled_max = TWO_BYTE_MAX scaled_missing = MISSING_VALUE_INT2 endif !--- write remaining attributes Istatus = sfsnatt(Sds_Id, "RANGE_MIN", DFNT_FLOAT32, 1, sds_min) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MAX", DFNT_FLOAT32, 1, sds_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MIN", DFNT_INT32, 1, scaled_min) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MAX", DFNT_INT32, 1, scaled_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MISSING", DFNT_INT32, 1, scaled_missing) + Istatus endif !----------------------------------------------------------------------------------- ! write data !------------------------------------------------------------------------------------ !--- write unscaled arrays if (scaled == 0) then if (Sds_Type == DFNT_FLOAT32) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, sds_data) + Istatus endif if (Sds_Type == DFNT_INT8) then temp_i1 = int(sds_data,kind=int1) do i = 1,n if (sds_data(i) .eq. sds_missing) then temp_i1(i) = MISSING_VALUE_INT1 endif end do Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus endif if (Sds_Type == DFNT_INT16) then temp_i2 = int(sds_data,kind=int2) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i2) + Istatus endif if (Sds_Type == DFNT_INT32) then temp_i4 = int(sds_data,kind=int4) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i4) + Istatus endif endif !--- write scaled arrays if (scaled > 0) then if (Sds_Type == DFNT_INT8) then call SCALE_VECTOR_I1_RANK1(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i1) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus elseif (Sds_Type == DFNT_INT16) then call SCALE_VECTOR_I2_RANK1(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i2) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i2) + Istatus else print *, "unsupported scaled / Sds_Type combination, stopping" stop endif endif !-------------------------------------------------------------------- ! close this record !-------------------------------------------------------------------- Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF4_SDS_RANK1 !------------------------------------------------------------------------------------------------ !--- Write Routine for Rank=2 !----------------------------------------------------------------------------------------------- subroutine WRITE_CLAVRX_HDF4_SDS_RANK2(Sd_Id,sds_data,Sds_Name,Sds_Type,scaled,sds_min,sds_max,& sds_units,sds_missing,sds_dim1,sds_dim2,compress_flag,Istatus) real, intent(in), dimension(:,:):: sds_data real, intent(in):: sds_min, sds_max,sds_missing integer, intent(in):: Sd_Id,Sds_Type,compress_flag integer(kind=int1), intent(in):: scaled character(len=*), intent(in):: Sds_Name, sds_units,sds_dim1,sds_dim2 integer, intent(out):: Istatus real:: scaled_min, scaled_max, scaled_missing integer:: sds_rank,units_len integer, dimension(2):: sds_dims,sds_edge,sds_chunk_size integer:: Sds_Id integer(kind=int4), dimension(2):: comp_prm integer(kind=int4):: comp_type integer(kind=int1),dimension(size(sds_data,1),size(sds_data,2)):: temp_i1 integer(kind=int2),dimension(size(sds_data,1),size(sds_data,2)):: temp_i2 integer(kind=int4):: i1,i2,n1,n2 ! HDF function declarations integer:: sfcreate, sfdimid, sfsdmname, sfwdata, sfendacc, & sfscatt, sfsnatt sds_rank = 1 n1 = size(sds_data,1) n2 = size(sds_data,2) sds_dims(1) = n1 sds_edge(1) = n1 sds_dims(2) = n2 sds_edge(2) = n2 units_len = len_trim(sds_units) Istatus = 0 !------------------------------------------------------------- ! define compression here !------------------------------------------------------------- sds_chunk_size(1) = size(sds_data,1) sds_chunk_size(2) = size(sds_data,2) comp_type = 0 !no compression comp_prm(1) = 0 comp_prm(2) = 0 if (compress_flag == 1) then !gzip compression comp_type = 4 comp_prm(1) = 6 comp_prm(2) = 0 endif if (compress_flag == 2) then !szip compression comp_type = 5 comp_prm(1) = 32 comp_prm(2) = 2 endif !---------------------------------------------------------------------------- ! create sds !---------------------------------------------------------------------------- !-- write initial sds attributes Sds_Id = sfcreate(Sd_Id,Sds_Name,Sds_Type,sds_rank,sds_dims) Istatus = sfsdmname(sfdimid(Sds_Id,0),sds_dim1) Istatus = sfsdmname(sfdimid(Sds_Id,1),sds_dim2) Istatus = sfscatt(Sds_Id, "UNITS", DFNT_CHAR8, units_len, sds_units) Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, scaled) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MISSING", DFNT_FLOAT32, 1, sds_missing) + Istatus !--- determined if a scaled sds, if so write needed attributes for scaling if (scaled > 0) then !--- determine scaled ranges based on Sds_Type if (Sds_Type == DFNT_INT8) then scaled_min = ONE_BYTE_MIN scaled_max = ONE_BYTE_MAX scaled_missing = MISSING_VALUE_INT1 elseif (Sds_Type == DFNT_INT16) then scaled_min = TWO_BYTE_MIN scaled_max = TWO_BYTE_MAX scaled_missing = MISSING_VALUE_INT2 endif !--- write remaining attributes Istatus = sfsnatt(Sds_Id, "RANGE_MIN", DFNT_FLOAT32, 1, sds_min) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MAX", DFNT_FLOAT32, 1, sds_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MIN", DFNT_INT32, 1, scaled_min) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MAX", DFNT_INT32, 1, scaled_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MISSING", DFNT_INT32, 1, scaled_missing) + Istatus endif !----------------------------------------------------------------------------------- ! write data !------------------------------------------------------------------------------------ !--- write unscaled arrays if (scaled == 0) then if (Sds_Type == DFNT_FLOAT32) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, sds_data) + Istatus endif if (Sds_Type == DFNT_INT8) then temp_i1 = int(sds_data,kind=int1) do i1 = 1, n1 do i2 = 1, n2 if (sds_data(i1,i2) .eq. sds_missing) then temp_i1(i1,i2) = MISSING_VALUE_INT1 endif enddo enddo Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus endif if (Sds_Type == DFNT_INT16) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, int(sds_data,kind=int2)) + Istatus endif if (Sds_Type == DFNT_INT32) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, int(sds_data,kind=int4)) + Istatus endif endif !--- write scaled arrays if (scaled > 0) then if (Sds_Type == DFNT_INT8) then call SCALE_VECTOR_I1_RANK2(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i1) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus elseif (Sds_Type == DFNT_INT16) then call SCALE_VECTOR_I2_RANK2(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i2) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i2) + Istatus else print *, "unsupported scaled / Sds_Type combination, stopping" stop endif endif !-------------------------------------------------------------------- ! close this record !-------------------------------------------------------------------- Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF4_SDS_RANK2 !-------------------------------------------------------------------------------- !---- Write Routine for Rank=3 !-------------------------------------------------------------------------------- subroutine WRITE_CLAVRX_HDF4_SDS_RANK3(Sd_Id,sds_data,Sds_Name,Sds_Type,scaled,sds_min,sds_max,& sds_units,sds_missing,sds_dim1,sds_dim2,sds_dim3,compress_flag,Istatus) real, intent(in), dimension(:,:,:):: sds_data real, intent(in):: sds_min, sds_max, sds_missing integer, intent(in):: Sd_Id,Sds_Type,compress_flag integer(kind=int1), intent(in):: scaled character(len=*), intent(in):: Sds_Name, sds_units,sds_dim1,sds_dim2,sds_dim3 integer, intent(out):: Istatus real:: scaled_min, scaled_max, scaled_missing integer:: sds_rank,units_len integer, dimension(3):: sds_dims,sds_edge,sds_chunk_size integer:: Sds_Id integer(kind=int4), dimension(2):: comp_prm integer(kind=int4):: comp_type integer(kind=int1),dimension(size(sds_data,1),size(sds_data,2),size(sds_data,3)):: temp_i1 integer(kind=int2),dimension(size(sds_data,1),size(sds_data,2),size(sds_data,3)):: temp_i2 integer(kind=int4):: i1,i2,i3,n1,n2,n3 ! HDF function declarations integer:: sfcreate, sfdimid, sfsdmname, sfwdata, sfendacc, & sfscatt, sfsnatt sds_rank = 1 n1 = size(sds_data,1) n2 = size(sds_data,2) n3 = size(sds_data,3) sds_dims(1) = n1 sds_edge(1) = n1 sds_dims(2) = n2 sds_edge(2) = n2 sds_dims(3) = n3 sds_edge(3) = n3 units_len = len_trim(sds_units) Istatus = 0 !------------------------------------------------------------- ! define compression here !------------------------------------------------------------- sds_chunk_size(1) = size(sds_data,1) sds_chunk_size(2) = size(sds_data,2) sds_chunk_size(3) = size(sds_data,3) comp_type = 0 !no compression comp_prm(1) = 0 comp_prm(2) = 0 if (compress_flag == 1) then !gzip compression comp_type = 4 comp_prm(1) = 6 comp_prm(2) = 0 endif if (compress_flag == 2) then !szip compression comp_type = 5 comp_prm(1) = 32 comp_prm(2) = 2 endif !---------------------------------------------------------------------------- ! create sds !---------------------------------------------------------------------------- !-- write initial sds attributes Sds_Id = sfcreate(Sd_Id,Sds_Name,Sds_Type,sds_rank,sds_dims) Istatus = sfsdmname(sfdimid(Sds_Id,0),sds_dim1) Istatus = sfsdmname(sfdimid(Sds_Id,1),sds_dim2) Istatus = sfsdmname(sfdimid(Sds_Id,2),sds_dim3) Istatus = sfscatt(Sds_Id, "UNITS", DFNT_CHAR8, units_len, sds_units) Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, scaled) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MISSING", DFNT_FLOAT32, 1, sds_missing) + Istatus !--- determined if a scaled sds, if so write needed attributes for scaling if (scaled > 0) then !--- determine scaled ranges based on Sds_Type if (Sds_Type == DFNT_INT8) then scaled_min = ONE_BYTE_MIN scaled_max = ONE_BYTE_MAX scaled_missing = MISSING_VALUE_INT1 elseif (Sds_Type == DFNT_INT16) then scaled_min = TWO_BYTE_MIN scaled_max = TWO_BYTE_MAX scaled_missing = MISSING_VALUE_INT2 endif !--- write remaining attributes Istatus = sfsnatt(Sds_Id, "RANGE_MIN", DFNT_FLOAT32, 1, sds_min) + Istatus Istatus = sfsnatt(Sds_Id, "RANGE_MAX", DFNT_FLOAT32, 1, sds_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MIN", DFNT_INT32, 1, scaled_min) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MAX", DFNT_INT32, 1, scaled_max) + Istatus Istatus = sfsnatt(Sds_Id, "SCALED_MISSING", DFNT_INT32, 1, scaled_missing) + Istatus endif !----------------------------------------------------------------------------------- ! write data !------------------------------------------------------------------------------------ !--- write unscaled arrays if (scaled == 0) then if (Sds_Type == DFNT_FLOAT32) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, sds_data) + Istatus endif if (Sds_Type == DFNT_INT8) then temp_i1 = int(sds_data,kind=int1) do i1 = 1, n1 do i2 = 1, n2 do i3 = 1, n3 if (sds_data(i1,i2,i3) .eq. sds_missing) then temp_i1(i2,i2,i3) = MISSING_VALUE_INT1 endif enddo enddo enddo Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus endif if (Sds_Type == DFNT_INT16) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, int(sds_data,kind=int2)) + Istatus endif if (Sds_Type == DFNT_INT32) then Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, int(sds_data,kind=int4)) + Istatus endif endif !--- write scaled arrays if (scaled > 0) then if (Sds_Type == DFNT_INT8) then call SCALE_VECTOR_I1_RANK3(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i1) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i1) + Istatus elseif (Sds_Type == DFNT_INT16) then call SCALE_VECTOR_I2_RANK3(sds_data,scaled,sds_min,sds_max,sds_missing,temp_i2) Istatus = sfwdata(Sds_Id, 0, 1, sds_edge, temp_i2) + Istatus else print *, "unsupported scaled / Sds_Type combination, stopping" stop endif endif !-------------------------------------------------------------------- ! close this record !-------------------------------------------------------------------- Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF4_SDS_RANK3 !---------------------------------------------------------------------------------------------------- ! HDF4 READ ROUTINES ! this routine reads in level3 sds's, it assumes ! 1. - you know the size of the array (num_cells_with_data) !----------------------------------------------------------------------------------------------------- subroutine READ_CLAVRX_HDF4_SDS_RANK1(Sd_Id,sds_dim_input,Sds_Name,sds_data, & sds_data_type,scaled,sds_units, & unscaled_min,unscaled_max,unscaled_missing,& scaled_min,scaled_max,scaled_missing,& Istatus) integer(kind=int4), intent(in):: Sd_Id,sds_dim_input character(len=*), intent(in):: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp real, intent(out):: unscaled_min, unscaled_max, unscaled_missing integer(kind=int4), intent(out):: scaled_min, scaled_max, scaled_missing real, intent(out), dimension(:):: sds_data integer(kind=int1), intent(out):: scaled character(len=*), intent(out):: sds_units integer(kind=int4), intent(out):: sds_data_type,Istatus integer(kind=int4):: Sds_Id,sds_dim1 integer(kind=int4):: num_attrs, sds_rank integer(kind=int4), dimension(1):: dimsizes real, dimension(size(sds_data)):: sds_data_temp integer(kind=4), dimension(1):: sds_dims_1d, sds_start_1d, sds_stride_1d, sds_edges_1d integer(kind=int1), dimension(:), allocatable:: temp_i1 integer(kind=int2), dimension(:), allocatable:: temp_i2 integer(kind=int4), dimension(:), allocatable:: temp_i4 real(kind=real4), dimension(:), allocatable:: temp_r4 Istatus = 0 !---------------------------------------------------------------------------- ! open sds for reading !---------------------------------------------------------------------------- Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,Sds_Name)) Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, dimsizes, sds_data_type, num_attrs) + Istatus sds_dim1 = dimsizes(1) sds_dims_1d = (/sds_dim1/) sds_start_1d = (/ 0 /) sds_stride_1d = (/ 1 /) sds_edges_1d = (/ sds_dim1 /) sds_units = " " !--- read sds attributes Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"SCALED"), scaled) Istatus = sfrcatt(Sds_Id, sffattr(Sds_Id,"UNITS"), sds_units) Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"RANGE_MISSING"), unscaled_missing) !-- if scaled, read attributes that allow unscaling if (scaled > 0) then Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"SCALED_MISSING"), scaled_missing) Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"SCALED_MIN"), scaled_min) Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"SCALED_MAX"), scaled_max) Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"RANGE_MIN"), unscaled_min) Istatus = sfrnatt(Sds_Id, sffattr(Sds_Id,"RANGE_MAX"), unscaled_max) endif !-- check dimension against expectations if (sds_dim_input /= sds_dim1) then print *, "error, sds dimension differs from expectations, stopping", sds_dim_input, sds_dim1 stop endif !--- allocate arrays for holding data, read data and store in output array if (sds_data_type == DFNT_INT8) then allocate(temp_i1(sds_dim1)) Istatus = sfrdata(Sds_Id, sds_start_1d, sds_stride_1d, sds_edges_1d, temp_i1) + Istatus sds_data = real(temp_i1) elseif (sds_data_type == DFNT_INT16) then allocate(temp_i2(sds_dim1)) Istatus = sfrdata(Sds_Id, sds_start_1d, sds_stride_1d, sds_edges_1d, temp_i2) + Istatus sds_data = real(temp_i2) elseif (sds_data_type == DFNT_INT32) then allocate(temp_i4(sds_dim1)) Istatus = sfrdata(Sds_Id, sds_start_1d, sds_stride_1d, sds_edges_1d, temp_i4) + Istatus sds_data = real(temp_i4) elseif (sds_data_type == DFNT_FLOAT32) then allocate(temp_r4(sds_dim1)) Istatus = sfrdata(Sds_Id, sds_start_1d, sds_stride_1d, sds_edges_1d, temp_r4) + Istatus sds_data = temp_r4 else print *, "attempt to read unsupported data type, stopping" stop endif !---deallocate temp arrays if (allocated(temp_i1)) deallocate(temp_i1) if (allocated(temp_i2)) deallocate(temp_i2) if (allocated(temp_i4)) deallocate(temp_i4) if (allocated(temp_r4)) deallocate(temp_r4) !--- close sds Istatus = sfendacc(Sds_Id) + Istatus !--- unscale sds if (scaled > 0) then sds_data_temp = sds_data !---- linear if (scaled == 1) then sds_data_temp = min(1.0,max(0.0,real(sds_data_temp - scaled_min)/real(scaled_max - scaled_min))) sds_data_temp = unscaled_min + sds_data_temp * (unscaled_max - unscaled_min) endif !---- log10 if (scaled == 2) then sds_data_temp = min(1.0,max(0.0,real(sds_data_temp - scaled_min)/real(scaled_max - scaled_min))) sds_data_temp = unscaled_min + sds_data_temp * (unscaled_max - unscaled_min) sds_data_temp = 10**(sds_data_temp) endif !---- square root if (scaled == 3) then sds_data_temp = min(1.0,max(0.0,real(sds_data_temp - scaled_min)/real(scaled_max - scaled_min))) sds_data_temp = unscaled_min + (sds_data_temp**2) * (unscaled_max - unscaled_min) endif !--- set scaled missing values !where (sds_data == scaled_missing) where (sds_data .eq. real(scaled_missing)) sds_data_temp = unscaled_missing endwhere sds_data = sds_data_temp endif end subroutine READ_CLAVRX_HDF4_SDS_RANK1 !--------------------------------------------------------------------------------------------------------- ! Begin of New Routines to this Module !--------------------------------------------------------------------------------------------------------- !======================================================================= ! read a global numerical attribute !======================================================================= function READ_HDF_GLOBAL_ATTRIBUTE_NUM(Sd_Id,Attribute_Name) result(Attr_Value) integer, intent(in):: Sd_Id character(len=*), intent(in):: Attribute_Name real(kind=real4):: Attr_Value integer:: Istatus integer:: Attr_Id character(len=100):: Attr_Name integer:: Attr_Type integer:: Attr_Count integer(kind=int1):: Attr_Value_I1 integer(kind=int2):: Attr_Value_I2 integer(kind=int4):: Attr_Value_I4 real(kind=real4):: Attr_Value_R4 real(kind=real8):: Attr_Value_R8 !--- hdf commands integer:: sffattr integer:: sfrnatt integer:: sfgainfo !------------------------------------------------------------------------------------ ! begin executable code !------------------------------------------------------------------------------------ Istatus = 0 !--- open attribute Attr_Id = sffattr(Sd_Id,trim(Attribute_Name)) if (Attr_Id < 0) then Istatus = 1 Attr_Value = Missing_Value_Real4 return endif Istatus = sfgainfo(Sd_Id,Attr_Id,Attr_Name,Attr_Type,Attr_Count) + Istatus if (Attr_Type == DFNT_INT8) then Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value_I1) + Istatus Attr_Value = real(Attr_Value_I1) elseif (Attr_Type == DFNT_INT16) then Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value_I2) + Istatus Attr_Value = real(Attr_Value_I2) elseif (Attr_Type == DFNT_INT32) then Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value_I4) + Istatus Attr_Value = real(Attr_Value_I4) elseif (Attr_Type == DFNT_FLOAT32) then Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value_R4) + Istatus Attr_Value = Attr_Value_R4 elseif (Attr_Type == DFNT_FLOAT64) then Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value_R8) + Istatus Attr_Value = real(Attr_Value_R8) else print *, "Unknown Attribute Type, stopping" stop endif !--- check for final error status if (Istatus /= 0) then print *, "Errors on read of ", trim(Attribute_Name) endif end function READ_HDF_GLOBAL_ATTRIBUTE_NUM !======================================================================= ! read a global string attribute !======================================================================= function READ_HDF_GLOBAL_ATTRIBUTE_STR(Sd_Id,Attribute_Name) result(Attr_Value) integer, intent(in):: Sd_Id character(len=*), intent(in):: Attribute_Name character(len=500):: Attr_Value integer:: Istatus integer:: Attr_Id !character(len=100):: Attr_Name !--- hdf commands integer:: sffattr integer:: sfrnatt !------------------------------------------------------------------------------------ ! begin executable code !------------------------------------------------------------------------------------ Istatus = 0 !--- open attribute Attr_Id = sffattr(Sd_Id,trim(Attribute_Name)) if (Attr_Id < 0) then Istatus = 1 Attr_Value = '' return endif !--- read attribute Istatus = sfrnatt(Sd_Id, Attr_Id, Attr_Value) + Istatus !--- check for final error status if (Istatus /= 0) then print *, "Errors on read of ", trim(Attribute_Name) endif end function READ_HDF_GLOBAL_ATTRIBUTE_STR !======================================================================= ! read CLAVR-x a one dimensional sds !======================================================================= subroutine READ_CLAVRX_HDF_SDS_1D(file_name,Sds_Name,Unscaled_Sds_Data,Istatus,quiet, & Sds_Start,Sds_Stride,Sds_Edges) character(len=*), intent(in):: file_name character(len=*), intent(in):: Sds_Name real(kind=real4), intent(out),dimension(:), allocatable:: Unscaled_Sds_Data character(len=*), intent(in), optional:: quiet integer:: Sd_Id integer:: Sds_Idx integer, dimension(1):: Sds_Dims, Rank integer, optional, dimension(1):: Sds_Start integer, optional, dimension(1):: Sds_Stride integer, optional, dimension(1):: Sds_Edges integer(kind=int1), dimension(:), allocatable:: Temp_I1 integer(kind=int2), dimension(:), allocatable:: Temp_I2 integer(kind=int4), dimension(:), allocatable:: Temp_I4 real(kind=real4), dimension(:), allocatable:: Temp_R4 real(kind=real4), dimension(:), allocatable:: Scaled_Sds_Data real(kind=real4):: Scale_Factor, Add_Offset, Actual_Missing integer:: Data_Type integer:: Fill_Value integer:: Num_Attrs integer:: Scaling_Type integer, intent(out):: Istatus integer:: sds_index integer:: Attr_Index character(72):: Sds_Name_Temp integer(kind=int1):: dummy_i1 integer(kind=int2):: dummy_i2 !------------------------------------------------------------------------------------ ! begin executable code !------------------------------------------------------------------------------------ Istatus = 0 !--- open the file Sd_Id = sfstart(trim(file_name), DFACC_READ) !--- handle a failure of the opening if (Sd_Id < 0) then Istatus = 1 return endif !--- find sds in the file sds_index = sfn2index(Sd_Id,trim(Sds_Name)) !--- handle failure of finding sds if (sds_index < 0) then Istatus = 1 if (.not. present(quiet)) print *, "Error could not find sds named ", trim(Sds_Name) return endif !--- open the sds Sds_Idx = sfselect(Sd_Id, sds_index) !--- handle failure of opening the sds if (Sds_Idx < 0) then Istatus = 1 if (.not. present(quiet)) print *, "Error opening sds named ", trim(Sds_Name) return endif !--- get information on this file Istatus = sfginfo(Sds_Idx, Sds_Name_Temp, Rank, Sds_Dims, Data_Type, Num_Attrs) + Istatus !--- if (.not. present(Sds_Start)) Sds_Start = (/0/) if (.not. present(Sds_Stride)) Sds_Stride = (/ 1 /) if (.not. present(Sds_Edges)) Sds_Edges = Sds_Dims !--- set missing value to default Actual_Missing = DEFAULT_MISSING_VALUE !--- read scaling attribute (0=no scaling, 1 = linear) Scaling_Type = 0 Attr_Index = sffattr(Sds_Idx,"SCALED") if (Attr_Index == -1) then Scaling_Type = 0_int1 else Istatus = sfrnatt(Sds_Idx, Attr_Index, Scaling_Type) + Istatus endif !--- scale factor Scale_Factor = 1.0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,"scale_factor") if (Attr_Index == -1) then if (.not. present(quiet)) print *, "scale factor missing, assumed 1.0 for sds named ", trim(Sds_Name) else Istatus = sfrnatt(Sds_Idx, Attr_Index, Scale_Factor) + Istatus endif endif !--- add_offset Add_Offset = 0.0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,"add_offset") if (Attr_Index == -1) then if (.not. present(quiet)) print *, "add offset missing, assumed 0.0 for sds named ", trim(Sds_Name) else Istatus = sfrnatt(Sds_Idx, Attr_Index, Add_Offset) + Istatus endif endif !--- read fill value Fill_Value = 0.0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,'_FillValue') if (Attr_Index == -1) then if (.not. present(quiet)) print *, "fill value missing, assumed for sds named ", trim(Sds_Name) if (Data_Type == DFNT_INT8) Fill_Value = -128.0 if (Data_Type == DFNT_INT16) Fill_Value = -32768.0 else if (Data_Type == DFNT_INT8) then Istatus = sfrnatt(Sds_Idx, Attr_Index, dummy_i1) + Istatus Fill_Value = real(dummy_i1) endif if (Data_Type == DFNT_INT16) then Istatus = sfrnatt(Sds_Idx, Attr_Index, dummy_i2) + Istatus Fill_Value = real(dummy_i2) endif endif endif !--- allocate arrays for holding data, read data and store in output array allocate(Scaled_Sds_Data(Sds_Dims(1))) allocate(Unscaled_Sds_Data(Sds_Dims(1))) if (Data_Type == DFNT_INT8) then allocate(Temp_I1(Sds_Dims(1))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I1) + Istatus Scaled_Sds_Data = real(Temp_I1) elseif (Data_Type == DFNT_INT16) then allocate(Temp_I2(Sds_Dims(1))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I2) + Istatus Scaled_Sds_Data = real(Temp_I2) elseif (Data_Type == DFNT_INT32) then allocate(Temp_I4(Sds_Dims(1))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I4) + Istatus Scaled_Sds_Data = real(Temp_I4) elseif (Data_Type == DFNT_FLOAT32) then allocate(Temp_R4(Sds_Dims(1))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_R4) + Istatus Scaled_Sds_Data = Temp_R4 else if (.not. present(quiet)) print *, "Possibly fatal error at location 2:" if (.not. present(quiet)) print *, "data type was ", Data_Type if (.not. present(quiet)) print *, "sds complete value is " ! if (.not. present(quiet)) print *, Sds print *, "attempt to read unsupported data type, stopping" Scaled_Sds_Data = MISSING_VALUE_REAL4 Data_Type = -999 stop endif !---deallocate temp arrays if (allocated(Temp_I1)) deallocate(Temp_I1) if (allocated(Temp_I2)) deallocate(Temp_I2) if (allocated(Temp_I4)) deallocate(Temp_I4) if (allocated(Temp_R4)) deallocate(Temp_R4) !--- close Sds Istatus = sfendacc(Sds_Idx) + Istatus !----- close input hdf file Istatus = sfend(Sd_Id) + Istatus !--- unscale Sds Unscaled_Sds_Data = Scaled_Sds_Data * Scale_Factor + Add_Offset !--- set scaled missing values (unless its a packed data set) if (Scaling_Type /= 0 .or. index(Sds_Name, 'packed') > 0) then where (Scaled_Sds_Data .eq. Fill_Value) Unscaled_Sds_Data = Actual_Missing endwhere endif if (allocated(Scaled_Sds_Data)) deallocate(Scaled_Sds_Data) end subroutine READ_CLAVRX_HDF_SDS_1D !======================================================================= ! read CLAVR-x a two dimensional sds !======================================================================= subroutine READ_CLAVRX_HDF_SDS_2D(file_name,Sds_Name,Unscaled_Sds_Data,Istatus,quiet, & Sds_Start,Sds_Stride,Sds_Edges) character(len=*), intent(in):: file_name character(len=*), intent(in):: Sds_Name real(kind=real4), intent(out),dimension(:,:), allocatable:: Unscaled_Sds_Data character(len=*), intent(in), optional:: quiet integer:: Sd_Id integer:: Sds_Idx integer, dimension(2):: Sds_Dims, Rank integer, optional, dimension(2):: Sds_Start integer, optional, dimension(2):: Sds_Stride integer, optional, dimension(2):: Sds_Edges integer(kind=int1), dimension(:,:), allocatable:: Temp_I1 integer(kind=int2), dimension(:,:), allocatable:: Temp_I2 integer(kind=int4), dimension(:,:), allocatable:: Temp_I4 real(kind=real4), dimension(:,:), allocatable:: Temp_R4 real(kind=real4), dimension(:,:), allocatable:: Scaled_Sds_Data real(kind=real4):: Scale_Factor, Add_Offset, Actual_Missing integer:: Data_Type integer:: Fill_Value integer:: Num_Attrs integer:: Scaling_Type integer, intent(out):: Istatus integer:: sds_index integer:: Attr_Index character(72):: Sds_Name_Temp integer(kind=int1):: dummy_i1 integer(kind=int2):: dummy_i2 !------------------------------------------------------------------------------------ ! begin executable code !------------------------------------------------------------------------------------ Istatus = 0 !--- open the file Sd_Id = sfstart(trim(file_name), DFACC_READ) !--- handle a failure of the opening if (Sd_Id < 0) then Istatus = 1 return endif !--- find sds in the file sds_index = sfn2index(Sd_Id,trim(Sds_Name)) !--- handle failure of finding sds if (sds_index < 0) then Istatus = 1 if (.not. present(quiet)) print *, "Error could not find sds named ", trim(Sds_Name) return endif !--- open the sds Sds_Idx = sfselect(Sd_Id, sds_index) !--- handle failure of opening the sds if (Sds_Idx < 0) then Istatus = 1 if (.not. present(quiet)) print *, "Error opening sds named ", trim(Sds_Name) return endif !--- get information on this file Istatus = sfginfo(Sds_Idx, Sds_Name_Temp, Rank, Sds_Dims, Data_Type, Num_Attrs) + Istatus !--- if (.not. present(Sds_Start)) Sds_Start = (/0,0/) if (.not. present(Sds_Stride)) Sds_Stride = (/ 1,1 /) if (.not. present(Sds_Edges)) Sds_Edges = Sds_Dims !--- set missing value to default Actual_Missing = DEFAULT_MISSING_VALUE !--- read scaling attribute (0=no scaling, 1 = linear) Scaling_Type = 0 Attr_Index = sffattr(Sds_Idx,"SCALED") if (Attr_Index == -1) then Scaling_Type = 0_int1 else Istatus = sfrnatt(Sds_Idx, Attr_Index, Scaling_Type) + Istatus endif !--- scale factor Scale_Factor = 1.0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,"scale_factor") if (Attr_Index == -1) then if (.not. present(quiet)) print *, "scale factor missing, assumed 1.0 for sds named ", trim(Sds_Name) else Istatus = sfrnatt(Sds_Idx, Attr_Index, Scale_Factor) + Istatus endif endif !--- add_offset Add_Offset = 0.0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,"add_offset") if (Attr_Index == -1) then if (.not. present(quiet)) print *, "add offset missing, assumed 0.0 for sds named ", trim(Sds_Name) else Istatus = sfrnatt(Sds_Idx, Attr_Index, Add_Offset) + Istatus endif endif !--- read fill value Fill_Value = 0 if (Scaling_Type == 1) then Attr_Index = sffattr(Sds_Idx,'_FillValue') if (Attr_Index == -1) then if (.not. present(quiet)) print *, "fill value missing, assumed for sds named ", trim(Sds_Name) if (Data_Type == DFNT_INT8) Fill_Value = -128 if (Data_Type == DFNT_INT16) Fill_Value = -32768 else if (Data_Type == DFNT_INT8) then Istatus = sfrnatt(Sds_Idx, Attr_Index, dummy_i1) + Istatus Fill_Value = real(dummy_i1) endif if (Data_Type == DFNT_INT16) then Istatus = sfrnatt(Sds_Idx, Attr_Index, dummy_i2) + Istatus Fill_Value = real(dummy_i2) endif endif endif !--- allocate arrays for holding data, read data and store in output array allocate(Scaled_Sds_Data(Sds_Dims(1),Sds_Dims(2))) allocate(Unscaled_Sds_Data(Sds_Dims(1),Sds_Dims(2))) if (Data_Type == DFNT_INT8) then allocate(Temp_I1(Sds_Dims(1),Sds_Dims(2))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I1) + Istatus Scaled_Sds_Data = real(Temp_I1) elseif (Data_Type == DFNT_INT16) then allocate(Temp_I2(Sds_Dims(1),Sds_Dims(2))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I2) + Istatus Scaled_Sds_Data = real(Temp_I2) elseif (Data_Type == DFNT_INT32) then allocate(Temp_I4(Sds_Dims(1),Sds_Dims(2))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_I4) + Istatus Scaled_Sds_Data = real(Temp_I4) elseif (Data_Type == DFNT_FLOAT32) then allocate(Temp_R4(Sds_Dims(1),Sds_Dims(2))) Istatus = sfrdata(Sds_Idx, Sds_Start, Sds_Stride, Sds_Edges, Temp_R4) + Istatus Scaled_Sds_Data = Temp_R4 else if (.not. present(quiet)) print *, "Possibly fatal error at location 2:" if (.not. present(quiet)) print *, "data type was ", Data_Type if (.not. present(quiet)) print *, "sds complete value is " ! if (.not. present(quiet)) print *, Sds print *, "attempt to read unsupported data type, stopping" Scaled_Sds_Data = MISSING_VALUE_REAL4 Data_Type = -999 stop endif !---deallocate temp arrays if (allocated(Temp_I1)) deallocate(Temp_I1) if (allocated(Temp_I2)) deallocate(Temp_I2) if (allocated(Temp_I4)) deallocate(Temp_I4) if (allocated(Temp_R4)) deallocate(Temp_R4) !--- close Sds Istatus = sfendacc(Sds_Idx) + Istatus !----- close input hdf file Istatus = sfend(Sd_Id) + Istatus !--- unscale Sds Unscaled_Sds_Data = Scaled_Sds_Data * Scale_Factor + Add_Offset !--- set scaled missing values (unless its a packed data set) if (Scaling_Type /= 0 .or. index(Sds_Name, 'packed') > 0) then where (Scaled_Sds_Data .eq. Fill_Value) Unscaled_Sds_Data = Actual_Missing endwhere endif if (allocated(Scaled_Sds_Data)) deallocate(Scaled_Sds_Data) end subroutine READ_CLAVRX_HDF_SDS_2D !====================================================================== ! routine to write unscaled 1d sds !====================================================================== subroutine WRITE_CLAVRX_HDF_SDS_1D(Sd_Id,Sds_Name,Sds_Data,Istatus) integer, intent(in):: Sd_Id character (len=*), intent(in):: Sds_Name real, dimension(:),intent(in):: Sds_Data integer, intent(out):: Istatus integer, dimension(1):: Sds_Dims integer, dimension(1):: Sds_Start integer, dimension(1):: Sds_Edges integer, dimension(1):: Sds_Stride integer:: Nx integer:: Sds_Rank integer:: Sds_Id integer:: sfcreate integer:: sfsnatt integer:: sfwdata integer:: sfendacc Istatus = 0 Sds_Rank = 1 Nx = size(Sds_Data) Sds_Dims = (/Nx/) Sds_Start = (/0/) Sds_Stride = (/1/) Sds_Edges = (/Nx/) Sds_Id = sfcreate(Sd_Id,Sds_Name,DFNT_FLOAT32,Sds_Rank,Sds_Dims) if (Sds_Id < 0) then Istatus = 1 return endif Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, 0) + Istatus Istatus = sfsnatt(Sds_Id, "_Fill_Value", DFNT_FLOAT32, 1, Missing_Value_Real4) + Istatus Istatus = sfwdata(Sds_Id, Sds_Start, Sds_Stride, Sds_Edges, Sds_Data) + Istatus Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF_SDS_1D !====================================================================== ! routine to write unscaled 2d sds !====================================================================== subroutine WRITE_CLAVRX_HDF_SDS_2D(Sd_Id,Sds_Name,Sds_Data,Istatus) integer, intent(in):: Sd_Id character (len=*), intent(in):: Sds_Name real, dimension(:,:),intent(in):: Sds_Data integer, intent(out):: Istatus integer, dimension(2):: Sds_Dims integer, dimension(2):: Sds_Start integer, dimension(2):: Sds_Edges integer, dimension(2):: Sds_Stride integer:: Nx integer:: Ny integer:: Sds_Rank integer:: Sds_Id integer:: sfcreate integer:: sfsnatt integer:: sfwdata integer:: sfendacc integer:: sfdimid integer:: sfsdmname Istatus = 0 Sds_Rank = 2 Nx = size(Sds_Data(:,1)) Ny = size(Sds_Data(1,:)) Sds_Dims = (/Nx, Ny/) Sds_Start = (/0,0/) Sds_Stride = (/1,1/) Sds_Edges = (/Nx, Ny/) Sds_Id = sfcreate(Sd_Id,Sds_Name,DFNT_FLOAT32,Sds_Rank,Sds_Dims) if (Sds_Id < 0) then Istatus = 1 return endif Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, 0) + Istatus Istatus = sfsnatt(Sds_Id, "_Fill_Value", DFNT_FLOAT32, 1, Missing_Value_Real4) + Istatus Istatus = sfsdmname(sfdimid(Sds_Id, 0),"longitude index") + Istatus Istatus = sfsdmname(sfdimid(Sds_Id, 1),"latitude index") + Istatus Istatus = sfwdata(Sds_Id, Sds_Start, Sds_Stride, Sds_Edges, Sds_Data) + Istatus Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF_SDS_2D !====================================================================== ! routine to write unscaled 3d sds !====================================================================== subroutine WRITE_CLAVRX_HDF_SDS_3D(Sd_Id,Sds_Name,Sds_Data,Istatus) integer, intent(in):: Sd_Id character (len=*), intent(in):: Sds_Name real, dimension(:,:,:),intent(in):: Sds_Data integer, intent(out):: Istatus integer, dimension(3):: Sds_Dims integer, dimension(3):: Sds_Start integer, dimension(3):: Sds_Edges integer, dimension(3):: Sds_Stride integer:: Nx integer:: Ny integer:: Nz integer:: Sds_Rank integer:: Sds_Id integer:: sfcreate integer:: sfsnatt integer:: sfwdata integer:: sfendacc integer:: sfdimid integer:: sfsdmname Istatus = 0 Sds_Rank = 3 Nx = size(Sds_Data(:,1,1)) Ny = size(Sds_Data(1,:,1)) Nz = size(Sds_Data(1,1,:)) Sds_Dims = (/Nx, Ny, Nz/) Sds_Start = (/0,0,0/) Sds_Stride = (/1,1,1/) Sds_Edges = (/Nx, Ny, Nz/) Sds_Id = sfcreate(Sd_Id,Sds_Name,DFNT_FLOAT32,Sds_Rank,Sds_Dims) if (Sds_Id < 0) then Istatus = 1 return endif Istatus = sfsnatt(Sds_Id, "SCALED", DFNT_INT8, 1, 0) + Istatus Istatus = sfsnatt(Sds_Id, "_Fill_Value", DFNT_FLOAT32, 1, Missing_Value_Real4) + Istatus Istatus = sfsdmname(sfdimid(Sds_Id, 0),"longitude index") + Istatus Istatus = sfsdmname(sfdimid(Sds_Id, 1),"latitude index") + Istatus Istatus = sfwdata(Sds_Id, Sds_Start, Sds_Stride, Sds_Edges, Sds_Data) + Istatus Istatus = sfendacc(Sds_Id) + Istatus end subroutine WRITE_CLAVRX_HDF_SDS_3D !====================================================================== ! opens file !====================================================================== function OPEN_FILE_HDF_READ(filename,file_id) result(Error_Status) character(*), intent(in) :: filename integer(kind=int4), intent(out) :: file_id integer(kind=int4) :: Error_Status integer :: sfstart Error_Status = SUCCEED ! --- open file file_id = sfstart(trim(filename),DFACC_READ) if (file_id == FAIL) then print "(a,'Cannot Open HDF file, ',a)", trim(filename) Error_Status = FAIL endif return end function OPEN_FILE_HDF_READ !====================================================================== ! closes file !====================================================================== function CLOSE_FILE_HDF_READ(file_id,filename) result(Error_Status) integer(kind=int4), intent(in) :: file_id character(*), intent(in) :: filename integer :: Error_Status integer :: sfend Error_Status = SUCCEED ! --- close file Error_Status = sfend(file_id) if (Error_Status == FAIL) then print "(a,'Cannot close HDF file, ',a,' - aborting')", & trim(filename) stop endif return end function CLOSE_FILE_HDF_READ !====================================================================== ! reads dimensions !====================================================================== function HDF_SDS_DIMENSIONS_READER(id, Sds_Name, Rank, Dims) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), intent(out) :: Rank integer(kind=int4), dimension(MAX_RANK_HDF), intent(out) :: Dims integer(kind=int4) :: Error_Status integer(kind=int4) :: Sds_Id, Istatus, Sds_Type, Sds_Nattr Error_Status = SUCCEED Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) Istatus = sfginfo(Sds_Id, Sds_Name_Temp, Rank, Dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",trim(Sds_Name),id Error_Status = FAIL endif Istatus = sfendacc(Sds_Id) return end function HDF_SDS_DIMENSIONS_READER !------------------------------------------------------------------- ! Subroutine to read 1D int8 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT8_1D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(1), intent(inout) :: istart, istride integer(kind=int4), dimension(1), intent(inout) :: iedge integer(kind=int1), dimension(:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(1) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_UINT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 1) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istride(1) < 1) istride(1) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) iedge(1) = min(max_iedge(1),iedge(1)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT8_1D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT8_1D !------------------------------------------------------------------- ! Subroutine to read 1D int16 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT16_1D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(1), intent(inout) :: istart, istride integer(kind=int4), dimension(1), intent(inout) :: iedge integer(kind=int2), dimension(:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(1) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT16) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 1) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istride(1) < 1) istride(1) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) iedge(1) = min(max_iedge(1),iedge(1)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT16_1D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT16_1D !------------------------------------------------------------------- ! Subroutine to read 1D int32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT32_1D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(1), intent(inout) :: istart, istride integer(kind=int4), dimension(1), intent(inout) :: iedge integer(kind=int4), dimension(:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(1) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 1) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istride(1) < 1) istride(1) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) iedge(1) = min(max_iedge(1),iedge(1)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT32_1D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT32_1D !------------------------------------------------------------------- ! Subroutine to read 1D float32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT32_1D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(1), intent(inout) :: istart, istride integer(kind=int4), dimension(1), intent(inout) :: iedge real(kind=real4), dimension(:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(1) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 1) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istride(1) < 1) istride(1) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) iedge(1) = min(max_iedge(1),iedge(1)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT32_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT32_1D !------------------------------------------------------------------- ! Subroutine to read 1D float64 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT64_1D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(1), intent(inout) :: istart, istride integer(kind=int4), dimension(1), intent(inout) :: iedge real(kind=real8), dimension(:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(1) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT64) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 1) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istride(1) < 1) istride(1) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) iedge(1) = min(max_iedge(1),iedge(1)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT64_1D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT64_1D !------------------------------------------------------------------- ! Subroutine to read 2D int8 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT8_2D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(2), intent(inout) :: istart integer(kind=int4), dimension(2), intent(inout) :: istride integer(kind=int4), dimension(2), intent(inout) :: iedge integer(kind=int1), dimension(:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(2) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_UINT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 2) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istart(2) < 0) istart(2) = 0 if (istride(1) < 1) istride(1) = 1 if (istride(2) < 1) istride(2) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) if (iedge(2) < 0) iedge(2) = int(ceiling(real(sds_dims(2))/real(istride(2)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) max_iedge(2) = int(ceiling(real(sds_dims(2) - istart(2))/real(istride(2)))) iedge(1) = min(max_iedge(1),iedge(1)) iedge(2) = min(max_iedge(2),iedge(2)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 2d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 2d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT8_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT8_2D !------------------------------------------------------------------- ! Subroutine to read 2D int16 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT16_2D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(2), intent(inout) :: istart, istride integer(kind=int4), dimension(2), intent(inout) :: iedge integer(kind=int2), dimension(:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(2) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT16) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 2) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istart(2) < 0) istart(2) = 0 if (istride(1) < 1) istride(1) = 1 if (istride(2) < 1) istride(2) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) if (iedge(2) < 0) iedge(2) = int(ceiling(real(sds_dims(2))/real(istride(2)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) max_iedge(2) = int(ceiling(real(sds_dims(2) - istart(2))/real(istride(2)))) iedge(1) = min(max_iedge(1),iedge(1)) iedge(2) = min(max_iedge(2),iedge(2)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 2d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 2d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT16_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT16_2D !------------------------------------------------------------------- ! Subroutine to read 2D int32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT32_2D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(2), intent(inout) :: istart, istride integer(kind=int4), dimension(2), intent(inout) :: iedge integer(kind=int4), dimension(:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(2) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 2) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istart(2) < 0) istart(2) = 0 if (istride(1) < 1) istride(1) = 1 if (istride(2) < 1) istride(2) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) if (iedge(2) < 0) iedge(2) = int(ceiling(real(sds_dims(2))/real(istride(2)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) max_iedge(2) = int(ceiling(real(sds_dims(2) - istart(2))/real(istride(2)))) iedge(1) = min(max_iedge(1),iedge(1)) iedge(2) = min(max_iedge(2),iedge(2)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 2d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 2d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT32_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT32_2D !------------------------------------------------------------------- ! Subroutine to read 2D float32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT32_2D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(2), intent(inout) :: istart, istride integer(kind=int4), dimension(2), intent(inout) :: iedge real(kind=real4), dimension(:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(2) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 2) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istart(2) < 0) istart(2) = 0 if (istride(1) < 1) istride(1) = 1 if (istride(2) < 1) istride(2) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) if (iedge(2) < 0) iedge(2) = int(ceiling(real(sds_dims(2))/real(istride(2)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) max_iedge(2) = int(ceiling(real(sds_dims(2) - istart(2))/real(istride(2)))) iedge(1) = min(max_iedge(1),iedge(1)) iedge(2) = min(max_iedge(2),iedge(2)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 2d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 2d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT32_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT32_2D !------------------------------------------------------------------- ! Subroutine to read 2D float64 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT64_2D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(2), intent(inout) :: istart, istride integer(kind=int4), dimension(2), intent(inout) :: iedge real(kind=real8), dimension(:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status integer(kind=int4), dimension(2) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT64) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 2) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (istart(1) < 0) istart(1) = 0 if (istart(2) < 0) istart(2) = 0 if (istride(1) < 1) istride(1) = 1 if (istride(2) < 1) istride(2) = 1 if (iedge(1) < 0) iedge(1) = int(ceiling(real(sds_dims(1))/real(istride(1)))) if (iedge(2) < 0) iedge(2) = int(ceiling(real(sds_dims(2))/real(istride(2)))) max_iedge(1) = int(ceiling(real(sds_dims(1) - istart(1))/real(istride(1)))) max_iedge(2) = int(ceiling(real(sds_dims(2) - istart(2))/real(istride(2)))) iedge(1) = min(max_iedge(1),iedge(1)) iedge(2) = min(max_iedge(2),iedge(2)) if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 2d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 2d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT64_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT64_2D !------------------------------------------------------------------- ! Subroutine to read 3D int8 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT8_3D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(3), intent(inout) :: istart, istride integer(kind=int4), dimension(3), intent(inout) :: iedge integer(kind=int1), dimension(:,:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status, idim integer(kind=int4), dimension(3) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_UINT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 3) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif do idim=1, sds_rank if (istart(idim) < 0) istart(idim) = 0 if (istride(idim) < 1) istride(idim) = 1 if (iedge(idim) < 0) iedge(idim) = int(ceiling(real(sds_dims(idim))/real(istride(idim)))) max_iedge(idim) = int(ceiling(real(sds_dims(idim) - istart(idim))/real(istride(idim)))) iedge(idim) = min(max_iedge(idim),iedge(idim)) end do if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2) .or. & size(buffer,3) < iedge(3)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 3d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2),iedge(3)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 3d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT8_3D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT8_3D !------------------------------------------------------------------- ! Subroutine to read 3D int16 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT16_3D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(3), intent(inout) :: istart, istride integer(kind=int4), dimension(3), intent(inout) :: iedge integer(kind=int2), dimension(:,:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status, idim integer(kind=int4), dimension(3) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT16) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 3) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif do idim=1, sds_rank if (istart(idim) < 0) istart(idim) = 0 if (istride(idim) < 1) istride(idim) = 1 if (iedge(idim) < 0) iedge(idim) = int(ceiling(real(sds_dims(idim))/real(istride(idim)))) max_iedge(idim) = int(ceiling(real(sds_dims(idim) - istart(idim))/real(istride(idim)))) iedge(idim) = min(max_iedge(idim),iedge(idim)) end do if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2) .or. & size(buffer,3) < iedge(3)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 3d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2),iedge(3)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 3d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT16_3D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT16_3D !------------------------------------------------------------------- ! Subroutine to read 3D int32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_INT32_3D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(3), intent(inout) :: istart, istride integer(kind=int4), dimension(3), intent(inout) :: iedge integer(kind=int4), dimension(:,:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status, idim integer(kind=int4), dimension(3) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 3) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif do idim=1, sds_rank if (istart(idim) < 0) istart(idim) = 0 if (istride(idim) < 1) istride(idim) = 1 if (iedge(idim) < 0) iedge(idim) = int(ceiling(real(sds_dims(idim))/real(istride(idim)))) max_iedge(idim) = int(ceiling(real(sds_dims(idim) - istart(idim))/real(istride(idim)))) iedge(idim) = min(max_iedge(idim),iedge(idim)) end do if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2) .or. & size(buffer,3) < iedge(3)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 3d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2),iedge(3)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 3d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_INT32_2D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_INT32_3D !------------------------------------------------------------------- ! Subroutine to read 3D float32 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT32_3D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(3), intent(inout) :: istart, istride integer(kind=int4), dimension(3), intent(inout) :: iedge real(kind=real4), dimension(:,:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status, idim integer(kind=int4), dimension(3) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT32) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 3) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif do idim=1, sds_rank if (istart(idim) < 0) istart(idim) = 0 if (istride(idim) < 1) istride(idim) = 1 if (iedge(idim) < 0) iedge(idim) = int(ceiling(real(sds_dims(idim))/real(istride(idim)))) max_iedge(idim) = int(ceiling(real(sds_dims(idim) - istart(idim))/real(istride(idim)))) iedge(idim) = min(max_iedge(idim),iedge(idim)) end do if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2) .or. & size(buffer,3) < iedge(3)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 3d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2),iedge(3)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 3d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT32_3D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT32_3D !------------------------------------------------------------------- ! Subroutine to read 3D float64 hdf data. !------------------------------------------------------------------- function READ_HDF_SDS_FLOAT64_3D(Sd_Id, Sds_Name, istart, istride, iedge, buffer, type) result(Error_Status) integer(kind=int4), intent(in) :: Sd_Id character(*), intent(in) :: Sds_Name character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int4), dimension(3), intent(inout) :: istart, istride integer(kind=int4), dimension(3), intent(inout) :: iedge real(kind=real8), dimension(:,:,:), allocatable, intent(inout) :: buffer integer(kind=int4), intent(out), optional :: type integer(kind=int4) :: astatus, Istatus, Sds_Id, sds_rank, Sds_Type, Sds_Nattr, Error_Status, idim integer(kind=int4), dimension(3) :: sds_dims, max_iedge logical:: size_check Error_Status = SUCCEED Sds_Id = sfselect(Sd_Id, sfn2index(Sd_Id,trim(Sds_Name))) if (Sds_Id == FAIL) then print "(a,'Error selecting ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Error_Status = FAIL return endif Istatus = sfginfo(Sds_Id, Sds_Name_Temp, sds_rank, sds_dims, Sds_Type, Sds_Nattr) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name_Temp),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT64) then print "(a,'Error reading (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (sds_rank /= 3) then print "(a,'Error reading (rank mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif do idim=1, sds_rank if (istart(idim) < 0) istart(idim) = 0 if (istride(idim) < 1) istride(idim) = 1 if (iedge(idim) < 0) iedge(idim) = int(ceiling(real(sds_dims(idim))/real(istride(idim)))) max_iedge(idim) = int(ceiling(real(sds_dims(idim) - istart(idim))/real(istride(idim)))) iedge(idim) = min(max_iedge(idim),iedge(idim)) end do if (allocated(buffer)) then if (size(buffer,1) < iedge(1) .or. & size(buffer,2) < iedge(2) .or. & size(buffer,3) < iedge(3)) then deallocate(buffer,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 3d HDF buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(buffer))) then allocate(buffer(iedge(1),iedge(2),iedge(3)),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 3d buffer.')",EXE_PROMPT stop endif endif !--- check for conistency in size of input and output size_check = CHECK_EDGE_VS_OUTPUT_SHAPE(iedge,shape(buffer)) !-- if not consistent size, return and don't attempt to read if (.not. size_check) then print *, "Size inconsistency in READ_HDF_SDS_FLOAT64_3D, skipping read" Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrdata(Sds_Id, istart, istride, iedge, buffer) if (Istatus /= 0) then print "(a,'Error reading ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Sds_Name),Sd_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_SDS_FLOAT64_3D !------------------------------------------------------------------- ! This routine is used to read char8 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_CHAR8_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name !character(len=len(Sds_Name)):: Sds_Name_Temp character(len=*), intent(inout) :: attr character(len=1000), dimension(1) :: buffer integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrcatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrcatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id attr = " " Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif attr = TRIM(buffer(1)(1:count)) Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_CHAR8_SCALAR !------------------------------------------------------------------- ! This routine is used to read int8 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT8_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name !character(len=len(Sds_Name)):: Sds_Name_Temp integer(kind=int1), intent(inout) :: attr integer(kind=int4), intent(out), optional :: type integer(kind=int1), dimension(1) :: buffer character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED attr = MISSING_VALUE_INT1 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (count /= 1) then print "(a,'Error reading attribute (count mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrnatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) attr = buffer(1) return end function READ_HDF_ATTRIBUTE_INT8_SCALAR !------------------------------------------------------------------- ! This routine is used to read int16 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT16_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name integer(kind=int2), intent(inout) :: attr integer(kind=int4), intent(out), optional :: type integer(kind=int2), dimension(1) :: buffer character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED attr = MISSING_VALUE_INT2 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT16) then print*,trim(Sds_Name),type,DFNT_INT16 print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (count /= 1) then print "(a,'Error reading attribute (count mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrnatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) attr = buffer(1) return end function READ_HDF_ATTRIBUTE_INT16_SCALAR !------------------------------------------------------------------- ! This routine is used to read int32 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT32_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name integer(kind=int4), intent(inout) :: attr integer(kind=int4), intent(out), optional :: type integer(kind=int4), dimension(1) :: buffer character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED attr = MISSING_VALUE_INT4 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT32) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (count /= 1) then print "(a,'Error reading attribute (count mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrnatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) attr = buffer(1) return end function READ_HDF_ATTRIBUTE_INT32_SCALAR !------------------------------------------------------------------- ! This routine is used to read float32 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_FLOAT32_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name real(kind=real4), intent(inout) :: attr integer(kind=int4), intent(out), optional :: type real(kind=real4), dimension(1) :: buffer character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED attr = MISSING_VALUE_REAL4 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT32) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (count /= 1) then print "(a,'Error reading attribute (count mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrnatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) attr = buffer(1) return end function READ_HDF_ATTRIBUTE_FLOAT32_SCALAR !------------------------------------------------------------------- ! This routine is used to read float64 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_FLOAT64_SCALAR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name real(kind=real8), intent(inout) :: attr integer(kind=int4), intent(out), optional :: type real(kind=real8), dimension(1) :: buffer character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED attr = MISSING_VALUE_REAL8 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT64) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (count /= 1) then print "(a,'Error reading attribute (count mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfrnatt(Sds_Id, Attr_Index, buffer) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) attr = buffer(1) return end function READ_HDF_ATTRIBUTE_FLOAT64_SCALAR !------------------------------------------------------------------- ! This routine is used to read int8 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT8_VECTOR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name integer(kind=int1), dimension(:), allocatable, intent(inout) :: attr integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status, astatus integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT8 .and. & Sds_Type /= DFNT_UINT8 .and. & Sds_Type /= DFNT_CHAR8 .and. & Sds_Type /= DFNT_CHAR) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (allocated(attr)) then if (size(attr,1) < count) then deallocate(attr,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF attr buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(attr))) then allocate(attr(count),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d attr buffer.')",EXE_PROMPT stop endif endif Istatus = sfrnatt(Sds_Id, Attr_Index, attr) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_INT8_VECTOR !------------------------------------------------------------------- ! This routine is used to read int16 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT16_VECTOR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name integer(kind=int2), dimension(:), allocatable, intent(inout) :: attr integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status, astatus integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED ! attr = MISSING_VALUE_REAL4 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT16 .AND. & Sds_Type /= DFNT_UINT16) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (allocated(attr)) then if (size(attr,1) < count) then deallocate(attr,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF attr buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(attr))) then allocate(attr(count),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d attr buffer.')",EXE_PROMPT stop endif endif attr = MISSING_VALUE_INT2 Istatus = sfrnatt(Sds_Id, Attr_Index, attr) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_INT16_VECTOR !------------------------------------------------------------------- ! This routine is used to read int32 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_INT32_VECTOR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name integer(kind=int4), dimension(:), allocatable, intent(inout) :: attr integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status, astatus integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED ! attr = MISSING_VALUE_REAL4 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_INT32 .AND. & Sds_Type /= DFNT_UINT32) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (allocated(attr)) then if (size(attr,1) < count) then deallocate(attr,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF attr buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(attr))) then allocate(attr(count),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d attr buffer.')",EXE_PROMPT stop endif endif attr = MISSING_VALUE_INT4 Istatus = sfrnatt(Sds_Id, Attr_Index, attr) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_INT32_VECTOR !------------------------------------------------------------------- ! This routine is used to read float32 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_FLOAT32_VECTOR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name real(kind=real4), dimension(:), allocatable, intent(inout) :: attr integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status, astatus integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED !attr = MISSING_VALUE_REAL4 Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT32) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (allocated(attr)) then if (size(attr,1) < count) then deallocate(attr,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF attr buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(attr))) then allocate(attr(count),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d attr buffer.')",EXE_PROMPT stop endif endif attr = MISSING_VALUE_REAL4 Istatus = sfrnatt(Sds_Id, Attr_Index, attr) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_FLOAT32_VECTOR !------------------------------------------------------------------- ! This routine is used to read float32 HDF SDS attributes. !------------------------------------------------------------------- function READ_HDF_ATTRIBUTE_FLOAT64_VECTOR(id, Sds_Name, Attr_Name, attr, type) result(Error_Status) integer(kind=int4), intent(in) :: id character(len=*), intent(in) :: Sds_Name, Attr_Name real(kind=real8), dimension(:), allocatable, intent(inout) :: attr integer(kind=int4), intent(out), optional :: type character(len=1020) :: name integer(kind=int4) :: Istatus, Attr_Index, Sds_Type, count, Sds_Id, Error_Status, astatus integer :: sffattr, sfrnatt, sfgainfo, sfn2index, sfselect, sfendacc Error_Status = SUCCEED Sds_Id = sfselect(id, sfn2index(id,trim(Sds_Name))) if (Sds_Id == FAIL) Sds_Id = id Attr_Index = sffattr(Sds_Id, trim(Attr_Name)) if (Attr_Index == FAIL) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Error_Status = FAIL return endif Istatus = sfgainfo(Sds_Id, Attr_Index, name, Sds_Type, count) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (present(type)) then type = Sds_Type Istatus = sfendacc(Sds_Id) Error_Status = SUCCEED return endif if (Sds_Type /= DFNT_FLOAT64) then print "(a,'Error reading attribute (type mismatch) ',a,' from Sd_Id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif if (allocated(attr)) then if (size(attr,1) < count) then deallocate(attr,stat=astatus) if (astatus /= 0) then print "(a,'Error deallocating 1d HDF attr buffer.')",EXE_PROMPT stop endif endif endif if ((.not. allocated(attr))) then allocate(attr(count),stat=astatus) if (astatus /= 0) then print "(a,'Not enough memory to allocate 1d attr buffer.')",EXE_PROMPT stop endif endif attr = MISSING_VALUE_REAL8 Istatus = sfrnatt(Sds_Id, Attr_Index, attr) if (Istatus /= 0) then print "(a,'Attribute ',a,' reading error from id: ',i0)",EXE_PROMPT,trim(Attr_Name),Sds_Id Istatus = sfendacc(Sds_Id) Error_Status = FAIL return endif Istatus = sfendacc(Sds_Id) return end function READ_HDF_ATTRIBUTE_FLOAT64_VECTOR !------------------------------------------------------------------------------- ! !------------------------------------------------------------------------------- function CHECK_EDGE_VS_OUTPUT_SHAPE(size_in, size_out) result(size_check) integer(kind=int4), dimension(:), intent(in):: size_in integer(kind=int4), dimension(:), intent(in):: size_out logical:: size_check integer:: i, n n = size(size_in) size_check = .true. do i = 1,n if (size_in(i) /= size_out(i)) size_check = .false. enddo return end function CHECK_EDGE_VS_OUTPUT_SHAPE !====================================================================== end module CX_HDF4_MOD