

      include 'flib.fi'
      include 'fgraph.fi'
      implicit integer*2 (a-z)
      include 'fgraph.fd'
      integer*4 dum1,bgd1
      character*8 buff,passwrd
      data bgd1/1/,fgd1/14/,passwrd/'sB8yr0hF'/
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call getarg(1,buff,length)
      if(buff.ne.passwrd) then
        print *,'program can only be run from program GEOCON'
        stop
      endif
      call clearscreen($GCLEARSCREEN)
c*****WRITE MAIN FUNCTION KEY MENU
      call funkey
c*****CHECK FOR FUNCTION KEY ACTIVATION
10    call funact
      go to 10
      stop
      end
c***************************************
      subroutine funkey
      implicit integer*2 (a-z)
      parameter(num=7)
      include 'fgraph.fd'
      record/rccoord/curpos
      character* 52 key(num)
      integer*4 dum1,bgd,bgd1,bgd2
      data bgd/15/,bgd2/4/,fgd/0/
      data key/'         PROGRAM  P R O J E C T',
     & '         transforms lat/long to x/y coordinates ',
     & ' ',
     & '         F1  = INTERACTIVE INPUT/EDITING',
     & '         F2  = COMMAND FILE INPUT',
     & '         F3  = RUN PROJECTION PROGRAM',
     & '         ESC = QUIT PROGRAM'/

      bgd1= getbkcolor()
      fgd1=gettextcolor()
      dum1= setbkcolor(bgd)
      dum2=settextcolor(fgd)

      row=1
      do 10 i=1,num-1
      call settextposition(row,4,curpos)
      call outtext(key(i))
      row=row+2
10    continue
      dum1= setbkcolor(bgd2)
      dum2=settextcolor(bgd)
      call settextposition(25,4,curpos)
      call outtext(key(num))

      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)

      return
      end

c***************************************
      subroutine funact
      implicit integer*2 (a-z)
      include 'fgraph.fd'
      integer*4 ierr,ic,ii,bgd1,dum1
      data bgd1/1/,fgd1/14/
      data ic/50/,ii/10/
      data esc/27/

c*****GET SCAN CODE FOR FUNCTION KEYS
      ch=0
      call getchr(ch)
      if(ch.gt.58.and.ch.lt.69) then
      ich = ch-58
      go to (20,30,40) ich
      else if(ch.eq.esc) then
      go to 55
      endif
      go to 60

c*****HELP FILE
c10    call page('set')
c      call helpp
c      go to 50

c*****INTERACTIVE INPUT
20    call page('set')
      call edit(ierr)
      if(ierr.ne.0) pause 'press ENTER to return to menu'
      dum = setvideomode($DEFAULTMODE)
      call clearscreen($GCLEARSCREEN)
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call funkey
      go to 60

c*****USE COMMAND FILE
30    call page('set')
      call input(ic,ic,ierr)
      if(ierr.ne.0) pause 'press ENTER to return to menu'
      go to 50

c*****RUN 
40    call page('set')
      call input(ii,ii,ierr)
      if(ierr.ne.0) pause 'press ENTER to return to menu'

50    call page('res')
      go to 60

c*****QUIT PROGRAM
55    stop

60    return
      end
c***************************************
      subroutine getinp
      include 'flib.fd'
      record/regs$info/regs
      integer*2 ich,icnt
      character*(*) str
      character*1 cr
      data cr/#0d/
      entry getchr(ich)
c*****CHECK FOR KEYBOARD INPUT
c*****RETURNS IF NO KEYBOARD ENTRY
      regs.bregs.ah=11
      call intdosqq(regs,regs)
      if(regs.bregs.al.eq.0) return
      regs.bregs.ah=8
      go to 5
c*****- THIS ENTRY CLEARS BUFFER AND WAITS FOR KEYBOARD ENTRY 
c*****NO ECHO
      entry getch(ich)
      regs.bregs.ah=12
      regs.bregs.al=8
5     call intdosqq(regs,regs)
      if(regs.bregs.al.eq.0) then
c*****EXTENDED KEYBOARD INPUT(E.G., FUNCTION KEYS)
      call intdosqq(regs,regs)
      ich=regs.bregs.al
      else
c*****ASCII CHARACTER INPUT
      ich=regs.bregs.al
      endif
      return
      entry getstr(str,icnt)
c*****CHECK FOR KEYBOARD INPUT
      regs.bregs.ah=11
      call intdosqq(regs,regs)
      if(regs.bregs.al.eq.0) return
c*****GET STRING OF CHARACTERS 
      icnt=0
      do 10 while(str(icnt:icnt).ne.cr)
        regs.bregs.ah=8
        call intdosqq(regs,regs)
        if(regs.bregs.al.eq.0) then
c*****EXTENDED KEYBOARD INPUT(E.G., ARROW KEYS)
          call intdosqq(regs,regs)
          ich=regs.bregs.al
c*****UP ARROW - RETURN
          if(ich.eq.72) then
            icnt = -72
            return
          endif
c*****DOWN ARROW - RETURN
          if(ich.eq.80) then
            icnt = -80
            return
          endif
c*****LEFT ARROW - ECHO A NON-DESTRUCTIVE BACKSPACE
          if(ich.eq.75) then
            icnt=icnt-1
            if(icnt.lt.0) then
               icnt=-98
               return
            endif
            regs.bregs.dl=char(8)
            regs.bregs.ah=2
            call intdosqq(regs,regs)
          endif
c*****RIGHT ARROW - ECHO THE CHARACTER PREVIOUSLY THERE
          if(ich.eq.77) then
            icnt=icnt+1
            regs.bregs.dl=str(icnt:icnt)
            regs.bregs.ah=2
            call intdosqq(regs,regs)
          endif
c*****PAGE DOWN
          if(ich.eq.81) then
            icnt = -81
            return
          endif
c*****PAGE UP
          if(ich.eq.73) then
            icnt = -73
            return
          endif
        else
          ich=regs.bregs.al
c*****8=BACKSPACE;13=CARRIAGE RETURN;27=ESC
          if(ich.eq.13) then
            if(icnt.eq.0) icnt = -13
            return
          endif
          if(ich.eq.27) go to 20
          if(ich.eq.8) then
            icnt=icnt-1
            if(icnt.lt.0) then
               icnt=-98
               return
            endif
            regs.bregs.dl=char(8)
          else
            icnt=icnt+1
            str(icnt:icnt)=char(ich)
            regs.bregs.dl=str(icnt:icnt)
          endif
          regs.bregs.ah=2
          call intdosqq(regs,regs)
        endif
10    continue
20    if(icnt.eq.0) icnt=-99
      return
      end
c***************************************
      subroutine page(set)
      implicit integer*2 (a-z)
      include 'fgraph.fd'
      character*3 set
      if(set.eq.'set') then
      oldapage=getactivepage()
      oldvpage=getvisualpage()
      newapage=setactivepage(oldapage+1)
      newvpage=setvisualpage(oldvpage+1)
      call clearscreen($GCLEARSCREEN)
      else
      oldapage=setactivepage(oldapage)
      oldvpage=setvisualpage(oldvpage)
      endif
      return
      end
