c *********************************************************************
c 
c The makefile contains a line (the last line) on which is found
c the "address" of the HDF library required at link time.
c The path of the file might need to be changed to accomplish
c the program link.
c 
c The program thus produced will be quite large (410K bytes).
c *********************************************************************
c# Make sure that when this file is written to makefile, that the 
c# makefile source lines start in column 1.  On the link line (the last
c# line) bound the line to column 1, then insert a tab before the "$"
c# character.
c#
c FFLAGS = -u -O
c OBJECTS = ReadNonScanner.o
c 
c ReadNonScanner:	$(OBJECTS)
c $(LINK.f) -o $@ $(OBJECTS) /home/hdf/HDF3.3r3/lib/libdf.a
c *********************************************************************
c  Version 2.0        Date: 06/02/94    Programmer: Langley DAAC
c  Version 2.1        Date: 06/29/94    Programmer: Langley DAAC
c  Version 2.2        Date: 07/01/94    Programmer: Langley DAAC
c  Version 2.3        Date: 07/14/94    Programmer: Langley DAAC
c  Version 2.4        Date: 07/26/94    Programmer: Langley DAAC
c  Version 2.5        Date: 08/08/94    Programmer: Langley DAAC
c
c  06/02/94   The longitude values which are stored in the S-4G HDF
c             files are being stored from -180 to 180 where as the
c             data is being stored from 0 to 360 degrees.
c
c             !!!!!!!!!!!!!!!!!!   NOTE   !!!!!!!!!!!!!!!!!!!!!!!
c             The longitude values in the data files have not been
c             corrected.  Only this read program has been modified
c             to correct this presentation of the data.  This is only
c             affected when a user selects data from a latitude/longitude
c             option.  If the user decides to use an outside piece of
c             software which depends on these latitude/longitude values,
c             please ignore these values.
c
c  06/29/94   Corrected the error of printing out the min/max values
c             in reverse pretaining to reading 8-bit data.
c
c  07/01/94   Corrected the portion of the code which converted 8-bit
c             data from character to integer using the command called
c             ICHAR.  This intrinsict command only converts positive
c             integers ranging from 0 to 255.  This code has been 
c             modified to convert negative values correctly.
c             There were some code lines that went pass the 72nd column.
c             These lines have been shifted to the left.
c
c  07-14-94   When presenting the parameter names to the user to make
c             a selection of which parameters to read, the incorrect
c             term was being printed out following each parameter name.
c             I am referring to the Zonal/Global terms.
c             Request statements were also reworded at this time.
c
c  07/26/94  The minimum and maximum values are incorrect within the HDF data
c            files for the longwave and shortwave parameters.  So that the
c            user would not get this information from the data file, the 
c            print lines for this information have been commented out in
c            this code.  For the correct values for all parameters, please
c            refer to the ERBE S-4G User's Guide.
c            Zonal and Global values were not being printed out 
c            correctly in the report file.  This was corrected.
c
c  08/08/94  It was recommended to change the word REGION to BAND when
c            printing out Band values in the report file.  The other 
c            suggestion was start the count at 1 instead of 0.  There is
c            no Band or Region number that starts its count at 0.
c *********************************************************************
  
cc *********************************************************************
cc 
cc  The following list of parameters needs to be extracted from this file
cc  and written to another file (called s4gnread.i) prior to attempting
cc  to compile the program.
cc
c
c       integer RUNIT
c       parameter (RUNIT = 8)
c
c       integer TRUE
c       parameter (TRUE = 1)
c       integer FALSE
c       parameter (FALSE = 0)
c 
c       integer LABLEN
c       integer COLS
c       integer MAXNUM
c       integer SCRLNS
c       parameter (LABLEN = 45)
c       parameter (COLS = 5)
c       parameter (MAXNUM = 1024)
c       parameter (SCRLNS = 15)
c 
c       integer GROUP1
c       integer GROUP2
c       integer GROUP3
c       parameter (GROUP1 = 1)
c       parameter (GROUP2 = 2)
c       parameter (GROUP3 = 3)
c 
c       integer DEG5
c       integer DEG10
c       parameter (DEG5 = 16)
c       parameter (DEG10 = 32)
c 
c       integer REGION
c       integer ZONAL
c       parameter (REGION = 256)
c       parameter (ZONAL = 512)
c 
c       integer NF5
c       integer NF10
c       integer NFZG
c       integer SF10
c       integer SFZG
c       parameter (NF5 = REGION + DEG5 + GROUP1)
c       parameter (NF10 = REGION + DEG10 + GROUP1)
c       parameter (NFZG = ZONAL + DEG10 + GROUP3)
c       parameter (SF10 = REGION + DEG10 + GROUP1)
c       parameter (SFZG = ZONAL + DEG10 + GROUP2)
c 
c       integer NREG5
c       integer NREG10
c       parameter (NREG5 = 180 * 360 / 25)
c       parameter (NREG10 = 180 * 360 / 100)
c 
c       integer MXRANK
c       parameter (MXRANK = 2)
c 
c 
c       integer DFTAG_NDG
c       parameter (DFTAG_NDG = 720)
c 
c       integer DFTAG_SD
c       parameter (DFTAG_SD = 702)
c 
c       integer DFACC_READ
c       parameter (DFACC_READ = 1)
c 
c       integer DFNT_INT8
c       parameter (DFNT_INT8 = 20)
c 
c       integer DFNT_INT16
c       parameter (DFNT_INT16 = 22)
c 
c       integer DFNT_INT32
c       parameter (DFNT_INT32 = 24)
c 
cc
cc **** ulv   : The North-West corner (latitude)
cc **** ulh   : The North-West corner (longitude)
cc **** llv   : The South-East corner (latitude)
cc **** llh   : The South-East corner (longitude)
cc **** start : The first region to be printed
cc **** stop  : The last region to be printed
cc **** 
cc **** Either the first four elements will have real
cc **** values or the last two will, NOT both.
cc
c      common /regin/ ulv, ulh, lrv, lrh, begin1, end1
c      integer ulv
c      integer ulh
c      integer lrv
c      integer lrh
c      integer begin1
c      integer end1
c
c
cc
cc **** This common block allows us to have only
cc **** one print routine.  When we get to the print
cc **** routine, it is smart enough to know where it
cc **** needs to go to get the data out of this structure
cc
c      common /values/ data ,dwvalue, wvalue, wdumy, bvalue, bdumy
c      integer*4 dwvalue(2592)
c      real*4 data(2592)
c      integer*2 wvalue(2592)
c      integer*2 wdumy(2592)
c      character bvalue(2592)
c      character bdumy(7776)
c
cc
cc **** This common block allows us to get the 
cc **** scale factors from the HDF file more easily
cc
c        common /scales/ dwscale, wscale, wdummy, bscale, bdummy
c	integer*4 dwscale(72)
c 	integer*2 wscale(72)
c 	integer*2 wdummy(72)
c 	character bscale(72)
c 	character bdummy(216)
 
c**********************************************************************
c*     This ends the s4gnread.i file.   (above this line)
c**********************************************************************


c**********************************************************************
c   Name -  main                         Module -
c   Language - FORTRAN                   Type - 
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    A basic program driver.  It is intended to get things done, as a
c    supervisor will, not by acutually doing the work, but making sure
c    the work gets done.
c  
c   Output Files -
c    The report file, the name of which is generated in another
c    function
c  
c   Input Parameters -
c    NONE
c  
c   Output Parameters -
c    NONE
c  
c   Key Local Parameters -
c     integer ftype                     : Flag word indicating the type
c                                         of input data
c     integer nlabls                    : Number of labels/SDS found in
c                                         the data file
c     integer rlist(MAXNUM)             : Reference list
c     integer selist(MAXNUM)            : User selection list of SDS
c     record /coords/ regin             : User selected list of regions
c     character*32 fname                : Name of HDF file
c     characger*32 rname                : Name of report file
c     character*(LABLEN) lables(MAXNUM) : Place to hold label list
c  
c   Subroutines Called -
c    gdlabs : Get all the data labels from the HDF file
c    gfdata : Get all we know about the file and print it
c    gfname : Get the user to help us build the HDF file name
c    gftype : Get the type of data in the file 
c             (NF5, NF10, NFZG, SF10, SFZG)
c    selsds : Get a list of user desired SDSs
c    report : Write the actual data to the report
c    subset : Further subset the extracted data based upon region
c             or lat/long
c  
c   Exit States -
c  
c**********************************************************************

      program ReadNonScanner
      include "s4gnread.i"

      integer ftype
      integer nlabls
      integer rlist(MAXNUM)
      integer selist(MAXNUM)

      character*1 iwhich
      character*32 fname
      character*32 rname
      character*(LABLEN) labels(MAXNUM)

      integer gfname
      integer gfname2
      integer gftype
      integer gftype2
      integer gfdata
      integer selsds
      integer subset
      integer done
      integer iret


c
c **** The HDF functions/subroutines
c
      integer dallist

      ulv = 0
      ulh = 0
      lrv = 0
      lrh = 0
      begin1 = 0
      end1 = 0
c      do 100 counter = 1, 6
c          regin.dummy(counter) = 0
c100   continue

