      include 'fgraph.fi'
      implicit integer*2 (a-z)
      include 'fgraph.fd'
      integer*4 dum1,bgd1
      data bgd1/1/,fgd1/14/
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call clearscreen($GCLEARSCREEN)
      write(*,'(///)')
      write( *,'(14x,2a/)')' program:  G E O C O N - V E R S I O N',
     & '  1.0'
      write( *,'(14x,a)') ' author:   Richard H. Godson'
c      write( *,'(14x,a)') '           12526 West Texas Pl.'
c      write( *,'(14x,a)') '           Lakewood,CO 80228  (303) 988-8057'
      write( *,'(14x,a)') '           MARCH, 1992'
      write(*,'(/14x,a/)')'                  DISCLAIMER'
      write( *,'(14x,2a)')' Although program tests have been made, no',
     & ' guarantee '
      write( *,'(14x,2a)')' (expressed or implied) is made by the',
     & ' author regarding'
      write( *,'(14x,2a)')' program correctness,accuracy, or proper',
     & ' execution on all'
      write( *,'(14x,a)')' computer systems.'
      call sleep(4.)
      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=13)
      include 'fgraph.fd'
      character* 56 key(num)
      integer*4 dum1,bgd,bgd1,bgd2
      record/rccoord/curpos
      data bgd/15/,bgd2/4/fgd/0/,bgd1/1/,fgd1/14/
      data key/'         MAIN PROGRAM  G E O C O N',
     & '     projection,gridding and contouring driver program',
     & ' ',
     & '         F1  = HELP',
     & '         F2  = EXIT TO DOS',
     & '         F3  = DATA RANGE AND PLOT OF RANDOM DATA',
     & '         F4  = HISTOGRAM OF A GRID FILE',
     & '         F5  = PROJECTION PROGRAM',
     & '         F6  = GRIDDING PROGRAM',
     & '         F7  = CONTOUR PROGRAM',
     & '         F8  = 3D PLOT PROGRAM',
     & '         F9  = TRIANGLE CONTOUR 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***************************************
      interface to integer*2 function system[c]
     & (str[reference])
      character*1 str
      end

c***************************************
      interface to integer*2 function spawnlp[c,varying](mode)
      integer*2 mode
      end

c***************************************
      subroutine funact
      implicit integer*2 (a-z)
      include 'fgraph.fd'
      character*1 resp
      character*8 passg,benign,contur
      character*9 passwrd,second
      character*14 program
      integer*4 dum1,bgd1
      data bgd1/1/,fgd1/14/
     & ,esc/27/,passg/'sB8yr0hF'/,benign/'benign  '/,contur/'contour '/

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 (10,20,21,23,25,30,35,40,45) ich
      else if(ch.eq.esc) then
      go to 55
      endif
      go to 60


c*****HELP
10    call page('set')
      call geohlp
      call page('res')
      call funkey
      go to 60

c*****EXIT TO DOS
20    call page('set')
      i = system('command'c)
      if(i.eq.-1) then 
        print *, 'Can''t invoke COMMAND.COM'
        pause 'Press ENTER to return to menu'
        go to 52
      endif
      call page('res')
      go to 60

c*****DATA RANGE OF RANDOM DATA FILE
21    call page('set')
      program='xyzspecs.exe'//''c
      second = benign//''c
      go to 50

c*****HISTOGRAM OF A FILE
23    call page('set')
      program='histg.exe'//''c
      second = benign//''c
      go to 50

c*****RUN PROJECTION PROGRAM
25    call page('set')
      program='project.exe'//''c
      second = benign//''c
      go to 50

c*****RUN GRIDDING PROGRAM
30    call page('set')
      second = benign//''c
      write(*,'(a\)') ' want to bypass data augumentation ? [n]:'
      read(*,'(a)') resp
      if(resp.ne.'y'.and.resp.ne.'Y') then
        program='tr.exe'//''c
        passwrd=passg//''c
        istat=spawnlp(0,loc(program),loc(program),
     &  loc(passwrd),loc(second),int4(0))
        if(istat.eq.-1) then
          print *,'not enough memory to run program'
          print *,'program requires about 575K'
          pause 'Press ENTER to return to menu'
          go to 52
        endif
      endif
      program='mcgrd.exe'//''c
      go to 50

c*****RUN CONTOUR PROGRAM
35    call page('set')
      program='cont.exe'//''c
      second = benign//''c
      go to 50

c*****RUN 3D PROGRAM
40    call page('set')
      program='plot3d.exe'//''c
      second = benign//''c
      go to 50

c*****RUN TRIANGLE CONTOURING PROGRAM
45    call page('set')
      program='tr.exe'//''c
      second = contur//''c

50    passwrd=passg//''c
      istat=spawnlp(0,loc(program),loc(program),
     & loc(passwrd),loc(second),int4(0))
      if(istat.eq.-1) then
        print *,'not enough memory to run program'
        print *,'program requires ~ 575K'
        pause 'Press ENTER to return to menu'
      endif

52    dum=setvideomode($DEFAULTMODE)
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call clearscreen($GCLEARSCREEN)
      call funkey
      go to 60


c*****QUIT PROGRAM
55    dum=setvideomode($DEFAULTMODE)
      stop

60    return
      end
c***************************************
      include 'flib.fi'
      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 
      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 WITH ECHO
      icnt=0
      regs.bregs.ah=1
      do 10 while(str(icnt:icnt).ne.cr)
        call intdosqq(regs,regs)
        if(regs.bregs.al.eq.0) then
c*****EXTENDED KEYBOARD INPUT(E.G., FUNCTION KEYS)
c*****DON'T PUT INTO INPUT STRING BUT COUNT
          call intdosqq(regs,regs)
          icnt=icnt+2
          str(icnt:icnt)=' '
          str(icnt-1:icnt-1)=' '
        else
          ich=regs.bregs.al
c*****8=BACKSPACE;13=CARRIAGE RETURN;27=ESC
          if(ich.eq.13) return
          if(ich.eq.8) then
            icnt=icnt-1
            if(icnt.lt.0) then
               icnt=-98
               return
            endif
          else if(ich.eq.27) then
            go to 20
          else
            icnt=icnt+1
            str(icnt:icnt)=char(ich)
          endif
        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 sleep(sec)
      integer*2 ihr,imin,isec,i100th,ich
      ich = 0
      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.
      call getchr(ich)
      if(ich.ne.0) return
      if((t2-t1).lt.sec) go to 10
      return
      end
c***************************************
      subroutine geohlp
      character*1 ans
      character*79 line
      character*87 file1
c      open(10,file='geocon.hlp',status='old')
c
      open(10,file='\pfhelp.tmp',form='formatted',status='old')
      read(10,102) line
  102 format(a)
      close(10)
      n=index(line,' ')
      file1=line(1:n-1)//'geocon.hlp'
      open(10,file=file1,form='formatted',status='old')
c
        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

  150 pause ' END OF HELP FILE - press ENTER to return to menu'
  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