c***************************************
      subroutine edit(ierr)
      implicit integer*2 (a-z)
      parameter(ninp=25,numt=50)
      include 'fgraph.fd'
      record/rccoord/curpos
      integer*4 dum1,bgd,bgd1,bgd2,is,ie,ierr
      logical quest
      character*80 tinp(numt)
      character*80 inp(ninp)
      character*80 string
      character*6 tindex(numt)
      character*1 nul,resp
      logical array
      common/lset/setrow,setcol,linptr,line,inum,inp
      common/lout/tindex,ix,tinp,array
      data bgd/4/fgd/15/,bgd1/1/,fgd1/14/,bgd2/2/,nul/#00/
      ierr = 0
      quest=.false.

* check for mouse, resetting it in the process
5     m1 = 0
      call mouse(m1, m2, m3, m4)

* Quit if mouse wasn't found
      if (m1.eq.0)  then
        print *,  ' Mouse not found'
        ierr=1
        return
      endif

* Initialize menu pointer to first option
      linptr = 1

c*****READ INPUT 23 LINES AT A TIME
      is = 1
      ie=23
c*****DELAY AFTER MOUSE BUTTON PRESSED
c*****SEEMS TO PREVENT ACCIDENTAL PAGE FLIPPING
66    call sleep(.5)
      call input(is,ie,ierr)
      if(ierr.ne.0) go to 300
      nlines=ie
      if(is.eq.1) go to 77
      if(is.eq.2) go to 777
      go to 88
77    write(string,'(a)') 'press ESC to exit'
      go to 9
777   write(string,'(2a)') 'press ',
     & 'PAGE UP for previous page or ESC to exit'
      go to 9
88    write(string,'(2a)') 'press MOUSE or ENTER to return',
     & ' or ESC to exit'
9     dum1= setbkcolor(bgd1)
      call clearscreen($GCLEARSCREEN)
      dum1= setbkcolor(bgd)
      dum2=settextcolor(fgd)
      call settextposition(25,1,curpos)
      call outtext(string(1:77))
      string=' '
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)

c*****RESET MOUSE
      m1 = 0
      call mouse(m1, m2, m3, m4)

* Initialize count of accumulated vertical mouse motion
      motion = 0

* Set flag to update menu first time
      wflag = 1

* Main loop starts here
   10 continue

* Update the menu only when necessary
      if (wflag.eq.1) then
          wflag = 0

        line=0
        do 20 inum = 1,ie
        line=line+1
        call outp
20      continue
        call settextposition(setrow,setcol,curpos)

* End of updating the menu
      end if

c*****CHECK ON KEYBOARD INPUT
      cnt=0
      inum=linptr
      call getstr(inp(inum)(setcol:),cnt)


      if(cnt.ne.0) then
c*****CHECK FOR ENTER KEY AS FIRST CHARACTER
       if(cnt.eq.-13) go to 40
c*****CNT = -99 MEANS ESC AS FIRST TYPED CHARACTER
       if(cnt.eq.-99) go to 999
c*****CNT = -81 MEANS PAGE DOWN(NEXT PAGE)
c       if(cnt.eq.-81.and.is.eq.1) then
c          is = is + 1
c          linptr = 1
c          go to 66
c       endif
c*****CNT = -73 MEANS PAGE UP(PREVIOUS PAGE)
c       if(cnt.eq.-73.and.is.eq.2) then
c         is = is -1
c         linptr = 1
c         go to 66
c       endif
c*****CNT = -98 MEANS CURSOR WAS MOVED TO = SIGN OR LEFT OF IT
       if(cnt.eq.-98) go to 30
c*****CNT = -72 MEANS UP ARROW
       if(cnt.eq.-72) then
         if (linptr.gt.1) then
           linptr = linptr - 1
           wflag = 1
         endif
         go to 10
       endif
c*****CNT = -80 MEANS DOWN ARROW
       if(cnt.eq.-80) then
         if (linptr.lt.nlines) then
           linptr = linptr + 1
           wflag = 1
         endif
         go to 10
       endif
c*****CHECK FOR COMMENT OR QUESTION LINE 
       if(inp(inum)(1:1).eq.'#'.or.inp(inum)(1:1).eq.'?'
     & .or.inp(inum)(1:1).eq.nul) go to 30
       line=linptr
       call outp
       call settextposition(setrow,setcol,curpos)
       cnt=0
         ix=ix+1
         tinp(ix)=inp(inum)(setcol:)
         tindex(ix)=inp(inum)(1:6)
       call output('n',ierr)
       if(ierr.ne.0) return
      endif


* Accumulate vertical mouse motion counts
30    m1 = 11
      call mouse(m1, m2, m3, m4)
      motion = motion + m4

* Move up the menu if enough mouse motion
      if (motion.lt.-17) then
          motion = 0
          if (linptr.gt.1) then
              linptr = linptr - 1
              wflag = 1
          end if
      end if

* Move down the menu if enough mouse motion
      if (motion.gt.17) then
          motion = 0
          IF (linptr.lt.nlines) then
              linptr = linptr + 1
              wflag = 1
          end if
      end if

      m1=3
      m2=0
      call mouse(m1, m2, m3, m4)
      if(m2.eq.0) go to 10

40     if(inp(inum)(1:1).eq.'?') then
         isave = is 
         lsave = linptr
         read(inp(inum)(2:3),'(i2)')  is
         is = is + 2
         linptr = 1
         quest=.true.
         go to 66
       endif

      if(quest) then
        quest=.false.
        is = isave
        linptr = lsave
        go to 66
      endif

      go to 10

999   dum1= setbkcolor(bgd2)
      dum2=settextcolor(fgd)
      string=' '

      call settextposition(25,1,curpos)
      write(string,'(a)')'WANT TO SAVE CHANGES TO A DISK FILE ? [y]'
      call outtext(string(1:77))
      call settextposition(25,42,curpos)

      read(*,'(a)') resp
      if(resp.ne.'n'.and.resp.ne.'N') then
c*****SAVE 
          call output('y',ierr)
      endif

300   dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      return
      end
c***************************************
      subroutine sleep(sec)
      integer*2 ihr,imin,isec,i100th
      call gettim(ihr,imin,isec,i100th)
      t1 = ihr*3600. + imin*60. +  isec + i100th/100. 
10    call gettim(ihr,imin,isec,i100th)
      t2 = ihr*3600. + imin*60. +  isec + i100th/100.
      if((t2-t1).lt.sec) go to 10
      return
      end
c***************************************
      subroutine outp
      implicit integer*2 (a-z)
      parameter(ninp=25)
      include 'fgraph.fd'
      integer*4 dum1,bgd,bgd1
      character*80 inp(ninp)
      common/lset/setrow,setcol,linptr,line,inum,inp
      data bgd/7/fgd/0/,bgd1/1/,fgd1/14/

