C  **************************************************************
C
C  ULTRATAPE - REPLACES MEGATAPE
C             PERFORMS READS, WRITES, AND LISTINGS ON 80 CHAR/RECORD
C             STYLE TAPES FOR THE ARCHIVAL OF GRID, POST,
C             XYZ BINARY DATA FORMATS, AS WELL AS ASCII FILES.
C
C  **************************************************************
C  REVISION HISTORY
C     PROGRAM/VERS     WHEN     WHAT           BY WHOM
C      MEGATAPE/0     8/17/83  TYPED IN        RICK SALTUS
C         "           8/22/83  READ TESTED
C         "           8/22/83  WRITE SUBROUTINES ADDED
C         "           8/23/83  GRID READS RE-WRITTEN
C         "          11/21/83  OPTIONAL LIST TO FILE
C         "           5/15/84  SKIP JUNK FILES AT START
C      MEGATAPE/1.0   5/21/84  ALLOW MANUAL INPUT OF GRID PARAMS
C     ULTRATAPE/0.0   9/09/85  ULTRATAPE CREATED FROM MEGATAPE
C     ULTRATAPE/0.1   9/30/85  VARIABLE BPI OPTION, ADDED ERROR HANDLING
C     ULTRATAPE/1.0  11/14/85  QIOW TAPE WRITES
C
      Integer *4chan
      Character*80 quest,tname*6,dname*8,top*1,ans*1
      Common /tape/dname,nfile,chan,ioffset,icode
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      common /dump/ ibrec,outblock
      character*4000 outblock
C      dimension outblock(50)
C
      ibrec=1
C
      Print *
      Write (6,100)
  100 Format (25x,'--- UltraTape  version 1.0 ---')
      Print *
      Print *,
     &'- A program for archival and retrieval of data on 80 character',
     &' per record tapes.'
      Print *,'- Please note that I like you to allocate a tape drive',
     &' before you run me.'
      Print *
      quest='Enter tape drive name (MTA0:, MTA1:, MSA0:, or MSB0:)'
      dname='MSA0:'
      ival=iaquest(quest,dname,'(A8)',-8)
      ilen=ideblank(dname)
      If (dname(ilen:ilen).NE.':')dname(ilen+1:ilen+1)=':'
      If (ival.EQ.-1)Go To 9999
C
C       MOUNT TAPE
C
      mult=1
      irec=80
      iblk=4000
      iden=1600
C
      Print *
      Print *,'- The program will now attempt to access your tape'
      Print *,
     &'- If the requested tape drive is allocated to someone else,'
     &,' the program will'
      Print *,'  wait until it is free.'
      Print *,
     &'- If you have allocated the drive and your tape isn''t on it,'
     &,' please put your'
      Print *,'  tape on now.'
      Print *
      If (iiquest('Tape density (800/1600/6250)',iden,'(i10)',1).LT.0)
     &Go To 9999
      Call mountape(tname,dname,dname,chan,irec,iblk,iden,1)
      nfile=1
      top='L'
      ioffset=0
   10 Continue
      Print *
      quest='Tape operation (Read/Write/List/Dump/Exit)'
      ival=iaquest(quest,top,'(A1)',-1)
      If (top.EQ.'R') Then
         Call readtape(0)
         Else If (top.EQ.'W') Then
         Call writetape()
         Else If (top.EQ.'L') Then
         Call readtape(1)
         Else If (top.EQ.'D') Then
         Call readtape(2)
         Else If ((top.EQ.'E').OR.(top.EQ.'Q').OR.(top.EQ.'/')) Then
         Go To 9998
         End If
      Go To 10
C
C     ENDINGS
C
 9998 Continue
      Print *
      quest='Do you want me to leave your tape online (y/n)'
      ans='N'
      ival=iaquest(quest,ans,'(A1)',-1)
      idmode=0
      If (ans.EQ.'Y')idmode=1
      Call dismount(dname,chan,idmode)
C
C     END WITH NO DISMOUNT
C
 9999 Continue
      Print *
      Print *,'- Have an Ultra-nice day'
      End
C  *********************************************************************
C
C     READTAPE - ASKS FOR RANGE TO READ AND CALLS PROPER READ SUBROUTINE
C             MODE=0 READ
C                 =1 LIST ONLY
C                 =2 DUMP ENTIRE TAPE TO DEFAULT DIRECTORY
C
C  *********************************************************************
      Subroutine readtape(mode)
      Character*8 dname,quest*80,ans*1,lfile*50
      Integer *4chan
      Common /tape/dname,nfile,chan,ioffset,icode
      nout=6
      If (mode.EQ.1) Then
         ans='N'
         quest='Do you want to send the listing to a file (Y/N)'
         ival=iaquest(quest,ans,'(A1)',-1)
         If (ans.EQ.'Y') Then
            nout=13
            lfile='ULTRATAPE.LIS'
            quest='Name of file to receive listing'
            ival=iaquest(quest,lfile,'(A50)',50)
            Open (13,file=lfile,status='NEW',form='FORMATTED',
     &      carriagecontrol='LIST')
            End If
         End If
      quest='File number of first file to read (0 if entire tape)'
      If (mode.EQ.1)
     &quest='File number of first file to list (0 if entire tape)'
      ifile1=0
      ifile2=0
      ival=iiquest(quest,ifile1,'(I11)',1)
      If (ival.GE.0) Then
         If (ifile1.NE.0) Then
            quest='Last file (0 if rest of tape)'
            ival=iiquest(quest,ifile2,'(I10)',1)
            If (ival.EQ.-1)Go To 99
            End If
         If (ifile1.EQ.0)ifile1=1
   10    Continue
         Call tapepos(chan,nfile,ifile1,1,ioffset)
         ieot=igetfile(ifile1,mode,nout)
         If (ieot.LT.0)Go To 98
         ifile1=ifile1+1
         If ((ifile2.EQ.0).OR.(ifile1.LE.ifile2))Go To 10
         End If
C
C       FALLS OUT HERE AFTER IFILE2 IS READ
C
   99 Continue
      If (ans.EQ.'Y')Close (13)
      Return
C
C       GETS HERE IF END OF TAPE IS REACHED
C
   98 Continue
      Print *,'- Reached the end of the tape.'
C
C     BACK UP ONE EOF MARK, SO THE TAPE IS STILL AT NFILE
C
      Call skipfile(chan,-1,0)
      Return
      End
C  *************************************************************
C     WRITETAPE - GETS INFORMATION ON DISK FILE AND CALLS
C                 PROPER WRITING SUBROUTINE
C  *************************************************************
      Subroutine writetape()
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname
      Integer *4chan
      Character*80 quest,filename,desc,ans*1
      ifile1=1
      quest='File number of first file to write on tape'
      ival=iiquest(quest,ifile1,'(I10)',1)
      If (ival.GE.0) Then
         Call tapepos(chan,nfile,ifile1,1,ioffset)
   10    Continue
         ival=iaquest('Disk file name',filename,'(a80)',0)
   15    Continue
         quest='File type (1-8), 0 for list'
         ival=iiquest(quest,itype,'(I2)',1)
         If (itype.EQ.0) Then
            Print *
            Print *,'File types:'
            Print *,' 1 = Standard Grid File'
            Print *,' 2 = Gravity Post File (BOUGUER style)'
            Print *,' 3 = Magnetic Post File (MAD style)'
            Print *,' 4 = Generic Post File'
            Print *,' 5 = XYZ File'
            Print *,' 6 = Design your own binary file'
            Print *,' 7 = 80 character/record Ascii file'
            Print *,' 8 = >80 character/record Ascii file'
            Print *
            Go To 15
            End If
         quest='Description (<80 characters)'
         If (itype.EQ.1)desc='USGS STANDARD GRID FILE'
         If (itype.EQ.2)desc='USGS GRAVITY DATA FILE'
         If (itype.EQ.3)desc='USGS MAGNETIC DATA FILE'
         If (itype.EQ.4)desc='USGS DATA FILE'
         If (itype.EQ.5)desc='USGS XYZ DATA FILE'
         If (itype.EQ.6)desc='USGS DATA FILE'
         If (itype.EQ.7)desc='USGS 80 CHARACTER ASCII DATA FILE'
         If (itype.EQ.8)desc='USGS ASCII DATA FILE'
         ival=iaquest(quest,desc,'(A80)',80)
         quest='Write another file to tape [y/n]'
         ans='N'
         If (itype.EQ.1)Call putgrid(filename,desc,ifile1)
         If ((itype.GT.1).AND.(itype.LT.7))Call putbin(filename,desc,
     &   ifile1)
         If (itype.GE.7)Call putascii(filename,desc,ifile1)
         ifile1=ifile1+1
         Print *
         ival=iaquest(quest,ans,'(A1)',-1)
         If (ans.EQ.'Y')Go To 10
         End If
      Return
      End
