
      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=10)
      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  C O N T',
     & '          contouring program ',
     & ' ',
     & '          F1  = HELP',
     & '          F2  = INTERACTIVE INPUT/EDITING',
     & '          F3  = COMMAND FILE INPUT',
     & '          F4  = LINE CONTOURING',
     & '          F5  = RASTER COLOR CONTOURING',
     & '          F6  = COLOR SHADED RELIEF CONTOURING',
     & '          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 dum1,bgd1,icapt,iwhite,ic,ii,ierr
      character*1 ctype,speed
      common/captur/icapt,iwhite,ctype
      data bgd1/1/,fgd1/14/
      data ic/250/,ii/300/,esc/27/

c*****GET SCAN CODE FOR FUNCTION KEYS
      ch=0
      call getchr(ch)
      if(ch.eq.108.or.ch.eq.109) then
        speed = 'f'
        ich = ch - 103
        go to (10,35,36,37,40,44) ich
      else if(ch.gt.58.and.ch.lt.69) then
        speed = 's'
        ich = ch-58
        go to (10,35,36,37,40,44) ich
      else if(ch.eq.esc) then
        go to 55
      endif
      go to 60

c*****HELP FILE
10    call page('set')
      call helpc
      go to 45

c*****INTERACTIVE INPUT
35    call page('set')
      call edit(ierr)
      if(ierr.ne.0)
     & pause 'press ENTER to return to menu                            '
      go to 45

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

c*****RUN LINE CONTOUR
37    call page('set')
      call input(ii,ii,ierr)
      if(ierr.ne.0) then
        pause 'press ENTER to return to menu'
        go to 45
      endif
      ctype='l'
      call pccon(speed)
      go to 45

c*****RUN RASTER COLOR CONTOUR
40    call page('set')
      call input(ii,ii,ierr)
      if(ierr.ne.0) then
        pause 'press ENTER to return to menu'
        go to 45
      endif
      ctype='c'
      call pccon(speed)
      go to 45

c*****RUN COLOR SHADED RELIEF
44    call page('set')
      call input(ii,ii,ierr)
      if(ierr.ne.0) then
        pause 'press ENTER to return to menu'
        go to 45
      endif
      ctype='s'
      call pccon(speed)

c*****RESET THINGS
45    dum=setvideomode($DEFAULTMODE)
      call clearscreen($GCLEARSCREEN)
      dum1= setbkcolor(bgd1)
      dum2=settextcolor(fgd1)
      call funkey
      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=250)
      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,'(2a)') 'press MOUSE or ENTER for ? lines ',
     & ';PAGE DOWN for next page or ESC to exit'
      go to 9
777   write(string,'(2a)') 'press MOUSE or ENTER for ? lines ',
     & ';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:74))
      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)
       if(cnt.eq.-81.and.is.eq.1) then
          is = is + 1
          linptr = 1
          go to 66
       endif
c*****CNT = -73 MEANS PAGE UP(PREVIOUS PAGE)
       if(cnt.eq.-73.and.is.eq.2) then
         is = is -1
         linptr = 1
         go to 66
       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)
c         print *,'edit',ix,tindex(ix),tinp(ix)
c         pause
c*****CHECK FIRST CHARACTER FOR ALPHA
c*****IF NOT; THEN ARRAY DATA ON MORE THAN ONE LINE
          if(ichar(tindex(ix)(1:1)).lt.65) then
            array = .true.
             do 23 i=inum,inum-19,-1
               if(inp(i)(1:1).eq.'#') go to 24
23           continue
24                if(inp(i)(3:3).eq.'#') then
                    tindex(ix)=inp(i)(4:9)
                    istop = 20
                  else if(inp(i)(2:2).eq.'#') then
                    tindex(ix)=inp(i)(3:8)
                    istop = 2
                  else
                    istop = 1
                    tindex(ix)=inp(i)(2:7)
                  endif
                   do 25 j=i+1,i+istop
                      ix = ix +1
                      tinp(ix) = inp(j)
                      tindex(ix) = ' '
25                 continue
          endif
      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)

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

      read(*,'(a)') resp
      if(resp.ne.'n'.and.resp.ne.'N') then
c*****SAVE 
          call output('y',ierr)
          if(ierr.ne.0) return
      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)
      include 'fgraph.fd'
      common/lset/setrow,setcol,linptr,line,inum,inp
      integer*4 dum1,bgd,bgd1
      parameter(ninp=25)
      character*80 inp(ninp)
      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 input(is,ie,ierr)
      parameter(ninp=25,numt=250)
      character*80 tinp(numt)
      character*6 tindex(numt)
      integer*2 ix
      logical array
      common/lout/tindex,ix,tinp,array
      include 'fgraph.fd'
      character*80 inp(ninp)
      integer*2 setrow,setcol,linptr,line,inum
      common/lset/setrow,setcol,linptr,line,inum,inp
c
c     input and common block initialization
c
      common /titls/ title1,title2,title3,fmtx,fmty
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     1 ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common/chksiz/conlim
      common /concom/ ncol,nrow,bmin,bmax,
     1 grad,gflg,ijs,ije,ijsi,ijei,prime,ij4,cont,
     1 fltmax,lmult(0:3),idashs,linet,sigma,nsig
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),
     1             baslat(3),
     1 iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     2 phi1,phi2
      COMMON /LXCB/ LXFILE,LXFMT,LXPROJ,LXUNIT,LXTYPE
      common/txcb/txfile
      common /vect/ ispost,lowhi,nid,ncharv,szpost,vmin,vmax,
     & lifmtv(10),lfmtv(4),ich(20),lchid(20),DGRAD,sizehi,szlab
      common /labcom/ lchars(6),fmtc,nchar,size,idum(3),delb
      common /contrc/ cmin,cmax,dcval,ncval,nsec,gradi,
     1                acdel(200),acgrad(200),jcdash(200),
     2                ncval2,acsize(200),acmin(200),acmax(200)
      common /contur/ acval(200)
      COMMON /HACOM/ HACHLN,HACHSP,HACHGP,HACHMX,HACHLM,HACHVB
      common /pltcom/ npens
      common/files/ifile,ifile2,ifile3,acfile,mxhach,access
      common /bdist/ brmin, brmax, cntras,sunaz,sunel,linear,df(64)
      character*1 ctype
      common/captur/icapt,iwhite,ctype
c
      character*40 title1,title2,title3,ifile,ifile2,ifile3,cfile,
     1             iblank,ifmtv,txdum
      character*16 fmtc,fmtx,fmty,jblank,fmtv,lxfmt
      CHARACTER*40 LXFILE,ACFILE,TXFILE
      character*4 chid(20)
      character*6 access
      real latm,latx,longm,longx
      logical prime,first,opn
      character*1 ap
      equivalence (lchid,chid),(lifmtv,ifmtv),(lfmtv,fmtv)
