h07709
s 00004/00007/00229
d D 1.7 83/03/08 13:41:58 mrk 7 6
c fixed bar width on smaller graphs
e
s 00013/00008/00223
d D 1.6 83/02/28 21:53:35 mrk 6 5
c changed how step graphs are defined
e
s 00006/00008/00225
d D 1.5 83/02/22 14:15:58 mrk 5 4
c modified to label bars correctly, offset label more
e
s 00034/00029/00199
d D 1.4 83/02/10 13:47:51 mrk 4 3
c modified to support line attributes for stick and step graphs
e
s 00017/00006/00211
d D 1.3 83/02/07 19:36:24 mrk 3 2
c modified label point, use fudge factor, negative values
e
s 00042/00032/00175
d D 1.2 83/01/28 13:52:00 tes 2 1
c initial_internal_update
e
s 00207/00000/00000
d D 1.1 83/01/28 13:02:20 tes 1 0
c date and time created 83/01/28 13:02:20 by tes
e
u
tes
mjb
mrk
mmm
U
t
T
I 1
subroutine gpgrbr (type, count, xdata, ydata, stkary)
########################################################################
#                                                                      #
#          THIS MATERIAL IS CONFIDENTIAL AND IS FURNISHED UNDER        #
#          A WRITTEN LICENSE AGREEMENT.  IT MAY NOT BE USED,           #
#          COPIED OR DISCLOSED TO OTHERS EXCEPT IN ACCORDANCE          #
#          WITH THE TERMS OF THAT AGREEMENT.                           #
#                                                                      #
#          COPYRIGHT (C) 1982 GRAPHIC SOFTWARE SYSTEMS INC.            #
#          ALL RIGHTS RESERVED.                                        #
#                                                                      #
#     Function: display a data set as a bar, step, or stick graph      #
#                                                                      #
#     Input Parameters:                                                #
#            type   - type of graph (3-bar, 4-step, 5-stick)           #
#            count  - length of data array                             #
#            xdata  - array of x coordinates                           #
#            ydata  - array of y coordinates                           #
#            stkary - array used to stack current graph extents        #
#                                                                      #
#     Output Parameters:                                               #
#            stkary - array used to stack current graph extents        #
#                                                                      #
#     Routines Called:                                                 #
#            imove  - modify current position for later action         #
#            gpbar  - display a bar                                    #
#            gpstck - put a value into the stack arrray                #
#            gpdraw - do a 2d draw                                     #
#            gpcstk - get a value from the stack array                 #
#            gpxfrm - transform a data point                           #
#            gpsatt - Set an attribute on the current device           #
#                                                                      #
########################################################################
 
integer type, count
real xdata(1), ydata(1), stkary(1)
 
D 3
integer i, j, index, klustr, iup, ibase, errind, ilen, istr(8), gr2chr, iout
E 3
I 3
integer i, j, index, klustr, iup, ibase, errind, ilen, istr(8), gr2chr, iout,
        idir, base, justfy(4)
E 3
D 2
real data(2), dbase(2), dtop(2), x, y, temp, xd, yd, 
     width, barwid, offset, xlast, ylast

PLOTxREALS PLOTxGETREAL
E 2
I 2
D 6
real data(2), dbase(2), dtop(2), x, y, temp, xd, yd, temp2,
E 6
I 6
real data(2), dbase(2), dtop(2), x, y, temp, xd, yd, temp2, delta,
E 6
D 7
     width, barwid, offset, xlast, ylast, gtreal
E 7
I 7
     offset, xlast, ylast, gtreal
E 7
E 2
 