C  *********************************************************************
C    IGETFILE - GETS A FILE OFF THE TAPE AND WRITES IT TO DISK
C              MODE=0 READ
C                  =1 LIST ONLY
C                  =2 DUMP (AUTO READ)
C  *********************************************************************
      Integer Function igetfile(ifile1,mode,lfile)
      Common /gspecs/nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,id,pgm
      Character*56 id,pgm*8
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*(8) dname
      Integer *4chan
      Character*80 quest,filename*80,desc*80,date*50
      Data tdval/1.0e30/,ddval/1.1e38/
      igetfile=0
C
C     OPEN INPUT FILE (TAPE)
C
      Open (11,file=dname,status='OLD',form='FORMATTED',readonly)
C
C     READ HEADER INFO & LIST
C
      ieot=ireadhead(filename,desc,date)
      If (ieot.LT.0)Go To 99
C
C     LIST
C
      Write (lfile,1001)
 1001 Format ()
      Write (lfile,1002)ifile1,date
 1002 Format (' + TAPE FILE:',i4,' CREATION DATE: ',a23)
      Write (lfile,1004)filename
      Write (lfile,1004)desc
 1004 Format (x,'+ ',a78)
      If (itype.EQ.1) Then
         Write (lfile,1005)itype,ftype,idiskrec,itaperec,nlines
 1005    Format (x,'+ Filetype=',i2,x,a6,', Words/grid row=',i4,
     &   ' Numbers/tape record=',i2,/,
     &   ' + Tape records/grid row=',i3,'.')
         Call gprspecs(id,pgm,nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,lfile)
         Else If ((itype.GT.1).AND.(itype.LT.7)) Then
         Write (lfile,1006)itype,ftype,idiskrec,itaperec,nlines
 1006    Format (x,'+ Filetype=',i2,x,a6,', Words/disk record=',i4,
     &   ' Characters per tape line=',i3,/,
     &   ' + Tape records/line=',i3,'.')
         Else
         Write (lfile,1007)itype,ftype,idiskrec,nlines
 1007    Format (x,'+ Filetype=',i2,x,a6,x,i3,' Characters/line,',i3,
     &   ' Tape records/line.')
         End If
C
C     FOR LIST ONLY, SKIP OVER REST OF FILE
C
      If (mode.EQ.1) Then
         Close (11)
         Call skipfile(chan,1,0)
         nfile=nfile+1
         Else
C
C     READ IN FILE AND COPY TO DISK FILE
C
         Print *
         quest='Output file name'
         If (mode.EQ.0)
     &   ival=iaquest(quest,filename,'(A50)',50)
         If (itype.EQ.1) Then
            igetfile=igetgrid(filename,id,pgm,nc,nr,nz,x0,dx,y0,dy)
            Else If (itype.LT.7) Then
            igetfile=igetbin(filename)
            Else
            igetfile=igetascii(filename)
            End If
C
C       END OF FILE
C
   98    Continue
         Close (11)
         nfile=nfile+1
         End If
      Return
C
C     ZERO LENGTH FILE (END OF TAPE) OR INCOMPLETE HEADER REACHED
C
   99 Continue
      Close (11)
      igetfile=-1
      Return
      End
C **************************************************************
C     IREADHEAD - INPUT TAPE FILE HEADER
C **************************************************************
      Integer Function ireadhead(filename,desc,date)
      Character*(*) filename,desc,date
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /gspecs/nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,id,pgm
      Character*56 id,pgm*8
      Character*(80) buffer
C
      ireadhead=0
      If (igetrec(buffer,80,1).LT.0)Go To 98
      Read (buffer,105,err=99)itype,date
  105 Format (9x,i5,16x,a50)
      If (igetrec(filename,80,1).LT.0)Go To 99
      If (igetrec(desc,80,1).LT.0)Go To 99
      If (igetrec(rformat,80,1).LT.0)Go To 99
      If (igetrec(buffer,80,1).LT.0)Go To 99
      Read (buffer,115,err=99)ftype,itaperec,idiskrec,nlines
  115 Format (a6,3(10x,i5))
C
C     IF GRID, READ GRID SPECS
C
      If (itype.EQ.1) Then
         If (igetrec(buffer,80,1).LT.0)Go To 99
         Read (buffer,120,err=99)id,pgm,cm,bl
  120    Format (a56,a8,2f8.3)
         If (igetrec(buffer,80,1).LT.0)Go To 99
         Read (buffer,125,err=99)nc,nr,nz,iproj,x0,dx,y0,dy
  125    Format (2i5,i4,i2,4e16.8)
         End If
C
C     SKIP OVER REST OF TAPE FILE HEADER (TOTAL OF 10 RECORDS)
C
      nskip=5
      If (itype.EQ.1)nskip=3
      Do 18 i=1,nskip
   18 If (igetrec(buffer,80,1).LT.0)Go To 99
      Return
C
C     ENCOUNTERED END OF FILE (END OF TAPE ?) READING HEADER
C
   98 Continue
      ireadhead=-1
   99 Continue
      Print *,'- Encountered end of file reading tape file header'
      Return
      End
C *********************************************************************
C     WRITEHEAD - WRITES FILE HEADER TO TAPE
C *********************************************************************
      Subroutine writehead(filename,desc)
      Character*(*) filename,desc
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /gspecs/nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,id,pgm
      Character*56 id,pgm*8
C
      Character*50 date,buffer*80
C
      Call lib$date_time(date)
      Write (buffer,100)itype,date
  100 Format ('FILETYPE=',i5,' CREATION DATE: ',a50)
      Call dumprec(buffer,80,1)
      Call dumprec(filename,80,1)
      Call dumprec(desc,80,1)
      Call dumprec(rformat,80,1)
      Write (buffer,120)ftype,itaperec,idiskrec,nlines
  120 Format (a6,' IN #/LINE',i5,' OUT #/LIN',i5,4x,'IN/OUT',i5)
      Call dumprec(buffer,80,1)
      If (itype.EQ.1) Then
         Write (buffer,130)id,pgm,cm,bl
  130    Format (a56,a8,2f8.3)
         Call dumprec(buffer,80,1)
         Write (buffer,140)nc,nr,nz,iproj,x0,dx,y0,dy
  140    Format (2i5,i4,i2,4e16.8)
         Call dumprec(buffer,80,1)
         buffer='THE TWO LINES ABOVE CONTAIN GRID SPECIFICATIONS.'
         Call dumprec(buffer,80,1)
         buffer=
     &'LINE 1: GRID ID (a56), CREATION PROGRAM (a8), C MERID, BASE LAT'
         Call dumprec(buffer,80,1)
         buffer=
     &'LINE 2: #COL, #ROW, #VAL, PROJ, X ORIG., DEL X, Y ORIG., DEL Y'
         Call dumprec(buffer,80,1)
         Else
         buffer=
     &   'USGS TAPE FILE HEADER ...... DATA BEGINS AT RECORD #11'
         Do 10 i=6,10
   10    Call dumprec(buffer,80,1)
         End If
      Return
      End