c
      data itty,icmd,igrid,ista,igrid3,kdsk,mdsk/5,9,10,8,40,41,42/
      data iblank/' '/,jblank/' '/
      data first/.true./,ap/''''/
c
      ierr=0
      if(is.eq.250.or.first) then
      ix=0
      tindex=' '
      tinp=' '
      array = .false.
      lmult(0)=256*256*256
      lmult(1)=256*256
      lmult(2)=256
      lmult(3)=1
      ibound=999
      conlim=0.
      lowhi=0
      DGRAD=0.
      ispost=0
      xxx(1)=0.
      xxx(2)=0.
      yyy(1)=0.
      yyy(2)=0.
      ich=4
      chid='zzzz'
      nid=0
      vmin=0.
      vmax=.5
      ncharv=0
      fmtv='(f7.2)'
      ifmtv=' '
      ncval=0
      dcval=-1.
      nchar=-1
      nsec=5
      gradi=30.
      gflg=1.0e37
      fltmax=1.0e37
      cmin=-fltmax
      cmax=fltmax
      iplotr=9
      idashs=0
      linet=0
      ncharx=0
      nchary=0
      lintx=5
      linty=5
      size=.12
      sizex=.12
      sizey=.12
      sizel=0.
      sizep=.12
      szlab=.1
      szpost=.06
      sizehi=.1
      adelx=0.
      adely=0.
      pllx=0.
      plly=0.
      xscale=0.
      yscale=0.
      mscale=0
      xp1(2)=0.
      yp1(2)=0.
      sigma=7.3
      nsig=0
      delb=0.
      phi1=33.
      phi2=45.
      iproj=999
      unit=2
      neat=0
      tint=0.
      itpost=2
      cm(1)=999.
      cm(2)=0.
      cm(3)=0.
      baslat(1)=999.
      baslat(2)=0.
      baslat(3)=0.
      latm=0.
      latx=0.
      longm=0.
      longx=0.
      title2=iblank
      title3=iblank
      fmtc=jblank
      fmtx=jblank
      fmty=jblank
      npens=6
      ifile=iblank
      ifile2=iblank
      ifile3=iblank
      HACHSP=.15
      HACHLN=.05
      HACHGP=0.
      MXHACH=0
      HACHLM=-1.
      HACHVB=0.
      ACFILE=IBLANK
      TXFILE=IBLANK
      LXFILE=IBLANK
      LXFMT=jblank
      LXPROJ=999
      LXUNIT=2
      LXTYPE=0
      ICAPT=0
      HACHMX=FLOAT(MXHACH)
      acval=0.
      acdel=0.
      acgrad=0.
      acmin=0.
      acmax=0.
      acsize=0.
      jcdash=0
      JCDASH(1)=999
      acsize(1)=-1.
      acmin(1)=1.e38
      acmax(1)=-1.e38
      brmin=-.5
      brmax=.5
      cntras=.5
      sunaz=0.
      sunel=40.
      endif
      first=.false.
      if(is.eq.250) go to 250
      if(is.eq.300) go to 300
      call inptxt(is,ie)
      return
250   write(*,'(a\)') ' ENTER COMMAND FILE NAME: '
      read(*,'(a)') cfile
        inquire(unit=icmd,opened=opn)
          if(opn) close(icmd)
      open(unit=icmd,file=cfile,form='formatted',
     1 status='old',err=982,iostat=icheck)
      call namel(icmd,ierr)
      close (icmd)
      if(ierr.ne.0) return
      go to 300
982   call fcheck(icmd,cfile,icheck,ierr)
      if(ierr.eq.0) go to 250
      if(ierr.ne.0) then
        close (icmd)
        return
      endif

C
300   call acinp(ierr)
      if(ierr.eq.1.or.is.eq.250) return
C
   40 ip=iplotr
      nogrid=0
      if(abs(xxx(1))+abs(xxx(2)).ne.0. .and.
     1 abs(yyy(1))+abs(yyy(2)).ne.0.) nogrid=1
c
  441 if(nogrid.eq.0 .and. ifile.eq.iblank) then
        print 60
   60   format(' enter grid filename :'$)
        read(itty,69) ifile
   69   format(a)
        ix=ix+1
        tinp(ix)=ap//ifile//ap
        tindex(ix)='ifile '
      endif

      if(nogrid.eq.0) then
        call opngrd(igrid,ifile,ierr,*441,*443)
      endif 
c
442     if(ifile3.ne.iblank) then
          call opngrd(igrid3,ifile3,ierr,*543,*443)
        endif
          go to 544
543       write(*,'(a\)') ' ENTER OVERLAY GRID FILE NAME: '
          read(*,'(a)') ifile3
          ix=ix+1
          tinp(ix)=ap//ifile3//ap
          tindex(ix)='ifile3'
          go to 442
544     if(ispost.eq.0) go to 710
771     if(ifile2.eq.iblank) then
          print 700
700       format(' ENTER RANDOM DATA FILENAME :'\)
          read(*,'(a)') ifile2
          ix=ix+1
          tinp(ix)=ap//ifile2//ap
          tindex(ix)='ifile2'
        endif
        call opnsta(ista,ifile2,ifmtv,ierr,*771)
c*****LINE DATA FILE
710     if(lxfile.ne.' ') then
  136     if(lxfile.eq.' ') then
            write(*,'(a\)') ' ENTER LINE DATA FILENAME :'
            read(*,'(a)') lxfile
            ix=ix+1
            tinp(ix)=ap//lxfile//ap
            tindex(ix)='lxfile'
          endif
          call opnsta(kdsk,lxfile,lxfmt,ierr,*136)
          if(ierr.ne.0) go to 443
          close(kdsk)
        endif

c*****TEXT DATA FILE
      if(txfile.ne.' ') then
  137   if(txfile.eq.' ') then
          write(*,'(a\)') ' ENTER TEXT DATA FILENAME :'
          read(*,'(a)') txfile
          ix=ix+1
          tinp(ix)=ap//txfile//ap
          tindex(ix)='txfile'
        endif
        open(unit=mdsk,file=txfile,form='formatted',
     1  status='old',err=720,iostat=icheck)
        read(mdsk,*,err=730,iostat=icheck) x,y,txdum,i,w
        close(mdsk)
        return
720     call fcheck(mdsk,txfile,icheck,ierr)
        if(ierr.eq.0) go to 137
        return
730     print *,'error no. ',icheck,' with txfile:',txfile
        close(mdsk)
        ierr = 1
        return
      endif
443   return
      end
c***************************************
      subroutine opngrd(igrid,ifile,ierr,*,*)
      character*(*) ifile
      character*64 title
      logical opn
        inquire(unit=igrid,opened=opn)
          if(opn) close(igrid)
        open(unit=igrid,file=ifile,
     &  status='old',form='unformatted',err=442,iostat=icheck)
        read(igrid,err=442,end=442,iostat=icheck) title,ncol
        rewind igrid
        return
442     call fcheck(igrid,ifile,icheck,ierr)
        if(ierr.eq.0) return 1
        if(ierr.eq.1) return 2
        if(ierr.eq.2) then
          ierr = 0
          return
        endif
c           if(ncol.gt.10000) then
c             open(unit=igrid,file=ifile,access='sequential',
c     &       status='old',form='unformatted')
c             access='sequen'
c           else
c             nbytes=(ncol+1)*4
c             open(unit=igrid,file=ifile,access='direct',
c     &       recl=nbytes,status='old',form='unformatted')
c             access='direct'
       return
       end
c***************************************
      subroutine fcheck(igrid,fname,ierror,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
      call iof(igrid,fname,ierror,ierr)
      if(ierr.eq.1) go to 10
      return
10    print *,'error no. ',ierror,' with file: ',fname
      fname=' '
      return
      end
c***************************************************************
      subroutine iof(igrid,fname,ierror,ierr)
      parameter (numz=4500)
      character*(*) fname
      character*150 string
      dimension z(4500)
      close(igrid)
      jgrid=igrid+1
      kgrid=jgrid+1
      open(jgrid,file=fname,status='old',err=90,iostat=ierror,
     & form='formatted')
      read(jgrid,'(a)',err=90,iostat=ierror) string
c*****FORMATTED INPUT DATA FILE
c*****CREATE A SCRATCH UNFORMATTED FILE FOR INPUT TO PROGRAM
      open(igrid,status='scratch',form='unformatted')
      open(kgrid,status='scratch',form='formatted')
      lens = len_trim(string)
      write(kgrid,'(4a)') '''',string(1:64),'''',string(65:lens)
      rewind kgrid
      read(kgrid,*,err=90,iostat=ierror) string(1:64),nc,nr,nz,
     & xo,dx,yo,dy
      close(kgrid)
      if(nc.eq.0.or.nr.eq.0.or.nz.ne.1) then
        print *,'formatted grid file has wrong format'
        go to 90
      endif
      if(nc.gt.numz) then
        print *,'number of input columns ',nc,' > ',numz
        go to 90
      endif
      write(igrid) string(1:64),nc,nr,nz,xo,dx,yo,dy
      iend=0
10    call iorw(jgrid,igrid,z,nc,iend,ierror,ierr)
      if(iend.ne.0) go to 20
      if(ierr.eq.1) go to 20
      go to 10
20    close(jgrid)
      rewind igrid
      return
90    ierr = 1
      close(jgrid)
      close(kgrid)
      return
      end
c***************************************
      subroutine iorw(jgrid,igrid,z,nc,iend,ierror,ierr)
      dimension z(nc)
      read(jgrid,*,end=10,err=20,iostat=ierror) y,z
      write(igrid) y,z
      return
10    iend=1
      ierr = 2
      return
20    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 *,ifile2,' 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 output(resp,ierr)
      parameter(nump=9,numt=250)
      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
      common /titls/ title1,title2,title3,fmtx,fmty
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     1 ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common/chksiz/conlim
      common /concom/ ncol,nrow,bmin,bmax,
     1 grad,gflg,ijs,ije,ijsi,ijei,prime,ij4,cont,
     1 fltmax,lmult(0:3),idashs,linet,sigma,nsig
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),
     1             baslat(3),
     1 iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     1 phi1,phi2
      COMMON /LXCB/ LXFILE,LXFMT,LXPROJ,LXUNIT,LXTYPE
      common/txcb/txfile
      common /vect/ ispost,lowhi,nid,ncharv,szpost,vmin,vmax,
     & lifmtv(10),lfmtv(4),ich(20),lchid(20),DGRAD,sizehi,szlab
      common /labcom/ lchars(6),fmtc,nchar,size,idum(3),delb
      common /contrc/ cmin,cmax,dcval,ncval,nsec,gradi,
     1                acdel(200),acgrad(200),jcdash(200),
     2                ncval2,acsize(200),acmin(200),acmax(200)
      common /contur/ acval(200)
      COMMON /HACOM/ HACHLN,HACHSP,HACHGP,HACHMX,HACHLM,HACHVB
      common /pltcom/ npens
      common/files/ifile,ifile2,ifile3,acfile,mxhach,access
      common /bdist/ brmin, brmax, cntras,sunaz,sunel,linear,df(64)
      character*1 ctype
      common/captur/icapt,iwhite,ctype
c
      character*40 title1,title2,title3,ifile,ifile2,ifile3,
     1             sfile,ifmtv
      character*16 fmtc,fmtx,fmty,fmtv
      CHARACTER*40 LXFILE,TXFILE,ACFILE
      CHARACTER*16 LXFMT
      character*4 eq
      character*4 chid(20)
      character*6 p(nump)
      character*80 str
      character*6 access
      real latm,latx,longm,longx
      logical prime,save
      equivalence (lchid,chid),(lifmtv,ifmtv),(lfmtv,fmtv)
      data bgd1/1/,fgd1/14/,jcmd/9/,eq/' = '/
c
      data p/'acval','jcdash',
     & 'acdel','acgrad','acmin',
     & 'acmax','acsize','ich','chid  '/
 
      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 NAMEL
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
c*****MUST UPDATE NCVAL BEFORE OUTPUT OF ARRAYS THAT USE IT
      if(tindex(i).eq.'ncval') then
      n = leftj(tinp(i))
      read(tinp(i),'(i3)') ncval
      endif
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
      if(.not.array) go to 80
        do 70 j=1,nump
          if(p(j).eq.tindex(i)) go to 75
70      continue
        go to 80
75      if(j.lt.8) then
c*****ARRAYS ON TWENTY LINES
c*****DON'T PROCESS IF NCVAL = 0
          if(ncval.eq.0) go to 100
          if(save) then
            write(jcmd,'(1x,2a)',err=993,iostat=icheck)
     &        tindex(i),eq
          else
            it = it + 1
            tinp(it) = tindex(i)//eq
          endif

             if(mod(ncval,10).eq.0) then
               nl = ncval/10
               nnl = 80
             else
               nl = ncval/10 
               nnl = (ncval - nl*10) * 8
               nl = nl + 1
             endif

             do 60 k=1,nl
             if(k.eq.nl) then
               if(save) then
                 write(jcmd,'(a)',err=993,iostat=icheck)
     &           tinp(i+k)(1:nnl)
               else
                 it = it + 1
                 write(tinp(it),'(a)')  tinp(i+k)(1:nnl)
               endif
               go to 60
             endif
               if(save) then
                 write(jcmd,'(a)',err=993,iostat=icheck) tinp(i+k)
               else
                 it = it + 1
                 write(tinp(it),'(a)')  tinp(i+k)
               endif
60           continue
       else if(j.eq.8) then
c******ARRAYS ON TWO LINE
         if(save) then
            write(jcmd,'(1x,2a)',err=993,iostat=icheck)
     &        tindex(i),eq
            write(jcmd,'(a)',err=993,iostat=icheck)
     &        tinp(i+1)
         else
            it = it + 1
            tinp(it) = tindex(i)//eq
            it = it + 1
            write(tinp(it),'(a)')  tinp(i+1)
         endif
       else
c******ARRAYS ON THREE LINES
         if(save) then
            write(jcmd,'(1x,2a)',err=993,iostat=icheck)
     &        tindex(i),eq
          write(jcmd,'(a)',err=993,iostat=icheck)
     &        tinp(i+1)
          write(jcmd,'(a)',err=993,iostat=icheck)
     &        tinp(i+2)
         else
            it = it + 1
            tinp(it) = tindex(i)//eq
            it = it + 1
            write(tinp(it),'(a)')  tinp(i+1)
            it = it + 1
            write(tinp(it),'(a)')  tinp(i+2)
         endif
       endif
       go to 100
c******VALUES ON ONE LINE
80     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)
       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 namel(jcmd,ierr)
        close(jcmd)
      else
        call namel(-99,ierr)
      endif
      return
      end
c***************************************
      subroutine namel(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=250)
      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 pccontur 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 pccontur
c
      parameter(nnvar=93,numr=25)
      common /titls/ title1,title2,title3,fmtx,fmty
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     1 ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     1 lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common/chksiz/conlim
      common /concom/ ncol,nrow,bmin,bmax,
     1 grad,gflg,ijs,ije,ijsi,ijei,prime,ij4,cont,
     1 fltmax,lmult(0:3),idashs,linet,sigma,nsig
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),baslat(3),
     1 iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     2 phi1,phi2
      common /vect/ ispost,lowhi,nid,ncharv,szpost,vmin,vmax,
     & lifmtv(10),lfmtv(4),ich(20),lchid(20),dgrad,sizehi,szlab
      common/labcom/lchars(6),fmtc,nchar,size,idum(3),delb
      common /contrc/ cmin,cmax,dcval,ncval,nsec,gradi,
     1                acdel(200),acgrad(200),jcdash(200),
     2                ncval2,acsize(200),acmin(200),acmax(200)
      common/txcb/txfile
      common /contur/ acval(200)
      common/hacom/hachln,hachsp,hachgp,hachmx,hachlm,hachvb
      common/lxcb/lxfile,lxfmt,lxproj,lxunit,lxtype
      common/files/ifile,ifile2,ifile3,acfile,mxhach,access
      common /bdist/ brmin, brmax, cntras,sunaz,sunel,linear,df(64)
      character*1 ctype
      common/captur/icapt,iwhite,ctype
c
      CHARACTER*40 LXFILE,ACFILE,TXFILE
      character*40 title1,title2,title3,ifile,ifile2,ifile3,ifmtv
      character*16 fmtc,fmtx,fmty,fmtv,lxfmt,cfmt
      character*4 chid(20)
      character*6 access
      real latm,latx,longm,longx
      character*6 pvar,var(nnvar)
      character*56 kvar,tvar
      logical chv
      equivalence(lchid,chid),(lifmtv,ifmtv),(lfmtv,fmtv)
      data var/'nsec','mscale','iplotr','nchar','idashs',
     1 'ncval','ncharx','nchary','lintx','linty','nsig','iproj',
     2 'neat','itpost','ibound','ispost','ncharv','lowhi','nid',
     3 'lxproj','lxunit','lxtype','mxhach','icapt','dcval',
     4 'cmin','cmax','xscale','yscale','gradi','size','phi1',
     5 'phi2','sizel','sizex','sizey','adelx','adely','pllx',
     6 'plly','sigma','sizep','unit','tint','vmax',
     7 'vmin','szpost','sizehi','szlab','conlim','dgrad','delb',
     8 'hachsp','hachln','hachlm','hachgp','hachvb',
     8 'sunaz','sunel','cntras','brmin','brmax',
     9 'title2','title3','fmtc','fmtx',
     a 'fmty','fmtv','ifmtv','ifile','ifile2','ifile3',
     b 'acfile','lxfile','lxfmt','txfile','acval','latm',
     c 'latx','longm','longx','cm','baslat','xxx','yyy','ich','chid',
     d 'jcdash','acdel','acgrad','acsize','acmin','acmax'/
      ierr=0
      numa=77
      do 190 i=1,nnvar
      if(pvar.ne.var(i)) go to 190
      if(.not.chv) then
c
c     noncharacter value
c     right justify the number in variable kvar
c
      m=57-nn
      im=m-1
      kvar(m:56)=tvar(1:nn)
c*****CHANGE THESE FOLLOWING TWO NUMBERS IF VARIABLES ARE ADDED BEFORE THEM
      if(i.lt.numr.or.i.eq.86.or.i.eq.88) 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,119,120,121,1121,1221,1321,122,123,124,
     & 125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,
     & 142,143,144,145,1451,1452,146,147,148,149,150,
     & 1150,1250,1350,1450,1550,1650,1750,1850,151,152,153,154,
     & 155,156,157,158,159,1591,160,161,162,163,164,165,166,167,168,
     & 169,170,171,172,173,174,175,176,177,178,179,180),i
  101 nsec=jvar
      go to 200
  102 mscale=jvar
      go to 200
  103 iplotr=jvar
      go to 200
  104 nchar=jvar
      go to 200
  105 idashs=jvar
      go to 200
  106 ncval=jvar
      go to 200
  107 ncharx=jvar
      go to 200
  108 nchary=jvar
      go to 200
  109 lintx=jvar
      go to 200
  110 linty=jvar
      go to 200
  111 nsig=jvar
      go to 200
  112 iproj=jvar
      go to 200
  113 neat=jvar
      go to 200
  114 itpost=jvar
      go to 200
  115 ibound=jvar
      go to 200
  116 ispost=jvar
      go to 200
  117 ncharv=jvar
      go to 200
  118 lowhi=jvar
      go to 200
  119 nid=jvar
      go to 200
  120 lxproj=jvar
      go to 200
  121 lxunit=jvar
      go to 200
 1121 lxtype=jvar
      go to 200
 1221 hachmx=float(jvar)
      mxhach=jvar
      go to 200
 1321 icapt=jvar
      go to 200
  122 dcval=xvar 
      go to 200
  123 cmin=xvar
      go to 200
  124 cmax=xvar
      go to 200
  125 xscale=xvar
      go to 200
  126 yscale=xvar
      go to 200
  127 gradi=xvar
      go to 200
  128 size=xvar
      go to 200
  129 phi1=xvar
      go to 200
  130 phi2=xvar
      go to 200
  131 sizel=xvar
      go to 200
  132 sizex=xvar
      go to 200
  133 sizey=xvar
      go to 200
  134 adelx=xvar
      go to 200
  135 adely=xvar
      go to 200
  136 pllx=xvar
      go to 200
  137 plly=xvar
      go to 200
  138 sigma=xvar
      go to 200
  139 sizep=xvar
      go to 200
  140 unit=xvar
      go to 200
  142 tint=xvar
      go to 200
  143 vmax=xvar
      go to 200
  144 vmin=xvar
      go to 200
  145 szpost=xvar
      go to 200
 1451 sizehi=xvar
      go to 200
 1452 szlab=xvar
      go to 200
  146 conlim=xvar
      go to 200
  147 dgrad=xvar
      go to 200
  148 delb=xvar
      go to 200
  149 hachsp=xvar
      go to 200
  150 hachln=xvar
      go to 200
 1150 hachlm=xvar
      go to 200
 1250 hachgp=xvar
      go to 200
 1350 hachvb=xvar
      go to 200
 1450 sunaz=xvar
      go to 200
 1550 sunel=xvar
      go to 200
 1650 cntras=xvar
      go to 200
 1750 brmin=xvar
      go to 200
 1850 brmax=xvar
      go to 200
  151 title2=tvar(1:nn)
      go to 200
  152 title3=tvar(1:nn)
      go to 200
  153 fmtc=tvar(1:nn)
      go to 200
  154 fmtx=tvar(1:nn)
      go to 200
  155 fmty=tvar(1:nn)
      go to 200
  156 fmtv=tvar(1:nn)
      go to 200
  157 ifmtv=tvar(1:nn)
      go to 200
  158 ifile=tvar(1:nn)
      go to 200
  159 ifile2=tvar(1:nn)
      go to 200
 1591 ifile3=tvar(1:nn)
      go to 200
  160 acfile=tvar(1:nn)
      go to 200
  161 lxfile=tvar(1:nn)
      go to 200
  162 lxfmt=tvar(1:nn)
      go to 200
  163 txfile=tvar(1:nn)
      go to 200
  164 acval(inum)=xvar
      go to 200
  165 latm(inum)=xvar
      go to 200
  166 latx(inum)=xvar
      go to 200
  167 longm(inum)=xvar
      go to 200
  168 longx(inum)=xvar
      go to 200
  169 cm(inum)=xvar
      go to 200
  170 baslat(inum)=xvar
      go to 200
  171 xxx(inum)=xvar
      go to 200
  172 yyy(inum)=xvar
      go to 200
  173 ich(inum)=jvar
      go to 200
  174 chid(inum)=tvar(1:nn)
      go to 200
  175 jcdash(inum)=jvar
      go to 200
  176 acdel(inum)=xvar
      go to 200
  177 acgrad(inum)=xvar
      go to 200
  178 acsize(inum)=xvar
      go to 200
  179 acmin(inum)=xvar
      go to 200
  180 acmax(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,ierr)
      return
      end
c***********************************************************************
      subroutine tcheck(pvar,tvar,nn,chv,inum,iarray,ierr)
c*****PUTS COMMAND FILE OR INTERACTIVE INPUT INTO TEMPORARY ARRAYS 
c*****FOR SAVING THE FILE IF REQUESTED
      parameter(nump=9,numt=250)
      character*6 pvar
      character*56 tvar
      character*80 tinp(numt)
      integer*2 ix
      character*6 tindex(numt)
      logical array
      common/lout/tindex,ix,tinp,array
      character*1 ap
      character*6 p(nump)
      logical chv
      data ap/''''/
      data p/'acval','jcdash',
     & 'acdel','acgrad','acmin',
     & 'acmax','acsize','ich','chid'/

      if(iarray.eq.0) then
        ix=ix+1
        tindex(ix) = pvar
        tinp(ix) = ' '
        if(chv) then
          tinp(ix)=ap//tvar(1:nn)//ap
        else
          tinp(ix)=tvar(1:nn)
        endif

      else
