c
c
c *** graph ***
c
c
      subroutine graph(gtype,nyears,nfactors,years,factors,values,
     &                title1,title2)
c-------------------------------------------------------------------------
c  titlparm(1) : title1 color
c  titlparm(2) : title1 size
c  titlparm(3) : title1 font
c  titlparm(4) : title2 color
c  titlparm(5) : title2 size
c  titlparm(6) : title2 font
c
c  factparm(1) : factor color
c  factparm(2) : factor size
c  factparm(3) : factor font
c-------------------------------------------------------------------------
      implicit integer*2 (a-z)
      integer*2 gtype,nyears,nfactors
      real      values(10,10)
      character*4 years(10)
      character*15 factors(10)
      character*80 title1,title2
      character dummy

      dimension titlparm(3,2),factparm(3),setup(19),limits(66),echoxy(2)

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device
      common /graph2/ maxfln

      data titlparm /5,1300,1,3,650,1/
      data factparm /5,1,1/
      data setup /0,1,1,3,1,2,1,0,0,1,1,68,73,83,80,76,65,89,32/
c
c --- setup graph common
c
      ll=1
      ul=2
      ur=3
      lr=4
      x=1
      y=2
      window(x,ll)=9200
      window(y,ll)=2000
      window(x,ul)=9200
      window(y,ul)=27000
      window(x,ur)=28000
      window(y,ur)=27000
      window(x,lr)=28000
      window(y,lr)=2000
c
c --- open workstation
c
      status=vopnwk(setup,device,limits)
      if(status.eq.0) goto 100
      status=vqerr()
      write(*,10) status
 10   format(' * ERROR * unable to open device * (',i5,')')
      goto 999
c
c --- plot titles
c
 100  continue
      titlebot=32767
      maxfln=15
      if(limits(1).le.320) maxfln=8
      call setcolor(limits(14),limits(36),limits(40),backcolr,fillcolr)
      status=vsbcol(device,backcolr)
      status=vsfcol(device,fillcolr)
      status=vclrwk(device)
      call plotitle(title1,1,titlparm)
      call plotitle(title2,2,titlparm)
c
c --- plot cake or pie
c
      if(gtype.eq.1)then
         call plotpie(values,nfactors)
      elseif (gtype.eq.2) then
         call plotcake(years,nyears,values,nfactors)
      else
         call plotbar(years,nyears,values,nfactors)
      endif
c
c --- plot factors
c
      call plotfact(factors,nfactors,factparm)
c
c --- close workstation and return
c
 999  continue
      status=vrqstr(device,1,0,echoxy,dummy)
      status=vscurm(device,3)
      status=vencur(device)
      status=vclswk(device)
      return
      end
c
c
c *** plotitle ***
c
c
      subroutine plotitle(text,linenum,parms)
      implicit integer*2 (a-z)
      character*80 text
      integer*2 linenum,parms(3,2)
      real real

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      data ledge,redge /0,32767/

c
c --- set graphic text color, size, and font
c
      status=vstcol(device,parms(1,linenum))
      status=vsthgt(device,parms(2,linenum),chrwid,celwid,celhgt)
      status=vstfnt(device,parms(3,linenum))
c
c --- position cursor and output text
c
      status=vstaln(device,0,0,horzrl,vertrl)
      textx=ledge+real(redge-ledge-strlen(text)*celwid)/2.0
      if(textx.lt.0) textx=0
      titlebot=titlebot-celhgt*1.5
      status=vgtxts(device,textx,titlebot,strlen(text),text)

      return
      end
c
c
c *** plotfact ***
c
c
      subroutine plotfact(factors,nfactors,parms)
      implicit integer*2 (a-z)

      character*15 factors(nfactors)
      character*80 text
      dimension parms(3),rgbin(3),rgbout(3),llur(2,2)

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device
      common /graph2/ maxfln

      data solid,hatch /1,2/
c
c --- setup graphictext
c
      status=vstcol(device,parms(1))
      status=vsthgt(device,parms(2),chrwid,celwid,celhgt)
      status=vstfnt(device,parms(3))
      status=vstaln(device,0,0,horzrl,vertrl)
      status=vsfint(device,solid)
