c---- freadpathP------------------------------------------------------------- integer function freadpathP(hdf_file,project,dataset_name, & source_name,processing_level,reference_date, & start_date,stop_date,position_type,grid_type, & grid_name,projection,latitude,longitude, & Temporal_Res,Spatial_X_Res,Spatial_Y_Res, & lat_grid, & lon_grid,temp,wvapor,sktemp,fcld,clpress, & cltemp,zangle,emiss,pblstrat,Cg,alpha, & IIIreject,obs,temp_sd, & wvapor_sd,sktemp_sd,fcld_sd,clpress_sd,cltemp_sd, & zangle_sd,emiss_sd,pblstrat_sd,Cg_sd,alpha_sd) c------------------------------------------------------------------------------- c This program provides a fortran interface to the TOVS pathP files in HDF c format. c implicit none integer*4 DFACC_RDONLY,XGRDSZ,YGRDSZ parameter(DFACC_RDONLY=1,YGRDSZ=67,XGRDSZ=67) c input: character *(*) hdf_file c output: c Meta Data character*256 project character*256 dataset_name character*256 source_name character*256 processing_level character*256 reference_date character*256 start_date character*256 stop_date character*256 position_type character*256 grid_type character*256 projection character*256 grid_name real*4 latitude(4) real*4 longitude(4) character*256 Temporal_Res character*256 Spatial_X_Res character*256 Spatial_Y_Res c scientific data sets real*4 lat_grid(XGRDSZ,YGRDSZ) real*4 lon_grid(XGRDSZ,YGRDSZ) real*4 temp(XGRDSZ,YGRDSZ,9) real*4 wvapor(XGRDSZ,YGRDSZ,5) real*4 sktemp(XGRDSZ,YGRDSZ) real*4 fcld(XGRDSZ,YGRDSZ) real*4 clpress(XGRDSZ,YGRDSZ) real*4 cltemp(XGRDSZ,YGRDSZ) real*4 zangle(XGRDSZ,YGRDSZ) real*4 emiss(XGRDSZ,YGRDSZ) real*4 pblstrat(XGRDSZ,YGRDSZ) real*4 cg(XGRDSZ,YGRDSZ) real*4 alpha(XGRDSZ,YGRDSZ) real*4 iiireject(XGRDSZ,YGRDSZ) real*4 obs(XGRDSZ,YGRDSZ) real*4 temp_sd(XGRDSZ,YGRDSZ,9) real*4 wvapor_sd(XGRDSZ,YGRDSZ,5) real*4 sktemp_sd(XGRDSZ,YGRDSZ) real*4 fcld_sd(XGRDSZ,YGRDSZ) real*4 clpress_sd(XGRDSZ,YGRDSZ) real*4 cltemp_sd(XGRDSZ,YGRDSZ) real*4 zangle_sd(XGRDSZ,YGRDSZ) real*4 emiss_sd(XGRDSZ,YGRDSZ) real*4 pblstrat_sd(XGRDSZ,YGRDSZ) real*4 cg_sd(XGRDSZ,YGRDSZ) real*4 alpha_sd(XGRDSZ,YGRDSZ) c HDF function declarations integer*4 sfn2index,sfrdata,sfselect,sfginfo,sfstart,sffinfo integer*4 ppgetattr_c,ppgetattr_f,sfattr,sfend c internal variables integer*4 hdf_id,ret,ndatasets,nglobal_attr,error integer*4 rank,nattrs,number_type,i integer*4 ppgetsds c Memory storage notes: c C: c buffer [NVARS][YGRDSZ][XGRDSZ] c Fortran,IDL: c buffer(XGRDSZ,YGRDSZ,NVARS) c initializations error=0 c open SD interface to access file with name HDF_FILE hdf_id =sfstart(HDF_FILE, DFACC_RDONLY) c You can obtain information about the hdf file through this call ret = sffinfo(hdf_id,ndatasets, nglobal_attr) c read Meta data stored as SD attribtutes ret = ppgetattr_c(hdf_id,"PROJECT", project) error = error+ret ret = ppgetattr_c(hdf_id,"DATASET_NAME", dataset_name) error = error+ret ret = ppgetattr_c(hdf_id,"SOURCE_NAME", source_name) error = error+ret ret = ppgetattr_c(hdf_id,"PROCESSING_LEVEL", processing_level) error = error+ret ret = ppgetattr_c(hdf_id,"REFERENCE_DATE", reference_date) error = error+ret ret = ppgetattr_c(hdf_id,"START_DATE", start_date) error = error+ret ret = ppgetattr_c(hdf_id,"STOP_DATE", stop_date) error = error+ret ret = ppgetattr_c(hdf_id,"POSITION_TYPE", position_type) error = error+ret ret = ppgetattr_c(hdf_id,"GRID_TYPE", grid_type) error = error+ret ret = ppgetattr_c(hdf_id,"PROJECTION", projection) error = error+ret ret = ppgetattr_c(hdf_id,"Temporal_Res", Temporal_Res) error = error+ret ret = ppgetattr_c(hdf_id,"Spatial_X_Res", Spatial_X_Res) error = error+ret ret = ppgetattr_c(hdf_id,"Spatial_Y_Res", Spatial_Y_Res) error = error+ret ret = ppgetattr_f(hdf_id,"LATITUDE", latitude) error = error+ret ret = ppgetattr_f(hdf_id,"LONGITUDE", longitude) error = error+ret c The below call would allow you to obtain information about a c specific scientific data set c ret = sfginfo(sds_id,DATASET_NAME, rank, dimsizes, c & number_type, nattrs) c c Latitude and Longitude Grids are external files; c there is no lat/lon information in the TOVS SDS HDF files c The files LatGrd.exhdf and LonGrd.exhdf must be in the c same directory from which this software is run c ret=ppgetsds(hdf_id,"LATITUDE_GRID",lat_grid,1) error=error+ret ret=ppgetsds(hdf_id,"LONGITUDE_GRID",lon_grid,1) error=error+ret c ret=ppgetsds(hdf_id,"TEMP",temp,9) error=error+ret ret=ppgetsds(hdf_id,"WVAPOR",wvapor,5) error=error+ret ret=ppgetsds(hdf_id,"SKTEMP",sktemp,1) error=error+ret ret=ppgetsds(hdf_id,"FCLD",fcld,1) error=error+ret ret=ppgetsds(hdf_id,"CLPRESS",clpress,1) error=error+ret ret=ppgetsds(hdf_id,"CLTEMP",cltemp,1) error=error+ret ret=ppgetsds(hdf_id,"ZANGLE",zangle,1) error=error+ret ret=ppgetsds(hdf_id,"EMISS",emiss,1) error=error+ret ret=ppgetsds(hdf_id,"PBLSTRAT",pblstrat,1) error=error+ret ret=ppgetsds(hdf_id,"Cg",cg,1) error=error+ret ret=ppgetsds(hdf_id,"ALPHA",alpha,1) error=error+ret ret=ppgetsds(hdf_id,"IIIreject",iiireject,1) error=error+ret ret=ppgetsds(hdf_id,"OBS",obs,1) error=error+ret ret=ppgetsds(hdf_id,"TEMP-SD",temp_sd,9) error=error+ret ret=ppgetsds(hdf_id,"WVAPOR-SD",wvapor_sd,5) error=error+ret ret=ppgetsds(hdf_id,"SKTEMP-SD",sktemp_sd,1) error=error+ret ret=ppgetsds(hdf_id,"FCLD-SD",fcld_sd,1) error=error+ret ret=ppgetsds(hdf_id,"CLPRESS-SD",clpress_sd,1) error=error+ret ret=ppgetsds(hdf_id,"CLTEMP-SD",cltemp_sd,1) error=error+ret ret=ppgetsds(hdf_id,"ZANGLE-SD",zangle_sd,1) error=error+ret ret=ppgetsds(hdf_id,"EMISS-SD",emiss_sd,1) error=error+ret ret=ppgetsds(hdf_id,"PBLSTRAT-SD",pblstrat_sd,1) error=error+ret ret=ppgetsds(hdf_id,"Cg-SD",cg_sd,1) error=error+ret ret=ppgetsds(hdf_id,"ALPHA-SD",alpha_sd,1) error=error+ret if (error.lt.0) then write(0,*) 'Error reading file : ', hdf_file endif ret=sfend(hdf_id) return end integer function ppgetsds(hdf_id, sdsname,sds,nz) c------------------------------------------------------------------------------- c This function obtains a single scientific data set in file pointed to by c hdf_id. The name of the scientific data sets is given in sdsname c c Input: c integer*4 hdf_id HDF file ID as returned by sfstart c character *(*) name of Scientific Data set c real*4 sds(MAXSIZE) c This buffer must be large enough to c hold the entire data set c integer*4 nz number of elements in z dimension implicit none integer*4 MAXSIZE parameter(MAXSIZE=67*67*9) integer*4 hdf_id,nz,i character*(*) sdsname real*4 sds(MAXSIZE) c internal variabels integer*4 index,sds_id,ret integer*4 START(3),STRIDE(3),EDGE(3) c hdf function declarations integer*4 sfn2index,sfrdata,sfselect,sfendacc c WARNING: STRIDE is set to 1,1,1 due to a bug in HDF3.3r3 the correct c values should be 0,0,0. Future versions of HDF may have this fixed data (START(i),i=1,3) /0,0,0/ data (STRIDE(i),i=1,3) /1,1,1/ data (EDGE(i),i=1,3) /67,67,0/ EDGE(3)= nz c get index of data set in HDF file print*,'sdsname :',sdsname index = sfn2index(hdf_id,sdsname) c select data data set sds_id = sfselect(hdf_id, index) ppgetsds = sfrdata(sds_id, START, STRIDE, EDGE,sds) ret = sfendacc(sds_id) call heprnt(0) return end integer function ppgetattr_c(hdf_id,attribute_name,attribute) C----------------------------------------------------------------------- c This function obtains a single global character attributes from the c PATH P hdf file which is pointed to by hdf_id c c input: c integer*4 hdf_id id returned from sfstart c character*(*) attribute_name Metadata attribute to return c character*(*) attribute value of attribute c returns: c 0 : success c -1: error c----------------------------------------------------------------------- implicit none c interface integer*4 hdf_id character*(*) attribute_name,attribute c FIX for SOLARIS character*64 attr_name c HDF functions integer*4 sfrattr,sffattr,sfgainfo c internal variables integer*4 index,number_type,length,ret c print*,'attribute_name :',attribute_name index=sffattr(hdf_id,attribute_name) c print*,'Index:',index ret = sfgainfo(hdf_id,index,attr_name, number_type, & length) ppgetattr_c=sfrattr(hdf_id,index,attribute(1:length)) c c print attribute value to standard output c print *,attribute(1:length) return end integer function ppgetattr_f(hdf_id,attribute_name,attribute) C----------------------------------------------------------------------- c This function obtains a 4 element floating point attribute from the c PATH P hdf file which is pointed to by hdf_id c c input: c integer*4 hdf_id id returned from sfstart c character*(*) attribute_name Metadata attribute to return c real*4 attribute(4) value of attribute c returns: c 0 : success c -1: error c----------------------------------------------------------------------- implicit none c interface integer*4 hdf_id character*(*) attribute_name real*4 attribute c HDF functions integer*4 sfrattr,sffattr c internal variables integer*4 index index=sffattr(hdf_id,attribute_name) ppgetattr_f=sfrattr(hdf_id,index,attribute) return end