C
C  *****************************************************************
C     GETBIN - INPUTS AND TRANSLATES A BINARY FILE
C  *****************************************************************
      Integer Function igetbin(filename)
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname
      Integer *4chan
      Character filename*(*),buffer*256
      Dimension binval(100)
      Parameter (tdval=1.0e30,ddval=1.1e38,io_ok=0)
      include'($fordef)'
      igetbin=0
      ipos=1
      iread=0
      icant=0
      iwrote=0
      Open (10,file=filename,status='NEW',form='UNFORMATTED')
      Print *,'- Reading a binary file from tape......'
   20 Continue
      If (igetrec(buffer,itaperec,nlines).LT.0)Go To 98
      iread=iread+1
      Read (buffer,rformat,iostat=io_stat)(binval(i),i=1,idiskrec)
      If (io_stat.NE.io_ok) Then
         Call errsns(,,,,istat)
         If (istat.EQ.for$_inpconerr) Then
            Write (6,100)iread
  100       Format (' - Format problem reading tape record #',i6,
     &      '.  Unable to convert to binary.')
            Write (6,110)buffer
  110       Format (a80)
            icant=icant+1
            Else
            Write (6,120)iread
  120       Format (' - Problem reading record #',i6)
            icant=icant+1
            Call lib$signal(%val(istat))
            End If
         Else
C        IF (BINVAL(3).GE.TDVAL) BINVAL(3)=DDVAL
         Write (10)(binval(i),i=1,idiskrec)
         iwrote=iwrote+1
         End If
      Go To 20
C
C       END OF FILE
C
   98 Continue
      Write (6,200)iread,iwrote
  200 Format (' - ',i6,' Tape records read, ',i6,
     &' disk records written.')
      If (icant.NE.0)Write (6,210)icant
  210 Format (' - ',i6,' Records skipped due to read problems.')
      Close (10)
      Return
      End
C  *****************************************************************
C     GETASCII - INPUTS AN ASCII FILE
C  *****************************************************************
      Integer Function igetascii(filename)
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname
      Integer *4chan
      Character filename*(*),buffer*256,strip*1,sformat*10
      igetascii=0
C
      strip='Y'
      ival=iaquest('Remove trailing blanks (y/n)',strip,'(a1)',-1)
C
      Open (10,file=filename,status='NEW',form='FORMATTED',
     &carriagecontrol='LIST')
      Print *,'- Reading an Ascii file from tape.......'
   20 Continue
      If (igetrec(buffer,itaperec,nlines).LT.0)Go To 98
C
C       ADD TRAILING BLANK STRIP HERE
C
      If (strip.EQ.'Y') Then
         istrip=itlen(buffer(1:itaperec))
         Write (sformat,100)istrip
  100    Format ('(a',i3,')')
         Write (10,sformat)buffer(1:istrip)
         Else
         Write (10,rformat)buffer(1:itaperec)
         End If
      Go To 20
C
C       END OF FILE
C
   98 Continue
      Close (10)
      Return
      End
C  **************************************************************
C     GETGRID - GETS A GRID FROM TAPE TO DISK
C  **************************************************************
      Integer Function igetgrid(filename,id,pgm,nc,nr,nz,x0,dx,y0,dy)
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname
      Integer *4chan
      Character*80 quest,desc,filename,buffer
      Character*56 id,pgm*8
      Dimension tval(10000)
      Data tdval/1.0e30/,ddval/1.1e38/
      igetgrid=0
C
C     READ IN THE GRID, UNPACK ROWS AND WRITE TO DISK
C
      Open (10,file=filename,status='NEW',form='UNFORMATTED')
      Write (10)id,pgm,nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl
      irow=0
      ipos=1
      Print *,'- Reading a grid from tape.....'
C
C     READ IN A RECORD (80 CHARACTER) FROM THE TAPE
C
   20 Continue
      Do 25 i=1,nlines
      ipos=((i-1)*itaperec)+1
      If (igetrec(buffer,80,1).LT.0)Go To 98
   25 Read (buffer,rformat)(tval(j),j=ipos,ipos+itaperec-1)
C
C     CHANGE TAPE DVAL (MISSING DATA FLAG) TO SYSTEM DVAL
C
      Do 35 j=1,nc+1
   35 If (tval(j).GE.tdval)tval(j)=ddval
C
C     WRITE THE ROW TO THE DISK FILE
C
      Call rowout(tval,nc+1)
      irow=irow+1
C Statement added by John Cady 1/17/92 to print progress reports
      if(irwpr(irow).eq.1 . or. irow+10.gt.nr) 
     1  print *,' Wrote row ',irow,' to disk.'
C
C     IF THE LAST ROW HASN'T BEEN WRITTEN, THEN READ IN NEXT RECORD
C
      ipos=1
      If (irow.LT.nr)Go To 20
C
C     NORMAL TERMINATION - GO TO END OF FILE
C
   76 If (igetrec(buffer,80,1).LT.0)Go To 98
      Go To 76
C
C     HIT END OF FILE
C
   98 Continue
      If (irow.LT.nr)
     &Print *,'- End of file encountered after ',irow,' rows.'
      Close (10)
      Return
      End
C  ****************************************************************
C     PUTGRID
C  ****************************************************************
      Subroutine putgrid(filename,desc,ifile1)
      Character*(*) filename,desc
      Common /gspecs/nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,id,pgm
      Character*56 id,pgm*8
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname,buffer*80
      Integer *4chan
      Dimension tval(10000)
      Data dval/1.0e38/,tdval/1.0e30/
C
C     OPEN INPUT (DISK) AND OUTPUT (TAPE) FILES
C
      Open (10,file=filename,status='OLD',form='UNFORMATTED',readonly)
      Open (11,file=dname,status='NEW',form='FORMATTED',recl=80,
     & blocksize=4000,carriagecontrol='list')
C
C     READ STANDARD GRID HEADER AND WRITE TAPE FILE HEADER
C
      Read (10,err=5)id,pgm,nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl
      Go To 7
C
C     "OLD" GRID WITH NO PROJ INFORMATION
C
    5 Continue
      Rewind (10)
      Read (10)id,pgm,nc,nr,nz,x0,dx,y0,dy
      ival=iiquest('Projection of grid (1=poly, 2=utm, 4=lam, 5=alb)',
     &iproj,'(i5)',0)
      ival=irquest('Central meridian',cm,'(f16.8)',0)
      ival=irquest('Base latitude',bl,'(f16.8)',0)
C
    7 rformat='(5E16.8)'
      ftype='GRID'
      itaperec=5
      idiskrec=(nc*nz)+1
      irem=mod(idiskrec,itaperec)
      nlines=int(idiskrec/itaperec)
      If (irem.NE.0)nlines=nlines+1
      Print *
C
      Call writehead(filename,desc)
      Print *,'- Grid specifications:'
      Call gprspecs(id,pgm,nc,nr,nz,x0,dx,y0,dy,iproj,cm,bl,6)
C
C     WRITE GRID ROWS TO TAPE
C
      irow=0
      iwrote=0
      Print *,'- Writing a standard grid file to tape.....'
   10 Continue
      irow=irow+1
C
C     READ IN A GRID ROW
C
      Call rowin(tval,nc+1)
C
C  Statement added by John Cady 1/17/92
      if(irwpr(irow).eq.1 .or. irow+10.gt.nr) 
     1 print *,' Read row ',irow,' from disk.'
C     CHANGE DVALS (MISSING DATA FLAG) TO TAPE DVAL
C
      Do 15 j=1,nc+1
   15 If (tval(j).GE.dval)tval(j)=tdval
C
C     SET IPOS TO INDICATE THE NUMBER OF VALUES TO BE OUTPUT
C     itaperec TO A LINE
C
      ipos=1
   20 Continue
      Write (buffer,rformat)(tval(i),i=ipos,ipos+itaperec-1)
      Call dumprec(buffer,80,1)
      iwrote=iwrote+1
      ipos=ipos+itaperec
C
C     IF SOME VALUES HAVEN'T BEEN WRITTEN YET, KEEP WRITING
C
      If (ipos.LT.nc+2)Go To 20
C
C     IF THE LAST ROW HASN'T BEEN WRITTEN YET, KEEP READING
C
      If (irow.LT.nr)Go To 10
C
C     DONE- dump blocks and close file
C
      call dumpblock()
      Close (11)
      Close (10)
      nfile=nfile+1
      Print *
      Write (6,180)ifile1
  180 Format (x,'- Tape file #:',i4)
      Write (6,190)filename
  190 Format (x,'- ',a78)
      If (iwrote.NE.(nr*nlines)) Then
         Write (6,195)iwrote,nr*nlines
  195    Format (' - Required ',i5,' records rather than ',
     &   i5,' as expected.')
         End If
      Write (6,200)iwrote+10
  200 Format (' - Written to tape with ',i5,' tape records.')
      Return
      End