c*****ARRAYS
        do 10 i=1,nump
        if(pvar.eq.p(i)) go to 20
10      continue
c*****ARRAYS ON ONE LINE
          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 60

c*****ARRAYS ON MORE THAN ONE LINE
20        if(nn.gt.7) then
            print *,'number of digits > 7 for: ',p(i)
            ierr = 1
            return
          endif

             if(inum.eq.1) then
               array = .true.
               k=1
               ix = ix + 1
               tindex(ix)=pvar
               ix = ix + 1
               tindex(ix) = ' '
               tinp(ix) = ' '
               if(i.lt.8) then
                 incr = 7
               else if(i.eq.8) then
                 incr = 2
               else
                 incr = 6
               endif
               nstop = 80 - incr
             endif

             if(k.gt.nstop) then
               ix = ix + 1
               tindex(ix) = ' '
               tinp(ix) = ' '
               k=1
             endif
             if(chv) then
               tinp(ix)(k:k+incr)=ap//tvar(1:nn)//ap
             else
               tinp(ix)(k:k+incr)=tvar(1:nn)
             endif
             k=k+incr+1
             go to 60
      endif
60    return
      end
C________________________________________________________________
C
C     PROGRAM  PC  C O N T O U R
C________________________________________________________________
c  revision date 11/91
C
c
c  general contouring program
c
c  originally developed and coded by..
c    gerald ian evenden
c    u. s. geological survey
c    denver, colorado  80225
c
c  modified for the honeywell/multics computer
c   by r.h. godson - april,1977
c  station posting, hi-low symbols, lat-lon ticks, active
c  defaults
c   by mike webring, USGS
c  modified for the DEC/VAX by
c   Cindy Cooper, EDS and Ray Watts, USGS
c  converted to pc's with Microsort Fortran v4.01
c   by r.h. godson june,1988
c
c
c  grids of up to about 4500 columns can be contoured with nwork=16000.
c  in practice, 30 to 40 rows per tier is prefered so that 300
c  to 400 columns is a desirable limit.  the formula for rows
c  per tier (rpt) is ......
c     rpt=4*(nwork-ncval-ncol)/(5*ncol+4)
c     If larger grids are desired, recompile with nwork 
c     increased and appropriate [huge] inserts.
c

