c--------------- PROGRAM: COOPSOD.FOR ---------------------------- c c This Program conforms to UNIX FORTRAN (IBM RISC/6000) standards. c c THIS SOFTWARE IS PROVIDED AS IS. CONVERSIONS TO OTHER PLATFORMS, c MODIFICATIONS, AND/OR COMPILATIONS OF THIS CODE BY THE USER IS c HIS/HER RESPONSIBILITY. c c FUNCTION: Selects records from Cooperative Summary of the Day c CDROM files and write them to hard disk or diskette files. c c Selections are made by Station Number and Date (required), and c optionally by Element Code. Selected data may be written one c file or in separate files by station number. c c NO special functions or subroutines are called. c c dimension ibuf4(101) character abuf*404, filnam*11, filein*40, filout*40 character dafill*12, omode*1, oseq*26, savout*7, ecode*4 character bstn*6(50), estn*6(50), bdat*6(50), edat*6(50) character elem*4(20), astno*2, state*2(91), sttbl*18(56) character savstn*6, savdt1*6, savdt2*6, eletbl*4(16) character pathi*40, patho*40, opt*1, param*80, cddev*1, odest*1 integer*1 ibuf1(404), ichflg(0:255) logical dosch1, dosch2, dosch3, eof7, badflg, doloop, keepit logical newdsk, cls9, tsting equivalence(ibuf4(1), ibuf1(1), abuf) c data state /'al','az','ar','ca','co','ct','de','fl','ga','id', & 'il','in','ia','ks','ky','la','me','md','ma','mi','mn','ms', & 'mo','mt','ne','nv','nh','nj','nm','ny','nc','nd','oh','ok', & 'or','pa','ri','sc','sd','tn','tx','ut','vt','va','wa','wv', & 'wi','wy','XX','ak','hi','XX','XX','XX','XX','XX','XX','XX', & 'XX','XX','XX','XX','XX','XX','XX','pr','vi','XX','XX','XX', & 'XX','XX','XX','XX','XX','XX','XX','XX','XX','XX','XX','XX', & 'XX','XX','XX','XX','XX','XX','XX','XX','pi'/ c data oseq /'abcdefghijklmnopqrstuvwxyz'/ c data sttbl/'01 Alabama','02 Arizona','03 Arkansas', & '04 California','05 Colorado','06 Connecticut','07 Delaware', & '08 Florida','09 Georgia','10 Idaho','11 Illinois', & '12 Indiana','13 Iowa','14 Kansas','15 Kentucky','16 Louisiana', & '17 Maine','18 Maryland','19 Massachusetts','20 Michigan', & '21 Minnesota','22 Mississippi','23 Missouri','24 Montana', & '25 Nebraska','26 Nevada','27 New Hampshire','28 New Jersey', & '29 New Mexico','30 New York','31 North Carolina', & '32 North Dakota','33 Ohio','34 Oklahoma','35 Oregon', & '36 Pennsylvania','37 Rhode Island','38 South Carolina', & '39 South Dakota','40 Tennessee','41 Texas','42 Utah', & '43 Vermont','44 Virginia','45 Washington','46 West Virginia', & '47 Wisconsin','48 Wyoming','50 Alaska','51 Hawaii', & '66 Puerto Rico','67 Virgin Islands','91 Pacific Islands', & ' ',' ',' '/ c data eletbl/'DYSW','EVAP','MNPN','MXPN','PRCP','SNOW','SNWD', & 'TMAX','TMIN','TOBS','WDMV','WTEQ','SNYZ','SOYZ','SXYZ',' '/ c c---- variable tsting allows programmer to selectively display values--- c c tsting = .true. tsting = .false. c c------------------ INITIALIZE TABLE OF FLAGS FOR CHECKING FOR c------------------ INVALID CHARACTERS, 0 = INVALID, 1 = VALID c do 20 ic=0, 255 ichflg(ic) = 0 20 continue ichflg(32) = 1 ichflg(40) = 1 ichflg(41) = 1 ichflg(43) = 1 ichflg(45) = 1 do 25 ic=48, 57 ichflg(ic) = 1 25 continue do 30 ic=65, 90 ichflg(ic) = 1 30 continue c c----------------------------- GET SELECTION PARAMETERS ------------- c c--------- INITIALIZE PARAMETER VARIABLES -------- c do 33 il=1, 50 bstn (il) = ' ' estn (il) = '999999' bdat (il) = ' ' edat (il) = '999999' 33 continue c do 35 ie=1, 20 elem(ie) = ' ' 35 continue c WRITE(6, 40) 40 format(/ & ' COOPSODX.EXE is a FORTRAN program to perform extractions from' &/' the Cooperative Summary Of the Day CDROM data files and' &/' to write the extractions to data file(s) on a UNIX ' &/' workstation.'/ &/' Selection parameters allow you to extract data for one or' &/' more stations from ONE state at a time. You may specify date' &/' ranges and element codes. You will also be asked to supply' &/' a PATH for the output files. An output directory must be' &/' established before writing to it'/ &/' Pressing CTRL-C at any time should abort the program.'/ &/' (Press ENTER to CONTINUE)') c read (5, '(a1)') opt c doloop = .true. do 50 while (doloop) write(6, 42) 42 format(//' Enter State Number, Ex. Alabama = 1, Texas = 41' & /' (Enter 99 To See State Table)') read (5, '(i2)') istno c if (istno .eq. 99) then do 45 ix = 1, 14 write(6,44)sttbl(ix),sttbl(ix+14),sttbl(ix+28),sttbl(ix+42) 44 format(1x,4a18) 45 continue elseif (istno .ge. 0 .and. istno .le. 92) then if (state(istno) .ne. 'XX') then write(astno, '(i2.2)') istno write(filnam, 47) state(istno), astno 47 format(a2,a2,'stn.dat') write(6, 48) filnam 48 format(/' INPUT FILE = ',a11) doloop = .false. else write(6, *)'--------- INVALID STATE CODE, TRY AGAIN ----' endif else write(6, *)'--------- INVALID STATE CODE, TRY AGAIN ----' endif 50 continue c isttot = 0 doloop = .true. do 70 while (doloop) write(6, 54) 54 format(//'Enter station and date range, or enter "END"' & /' (Enter ? to see an example)' & /'BSTN ESTN B-YRMO E-YRMO') read(5,'(a80)') param if (param(1:3) .eq. 'end' .or. param(1:3) .eq. 'END') then doloop = .false. elseif (param(1:1) .eq. '?' .or. param(2:2) .eq. '?') then write(6, 55) 55 format( & /' Example: To select station 0265 for 1980/01-12, and' & /' stations 5500 to 6000 for 1970/01 to 1990/12, ENTER:' & //' BSTN ESTN B-YRMO E-YRMO' & /' 0265 0265 198001 198012' & /' 5500 6000 197001 199012' & /' END'/) c else keepit = .true. if (param(1:4) .eq. ' ' .or. param(6:9) .eq. ' ' .or. & param(11:16) .eq. ' ' .or. & param(18:23) .eq. ' ') then write (6, 56) 56 format(//' ** ERROR: One or More Blank Fields - ', & 'PLEASE RE-ENTER !!') keepit = .false. elseif (param(1:4) .gt. param(6:9) .or. & param(11:16) .gt. param(18:23)) then write (6, 57) 57 format(//' ** ERROR: Station Sequence or Date Sequence', & ' Reversed') keepit = .false. endif c if (keepit) then isttot = isttot + 1 write(6,60)param(1:4),param(6:9),param (11:16),param(18:23) 60 format(/' Begin-Stn = ',a4,' End-Stn = ',a4, & ' Begin-Date = ',a6,' End-Date = ',a6) c bstn(isttot) = astno // param(1:4) estn(isttot) = astno // param (6:9) bdat(isttot) = param(11:16) edat(isttot) = param(18:23) c if(isttot .ge. 50) then write(6, 65) 65 format(/'MAX LIMIT OF 50 SELECTS REACHED') doloop = .false. endif endif endif 70 continue c 73 continue ielem = 0 write(6, 75) 75 format(//' Do You Want To Select By Elements ?? ( Y or N )') read (5, '(a1)') opt if (opt .eq. 'N' .or. opt .eq. 'n') then write(6, *)'--------- SELECTING ALL ELEMENTS -------' go to 100 endif if (opt .ne. 'Y' .and. opt .ne. 'y') then go to 73 endif doloop = .true. do 90 while (doloop) write(6, 80) 80 format(//' Enter Element-Code (4-chars, in CAPITAL LETTERS),', & ' or Enter "END"' & /' (Enter ? To See Element Table)') read(5, '(a80)') param if (param(1:3) .eq. 'end' .or. param(1:3) .eq. 'END') then doloop = .false. elseif (param(1:1) .eq. '?') then write(6, '(/)') do 83 ix=1, 4 write(6, 82)eletbl(ix), eletbl(ix+4), & eletbl(ix+8), eletbl(ix+12) 82 format(4(5x,a4,5x)) 83 continue write(6, 85) 85 format(/' (Entering SNYZ, SOYZ, or SXYZ selects all ', & 'combinations for that SOIL element.'/) else keepit = .false. do 87 ix = 1, 15 if (eletbl(ix) .eq. param(1:4)) then keepit = .true. endif 87 continue c if (.not. keepit) then write(6, 88) param(1:4) 88 format(//' ** ERROR: Element Code (',a4,') NOT ', & 'VALID - PLEASE RE-ENTER !!') else c ielem = ielem + 1 elem(ielem) = param(1:4) write(6,89) ielem, elem(ielem) 89 format(' Element(',i2,') = ',a4) endif endif 90 continue c 100 continue write(6, 105) 105 format(//' Enter Full Path To CDROM Input File Directory', & ', Example. /cdrom/data/') read(5, '(a40)') pathi doloop = .true. lpathi = 41 do 106 while (doloop) lpathi = lpathi - 1 if (lpathi .eq. 0) then write(6, *) '------- NO PATH FOUND, PLEASE RE-ENTER ----' go to 100 endif if (pathi(lpathi:lpathi) .ne. ' ') then doloop = .false. endif 106 continue c c write(6, 107) cddev c107 format(/' CDROM Drive Letter = ',a1) c 118 continue write(6, 120) 120 format(//' Enter Output Path, Example. /data/coop/') patho = ' ' read(5, '(a40)') patho doloop = .true. lpatho = 41 do 125 while (doloop) lpatho = lpatho - 1 if (lpatho .eq. 0) then write(6, *) '------- NO PATH FOUND, PLEASE RE-ENTER ----' go to 118 endif if (patho(lpatho:lpatho) .ne. ' ') then doloop = .false. endif 125 continue c doloop = .true. do 135 while (doloop) write(6, 130) 130 format( & //' Specify Output Recording: 1 = One Station Per File' & /' 2 = ALL Stations In One File') read(5, '(a1)') omode if (omode .eq. '1' .or. omode .eq. '2') then doloop = .false. else write(5, *)' -------------- INVALID ENTRY, TRY AGAIN -----' endif 135 continue c write(6, 140) 140 format(//' -- SELECTION BEGINS --') filein = ' ' filein = pathi(1:lpathi) // filnam write(6, 145) filein 145 format(/' Opening Input File: ',a40) ioutot = 0 c c--------- OUTER LOOP PROCESSES STATION/DATE REQUESTS --------- c do 500 istn = 1, isttot c open (7, file=filein, recl=404, err=950, iostat=istat, & access='direct') c ioutct = 0 noutct = 0 ibytes = 0 i = 1 j = 1 k = 1 invcnt = 0 dosch1 = .true. savstn = ' ' c c------------------------- STEP THRU FILE 10000 LINES AT A TIME c do 175 while (dosch1) irec = i read(7, rec=i, err=1000, iostat=istat) ibuf4 c c------------------------ IF ISTAT = -1, HANDLE AS AN EOF... c if (istat .eq. -1) then dosch1 = .false. else if (tsting) then write(6, 147) i, abuf(1:30) endif 147 format(' Rec',i7,' = ',a30) if (abuf(4:9) .lt. bstn(istn)) then j = i i = i + 10000 else dosch1 = .false. endif endif c 175 continue c dosch2 = .true. c c------------------------- STEP THRU FILE 100 RECORDS AT TIME c do 275 while (dosch2) irec = j read(7, rec=j, err=1000, iostat=istat) ibuf4 c c------------------------ IF ISTAT = -1, HANDLE AS AN EOF... c if (istat .eq. -1) then dosch2 = .false. else if (tsting) then write(6, 210) j, abuf(1:30) endif 210 format(' Rec',i7,' = ',a30) if (abuf(4:9) .lt. bstn(istn)) then k = j j = j + 100 else dosch2 = .false. endif endif c 275 continue c dosch3 = .true. c c--------------------- STEP THRU FILE ONE RECORD AT A TIME c do 375 while (dosch3) irec = k read(7, rec=k, err=1000, iostat=istat) ibuf4 c c-----------------------IF ISTAT = -1, HANDLE AS AN EOF... c if (istat .eq. -1) then eof7 = .true. dosch3 = .false. go to 375 endif c if (tsting) then write(6, 280) k, abuf(1:30) endif 280 format(' Rec',i7,' = ',a30) if (abuf(4:9) .lt. bstn(istn)) then k = k + 1 go to 375 endif if (abuf(4:9) .gt. estn(istn)) then dosch3 = .false. go to 375 endif if (abuf(18:23) .lt. bdat(istn) .or. & abuf(18:23) .gt. edat(istn)) then k = k + 1 go to 375 endif c keepit = .false. if (ielem .eq. 0) then keepit = .true. else do 290 ie = 1, ielem ecode = elem(ie) if (ecode .eq. 'SNYZ') then if(abuf(12:13) .eq. 'SN') then if (abuf(14:15) .ne. 'OW' & .and. abuf(14:15) .ne. 'WD') then keepit = .true. endif endif elseif (ecode .eq. 'SOYZ') then if (abuf(12:13) .eq. 'SO') then keepit = .true. endif elseif (ecode .eq. 'SXYZ') then if (abuf(12:13) .eq. 'SX') then keepit = .true. endif elseif (abuf(12:15) .eq. ecode) then keepit = .true. endif 290 continue endif c if (.not. keepit) then k = k + 1 go to 375 endif c c--------------- THIS RECORD WAS SELECTED FOR OUTPUT !!!!! ------------ c if (savstn .eq. ' ') then savstn = abuf(4:9) iseq = 0 endif cls9 = .false. newdsk = .false. c c------------------ DOES THE OUTPUT FILE NEED TO BE CLOSED ???? c if (omode .eq. '1' .and. savstn .ne. abuf(4:9)) then cls9 = .true. endif c c c--------------- DISPLAY INVENTORY INFORMATION ----------- c if (savstn .ne. abuf(4:9) .or. cls9 .or. newdsk ) then write(6, 295) savstn, savdt1, savdt2, noutct 295 format(/' ** St/Station: ',a6,' Begin_Date: ',a6, & ' End_Date: ',a6,' Records:',i6) noutct = 0 endif c if (cls9) then close (9) write(6, 300) filout, ioutct 300 format(/' Closing: ',a40,i7,' Records Written') if (invcnt .gt. 0) then write(6, 305) invcnt 305 format(1x,i7,' Records Had Invalid Chars Changed To (?)') endif ioutct = 0 invcnt = 0 c if (savout(1:6) .ne. abuf(4:9)) then iseq = 0 endif endif c if (newdsk) then ibytes = 0 write(6, 308) ndisk, patho(1:2) 308 format( & //' DISKETTE #',i2,' FULL - SWAP DISKETTES IN DRIVE ',a2, & /' -- PRESS ENTER TO CONTINUE OR CTRL-C TO STOP --') read(5, '(a1)') opt ndisk = ndisk + 1 endif c c-------------------- OPEN OUTPUT FILE IF NECESSARY ------ c if (ioutct .eq. 0) then c c------------- PROGRAM ALLOWS FOR UP TO 26 UNIQUE FILENAMES --- c doloop = .true. do 350 while (doloop) iseq = iseq + 1 if (iseq .gt. 26) then write(6, 339) 339 format(//' ---- CANNOT CREATE A NEW DISK FILE ----' & /' PLEASE DEFINE A NEW DIRECTORY, OR ERASE OLD FILES' & /' AND RESTART THE PROGRAM' & /' ----- STOPPING PROGRAM -----') stop endif filout = patho(1:lpatho) // abuf(4:9) // & oseq(iseq:iseq) // '.dat' savout = abuf(4:9) // oseq(iseq:iseq) open (9, file=filout, status='new', err=343) write(6, 341) filout 341 format(/' Opening Output File: ',a40) doloop = .false. savdt1 = abuf(18:23) savdt2 = abuf(18:23) go to 350 c 343 continue write(6, 345) filout 345 format(/' Cannot Open ',a40 & /' File Exists, Trying Another Filename !!') 350 continue c endif c c----------------------REPLACE INVALID CHARACTERS WITH QUESTION MARKS--- c badflg = .false. do 358 ic=1, 402 ival = ibuf1(ic) if (ichflg(ival) .eq. 0) then abuf (ic:ic) = '?' if (.not. badflg) then invcnt = invcnt + 1 badflg = .true. write(6, 355) abuf(1:30) 355 format(' INVALID CHARS FOUND: ',a30) endif endif 358 continue c c------------- EXAMINE FLAGGED RECORDS SETTING DAYS TO MISSING --- c if (badflg) then iday = 0 do 364 ip=31, 402, 12 iday = iday + 1 if (abuf(ip:ip+11) .eq. '????????????') then write(dafill, 361) iday 361 format(i2.2,'99-99999M ') abuf(ip:ip+11) = dafill endif 364 continue endif c c write(9, '(a402)') abuf(1:402) ioutct = ioutct + 1 noutct = noutct + 1 ioutot = ioutot + 1 ibytes = ibytes + 404 if (savstn .ne. abuf(4:9)) then savstn = abuf(4:9) savdt1 = abuf(18:23) savdt2 = abuf(18:23) endif if (abuf(18:23) .lt. savdt1) then savdt1 = abuf(18:23) endif if (abuf(18:23) .gt. savdt2) then savdt2 = abuf(18:23) endif k = k + 1 go to 375 c 375 continue c if (ioutct .gt. 0) then write(6, 295) savstn, savdt1, savdt2, noutct close (9) write(6, 300) filout, ioutct if (invcnt .gt. 0) then write(6, 305) invcnt endif ioutct = 0 invcnt = 0 endif c 500 continue c 900 continue if (ioutot .eq. 0) then write(6, 905) 905 format(/' << NO DATA SELECTED >>') else write(6, 910) ioutot 910 format(/' A Grand Total Of ',i6,' Records Selected') endif c write(6, 920) 920 format(//' END OF JOB ') stop c 950 write (6, 960) istat 960 format(/' ERROR - OPENING INPUT FILE - IOSTAT = ',i5) stop 1000 write(6, 1010) irec, istat 1010 format(' ERROR READING INPUT FILE, record = ',i6,' iostat = ',i5) stop end