C  ****************************************************************
C     PUTBIN - WRITES A BINARY FILE TO TAPE
C  ****************************************************************
      Subroutine putbin(filename,desc,ifile1)
      Character*(*) filename,desc
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname,id,buffer*256,quest*80
      Integer *4chan
      Dimension binval(100)
      Parameter (dval=1.0e38,tdval=1.0e30,io_ok=0)
      include'($fordef)'
      irec=0
      iwrote=0
      icant=0
      idlen=len(desc)
C
C     OPEN INPUT (DISK) AND OUTPUT (TAPE) FILES
C
      Open (10,file=filename,status='OLD',form='UNFORMATTED',readonly)
      Open (11,file=dname,status='NEW',form='FORMATTED',recl=80,
     & blocksize=4000,carriagecontrol='list')
C
      ftype='BINARY'
      If (itype.EQ.6) Then
C
C     USER WANTS TO 'CUSTOM DESIGN' A BINARY FILE TYPE
C
         quest='Fortran format for record translation'
         rformat='(3e16.8)'
         ival=iaquest(quest,rformat,'(a80)',-1)
         quest='Number of words in disk file record'
         ival=iiquest(quest,idiskrec,'(i5)',0)
         quest='Number of characters produced by fortran format'
         ival=iiquest(quest,itaperec,'(i5)',0)
C
C     SET UP STANDARD BINARY FILE TYPE
C
         Else If (itype.EQ.2) Then
C
C     GRAVITY POST FILE
C
         rformat='(2a4,2f10.4,2f9.3,f10.3,2f7.2,f10.3)'
         idiskrec=10
         itaperec=80
         Else If (itype.EQ.3) Then
C
C     AEROMAG POST FILE
C
         rformat='(2a4,2f10.4,2f10.1,2f6.1,f12.3,f8.3)'
         idiskrec=10
         itaperec=80
         Else If (itype.EQ.4) Then
C
C     GENERIC POST FILE
C
         rformat='(2a4,8e16.8)'
         idiskrec=10
         itaperec=136
         Else If (itype.EQ.5) Then
C
C     GENERIC XYZ FILE
C
         rformat='(3e20.8)'
         idiskrec=3
         itaperec=60
         End If
      irem=mod(itaperec,80)
      nlines=int(itaperec/80)
      If (irem.NE.0)nlines=nlines+1
C
C     WRITE TAPE FILE HEADER
C
      Call writehead(filename,desc)
C
C     WRITE BINARY FILE TO TAPE
C
      Print *,'- Writing a binary disk file to tape......'
   10 Continue
      Read (10,End =99)(binval(i),i=1,idiskrec)
      irec=irec+1
C      DO 15 J=1,8
C  15  IF (PVAL(J).GE.DVAL) PVAL(J)=TDVAL
      Write (buffer,rformat,iostat=io_stat)(binval(i),i=1,idiskrec)
C
C     VAX DEPENDANT ERROR HANDLING
C
      If (io_stat.NE.io_ok) Then
         Call errsns(,,,,istat)
         If (istat.EQ.for$_outconerr) Then
C     Format statement puts '****'s in output buffer
            Write (6,100)irec
  100       Format (' - Some value in disk file record #',i6,
     &      ' is too big for the format - skip record')
            icant=icant+1
            Else
            Write (6,110)irec
  110       Format (' - Write error on disk file record #',i6)
            Call lib$signal(%val(istat))
            icant=icant+1
            End If
         Else
         Call dumprec(buffer,itaperec,nlines)
         iwrote=iwrote+1
         End If
      Go To 10
C
C     DONE
C
   99 Continue
      Print *
      Write (6,180)ifile1
  180 Format (x,'- Tape file #:',i4)
      Write (6,190)filename
  190 Format (x,'- ',a78)
      Write (6,200)irec,iwrote+10
  200 Format (' - ',i6,' Disk records written to ',i6,' tape records.')
      If (icant.NE.0)Write (6,210)icant
  210 Format (' - ',i6,' Records not written due to format problems')
      Close (10)
      call dumpblock()
      Close (11)
      nfile=nfile+1
      Return
      End
C  ****************************************************************
C     PUTASCII - PUTS A SIMPLE ASCII FILE TO TAPE
C  ****************************************************************
      Subroutine putascii(filename,desc,ifile1)
      Common /fheader/itype,ftype,itaperec,idiskrec,nlines,rformat
      Character*80 rformat,ftype*6
      Character*(*) filename,desc
      Common /tape/dname,nfile,chan,ioffset,icode
      Character*8 dname,id,buffer*256
      Integer *4chan
      Dimension xval(3)
      Data dval/1.0e38/,tdval/1.0e30/
      irec=0
      idlen=len(desc)
C
C     OPEN INPUT (DISK) AND OUTPUT (TAPE) FILES
C
      Open (10,file=filename,status='OLD',form='FORMATTED',readonly)
      Open (11,file=dname,status='NEW',form='FORMATTED',recl=80,
     & blocksize=4000,carriagecontrol='list')
C
C     SET UP TAPE FILE HEADER INFORMATION
C
      idiskrec=80
      itaperec=80
      rformat='(a80)'
      ftype='ASCII'
      If (itype.EQ.8) Then
         ival=iiquest('Disk file record length (characters)',idiskrec,
     &   '(i5)',0)
         Write (rformat,100)idiskrec
         itaperec=idiskrec
  100    Format ('(a',i4,')')
         End If
      irem=mod(itaperec,80)
      nlines=int(itaperec/80)
      If (irem.NE.0)nlines=nlines+1
C
      Call writehead(filename,desc)
C
C     WRITE ascii FILE TO TAPE
C
      Print *,'- Writing an Ascii disk file to tape......'
   10 Continue
      Read (10,rformat,End =99)buffer
      irec=irec+1
      Call dumprec(buffer,itaperec,nlines)
      Go To 10
C
C     DONE
C
   99 Continue
      Print *
      Write (6,180)ifile1
  180 Format (x,'- Tape file #:',i4)
      Write (6,190)filename
  190 Format (x,'- ',a78)
      Write (6,110)irec,irec*nlines+10
  110 Format (' - ',i6,' disk records written to ',i6,' tape records.')
      Close (10)
      call dumpblock()
      Close (11)
      nfile=nfile+1
      Return
      End
C *****************************************************************
C     DUMPREC - Dumps records into a block and calls dumpblock
C *****************************************************************
      Subroutine dumprec(buffer,len,nline)
      Character*(*) buffer
      common /dump/ irec,outblock
      character*4000 outblock
C      dimension outblock(50)
      Do 10 i=1,nline
      ib=(i-1)*80+1
      ie=min(len,ib+79)
      outblock(irec:irec+79)=buffer(ib:ie)
      irec=irec+80
      if (irec.gt.4000) call dumpblock()
   10 Continue
      Return
      End
C  ****************************************************************
C     DUMPBLOCK - Writes a block (4000 bytes) to tape
C  ****************************************************************
      subroutine dumpblock
      common /tape/ dname,nfile,chan,ioffset,icode
      character*8 dname
      integer*4 chan,sys$qiow,lib$stop,stat
      common /dump/ irec,outblock
      character*4000 outblock
      integer*2 iosb(4)
C
      external io$_writelblk
C
C      dimension outblock(50)
C
      if (irec.gt.1) then
      stat=sys$qiow(,%val(chan),io$_writelblk,iosb,,,
     & %ref(outblock(1:1)),%val(irec-1),,,,)
C
C      write(11,100)(outblock(j),j=1,irec-1)
      irec=1
  100 format(50(a80,/))
      end if
      return
      end
C  ****************************************************************
C     IGETREC - TAPE INPUT
C  ****************************************************************
      Integer Function igetrec(buffer,len,nline)
      Character*(*) buffer
C
      igetrec=0
      Do 10 i=1,nline
      ib=(i-1)*80+1
      ie=min(len,ib+79)
      Read (11,100,End =99)buffer(ib:ie)
   10 Continue
  100 Format (a80)
      Return
C
   99 Continue
      igetrec=-1
      Return
      End