c******************************************************************************
      subroutine pccon(speed)
      parameter(nwork=16000,numt=250)
      include 'pxz99.cmn'
      character*80 tinp(numt)
      integer*2 ix
      character*6 tindex(numt)
      logical array
      common/lout/tindex,ix,tinp,array
      character*1 speed,resp
      integer*2 dum2,settextcolor,setvideomode
      integer*4 setbkcolor,maxcol(4)
      common /titls/ title1,title2,title3,fmtx,fmty
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     & ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common/chksiz/conlim
      common /concom/ ncol,nrow,bmin,bmax,
     & grad,gflg,ijs,ije,ijsi,ijei,prime,ij4,cont,
     & fltmax,lmult(0:3),idashs,linet,sigma,nsig
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),
     &             baslat(3),
     & iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     & phi1,phi2
      COMMON /LXCB/ LXFILE,LXFMT,LXPROJ,LXUNIT,LXTYPE
      common /vect/ ispost,lowhi,nid,ncharv,szpost,vmin,vmax,
     & lifmtv(10),lfmtv(4),ich(20),lchid(20),DGRAD,sizehi,szlab
      common /labcom/ lchars(6),lfmtc(4),nchar,size,ifill(3),
     1 delb
      common /contrc/ cmin,cmax,dcval,ncval,nsec,gradi,
     1                acdel(200),acgrad(200),jcdash(200),
     2                ncval2,acsize(200),acmin(200),acmax(200)
      common /contur/ acval(200)
      COMMON /HACOM/ HACHLN,HACHSP,HACHGP,HACHMX,HACHLM,HACHVB
      character*1 ctype,dtype
      common/captur/icapt,iwhite,ctype
      common/files/ifile,ifile2,ifile3,acfile,mxhach,access
      common/txcb/txfile
      common/gridsp/ iright,jupp
      common/scalef/ iwc0,jwc0,nxhpix,nyhpix,xpix,ypix,xscr,yscr
      common /bdist/ brmin, brmax, cntras,sunaz,sunel,linear,df(64)
      dimension work(nwork),idim(10),cr(2)
      integer iwork(nwork)
      character*40 title1,title2,title3,LXFILE
      character*40 ifile,ifile2,ifile3,acfile,txfile,blank
      character*16 header
      character*16 fmtc,fmtx,fmty,LXFMT
      CHARACTER*16 FMTC2
      character*6 fmttmp,access
      real latm,latx,longm,longx
      integer ifmtx(4),ifmty(4)
      logical prime,extra,black
      character*56 istrin,jstrin,title4
      integer istri(14),jstri(14)
      integer*1 jwork(64000)
      equivalence(istrin,istri(1)),(jstrin,jstri(1))
      equivalence (lfmtc,fmtc)
      equivalence (work(1),iwork(1)),(iwork(1),jwork(1))
      equivalence (ifmtx,fmtx),(ifmty,fmty)
      integer*2 jch,jclr,bx,by
      data idim(1)/0/,ista/8/,blank/' '/,igrid3/40/,kdsk/41/,mdsk/42/
c     iz & jz are integers of z and Z; it & jt are integers of t and T
c     il & jl are integers of l and L
c     kp & jp are integers of p and P
c     iv & jv are integers of v and V
      data iz/122/,jz/90/,it/116/,jt/84/,il/108/,jl/76/,kp/112/,
     & jp/80/,iv/118/,jv/86/
      data ldev/9/,iblack/39/,nvmax/200/,maxsh/9/,maxcol/3,15,15,63/

      if(iplotr.eq.5.and.ctype.ne.'l') then
        print *,'only line contouring can be done with pen plotters'
        go to 340
      endif

c*****IF ACFILE IS SPECIFIED THEN ACVALS CAN BE CHANGED BY ACDELS
c*****THIS WILL MESS UP RASTER CONTOURING SO A CHECK MUST BE MADE
      if(acfile.ne.blank.and.ctype.ne.'l') then
        print *,'acfile not allowed with raster contouring'
        go to 340
      endif

      if(icapt.ne.0) then
         ctype = 'l'
         iplotr = 9
      endif

c*****CHECK ncval FOR DIFFERENT COLOR OPTIONS
      if(dcval.gt.0. .and. ncval.gt.0) ncval=0
      if(ncval.gt.0) then
      cmin = acval(1)
      cmax = acval(ncval)
      if(ctype.eq.'l') then
        if(ncval.gt.nvmax) then
           print *,'only ',nvmax,' contour levels allowed'
           go to 340
        endif
      else if(ctype.eq.'s') then
        if(ncval.gt.maxsh) then
           print *,'only ',maxsh,' contour levels allowed',
     &     ' for color shaded relief'
           go to 340
        endif
      else
        if(ncval.gt.maxcol(iplotr-7)) then
           print *,'only ',maxcol(iplotr-7),' contour levels allowed',
     &     ' for this video mode'
           go to 340
        endif
      endif
      endif
      if(ctype.eq.'s') iplotr=11

      isub = 0
      igrid=10

      dcvtmp=dcval
      ncvtmp=ncval
      cmntmp=cmin
      cmxtmp=cmax
      nchtmp=nchar
      fmttmp=fmtc(1:6)
      lohitm=lowhi
      sizetm=sizel
      sizxtm=sizex
      sizytm=sizey
      pllxt = pllx
      pllyt = plly
      jcdtmp=jcdash(1)
      sigtmp=sigma
      nwkres=nwork

c  convert map scale to data units/inch - if not a screen plot
      if(mscale.gt.0.and.iplotr.eq.5) then
        if(unit.gt.2.5 .or. unit.lt.-.5) then
          print *, ' invalid ''UNIT'' parm'
          go to 340
        endif
        unitc=1.0
        if(unit.gt.0.5) unitc=39.370079
        if(unit.gt.1.5) unitc=39370.079
        xscale=float(mscale)/unitc
        yscale=xscale
      endif
c
c  given limits instead of a grid - post stations
      if(abs(xxx(1))+abs(xxx(2)).eq.0. .and.
     1 abs(yyy(1))+abs(yyy(2)).eq.0.) go to 31
      call ngrid(ista,*340)
      return