c
c --- plot legend
c
      oboxh=window(2,2)-window(2,1)
      oboxw=window(1,1)-celwid
      iboxw=oboxw-2*celwid
      iboxh=oboxh/nfactors
      do 20 i=1,nfactors
         llur(1,1)=0
         llur(2,1)=window(2,1)+(i-1)*iboxh
         llur(1,2)=llur(1,1)+iboxw
         llur(2,2)=llur(2,1)+iboxh
         flen=strlen(factors(i))
         if(flen.gt.maxfln) flen=maxfln
         call ctrtxt(factors(i),flen,llur)
         llur(1,1)=llur(1,1)+iboxw+celwid
         llur(2,1)=(llur(2,1)+llur(2,2))/2.0-celhgt/2.0
         llur(1,2)=llur(1,1)+celwid
         llur(2,2)=llur(2,1)+celhgt
         status=vsfcol(device,factcolr(i))
         if(factstyl(i).ne.0) then
           status=vsfint(device,hatch)
           status=vsfstl(device,factstyl(i))
         endif
         status=vbar(device,llur)
20    continue

      return
      end
c
c
c *** plotcake ***
c
c
      subroutine plotcake(xtitles,numxs,values,numys)
      implicit integer*2 (a-z)

      integer*4 int
      character*4 xtitles(10)
      real values(10,10),val,maxfac
      dimension point(2,20),tic(4),llur(2,2)
      character*20 ticlab
      dimension areas(2,20,10)

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      data ticsiz,nvtics,chrhgt,solid,hollow,hatch /1000,4,461,1,0,2/

      areas(1,1,1)=window(1,4)
      areas(2,1,1)=window(2,4)
      areas(1,2,1)=window(1,1)
      areas(2,2,1)=window(2,1)
      pt=2
c
c --- plot window with ticks
c
      status=vsfint(device,hollow)
      llur(1,1)=window(1,1)
      llur(2,1)=window(2,1)
      llur(1,2)=window(1,3)
      llur(2,2)=window(2,3)
      status=vbar(device,llur)
      ntics=numxs-2
      xticspc=(window(1,4)-window(1,1))/(ntics+1)
      do 10 i=1,ntics
         tic(1)=window(1,1)+xticspc*i
         tic(2)=window(2,1)-ticsize/2
         tic(3)=tic(1)
         tic(4)=tic(2)+ticsize
         status=vpline(device,2,tic)
 10   continue
      ntics=nvtics
      yticspc=(window(2,3)-window(2,4))/(ntics+1)
      do 20 i=1,ntics
         tic(1)=window(1,3)-ticsize/2
         tic(2)=window(2,4)+yticspc*i
         tic(3)=tic(1)+ticsize
         tic(4)=tic(2)
         status=vpline(device,2,tic)
 20   continue
c
c --- label tics
c
      status=vstcol(device,3)
      status=vsthgt(device,chrhgt,chrwid,celwid,celhgt)
      do 30 i=1,numxs
         status=vgtxts(device,window(1,1)+(i-1)*xticspc-2*celwid,
     &                 window(2,1)-ticsize/2-celhgt,4,xtitles(i))
 30   continue
      call frange(1,values,int(numxs),int(numys),maxfac)
      do 40 i=1,nvtics+1
         call itochr(maxfac/(nvtics+1)*i,ticlab,count)
         status=vgtxts(device,window(1,4)+ticsize/2,
     &                 window(2,4)+i*yticspc-celhgt/2,count,ticlab)
 40   continue
c
c --- draw cake
c
      status=vsfint(device,solid)
      do 75 i=1,numys
         status=vsfcol(device,factcolr(i))
         if(factstyl(i).ne.0) then
           status=vsfint(device,hatch)
           status=vsfstl(device,factstyl(i))
         endif
         do 50 j=1,numxs
            val=0
            do 45 k=1,i
               val=val+values(j,k)
 45         continue
            point(1,j)=window(1,1)+(j-1)*xticspc
            point(2,j)=window(2,1)+int(val/maxfac*
     &                 real(window(2,2)-window(2,1)))
            pt=pt+1
            areas(1,pt,i)=point(1,j)
            areas(2,pt,i)=point(2,j)
 50      continue
         status=vpline(device,numxs,point)
         call afill(areas,i,pt)
         do 60 j=1,numxs
            areas(1,j,i+1)=areas(1,pt-j+1,i)
            areas(2,j,i+1)=areas(2,pt-j+1,i)
 60      continue
         pt=numxs
 75   continue

      return
      end
c
c
c *** plotbar ***
c
c
      subroutine plotbar(xtitles,numxs,values,numys)
      implicit integer*2 (a-z)

      integer*4 int
      character*4 xtitles(10)
      real values(10,10),maxfac,windht
      dimension tic(4),llur(2,2)
      character*20 ticlab

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      data ticsiz,nvtics,chrhgt,solid,hollow,hatch /1000,4,461,1,0,2/