C  ****************************************************************
C     ROWOUT - VARAIBLE DIM ROW OUTPUT
C  ****************************************************************
      Subroutine rowout(tval,idim)
      Dimension tval(idim)
      Write (10)tval
      Return
      End
C  ****************************************************************
C     ROWIN - VARIABLE DIMENSION ROW INPUT
C  ****************************************************************
      Subroutine rowin(tval,idim)
      Dimension tval(idim)
      Read (10)tval
      Return
      End
Cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      Subroutine gprspecs(id,pgm,ncol,nrow,nz,xo,dx,yo,dy,iproj,cm,bl,
     &nfile)
      Character id*56,pgm*8
      Write (nfile,1001)id,pgm
 1001 Format (' +  id=',a56,'   pgm=',a8)
      Write (nfile,1002)'nz  =',nz
      Write (nfile,1002)'ncol=',ncol,'xo=',xo,'dx=',dx
      Write (nfile,1002)'nrow=',nrow,'yo=',yo,'dy=',dy
      Write (nfile,1002)'proj=',iproj,'cm=',cm,'bl=',bl
 1002 Format (1x,'+ ',a6,i8,a8,g14.8,a8,g14.8)
      Return
      End
C+
C     SKIPFILE SUBROUTINE 
C       VAX dependant subroutine to position mag tapes
C
C     Call SKIPFILE (CHAN,NUM,MODE)
C
C        CHAN = Channel number of tape drive
C
C         NUM = Number of end of file marks to skip
C
C        MODE = 0 no rewind
C               1 rewind first
C
C      Calls: SYS$QIOW, LIB$STOP
C-
C  *********************************************
C
      SUBROUTINE SKIPFILE(CHAN,NUM,MODE)
      INTEGER*4 CHAN,NUM,SYS$QIOW,LIB$STOP
      INCLUDE '($SSDEF)'
      INCLUDE '($IODEF)'
C
      IF (MODE.NE.0) THEN
        ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_REWIND),,,,,,,,,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 99
        END IF
      IF (NUM.NE.0) THEN
        ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SKIPFILE),,,,%VAL(NUM),,,,,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 98 
        END IF
      RETURN
C
   98 PRINT *,'UNABLE TO SKIP FILE ON TAPE'
      CALL LIB$STOP(%VAL(ISTAT))
      STOP
   99 PRINT *,'UNABLE TO REWIND TAPE'
      CALL LIB$STOP(%VAL(ISTAT))
      STOP
      END
C+
C      TAPEPOS - CALLS THE SKIPFILE SUBROUTINE TO POSITION
C                A TAPE TO THE BEGINNING OF THE REQUESTED FILE
C
C       Call TAPEPOS (chan,nfile,ifile,mult,ieot)
C
C          chan = channel number of the tape drive (assigned during mount)
C
C         nfile = physical file number to position the tape at
C
C         ifile = current logical file number
C
C         mult  = number of physical files per logical file
C                 (normally = 1)
C
C       ioffset = number of files to skip over at the begining of the tape
C
C-
C  ***************************************************************
      SUBROUTINE TAPEPOS(CHAN,NFILE,IFILE,MULT,IOFFSET)
      INTEGER*4 CHAN
      MFILE=(IFILE-1)*MULT+1+IOFFSET
C
C
      if (nfile.ne.mfile) then
      write (6,100)nfile,mfile
 100  format (' - Tape is at file',i4,', will now skip to file',i4,'.')
      end if
C
C
      IF (NFILE.LT.MFILE) THEN
        CALL SKIPFILE(CHAN,MFILE-NFILE,0)
        NFILE=MFILE
      ELSE IF (NFILE.GT.MFILE) THEN
        IF (MFILE.EQ.1) THEN
          CALL SKIPFILE(CHAN,0,1)
          NFILE=1
        ELSE 
          CALL SKIPFILE(CHAN,MFILE-NFILE-1,0)
          CALL SKIPFILE(CHAN,1,0)
          NFILE=MFILE
          END IF
        END IF
      RETURN
      END
C+
C     DISMOUNT SUBROUTINE
C       VAX dependant subroutine to dismount a tape drive
C
C       call DISMOUNT (DNAME,CHAN,MODE)
C
C         DNAME = character string containing name of the tape drive
C
C          CHAN = Integer*4 tape drive channel number
C
C     MODE = 0  REWINDS THE TAPE, DISMOUNTS, AND DEASSIGNS
C               CHANNEL, 
C          
C          = 1  JUST DISMOUNTS THE TAPE WITH NO UNLOAD
C
C 
C       Calls: SYS$QIOW, SYS$DASSGN, SYS$DISMOU, LIB$STOP
C-
      SUBROUTINE DISMOUNT(DNAME,CHAN,MODE)
      CHARACTER*(*) DNAME
      INTEGER*4 CHAN,SYS$DISMOU,SYS$DASSGN,SYS$QIOW
      INCLUDE '($SSDEF)'
      INCLUDE '($IODEF)'
      INCLUDE '($DMTDEF)'
C
      IF (MODE.EQ.0) THEN
        ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_REWINDOFF),,,,,,,,,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 96
        ISTAT=SYS$DASSGN(%VAL(CHAN))
        IF (ISTAT.NE.SS$_NORMAL) GO TO 98
        ISTAT=SYS$DISMOU(DNAME,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 97
      ELSE
        ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_REWIND),,,,,,,,,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 96
        ISTAT=SYS$DISMOU(DNAME,%VAL(DMT$_NOUNLOAD))
        IF (ISTAT.NE.SS$_NORMAL) GO TO 97
        ISTAT=SYS$DASSGN(%VAL(CHAN))
        IF (ISTAT.NE.SS$_NORMAL) GO TO 98
        END IF
      CHAN=0
      RETURN
C
C     ERROR RETURNS
C
  96  PRINT *,'UNABLE TO REWIND'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  97  PRINT *,'UNABLE TO DISMOUNT TAPE'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  98  PRINT *,'UNABLE TO DEASSIGN CHANNEL NUMBER'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  99  PRINT *,'UNABLE TO DEALLOCATE TAPE DRIVE'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
      END
C+
C     MOUNTAPE FUNCTION
C      VAX dependant function to mount a FOREIGN tape
C
C       ival = MOUNTAPE (TAPENO,TNAME,DNAME,CHAN,REC,BLK,DEN,MODE)
C
C         IVAL =  0 mount worked !
C              = -1 mount failed
C
C       TAPENO = Character string containing tape number
C       TNAME  = Character string containing tape name
C       DNAME  = Drive name (returned for mode=0, read for mode=1)
C       CHAN   = Tape drive channel number (returned)
C       REC    = Record size for mount
C       BLK    = Block size for mount
C       DEN    = Tape density (800/1600/6250)
C
C     MODE  = 0  ALLOCATES DRIVE, REQUESTS TAPE TO BE MOUNTED,
C                ASSIGNS CHANNEL NUMBER, AND MOUNTS TAPE.
C
C           = 1  JUST MOUNTS TAPE, AND ASSIGNS CHANNEL NUMBER
C-
      INTEGER FUNCTION MOUNTAPE
     & (TAPENO,TNAME,DNAME,CHAN,REC,BLK,DEN,MODE)
      CHARACTER*(*) TAPENO,TNAME,DNAME,A*1
      INTEGER*4 CHAN,SYS$ASSIGN,NLEN,SYS$ALLOC,SYS$MOUNT,SYS$CRELOG
      INCLUDE '($MNTDEF)'
      INCLUDE '($SSDEF)'
      INTEGER*2 IC1,IC2,IC3,IC4,IC5,IC6,IC7,IC8
      INTEGER*2 BL1,BL2,BL3,BL4,BL5,BL6,BL7,BL8
      INTEGER*4 BA1,BA2,BA3,BA4,BA5,BA6,BA7
      INTEGER*4 NU1,NU2,NU3,NU4,NU5,NU6,NU7
      INTEGER*4 ZERO,BLK,REC,FOREIGN,DEN
      COMMON /MTLIST/ BL1,IC1,BA1,NU1,BL2,IC2,BA2,NU2,
     1BL4,IC4,BA4,NU4,BL5,IC5,BA5,NU5,
     2BL6,IC6,BA6,NU6,BL7,IC7,BA7,NU7,BL8,IC8,ZERO