c
c  default contour interval or labels
31    extra = .true.
      if (ncval.eq.0 .and. dcval.eq.0.0) go to 35
      if(dcval.gt.0. .and. ncval.gt.0) ncval=0
      if(dcval.lt.0. .or. nchar.lt.0 .or. fmtc(1:6).eq.'      ')
     1then
        if(ncval.gt.0) then
          cr(1)=acval(1)
          cr(2)=acval(ncval)
          dx=0.
          call setax(cr,dx,ncval,NCHAR2,FMTC2)
        else
          read(igrid,err=330,iostat=icheck) title1,header,ip1,ip2,
     &    nc,nr,nz,xo,dx,yo,dy
          call gmax(igrid,fltmax,nc,work,cr(1),cr(2))
          if(dcval.lt.0.) dcval=0.
          if(cr(1).eq.cr(2)) dcval=1.
          if(ctype.eq.'l') then
            ndcval=20
          else if(ctype.eq.'s') then
            ndcval=8
          else
c***********CALL TO PXZ42 GETS NUMBER OF COLORS FOR VIDEO MODE
            ipltr=iplotr+1
            call pxz42(1)
            ndcval=ncolor-2
          endif
          call setax(cr,dcval,ndcval,NCHAR2,FMTC2)
          if(dcval.eq.0) then
            print *,'contour interval is less 1.0e-20'
            go to 340
          endif
        endif
      endif
      dcval2 = dcval
C
C ADDITION TO PROGRAM MADE 17FEB87 TO ALLOW USER SELECTION OF
C CONTOUR LABEL FORMAT WHEN ACVALS ARE BEING USED
C
            IF(nchar.lt.0)  nchar=nchar2
            IF( fmtc(1:6).eq.'      ') fmtc=fmtc2
c
   35 if(ncval.gt.0) then
        do 40 i=1,ncval
   40   work(i)=acval(i)
      endif
      if (nsec.lt.0) nsec=0
c      if (gradi.lt.0.) gradi=0.
      if (nchar.lt.0) nchar=0
      if (size.lt.0.) size=0.
      if (nsig.ne.0) nsig=4
      sigma=.001*sigma
c
c  contour values...
   50 if(dcval.gt.0.0 .or. ncval.gt.0 .or. ispost.ne.0) go to 52
      write(*,51)
   51 format(' %neither contours or station posting specified')
      go to 340
   52 if (ncval.gt.0) go to 80
c
c  incremental contours mode
      if (dcval.ge.0.0) go to 70
      write(*,60)
   60 format(' %dcval less than zero')
      go to 340
   70 ixad=1
      go to 120
c
c  specified contours mode.
   80 if (ncval.eq.1) go to 110
c
c  check ascendency.
      do 100 i=2,ncval
      if (work(i).gt.work(i-1)) go to 100
      IF(acgrad(1).NE.0) THEN
        IF(acgrad(I).NE.acgrad(I-1)) GOTO 100
      END IF
      write(*,90)
90    format(' %non-ascending specified contours')
      go to 340
  100 continue
  110 ixad=ncval+1
c
c  open grid file for preliminary check.
  120 nwkres=nwkres-ncval
      call openck(igrid,xo,yo,delx,dely,
     1 work(ixad),nwkres,iquad)
      if (ncol.eq.0) then
        ifile=' '
        go to 340
      endif
      jgrid = igrid
      mcol = ncol
      nrowp = nrow
      xxx(1)=xx(1)
      xxx(2)=xx(2)
      yyy(1)=yy(1)
      yyy(2)=yy(2)

      call setnic(ier)
      if(ier.ne.0) then
        print *,'error in subroutine setnic'
        go to 340
      endif 

c*****INITIAL WHITE COLOR FROM PLOT SYSTEM(pxz99.cmn)
      iwhite = jcol
c*****SET COLOR FOR OPTIONS
      if(ctype.eq.'l'.and.iplotr.eq.11) call remap3

      if(ctype.ne.'l') then
c*****RASTER CONTOURING
        call scalsc(1,ncol,1,nrow)
        call rgrd(work,igrid,speed,ierr)
        if(ierr.ne.0) go to 340
        close(igrid)
        igrid=igrid+1
121     rewind igrid

        read(igrid,err=330,iostat=icheck) title1,header,ip1,ip2,
     &  ncol,nrow,nz,xo,delx,yo,dely
        call gmax(igrid,fltmax,ncol,work,cr(1),cr(2))
        if(cmin.ne.-fltmax) cr(1)=amax1(cr(1),cmin)
        if(cmax.ne.fltmax) cr(2)=amin1(cr(2),cmax)

        call scalsc(1,ncol,1,nrow)
        if(ctype.eq.'s') call csrel(work,nwork,igrid,ldev,ierr)
        call grdclr(work,work(ncol+1),cr,igrid,ldev,numcol,black,
     &  iblack,ierr)
        close(ldev)
        if(ierr.eq.1) go to 340
        mcol = ncol
        if(ifile3.ne.blank) then
        rewind igrid3
           read(igrid3,err=335,iostat=icheck) title4,ip1,ip2,
     &     ncol,nrow,nz,xo,delx,yo,dely
           call gmax(igrid3,fltmax,ncol,work,cr(1),cr(2))
           read(igrid3,err=335,iostat=icheck) title4,ip1,ip2,
     &     ncol,nrow,nz,xo,delx,yo,dely
           nwkres=nwork
           ixad = 1
           ncval = 0
           dcval = 0.
           cmin = -fltmax
           cmax = fltmax
           if(cr(1).eq.cr(2)) dcval=1.
           call setax(cr,dcval,20,nchar,fmtc)
           idashs = 0
           jcdash(1) = 999
           linet = -7
           jgrid = igrid3
           go to 123
        endif
        go to 205
      endif
c
c  slice up core
  123 if(iquad.eq.3) go to 150
      nrowt=4*(nwkres-ncol)/(5*ncol+4)
      if(nrowt.ge.2) go to 140
c
  125 write(*,126)
  126 format(' %insufficient memory')
      go to 340
c
  140 idad=ixad+ncol
      iyad=nwork-nrowt+1
      ifad=idad+nrowt*ncol
      go to 160
c
  150 nrowt=4*nwkres/(13*ncol)
      if(nrowt.lt.2) go to 120
      k=nrowt*ncol
      idad=ixad+k
      iyad=nwork-k+1
      ifad=idad+k
c
  160 if(iquad.eq.3) go to 200
      k=ixad+ncol-1
      if(delx.ne.0) go to 180
      do 170 i=ixad,k
  170 work(i)=work(i)*xxscal
      go to 200
  180 xo=xo*xxscal
      delx=delx*xxscal
      do 190 i=ixad,k
      work(i)=xo
  190 xo=xo+delx
c
  200 npass=(nrow+nrowt-3)/(nrowt-1)
      jres=1+nrow-nrowt-(npass-2)*(nrowt-1)
c
c   branch around contour trace
c
      IF(HACHLM.LT.0.) HACHLM=HACHSP*7.

        call hacher(npass,NROWT,YO*YYSCAL,DELY*YYSCAL,
     1  hachln,hachsp,HACHGP,HACHMX,HACHLM,HACHVB,CONLIM,delb,
     2  work(1),work(8001),work(12001),ier)
        if(ier.ne.0) go to 340

      if(dcval.eq.0. .and. ncval.eq.0) go to 205
      call conttr(work(ixad),work(iyad),work(idad),
     1 iwork(ifad),work,nrowt,ncol,xxscal,yyscal,gflg,
     1 yo*yyscal,dely*yyscal,iquad,npass,jres,jgrid,
     1 ixad,iyad,ier)
      if(ier.ne.0) go to 340
      call gather(ier)
      if(ier.ne.0) go to 340
c
c  rescale in grid data units
c
205   if(.not.extra.or.icapt.ne.0) go to 211
      call scale(xxx,yyy,xp1,yp1,3,ier)
        if(ier.ne.0) then
          print *,'error in plot system subroutine scale'
          go to 340
        endif 
      if (sizel.le.0.) go to 130
c
c  plot titles
c
      call ptitle
c
c  plot axis
130   if(ctype.eq.'l') then
        jwhite = 0
      else
        jwhite = iwhite * 100
      endif
c
      if(adelx.eq.0.) go to 131
      call xaxis(xxx,yyy,xp1,adelx,jwhite+lintx,sizex,
     &           ifmtx,ncharx)
  131 if(adely.eq.0.) go to 132
      call yaxis(yyy,xxx,yp1,adely,jwhite+linty,sizey,
     &           ifmty,nchary)
c
c  subroutine state requires the world data bank 2
c  135 if(ibound .ne. 999) call state

c*****LINE DATA FILE
132   if(lxfile.ne.' ') then
        call lxplot(kdsk,ierr)
        if(ierr.ne.0) go to 340
      endif

c*****TEXT DATA FILE
      if(txfile.ne.' ') then
        call txplot(mdsk,ierr)
        if(ierr.ne.0) go to 340
      endif
 
c*****POST STATIONS
      if(ispost.ne.0) then
        call vector(xxx,yyy,szlab,ista,ier)
        if(ier.ne.0) go to 340
        rewind ista
      endif
 
      if(dcval.eq.0. .and. ncval.eq.0) go to 211
c*****PLOT HIGH AND LOW SYMBOLS
210   if(lowhi.eq.0) go to 211
      IF(LOWHI.GE.0) THEN
        NOHI=0
      ELSE
        NOHI=1
        LOWHI=-1*LOWHI
      END IF
      nc2=mcol+2*lowhi
      iw=2*lowhi+1
      if(nc2*(iw+4)+iw .gt. nwork) go to 211
      rewind igrid
      call hilow(work,work(nc2+1),work(2*nc2+1),work(3*nc2+1),
     & work(4*nc2+1),work(nc2*(iw+4)+1),nc2,iw,sizehi,DGRAD,NOHI,
     & igrid)
      lowhi=lohitm
c
c  plot lat-long
211   if(iproj.gt.0 .and. iproj.lt.999) call llpost

      if(dcval.eq.0. .and. ncval.eq.0) then
c       close plot
        call endpt(idim)
        go to 350
      endif

      if(icapt.eq.0) then