c
c --- plot window with ticks
c
      status=vsfint(device,hollow)
      llur(1,1)=window(1,1)
      llur(2,1)=window(2,1)
      llur(1,2)=window(1,3)
      llur(2,2)=window(2,3)
      status=vbar(device,llur)
      ntics=numxs-1
      xticspc=(window(1,4)-window(1,1))/(ntics+1)
      do 10 i=1,ntics
         tic(1)=window(1,1)+xticspc*i
         tic(2)=window(2,1)-ticsize/2
         tic(3)=tic(1)
         tic(4)=tic(2)+ticsize
         status=vpline(device,2,tic)
 10   continue
      ntics=nvtics
      yticspc=(window(2,3)-window(2,4))/(ntics+1)
      do 20 i=1,ntics
         tic(1)=window(1,3)-ticsize/2
         tic(2)=window(2,4)+yticspc*i
         tic(3)=tic(1)+ticsize
         tic(4)=tic(2)
         status=vpline(device,2,tic)
 20   continue
c
c --- label tics
c
      status=vstcol(device,3)
      status=vsthgt(device,chrhgt,chrwid,celwid,celhgt)
      do 30 i=1,numxs
         status=vgtxts(device,window(1,1)+(i-1)*xticspc,
     &                 window(2,1)-ticsize/2-celhgt,4,xtitles(i))
 30   continue
      call frange(2,values,int(numxs),int(numys),maxfac)
      do 40 i=1,nvtics+1
         call itochr(maxfac/(nvtics+1)*i,ticlab,count)
         status=vgtxts(device,window(1,4)+ticsize/2,
     &                 window(2,4)+i*yticspc-celhgt/2,count,ticlab)
 40   continue
c
c --- draw bars
c
      windht=window(2,2)-window(2,1)
      barwid=xticspc/(numys+1)
      status=vsfint(device,solid)
      do 75 i=1,numxs
         xbase=window(1,1)+(i-1)*xticspc
         do 50 j=1,numys
            status=vsfcol(device,factcolr(j))
            if(factstyl(j).ne.0) then
              status=vsfint(device,hatch)
              status=vsfstl(device,factstyl(j))
            endif
            llur(1,1)=xbase+(j-1)*barwid
            llur(2,1)=window(2,1)
            llur(1,2)=llur(1,1)+barwid
            llur(2,2)=llur(2,1)+values(i,j)/maxfac*windht
            status=vbar(device,llur)
 50      continue
 75   continue

      return
      end
c
c
c *** itochr ***
c
c
      subroutine itochr(rnum,string,len)
      implicit integer*2 (a-z)

      real*4 rnum,rtemp
      character*1 string(20)
c
c --- determine string length
c
      rtemp=rnum
      do 10 i=1,20
         if(rtemp/10.0**i.lt.1.0) goto 20
 10   continue
c
c --- convert digits to characters
c
 20   do 30 k=i,1,-1
         j=int(amod(rtemp,10.0))
         string(k)=48+j
         rtemp=rtemp/10.0
 30   continue
      len=i

      return
      end
c
c
c *** plotpie ***
c
c
      subroutine plotpie(values,nfactors)
      implicit integer*2 (a-z)
      real values(10,10),real,totfact
      integer*4 int

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      data solid,hatch /1,2/

      xpiecntr=(int(window(1,1))+int(window(1,4)))/2
      ypiecntr=(int(window(2,1))+int(window(2,2)))/2
      pierds=(window(2,2)-window(2,1))/3
      totfact=0.0
      do 10 i=1,nfactors
         totfact=totfact+values(1,i)
 10   continue
      call vsort(values,factcolr,nfactors,factstyl)
      begang=0
      status=vsfint(device,solid)
      do 20 i=1,nfactors
         status=vsfcol(device,factcolr(i))
         if(factstyl(i).ne.0) then
           status=vsfint(device,hatch)
           status=vsfstl(device,factstyl(i))
         endif
         if(i.eq.nfactors) then
           endang=3600
         else
           endang=begang+values(1,i)/totfact*3600
         endif
         status=vpiesl(device,xpiecntr,ypiecntr,pierds,begang,endang)
         begang=endang
 20   continue

      return
      end
c
c
c *** ctrtxt ***
c
c
      subroutine ctrtxt(text,tlen,llur)
      implicit integer*2 (a-z)
      character text(tlen)
      dimension llur(2,2),attrib(10)
      real real

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      status=vqtatt(device,attrib)
      length=attrib(9)*tlen
      xstrt=llur(1,1)+real(llur(1,2)-llur(1,1)-length)/2.0
      ystrt=llur(2,1)+real(llur(2,2)-llur(2,1)-attrib(10))/2.0
      status=vgtxts(device,xstrt,ystrt,tlen,text)

      return
      end
