This program is an extension of the last one. It starts by prompting for the number of sides for the polygon, and then continues as before. However, rather than just accept the default settings for the input devices it initializes them in a suitable way. As an example, the choice device is set-up to provide a menu, and the valuator has reasonable limiting values.
Note that initialization is implementation-dependent and may also be device-dependent. This example works for GKSGRAL. .cc 6
PROGRAM initst
INCLUDE 'GKS$GTSDEV'
INCLUDE 'GKS$ENUM'
C
INTEGER errfil
PARAMETER (errfil=6)
INTEGER wktyp, wkid, conid
PARAMETER (wkid = 1, conid = 1)
INTEGER chcdev, locdev, strdev, valdev ! device numbers
PARAMETER (chcdev = 1, locdev = 1, strdev = 1, valdev = 1)
INTEGER tnr, pet, i, status, dcunit, lx, ly
INTEGER lstr, nsides, fill, lfi(4)
REAL px(10), py(10)
REAL chrht, sides, rx, ry, inival
PARAMETER (inival = 3.0)
INTEGER errind ! error flag
REAL dum(2) ! dummy array
CHARACTER*40 filename
CHARACTER*80 str(4) ! array used by GPREC
CHARACTER*30 fi
INTEGER asflst(13)
DATA asflst/13 * gindiv/! set all ASFs
C
C Open error log file, GKS and a Workstation
C
OPEN (unit=errfil, file='errors', status='unknown')
wktyp = T4107 ! set workstation type
CALL gopks(errfil, 0) ! open gks (bufa not used)
CALL gopwk(wkid, conid, wktyp) ! open workstation
CALL gacwk(wkid) ! activate workstation
CALL gsasf(asflst) ! set attributes individually
CALL gqdsp(wktyp, status, dcunit, rx, ry, lx, ly)
C
C Request valuator for no of sides of polygon (3-10)
C Initialize echo area and valuator upper and lower limits
C
CALL gmsg(wkid, 'Enter the number of sides for the polygon')
pet = 1 ! define prompt/echo type
lstr = 0 ! data record not used
CALL ginvl(wkid, valdev, inival, pet, 0.0, rx, 0.0, ry/5,
* 3.0, 10.0, lstr, str)
CALL grqvl(wkid, valdev, status, sides)
nsides = ifix(sides)
C
C request locator positions
C
CALL gmsg(wkid, 'point to vertices')
CALL grqlc(wkid, locdev, status, tnr, px(1), py(1))
CALL gpm(1, px(1), py(1))
DO 30 i = 2,nsides
C
C Request locator for other positions
C Initialize cursor to previous position
C (for devices with this capability (eg not tek 4014))
C
CALL ginlc (wkid,locdev,0,px(i-1),py(i-1),pet,
* 0.,rx,0.,ry,lstr,str)
CALL grqlc(wkid, locdev, status, tnr, px(i), py(i))
CALL gpm(1, px(i), py(i))
30 CONTINUE
C
C Request choice for fill area interior style (0-3)
C Use gprec to set up the DATA record used to initialize
C the logical choice device with 4 menu strings.
C
C Note:
C The call to GPREC does not conform to the final FORTRAN Binding.
C
fi(1:6) = 'hollow'
lfi(1) = 6
fi(7:11) = 'solid'
lfi(2) = 5
fi(12:18) = 'pattern'
lfi(3) = 7
fi(19:23) = 'hatch'
lfi(4) = 5
CALL gprec(4, lfi, 0, dum, 23, fi, 4, status, lstr, str)
CALL ginch(wkid, chcdev, 1, 2, 3, 0.8*rx, rx, 0.5*ry, ry,
* lstr, str)
CALL grqch(wkid, chcdev, status, fill)
CALL gsfais(fill-1) ! Set fill area style
CALL gfa(nsides, px, py) ! Draw fill area
C
C Request string for title of picture
C Initialize default string and echo area
C
CALL gmsg(wkid, 'Give the title of the picture')
CALL ginst(wkid, strdev, 14, 'picture title', pet,
* 0.0 ,rx ,0.0, 0.1*ry, 80, 1, 1, str)
CALL grqst (wkid, strdev, status, lstr, str)
C
C Request valuator for CHARACTER height
C Initialize valuator echo area plus value limits 1/100 to 1/10.
C
CALL gmsg(wkid, 'Give CHARACTER height (0.01 to 0.1)')
CALL ginvl(wkid, valdev, 0.1, pet, 0.0, rx, 0.0, ry/5,
* 0.01 ,0.1, 1, str)
CALL grqvl(wkid, valdev, status, chrht)
CALL gschh(chrht)
C
C Request locator for text position
C
CALL gmsg(wkid, 'Give text position')
CALL grqlc(wkid, locdev, status, tnr, px(1), py(1))
CALL gstxfp(1, gstrkp) ! font 1, stroke precision
CALL gtx(px(1), py(1), str(1)(1:lstr))
CALL gdawk(wkid) ! deactivate workstation
CALL gclwk(wkid) ! close workstation
CALL gclks ! close gks
END