c******IDIM(1)=99 TRANSFERS THE WAIT FOR KEYBOARD ENTRY FROM THE PLOT
C******SYSTEM TO THE CALLING PROGRAm
       idim(1)=99
       call endpt(idim)
       dtype = ctype
       sigma = sigtmp
       if(jch.eq.il.or.jch.eq.jl) then
         nchar = nchtmp
         idashs = idatmp
         jcdash(1) = jcdtmp
         linet = 0
       endif
       if(ifile3.ne.blank)  then
         linet = 0
         jcdash(1) = jcdtmp
       endif

       call option(iplotr)
250    call getch(jch)

c******TOGGLE BETWEEN COLORS AND GRAY SHADES
        if((jch.eq.it.or.jch.eq.jt).and.ctype.ne.'s'
     &    .and.ctype.ne.'l') then
           if(ctype.eq.'c')then
             ctype = 'd'
           else if(ctype.eq.'d') then
             ctype = 'g'
           else if(ctype.eq.'g') then
             ctype = 'c'
           endif
           call pcolor(numcol)
           go to 250
        endif 
        ctype = dtype
          
c******ZOOM IN
        if(jch.eq.iz.or.jch.eq.jz) then
          call optclr(iplotr)

c******MUST USE NROWP INSTEAD OF NROW AS NROW GETS CHANGED IN CONTTR
          if(ctype.eq.'l') call scalsc(1,ncol,1,nrowp)
260       call zoom(icol1,icol2,irow1,irow2,'m',ierr)
          if(ierr.ne.0) then
          call zerr(iplotr)
          go to 260
          endif
          rewind igrid

          call subset(work,igrid,icol1,icol2,irow1,irow2,ierr)
          if(ierr.ne.0) go to 340
          isub = 1
          close(igrid)
          igrid=igrid+1
          rewind igrid
          dcval=dcvtmp
          ncval=ncvtmp
          cmin=cmntmp
          cmax=cmxtmp
          nchar=nchtmp
          fmtc(1:6)=fmttmp
          go to 31
        endif
c*******COLOR SHADED RELIEF WITH NEW PARAMETERS
        if((jch.eq.iv.or.jch.eq.jv).and.ctype.eq.'s') then
          dum2 = setvideomode(-1)
          idum = setbkcolor(1)
          dum2 = settextcolor(14)
304       write(*,'(2a\)') ' ENTER NEW AZIMUTH (0 IS NORTH; VALUES',
     &     ' ARE CLOCKWISE (0-360):'
          read *,sunaz
          write(*,'(a\)') ' ENTER NEW ANGLE FROM THE HORIZON (0-90):'
          read *,sunel
          if(sunaz.lt.0.or.sunaz.gt.360..or.sunel.lt.0..or.
     &       sunel.gt.90.) then
            write(*,'(a)') ' NEW VALUES ARE OUT OF RANGE'
            write(*,'(a\)') ' TRY AGAIN ? [y]: '
            read(*,'(a)') resp
            if(resp.eq.'n'.or.resp.eq.'N') then
             go to 340
            else
             go to 304
            endif
          endif
            idim(1) = 0
            call pltset(iplotr,xp1(4),yp1(4),idim)
            call scale(xx,yy,xp1,yp1,4,ier)
            call neatl
            cmin = cmntmp
            cmax = cmxtmp
            ncval = ncvtmp
            dcval = dcval2
            go to 121
        endif

c*******PUT LINE CONTOURS ON TOP OF COLORS OF SAME GRID
        if((jch.eq.il.or.jch.eq.jl).and.ctype.ne.'l'
     &    .and.ifile3.eq.blank) then
          if(black) then
            jclr = 0
            call mcolor(jclr)
  305       read(iblack,end=307) bx,by
            call makel(bx,by,bx,by)
            go to 305
  307       close (iblack)
            go to 250
         else
          call optclr(iplotr)
          call scale(xx,yy,xp1,yp1,4,ier)
          if(ier.ne.0) then
            print *,'error in subroutine scale'
            go to 340
          endif 
          if(ncval.gt.0) then
            do 310 i=1,ncval
  310       work(i)=acval(i)
            jcdtmp = jcdash(1)
            jcdash(1) = 999
          endif
          rewind igrid
          call openck(igrid,xo,yo,delx,dely,
     1    work(ixad),nwkres,iquad)
          if (ncol.eq.0) then
            ifile=' '
            go to 340
          endif
          nchtmp = nchar
          idatmp = idashs
          idashs = 0
          nchar = 0
          linet = -7
          extra = .false.
          jgrid = igrid
          go to 123
         endif
        endif

c*******PLOT A PROFILE FROM CONTOUR PLOT
        if(jch.eq.kp.or.jch.eq.jp) then
          call prf(igrid,ifile,speed,work,*340)
        endif

c*******ENTER OPTION - CLOSE PLOT
        go to 350
      else
c      dum2=setvideomode(-1)
       print *,' '
       print *,'files contour.cor and contour.val created'
      endif
      go to 340
  330 print *,'error no.',icheck,' reading header of grid file: ',
     & ifile
      ifile=' '
      go to 340
  335 print *,'error no.',icheck,' reading header of grid file: ',
     & ifile3
      ifile3=' '
  340 pause 'press ENTER to return to menu'
  350 if(isub.eq.0) then
        close(igrid)
      else
       call save(work,igrid)
      endif
      if(ifile3.ne.blank) close(igrid3)

      xxx(1)=0
      xxx(2)=0
      yyy(1)=0
      yyy(2)=0
      dcval=dcvtmp
      ncval=ncvtmp
      cmin=cmntmp
      cmax=cmxtmp
      nchar=nchtmp
      fmtc(1:6)=fmttmp
      lowhi=lohitm
      sizel=sizetm
      sizex=sizxtm
      sizey=sizytm
      pllx = pllxt
      plly = pllyt
      jcdash(1)=jcdtmp
      if(ctype.eq.'s') iplotr=9
      return
      end
C
C________________________________________________________________
C
C     SUBROUTINE  G M A X
C________________________________________________________________
C
      subroutine gmax(igrid,fltmax,na,z,zmin,zmax)
      dimension ihdr(16),z(na)
      zmin=fltmax
      zmax=-fltmax
      rewind(igrid)
      read(igrid) ihdr,nc,nr,nz,xo,dx,yo,dy
      if(nz.gt.1) go to 30
      if(dx.eq.0.) read(igrid)
      do 20 j=1,nr
      read(igrid,end=30) y,z
      do 10 i=1,nc
      if(z(i).gt.fltmax) go to 10
      if(z(i).gt.zmax) zmax=z(i)
      if(z(i).lt.zmin) zmin=z(i)
   10 continue
   20 continue
   30 rewind(igrid)
      return
      end
C
C________________________________________________________________
C
C     SUBROUTINE  O P T I O N
C________________________________________________________________
C
      subroutine option(iplotr)
      character istr1*4,istr2*6,istr3*5,istr4*3,jstrin*56
      character ctype*1,access*6
      common/captur/icapt,iwhite,ctype
      common/files/ifile,ifile2,ifile3,acfile,mxhach,access
      character*40 ifile,ifile2,ifile3,acfile,blank
      integer*2 dum2,jcolor,settextcolor,kcolor
      structure/rccoord/
        integer*2 row
        integer*2 col
      end structure
      record/rccoord/curpos
      data blank/' '/
      kcolor = iwhite
          if(iplotr.eq.9.or.iplotr.eq.10) then
            jcolor = 14
          else if(iplotr.eq.8) then
            jcolor = 2
          else if(iplotr.eq.11) then
            jcolor = 250
          endif
       if(ctype.eq.'c'.and.ifile3.eq.blank) then
         write(jstrin,'(2a)') 'L     P       T     ',
     &   ' Z    or ENTER'
         write(istr1,'(a)') 'ines'
         write(istr2,'(a)') 'rofile'
         write(istr3,'(a)') 'oggle'
         write(istr4,'(a)') 'oom'
       else if(ctype.eq.'c'.and.ifile3.ne.blank) then
         write(jstrin,'(2a)') '      P       T     ',
     &   ' Z    or ENTER'
         write(istr1,'(a)') '    '
         write(istr2,'(a)') 'rofile'
         write(istr3,'(a)') 'oggle'
         write(istr4,'(a)') 'oom'
       else if(ctype.eq.'s'.and.ifile3.eq.blank) then
         write(jstrin,'(2a)') 'L     P       V     ',
     &   ' Z    or ENTER'
         write(istr1,'(a)') 'ines'
         write(istr2,'(a)') 'rofile'
         write(istr3,'(a)') 'iew  '
         write(istr4,'(a)') 'oom'
       else if(ctype.eq.'s'.and.ifile3.ne.blank) then
         write(jstrin,'(2a)') '      P       V     ',
     &   ' Z    or ENTER'
         write(istr1,'(a)') '   '
         write(istr2,'(a)') 'rofile'
         write(istr3,'(a)') 'iew  '
         write(istr4,'(a)') 'oom'
       else 
         write(jstrin,'(2a)') '      P       Z     ',
     &   '      or ENTER'
         write(istr1,'(a)') '   '
         write(istr2,'(a)') 'rofile'
         write(istr3,'(a)') 'oom  '
         write(istr4,'(a)') '   '
       endif

        irow = 25
        if(iplotr.eq.10) irow=irow+5
        dum2 = settextcolor(kcolor)
        call settextposition(irow,1,curpos)
        call outtext(jstrin(1:38))
        dum2 = settextcolor(jcolor)
        call settextposition(irow,2,curpos)
        call outtext(istr1)
        call settextposition(irow,8,curpos)
        call outtext(istr2)
        call settextposition(irow,16,curpos)
        call outtext(istr3)
        call settextposition(irow,23,curpos)
        call outtext(istr4)
        return
        entry optclr(iplotr)
        dum2 = settextcolor(0)
        jstrin = ' '
        irow = 25
        if(iplotr.eq.10) irow=irow+5
        call settextposition(irow,1,curpos)
        call outtext(jstrin(1:38))
        return
        entry zerr(iplotr)
        kcolor = iwhite
        dum2 = settextcolor(kcolor)
        jstrin = 'wrong click sequence'
        irow = 25
        if(iplotr.eq.10) irow=irow+5
        call settextposition(irow,1,curpos)
        call outtext(jstrin(1:20))
        call sleep(2.)
        jstrin = 'click lower-left & then upper-right'
        call settextposition(irow,1,curpos)
        call outtext(jstrin(1:35))
        return
        end