* Write menu, highlighted if selected
      if (linptr.eq.line) then
      dum1= setbkcolor(bgd)
      dum2=settextcolor(fgd)
      else
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      end if
      call placel
      return
      end
c***************************************
      subroutine placel
      implicit integer*2(a-z)
      include 'fgraph.fd'
      record/rccoord/curpos
      parameter(ninp=25)
      character*80 inp(ninp)
      common/lset/setrow,setcol,linptr,line,inum,inp
      character*3 str
c*****STR CONTAINS HEX CODES FOR =  ? and NUL
      data str(1:1)/#3d/,str(2:2)/#3f/,str(3:3)/#00/
      call settextposition(line,1,curpos)
      call outtext(inp(inum))
      if(linptr.eq.line) then
      setrow= line
      setcol = scan(inp(inum),str) + 1
      endif
      return
      end
c***************************************
      subroutine output(resp,ierr)
      parameter(numt=50)
      include 'fgraph.fd'
      record/rccoord/curpos
      character*1 resp
      character*80 tinp(numt)
      integer*2 ix
      character*6 tindex(numt)
      integer*4 dum1,bgd1
      logical array
      common/lout/tindex,ix,tinp,array
c
c     namelist output
c
      character str*80,eq*4
      character*40 sfile
      logical save
      data bgd1/1/,fgd1/14/,jcmd/9/,eq/' = '/
c
c
      ierr=0

      if(resp.eq.'y') then
 
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call clearscreen($GCLEARSCREEN)

c*****SAVE
        if(ix.eq.0) then
          call settextposition(10,1,curpos)
          call outtext('NO VALUES WERE INPUT')
          call settextposition(11,1,curpos)
          ierr=1
          return
        endif

        call settextposition(10,1,curpos)
        write(*,'(a\)') ' ENTER FILE NAME FOR SAVING VALUES: '
        read(*,'(a)') sfile
        open(unit=jcmd,file=sfile,form='formatted',
     1  status='unknown',err=992,iostat=icheck)
        save = .true.
      else
c*****DON'T SAVE
        save = .false.
      endif
      go to 50

c*****FILE ERRORS
992   write(str,'(a,i5,2a)') 'error no. ',icheck,
     & ' on opening file: ',sfile
      go to 995
993   write(str,'(a,i5,2a)') 'error no. ',icheck,
     & ' on writing file: ',sfile
      close (jcmd)
995   call settextposition(11,1,curpos)
      call outtext(str(1:75))
      sfile=' '
      call settextposition(12,1,curpos)
      ierr=1
      return

c*****PUT VALUES IN A DISK FILE OR ARRAY TINP
c*****TO BE READ INTO MEMORY BY SUBROUTINE NAMEPR
c*****FIRST CHECK FOR DUPLICATE LINE CHANGES AND USE ONLY LAST ONE
50    it = 0
      do 52 i=ix,1,-1
      do 51 j=i-1,1,-1
      if(tindex(i).eq.tindex(j)) tindex(j)=' '
51    continue
52    continue
      if(save) then
        write(jcmd,'(a)',err=993,iostat=icheck) ' &value'
      endif
     
      do 100 i=1,ix
      if(tindex(i).eq.' ') go to 100
c******VALUES ON ONE LINE
       if(save) then
         write(jcmd,'(1x,2a,a58)',err=993,iostat=icheck)
     &        tindex(i),eq,tinp(i)
       else
         it = it + 1
         write(str,'(a)') tinp(i)(1:70)
         write(tinp(it),'(3a)') tindex(i),eq,str(1:70)
c         print *,'output ',it,i,tindex(i),' gap ',tinp(it)
c         pause
       endif
100   continue
      if(save) then
        write(jcmd,'(a)',err=993,iostat=icheck) ' &'
      else
         it = it + 1
         tinp(it) = ' &'
      endif
      if(save) then
        rewind jcmd
        call namepr(jcmd,ierr)
        close(jcmd)
      else
        call namepr(-99,ierr)
      endif
      return
      end