c
c
c *** frange ***
c
c
      subroutine frange(rtype,values,nxs,nys,maxval)
      real values(10,10),coltot,maxcol,r,maxval
      integer*2 rtype

      maxcol=-1.0
      if(rtype.eq.1) then
         do 20 i=1,nxs
            coltot=0.0
            do 10 j=1,nys
               coltot=coltot+values(i,j)
 10         continue
            if(coltot.gt.maxcol) maxcol=coltot
 20      continue
      else
         do 27 i=1,nxs
            do 23 j=1,nys
               if(values(i,j).gt.maxcol) maxcol=values(i,j)

 23         continue
 27      continue
      endif

      if(maxcol.le.10.0) then
         maxval=10.0
      else
         do 30 i=1,20
            if(maxcol/10.0**i.lt.10.0) goto 40
 30      continue
 40      do 50 j=1,10
            r=maxcol/10.0**(i-1) + (j-1)
            if(amod(r,10.0).eq.0.0) goto 60
 50      continue
 60      maxval=r*10**(i-1)
      endif

      return
      end
c
c
c *** strlen ***
c
c
      integer*2 function strlen(string)
      character*1 string(80),period
      data period /';'/

      do 10 i=1,80
         if(string(i).eq.period) goto 20
 10   continue
      strlen=80
      return

 20   continue
      strlen=i-1
      return
      end
c
c
c *** afill ***
c
c
      subroutine afill(areas,anum,npts)
      implicit integer*2 (a-z)
      dimension areas(2,20,10),area(2,20)

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      do 10 i=1,npts
         area(1,i)=areas(1,i,anum)
         area(2,i)=areas(2,i,anum)
 10   continue
      status=vfarea(device,npts,area)

      return
      end
c
c
c *** setcolor ***
c
c
      subroutine setcolor(ncolrs,clrflg,maxclr,bckclr,filclr)
      implicit integer*2 (a-z)
      dimension rgb(3),rgbout(3)
      real real

      integer*2 window(2,4),backcolr,titlebot,factcolr(10),factstyl(10)
      common /graph1/ backcolr,factcolr,titlebot,factstyl,window,device

      if (ncolrs.ge.16) then
         do 20 i=8,16
            status=vqcolr(device,i-8,0,rgb)
            rgb(1)=real(rgb(1))*.75
            rgb(2)=real(rgb(2))*.75
            rgb(3)=real(rgb(3))*.75
            status=vscolr(device,i,rgb,rgbout)
 20      continue
         bckclr=4
         filclr=5
         j=0
         do 30 i=1,10
            j=j+1
            if(j.eq.bckclr) j=j+1
            factcolr(i)=j
            factstyl(i)=0
 30      continue
      elseif (ncolrs.ge.4) then
         rgb(1)=1000
         rgb(2)=1000
         rgb(3)=400
         status=vscolr(device,1,rgb,rgbout)
         rgb(1)=1000
         rgb(2)=400
         rgb(3)=1000
         status=vscolr(device,2,rgb,rgbout)
         rgb(1)=400
         rgb(2)=1000
         rgb(3)=400
         status=vscolr(device,3,rgb,rgbout)
         bckclr=1
         filclr=0
         j=2
         k=1
         do 130 i=1,10
            if(j.gt.ncolrs-1) j=2
            factcolr(i)=j
            factstyl(i)=k
            k=k+1
            if(k.gt.5)k=1
            j=j+1
 130     continue
      else
         bckclr=0
         filclr=1
         k=1
         do 230 i=1,10
            factcolr(i)=1
            factstyl(i)=k
            k=k+1
            if(k.gt.5)k=1
 230     continue
      endif

      return
      end
c
c
c *** vsort ***
c
c
      subroutine vsort(values,factcolr,nvals,factstyl)
      implicit integer*2 (a-z)
      real values(10,10),rtmp
      integer*2 factcolr(10),ftmp,factstyl(10)

      do 20 i=1,nvals-1
         do 10 j=i+1,nvals
            if(values(1,i).le.values(1,j)) goto 10
            rtmp=values(1,i)
            values(1,i)=values(1,j)
            values(1,j)=rtmp
            ftmp=factcolr(i)
            factcolr(i)=factcolr(j)
            factcolr(j)=ftmp
            ftmp=factstyl(i)
            factstyl(i)=factstyl(j)
            factstyl(j)=ftmp
 10      continue
 20   continue

      return
      end