C
C________________________________________________________________
C
C     SUBROUTINE  P R F
C________________________________________________________________
C
      subroutine prf(igrid,ifile,speed,work,*)
      dimension work(1)
      dimension idim(10)
      character*(*) ifile,speed
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     & ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common /concom/ ncol,nrow,bmin,bmax,
     & grad,gflg,ijs,ije,ijsi,ijei,prime,ij4,cont,
     & fltmax,lmult(0:3),idashs,linet,sigma,nsig
      character*1 ctype
      common/captur/icapt,iwhite,ctype
      character title4*56
      character*16 fmtx,fmty
      integer ifmtx(4),ifmty(4)
      integer*2 jch
      integer*4 remappalette
      equivalence (ifmtx,fmtx),(ifmty,fmty)
          call optclr(iplotr)
          if(ctype.eq.'l') then
            call scalsc(1,ncol,1,nrow)
            call rgrd(work,igrid,speed,ierr)
            if(ierr.ne.0) return 1
            close(igrid)
            igrid=igrid+1
            rewind igrid
            read(igrid,err=20,iostat=icheck) title4,ip1,ip2,
     &      ncol,nrow,nz,xo,delx,yo,dely
            call scalsc(1,ncol,1,nrow)
          endif
          call zoom(icol1,icol2,irow1,irow2,'p',ierr)
          rewind igrid
          n640 = 640
          call profil(igrid,ifile,work,icol1,irow1,icol2,irow2,
     &    work(n640 + 1),work(n640 *2 + 1),np,ier)
          if(ier.ne.0) return 1
          xx(1) = work(n640 * 2 + 1)
          xx(2) = xx(1) + float(np-1)
          yy(1) = 1.0e37
          yy(2) = -1.0e37
          do 10 i=1,np
          if(work(n640+i).gt.yy(2)) yy(2)=work(n640+i)
          if(work(n640+i).lt.yy(1)) yy(1)=work(n640+i)
10        continue
          idim(1) = 0
          call pltset(iplotr,xp1(4),yp1(4),idim)
          ncxtmp = ncharx
          ncytmp = nchary
          fmxtmp = fmtx
          fmytmp = fmty
          adxtmp = adelx
          adytmp = adely
          sixtmp = sizex
          siytmp = sizey
          sizex = .18
          sizey = .18
          adelx = 0
          adely = 0
          call setax(xx,adelx,20,ncharx,fmtx)
          call setax(yy,adely,20,nchary,fmty)
          xp1(3) = (nchary+1) * sizey
          yp1(3) =  2.
          xp1(1)=xp1(4)- xp1(3) -.2
          yp1(1)= 3.
          call scale(xx,yy,xp1,yp1,4,ier)
          if(ier.ne.0) then
            print *,'error in subroutine scale'
            return 1
          endif 
          call neatl
          call xaxis(xx,yy,xp1,adelx,lintx,sizex,
     &               ifmtx,ncharx)
          call yaxis(yy,xx,yp1,adely,linty,sizey,
     &               ifmty,nchary)
          if(iplotr.ne.8) then
            idum = remappalette(14,#153f3f)
            icolor=1400
          else
            icolor=200
          endif
          call line(work(n640 * 2 +1),work(n640 + 1),np,0,icolor)
          ncharx = ncxtmp
          nchary = ncytmp
          fmtx = fmxtmp
          fmty = fmytmp
          adelx = adxtmp
          adely = adytmp
          sizex = sixtmp
          sizey = siytmp
          idim(1)=99
          call endpt(idim)
          call getch(jch)
          return
20        print *,'error no.',icheck,' reading header of grid file: ',
     &    ifile
          ifile=' '
          return 1
          end
C
C________________________________________________________________
C
C     SUBROUTINE  N G R I D
C________________________________________________________________
C
      subroutine ngrid(ista,*)
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     & ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),
     1             baslat(3),
     & iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     & phi1,phi2
      common /vect/ ispost,lowhi,nid,ncharv,szpost,vmin,vmax,
     & lifmtv(10),lfmtv(4),ich(20),lchid(20),DGRAD,sizehi,szlab
      common /contrc/ cmin,cmax,dcval,ncval,nsec,gradi,
     1                acdel(200),acgrad(200),jcdash(200),
     2                ncval2,acsize(200),acmin(200),acmax(200)
      character*1 ctype
      common/captur/icapt,iwhite,ctype
      dimension idim(10)
      ctype='l'
      ncval=0
      dcval=0
      xx(1)=xxx(1)
      xx(2)=xxx(2)
      yy(1)=yyy(1)
      yy(2)=yyy(2)
      call setnic(ier)
        if(ier.ne.0) then
          print *,'error in subroutine setnic'
          return 1
        endif 
      call scale(xxx,yyy,xp1,yp1,3,ier)
        if(ier.ne.0) then
          print *,'error in plot system subroutine scale'
          return 1
        endif 
      if(ispost.ne.0) call vector(xxx,yyy,szlab,ista,ier)
        if(ier.ne.0) return 1
      call endpt(idim)
      rewind ista
      return
      end
C
C________________________________________________________________
C
C     SUBROUTINE  S E T N I C
C________________________________________________________________
C
      subroutine setnic(ier)
c
c  general setup of contour niceties.
c
      common /titls/ title1,title2,title3,fmtx,fmty
      common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     & ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     & lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
      common /llp/ latm(3),latx(3),longm(3),longx(3),cm(3),
     1             baslat(3),
     & iproj,xxx(2),yyy(2),sizep,unit,ip,neat,tint,itpost,ibound,
     & phi1,phi2
      COMMON /LXCB/ LXFILE,LXFMT,LXPROJ,LXUNIT,LXTYPE
      common/txcb/txfile
      character*1 ctype
      common/captur/icapt,iwhite,ctype
c
      dimension idim(1),ifmtx(4),ifmty(4)
      character*40 title1,title2,title3,blankt,LXFILE,txfile
      character*16 fmtx,fmty,blankf,LXFMT
      real latm,latx,longm,longx
      dimension it1(10),it2(10),it3(10)
      equivalence (it1,title1),(it2,title2),(it3,title3)
      equivalence (ifmtx,fmtx),(ifmty,fmty)
      data idim(1)/0/,blankf/' '/,blankt/' '/,ospace/.35/
c
      tspace=0.
      if (sizel.lt.0.) sizel=.12
      if(sizel.ne.0.) then
        if(iplotr.eq.8.or.iplotr.eq.11) sizel = sizel * 1.5
        if(title1.ne.blankt) then
          tspace=tspace+1.
          n=leftj(title1)
          if(iplotr.ne.5) then
            if((n * sizel).gt.9.) sizel = 9./float(n)
          endif
        endif
        if(title2.ne.blankt) then
          tspace=tspace+1.
          n=leftj(title2)
          if(iplotr.ne.5) then
            if((n * .75 * sizel).gt.9.) sizel = 9./(n * .75)
          endif
        endif
        if(title3.ne.blankt) then
          tspace=tspace+1.
          n=leftj(title3)
          if(iplotr.ne.5) then
            if((n * .75 * sizel).gt.9.) sizel = 9./(n * .75)
          endif
        endif
      endif
      sizelb=1.5*sizel
      if(adelx.eq.0.0 .and. ncharx.eq.0) go to 1
      if(fmtx.ne.blankf .and. ncharx.ge.0) go to 1
      call setax(xxx,adelx,20,ncharx,fmtx)
    1 if(adely.eq.0.0 .and. nchary.eq.0) go to 2
      if(fmty.ne.blankf .and. nchary.ge.0) go to 2
      call setax(yyy,adely,20,nchary,fmty)
    2 if (sizex.lt.0.) sizex=.12
      if(iplotr.eq.8.or.iplotr.eq.11) sizex = sizex * 1.5
      if (sizey.lt.0.) sizey=.12
      if(iplotr.eq.8.or.iplotr.eq.11) sizey = sizey * 1.5
      if (sizep.lt.0.) sizep=.12
      if (ncharx.lt.0) ncharx=0
      if (nchary.lt.0) nchary=0
      if (lintx.lt.1) lintx=5
      if (linty.lt.1) linty=5
      if(pllx.le.0. .and. (iproj.ne.0 .and. iproj.ne.999)) then
        if(sizep.eq.0.) sizep = .12
        pllx=12.*sizep
      endif
      if(plly.le.0. .and. (iproj.ne.0 .and. iproj.ne.999)) then
        if(sizep.eq.0.) sizep = .12
        plly= 3. * sizep+sizelb*(tspace+.5) + ospace 
      endif
      if(pllx.eq.0. .and. plly.eq.0.) sizep=0.
c
c  margin requirement setup.
c
   20 if (pllx.le.0.) go to 30
      xp1(3)=pllx
      go to 40
   30 xp1(3)=(nchary+1)*sizey
   40 if (plly.le.0.) go to 50
      yp1(3)=plly 
      go to 60
   50 yp1(3)=(ncharx+1)*sizex+(tspace+.5)*sizelb + ospace
c
   60 dx=xx(2)-xx(1)
      dy=yy(2)-yy(1)
      call pltset(iplotr,xp1(4),yp1(4),idim)
c
c  check scaling
c
      if (xscale.le.0.) go to 70
      if (yscale.le.0.) yscale=xscale
      go to 80
   70 if (yscale.le.0.) go to 90
      xscale=yscale
   80 xxscal=sign(1./xscale,dx)
      yyscal=sign(1./yscale,dy)