c
c **** Print the welcoming message 
c
      print *, 'Welcome to the S-4G Non-Scanner HDF data read program'
      print *, ' '
      print *, ' '
      print *,'********************************************************'
      print *,'*                                                      *'
      print *,'*           S-4G HDF NONSCANNER READ PROGRAM           *'
      print *,'*                                                      *'
      print *,'*           Version 2.5       August 08, 1994          *' 
      print *,'*                                                      *'
      print *,'* NOTE TO THE USER!!!!!                                *'
      print *,'*   FOR YOUR INFORMATION AS HOW THE DATA HAS BEEN      *'
      print *,'*   STORED IN THE S-4G HDF FILE, LATITUDE VALUES AND   *'
      print *,'*   LONGITUDE VALUES HAVE BEEN ADDED TO THE DATA FILE. *'
      print *,'*   IGNORE THESE VALUES WHEN USING OTHER HDF PACKAGES  *'
      print *,'*   BECAUSE THESE NUMBERS WILL NOT REPRESENT THE DATA  *'
      print *,'*   CORRECTLY.  THIS READ PROGRAM HAS BEEN MODIFIED TO *'
      print *,'*   HANDLE THESE VALUES.  IF YOU HAVE ANY QUESTIONS,   *'
      print *,'*   PLEASE FEEL FREE TO CONTACT THE LANGLEY DAAC.      *'
      print *,'*   THE WAY THAT THE LATITUDE AND LONGITUDE VALUES ARE *'
      print *,'*   STORED IN THE DATA FILE WILL NOT HAVE ANY MEANING  *'
      print *,'*   OR REPRESENT THE DATA CORRECTLY IN OUTSIDE         *'
      print *,'*   SOFTWARE PACKAGES.                                 *'
      print *,'*   THIS READ CODE HAS BEEN CORRECTED IN PRINTING OUT  *'
      print *,'*   OUT THE MINIMUM AND MAXIMUM VALUES IN REVERSE      *'
      print *,'*   ORDER.                                             *'
      print *,'*   DATA VALUES WHICH PRETAINED TO THE 8-BIT VALUES    *'
      print *,'*   ONLY WERE CONVERTED CORRECTLY IN THE ORIGINAL CODE.*'
      print *,'*   ALL POSITIVE VALUES WERE PRINTED CORRECTLY BUT NOT *'
      print *,'*   THE NEGATIVE VALUES.  THIS HAS NOW BEEN CORRECTED. *'
      print *,'*                                                      *'
      print *,'*   07/26/94  THE MINIMUM AND MAXIMUM VALUES ARE       *'
      print *,'*   INCORRECT WITHIN THE HDF DATA FILES FOR THE        *'
      print *,'*   LONGWAVE AND SHORTWAVE PARAMETERS.  SO THAT THE    *'
      print *,'*   USER WOULD NOT GET THIS INFORMATION FROM THE       *'
      print *,'*   DATA FILE, THE PRINT LINES FOR THIS INFORMATION    *'
      print *,'*   HAVE BEEN COMMENTED OUT IN THIS CODE.  FOR THE     *'
      print *,'*   CORRECT VALUES FOR ALL PARAMETERS, PLEASE REFER    *'
      print *,'*   TO THE ERBE S-4G USER"S GUIDE.                     *'
      print *,'*                                                      *'
      print *,'********************************************************'
      done=0
      do while (done .ne. 1)
        print*," "
        print*," "
        print*,"This program gives you two options."
        print*,"You can build either a 's4g' file or a 's4gn' file."
        print*,"The options are either '1' or '2'"
        print*,"Please enter a option number now."
        print*,"-------------------"
	print*,"option   type"
        print*,"-------------------"
        print*,"  1      s4g"
        print*,"  2     s4gn"
        print*,"-------------------"
        read(*,99) iwhich
        if ((iwhich .lt. '1') .or. (iwhich .gt. '2')) then
  	  print*,"this is not a valid option. ",iwhich
        else
	  done = 1
        endif
      end do
99    format(a)
c
c **** Get the user to input data required to generate
c **** the HDF filename.
c **** Need to get the HDF filename and the report
c **** file name.
c
        iret = 0
        if (iwhich .eq. "1") then
          iret = gfname(fname, rname)
	else
          iret = gfname2(fname, rname)
	endif
        if(iret .ne. 0)then
c
c ****    Get the file type, now that we know that
c ****    we have a good file name and that it 
c ****    matches a real data file.
c
        if (iwhich .eq. "1") then
	  ftype = gftype(fname)
        endif
        if (iwhich .eq. "2") then
	  ftype = gftype2(fname)
        endif
c
c ****    This should not be a problem, but good
c ****    practice requires that we check for it.
c
	 if(ftype .ne. 0)then
	     open(unit = RUNIT, file = rname, access = 'SEQUENTIAL', 
     1            form = 'FORMATTED', err = 9111)
c
c ****        Go put to the report file everything we know
c ****        about the data file, itself.
c
	     if(gfdata(fname) .eq. 1)then
c
c ****            Get the annotation labels associated with each of
c ****            the SDSs
c
                 nlabls = dallist(fname, DFTAG_NDG, rlist, labels,
     1                            MAXNUM, LABLEN, 1)
c
c ****            If we got at least one, then all is cool!
c
		 if(nlabls .ne. -1)then
c
c ****               Let the user select the desired labels
c
		    if(selsds(selist, labels, nlabls, ftype) .ne. 0)then
			if(subset(ftype) .ne. 0)then
                        print*,"Now call report"
			    call report(selist, nlabls, labels, 
     1                                  rlist, fname, ftype)
			    write(*, 1000)rname
			end if
		    end if
		 end if
	     end if
	     close(RUNIT)
	     goto 9999
9111         print *, 'main(): Unable to open the report file'
	     print *, ' '
	 else
	 end if
      else
      end if
