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