c
c  fixed scaling.
c
      xp1(1)=abs(dx*xxscal)
      yp1(1)=abs(dy*yyscal)
      if(iplotr.eq.5) then
        xp1(4)=xp1(1)+xp1(3)+sizey+13.*sizep + 1.5
        yp1(4)=yp1(1)+yp1(3)+sizex+3.*sizep 
      else
        xp1(4)=xp1(1)+xp1(3)+sizey + 1.5
        yp1(4)=yp1(1)+yp1(3)+sizex 
      endif
      go to 120
c
c  relative scaling, eg. xxscal=yyscal=0.
c
   90 xp1(4)=amin1(xp1(4),10.)
      yp1(4)=amin1(yp1(4),8.)
      if(iplotr.eq.5) then
        xp1(1)=xp1(4)-xp1(3)-sizey-6.*sizep - 1.5
        yp1(1)=yp1(4)-yp1(3)-sizex-3.*sizep 
      else
        xp1(1)=xp1(4)-xp1(3)-sizey - 1.5
        yp1(1)=yp1(4)-yp1(3)-sizex 
      endif
      if (xp1(1).gt.0..and.yp1(1).gt.0.) go to 110
      write(*,100)
  100 format(' %margin requires all plot area')
      ier=2
      go to 140
  110 xxscal=xp1(1)/dx
      yyscal=yp1(1)/dy
      if(mscale.eq.0.0) then
        xy=amin1(abs(xxscal),abs(yyscal))
        xxscal=sign(xy,xxscal)
        yyscal=sign(xxscal,yyscal)
      endif
      xp1(1)=abs(dx*xxscal)
      yp1(1)=abs(dy*yyscal)
c
c  initial labelling scale call
c
c
  120 call scale(xx,yy,xp1,yp1,4,ier)
      if (ier.ne.0) go to 140
      if(icapt.eq.0) then
c       if(iplotr.eq.5) write(*,65) xp1(4),yp1(4)
c  65   format(/,' plotter size(inches): x=',f7.2,'  y=',f7.2)
        if(neat.eq.0) call neatl

c*****ICAPT=1;NO PLOTTING - JUST CAPTURING CONTOUR COORDINATES
      else
        xxscal=1.
        yyscal=1.
      endif
c
c  rescale plotter for grid.
c
      xx(1)=xx(1)*xxscal
      xx(2)=xx(2)*xxscal
      yy(1)=yy(1)*yyscal
      yy(2)=yy(2)*yyscal
      call scale(xx,yy,xp1,yp1,3,ier)
  140 return
      entry ptitle
c
c  plot titles
c
      xcent=0.5*xp1(1)+xp1(3)
      yt=sizelb * .5 + ospace
      if(title3.eq.blankt) go to 127
      n=leftj(title3)
      xt=xcent-float(n/2)*.75*sizel
      if(xt.lt.sizel) xt = sizel
      call vchar(xt,yt,it3,n,3,.75*sizel,0.,0.,0.)
      yt=yt+sizelb
127   if(title2.eq.blankt) go to 128
      n=leftj(title2)
      xt=xcent-float(n/2)*.75*sizel
      if(xt.lt.sizel) xt = sizel
      call vchar(xt,yt,it2,n,3,.75*sizel,0.,0.,0.)
      yt=yt+sizelb
128   if(title1.eq.blankt) go to 130
      n=leftj(title1)
      xt=xcent-float(n/2)*sizel
      if(xt.lt.sizel) xt = sizel
      call vchar(xt,yt,it1,n,3,sizel,0.,0.,0.)
130   return
      end
C
C
C
C________________________________________________________________
C
C     SUBROUTINE  S E T A X
C________________________________________________________________
C
      subroutine setax(x,dx,maxint,nch,fmt)
c  adjust interval and labeling format
c  input x-min max range, optional dx-spacing and
c  maxint-intervals
c  returns dx, nch-number of significant figures, fmt-labeling
c  format
      dimension x(2)
      character fmt*(*)
      ixpn(r)=int(alog10(abs(r))+100.)-100
      fmt='(1pe13.6)'
      nch=13
      if(dx.ne.0.) go to 5
      if(maxint.le.0) maxint=20
      t=abs(x(2)-x(1))/float(maxint)
      if(t.lt.1.e-20) return
      p10=10.**ixpn(t)
      p10=sign(1.0,t)*p10
      t1=t/p10
      if(t1.le.1.0) dx=p10
      if(t1.gt.1.0) dx=2.*p10
      if(t1.gt.2.0) dx=5.*p10
      if(t1.gt.5.0) dx=10.*p10
    5 idecm=0
      n10=ixpn(dx)
      if(n10.lt.0) idecm=iabs(n10)
      xmax =  amax1(abs(x(1)),abs(x(2)) )
      if(xmax.eq.0.) then
        n10 = 0
        go to 7
      endif
      n10=ixpn( xmax )
      iw=4+idecm
    7 if(n10.ge.0) iw=3+n10+idecm
      if(iw.gt.9) go to 11
      write(fmt,10) iw,idecm
   10 format('(f',i1,'.',i1,')' )
      nch=iw
      if(idecm.eq.0) nch=nch-1
   11 return
      end
C
C________________________________________________________________
C
C     FUNCTION  L E F T J
C________________________________________________________________
C
        function leftj(a)
c  left justifies a string and returns the position
c  of the last nonblank character
        character a*(*)
        n=len(a)
        if(a(1:1).ne.' ') go to 15
        do 1 m=2,n
1       if(a(m:m).ne.' ') go to 5
        leftj=0
        return
5       i2=1
        do 10 i=m,n
        a(i2:i2)=a(i:i)
        a(i:i)=' '
10      i2=i2+1
        n=n-m+1
15      do 20 leftj=n,1,-1
20      if(a(leftj:leftj).ne.' ') go to 25
25      return
        end
c******************************************************************************
      subroutine perout(nout,ncont,ipass,npass,perstr)
           common /setxy/ xx(2),yy(2),xp1(4),yp1(4),iplotr,sizel,
     &     ncharx,nchary,sizex,sizey,adelx,adely,pllx,plly,
     &     lintx,linty,xscale,yscale,xxscal,yyscal,mscale,delx,dely
           character*1 ctype
           common/captur/icapt,iwhite,ctype
           integer*2 dum2,jcolor,settextcolor
           structure/rccoord/
            integer*2 row
            integer*2 col
           end structure
           record/rccoord/curpos
           integer istri(4),jstri(4)
           character*9 perstr
           character*16 istrin,jstrin
           equivalence(istrin,istri)
           equivalence(jstrin,jstri)

           if(nout.eq.1.and.ipass.eq.1) then
             jcolor = iwhite
             dum2 = settextcolor(jcolor)
             call settextposition(25,1,curpos)
             if(iplotr.eq.10) call settextposition(30,1,curpos)
             opass =1./float(npass)
             if(float(ncont)/opass.lt.10.) return
             jperc=1
             xp= xp1(3) 
             yp= .15
             write(istrin,'(2a)') '  1 % ',perstr
             jstrin(1:3)='  1'
              call outtext(istrin)
           endif

           if(float(ncont)/opass.lt.10.) return
           ppass = float(ipass-1)/float(npass)
           tcont = float(nout) / float(ncont)
           iperc=ifix((tcont * opass + ppass) * 10. + .000001)

           if(iperc.eq.jperc) then
             write(istrin,'(i3)') iperc*10
              call settextposition(25,1,curpos)
              if(iplotr.eq.10) call settextposition(30,1,curpos)
              call outtext(istrin(1:3))
             jperc=jperc+1
             jstri=istri
           endif

           if(iperc.eq.10) then
             write(istrin,'(3a)') jstrin(1:3),' % ',perstr
             dum2 = settextcolor(0)
             call settextposition(25,1,curpos)
             if(iplotr.eq.10) call settextposition(30,1,curpos)
             call outtext(istrin)
           endif
      return
      end
c***************************************
      interface to integer*2 function system[c]
     & (str[reference])
      character*1 str
      end
c***************************************
      subroutine save(z,igrid)
      include 'fgraph.fd'
      integer*2 dum,system
      character*1 resp
      character*40 fname,ofile
      character*64 title
      character*90 string
      logical exists
      dum = setvideomode($DEFAULTMODE)
        write(*,'(///2a\)') ' DO YOU WANT TO SAVE THE LAST ZOOMED',
     &   ' SUBSET FILE [n]: '
        read(*,'(a)') resp
        if(resp.eq.'y'.or.resp.eq.'Y') then
          inquire(unit=igrid,name=fname)
10        write(*,'(a\)') ' ENTER OUTPUT FILE NAME: '
          read(*,'(a)') ofile
          inquire(file=ofile,exist=exists)
          if(exists) then
            write(*,'(/3a)') ' FILE ',ofile,' ALREADY EXISTS'
            write(*,'(a\)') ' DO YOU WANT TO ENTER ANOTHER NAME [y]: '
            read(*,'(a)') resp
            if(resp.ne.'n'.and.resp.ne.'N') go to 10
            string='copy '//fname//' '//ofile//''c
            i = system(string) 
            if(i.eq.-1) go to 15
            go to 30
          endif
          string='ren '//fname//' '//ofile//''c
          i = system(string) 
          if(i.eq.-1) go to 15
          go to 30
        endif
        go to 30
15      rewind igrid
        igrid2 = igrid + 1
        open(igrid2,file=ofile,form='unformatted',
     &       status='unknown')
        read(igrid) title,nc,nr,nz,xo,dx,yo,dy
        write(igrid2) title,nc,nr,nz,xo,dx,yo,dy
        do 20 i=1,nr
        call rwsave(igrid,z,nc,'r')
        call rwsave(igrid2,z,nc,'w')
20      continue
        close(igrid2)
30      close(igrid)
        return
        end
c***************************************
        subroutine rwsave(iunit,z,nc,rw)
        dimension z(nc)
        character rw
        if(rw.eq.'r') then
        read(iunit) y,z
        else
        write(iunit) y,z
        endif
        return
        end