C
      BL8=0
      IC8=0
      ZERO=0
      FOREIGN=MNT$M_FOREIGN
C
C     SET UP MOUNT DATA STRUCTURE
C
      IC1=MNT$_DEVNAM
      BL1=LEN(DNAME)
      BA1=%LOC(DNAME)
      IC2=MNT$_VOLNAM
      BL2=LEN(TAPENO)
      BA2=%LOC(TAPENO)
      IC3=MNT$_LOGNAM
      BL3=LEN(TNAME)
      BA3=%LOC(TNAME)
      IC6=MNT$_BLOCKSIZE
      BL6=4
      BA6=%LOC(BLK)
      IC5=MNT$_RECORDSIZ
      BL5=4
      BA5=%LOC(REC)
      IC4=MNT$_FLAGS
      BL4=4
      BA4=%LOC(FOREIGN)
      IC7=MNT$_DENSITY
      BL7=4
      BA7=%LOC(DEN)
C
      MOUNTAPE=-1
      IF (MODE.EQ.0) THEN
        ISTAT=SYS$ALLOC('MS',NLEN,DNAME,)
        IF (ISTAT.NE.SS$_NORMAL) GO TO 97
        ISTAT=SYS$CRELOG(%VAL(2),TNAME,DNAME,)
        IF (.NOT.ISTAT) GO TO 96
        PRINT *,'TAPE DRIVE ',DNAME,' ASSIGNED'
        PRINT *,'PLEASE MOUNT TAPE ON DRIVE ASSIGNED, THEN PRESS RETURN'
        READ(5,100)A
  100   FORMAT(A1)
        END IF
      ISTAT=SYS$MOUNT(BL1)
      IF (ISTAT.NE.SS$_NORMAL) GO TO 98
      ISTAT=SYS$ASSIGN(DNAME,CHAN,,)
      IF (ISTAT.NE.SS$_NORMAL) GO TO 99
      MOUNTAPE=0
      RETURN
C
  96  PRINT *,'UNABLE TO MAKE ENTRY TO LOGICAL NAME TABLE'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  97  PRINT *,'UNABLE TO ALLOCATE TAPE DRIVE'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  98  PRINT *,'UNABLE TO MOUNT TAPE'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
  99  PRINT *,'UNABLE TO ASSIGN I/O CHANNEL'
      CALL LIB$STOP(%VAL(ISTAT))
      RETURN
      END
CS    USGS Function IAQUEST
C     Version: 1.0
C     Technical Contact: R. Saltus
C     Release: not released
C
C+
C     Function IAQUEST
C
C     Program purpose:
C         Asks a question requiring a character-string response.
C         Allows the use of a default answer and will optionally upshift the
C         response.
C
C     Instructions for use:
C         This subroutine should be called whenever a character-string response
C         is called for in a FORTRAN program.
C
      Integer Function iaquest(quest,aval,form,mode)
C-
C
C     Variables and parameters:
C     ireturn = IAQUEST (quest,aval,form,mode)
C
C      ireturn =  -1 if '//' was given as response (user wants out)
C                  0 if no response (user took default)
C                  1 if user responded (returns response in aval)
C
C        quest =  Character string containing question to be asked
C                 (with no ? at the end, it is added by function)
C
C         aval =  Character string to receive answer
C                 (used to pass default if one is available)
C
C         form =  Character string containing fortran format to be
C                 used to read the user response
C
C         mode =  Integer control parameter:
C
C              mode > 0, default allowed
C              mode = 0, no default allowed, upshift response
C              mode < 0, default allowed, upshift response
C
C         Calls ITLEN, UPSHIFT, GETANS
C^
C  *********************************************
      Character quest*(*),form*(*),aval*(*)
      Character*100 str,form2*10,ans*80,astr*30
      iaquest=0
      iqlen=itlen(quest)
      irlen=itlen(aval)
C
C     If response is to be upshifted, upshift default
C
      If (mode.LT.0)Call upshift(aval)
      If (irlen.EQ.0)irlen=1
C
C     Insert default answer into question
C
      If (mode.NE.0) Then
         str=quest(1:iqlen)//' ['//aval(1:irlen)//']?'
         islen=iqlen+irlen+4
      Else
         str=quest(1:iqlen)//'?'
         islen=iqlen+1
      End If
C
C     Construct fortran format for printing of question
C
      Write (form2,105)islen
  105 Format ('(x,a',i3,',$)')
C
C     Repeats to here if question is re-asked
C
   13 Continue
C
C     Call getans to obtain answer (allows multiple answers per line)
C
      Call getans(str,form2,ans)
C
C     If getans is not used, the following two statements ask question
C
C       Write (6,form2)str
C       Read (5,form)ans
C
C     Check answer
C
      ialen=31
      ialen=itlen(ans)
      If (ialen.NE.0) Then
C
C     got an answer
C
C     find first non-blank character
C
      do 5,ifirst=1,ialen
      if (ans(ifirst:ifirst).ne.' ') goto 6
   5  continue
   6  continue
      ans(1:ialen)=ans(ifirst:ialen)
         If (ans(ifirst:ialen).EQ.'//') Then
            iaquest=-1
         Else
            iaquest=1
C
C           Move answer into AVAL
C
            aval(1:len(aval))=ans(1:len(aval))
            If (mode.LE.0)Call upshift(aval)
         End If
      Else
C
C        Didn't get an answer, if no default ask question again
C
         If (mode.EQ.0)Go To 13
      End If
      Return
      End
CS    USGS Function IIQUEST
C     Version: 1.0
C     Technical Contact: Richard W. Saltus
C     Release: not released
C
C+
C     Function IIQUEST
C
C     Program purpose:
C         This function asks a question which requires an integer as response.
C         If a default is available, the user may take it by simply pressing
C         return. If a non-integer response is given, the question is re-asked.
C         Use of the special string "//" allows the user to signal the main
C         program (usually used to flag the end of a list or desire to exit
C         a program section).
C
C     Instructions for use:
C         This function should be used to ask all questions requiring integral
C         response.
C
      INTEGER FUNCTION IIQUEST(QUEST,IVAL,FORM,MODE)
C-
C
C     Variables and parameters:
C
C    IIQUEST - Asks a question with an integer answer
C
C     ireturn = IIQUEST (quest,ival,form,mode)
C
C      ireturn =  -1 if '//' was given as response (user wants out)
C                  0 if no response (user took default)
C                  1 if user responded (returns response in aval)
C
C        quest =  Character string containing question to be asked
C                 (with no ? at the end, it is added by function)
C
C         ival =  integer variable to receive answer
C                 (used to pass default if one is available)
C
C         form =  Character string containing fortran format to be
C                 used to format the default contained in ival
C
C         mode =  Integer control parameter:
C
C            mode = 0, required response (no default allowed)
C            mode <>0, default allowed
C
C         Calls: ITLEN, GETANS
C^
C  *********************************************
      Character quest*(*),form*(*),rstr2*30
      Character*100 str,form2*10,ans*30,astr*30
      iiquest=0
      iqlen=itlen(quest)
C
C     Format default for insertion into question
C
      Write (rstr2,form)ival
      irlen=ideblank(rstr2)
      If (mode.NE.0) Then
C
C        Construct question with default in brackets
C
         str=quest(1:iqlen)//' ['//rstr2(1:irlen)//']?'
         islen=iqlen+irlen+4
      Else
C
C        No default, add '?' to question
C
         str=quest(1:iqlen)//'?'
         islen=iqlen+1
      End If
C
C     Make fortran format for printing of question
C
      Write (form2,105)islen
  105 Format ('(x,a',i3,',$)')
C
C     Repeats to here if question is re-asked
C
   13 Continue
C
C     call getans to obtain answer
C
      Call getans(str,form2,ans)
C
C     If GETANS is not used, the following two statements will ask question
C
C      Write (6,form2)str
C      Read (5,110)ans
  110 Format (a30)
C
C     Check answer
C
      ialen=ideblank(ans)
      If (ialen.NE.0) Then
C
C        Got an answer
C
         If (ans.EQ.'//') Then
            iiquest=-1
         Else
C
C           Convert answer to an integer
C
            iiquest=1
            Read (ans(1:ialen),120,err=25)ival
  120       Format (i11)
         End If
      Else