include(`pltcom')
I 3

data justfy /2, 8, 4, 6/  # Different text justifications
E 3
 
   # Set up the environment
   nclip = YES       # Turn clipping on
I 2

   if (nbrdir == 0) {   # Set up environmentals for bar direction
      ibase = 1
      iup = 2
D 7
      width = xvwlng/32767.
E 7
      }
   else {
      ibase = 2
      iup = 1
D 7
      width = yvwlng/32767.
E 7
      }

   # If a base line has been specified, output it
   if (nbstat != 0) {
      
      call gpsatt (SETxPOLYLINExCOLORxINDEX, nbsclr, iout)
      call gpsatt (SETxPOLYLINExLINETYPE, nbastl, iout)
      nlstyl = iout

      temp2 = zlwid    # Stack and reset line width
      zlwid = zbaswd

      data(1) = zrstrt(1)
      data(2) = zrstrt(2)
      data(iup) = zbrbas
      call gpxfrm (1, data(1), temp)
      data(1) = temp
      call gpxfrm (2, data(2), temp)
      data(2) = temp
      call imove (ABSOLUTE, data(1), data(2))
      data(ibase) = zrend(ibase)
      call gpxfrm (ibase, data(ibase), temp)
      data(ibase) = temp
      call gpdraw (data(1), data(2))

      zlwid = temp2  # Restore line width
      nbstat = NO   # no more base lines
      }
E 2
 
D 4
   call gpsatt (SETxPOLYLINExCOLORxINDEX, nbcolr, iout)
E 4
I 4
   if (type == BARxCHART) {  # Set appropriate attributes
E 4
 
D 4
   # Set the bar fill color index
   call gpsatt (SETxFILLxCOLORxINDEX, nbcolr, iout)
E 4
I 4
      # Set the bar fill color index
      call gpsatt (SETxFILLxCOLORxINDEX, nbcolr, iout)
E 4
   
D 4
   # Now set the devices fill by mapping the FILL INTERIOR STYLE
   # and FILL STYLE INDEX to the (0-7) value desired by the user
E 4
I 4
      # Now set the devices fill by mapping the FILL INTERIOR STYLE
      # and FILL STYLE INDEX to the (0-7) value desired by the user
E 4

D 4
   nbrcpf = NO  # Start by saying the device can not do the bar fill
   iout = -1    # Just in case nothing is returned by the driver
E 4
I 4
      nbrcpf = NO  # Start by saying the device can not do the bar fill
      iout = -1    # Just in case nothing is returned by the driver
E 4

D 4
   if (nbstyl > SOLID)  {  # Use a fill pattern or hatch
      call gpsatt (SETxFILLxINTERIORxSTYLE, PATTERN, iout)
      if (iout == PATTERN) {
	 nbrcpf = YES  # The device can do this fill
	 }
      else {
	 call gpsatt (SETxFILLxINTERIORxSTYLE, HATCH, iout)
	 if (iout == HATCH)  nbrcpf = YES
	 }
      # If can use hatch or pattern, map fill (2,n) to (1,n-1)
      call gpsatt (SETxFILLxSTYLExINDEX, nbstyl-1, iout)
E 4
I 4
      if (nbstyl > SOLID)  {  # Use a fill pattern or hatch
         call gpsatt (SETxFILLxINTERIORxSTYLE, PATTERN, iout)
         if (iout == PATTERN) {
	    nbrcpf = YES  # The device can do this fill
	    }
         else {
	    call gpsatt (SETxFILLxINTERIORxSTYLE, HATCH, iout)
	    if (iout == HATCH)  nbrcpf = YES
            }
         # If can use hatch or pattern, map fill (2,n) to (1,n-1)
         call gpsatt (SETxFILLxSTYLExINDEX, nbstyl-1, iout)

D 5
         if (nlbsts > 0)  {  # User wants point labeling
            if (nbrdir == 0)  base = 1  # Set for vertical bars
            else              base = 3  # Set for horizontal bars
            }

E 5
         }
      else  {  # Use a hollow or solid fill
         call gpsatt (SETxFILLxINTERIORxSTYLE, nbstyl, iout)
         if (iout == nbstyl)  nbrcpf = YES # The device does this fill
         }
D 5
 
E 5
I 5
      if (nlbsts > 0)  {  # User wants point labeling
         if (nbrdir == 0)  base = 1  # Set for vertical bars
         else              base = 3  # Set for horizontal bars
         }
E 5
E 4
      }
D 4
   else  {  # Use a hollow or solid fill
      call gpsatt (SETxFILLxINTERIORxSTYLE, nbstyl, iout)
      if (iout == nbstyl)  nbrcpf = YES # The device does this fill
E 4
I 4
   else  { # a stick or step graph
      call gpsatt (SETxPOLYLINExCOLORxINDEX, nlcolr, iout)
      call gpsatt (SETxPOLYLINExLINETYPE, nlstyl, iout)
      nlstyl = iout
E 4
      }
 
D 2
   # Contrl(OPCODE) = SETxPOLYLINExLINETYPE
E 2
D 4
   call gpsatt (SETxPOLYLINExLINETYPE, 1, iout)
   nlstyl = iout
 
E 4
   nlindx = nlindx + 1
   if (ndflgd > 0) {   # Put out the legend piece
      x = zlgxy(1) + zxlspc/2.
      y = zlgxy(2) - (float(nlindx) - .4)*zylspc
      call imove (ABSOLUTE, x, y)
      if (type == BARxCHART) {
         call gpbar (x-.4*zxlspc, y-.4*zylspc, .8*zxlspc, .6*zylspc)
         }
      else {
         temp = zxlspc/3.
         call imove (RELATIVE, -temp, 0.0)
         call gpdraw (x+temp,y)
         }
      }
 
   zxleft = zplmin(1)
   zybotm = zplmin(2)
   zxrght = zplmax(1)
   zytop = zplmax(2)

   call gpstck (count, stkary, 1, 0.0, 0.0, xd, yd)
 
D 2
   if (nbrdir == 0) {
      ibase = 1
      iup = 2
      width = xvwlng/32767.
      }
   else {
      ibase = 2
      iup = 1
      width = yvwlng/32767.
      }
E 2
D 7
   barwid = width*zbrwid
   offset = -(float(nbclst)/2.)*barwid
E 7
I 7
   offset = -(float(nbclst)/2.)*zbrwid
E 7
 
D 2
   if (nbstat != 0) {      # If a base line has been specified, output it
      data(1) = zrstrt(1)
      data(2) = zrstrt(2)
      data(iup) = zbrbas
      call gpxfrm (1, data(1), temp)
      data(1) = temp
      call gpxfrm (2, data(2), temp)
      data(2) = temp
      call imove (ABSOLUTE, data(1), data(2))
      data(ibase) = zrend(ibase)
      call gpxfrm (ibase, data(ibase), temp)
      data(ibase) = temp
      call gpdraw (data(1), data(2))
      }
 
E 2
   klustr = 0
   if (nbclst > 1) {   # If clustering
      if (nclskt >= nbclst) nclskt = 0
D 7
      offset = offset + (nclskt*barwid)
E 7
I 7
      offset = offset + (nclskt*zbrwid)
E 7
      klustr = nclskt
      nclskt = nclskt + 1
      }
 
D 4
   if (type == BARxCHART & nlbsts > 0)  {  # User wants point labeling
D 3
      if (nbrdir == 0)  njust(POINTxTEXTxATT) = 2  # Set to bottem center
      else              njust(POINTxTEXTxATT) = 4  # Set to left center
      call gptxat (POINTxTEXTxATT)
E 3
I 3
      if (nbrdir == 0)  base = 1  # Set for vertical bars
      else              base = 3  # Set for horizontal bars
E 3
      }

E 4
   do j=1, count {
D 2
      data(1) = PLOTxGETREAL(xdata(j))
      data(2) = PLOTxGETREAL(ydata(j))
E 2
I 2
      data(1) = gtreal (xdata, j-1)
      data(2) = gtreal (ydata, j-1)
E 2
      index = j + count*klustr
      if (nstack > 0)
         call gpcstk (index, stkary, data(1), data(2), dbase(1), dbase(2))
      else {
         dbase(ibase) = data(ibase)
         dbase(iup) = zbrbas
         }
      call gpstck (count, stkary, index, data(1), data(2), dtop(1), dtop(2))
 
      do i=1, 2 {
         call gpxfrm (i, dbase(i), x)
         dbase(i) = x
         call gpxfrm (i, dtop(i), x)
         dtop(i) = x
         }
 
      if (type == BARxCHART) {               # Bar chart
         dbase(ibase) = dbase(ibase) + offset
D 7
         dtop(ibase) = barwid
E 7
I 7
         dtop(ibase) = zbrwid
E 7
         dtop(iup) = dtop(iup) - dbase(iup)
         call gpbar (dbase(1), dbase(2), dtop(1), dtop(2))
	 if (nlbsts > 0)  {  # Put out the label
D 3
	    ilen = gr2chr (data(2), istr, 8, 2, errind)
E 3
I 3
	    idir = 0
E 3
	    if (nbrdir == 0) {
I 3
	       ilen = gr2chr (data(2), istr, 8, 2, errind)
	       if (dtop(2) < 0.)  idir = 1
E 3
	       call imove (ABSOLUTE, dbase(1)+.5*dtop(1), dbase(2)+dtop(2))
I 3
D 5
	       call imove (RELATIVE, 0., -float(idir)*.01+.005)
E 5
I 5
	       call imove (RELATIVE, 0., -float(idir)*.01+.011)
E 5
E 3
	       }
D 3
	    else {           
E 3
I 3
	    else {
	       ilen = gr2chr (data(1), istr, 8, 2, errind)
	       if (dtop(1) < 0.)  idir = 1
E 3
	       call imove (ABSOLUTE, dbase(1)+dtop(1), dbase(2)+.5*dtop(2))
I 3
D 5
	       call imove (RELATIVE, -float(idir)*.01+.005, 0.)
E 5
I 5
	       call imove (RELATIVE, -float(idir)*.01+.011, 0.)
E 5
E 3
	       }
I 3
	    idir = idir + base
	    njust(POINTxTEXTxATT) = justfy(idir)
	    call gptxat (POINTxTEXTxATT)
E 3
	    call text (ilen, istr)
	    }
         }
      else if (type == STEPxCHART) {         # Step graph
D 6
         if (j == 1)           call imove (ABSOLUTE, dtop(1), dtop(2))
         else if (nbrdir == 0) call gpdraw (dbase(1), ylast)
         else                  call gpdraw (xlast, dbase(2))
 
         call gpdraw (dtop(1), dtop(2))
         xlast = dtop(1)
         ylast = dtop(2)
E 6
I 6
	 if (j > 1)  {
	    delta = (dtop(1) - xlast) / 2.
	    if (j == 2) call imove (ABSOLUTE, xlast-delta, ylast)
	    temp2 = xlast + delta
	    call gpdraw (temp2, ylast)
	    call gpdraw (temp2, dtop(2))
	    }
	 if (j == count)  {
	    call gpdraw (dtop(1)+delta, dtop(2))
	    }
	 xlast = dtop(1)
	 ylast = dtop(2)
E 6
         }
      else {                                 # Stick plot
         if (nbclst > 1) {
            dbase(ibase) = dbase(ibase) + offset
            dtop(ibase) = dtop(ibase) + offset
            }
         call imove (ABSOLUTE, dbase(1), dbase(2))
         call gpdraw (dtop(1), dtop(2))
         }
      }

   call imove (ABSOLUTE, zxabsl, zyabsl)  # Force the buffer to get dumped
   zybotm = 0.0    # Reset clipping to do full viewport clipping
   zytop = 1.0
   zxleft = 0.0
   zxrght = 1.0
   nclip = NO  # Turn clipping off

   return
end
E 1