c************************************************************************
      subroutine inptxt(ie)
      character*80 inp(25)
      integer*2 setrow,setcol,line,linptr,inum
      common/lset/setrow,setcol,linptr,line,inum,inp
      character ifile*40,ofile*40,ifmt*40,ofmt*40,dcon*3
      common/cparm/ifile,ofile,ifmt,ofmt,dcon
      common/rparm/baslat(3),cm(3),iproj,phi1,phi2,sca,s1,s2,
     & ianom,janom,ieast,irec,jrec
      character*1 ap,nul
      data ap/''''/,nul/#00/,iptr/0/

1     ii=iptr+1
      write(inp(ii),'(4a)') 'ifile (INPUT FILE)=',ap,
     & ifile,ap
      ii=ii+1
      write(inp(ii),'(4a)') 'ofile (OUTPUT FILE)=',ap,
     & ofile,ap
      ii=ii+1
      write(inp(ii),'(2a,t60,a,i5)') 'iproj (PROJECTION',
     & ' NUMBER)','=',iproj
      ii=ii+1
      write(inp(ii),'(2a)')nul, 
     & '       iproj MUST BE ONE OF THE FOLLOWING NUMBERS'
      ii=ii+1
      write(inp(ii),'(2a)')nul,'       1  American Polyconic'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       2  ellipsoidal transverse',
     & ' mercator'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'          no output beyond 3 degrees',
     & ' from the "cm"'
      ii=ii+1
      write(inp(ii),'(2a)')nul,'       3  mercator'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       4  lambert - default parallels',
     & ' 33 and 45'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       5  albers US  - parallels 29.5',
     & ' and 45.5'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       6  albers Alaska  - parallels',
     & ' 55 and 65'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       7  albers Hawaii  - parallels',
     & ' 8 and 18'
      ii=ii+1
      write(inp(ii),'(2a)')nul,'       8  polar stereographic'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'       9  spherical transverse',
     & ' mercator, zero distortion meridians'
      ii=ii+1
      write(inp(ii),'(3a)')nul,'          are approx. 22 degrees from',
     & ' "cm"'
      ii=ii+1
      write(inp(ii),'(a)') nul
      ii=ii+1
      write(inp(ii),'(2a,t60,a,f6.0)') 'phi1   (LOWER ',
     & ' PARALLEL FOR LAMBERT PROJECTION)','=',phi1
      ii=ii+1
      write(inp(ii),'(2a,t60,a,f6.0)') 'phi2   (UPPER ',
     & ' PARALLEL FOR LAMBERT PROJECTION)','=',phi2
      ii=ii+1
      write(inp(ii),'(2a,t60,a,3f6.0)') 'cm     (CENTRAL MERIDIAN',
     & ' (DEG,MIN & SEC))','=',cm
      ii=ii+1
      write(inp(ii),'(2a,t60,a,3f6.0)') 'baslat (BASE LATITUDE',
     & ' (DEG,MIN & SEC))','=',baslat
      ii=ii+1
      write(inp(ii),'(2a,t60,4a)') 'dcon   (INPUT DATA UNITS',
     & ' (DEG,MIN OR SEC))','=',ap,dcon,ap
      ii=ii+1
      write(inp(ii),'(2a,t60,a,i5)') 'ieast  (SET NON-ZERO FOR',
     & ' EAST LONGTITUDES)','=',ieast
      ii=ii+1
      write(inp(ii),'(2a,t60,a,f9.7)') 'sca    (SCALING FACTOR FOR',
     & ' OUTPUT COORDINATES)','=',sca
      ii=ii+1
      write(inp(ii),'(3a)')nul,'      (.001-KILOMETERS,1-METERS',
     & ',39.370079-INCHES)' 
      ie=ii
      return
      end
c      write(inp(ii),'(a)')nul 
c      ii=ii+1
c      write(inp(ii),'(2a)')nul, 
c     & '        ADDITIONAL PARAMETERS ON THE NEXT PAGE'
c      ie=ii
c      return
c2     ii = iptr + 1
c      write(inp(ii),'(2a,t60,a,i5)') 'irec  (INPUT RECORD',
c     & ' TYPE)','=',irec
c      ii=ii+1
c      write(inp(ii),'(2a,t60,a,i5)') 'jrec  (OUTPUT RECORD',
c     & ' TYPE)','=',jrec
c      ii=ii+1
c      write(inp(ii),'(a)')nul 
c      ii=ii+1
c      write(inp(ii),'(2a)')nul, 
c     & '   irec AND jrec MUST BE ONE OF THE FOLLOWING NUMBERS'
c      ii=ii+1
c      write(inp(ii),'(2a)')nul, 
c     & '   1 BINARY XYZ(LON,LAT,Z)'
c      ii=ii+1
c      write(inp(ii),'(2a)')nul, 
c     & '   2 BINARY POST(ID,LON,LAT,Z(1-6))'
c      ii=ii+1
c      write(inp(ii),'(3a)')nul, 
c     & '   3 FORMATTED XYZ(LON,LAT,Z)'
c      ii=ii+1
c      write(inp(ii),'(2a)')nul, 
c     & '   4 FORMATTED POST(ID,LON,LAT, Z(1-ianom))'
c      ii=ii+1
c      write(inp(ii),'(3a)')nul, 
c     & '   5 FORMATTED CARD IMAGE(ID,LAT DEG,LAT MIN,LON DEG,LON MIN',
c     & 'Z(1-ianom))'
c      ii=ii+1
c      write(inp(ii),'(a)')nul 
c      ii=ii+1
c      write(inp(ii),'(2a,t60,a,i5)') 'ianom (NUMBER OF Z VALUES',
c     & ' TO BE READ FROM FORMATTED FILE)','=',ianom
c      ii=ii+1
c      write(inp(ii),'(2a,t60,a,i5)') 'janom (NUMBER OF ONE Z',
c     & ' VALUE FOR OUTPUT IN XYZ RECORDS)','=',janom
c      ii=ii+1
c***********************************************************************
      subroutine fcheck(fname,icheck,ierr)
      character*(*) fname
      character*1 resp
      logical exists
      inquire(file=fname,exist=exists)
        if(.not.exists) then
          print *,'can''t find file ',fname
          fname=' '
          write(*,'(a\)') ' TRY AGAIN ? [y]: '
          read(*,'(a)') resp
          if(resp.eq.'n'.or.resp.eq.'N') then
            ierr=1
            return
          else
            ierr=0
            return
          endif
        endif
      print *,'error no. ',icheck,' with file: ',fname
      fname=' '
      ierr=1
      return
      end
c***********************************************************************
      subroutine input(is,ie,ierr)
c
	double precision d2r,dp1,dp2
	character ifile*40,ofile*40,ifmt*40,ofmt*40,
     1 dcon*3,cf*50
      common/cparm/ifile,ofile,ifmt,ofmt,dcon
      common/rparm/baslat(3),cm(3),iproj,phi1,phi2,sca,s1,s2,
     & ianom,janom,ieast,irec,jrec
       logical first
       character*1 ifmtv
	data icmd/9/,first/.true./
	d2r=3.14159265d0/180.d0
        ierr = 0
        if(is.eq.50.or.first) then
        ifile=' '
        ofile=' '
        ifmt= ' '
        ofmt= ' '
        dcon='deg'
        ieast=0
        sca=.001
        s1=0.
        s2=0.
        iproj=0
        baslat(1)=999.
        baslat(2)=0.
        baslat(3)=0.
        cm(1)=999.
        cm(2)=0.
        cm(3)=0.
        phi1=33.
        phi2=45.
        endif
        first=.false.
        if(is.eq.10) go to 44
        if(is.eq.50) go to 1
        call inptxt(ie)
        return

1     write(*,'(a\)') ' ENTER COMMAND FILE NAME: '
      read(*,'(a)') cf
      open(unit=icmd,file=cf,form='formatted',
     1 status='old',err=2,iostat=icheck)
      call namepr(icmd,ierr)
      close (icmd)
      return
2     call fcheck(cf,icheck,ierr)
      if(ierr.eq.0) go to 1
      if(ierr.ne.0) then
        close (icmd)
        return
      endif

44     if(iproj.lt.1.or.iproj.gt.9) then
         print *,'projection number ',iproj,' must be 1 - 9'
         ierr = 1
         return
       endif

       if(baslat(1).eq.999..or.cm(1).eq.999.) then
         print *,'baslat and/or cm must be specified'
         ierr = 1
         return
       endif

       if(ifile.ne.' ') go to 40
411    print  41
41	format(' enter input file name:'$)
	read(*,'(a)') ifile
40     call opnsta(10,ifile,ifmtv,ierr,*411)
       if(ierr.ne.0) return

       if(ofile.ne.' ') go to 42
412    print  43
43	format(' enter output file name:'$)
	read(*,'(a)') ofile
42     if(ifmtv.eq.' ') then
         open(unit=11,file=ofile,form='unformatted',
     1        status='unknown',err=61,iostat=icheck)
       else
	  open(unit=11,file=ofile,form='formatted',
     1        status='unknown',err=61,iostat=icheck)
       endif
       go to 602
61     call fcheck(ofile,icheck,ierr)
      if(ierr.eq.0) go to 412
      if(ierr.ne.0) then
        close (11)
        return
      endif

602    a=-1.
	if(ieast.ne.0) a=1.
	assign 51 to icon
	if(irec.eq.5) go to 30
	cdeg=1.
	if(dcon.eq.'min') cdeg=1./60.
	if(dcon.eq.'sec') cdeg=1./3600.
	if(cdeg.ne.1.0) assign 50 to icon
30	continue
c

       if(iproj.ge.5 .and. iproj.le.7) call setalb(iproj)
	dp1=dble(phi1)*d2r
	dp2=dble(phi2)*d2r
	if(iproj.eq.4) call setlam(dp1,dp2)
	yb=abs(baslat(1))+baslat(2)*1.6666667e-2+baslat(3)*2.77777e-4
       yb=sign(yb,baslat(1))
	cmd=abs(cm(1))+cm(2)*1.6666667e-2+cm(3)*2.77777e-4
	cmd=sign(cmd,a)
	call prjctl(yb,cmd,xc,yc,cmd,sca,iproj)
	it=0
	ic=0
c
9      if(ifmtv.eq.' ') then
         read(10,end=10,err=70,iostat=icheck)xd,yd,z
       else
         read(10,*,end=10,err=70,iostat=icheck) xd,yd,z
       endif
13	it=it+1
	xd=sign(xd,a)
	go to icon,(50,51)
50	xd=xd*cdeg
	yd=yd*cdeg
51	if(abs(yd).gt.90.0) go to 9
	call prjctl(yd,xd,x,y,cmd,sca,iproj)
	if(x.lt.-1.e15) go to 9
	y=y-yc
       if(ifmtv.eq.' ') then
         write(11)x,y,z
       else
         write(11,*)x,y,z
       endif
 	ic=ic+1
	go to 9
10	print  11,ic,it
11	format(i7,' stations output from',i7,' input')
	close(10)
	close(11)
       print *,' '
       pause ' press ENTER to return to menu'
	return
70     print*,'error no. ',icheck,' reading input file'
	close(10)
       ierr = 1
       return
	end
c***********************************************************************
      subroutine opnsta(ista,ifile2,ifmtv,ierr,*)
      character*(*) ifile2,ifmtv
      character*1 resp
      logical exists,opn
      ierr=0
      inquire(file=ifile2,exist=exists)
        if(.not.exists) then
          print *,'can''t find file ',ifile2
          ifile2=' '
          write(*,'(a\)') ' TRY AGAIN ? [y]: '
          read(*,'(a)') resp
          if(resp.eq.'n'.or.resp.eq.'N') then
            ierr=1
            return 
          else
            return 1
          endif
        endif
        inquire(unit=ista,opened=opn)
          if(opn) close(ista)
        open(unit=ista,file=ifile2,
     &  status='old',err=442,iostat=icheck)
        read(ista,*,err=442,end=442,iostat=icheck) x,y,z
        rewind ista
        ifmtv(1:1) = '*'
        return
442     close(ista)
        open(unit=ista,file=ifile2,form='unformatted',
     &  status='old',err=443,iostat=icheck)
        read(ista,err=444,end=444,iostat=icheck) x,y,z
        nword = lenrec(ista,'u')
        if(nword.ne.3.and.nword.ne.-1) go to 444
        ifmtv = ' '
        return
443    print *,'error no. ',icheck,' with file: ',ifile2
       go to 445
444    print *,'file is not an xyz file'
445    ifile2=' '
       close(ista)
       ierr = 1
       return 
       end
c***********************************************************************
	function lenrec( ista,rtype )
c  brute force recovery of record length
       parameter(nwork=50)
	real irec(nwork)
       character*1 rtype

	istep = 10
	rewind ista

	do 5 max = istep, nwork, istep
         if(rtype.eq.'u') then
           read( ista, err=10 ) ( irec(i), i=1, max )
         else
	    read( ista,*, err=10 ) ( irec(i), i=1, max )
         endif
	  rewind ista
5       continue
	lenrec = -1
	go to 99

10	rewind ista
	do 30 j = max, max - istep, -1
         if(rtype.eq.'u') then
	    read( ista, err=20 ) ( irec(i), i=1, j )
         else
	    read( ista,*, err=20 ) ( irec(i), i=1, j )
         endif
	  lenrec=j
	  go to 99
20	  rewind ista
30      continue

99	rewind ista
	return
	end
c***********************************************************************
	subroutine prjctl(ylat,xlon,x,y,cm,sfac,iprojt)
c  call projection routines
	double precision yl,xl,xp,yp,degr
	data degr/.0174532925199433d0/
	yl=dble(ylat)*degr
	xl=dble(xlon-cm)*degr
	go to (1,2,3,4,5,5,5,8,9),iprojt
1	call poly(yl,xl,xp,yp)
	go to 20
2	call utmfwd(yl,xl,xp,yp)
	go to 20
3	call merctr(yl,xl,xp,yp)
	go to 20
4	call lambert(yl,xl,xp,yp)
	go to 20
5	call albers(yl,xl,xp,yp)
	go to 20
8	call polars(yl,xl,xp,yp)
	go to 20
9	call transm(yl,xl,xp,yp)
20	x=sngl(xp)*sfac
	y=sngl(yp)*sfac
	return
	end
c***********************************************************************
       subroutine poly(phi,dlamb,x,y)
       double precision phi,dlamb,xc,x,y,a,b,t,q,phi2,c1,c2
       a(xc)=
     1   6.378206402718907d 06 +xc*(
     1  -3.167517353503576d 06 +xc*(
     1   2.478805037574243d 05 +xc*(
     1  -3.530710396439220d 03 +xc*(
     1  -6.565371848240127d 02 +xc*(
     1   6.822539551727124d 01 +xc*(
     1  -2.888860980506611d 00 ))))))
       b(xc)=
     1   3.189103200618349d 06 +xc*(
     1  -2.115275857345996d 06 +xc*(
     1   4.144758431728325d 05 +xc*(
     1  -3.625295427368928d 04 +xc*(
     1   1.322429746943889d 03 +xc*(
     1   4.427183005616853d 01 +xc*(
     1  -8.630738701658902d 00 +xc*(
     1   4.279183401413811d-01 )))))))
       q(xc)=
     1   6.335034386662446d 06 +xc*(
     1   2.144094496614083d 04 +xc*(
     1  -4.182226973512467d 03 +xc*(
     1   3.609995316780635d 02 +xc*(
     1  -1.346978283534684d 01 ))))
       t(xc)=
     1   9.999999957157490d-01+xc*(
     1  -1.666665796975878d-01+xc*(
     1   8.333050613721043d-03+xc*(
     1  -1.980904608528695d-04+xc*
     1   2.605165638554101d-06 )))
       phi2=phi**2
       c1=dlamb*phi
       c2=(c1*t(phi2))**2
       x=dlamb*a(phi2)*t(c2)
       y=dlamb*c1   *b(phi2)*t(.25d0*c2)**2 + phi*q(phi2)
       return
       end
c***********************************************************************
	subroutine utmfwd(phi,dlam,x,y)
c  developed by g.i. evenden, usgs
	double precision phi,dlam,x,y,dl2,p
	x=1.d30
	y=1.d30
	p=phi*phi
	dl2=dlam*dlam
	if (p .le.1.94965360d0.and.dl2.le.3.7319881d-3)
     1    go to 10
	return
10	continue
	y=phi*(
     1      6332500.47d0+p*(21431.67d0+p*(-4179.269d0+p*(
     1      359.981d0-p*13.267d0)))
     1 -dl2*(-3187827d0+p*(2114440d0+p*(-414363.5d0+p*(
     1      36344.6d0-p*1420.3d0)))
     1  -dl2*(1334935d0+p*(-2356027d0+p*(1371758d0-p*
     1      267852d0)))))
	x=dlam*(6375655.2d0+p*(-3166253.6d0+p*(247800.26d0+p*(
     1      -3569.65d0+p*(-617.35d0+p*50.89d0))))
     1  -dl2*(-1069479d0+p*(2661562d0+p*(-1785956d0+p*(
     1    485045d0-p*52022d0)))))
	return
	end
c***********************************************************************
	subroutine merctr(lat,long,x,y)
	double precision lat,long,x,y,a,halfpi,b2da2,z
	data a/6378206.d0/,halfpi/1.57079632679489d0/,
     1 b2da2/9.932315290818186d-1/
	x=a*long
c	compute z/2
	z=0.5d0*(halfpi-datan(b2da2*dsin(lat)/dcos(lat)))
	y=a*dlog(dcos(z)/dsin(z))
	return
	end
c***********************************************************************
       subroutine lambert(ylat,xlon,x,y)
       implicit double precision(a-h,o-z)
       save fn,fk
c
c   Lambert Conformal Conic forward projection program using
c    Clark 1866 ellipsoidal earth.  (See Map Projections Used by
c    the U. S. Geological Survey, GS Bulletin 1532, pp. 107-108.)
c
c       Input:  ylat - Latitude in radians.
c                xlon - Longitude in radians, east of central meridian.
c       Output: x    - Distance in meters east of central meridan.
c                y    - Distance in meters (negative) south of 90 degrees lat.
c
c    Note that if setlam entry is not called prior to calling
c      subroutine lambert, the constants fn & fk are set to calculate
c      x & y for standard parallels of 33. & 45. degrees.
c
       data a/6378206.4d0/,e2/.006768657997291099d0/
       data pi4/.785398163397448310d0/,e/.82271854223003258d-1/
       data b2da2/.993231342002708901d0/
       data fn/.63049989185603457d0/,fk/.124526547337527528d8/
       z=pi4-.5d0*datan(b2da2*(dtan(ylat)))
       r=fk*dtan(z)**fn
       theta=fn*xlon
       x=r*dsin(theta)
       y=-r*dcos(theta)
       return
c
       entry setlam(ylat1,ylat2)
c
c   This entry sets up the Lambert Conformal Conic constants for
c      standard parallels ylat1 & ylat2, entered in radians, using the
c      Clark 1866 ellipsoidal earth parameters of a = 6378206.4 meters
c      & b = 6356583.8 meters.  Note that e**2 = (a*a - b*b) / (a*a).
c
	if(ylat1.ne.ylat2 .and. ylat1*ylat2.gt.0.d0) go to 2
	print  1,ylat1,ylat2
1	format(2f10.3,' incorrect standard parallels,',
     1       ' 33 & 45 will be used')
	ylat1=.575958656d0
	ylat2=.785398167d0
2      cos1=dcos(ylat1)
       cos2=dcos(ylat2)
       sin1=dsin(ylat1)
       sin2=dsin(ylat2)
       esin1=e*sin1
       esin2=e*sin2
       fm1=cos1/dsqrt(1.d0-e2*sin1*sin1)
       fm2=cos2/dsqrt(1.d0-e2*sin2*sin2)
       t1=dtan(pi4-.5d0*datan(b2da2*(sin1/cos1)))
       t2=dtan(pi4-.5d0*datan(b2da2*(sin2/cos2)))
       fn=(dlog(fm1)-dlog(fm2))/(dlog(t1)-dlog(t2))
       fk=a*fm1/(fn*t1**fn)
       return
       end
c***********************************************************************
	subroutine albers(ylat,xlon,x,y)
	double precision ylat,xlon,x,y,n,rho1sq,sinbt1,twoc2n,
     1 nus,nals,nhaw,rho295,rho55,rho8,tcnus,tcnals,tcnhaw,
     1 a1,b,c1,d,e1,f1,g,h,theta,rho,sinbet,sinphi,s2
	data a1/9.954804334645587d-1/,b/4.492024607745888d-3/,
     1 c1/2.736435989866449d-5/,d/1.763992166249299d-7/,
     1 e1/1.160814577272288d-9/,f1/7.714265487727804d-12/,
     1 g/5.154557173568170d-14/,h/3.455700205911349d-16/,
     1 nus/6.02903493787094d-1/,nals/8.627447947235633d-1/,
     1 nhaw/2.241096394314637d-1/,rho295/8.49196923967458d13/,
     1 rho55/1.806308673895081d13/,rho8/7.943986660586285d14/,
     1 tcnus/1.346470921892769d14/,tcnals/9.409410848453636d13/,
     1 tcnhaw/3.622298555079059d14/,sbt295/4.907351753179611d-1/,
     1 sbt55/8.1792905450587868d-1/,sbt8/1.385562096187223d-1/
	sinphi=dsin(ylat)
	s2=sinphi*sinphi
	sinbet=sinphi*(a1+s2*(b+s2*(c1+s2*(d+s2*
     1 (e1+s2*(f1+s2*(g+s2*h)))))))
	rho=dsqrt(rho1sq+twoc2n*(sinbt1-sinbet))
	theta=n*xlon
	x=rho*dsin(theta)
	y=-rho*dcos(theta)
	return
c
c set up constants
	entry setalb(iproj)
	if(iproj-6)500,510,520
500	n=nus
	rho1sq=rho295
	sinbt1=sbt295
	twoc2n=tcnus
	return
510	n=nals
	rho1sq=rho55
	sinbt1=sbt55
	twoc2n=tcnals
	return
520	n=nhaw
	rho1sq=rho8
	sinbt1=sbt8
	twoc2n=tcnhaw
	return
	end
c***********************************************************************
	subroutine polars(ylat,xlon,x,y)
c   polar stereographic projection
c  partially checked 
c  there is about 1% error with polarr calculated this way,
c  but the form should be (1+e)/(1-e) (?) which makes bigger errors.
	implicit double precision (a-h,o-z)
	data e/8.1820567882165d-2/,rad45/.785398163397448d0/,
     1 ee/4.09102839410826d-2/,polarr/12713644.51d0/
c      data r/6378160d0/
	dlat=dabs(ylat)
c	polarr=(2.d0*r/dsqrt(1.d0-e*e)) * ((1.d0-e)/(1.d0+e))**ee
	sinc=e*dsin(dlat)
	sine=(1.d0+sinc)/(1.d0-sinc)
	dlat2=dlat*.5d0
	tane2=rad45+dlat2
	tane1=dcos(tane2)/dsin(tane2)
	tanz=tane1*(sine**ee)
	p=tanz*polarr
	y=-(p*dcos(xlon))
	x=p*dsin(xlon)
	if(ylat.lt.0.d0) y=-y
c	scale=p*dsqrt(1.d0-e*e*dsin(dlat)**2)/dcos(dlat)/r
	return
	end
c***********************************************************************
       subroutine transm(ylat,xlon,x,y)
c
c   Transverse Mercator forward projection program using spherical
c      earth of radius 6371204. meters.  This is the radius of a
c      spherical earth of equivalent surface area to the Clark 1866
c      ellipsoid.  Note that the constant rsf is the product of this
c      radius and a scale factor of 0.926.  The scale factor is present
c      to balance the scale errors over North America.
c
c      input:  ylat - Latitude in radians.
c               xlon - Longitude in radians, east of central meridian.
c      output: x    - Distance in meters east of central meridian.
c               y    - Distance in meters north of equator.
c
       double precision ylat,xlon,x,y,rsf,b
       data rsf/5899734.904d0/
       b=dcos(ylat)*dsin(xlon)
       x=0.5d0*rsf*dlog((1.d0+b)/(1.d0-b))
       y=rsf*datan(dtan(ylat)/dcos(xlon))
       return
       end
c***************************************
      subroutine namepr(icmd,ierr)
c
c     namelist simulator for pc's with no namelist statement
c     this subroutine is program independent but it
c     calls subroutine check which is program dependent
c     The program does not handle the repeat indicator *
c     nor does it handle subscripted array variables or
c     substrings of character variables.
c     It also does not handle complex or logical variables.
c     nn = number of characters in value name(tvar)
c     chv = character variable indicator(logical)
c     inum = an array index number
c     nvar = a number returned by subroutine check to
c     determine whether a variable is an array
c     numa = a number returned by subroutine check
c     which is compared against nvar
c     r.godson,usgs,denver,co., 11/87
c
      parameter(numt=50)
      parameter(ivar=80)
      character*80 tinp(numt)
      character*6 tindex(numt)
      integer*2 ix
      logical array
      common/lout/tindex,ix,tinp,array
      character var(ivar),comma,apos,blank,equal,amp,dollar
      character*6 pvar
      character*56 tvar
      logical chv,vset
      data comma/','/,apos/#27/,blank/' '/,equal/'='/
      data amp/'&'/,dollar/'$'/,pvar/' '/,tvar/' '/,sls/'/'/
c
c     get namelist start name(e.g.&parms)
c
      ierr=0
      ix=0
      it=0
    5 if(icmd.ne.-99) then
        read(icmd,1000,end=910) var
      else
        go to 10
      endif
      do 7 i=1,ivar
      if(var(i).ne.amp.and.var(i).ne.dollar) go to 7
      do 6 m=i+1,ivar
      if(var(m).eq.blank) go to 15
    6 continue
    7 continue
      go to 5
c
c     start processing variables
c
   10 if(icmd.ne.-99) then
        read(icmd,1000,end=900) var
 1000 format(80a1)
      else
        it = it + 1
        read(tinp(it),'(a)') var
      endif
      m=1
   15 do 20 i=m,ivar
      if(var(i).eq.amp.or.var(i).eq.dollar.or.var(i)
     & .eq.sls) go to 900
      if(var(i).ne.blank.and.var(i).ne.comma) go to 30
   20 continue
      go to 10
   30 mm=0
c
c     check for continuation of array values on succeding lines
c
      item=ichar(var(i))
      if(item.eq.43.or.item.eq.45.or.item
     & .eq.46.or.(item.gt.47.and.item.lt.58).or.var(i).eq.apos) then
      k=i
      go to 95
      endif
c
c     get program variable name
c
   35 inum=1
      pvar=blank
      vset=.false.
      do 40 j=i,ivar
      if(var(j).eq.blank.or.var(j).eq.equal) go to 50
      mm=mm+1
      pvar(mm:mm)=var(j)
   40 continue
c
c     get variable value
c
     

   50 do 80 k=j+1,ivar
      if(var(k).eq.blank.or.var(k).eq.equal) go to 80
      if(var(k).eq.apos) then
c
c     character variable
      chv=.true.
      vset=.true.
      nn=0
      do 60 l=k+1,ivar
      if(var(l).eq.apos) go to 90
      nn=nn+1
      tvar(nn:nn)=var(l)
   60 continue
      call clearscreen($GCLEARSCREEN)
      write(*,*) 'error in namelist variable ',pvar,
     & ' no ending apostrophy'
      ierr=1
      return
      else
c
c     not a character variable
      chv=.false.
      nn=0
      do 70 l=k,ivar
      if(var(l).eq.blank.or.var(l).eq.comma
     & .or.var(l).eq.amp.or.var(l).eq.dollar
     & .or.var(l).eq.sls) go to 90
c
c     check for non numeric character
c
      item=ichar(var(l))
      if((item.lt.48.and.(item.ne.46
     & .and.item.ne.45.and.item.ne.43)) .or. (item .gt. 57 .and.
     & (item .ne. 69 .and. item .ne. 101 .and. item.ne.68
     &  .and. item.ne.100))) then
      call clearscreen($GCLEARSCREEN)
      write(*,*) 'missing first apostropy or a non numeric',
     & ' character in namelist variable ',pvar
      ierr=1
      return
      endif
      nn=nn+1
      tvar(nn:nn)=var(l)
   70 continue
      call clearscreen($GCLEARSCREEN)
      write(*,*) 'error in namelist variable ',pvar,
     & ' no delimiter'
      ierr=1
      return
      endif
   80 continue
c     no value on same line as variable
c     read next line
      if(icmd.ne.-99) then
        read(icmd,1000,end=900) var
      else
        it = it + 1
        read(tinp(it),'(a)') var
      endif
      j=0
      go to 50
c
c     call program dependent subroutine to assign values
c
   90 call check(pvar,tvar,nn,chv,nvar,numa,inum,ierr)
      if(ierr.ne.0) return
      tvar=blank
      k=l+1
      if(k.gt.80) go to 10
c
c     check to see if variable is an array
c     the variable numa used is program dependent
c
      if(nvar.lt.numa) go to 110
   95 if(.not.chv) then
c
c     array variable
c
      nn=0
      do 100 l=k,ivar
      if(var(l).eq.blank.and.nn.eq.0) go to 100
      if(var(l-1).eq.blank.and.var(l).eq.comma.and.nn.eq.0) go to 100
      if((var(l).eq.amp.or.var(l).eq.dollar
     & .or.var(l).eq.sls).and.nn.eq.0) go to 900
c
c     check for consecutive commas
c
      if(var(l).eq.comma.and.vset) then
      vset=.false.
      inum=inum+1
      go to 90
      else if(var(l).eq.comma) then
      inum=inum + 1
      go to 100
      endif
c
      if(var(l).eq.blank
     & .or.var(l).eq.amp.or.var(l).eq.dollar.or.
     & var(l).eq.sls) then
      inum=inum+1
      go to 90
      endif
      if(ichar(var(l)).gt.57.and.nn.eq.0) go to 120
      nn=nn+1
      tvar(nn:nn)=var(l)
      vset=.true.
  100 continue
      if(nn.ne.0) then
        inum=inum+1
        go to 90
      endif
      else
c
c     character array variable
c
      do 105 j=k,ivar
      if(var(j).eq.blank) go to 105
      if(var(j).eq.amp.or.var(j).eq.dollar.or.
     & var(j).eq.sls) go to 900
      if(ichar(var(j)).gt.57) then
      l=j
      go to 120
      endif
c
c     check for consecutive commas
c
      if(var(j).eq.comma.and.vset) then
      vset=.false.
      go to 105
      else if(var(j).eq.comma) then
      inum=inum + 1
      go to 105
      endif
      if(var(j).eq.apos) then
      nn=0
      inum=inum+1
      vset=.true.
      do 103 l=j+1,ivar
      if(var(l).eq.apos) go to 90
      nn=nn+1
      tvar(nn:nn)=var(l)
  103 continue
      call clearscreen($GCLEARSCREEN)
      write(*,*) 'error in namelist variable ',pvar,
     & ' no ending apostrophy'
      ierr=1
      return
      endif
  105 continue
c
c     end of array values
c
      endif
  110 m=l+1
      if(var(l).eq.amp.or.var(l).eq.dollar.or.
     & var(l).eq.sls) go to 900
      go to 130
  120 m=l
  130 if(m.lt.81) then
      go to 15
      else
      go to 10
      endif
  900 return
  910 write(*,*) ' error in namelist;no beginning & or $'
      ierr=1
      return
      end
c**********************************************************************
      subroutine check(pvar,tvar,nn,chv,nvar,numa,inum,ierr)
c
c     assigns values to proper variable
c     variables are passed to program prjrec through common blocks
c     numr=position in the array var where real variables start
c     numa=position in the array var where arrays start
c     nnvar=number of variables in program prjrec
c
      parameter(nnvar=18,numr=7)
      character*6 pvar,var(nnvar)
      character*56 tvar,kvar,cfmt
      logical chv
      character ifile*40,ofile*40,ifmt*40,ofmt*40,dcon*3
      common/cparm/ifile,ofile,ifmt,ofmt,dcon
      common/rparm/baslat(3),cm(3),iproj,phi1,phi2,sca,
     & s1,s2,ianom,janom,ieast,irec,jrec
      data var/'iproj','ianom','janom','ieast','irec','jrec',
     & 'phi1','phi2','sca','s1','s2','ifile','ofile','ifmt',
     & 'ofmt','dcon','baslat','cm'/
      ierr = 0
      numa=17
      do 190 i=1,nnvar
      if(pvar.ne.var(i)) go to 190
      if(.not.chv) then
c
c     noncharacter value
c     right justify then number in variable kvar
c
      m=57-nn
      im=m-1
      kvar(m:56)=tvar(1:nn)
      if(i.lt.numr) then
c
c     integer value
c
      write(cfmt,50) im,nn
   50 format('(',i2,'x,i',i2,')')
      read(kvar,cfmt) jvar
      else
c
c     real value
c
      write(cfmt,60) im,nn
   60 format('(',i2,'x,g',i2,'.0)')
      read(kvar,cfmt) xvar
      endif
      endif
      go to (101,102,103,104,105,106,107,108,109,110,111,112,
     & 113,114,115,116,117,118),i
  101 iproj=jvar
      go to 200
  102 ianom=jvar
      go to 200
  103 janom=jvar
      go to 200
  104 ieast=jvar
      go to 200
  105 irec=jvar
      go to 200
  106 jrec=jvar
      go to 200
  107 phi1=xvar
      go to 200
  108 phi2=xvar
      go to 200
  109 sca=xvar
      go to 200
  110 s1=xvar
      go to 200
  111 s2=xvar
      go to 200
  112 ifile=tvar(1:nn)
      go to 200
  113 ofile=tvar(1:nn)
      go to 200
  114 ifmt=tvar(1:nn)
      go to 200
  115 ofmt=tvar(1:nn)
      go to 200
  116 dcon=tvar(1:nn)
      go to 200
  117 baslat(inum)=xvar
      go to 200
  118 cm(inum)=xvar
      go to 200
  190 continue
      write(*,*) ' error in namelist - ',pvar,' variable not included'
      ierr = 1
      return
  200 nvar=i
      iarray=0
      if(i.ge.numa) iarray=1
      call tcheck(pvar,tvar,nn,chv,inum,iarray)
      return
      end
c***********************************************************************
      subroutine tcheck(pvar,tvar,nn,chv,inum,iarray)
c*****PUTS COMMAND FILE INPUT INTO PROPER VARIABLES FOR LATER
c*****SAVING THE FILE AFTER EDITING IS DONE
      parameter(nump=23,numt=50)
      character*6 pvar
      character*56 tvar
      character*80 tinp(numt)
      character*6 tindex(numt)
      integer*2 ix
      logical array
      common/lout/tindex,ix,tinp,array
      character*1 ap
      logical chv
      data ap/''''/

          if(iarray.eq.1) then
            if(inum.eq.1) then
              k = 1
              ix = ix + 1
              tindex(ix) = pvar 
              tinp(ix) = ' '
            endif
            tinp(ix)(k:k+(nn-1)) = tvar(1:nn)
            k = k+(nn-1) + 2
            go to 30

          else
            ix=ix+1
            tindex(ix) = pvar
            if(chv) then
              tinp(ix)=ap//tvar(1:nn)//ap
            else
              tinp(ix)=tvar(1:nn)
            endif
         endif