1000  format(//'The generated report will be written to "',a25,'"',//)
9999  end
c**********************************************************************
c   Name - gfname()                      Module -
c   Language - FORTRAN                   Type - function
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To extract from the user the information needed to determine
c    the name fo the required data file, check to see if the 
c    file exists and returning that file name to the calling
c    routine.
c  
c   Output Files -
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c     logical     ex       : Does the file exist?
c     logical     good     : Do we have a good data date?
c     character   fov      : To hold Field of View
c     character   proc     : To hold Processing type
c     character*2 resol    : To hold data resolution
c     character*4 ddate    : To hold data date
c     character   scode    : To hold Sat Code
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      integer function gfname(
     $                        fname, rname)
      character*32 fname
      character*32 rname

      include "s4gnread.i"

      integer     ex
      integer     good
      logical     ex1
      character   fov
      character   proc
      character*4 resol
      character*4 ddate
      character*4 scode

c
c **** Assume there will be a problem
c
      gfname = 0

c
c **** Print an intro and a warning
c
      print *, 'The name of the HDF file must conform to the standards'
      print *, 'developed by NASA/Langley for HDF granual ids.'
      print *, 'Please modify this code if the names have changed or'
      print *, 'are not located in the current working directory.'
      print *, ' '

c
c **** Need to introduce ourself and let him/her know
c **** the available options
c
      print *, 'In all of the following, '
      print *, 'case of your response is not important.'
      print *, 'In addition, if you wish to ABORT'
      print *, 'you may enter an ''a'' at any query.'
      print *, ' '

c
c **** Make sure we can get into the loop
c
      fov = ' '
c
c **** While we do not have a valid input, loop
c
      do while((fov .ne. 'm') .and. 
     1         (fov .ne. 'w') .and. 
     2         (fov .ne. 'a'))
c
c **** Write our query to the user and wait for his input.  when
c **** we get the input, convert it to lower case for the above
c **** comparison.  This makes our comparison that much shorter.
c
	  write(*, 1110) 
1110      format('There are two types of field-of-view, '
     1           '(W)ide Field-of-View or (M)edium Field-of-View.',
     1           /,'Enter Field-of-View.  -->', $)
          read (*, 1111) fov
1111      format(a1)
c
c **** Make the input lower case
c
	  call tolower(fov)
      end do
c
c **** If the user did not chose to abort the run, we continue
c
      if(fov .ne. 'a')then
	  proc = ' '
	  do while((proc .ne. 'n') .and. 
     1             (proc .ne. 's') .and. 
     2             (proc .ne. 'a'))
	      write(*, 1120)
1120          format(// 'There are two types of nonscanner data, '
     1                  '(N)umerical Filter or (S)hape Factor.',/,
     2                  ' Enter type of data.  -->', $)
	      read (*, 1111) proc
	      call tolower(proc)
	  end do


	  if(proc .ne. 'a')then
	      resol = '  '
	      do while((resol(1:1) .ne. 'a') .and. 
     1                 (resol(1:1) .ne. '5') .and.
     2                 (resol(1:2) .ne. '10') .and. 
     3                 (resol(1:2) .ne. 'zg'))
		  write(*, 1130)
1130              format(// 'There are three resolutions of data, '
     1                      '5 degree by 5 degree,',
     2                   /,'5 by 5 nested to 10 by 10 degree, and '
     3                      'Zonal-Global data.',/,
     4                   'Enter resolution: (5) (10) or (zg) '
     5                      '--->', $)
		  read(*, 1132)resol
1132  format(a4)
c
c **** Make both characters we need lower case
c
		  call tolower(resol(1:1))
		  if(resol(2:2) .ne. ' ') then
		      call tolower(resol(2:2))
		  end if
	      end do


	      if(resol(1:1) .ne. 'a')then
c
c **** If the user gave us a 5 degree requirement
c **** we need to make it a '5.'
c
		 if(resol(1:1) .eq. '5')then
		     resol = '5.'
		 end if
c
c **** We need to get into the loop somehow
c
		 good = FALSE
		 do while (good .eq. FALSE) 
		     write(*, 1140)
1140                 format(// 'Enter data date in the format YYMM.'
     1                          '  --> ',$)
		     read(*, 1132)ddate
c
c **** If the user aborted on us, then no need to worry about getting
c **** a good date
c
		     if(ddate(1:1) .ne. 'a')then
			 if((ddate(1:4) .ge. '8411') .and. 
     1                      (ddate(1:4) .le. '9002')) then
			     good = TRUE
			 end if
		     else
c
c **** To get out of the loop This does not pose a problem because we
c **** have an 'a' in ddate(1:1)
c
			 good = TRUE
		     end if
		 end do
c
c **** Get the sat code
c
		 if(ddate(1:1) .ne. 'a')then
		     scode = ' '
c
c **** The sat code must be in the right range (1 - 7)
c
		     do while((scode(1:1) .ne. 'a') .and.
     1                       ((scode(1:1) .le. '1') .or.
     2                        (scode(1:1) .ge. '7')))
			 write(*, 1150)
1150                     format(// 'Please indicate the satellite'
     1                              'combination, from the',
     2                          / 'following list, you desire:',
     3                          / '  (1) NOAA-9              '
     4                               '(5) ERBS & NOAA-9',
     5                          / '  (2) ERBS                '
     6                               '(6) ERBS & NOAA-10',
     7                          / '  (3) NOAA-10             '
     8                               '(7) ERBS, NOAA-9, & NOAA-10',
     9                          / '  (4) NOAA-9 & NOAA-10           '
     A                               '---> ',$)
			 read(*, 1132)scode
			 call tolower(scode(1:1))
			 print*,"scode ",scode(1:1)
		     end do
		     if(scode(1:1) .ne. 'a')then
c
c **** Build the file name, then the report name based upon the first
c **** 16 characters of the file name
c
 			 fname = 's4g_'//fov//proc//'f'//resol(1:2)//
     1                           '_'//ddate(1:4)//'_'//scode(1:1)
			 rname = fname(1:16)//'.rpt'
c
c **** Find out if the file name we built for the user really is 
c **** available.
c
			 inquire(file = fname, exist = ex1)
c                         if(ex1 .eq. .TRUE.) then
c                            ex = TRUE
c                         endif
c
c **** If so, then we can let the calling function know that 
c **** everything went as planned.
c
                         ex = TRUE
			 if(ex .eq. TRUE)then
			     print *, ' '
		     print *, 'The report will be written to ', rname
			     gfname = 1
			 end if
		     end if
		 end if
	      end if
	  end if
      end if
      return
      end
      subroutine tolower ( text )
      character text

      integer num

      num = ichar(text)
      if (num.ge.65 .and. num.le.90) then
	  text = char(num+32)
      end if 
      return
      end
      subroutine toupper ( text )
      character text

      integer num

      num = ichar(text)
      if (num.ge.97 .and. num.le.122) then
	  text = char(num-32)
      end if 
      return
      end




c*****************************************************************
c                    SUBROUTINE STR2INT                          *
c*****************************************************************
c
c Name - str2int                     Type - subroutine
c 
c Version - 1.0   date - 07/28/93   Programmer- Nichele Brown(SAIC)
c
c Purpose - This subroutine converts a character string to an integer
c
c Input parameter - buffer : the character string to be converted
c
c Output parameter - value : the converted integer value
c                    iret : return flag
c                           0 - conversion was a success
c                           1 - no convertible string
c                           2 - string contained only spaces
c
c Key Local Parameters - subval : holds the value being converted
c                        mark : holds the position within the string
c                        nest : holds a single char. conversion
c                        loopcnt : loop counter
c                        spcnt : number of spaces in the string
c
c Subroutines called - none.
c
c*****************************************************************

      subroutine str2int(buffer, value, start, iret)

      character buffer*80
      integer subval, value, sign
      integer mark, next, loopcnt, spcnt, iret, start

      spcnt = 0
      value = 0
      sign = 1
      iret = 0

c ****** validate that the string represents a numerical value ******

      do 100 loopcnt = start, len(buffer)
	if (buffer(loopcnt:loopcnt) .eq. ' ') spcnt = spcnt + 1
	if ((buffer(loopcnt:loopcnt) .lt. '0') .or.
     &  (buffer(loopcnt:loopcnt) .gt. '9')) then
	  if (buffer(loopcnt:loopcnt) .ne. ' ') iret = 1
        endif
100   continue

      mark = start
      subval = 0

      if (spcnt .eq. 80) then
	iret = 2
      else

c ******  skip the leading spaces of the string ******

	do while (buffer(mark:mark) .eq. ' ')
	  mark = mark + 1
        end do

c ****** convert the number from a string to a real ******

        if (buffer(mark:mark) .eq. '-') then
	  sign = -1
	  mark = mark + 1
	endif


        do while (buffer(mark:mark) .ne. ' ' .and.
     &            ichar(buffer(mark:mark)) .ne. 0)
	  next = ichar(buffer(mark:mark)) - 48
	  subval = subval * 10.0 + next
	  mark = mark + 1
        end do

        do while (mark .le. 80)
	  if (buffer(mark:mark) .ne. ' ' .and. 
     &        ichar(buffer(mark:mark)) .ne. 0) iret = 1
	  mark = mark + 1
        end do
      endif


      value = subval * sign

c *************************************************************
c *                    EXIT SUBROUTINE                        *  
c *************************************************************
1100  return
      end
c**********************************************************************
c   Name - gftype                        Module -
c   Language - FORTRAN                   Type - function
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To return to the calling routine a flag word indicating everything
c    we are able to determine about the characteristics of a file just
c    from the file name.  See s4gnread.i for the value of set bits in
c    the flag word.
c  
c   Input Parameters -
c    We are passed a pointer to the character string holding the file
c    name.
c  
c   Output Parameters -
c    The flag word, as described above.
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      integer function gftype(
     $                        fname)

      character*32 fname

      include "s4gnread.i"

      character dumy0
      character dumy1
c
c **** Always assume the worst, that we will have 
c **** problems
c
      gftype = 0
c
c **** Get the processing type
c
      dumy0 = fname(6:6)
c
c **** Get the resolution
c
      dumy1 = fname(8:8)
c
c **** Do we have Numerical Filter?
c
      if(dumy0 .eq. 'n')then
c
c ****    5 degree?
c
	 if(dumy1 .eq. '5')then
	     gftype = NF5
	 else
c
c ****       How about 10 degree?
c
	    if(dumy1 .eq. '1')then
		gftype = NF10
	    else
c
c ****           Check to make sure we have ZG
c
		if(dumy1 .eq. 'z')then
		    gftype = NFZG
		end if
	    end if
	 end if
      else
c
c ****    If not numerical filter, how about shape factor?
c
	 if(dumy0 .eq. 's')then
c
c ****       10 Degree resolution?
c
	    if(dumy1 .eq. '1')then
		gftype = SF10
	    else
c
c ****           How about zg?
c
		if(dumy1 .eq. 'z')then
		    gftype = SFZG
		end if
	    end if
	 end if
      end if
      return
      end
c****************************************************************
      integer function gftype2(
     $                        fname)
 
      character*32 fname
 
      include "s4gnread.i"
 
      character dumy0
      character dumy1
crats
c
c **** Always assume the worst, that we will have
c **** problems
c
      gftype2 = 0
c
c **** Get the processing type
c
      dumy0 = fname(7:7)
c
c **** Get the resolution
c
      dumy1 = fname(9:9)
c
c **** Do we have Numerical Filter?
c
      if(dumy0 .eq. 'n')then
c
c ****    5 degree?
c
         if(dumy1 .eq. '5')then
             gftype2 = NF5
         else
c
c ****       How about 10 degree?
c
            if(dumy1 .eq. '1')then
                gftype2 = NF10
            else
c
c ****           Check to make sure we have ZG
c
                if(dumy1 .eq. 'z')then
                    gftype2 = NFZG
                end if
            end if
         end if
      else
c
c ****    If not numerical filter, how about shape factor?
c
         if(dumy0 .eq. 's')then
c
c ****       10 Degree resolution?
c
            if(dumy1 .eq. '1')then
                gftype2 = SF10
            else
c
c ****           How about zg?
c
                if(dumy1 .eq. 'z')then
                    gftype2 = SFZG
                end if
            end if
         end if
      end if
      return
      end
c**********************************************************************
c   Name - gfdata                        Module -
c   Language - FORTRAN                   Type - 
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To extract from the HDF file all the file description type data
c  
c   Output Files -
c    The report file will be updated with the file description data 
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      integer function gfdata
     i                      (fname)

      include "s4gnread.i"

      character*32 fname

      integer Hopen
      integer dagfidl
      integer dagfid
      integer dagfds
      integer hdfile
      integer length
      integer mark
      character*5000 buffer

c
c **** Always assume the worst, that things are 
c **** going to fail somewhere
c
      gfdata = 0

c
c **** Open the HDF file so we can get the length of the
c **** file id
c
      hdfile = Hopen(fname, DFACC_READ, 0)
c
c **** Did we get the file open?
c
      if(hdfile .ne. 0)then
c
c **** Get the length of the ID
c
	  length = dagfidl(hdfile, 1)
	  if(length .ne. -1)then
	      length = length + 1
c
c **** Get the file id and write it to the report
c
	      if(dagfid(hdfile, buffer, length, 1) .ne. -1)then
		  write(RUNIT, 110)
                  length = 0
                  do mark = 1, len(buffer)
                    if (ichar(buffer(mark:mark)) .ne. 0) then
                      length = length + 1
                    endif
                  end do
                  write(RUNIT, *) buffer(1:length)
c
c **** Get the file description and start to write it to the report
c **** also.  This is a many part process.
c
		  if(dagfds(hdfile, buffer, 5000, 1) .ne. -1)then
c
c **** Write the label for the text
c
		      write(RUNIT, 120)
c
c **** This should get us the data out to the report just fine
c **** because it was preformatted when it was written to the
c **** HDF file.
c
                      length = 0
                      do mark = 1, len(buffer)
                        if (ichar(buffer(mark:mark)) .ne. 0) then
                          length = length + 1
                        endif
                      end do
                      write(RUNIT, *) buffer(1:length)
c
c **** I don't believe it!!  We actually got it done!!!
c
		      gfdata = 1
		  else
		      print *, 'gfdata(): Error extracting file
     1                          description'
		  end if
	      else
		  print *, 'gfdata(): Error getting the HDF file id'
	      end if
	  else
	      print *, 'gfdata(): Error getting length of the file id'
	  end if
	  call Hclose(hdfile)
      else
	  print *, 'gfdata(): Error attempting to open HDF file',fname
      end if
110   format(' File ID:'/)
120   format(//, ' File Description:', /)
      return
      end

c**********************************************************************
c   Name - selsds                        Module -
c   Language - FORTRAN                   Type - 
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      integer function selsds(
     i                  selist,
     i                  labels,
     i                  nlabls,
     i                  ftype)


      include "s4gnread.i"


      integer            selist(MAXNUM)
      character*(LABLEN) labels(MAXNUM)
      integer            nlabls
      integer            ftype

      integer RECCNT
      parameter (RECCNT = 24)

      integer recrds(RECCNT, 2)
      data recrds/
     1  1, 2, 3, 4, 5, 36, 60, 61, 62, 63, 64, 65,
     2 66, 97, 128, 159, 183, 207, 231, 232, 263, 294, 318, 342,
     3 32, 32, 32, 32, 32, 32, 16, 16, 16, 16, 16, 16, 
     4 16, 16, 16, 16, 16, 16, 16, 8, 8, 8, 8, 0
     5           /

      integer iret
      integer done
      integer count0
      integer count1
      integer count2
      integer value
      character*32 selstr
      do 100 count0 = 1, nlabls
	  selist(count0) = 0
100   continue
      write(*, 1110)nlabls
      call dlist(labels, 1, nlabls, ftype, recrds)
c*************************************************************
      do while(done .ne. TRUE)
	  write(*, 1120)
c  call Enter selection.  --> here
	  read (*, 101) selstr
101       format(a32)
	  call tolower(selstr(1:1))
c------------------------------------------------------------------
	  if(selstr(1:1) .eq. 'a') then
	      do 200 count0 = 1, nlabls
		  selist(count0) = 0
200           continue
              done = TRUE
	  else
c
c **** Does the user want to remove a selection from the list?
c
cdog
c------------------------------------------------------------------
	      if(selstr(1:1) .eq. 'd') then
                  call str2int(selstr, value, 2, iret)
c                  read(selstr(2:len(selstr)), *)value
		  if(value .le. nlabls) then
 		      count0 = 1
 		      count2 = recrds(RECCNT, 1) -1
 		      count1 = (value / count2) * count2
cmyfix
                      value = recrds(value, 1)
 		      do while(count0 .le. RECCNT .and.
     1                  value .gt. (count1 + recrds(count0, 1)))
 			  count0 = count0 + 1
 		      end do
 		      if(value .eq. (count1 + recrds(count0, 1))) then
 			  count2 = count1 + recrds(count0 + 1, 1) - 1
c			  do 300 count1 = value, count2
			     selist(count0) = 0
300                       continue
		      else
			  write(*, 1130)value
		      end if
		  else
		      write(*, 1140)nlabls
		  end if
	      else
c
c **** Does the user want us to display a selection list
c
		  if(selstr(1:1) .eq. 'l') then
c                     read(selstr(2:len(selstr)), *)value
                      call str2int(selstr, value, 2, iret)
		      call dlist(labels, value, nlabls, ftype, recrds)
		  else
c
c **** Does the user want us to go and generate a report?
c
		      if(selstr(1:1) .eq. 'q') then
			  count0 = 0
c
c **** Determine if there is a report to generate
c
			  do while(count0 .le. nlabls .and.
     1                      selist(count0) .eq. 0)
			      count0 = count0 + 1
			  end do
			  if(count0 .eq. nlabls) then
			      write(*, 1150)
			  end if
			  done = TRUE
		      else
c
c **** Does the user want to select a record?
c
			  if(selstr(1:1) .eq. 's') then
c                             read(selstr(2:len(selstr)), *)value
                              call str2int(selstr, value, 2, iret)
c
c **** Make sure that the desired record is allowed,
c **** i.e. it is in the HDF file.
c
			      if(value .le. nlabls) then
c
c **** Our offset into the recrds array
c
				 count0 = 1
c
c **** Record number of the last record in recrds
c **** strictly a temporary usage
c
				 count2 = recrds(RECCNT, 1) - 1
				 count1 = (value / count2) * count2
c
c **** Make sure we are still within array bounds, while looking
c **** for our user's value
c
cmy fix
                                 value = recrds(value, 1)
				 do while(count0 .le. RECCNT .and.
     1                             value.gt.(count1+recrds(count0, 1)))
				   count0 = count0 + 1
				 end do
c
c **** If we found the user's value, we can start the selection process
c
c-----------------------------------------------------------------------
cmyfix
			 if(value.eq.(count1+recrds(count0, 1)))then
c-----------------------------------------------------------------------
			     count2 = count1 + recrds(count0 + 1, 1) - 1
c
c **** Starting from the users request to the end of that record group
c **** select the parameter record number for output to the report
c
				         selist(count0) = 1
400                                  continue
				 else
c
c **** The user's input is not found in the "allowed" list
c
				     write(*, 1130)value
				 end if
			      else
c
c **** The user's input is not within bounds
c
				  write(*, 1140)nlabls
			      end if
			  else
c
c **** We have gotten a bogus input from the user, need to 
c **** teach the fool how things are done
c
			      call shelp()
			  end if
c------------------------------------------------------------------
		      end if
		  end if
	      end if
	  end if
      end do
c*************************************************************
c
c **** Find the first selected item.  If we get to the end
c **** of the selection list without finding an item selected
c **** the user must have aborted the selection
c
      count0 = 1
      do while(count0 .le. nlabls .and. selist(count0) .eq. 0)
	  count0 = count0 + 1
      end do
cmyfix
      count0 = count0 - 1
      if(count0 .eq. nlabls+1) then
	  write(*, 1160)
          selsds = 0
      else
         selsds = -1
      end if
      return
1110  format(//, ' There are ', i4, ' SDSs in this file.', /,
     1       ' This is the first portion of the list',//, ' ')
1120  format(//,'Enter selection.  --> ', $)
1130  format('SDS', i5, ' is not a valid choice.', /, 
     1       ' see above list or press ''h'' for help.', /, ' ')
1140  format(//, ' Error: Selection must fall between 1 and', i5)
1150  format('NO PARAMETERS WERE SELECTED!!', //, ' ')
1160  format(//'Data read ABORTED !!', //, ' ')
      end



c**********************************************************************
c   Name - dlist                         Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine dlist(
     i                 labels,
     i                 start,
     i                 nlabls,
     i                 ftype,
     i                 recrds)

      include "s4gnread.i"

      integer RECCNT
      parameter (RECCNT = 24)

      character*(LABLEN) labels(MAXNUM)
      integer start
      integer nlabls
      integer ftype
      integer recrds(RECCNT,2)


      integer lnum
      integer nrecs
      integer rcnt
      integer offset
      integer si
      integer ri
      integer lthru
      integer c0
      character*8 scope(6)
      character*11 resol(3)


      data scope /'Regional', 'Zonal', 'Zonal', 'Global',
     1            'Zonal', 'Global'/
      data resol /'Five Degree', 'Ten Degree', ' '/

      rcnt = recrds(RECCNT, 1) - 1
      if(start .le. nlabls) then
	  c0 = mod(start, rcnt)
	  offset = RECCNT
cmyfix	  do while(offset .gt. 0 .and. recrds(offset,1) .gt. c0)
          istop = RECCNT - c0
          istop = RECCNT - istop
          if(c0 .lt. 6) istop = 1
          do while(offset .gt. 0 .and. offset .gt. istop)
	      offset = offset - 1
	  end do
	  lthru = (start / rcnt)
c----------------------------------------------------------------------
	  if(ftype .eq. NF5) then
	      si = 1
	      ri = 1
	  else
	      if(ftype .eq. NF10 .or. ftype .eq. SF10) then
		  si = 1
		  ri = 2
	      else
		  if(ftype .eq. NFZG) then
		      si = lthru + 2
		      ri = mod(lthru, 3)+1
		  else
		      if(ftype .eq. SFZG) then
c 07-14-94 This line presented to the user the string zonal instead of stating
c          that the data was global data.  
c                         si = lthru + 2
                          si = lthru + 3
			  ri = lthru + 2
		      else
		      end if
		  end if
	      end if
	  end if
c----------------------------------------------------------------------
	  c0 = 1
c**********************************************************************
          k=0
	  do while(c0 .le. SCRLNS .and. 
cmyfix     1        ((rcnt * lthru) + (recrds(offset, 1))) .le. nlabls)
     1        ((rcnt * lthru) + (recrds(offset, 1))) .le. 342)
	      if(offset .eq. RECCNT) then
		  lthru = lthru + 1
		  offset = 1
		  ri = ri + 1
		  si = si + 1
                  k = 9
	      end if
cmyfix	      lnum = (rcnt * lthru) + (recrds(offset, 1))
	      lnum =  offset 
              k=k+1
	      nrecs = recrds(offset + 1, 1) - recrds(offset, 1)
cmyfix
              if(k .lt. 6) then
                if (offset .le. 23) then
	            write(*, 1110)lnum, labels(lnum), nrecs,
     1                           recrds(offset, 2), resol(ri), scope(si)
                endif
              endif
	        c0 = c0 + 1
	        offset = offset + 1
	  end do
c**********************************************************************
	  call shelp()
      else
	  write(*, 1120)nlabls
      end if
      return
1110  format('[',i4,'] : ',a25, ' : ',i2, ' records of ', i2, 
     1       ' bit data (', a11, a10,')')
1120  format('Please ask for a list starting between 1 and ', i4)
      end



c**********************************************************************
c   Name - shelp                         Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine shelp


      print *, ' '
      print *, ' '
      print *, 'There are 6 commands available:'
      print *, 'In all the following, "nnnn" refers to the item number'
      print *, 'a       : ABORT - discard all selection criteria, ',
     1         'generate no report'
      print *, 'dnnnn   : DELETE a chosen parameter "nnnn" from',
     1         ' the selection list'
      print *, 'lnnnn   : LIST new selection list to screen, ',
     1         'starting at "nnnn"'
      print *, 'q       : QUIT and generate the desired report'
      print *, 'snnnn   : Add parameter "nnnn" to the SELECTION list'
      print *, 'h       : HELP - Generate this message'

      return
      end
c**********************************************************************
c   Name - subset                        Module -
c   Language - FORTRAN                   Type - function
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c     fypte               : The type of file we working on
c     regin               : Sturcture of data 
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c     logical      done   : Flag to indicate major loop done
c     integer      deg    : Resolution of data
c     integer      start  : Starting region number
c     integer      stop   : Ending region number
c     real         ulat   : Define the cordinates of the selection
c     real         ulong  : grid on a map, using Lat/Long
c     real         llat   :
c     real         llong  :
c     character    dummy  : Place to hold user input
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      integer function subset(
     i                        ftype)
      include "s4gnread.i"

      integer ftype

      integer      done
      integer      deg
      integer      end
      integer      begin
      real         ulat
      real         ulong
      real         llat
      real         llong
      character    dummy

c
c **** This time, we are going to assume that
c **** everything is going to go all right
c
      subset = 1

c
c **** Get a number to represent the resolution
c **** of the data in the file
c
      if(and(ftype,DEG5) .ne. 0) then
	  deg = 5
      else
	  deg = 10
      end if
c
c **** Do we need the user to select the regional pick list?
c **** If we are dealing with regional data, we need to give the
c **** user the choice.  Zonal-Global data it does not make much
c **** sense to do so, especially since it would be difficult to
c **** implement
c
      if(and(ftype, REGION) .ne. 0) then
	  write(*, 1110)
1110      format(//, ' This program has the capability to further'
     1               ' subset the regional data', /, ' based upon user'
     2               ' require ments, expressed in units of either'
     3               ' Lat/Long or',/, ' by requesting a range of'
     4               ' region numbers.'//)
c
c **** We are going to keep going around in this loop
c **** until we get some sort of usable response from
c **** the user
c
	  done = FALSE
	  do while(done .eq. FALSE)
	      write(*, 1120)
1120          format('Please indicate that you are interested in'
     1               'further subsetting', /, ' the data selected'
     2               ' by entering (L) for Lat/Long, (R) for'
     3               ' Regional', /, ' subsetting, (N) for'
     4               ' NO SUBSETTING, or (A) to Abort'
     5               ' program. (L/N/R/A)       ---> ',$)
	      read (*, 1121) dummy
1121          format(a1)
c
c **** Make user response lower case
c
	      call tolower(dummy)
c
c **** Did the user abort the program on us?
c
	      if(dummy .eq. 'a') then
		  print *, 'Data Extraction ABORTED!!'
		  subset = 0
		  done = TRUE
	      else
c
c **** The user going to do things by lat and long?
c
		  if(dummy .eq. 'l') then
		      do while(done .eq. FALSE)
			  write(*, 1130)
1130  format('Please enter North-West corner Lat/Long '
c 05/31/94 to correct longitude error
c    1'(90.0 <= x < -90.0, -180.0 <= x < 180.0) -> ',$)
     1'(90.0 <= x < -90.0  0.0 <= x < 360.0) -> ',$)
			  read (*, *) ulat, ulong
			  write(*, 1140)
1140  format('Please enter South-East corner Lat/Long '
c 05/31/94 to correct longitude error
c    1'(90.0 <= x < -90.0, -180.0 <= x < 180.0) -> ',$)
     1'(90.0 <= x < -90.0  0.0 <= x < 360.0) -> ',$)
			  read (*, *) llat, llong
c 05/31/94 to correct longitude error
c        		  if(ulat .gt. 90.0 .or. ulong .lt. -180.0 .or.
c    1                       llat .le. -90.0 .or. llong .ge. 180.0) then
			  if(ulat .gt. 90.0 .or. ulong .lt. 0.0 .or.
     1                       llat .le. -90.0 .or. llong .ge. 360.0) then
			      print *, ' '
	      print *, 'Please enter coordinates per above instructions'
			      print *, ' '
			  else
			      done = TRUE
			  end if
		      end do
		      done = FALSE
c
c **** Assume, if you will, a grid system where the origin is in the
c **** upper left corner.  Positive progress along the 'X' axis is to
c **** the right.  Positive progress along the 'Y' axis is down.
c ****
c **** ulh is the horizontal position of the start
c ****     of the selected region
c **** ulv is the vertical position of the start 
c ****     of the selected region
c **** lrh is the horizontal position of the end
c ****     of the selected region
c **** llv is the vertical position of the end 
c ****     of the selected region
c
                      ulv =
     1                   (abs(int(90.0 - ulat)) / deg) + 1
                      ulh =
     1                   (abs(int(ulong)) / deg) + 1
c 05/31/94 to correct longitude error
c    1                   (abs(int(180.0 + ulong)) / deg) + 1
                      lrv =
     1                   ((abs(int(90.0 - llat))+(deg / 2)) / deg) + 1
		      if(lrv .gt. (180 / deg)) then
			  lrv = (180/deg)
		      end if
                      lrh = 
     1                   ((abs(int(0.0 + llong))+(deg / 2)) / deg) + 1
c 05/31/94 to correct longitude error
c    1                   ((abs(int(180.0 + llong))+(deg / 2)) / deg) + 1
		      if(mod(lrh, (360/deg) + 1) .eq. 0) then
			 lrh = lrh - 1
		      end if
c
c **** Make sure that the North-West corner is both North and West of
c **** the South-East corner
c
		      if((ulh .gt. lrh) .or.
     1                   (ulv .gt. lrv)) then
	          print *, 'The North-West corner can never be either'
	          print *, 'South or East of the South-East corner'
		          print *, 'of the subset!!!'
		      else
		          done = TRUE
		      end if
		  else
c
c **** Is the user asking to enter the range of regions that
c **** he/she wants?
c
		      if(dummy .eq. 'r') then
100                      write(*, 1150)((360 * 180) / (deg * deg)), deg
1150                     format(//, ' Please enter the starting and'
     1                   ' ending region number,', /, ' in the range '
     2                   'of 1 -> ', i4, ' and in the format of', ///, 
     3                   '        ''start  stop''', //, 'bearing in '
     4                   'mind that the file contains data', /, ' at a '
     5                   'resolution of ', i2, ' degrees             '
     6                   '---> ',$)
			 read (*, *) begin, end
                         print *, begin, '   ', end
c1151                     format(I, x1, I)
			 if((begin .lt. 1) .or. (begin .gt. end) .or.
     1                      (end.gt.(((360*180)/(deg*deg))+1)))then
				goto 100
			 else
c
c **** Save the start and stop region numbers for future use.
c
			     begin1 = begin
			     end1 = end
			     done = TRUE
			 end if
                      else
c
c **** The user dosn't care about the amount of data he will have to
c **** wade through, so we will be giving him all the data we can get
c **** our hands on.
c
			  if(dummy .eq. 'n') then
			     begin1 = 1
			     end1 = ((360 * 180) / (deg * deg))
			     done = TRUE
			  else
			      done = FALSE
			  end if
		      end if
		  end if
	      end if
	  end do
      end if
      return
      end

c**********************************************************************
c   Name - report                        Module -
c   Language - FORTRAN                   Type - function
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    This is a driver to make sure the user requested data actually
c    finds its way into a report file
c  
c   Output Files -
c  
c   Input Parameters -
c     i  selist   : Array of selected parameters
c     i  nlabls   : Number of SDSs in the HDF file
c     i  regin    : Coord structure
c     i  labels   : Array of data labels
c     i  rlist    : Array of reference numbers
c     i  fname    : Name of HDF file
c     i  ftype    : Type of data in the HDF file
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine report(
     $                   selist, 
     $                   nlabls, 
     $                   labels, 
     $                   rlist, 
     $                   fname, 
     $                   ftype)

      include "s4gnread.i"
      integer selist(MAXNUM)
      integer nlabls
      character*(LABLEN) labels(*)
      integer rlist(*)
      character*32 fname
      integer ftype
      integer iret
      integer DFNT_FLOAT32
      parameter (DFNT_FLOAT32=5)

      integer dsrref
      integer dsgdims
      integer dsgdast
      integer dsgnt
      integer daglab
      integer dsgrang
      integer count
      integer numdim
      integer numtyp
      integer arydim(MXRANK)
      integer min
      integer max
      integer scale
      integer*2 wmax
      integer*2 wmin
      character bmin
      character bmax
      character*(LABLEN) dlabel
      character*32 dunits
      character*16 dfmt
      character*16 dcoord
      character*(LABLEN) tlab


c
c **** Go through the entire label list, looking for those that have
c **** been selected to extracted from the HDF file.
c
      do 9999 count = 1, nlabls
c
c **** Skip those parameters that the user has not chosen to be 
c **** extracted from the file
c
	  if(selist(count) .ne. 0) then
c
c **** Tell the user which one we are working on now
c
	      write(*, 1110)count, labels(count)
c
c **** Accomplish something very like a random access
c **** to the desire SDS
c
        iret = dsrref(fname, rlist(count))
	if (iret .eq. 0) then
c
c **** Get the number of dimensions, and the size of each
c
		  if(dsgdims(fname, numdim, arydim, MXRANK) .eq. 0) then
c
c **** Get the attribute strings that are stored in the HDF file
c
                   if(dsgdast(dlabel, dunits, dfmt, dcoord) .eq. 0) then
c
c **** Get the type of data that is stored in this record (8, 16, 32 bit)
c
			  if(dsgnt(numtyp) .eq. 0) then
c
c **** Get the scale factor string
c
c----6----------------------------------------------------------------72>
 	     iret = daglab(fname, DFTAG_SD, rlist(count),
     1                                  tlab, len(tlab))
         if(iret .ne. 0) then
	   iret = 0
	   scale = 1
         endif
                              if (iret .eq. 0) then
c
c **** Turn this scale factor string into a real number that
c **** can be used to do number type things.
c
                                   tlab(LABLEN:LABLEN) = ' '
				   if(scale .ne. 1) then 
                                     call str2int(tlab, scale, 1, iret)
				   endif
c                                 read(tlab, *)scale

c
c **** Write the data label, the data units, and the format string
c **** that should be used to interpret the data (f11.4)
c
				  write(RUNIT, 1120)dlabel, dunits, dfmt
c
c **** Depending on the type of data we are getting (8, 16, 32 bit), there
c **** will be a different routine used to dump the data to the report
c
				  if(numtyp .eq. DFNT_INT8) then
c
c **** Need to write to the report file such things as the number of
c **** dimensions, the dimension label string, and the dimension
c **** scales.
c
                             call ritdim(numtyp, numdim, arydim, ftype)
c
c **** Get the maximum and minimum acceptable values for the data
c
c 
c 6-30-94 This line printed the min/max in reverse order.  This had to 
c         to be changed.              if(dsgrang(bmin, bmax) .eq. 0) then
			             iret = dsgrang(bmax, bmin)
				     if (iret .eq. 0) then
					  min = int(ichar(bmin))
					  max = int(ichar(bmax))
c
c **** Write this to the report.  This is done in a subroutine so that
c **** we don't end up writing the code more than once in this program.
c
					  call finhd(min, max, scale)
c
c **** Write the data to the report.  Need three different write
c **** routines to handle the different data types.
c
					  call wbyte(fname,
     1                                        numdim, arydim,
     2                                        ftype, scale)
				      else
					  write(RUNIT, 1130)
				      end if
				  else
                                      if(numtyp .eq. DFNT_FLOAT32) then
                             call ritdim(numtyp, numdim, arydim, ftype)
			          call s4gnwdword(fname,
     1                                                numdim,
     2                                                arydim, ftype,
     3                                                scale)
 				 endif
				      if(numtyp .eq. DFNT_INT16) then
                             call ritdim(numtyp, numdim, arydim, ftype)
c
c 6-30-94 This line printed the min/max in reverse order.  This had to 
c         to be changed.                  if(dsgrang(wmin, wmax) .eq. 0) then
c
                                     if(dsgrang(wmax, wmin) .eq. 0) then
					      min = int(wmin)
					      max = int(wmax)
			      call finhd(min, max, scale)
					      call wword(fname,
     1                                            numdim,
     2                                     arydim, ftype, scale)
c----6----------------------------------------------------------------72>
					  else
					      write(RUNIT, 1130)
					  end if
				      else
c***************************************************************************
                                         if(numtyp .eq. DFNT_INT32) then
                              call ritdim(numtyp, numdim, arydim, ftype)
c
c 6-30-94 This line printed the min/max in reverse order.  This had to 
c         to be changed.                      if(dsgrang(min, max) .eq. 0) then
c
                                       iret = dsgrang(max, min)
				       if (iret .eq. 0) then
                                             call finhd(min, max, scale)
					          call wdword(fname,
     1                                                numdim,
     2                                                arydim, ftype,
     3                                                scale)
					      else
						  write(RUNIT, 1130)
					      end if
					  end if
				      end if
				  end if
			      else
c*************************************************************************
				  write(RUNIT, 1140)
 				  call finerr(labels, rlist, count)
			      end if
			  else
			      write(RUNIT, 1150)
			      call finerr(labels, rlist, count)
			  end if
		      else
			  write(RUNIT, 1160)
			  call finerr(labels, rlist, count)
		      end if
		  else
		      write(RUNIT, 1170)
		      call finerr(labels, rlist, count)
		  end if
	      else
		  write(RUNIT, 1180)
		  call finerr(labels, rlist, count)
	      end if
	  end if
9999  continue
1110  format('Extracting record (', i4.4, ') (', a25, ')')
1120  format(/,' Data attributes are as follows:', /,' Label: ', a45, /,
     1 ' Units: ', a32, /, ' Format: ', a8)
1130  format(//, ' Error getting max & min')
1140  format(//, ' Error getting scale factor')
1150  format(//, ' Error getting data types')
1160  format(//, ' Error getting data attributes')
1170  format(//, ' Error getting data dimensions')
1180  format(//, ' Error setting file pointer')
      return
      end

c******************************************************************
      subroutine finhd(
     i                 min, max, scale)
      include "s4gnread.i"

      integer min
      integer max
      integer scale

c  07/26/94  The minimum and maximum values are incorrect within the HDF data
c            files for the longwave and shortwave parameters.  So that the 
c            user would not get this information from the data file, the
c            print lines for this information have been commented out in
c            this code.  For the correct values for all parameters, please
c            refer to the ERBE S-4G User's Guide.
c     write(RUNIT, 1110)max, min
      write(RUNIT, 1120)scale

c1110  format(' Data Maximum: ',i7, /, ' Data Minimum: ', i7)
1120  format(//' The scale factor of ', i4, ' has been applied '
     1       'to the following data:')

      return
      end
c******************************************************************

      subroutine finerr(
     i                  labels, rlist, index)

      include "s4gnread.i"

      character*(LABLEN) labels(*)
      integer rlist(*)
      integer index

      write(RUNIT, 1110)labels(index), rlist(index)
1110  format('Data Label = (',a45, '), Reference = ', i6,//)

      return
      end
c**********************************************************************
c   Name - ritdim                        Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    Need to write to the report such things as the number of
c    dimensions, the dimension label string, and the dimension
c    scales.
c  
c   Output Files -
c    NONE
c  
c   Input Parameters -
c    See comments below.
c  
c   Output Parameters -
c    See comments below.
c  
c   Key Local Parameters -
c    See comments below.
c  
c**********************************************************************
      subroutine ritdim(
     i                  numtyp,
     i                  numdim,
     i                  arydim,
     i                  ftype)


      include "s4gnread.i"

      integer NUM_ELMS
      PARAMETER (NUM_ELMS = 5)
      integer DFNT_FLOAT32
      parameter (DFNT_FLOAT32=5)

      integer numtyp
      integer numdim
      integer arydim(MXRANK)
      integer ftype
      integer iret

      integer degree
      integer count0
      integer count1

      character label*32
      character unit*32
      character format*32

      integer dsgdist
      integer dsgdisc
      integer dsrref

      integer iaddlon
      integer k, kk, addres8(256)

c
c  06-30-94
c  Initialize array that will be used in converting the 8 bit
c  integers to their correct value.  This pretains mainly to
c  the values that are expecting negative values but are 
c  assigned to positive values.
c
      k = 0
      do while ( k .le. 127)
         addres8(k+1) = k
         k = k + 1
      enddo
      k = 129
      kk = -128
      do while (k .le. 255)
         addres8(k) = kk + 1
         k = k + 1
         kk = kk + 1
      enddo

c
c **** Determine the resolution of the data and 
c **** put that value where we can use it.
c
      if((ftype .and. REGION) .eq. REGION) then
	  if((ftype .and. DEG5) .eq. DEG5) then
	      degree = 5
	  else
	      if((ftype .and. DEG10) .eq. DEG10) then
		  degree = 10
	      else
c
c **** Oops, we have a problem.
c
		  degree = 0
	      end if
	  end if
      else
c
c **** We got the whole world (in our hands).
c
	  degree = 1
      end if

c
c **** Are we working with 32 bit float data?
c
      if(numtyp .eq. DFNT_FLOAT32) then
c
c **** For each dimension of the data, do something nice
c
	      iret = dsrref(fname, 7)
	  do 5000 count0 = 1, numdim
c
c **** Get the dimension string
c
              iret = dsgdist(count0, label, unit, format)
	      if(iret .eq. 0) then
	      endif
5000         continue 
                iret = dsgdisc(count0, arydim(count0), dwscale)
		if (iret .eq. 0) then
		endif
       endif
c
c **** Are we working with 32 bit data?
c
      if(numtyp .eq. DFNT_INT32) then
c
c **** For each dimension of the data, do something nice
c
	      iret = dsrref(fname, 7)
	  do 200 count0 = 1, numdim
c
c **** Get the dimension string
c
              iret = dsgdist(count0, label, unit, format)
	      if(iret .eq. 0) then
c
c **** Are we working with global data ?
c
		  if(label(1:6) .ne. 'Global') then
c
c **** No, so we have to work it right
c
		      write(RUNIT, 1000)
		      write(RUNIT, *)label
		      write(RUNIT, 1010)
		      write(RUNIT, *)unit
		      write(RUNIT, 1020)
c
c **** Get the dimension scales into the array
c
                if(dsgdisc(count0, arydim(count0), dwscale) .eq. 0) then
c
c **** Write a blank line
c
c
c **** For the length of this dimension, do something
c
			  do 100 count1 = 1, arydim(count0)
			      
c
c  06/02/94
c  To correct longitude presentation error add 180 degrees to output.
c
                        if(label(1:20) .eq. 'Latitude Band Number') then
                                 iaddlon = 0
                              else
                                 if (count0 .eq. 1) then
                                     iaddlon = 180
                                 else
                                     iaddlon = 0
                                 endif
                              endif
c
c **** If we are at the end of a record, put a carriage return after
c **** we print the current value.
c
			      if(mod(count1, NUM_ELMS) .eq. 0) then
c                                 write(RUNIT, 1030)(dwscale(count1) * degree)
                     write(RUNIT,1030)((dwscale(count1)*degree)+iaddlon)
			      else
c
c **** Otherwise, just print the value and leave the print-head
c **** where it is.
c
c 06/02/94                        write(RUNIT, 1040)(dwscale(count1) * degree)
                     write(RUNIT,1040)((dwscale(count1)*degree)+iaddlon)
			      end if
100                       continue
c
c **** Another carriage return, just to be sure that things look
c **** as good as we can easily make them.
c
		          write(RUNIT, 1020)
		      else
c
c **** We had problem getting the dimension scale for this dimension
c
			  write(*, 1050)count0
		      end if
		  else
c
c **** We are global data, so we need to let the user know this.
c
		      write(RUNIT, *)label
		  end if
	      else
		  write(*, 1060)
	      end if
200       continue
      else
	  if(numtyp .eq. DFNT_INT16) then
	      do 400 count0 = 1, numdim
		  if(dsgdist(count0, label, unit, format) .eq. 0) then
		      if(label(1:6) .ne. 'Global') then
			  write(RUNIT, 1000)
			  write(RUNIT, *)label
			  write(RUNIT, 1010)
			  write(RUNIT, *)unit
                 if(dsgdisc(count0, arydim(count0), wscale) .eq. 0) then
			      write(RUNIT, 1020)
c
c  06/02/94
c  To correct longitude presentation error add 180 degrees to output.
c
                              if (count0 .eq. 1) then
                                 iaddlon = 180
                              else 
                                 iaddlon = 0
                              endif
			      do 300 count1 = 1, arydim(count0)
				  if(mod(count1, NUM_ELMS) .eq. 0) then
c 06/02/94                            write(RUNIT, 1030)(wscale(count1) * degree)
		      write(RUNIT,1030)((wscale(count1)*degree)+iaddlon)
				  else
c 06/02/94                            write(RUNIT, 1040)(wscale(count1) * degree)
		      write(RUNIT,1040)((wscale(count1)*degree)+iaddlon)
				  end if
300                           continue
			      write(RUNIT, 1020)
			  else
			      write(*, 1050)count0
			  end if
		      else
			  write(RUNIT, *)label
		      end if
		  else
		      write(*, 1060)
		  end if
400           continue
	  else
	      if(numtyp .eq. DFNT_INT8) then
		  do 600 count0 = 1, numdim
                    if(dsgdist(count0, label, unit, format) .eq. 0) then
			  if(label(1:6) .ne. 'Global') then
			      write(RUNIT, 1000)
			      write(RUNIT, *)label
			      write(RUNIT, 1010)
			      write(RUNIT, *)unit
                 if(dsgdisc(count0, arydim(count0), bscale) .eq. 0) then
				  write(RUNIT, 1020)
c
c  06/02/94
c  To correct longitude presentation error add 180 degrees to output.
c
                                 if (count0 .eq. 1) then
                                    iaddlon = 180
                                 else 
                                    iaddlon = 0
                                 endif
				 do 500 count1 = 1, arydim(count0)
                                  if(mod(count1, NUM_ELMS) .eq. 0) then
c 06/02/94                        write(RUNIT, 1030)(ichar(bscale(count1)) * degree)
c 06-30-94  Added conversion statement to convert 8-bit numbers
c           to correct positive or negative value
                                    kk = ichar(bscale(count1))
                                    if(kk .ge. 129) then
                         write(RUNIT,1030)((addres8(kk)*degree)+iaddlon)
                                    else
                                  write(RUNIT,1030)((kk*degree)+iaddlon)
                                    endif

				      else
c 06/02/94                        write(RUNIT, 1040)(ichar(bscale(count1)) * degree)
c 06-30-94  Added conversion statement to convert 8-bit numbers
c           to correct positive or negative value
                                         kk = ichar(bscale(count1))
                                         if(kk .ge. 129) then
                         write(RUNIT,1040)((addres8(kk)*degree)+iaddlon)
                                         else
                                  write(RUNIT,1040)((kk*degree)+iaddlon)
                                         endif
				      end if
500                              continue
			          write(RUNIT, 1020)
			      else
				  write(*, 1050)count0
			      end if
			  else
			      write(RUNIT, *)label
			  end if
		      else
			  write(*, 1060)
		      end if
600               continue
	      else
	      end if
	  end if
      end if
1000  format(' This dimension represents ',$)
1010  format(' expressed in ',$)
1020  format(/)
1030  format(i10)
1040  format(i10, $)
1050  format(' ritedim(): Error getting dimension scales ',i5)
1060  format(' ritdim(): Error getting dimension string')
      end
c**********************************************************************
c   Name - wbyte                         Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To extract all the data for a given parameter from the HDF file,
c    prepare it for printing and to pass all the requird data to the 
c    print routine so that it can be printed very nicely.
c  
c   Output Files -
c  
c   Input Parameters -
c    fname      : Name of HDF file
c    regin      : Structure used to define area to be put in report
c    numdim     : Number of dimensions to the data
c    arydim     : The size of each dimension
c    ftype      : The type of file (regional/zg/5/10/etc)
c    scale      : The scale factor to be applied to current record
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c     integer deg               : The resolution of the data (degrees)
c     integer numelm            : The number of data elements to print
c     integer offset            : Where to start the region data print
c     record /values/ data      : The place we stuff the data
c  
c   Subroutines Called -
c     integer dsgdata  : Get the data from the HDF file (HDF routine)
c  
c   Exit States -
c  
c**********************************************************************
      subroutine wbyte(
     i                 fname,
     i                 numdim,
     i                 arydim,
     i                 ftype,
     i                 scale)

      include "s4gnread.i"

      character*32 fname
      integer numdim
      integer arydim(*)
      integer ftype
      integer scale

      integer dsgdata

      integer deg
      integer numelm
      integer offset

c
c **** Get the data from the HDF file
c
      if(dsgdata(fname, numdim, arydim, bvalue) .eq. 0) then
c
c **** Determine which print routine we are going to use.
c **** If we are regional data or the user has not defined
c **** an area to be printed, then we we must print a range
c **** of regions.  Else, the user has define a rectangular
c **** area to be printed and we must determine just what 
c **** that area is and print it.
c
c 07/28/94  This code does not print out the zonal global
c data.  Correction had to be made so that these would print.
c         if(begin1 .eq. 0 .and. end1 .eq. 0) then
	  if(((ftype .and. REGION) .eq. REGION) .and.
     &        (begin1 .eq. 0 .and. end1 .eq. 0)) then
c
c **** Determine the resolution of the data
c
	      if((ftype .and. DEG5) .eq. DEG5) then
		  deg = 5
	      else
		  deg = 10
	      end if
c
c **** Since the use has defined a rectangular area to be 
c **** printed, go do it
c
	      call pregin((360 / deg), scale, DFNT_INT8)
	  else
c
c **** We know that we must print a sequential series of regions, but
c **** where do they start and where do they end?
c
	      if((begin1 .ne. 0) .or. (end1 .ne. 0)) then
		  numelm = end1 - begin1 + 1
		  offset = begin1
	      else
		  numelm = arydim(1)
		  offset = 1
	      end if
c
c **** Go print the series of regions.
c
	      call ritezg(offset, scale, numelm, DFNT_INT8)
	  end if
      else
c
c **** We were unable to get the data, so we must let the user 
c **** know about the problem.
c
	  write(*, 1110)
      end if
      return
1110  format('wbyte(): Unable to acquire byte data')
      end

c**********************************************************************
c   Name - pregin                        Module -
c   Language - FORTRAN                   Type - function
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c    regin   : Structure holding clue to area to print
c    rowlen  : Length of each "raster"
c    data    : Structure holding the data
c    scale   : The current scale factor
c    numtyp  : Size of data
c  
c   Output Parameters -
c    NONE
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine pregin(
     i                  rowlen,
     i                  scale,
     i                  numtyp)

      include "s4gnread.i"

      integer rowlen
      integer scale
      integer numtyp

      integer first
      integer c0
      integer c1
      integer c2
      integer c3
      integer raster
      integer c4


      do 900 c0 = ulv, lrv
	  first = TRUE
	  raster = (c0 - 1) * rowlen
	  do 800 c1 = ulh, lrh
	      c2 = c1 + raster
c  08/08/94  Scientist requested that region/band numbers follow format
c  as of scanner program which means never start format at zero.  To
c  do this, some of the following lines of code had to be modified for
c  this to work.
c  08/08/94   if(first .eq. TRUE .or. mod(c2, COLS) .eq. 0) then
	      if(first .eq. TRUE .or. mod((c2-1), COLS) .eq. 0) then

c  08/08/94       write(RUNIT, 1120)(c2 - mod(c2, COLS))
		  write(RUNIT, 1120)((((c2-1) / COLS)* COLS)+1)

c  08/08/94       if(first .eq. TRUE .and. mod(c2, COLS) .ne. 0) then
		  if(first .eq. TRUE) then

c  08/08/94  Inserted this next if statement to correct looping count of the columns
c  as of where to print the data in the proper columns in the report file.
                    if ((mod(c2,COLS)) .eq. 0) then
                      c4 = COLS-1
                    else 
                      c4 = mod(c2,COLS) - 1
                    endif

c  08/08/94           do 700 c3 = 1, mod(c2, COLS)
		      do 700 c3 = 1, c4
			  write(RUNIT, 1130)
700                   continue
		  end if
		  first = FALSE
	      end if
	      call pvalue(c2, scale, numtyp)
800       continue
	  write(RUNIT, 1140)
900   continue
      write(RUNIT, 1150)

1110  format(i17, $)
1120  format(/, ' ', i4, ': ', $)
1130  format('                 ', $)
1140  format(/)
1150  format(//)
      return
      end
c**********************************************************************
c   Name - ritezg                        Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c  
c   Output Files -
c  
c   Input Parameters -
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine ritezg(
     i                  offset,
     i                  scale,
     i                  numelm,
     i                  ntype)

      include "s4gnread.i"

      integer offset
      integer scale
      integer numelm
      integer ntype

      integer first
      integer count0
      integer count1
      integer c4

      first = TRUE

      do 300 count0 = offset, numelm + offset - 1

c  08/08/94  Scientist requested that region/band numbers follow format
c  as of scanner program which means never start format at zero.  To
c  do this, some of the following lines of code had to be modified for
c  this to work.
c  08/08/94  if(first .eq. TRUE .or. (mod(count0, COLS) .eq. 0)) then
c
         if(first .eq. TRUE .or. (mod((count0-1), COLS) .eq. 0)) then

c  08/08/94   write(RUNIT, 1120)(count0 - mod(count0, COLS))
              write(RUNIT, 1120)((count0+1) - mod(count0, COLS))
1120          format(/, ' ', i4, ': ', $)

c  08/08/94  To avoid writing a zero block of blanks.
              if (offset .eq. 1) then
                 first = FALSE
              endif
	      if(first .eq. TRUE) then
c  08/08/94  Inserted this next if statement to correct looping count of the columns
c  as of where to print the data in the proper columns in the report file.
                    if ((mod(c2,COLS)) .eq. 0) then
                      c4 = COLS-1
                    else 
                      c4 = mod(c2,COLS) + 1
                    endif

c  08/08/94       do 200 count1 = 0, mod(count0, COLS) - 1
          	  do 200 count1 = 1, c4 -1
		      write(RUNIT, 1130)
1130                  format('                 ', $)
200               continue
                  first = FALSE
	      end if
	  end if
	  call pvalue(count0, scale, ntype)
c	  if(count0 .eq. 150) then
c          endif
300   continue
      write(RUNIT, 1140)
1140  format(/,' ')
      return
      end

c**********************************************************************
c   Name - pvalue                        Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    Common print routine used by wbyte(), wword(), and wdword().
c    This routine would have to be duplicated in all the above
c    if we did not use a couple of extra (non-ANSI) extensions
c    to the FORTRAN language (structures and unions).
c  
c   Output Files -
c  
c   Input Parameters -
c    data     : The data we have extracted from the HDF file
c    offset   : The element of the array (of the union, of the struct)
c    scale    : The scale factor to be applied to the value
c    numtyp   : The size of the data 
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c  
c   Subroutines Called -
c  
c   Exit States -
c  
c**********************************************************************
      subroutine pvalue(
     i                  offset,
     i                  scale,
     i                  numtyp)


      include "s4gnread.i"

      integer offset
      integer scale
      integer numtyp
      integer DFNT_FLOAT32
      parameter (DFNT_FLOAT32=5)

      integer temp
      real rtemp
      double precision value
      integer k, kk, addres8(256)
c
c
c  07/01/94
c  To compensate for the 8-bit negative values
c  which are not converted properly using the ICHAR
c  command all alone.  This array stores the actual
c  numbers that the ICHAR command produces and passes
c  on the correct value (both positive and negative).
      k = 0
      do while (k .le.127)
         addres8(k+1) = k
         k = k + 1
      enddo
      k = 129
      kk = -128
      do while (k .le. 255)
         addres8(k) = kk + 1
         k = k + 1
         kk = kk + 1
      enddo

c
c **** Are we working with a byte value?
c
      if(numtyp .eq. DFNT_INT8) then
c
c **** Turn it into a real integer value for 
c **** easier comparison.  Floating point is 
c **** not as precise as integer when used in
c **** a comparison.
c
c 07/01/94  This section corrects the conversion of an
c           8-bit number correctly being a positive or
c           a negative number.
c         temp = int(ichar(bvalue(offset)))
c
          temp = ichar(bvalue(offset))
          if (temp .ge. 129) then
             temp = addres8(temp)
          endif

	  if(temp .eq. -127) then
c
c **** We need to convert the fill value to
c **** double precision
c
	      value = dble(temp)
	  else
c
c **** We need to apply the scale factor
c **** to the value before we print it
c
	      value = dble(temp) / dble(scale)
	  end if
      else
c
c **** Are we working with a 16 bit value?
c
	  if(numtyp .eq. DFNT_INT16) then
	      temp = int(wvalue(offset))
	      if(temp .eq. -127 .or. 
     1           temp .eq. 32767 .or.
     2           temp .eq. -32767) then
		  value = dble(temp)
	      else
		  value = dble(temp) / dble(scale)
	      end if
	  else
c
c **** Are we working with a 32 bit value?
c
	      if(numtyp .eq. DFNT_INT32) then
		  temp = int(dwvalue(offset))
		  if(temp .eq. -127 .or.
     1               temp .eq. 2147483647 .or.
     2               temp .eq. 32767 .or.
     3               temp .eq. -32767) then
                     value = dble(temp)
		  else
		      value = dble(temp) / dble(scale)
		  end if
	      end if
c
c **** Are we working with a 32 bit float value?
c
cfox
	      if(numtyp .eq. DFNT_FLOAT32) then
		  rtemp = data(offset)
		  if(rtemp .eq. -127 .or.
     1               rtemp .eq. 2147483647 .or.
     2               rtemp .eq. 32767 .or.
     3               rtemp .eq. -32767) then
                     value = rtemp
		  else
		      value = rtemp / scale
		  end if
	      end if
	  end if
      end if
c
c **** Print the value to the report
c
      write(RUNIT, 1110)value
1110  format(f17.4,$)
      return
      end
c**********************************************************************
c   Name - wword                         Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To extract all the data for a given parameter from the HDF file,
c    prepare it for printing and to pass all the requird data to the 
c    print routine so that it can be printed very nicely.
c  
c   Output Files -
c  
c   Input Parameters -
c    fname      : Name of HDF file
c    regin      : Structure used to define area to be put in report
c    numdim     : Number of dimensions to the data
c    arydim     : The size of each dimension
c    ftype      : The type of file (regional/zg/5/10/etc)
c    scale      : The scale factor to be applied to current record
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c     integer deg               : The resolution of the data (degrees)
c     integer numelm            : The number of data elements to print
c     integer offset            : Where to start the region data print
c     record /values/ data      : The place we stuff the data
c  
c   Subroutines Called -
c     integer dsgdata  : Get the data from the HDF file (HDF routine)
c  
c   Exit States -
c  
c**********************************************************************
      subroutine wword(
     i                 fname,
     i                 numdim,
     i                 arydim,
     i                 ftype,
     i                 scale)

      include "s4gnread.i"

      character*32 fname
      integer numdim
      integer arydim(*)
      integer ftype
      integer scale

      integer dsgdata

      integer deg
      integer numelm
      integer offset

c
c **** Get the data from the HDF file
c
      if(dsgdata(fname, numdim, arydim, wvalue) .eq. 0) then
c
c **** Determine which print routine we are going to use.
c **** If we are regional data or the user has not defined
c **** an area to be printed, then we we must print a range
c **** of regions.  Else, the user has define a rectangular
c **** area to be printed and we must determine just what 
c **** that area is and print it.
c
c 07/28/94  This code does not print out the zonal global
c data.  Correction had to be made so that these would print.
c         if(begin1 .eq. 0 .and. end1 .eq. 0) then
	  if(((ftype .and. REGION) .eq. REGION) .and.
     &        (begin1 .eq. 0 .and. end1 .eq. 0)) then
c
c **** Determine the resolution of the data
c
	      if((ftype .and. DEG5) .eq. DEG5) then
		  deg = 5
	      else
		  deg = 10
	      end if
c
c **** Since the use has defined a rectangular area to be 
c **** printed, go do it
c
	      call pregin((360 / deg), scale, DFNT_INT16)
	  else
c
c **** We know that we must print a sequential series of regions, but
c **** where do they start and where do they end?
c
	      if((begin1 .ne. 0) .or. (end1 .ne. 0)) then
		  numelm = end1 - begin1 + 1
		  offset = begin1
	      else
		  numelm = arydim(1)
		  offset = 1
	      end if
c
c **** Go print the series of regions.
c
	      call ritezg(offset, scale, numelm, DFNT_INT16)
	  end if
      else
c
c **** We were unable to get the data, so we must let the user 
c **** know about the problem.
c
	  write(*, 1110)
      end if
      return
1110  format('wword(): Unable to acquire byte data')
      end
c**********************************************************************
c   Name - wdword                         Module -
c   Language - FORTRAN                   Type - subroutine
c   Version - ??      Date - 13 Oct 92   Programmer - S.R. Quier (SAIC)
c  
c   Purpose -
c    To extract all the data for a given parameter from the HDF file,
c    prepare it for printing and to pass all the requird data to the 
c    print routine so that it can be printed very nicely.
c  
c   Output Files -
c  
c   Input Parameters -
c    fname      : Name of HDF file
c    regin      : Structure used to define area to be put in report
c    numdim     : Number of dimensions to the data
c    arydim     : The size of each dimension
c    ftype      : The type of file (regional/zg/5/10/etc)
c    scale      : The scale factor to be applied to current record
c  
c   Output Parameters -
c  
c   Key Local Parameters -
c     integer deg               : The resolution of the data (degrees)
c     integer numelm            : The number of data elements to print
c     integer offset            : Where to start the region data print
c     record /values/ data      : The place we stuff the data
c  
c   Subroutines Called -
c     integer dsgdata  : Get the data from the HDF file (HDF routine)
c  
c   Exit States -
c  
c**********************************************************************
      subroutine wdword(
     i                 fname,
     i                 numdim,
     i                 arydim,
     i                 ftype,
     i                 scale)

      include "s4gnread.i"

      character*32 fname
      integer numdim
      integer arydim(*)
      integer ftype
      integer scale

      integer dsgdata

      integer deg
      integer numelm
      integer offset
c
c **** Get the data from the HDF file
c
        iret = dsgdata(fname, numdim, arydim, dwvalue)
        if (iret .eq. 0) then
c
c **** Determine which print routine we are going to use.
c **** If we are regional data or the user has not defined
c **** an area to be printed, then we we must print a range
c **** of regions.  Else, the user has define a rectangular
c **** area to be printed and we must determine just what 
c **** that area is and print it.
c
c 07/28/94  This code does not print out the zonal global
c data.  Correction had to be made so that these would print.
c         if(begin1 .eq. 0 .and. end1 .eq. 0) then
	  if(((ftype .and. REGION) .eq. REGION) .and.
     &        (begin1 .eq. 0 .and. end1 .eq. 0)) then
c
c **** Determine the resolution of the data
c
	      if((ftype .and. DEG5) .eq. DEG5) then
		  deg = 5
	      else
		  deg = 10
	      end if
c
c **** Since the use has defined a rectangular area to be 
c **** printed, go do it
c
	      call pregin((360 / deg), scale, DFNT_INT32)
	  else
c
c **** We know that we must print a sequential series of regions, but
c **** where do they start and where do they end?
c
	      if((begin1 .ne. 0) .or. (end1 .ne. 0)) then
		  numelm = end1 - begin1 + 1
		  offset = begin1
	      else
		  numelm = arydim(1)
		  offset = 1
	      end if
c
c **** Go print the series of regions.
c
	      call ritezg(offset, scale, numelm, DFNT_INT32)
	  end if
      else
c
c **** We were unable to get the data, so we must let the user 
c **** know about the problem.
c
	  write(*, 1110)
      end if
      return
1110  format('wdword(): Unable to acquire byte data')
      end
c**********************************************************************
      subroutine s4gnwdword(
     $                 fname,
     $                 numdim,
     $                 arydim,
     $                 ftype,
     $                 scale)

      include "s4gnread.i"
cwizards
      character*32 fname
      integer numdim
      integer arydim(*)
      integer ftype
      integer scale
      integer DFNT_FLOAT32
      parameter (DFNT_FLOAT32=5)

      integer dsgdata

      integer deg
      integer numelm
      integer offset
c
c **** Get the data from the HDF file
c
        iret = dsgdata(fname, numdim, arydim, data)
        do 3321 i=400,500
3321    continue
        if (iret .eq. 0) then
c
c **** Determine which print routine we are going to use.
c **** If we are regional data or the user has not defined
c **** an area to be printed, then we we must print a range
c **** of regions.  Else, the user has defined a rectangular
c **** area to be printed and we must determine just what 
c **** that area is and print it.
c
c 07/28/94  This code does not print out the zonal global
c data.  Correction had to be made so that these would print.
c         if(begin1 .eq. 0 .and. end1 .eq. 0) then
c
	  if(((ftype .and. REGION) .eq. REGION) .and.
     &        (begin1 .eq. 0 .and. end1 .eq. 0)) then
c
c **** Determine the resolution of the data
c
	      if((ftype .and. DEG5) .eq. DEG5) then
		  deg = 5
	      else
		  deg = 10
	      end if
c
c **** Since the use has defined a rectangular area to be 
c **** printed, go do it
c
	      call pregin((360 / deg), scale, DFNT_FLOAT32)
	  else
c
c **** We know that we must print a sequential series of regions, but
c **** where do they start and where do they end?
c
	      if((begin1 .ne. 0) .or. (end1 .ne. 0)) then
		  numelm = end1 - begin1 + 1
		  offset = begin1
	      else
		  numelm = arydim(1)
		  offset = 1
	      end if
c
c **** Go print the series of regions.
c
	      call ritezg(offset, scale, numelm, DFNT_FLOAT32)
	  end if
      else
c
c **** We were unable to get the data, so we must let the user 
c **** know about the problem.
c
	  write(*, 1110)
      end if
      return
1110  format('wdword(): Unable to acquire byte data')
      end
c********************************************************************
      integer function gfname2(fname ,rname)
      character*32 fname
      character*32 rname

      include "s4gnread.i"

      integer     ex
      integer     good
      logical     ex1
      character   fov
      character   proc
      character*4 resol
      character*4 ddate
      character*4 scode
  
c
c **** Assume there will be a problem
c
      gfname2 = 0
cturkey 
c
c **** Print an intro and a warning
c
      print *, 'The name of the HDF file must conform to the standards'
      print *, 'developed by NASA/Langley for HDF granual ids.'
      print *, 'Please modify this code if the names have changed or'
      print *, 'are not located in the current working directory.'
      print *, ' '
 
c
c **** Need to introduce ourself and let him/her know
c **** the available options
c
      print *, 'In all of the following, '
      print *, 'case of your response is not important.'
      print *, 'In addition, if you wish to ABORT'
      print *, 'you may enter an ''a'' at any query.'
      print *, ' '
 
c
c **** Make sure we can get into the loop
c
      fov = ' '
c
c **** While we do not have a valid input, loop
c
      do while((fov .ne. 'm') .and.
     1         (fov .ne. 'w') .and.
     2         (fov .ne. 'a'))
c
c **** Write our query to the user and wait for his input.  when
c **** we get the input, convert it to lower case for the above
c **** comparison.  This makes our comparison that much shorter.
c
          write(*, 1110)
1110      format('There are two types of field-of-view, '
     1           '(W)ide Field-of-View or (M)edium Field-of-View.',
     1           /,'Enter Field-of-View.  -->', $)
          read (*, 1111) fov
1111      format(a1)
c
c **** Make the input lower case
c
          call tolower(fov)
      end do
c
c **** If the user did not chose to abort the run, we continue
c
       if(fov .ne. 'a')then
          proc = ' '
          do while((proc .ne. 'n') .and.
     1             (proc .ne. 's') .and.
     2             (proc .ne. 'a'))
              write(*, 1120)
1120          format(// 'There are two types of nonscanner data, '
     1                  '(N)umerical Filter or (S)hape Factor.',/,
     2                  ' Enter type of data.  -->', $)
              read (*, 1111) proc
              call tolower(proc)
          end do
 
          if(proc .ne. 'a')then
              resol = '  '
              do while((resol(1:1) .ne. 'a') .and.
     1                 (resol(1:1) .ne. '5') .and.
     2                 (resol(1:2) .ne. '10') .and.
     3                 (resol(1:2) .ne. 'zg'))
                  write(*, 1130)
1130              format(// 'There are three resolutions of data, '
     1                      '5 degree by 5 degree,',
     2                   /,'5 by 5 nested to 10 by 10 degree, and '
     3                      'Zonal-Global data.',/,
     4                   'Enter resolution: (5) (10) or (zg) '
     5                      '--->', $)
                  read(*, 1132)resol
1132  format(a)
c
c **** Make both characters we need lower case
c
                  call tolower(resol(1:1))
                  if(resol(2:2) .ne. ' ') then
                      call tolower(resol(2:2))
                  end if
              end do
 
 
              if(resol(1:1) .ne. 'a')then
c
c **** If the user gave us a 5 degree requirement
c **** we need to make it a '5.'
c
                 if(resol(1:1) .eq. '5')then
                     resol = '5.'
                 end if
c
c **** We need to get into the loop somehow
c
                 good = FALSE
                 do while (good .eq. FALSE)
                     write(*, 1140)
1140                 format(// 'Enter data date in the format YYMM.'
     1                          '  --> ',$)
                     read(*, 1132)ddate
c
c **** If the user aborted on us, then no need to worry about getting
c **** a good date
c
                     if(ddate(1:1) .ne. 'a')then
                         if((ddate(1:4) .ge. '8411') .and.
     1                      (ddate(1:4) .le. '9113')) then
                             good = TRUE
                         end if
                     else
c
c **** To get out of the loop This does not pose a problem because we
c **** have an 'a' in ddate(1:1)
c
                         good = TRUE
                     end if
                 end do
c
c **** Get the sat code
c
                 if(ddate(1:1) .ne. 'a')then
                     scode = ' '
                     scode = ' '
c
c **** The sat code must be in the right range (1 - 7)
c
                     do while((scode(1:1) .ne. 'a') .and.
     1		             ((scode(1:1) .lt. '1') .or.
     2		              (scode(1:1) .gt. '7')))
                         write(*, 1150)
1150                     format(// 'Please indicate the satellite'
     1                              'combination, from the',
     2                          / 'following list, you desire:',
     3                          / '  (1) NOAA-9              '
     4                               '(5) ERBS & NOAA-9',
     5                          / '  (2) ERBS                '
     6                               '(6) ERBS & NOAA-10',
     7                          / '  (3) NOAA-10             '
     8                               '(7) ERBS, NOAA-9, & NOAA-10',
     9                          / '  (4) NOAA-9 & NOAA-10           '
     A                               '---> ',$)
                         read(*, 1132)scode
                         call tolower(scode(1:1))
			 print*,"scode ",scode
                     end do
                     if(scode(1:1) .ne. 'a')then
c
c **** Build the file name, then the report name based upon the first
c **** 16 characters of the file name
c
                         llast = 0
                         jj = 0
                         fname = 's4gn_'//fov//proc//'f'//resol(1:2)//
     1                           '_'//ddate(1:4)//'_'//scode(1:1)
cmyfix                         rname = fname(1:16)//'.rpt'
                         newstr = len(fname)
                         do 99991 jj = 1 ,newstr
                           if(fname(jj:jj) .ne. " ") then
                             llast = jj
                           endif
99991                    continue
cmyfix
                         rname = fname(1:llast)//'.rpt'
c
c **** Find out if the file name we built for the user really is
c **** available.
c
                         inquire(file = fname, exist = ex1)
c                         if(ex1 .eq. .TRUE.) then
c                            ex = TRUE
c                         endif
c
c **** If so, then we can let the calling function know that
c **** everything went as planned.
c
                         ex = TRUE
                         if(ex .eq. TRUE)then
                     print *, ' '
                     print *, 'The report will be written to ', rname
                             gfname2 = 1
                         end if
                     end if
                 end if
              end if
          end if
      end if
      return
      end