C
C        Didn't get an answer, if no default ask question again
C
         If (mode.EQ.0)Go To 13
      End If
      Return
C
C     Couldn't decode, give error and ask question again
C
   25 Continue
      Write (6,130)
  130 Format (' Please answer again, I expect a number.')
      Go To 13
      End
CS    USGS Function IRQUEST
C     Version: 1.0
C     Technical Contact: Richard W. Saltus
C     Release: not released
C
C+
C     Function IRQUEST
C
C     Program purpose:
C         This function asks a question requiring a real number response.
C         It allows a default answer (if the user simply presses return).
C         The question is re-asked if a non-numeric answer is supplied.
C         The special character sequence "//" can be answered to indicate
C         a special condition.
C
C     Instructions for use:
C         This function should be called to ask all questions requiring decimal
C         numbers as answers.
C
      INTEGER FUNCTION IRQUEST(QUEST,RVAL,FORM,MODE)
C-
C
C     Variables and parameters:
C
C     ireturn = IRQUEST (quest,rval,form,mode)
C
C      ireturn =  -1 if '//' was given as response (user wants out)
C                  0 if no response (user took default)
C                  1 if user responded (returns response in aval)
C
C        quest =  Character string containing question to be asked
C                 (with no ? at the end, it is added by function)
C
C         rval =  Real variable to receive answer
C                 (used to pass default if one is available)
C
C         form =  Character string containing fortran format to be
C                 used to format the default contained in rval
C
C         mode =  Integer control parameter:
C
C            mode = 0, required response (no default allowed)
C            mode <>0, default allowed
C
C         Calls: ITLEN, GETANS
C^
C  *********************************************
      Character quest*(*),form*(*),rstr2*30
      Character*100 str,form2*10,ans*30,astr*30
      irquest=0
      iqlen=itlen(quest)
C
C     Format default for inclusion in question
C
      Write (rstr2,form)rval
      irlen=ideblank(rstr2)
      If (mode.NE.0) Then
C
C     If default allowed, insert it in question
C
         str=quest(1:iqlen)//' ['//rstr2(1:irlen)//']?'
         islen=iqlen+irlen+4
      Else
C
C        No default, just add '?' to question
C
         str=quest(1:iqlen)//'?'
         islen=iqlen+1
      End If
C
C     Construct format for printing the question
C
      Write (form2,105)islen
  105 Format ('(x,a',i3,',$)')
C
C     Repeats to here if question is re-asked
C
   13 Continue
C
C     call getans to obtain answer
C
      Call getans(str,form2,ans)
C
C      If getans is not used, the following statements will ask question
C
C      Write (6,form2)str
C      Read (5,110)ans
  110 Format (a30)
C
C     Check answer
C
      ialen=ideblank(ans)
      If (ialen.NE.0) Then
C
C        Got an answer
C
         If (ans.EQ.'//') Then
            irquest=-1
         Else
C
C           Convert answer to real number
C
            irquest=1
            Read (ans(1:ialen),120,err=25)rval
  120       Format (f20.0)
         End If
      Else
C
C        Didn't get an answer, if no default re-ask question
C
         If (mode.EQ.0)Go To 13
      End If
      Return
C
C     Couldn't convert the answer to a real number
C
   25 Continue
      Write (6,130)
  130 Format (' Please answer again, I''m expecting a number.')
      Go To 13
      End
CS    USGS Subroutine GETANS
C     Version: 1.0
C     Technical Contact: Richard W. Saltus
C     Release: not released
C
C+
C     Subroutine GETANS
C
C     Program purpose:
C         This subroutine is called by IAQUEST, IIQUEST, and IRQUEST to
C         ask questions and get responses. It allows for buffering of
C         input, answers to multiple questions on a single line, echoing
C         of program dialog, or input of answers from a file.
C
C     GETANS - Reads next answer from saved command line,
C              prompts for new command line if old command line empty.
C              Answers in the command line are delimited by semi-colons.
C
C       GETANS recognizes the following special commands:
C
C              @filename - takes subsequent input from the file 'filename'
C              >filename - records questions and responses to 'filename'
C              >*        - echos questions and answers at terminal
C              <         - stops recording
C              <*        - stops echoing
C              !stuff!   - skips stuff between exclamation points
C
C     Instructions for use:
C         Intended for use by the IxQUEST subroutines only.
C
       SUBROUTINE GETANS(QUEST,QFORM,ANS)
C-
C
C     Variables and parameters:
C
C
C     Call GETANS (quest, qform, ans)
C
C          quest = character variable, question to be asked
C
C          qform = character variable, fortran format for question
C
C          ans   = character variable to receive answer
C
C     Called by IIQUEST, IAQUEST, IRQUEST
C
C     Calls IGETTOK
C
C     Commons used : /GETCOM/ nextc, ifile, isfile, command
C
C^
C
      Character*(*) quest,qform,ans
      Common /getcom/nextc,ifile,isfile,command
      Character*(80) command,tok,form*40
      Logical asked,typed
C
C     initialize token
C
    1 Continue
      tok=' '
      lentok=0
      ic=len(command)
      it=len(tok)
      asked=.false.
      typed=.false.
C
C     If nothing in command line, ask question
C
    5 Continue
      If ((nextc.EQ.0).OR.(nextc.GT.ic)) Then
         If (ifile.EQ.0) Then
C
C        ask question at terminal
C
            asked=.true.
            typed=.true.
            Write (6,qform)quest
            Read (5,100)command
  100       Format (a80)
         Else
C
C        read command from file
C
            asked=.true.
         Read (ifile,100,End =99,err=99)command
      End If
      nextc=1
      End If
C
C     get a token from the command line
C
   10 Continue
      lenread=igettok(command(nextc:ic),tok(lentok+1:it),ierr,itype)
      nextc=lenread+nextc
      If (ierr.GE.0) Then
C
C     got a token
C
         If (tok(lentok+1:lentok+1).EQ.';') Then
C
C     got end of token
C
            If (nextc.GE.ic)nextc=0
         Else If (tok(lentok+1:lentok+1).EQ.'!') Then
C
C     skip over stuff between !'s in command line
C
            iskip=index(command(nextc:ic),'!')
            If (iskip.EQ.0) Then
C
C     skip rest of record
C
               nextc=0
               Go To 5
            Else
C
C     skip past next !
C
               nextc=nextc+iskip
               Go To 5
            End If
         Else
C
C     didn't get a ';' or a '!' - append new tok to old tok (reduce multiple
C                                 blanks to a single blank between tokens)
C
            newlen=itlen(tok(lentok+1:it))
            If (lenread.GT.newlen) Then
               newlen=newlen+1
               Do 20 icnt=newlen+lentok+1,lentok+1,-1
   20          tok(icnt+1:icnt+1)=tok(icnt:icnt)
               tok(lentok+1:lentok+1)=' '
            End If
            lentok=lentok+newlen
            If (ierr.EQ.0) Then
C
C     hit end of command line
C
               nextc=0
            End If
C
C     keep reading command line
C
            Goto 10
         End If
      Else
C
C      didn't get a token (hit end of line)
C
         nextc=0
         If ((lentok.EQ.0).AND.(.NOT.asked))Goto 5
      End If
C
C      ready to return answer
C
      ans=' '
      If (lentok.GT.0) Then
         If (tok(1:1).EQ.'@') Then
C
C     open file for command reading
C
            If (ifile.NE.0)Close (ifile)
            Open (69,file=tok(2:lentok),form='formatted',readonly,
     &      status='old',err=98)
            ifile=69
            nextc=0
            Go To 1
         Else If (tok(1:1).EQ.'>') Then
            If (tok(2:2).EQ.'*') Then
C
C     set echo flag for command echoing at terminal
C
               iecho=1
            Else
C
C     Open recording file
C
               If (isfile.NE.0)Close (isfile)
               Open (70,file=tok(2:lentok),form='formatted',status=
     &         'new',
     &         err=97)
               isfile=70
               Go To 1
            End If
         Else If (tok(1:1).EQ.'<') Then
            If (tok(2:2).EQ.'*') Then
C
C      turn off command echoing
C
               iecho=0
            Else
C
C      close recording file
C
               Close (isfile)
               isfile=0
               Go To 1
            End If
         Else