30    return
      end
c**********************************************************************
      subroutine helpp
      character*1 ans,sp
      character*6 var
      character*79 line,blank
      data blank/' '/,sp/#20/
      open(10,file='project.hlp',status='old')
      write(*,'(2a\)')' want general help or a specific variable',
     & '[ g or s] '
      read(*,'(a)') ans

      if(ans.eq.'g'.or.ans.eq.'G') then
        n = 0
   10   read(10,'(a)',end=150) line
        write(*,'(1x,a)') line
        n = n + 1
        if(n.lt.23) go to 10
        write(*,'(a\)') ' more? [y]'
        read(*,'(a)') ans
        if(ans.eq.'n'.or.ans.eq.'N') go to 200
        write(*,'(1x,a)') line
        n = 0
        go to 10
      endif

   20   write(*,'(/a\)') ' enter variable name or ENTER to quit: '
        read(*,'(a)') var
        if(var(1:1).eq.sp) go to 200
        call upcase(var)
        write(*,'(1x,a)') blank
   30   read(10,'(a)',end=100) line
        if(line(2:7).ne.var) go to 30
        write(*,'(1x,a)') line
   40   read(10,'(a)',end=200) line
        if(line.ne.blank) then
          write(*,'(1x,a)') line
          go to 40
        endif
        rewind(10)
        go to 20

  100 write(*,'(a,a6,a)') ' variable: ',var,' not found'
      write(*,'(a\)') ' more help ? [y] '
      read(*,'(a)') ans
      if(ans.ne.'n'.and.ans.ne.'N') then
        rewind(10)
        go to 20
      endif 
      go to 200
  150 pause ' END OF HELP FILE - press ENTER to exit'
  200 close(10)
      return
      end
c****************************************************************
      subroutine upcase(var)
C
      character*(*) var
C
      ilen=len(var)
      do 10 i=1,ilen
        k=ichar(var(i:i))
        if(k.ge.97.and.k.le.122) var(i:i)=char(k-32)
   10 continue
      return
      end
