c--------------- PROGRAM:  COOPSOD.FOR ---------------------------- 
c
c  This Program conforms to Microsoft FORTRAN 5.0 standards and 
c  should compile under higher versions of FORTRAN.  
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 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','KA','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(/
     & ' COOPSOD.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 hard drive or'
     &/' to a diskette.  '/
     &/' 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'/
     &/' Press CTRL-P to activate/deactivate a line printer.'/
     &/' 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 view 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, 60)
 60         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, 62)
 62         format(//'  ** ERROR:  Station Sequence or Date Sequence',
     &        ' Reversed')
            keepit = .false.
          endif
          if (keepit) then
            isttot = isttot + 1
            write(6,66)param(1:4),param(6:9),param(11:16),param(18:23)
 66         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, 68) 
 68           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 Specific 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 CDROM Drive Letter')
      read(5, '(a1)') cddev
      write(6, 107) cddev
 107  format(/' CDROM Drive Letter = ',a1)
c
      doloop = .true.
      do 115 while (doloop)
        write(6, 110)
 110    format(
     &  //' Enter Output Destination:   1 = Hard Drive (C:)'
     &   /'                             2 = Diskette, 3.5, 1.44 MB'
     &   /'                             3 = Diskette, 5.25, 1.2 MB')
        read(5, '(a1)') odest
        if (odest .eq. '1') then 
          doloop = .false.
        elseif (odest .eq. '2' .or. odest .eq. '3')then
          ndisk = 1
          write(6, 113)
 113      format(/' NOTE:  Diskette Assumed To Be Empty')
          doloop = .false.
        else
          write(6, *)'--------- INVALID ENTRY, TRY AGAIN --------'
        endif
 115  continue
c
 118  continue
      write(6, 120)
 120  format(//' Enter Output Path, Examples.  C:\COOPSOD'
     &        /'                               A:'  
     &        /'                               B:'
     &        /'                               A:\DATA')
      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 = cddev // ':\DATA\' // 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, end=150, err=1000, iostat=istat) ibuf4
        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
        go to 175
c
 150    continue
c       write(6, *)'END SENSED DOING "dosch1"'
        dosch1 = .false.
 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, end=250, err=1000, iostat=istat) ibuf4
        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
        go to 275
c
 250    continue
c       write(6, *)'END SENSED DOING "dosch2"'
        dosch2 = .false.
 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, end=370, err=1000, iostat=istat) ibuf4
        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
        if (odest .eq. '2' .and. ibytes .gt. 1300000) then
          newdsk = .true.
          cls9 = .true.        
        endif
        if (odest .eq. '3' .and. ibytes .gt. 1100000) then
          newdsk = .true.
          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
 370    continue
c       write(6, *)'END SENSED DOING "dosch3"'
        eof7 = .true.
        dosch3 = .false.
 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       