C
C     pass answer back and quit
C
            ans=tok(1:lentok)
         End If
      End If
      If (isfile.NE.0) Then
C
C     record question and answer in recording file
C
         If (lentok.LE.0)tok(1:1)=' '
         ir=max(1,lentok)
         iq=itlen(quest)
         Write (form,103)iq,ir
  103    Format ('(x,a1,a',i2,',a1,x,a',i2,')')
         Write (isfile,form)'!',quest(1:iq),'!',tok(1:ir)
      End If
      If ((iecho.NE.0).AND.(.NOT.typed)) Then
C
C     Echo question and answer at terminal
C
         If (lentok.LE.0)tok(1:1)=' '
         ir=max(1,lentok)
         iq=itlen(quest)
         Write (form,104)iq,ir
  104    Format ('(x,a',i2,',x,a',i2,')')
         Write (6,form)quest(1:iq),tok(1:ir)
      End If
      Return
C
C     error on recording file open
C
   97 Continue
      If (lentok.GE.2) Then
         Write (form,105)ir-1
  105    Format ('(x,a35,a',i2,')')
         Write (6,form)'Unable to open the recording file: ',tok(2:ir)
      Else
         Write (6,106)
  106    Format (x,'No name specified for recording file.')
      End If
      Go To 1
C
C     error on command file open
C
   98 Continue
      If (lentok.GE.2) Then
         Write (form,110)ir-1
         Write (6,form)'Unable to open the command file: ',
     &   tok(2:ir)
  110    Format ('(x,a33,a',i2,')')
      Else
         Write (6,111)
  111    Format (x,'No name specified for command file.')
      End If
      Go To 1
C
C     hit end of command file
C
   99 Continue
      Close (ifile)
      ifile=0
      Go To 5
      End
CS    USGS Function IGETTOK
C     Version: 1.0
C     Technical Contact: Richard W. Saltus
C     Release: not released
C
C+
C     Function IGETTOK
C
C     Program purpose:
C             - Selects next alpha-numeric token, special symbol,
C               or quoted string from BUF.
C               Puts token in TOK.  Returns ierr & itype to describe
C               token.
C
C     Instructions for use:
C           LEN = IGETTOK(BUF,TOK,IERR,ITYPE)
C
      INTEGER FUNCTION IGETTOK(BUF,TOK,IERR,ITYPE)
C-
C
C     Variables and parameters:
C
C                LEN = Length of BUF read.
C
C                BUF = Character string to search for token
C
C                TOK = Token found (Character string)
C
C               IERR = 1 , got a token
C                      0 , got a token, hit end of BUF
C                     -1 , didn't get a token, hit end of BUF
C
C               ITYPE = 1 , got an alpha-numeric token
C                       0 , got a quoted token
C                      -1 , got a single symbol
C
C         Called by: Style, IxQUEST subroutines, user program
C
C             Calls: ICTYPE
C
C      Commons used: none
C-
C  **********************************************************************
      Character*(*) buf,tok
      lbuf=len(buf)
      lmax=len(tok)
      ltok=0
C
      Do 10 i=1,lbuf
      If (ictype(buf(i:i)).LT.0) Then
C
C     got special symbol (non alpha-numeric)
C
         If (ltok.GT.0) Then
C
C       already have a token, this must end it
C
            igettok=i-1
            itype=1
            ierr=1
            Return
         Else
C
C       don't have a token yet
C
            If (buf(i:i).EQ.' ') Then
C
C         got a blank, skip it
C
               Continue
            Else If (buf(i:i).EQ.'''') Then
C
C         got a quote (begin quoted token)
C
               itemp=i
    5          Continue
               iend=index(buf(itemp+1:lbuf),'''')
               If (iend.EQ.0) Then
C
C           didn't find another quote
C
                  tok=buf(i:lbuf)
                  igettok=lbuf
                  itype=0
                  ierr=0
                  Return
               Else
C
C           did find another quote
C
                  nloc=itemp+iend+1
                  If (buf(nloc:nloc).EQ.'''') Then
C
C             paired quotes within quotes, keep looking for end
C
                     itemp=nloc
                     Go To 5
                  Else
C
C           found end of quoted token
C
                     tok=buf(i:itemp+iend)
                     igettok=itemp+iend
                     itype=0
                     If (i+iend.EQ.lbuf) Then
                        ierr=0
                     Else
                        ierr=1
                     End If
                  End If
                  Return
               End If
            Else
C
C       special symbol is token
C
               tok(1:1)=buf(i:i)
               itype=-1
               ierr=1
               igettok=i
               Return
            End If
         End If
      Else
C
C     got alpha-numeric
C
         ltok=ltok+1
         tok(ltok:ltok)=buf(i:i)
      End If
C
   10 Continue
C
C     reached end of buffer, all alpha-numerics
C
      itype=1
      igettok=lbuf
      If (ltok.EQ.0) Then
C
C       all blanks (no token)
C
         ierr=-1
      Else
C
C       got token
C
         ierr=0
      End If
      Return
      End
C+
C     ICTYPE - decides if a character is alphabetic, numeric, or other
C
C     ireturn = ICTYPE (C)
C
C            C = Single character (character*1)
C
C      ireturn =  1 , alpha (a-z,A-Z)
C              =  0 , digit (0-9)
C              = -1 , other
C
C      Called by: IGETTOK
C
C        Calls: none
C
C      Common: none
C-
C  *********************************************************************
      Integer Function ictype(c)
      Character*1 c,digits*10,abc*52
C
      digits='0123456789'
      abc='abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'
C
      If (index(abc,c).GT.0) Then
         ictype=1
         Else If (index(digits,c).GT.0) Then
         ictype=0
         Else
         ictype=-1
         End If
      Return
      End
C+
C    IDEBLANK- removes all blanks and returns length
C
C    ireturn = IDEBLANK (string)
C
C       ireturn = length of the string without blanks
C        string = character string to be de-blanked
C
C-
C  *********************************************
      Integer Function ideblank(string)
      Character*256 string*(*),temp
      j=1
      temp=' '
      itemp=len(string)
      Do 10 i=1,itemp
      If (string(i:i).EQ.' ')Go To 10
      temp(j:j)=string(i:i)
      j=j+1
   10 Continue
      string=temp
      ideblank=j-1
      Return
      End
CS    USGS Function ITLEN
C     Version: 1.0
C     Technical Contact: Richard W. Saltus
C     Release: not released
C
C+
C     Function ITLEN
C
C     Program purpose:
C         This function returns the length of a character string without
C         trailing blanks.
C
C     Instructions for use:
C         Use this function to find out the position of the last non-blank
C         character in a string.
C
      INTEGER FUNCTION ITLEN(STRING)
C-
C
C     Variables and parameters:
C
C     ireturn = ITLEN (string)
C
C        ireturn = the length of the string without trailing blanks
C         string = string to have trailing blanks removed from
C
C^
C  *********************************************
      Character string*(*)
      i=len(string)
   10 Continue
      If (string(i:i).NE.' ')Go To 15
      i=i-1
      If (i.LE.0)Go To 15
      Go To 10
   15 Continue
      itlen=i
      Return
      End
C+
C     UPSHIFT - Converts lowercase to uppercase.
C               All non-lowercase characters unchanged.
C
C     CALL UPSHIFT(A)
C
C             A = A character string of any length
C
C-
      SUBROUTINE UPSHIFT(A)
      CHARACTER*(*) A,UP*(26),DOWN*(26)
      UP='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
      DOWN='abcdefghijklmnopqrstuvwxyz'
      ILEN=LEN(A)
      DO 10 I=1,ILEN
        INUM=INDEX(DOWN,A(I:I))
        IF (INUM.NE.0) A(I:I)=UP(INUM:INUM)
  10      CONTINUE
      RETURN
      END
C  *****************************************************
C  INTEGER FUNCTION IRWPR  (John Cady)
C  *****************************************************
c   Function to control informational output.  
c   1,2,3,...11
c   21,31,41,...91
c   101,201,...

      Integer Function irwpr(ir)
      integer*2 ir
      irwpr=0
      if((ir.le.11).or.(imod(ir,10).eq.1).or.(imod(ir,100).eq.1))
     &  irwpr=1
      return
      end