C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details
SUBROUTINE VIINIT(ASPECT,JUSTIF)
C VDI-PostScript driver - B&W and COLOR versions
C Adapted for all systems by S.L.Thompson
C Original code from D.Campbell and J.LONG
C vdi device numbers are
C device number
C black & white, batch, no poly fill 799.1
C black & white, interactive, no poly 799.2
C black & white, batch, poly fill 799.3
C black & white, interactive, poly fill 799.4
C color, batch 799.5
C color, interactive 799.6
C color, batch, black-white interchange 799.7
C color, interactive, black-white interchange 799.8
C color, batch, black background 799.9
C color, interactive, black background 799.11
C Note that there are several parameters to set depending on how
C the package is to be used. Most are in routine pstsel routine
C which is called at the first of this routine (viinit.) Two other
c parameters (xinch,yinch) are set in this routine and vdiqd9.
C This code is for BOTH color and black & white systems.
C Flag is set for mode in pstsel.
C Device can be set with escape call before call to vdinit.
C Otherwise, code will interactively ask for device type.
C There is also an escape flag for landscape or portrait format.
C This deck was generated from a qms driver and still has the
C qms comments in places.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VIINIT -Initialize SVDI. postscript device
C D.L. CAMPBELL -1-DEC-1986
C J.P. LONG -9-NOV-1987
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C (postscript)
C ENTRY CONDITIONS -ASPECT = real ratio of X dimension to Y dimension.
C Range >0.0. Default: 0. (device dependent).
C JUSTIF = integer justification of NDC space on the
C device. Range 0-9. Default: 0 (device dependent.)
C CALLS -VBERRH,VDSTCS,VDSTLW,VIMOVA
C EXIT CONDITIONS -XNDCMX,YNDCMX = real NDC maximum valid values(as
C constrained by ASPECT).
C VECTOR = real array of attribute values(all device
C dependent except VECTOR(4)=0.0).
C NARRATIVE -This must be the first SVDI call made. All
C attribute values, the color table, and current
C position are set to appropriate defaults for the
C device. All necessary input device initialization
C is done. The screen is cleared or paper advanced
C if necessary to guarantee a blank view surface for
C drawing on.
C ASPECT specifies the ratio of the X dimension to the
C Y dimension . Maximum NDC values (at least one of
C which will be 1.0) are computed to give the ASPECT
C specified. The default ASPECT (0.0) is device
C dependent and equals the aspect ratio of the
C physical device, except for variable aspect devices
C (such as drum plotters) which are assigned a default
C aspect of 1.0. The NDC rectangle is scaled until
C one dimension fills the corresponding dimension of
C the device.
C JUSTIF determines where the rectangle is located on
C the device as diagrammed below:
C ---------
C | 7 8 9 |
C | 4 5 6 |
C | 1 2 3 |
C ---------
C For example, JUSTIF = 7 indicates NDC space will be
C upper left justified on the device.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Set parameters for type of usage.
C Two settings are coded - one for square field of view
C and one for full field of view.
C If VDIQDC is called before vdinit, full field of view is selected.
C Otherwise, square is used.
C size of full view
PARAMETER (XINCHO=10.0)
PARAMETER (YINCHO=7.5)
C size of square view
C PARAMETER (XINCHO=7.5)
C PARAMETER (YINCHO=7.5)
*- INCLUDE PSTSQUAR
C size of square view window
C parameters set to get same size plot as imagen and qms b&w.
C PARAMETER (XINCHO=7.4412525)
C PARAMETER (YINCHO=7.4412525)
*-
COMMON /VCMODR/ XINCH, YINCH
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
REAL ASPECT
INTEGER JUSTIF
COMMON /VCVEC1/ IVECT
INTEGER IVECT
C MAXIMUM VALID NDC VALUES. (DEVICE-INDEPENDENT)
REAL XNDCMX,YNDCMX
COMMON /VCNDCM/ XNDCMX,YNDCMX
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C CURRENT POSITION.
REAL XCP,YCP
COMMON /VCCRPS/ XCP,YCP
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
INTEGER XPAD,YPAD,XDEVIC,YDEVIC
COMMON /VCDDIM/ XPAD,YPAD,XDEVIC,YDEVIC
C JOB ID INFORMATION. (HC1, DIC)
include 'vcjob.blk'
COMMON /DEVCAP/ DEV(33)
C ESCAPE FLAGS
C PATNO AND BORDER USED BY VIPOLY FOR FILL PATTERN AND BORDER ON/OFF;
C DEFAULT COMPLETE FILL WITH BORDER. PLC.
COMMON /VCESCP/ PGFORM,PATNO,BORDER
INTEGER PGFORM,PATNO,BORDER
CHARACTER COORD*20,XCOORD*4,YCOORD*4
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
DIMENSION COLDEF(3)
C vcpstd variables control what to do with empty frames with
C command is received to dump data to output
C kempty=0, frame is void - do not draw
C >0, frame has data - draw it
COMMON /VCPSTD/ KEMPTY
integer dummy(1)
DEV(1) = 0.0
dev(2) = 1.0
dev(3) = 1.0
dev(4) = 1.0
dev(5) = 15.0
dev(6) = 2.0
dev(7) = 0.0
dev(8) = 0.0
dev(9) = 0.0
dev(10) = 0.0
dev(11) = 0.0
dev(12) = 0.0
dev(13) = 0.0
dev(14) = 0.0
dev(15) = 7230.0
dev(16) = 5040.0
dev(17) = 254.0
dev(18) = 178.0
dev(19) = 4.0
dev(20) = 10.0
dev(21) = 84.0
dev(22) = 0.0
dev(23) = 0.0
dev(24) = 3.0
dev(25) = 99999.
dev(26) = 0.0
dev(27) = 1.0
dev(28) = 0.0
dev(29) = 0.0
dev(30) = 5000.
dev(31) = 750.
dev(32) = 0.0
dev(33) = 1.0
C SET DEFAULT ATTRIBUTE VALUES. ALL ARE DEVICE DEPENDENT EXCEPT
C VECTOR(4)=0.0.
C .. following removed since should be in block data...
c DATA VECTOR /0.,7.,1.,0.,.06255,.01,.0/
C VECTOR(1)=FOREGROUND COLOR - BLACK
C (2)=BACKGROUND COLOR - WHITE
C (3)=INTENSITY - MAXIMUM
C (4)=LINE STYLE - SOLID
C (5)=LINE WIDTH - ABOUT 1/72 INCHES
C (6)=CHARACTER BOX Y - ABOUT 1/10 INCHES
C (7)=CHARACTER BOX X - 5/7 OF BOX-Y
vector(1) = 0.0
vector(2) = 7.0
vector(3) = 1.0
vector(4) = 0.0
vector(5) = 0.06255
vector(6) = 0.01
vector(7) = 0.0
C PROTECT INPUT PARAMETERS FROM BEING CHANGED.
ASPEC1=ASPECT
JUSTI1=JUSTIF
KEMPTY=0
PGFORM = 0
PATNO = 20
BORDER = 1
XCP = 0.0
YCP = 0.0
C CHECK FOR VALID ASPECT. IF(ASPECT.LT.0.0) THEN CALL VBERRH(721,5),
C AND USE DEFAULT ASPECT.
IF(ASPECT.LT.0.0) THEN
CALL VBERRH(721,5)
ASPEC1=0.0
END IF
C CHECK FOR VALID JUSTIF. IF(JUSTIF.LT.0 .OR. JUSTIF.GT.9) THEN
C CALL VBERRH(720,5), AND USE DEFAULT JUSTIF.
IF(JUSTIF.LT.0.OR.JUSTIF.GT.9) THEN
CALL VBERRH(720,5)
JUSTI1=0
END IF
C SCALE NDC UNITS TO DEVICE UNITS.
C FOR QMS, THE PHYSICAL PLOT SURFACE IS XINCH X YINCH (10.x7.5).
C DEVICE COORDINATES ARE KEPT IN 1/723 INCH TO GAIN SIMPLICITY
C IN ASSEMBLING CHARACTER STRINGS WITH FLOATING NUMBERS
C ACCURATE TO TENTHS OF DEVICE UNITS
C THE DEVICE ASPECT IS XINCH/YINCH
C BUT WE MUST MAP THE ASPECT SPECIFIED IN DC INTO THIS
C ADDRESSABILITY,USING AS MUCH OF THE SPACE AS POSSIBLE.
XINCH=XINCHO
YINCH=YINCHO
C test for rscors post or direct mode. Use 7.5x7.5 for direct
C and 10.0x7.5 for post
C if VDIQDC has already been called, we are in post mode;
C otherwise in direct mode
CALL VDIQD9(XINCH,YINCH)
C CHECK PAGE FORMAT - IF PORTRAIT,
C THEN SWITCH THINGS AROUND
IF (PGFORM.EQ.1) THEN
TEMP=XINCH
XINCH=YINCH
YINCH=TEMP
TEMP=DEV(15)
DEV(15)=DEV(16)
DEV(16)=TEMP
TEMP=DEV(17)
DEV(17)=DEV(18)
DEV(18)=TEMP
ENDIF
XUNITS=XINCH*723.
YUNITS=YINCH*723.
DASPEC=XUNITS/YUNITS
C DEFAULT ASPECT = 1., DEFAULT JUSTIF = 1.
IF(ASPEC1.EQ.0.) ASPEC1=DASPEC
IF(JUSTI1.EQ.0) JUSTI1=1
IF(ASPEC1.GE.DASPEC) THEN
C THEN X DIMENSION IS FILLED.
XDEVIC=XUNITS
YDEVIC=XUNITS/ASPEC1
XPAD=0
C FIGURE HOW MUCH Y PADDING IS NEEDED.
IF(JUSTI1.LE.3) THEN
YPAD=0
ELSE IF(JUSTI1.LE.6) THEN
YPAD=(YUNITS-YDEVIC)/2
ELSE
YPAD=YUNITS-YDEVIC
END IF
ELSE
C ELSE Y DIMENSION IS FILLED.
XDEVIC=YUNITS*ASPEC1
YDEVIC=YUNITS
YPAD=0
C FIGURE HOW MUCH X PADDING IS NEEDED.
IF(JUSTI1.EQ.3.OR.JUSTI1.EQ.6.OR.JUSTI1.EQ.9) THEN
XPAD=XUNITS-XDEVIC
ELSE IF(JUSTI1.EQ.2.OR.JUSTI1.EQ.5.OR.JUSTI1.EQ.8) THEN
XPAD=(XUNITS-XDEVIC)/2
ELSE
XPAD=0
END IF
END IF
C FIGURE MAXIMUM NDC VALUES XNDCMX AND YNDCMX.
IF(ASPEC1.GE.DASPEC) THEN
XNDCMX=MIN(1.,ASPEC1)
YNDCMX=XNDCMX/ASPEC1
ELSE
XNDCMX=ASPEC1
YNDCMX=1.
END IF
C SET SCALE FACTORS FOR NDC-TO-DEVICE MAPPING.
XSCALE=DBLE(XDEVIC)/XNDCMX
YSCALE=DBLE(YDEVIC)/YNDCMX
IF (PGFORM .GT. 0) THEN
YPAD = YPAD+280.
XPAD = XPAD+360.
ELSE
XPAD = XPAD+280.
YPAD = YPAD-180.
ENDIF
CALL PSTSEL(' ')
C SET UP MONITORING INFORMATION
CALL VBDEV('V PST ')
CALL VDMONI(0)
IVECT=0
C OPEN OUTPUT FILE
CALL PSTOFS(KOUTFL)
C INITIALIZE the printer
CALL PSTINI
CALL PSTBUF(38, '%%Title: Graphics SVDI PostScript File')
CALL PSTBUF(0,' ')
CALL PSTBUF(40, '%%Creator: SNL SEACAS SVDI Driver -- cps')
CALL PSTBUF(0,' ')
CALL PSTBUF(24, '%%Orientation: Landscape')
CALL PSTBUF(0,' ')
CALL PSTBUF(16, '%%Pages: (atend)')
CALL PSTBUF(0,' ')
CALL PSTBUF(28, '%%BoundingBox: 36 30 574 750')
CALL PSTBUF(0,' ')
CALL PSTBUF(24, '%%DocumentFonts: Courier')
CALL PSTBUF(0,' ')
CALL PSTBUF(13, '%%EndComments')
CALL PSTBUF(0,' ')
IF(MOCOLR.EQ.0) THEN
CALL PSTBUF(35,'% this file contains color commands')
CALL PSTBUF(0,' ')
C default user dictionary is too small to contain color
C definition commands - make a larger one.
CALL PSTBUF(14,'300 dict begin')
CALL PSTBUF(0,' ')
END IF
CALL PSTBUF(27,'/y {/Courier findfont} def ')
CALL PSTBUF(27,'/x {scalefont setfont} def ')
CALL PSTBUF(32,'/m {moveto} def /l {lineto} def ')
CALL PSTBUF
* (50,'/c {closepath} def /v {save} def /r {restore} def ')
CALL PSTBUF
* (54,'/f {eofill} def /s {stroke} def /w {setlinewidth} def ')
CALL PSTBUF(31,'/h {setdash} def /t {show} def ')
CALL PSTBUF(33,'/d {gsave} def /u {grestore} def ')
if (dev(23) .ge. 799.75 .and. dev(23) .le. 799.85) then
CALL PSTBUF(39,'/q {exch pop exch dup 2 exp 1 exch sub ')
CALL PSTBUF(39,'setgray add /brsum exch def brsum 0 le ')
CALL PSTBUF(40,'{ 0 setgray } if brsum 2 ge{ 1 setgray }')
CALL PSTBUF(10,' if } def ')
else if (dev(23) .ge. 799.05 .and. dev(23) .le. 799.15) then
CALL PSTBUF(28,'/q {exch pop exch dup 2 exp ')
CALL PSTBUF(39,'setgray add /brsum exch def brsum 0 le ')
CALL PSTBUF(40,'{ 0 setgray } if brsum 2 ge{ 1 setgray }')
CALL PSTBUF(10,' if } def ')
else
CALL PSTBUF(21,'/q {setrgbcolor} def ')
end if
CALL PSTBUF(14,'1 setlinejoin ')
CALL PSTBUF(0,' ')
C SET PAGE FORMAT (LANDSCAPE/PORTRAIT)
IF (PGFORM.EQ.0) THEN
CALL PSTBUF(4,'/o {')
CALL PSTBUF(10,'90 rotate ')
CALL PSTI2C(0,4,XCOORD)
CALL PSTI2C(INT(YDEVIC+YDEVIC*3./32.),4,YCOORD)
COORD = ' '//XCOORD(1:3)//'.'//XCOORD(4:4)//' -'//
1 YCOORD(1:3)//'.'//YCOORD(4:4)
CALL PSTBUF( 13,COORD)
CALL PSTBUF(11,' translate ')
CALL PSTBUF(6,'} def ')
YPAD = -YPAD
ELSE
CALL PSTBUF(17,'/o {newpath} def ')
ENDIF
CALL PSTBUF(35,'/p {showpage} def 1 setlinecap v o ')
C check for color or black & white mode
IF(MOCOLR.EQ.0) THEN
C color is on
C define some kind of color table
DO IC=0,7
COLDEF(1)=0.
COLDEF(2)=0.
COLDEF(3)=0.
IF(IC.EQ.1) THEN
COLDEF(1)=1.
ELSEIF(IC.EQ.2) THEN
COLDEF(2)=1.
ELSEIF(IC.EQ.3) THEN
COLDEF(1)=1.
COLDEF(2)=1.
ELSEIF(IC.EQ.4) THEN
COLDEF(3)=1.
ELSEIF(IC.EQ.5) THEN
COLDEF(1)=1.
COLDEF(3)=1.
ELSEIF(IC.EQ.6) THEN
COLDEF(2)=1.
COLDEF(3)=1.
ELSEIF(IC.EQ.7) THEN
COLDEF(1)=1.
COLDEF(2)=1.
COLDEF(3)=1.
END IF
DO IK=0,255,8
DUMMY(1) = IC+IK
CALL VDSTCO(1,DUMMY,COLDEF,0)
IF(IC.EQ.0) THEN
COLDEF(1)=0.2
COLDEF(2)=0.2
COLDEF(3)=0.2
END IF
end do
end do
END IF
VECTOR(1)=7.
VECTOR(2)=0.
C define the postscript current position
CALL VBVECT(0,XCP,YCP)
C shade background if appropriate
IF(KPSTBG.NE.0) THEN
CALL PSTBBG
KEMPTY=0
END IF
C INIT LINE WIDTH,CHARACTER SIZE
CALL VDSTLW(VECTOR(5))
c CALL VDSTCS(VECTOR(6))
CALL VDSTFC(NINT(VECTOR(1)))
CALL PSTBUF(0,' ')
RETURN
END
SUBROUTINE VDIQDC(INDEX,VALUE)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQDC -Inquire Device Capabilities.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -INDEX = integer capability number. Range 1-33.
C CALLS -
C EXIT CONDITIONS -VALUE = real value of the capability indicated by
C INDEX.
C NARRATIVE -Return values of various device capabilities. INDEX
C is the integer capability number (as given below),
C and the real value is returned in VALUE.
C 1. Erasability
C 0. None (hard copy)
C 1. Screen (Tektronix 4010)
C 2. Point or Line SLOW (Plasma)
C 3. Point or Line MEDIUM (Refresh -Serially connected)
C 4. Point or Line FAST (Refresh -Direct connected)
C 5. (1) and some (3) (Tektronix 4014 with write-thru mode)
C 2. Scan Type
C 0. Vector
C 1. Raster
C 2. Matrix (Plasma)
C 3. Intensities (1-N)
C 4. Colors (1-N) This is the number of colors that can be
C displayed at one time and may be less than the
C total number of colors the device can produce.
C 5. Line Widths (1-N)
C 6. Line Styles (0-N) A bit pattern indicating which of the 5
C non-solid line styles are supported in the
C device. Bits 4,3,2,1, and 0 correspond to line
C styles medium dash, long dash, short dash, dot
C dash, and dot. (0 - device has no hardware line
C styles - simulate.)
C 7. Character Sizes (0-N) (0 - device has no hardware - simulate)
C 8. Number of Locator Devices
C 9. Number of Valuator Devices
C 10. Number of Button Devices
C 11. Number of Keyboard Devices
C 12. Number of Stroke Devices
C 13. Input
C 0. none
C 1. synchronous only - program requests input, then the user
C supplies it.
C 2. synchronous and asynchronous - synchronous is the same
C as in (1) above. Asynchronous means the user can provide
C input at any time; this input is then saved by the system
C in an event queue until the program calls for it.
C 14. Input Timing
C 0. no timeout supported
C 1. unreliable timing
C 2. timeout with reliable timing
C 15. X Dimension of View Surface in Device Coordinates
C 16. Y Dimension of View Surface in Device Coordinates
C 17. X Dimension of View Surface in Physical Units (mm) (0 if
C undefined). If this dimension is variable (as for drum
C plotters), it should be set equal to the Y dimension to
C guarantee a device aspect ratio of 1.0.
C 18. Y Dimension of View Surface in Physical Units (mm) (0 if
C undefined).
C 19. Smallest Line Width (DC) at default intensity
C 20. Smallest Point (DC) at default intensity
C 21. Smallest Character Size (DC)
C 22. Header and Trailer Frames Required (0=no,1=yes)
C 23. Device Identifier
C 1. TK4 - Tektronix 4014
C 1.1 TK6 - Tektronix 4016
C 1.2 TEK - Tektronix 4010, 4012
C 1.3 TP2 - Tektronix 4662
C 1.4 TP8 - Tektronix 4662 with 8 pen option
C 1.5 T14 - Tektronix 4114
C 1.6 T13 - Tektronix 4113
C 1.7 T05 - TEKTRONIX 4105
C 1.8 T07 - TEKTRONIX 4107
C 1.9 T15 - TEKTRONIX 4115
C 2.1 16C - Dicomed 16mm color Movies
C 2.2 16B - Dicomed 16mm black and white movies
C 2.3 35C - Dicomed 35mm color slides
C 2.31 3MC - Dicomed 35mm movie color
C 2.4 35B - Dicomed 35mm black and white slides
C 2.41 3MB - Dicomed 35mm movie black and white
C 2.5 35A - Dicomed 35mm Aperture Card
C 2.6 24L - Dicomed 24X Fiche
C 2.7 48L - Dicomed 48X Fiche
C 2.8 CSQ - Dicomed Color Full Frame(square aspect ratio)
C 2.9 BSQ - Dicomed Black and White Full Frame(square aspect)
C 3 R94 - Ramtek 9400
C 4. T27 - Tektronix 4027
C 4.1 T25 - Tektronix 4025
C 5. ALP - Alphanumeric Terminal
C 6. HC1 - Remote Hard Copy
C 7. LXY - Printronix
C 8. TST - Test Driver, Print VDI calls made.
C 9. V25 - Digital VT125
C 10. AED - AED 512
C 10.1 AE7 - AED 767
C 10.2 AE1 - AED 1024
C 11. MET - SVDI Metafile
C 12. HPP - Hewlett Packard Printer/Plotter 2671G
C 12.1 H75 - HP 7580
C 12.2 H72 - HP 7221C OR T
C 12.3 H74 - HP 7475A
C 14. RET - Retrographics
C 15. AP5 - Aps 5 Phototypesetter
C 16. JP7 - JUPITER 7
C 16.1 JP1 - Jupiter 1024
C 17. GER - Gerber 4400 Photoplotter
C 18. XYN - XYNETICS
C 20. PS3 - E & S Picture System 300
C 21. QMS - QMS LASER PRINTER
C 22. C51 - CALCOMP 1051 DRUM PLOTTER
C 23. R25 - RASTER TECHNOLOGIES MODEL ONE/25
C 24. QLF - QCR large format (8 x 10)
C 24.1 Q35 - QCR 35mm format
C 25. T45 - Tektronix 4510 Rasterizer
C 24. Polygon support level
C 0. no support
C 1. fills convex polygons
C 2. fills simple polygons (may be concave but not
C self-crossing)
C 3. full complex polygon fill support
C 25. Maximum number of points in a polygon (99999. if infinite)
C 26. Setable color table
C 0. no
C 1. yes
C 27. Device color palette size (1-N) - the number of different
C colors a device can produce (may be more than the device
C can display simultaneously)
C 28. Direct color space size (0-N) - the number of colors
C available via direct RGB color specification
C (displayable simultaneously)
C 29. Vector verses Raster VDI
C 0. SVDI
C 1. SVDI+Raster
C 30. Maximum character height (DC)
C 31. Maximum line width (DC)
C 32. Color verses monochrome (greyscale) device
C 0. monochrome
C 1. color
C 33. Device pixel aspect - the ratio of the spacing of device
C pixels in x divided by the spacing in y (1 for square
C pixels)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
SAVE
INTEGER INDEX
REAL VALUE
C ESCAPE FLAGS
C PATNO AND BORDER USED BY VIPOLY FOR FILL PATTERN AND BORDER ON/OFF;
C DEFAULT COMPLETE FILL WITH BORDER. PLC.
COMMON /VCESCP/ PGFORM,PATNO,BORDER
INTEGER PGFORM,PATNO,BORDER
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
*- INCLUDE PSTFULL
C size of full view window
C parameters set to get same size plot as imagen and qms b&w.
PARAMETER (XINCHF=9.92167)
PARAMETER (YINCHF=7.4412525)
*-
C INITIALIZE THE DEVICE CAPABILITIES VECTOR.
COMMON /DEVCAP/ DEV(33)
DATA NOCALL /0/
C If device is 0, call to reset
IF(NINT(DEV(23)).EQ.0) THEN
CALL PSTSEL(' ')
END IF
C CHECK FOR VALID INDEX.
IF(INDEX.LT.1.OR.INDEX.GT.33) THEN
CALL VBERRH(726,5)
GOTO 999
END IF
C RETURN INDEXED VALUE.
VALUE=DEV(INDEX)
IF(INDEX.EQ.23) NOCALL=1
999 RETURN
C**********************************************************************
ENTRY VDIQD9(XINCH,YINCH)
C This is an added entry for rscors version of pst driver to
C tell if direct or post mode operation. If post mode, vdiqdc
C is called before vdinit to get terminal type. In direct mode
C it is never called to get type.
IF(NOCALL.NE.0) THEN
C XINCH=10.0
C YINCH=7.5
XINCH=XINCHF
YINCH=YINCHF
END IF
RETURN
END
SUBROUTINE VBERRH(ERRNUM,ERRSEV)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VBERRH -Error Handler.
C R.W.Simons -08APR81
C 30SEP81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -ERRNUM = integer error number.
C ERRSEV = integer severity code. If > 12, error is
C fatal.
C CALLS -VDLOGE.
C EXIT CONDITIONS -
C NARRATIVE -An error will normally cause an error message to
C be printed on the error output device and possible
C termination of the program, unless a routine VBERRH
C is supplied by the user. This routine will replace
C the default VBERRH provided by the system. The
C system supplied VBERRH calls VDLOGE before
C returning. All versions of VBERRH, whether user-
C supplied or default, must STOP on any error severity
C greater than 12.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ERRNUM,ERRSEV
C REPORT THE ERROR USING VDLOGE.
CALL VDLOGE(ERRNUM,ERRSEV)
C CHECK FOR FATAL ERROR.
IF(ERRSEV.GT.12) STOP
RETURN
END
SUBROUTINE VDGNAM(NAME)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDGNAM -Name the graphics output file
C P.L.Crotty -OCT88
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -NAME = character string; < 80 characters
C CALLS
C EXIT CONDITIONS -output graphics file is assigned the name NAME
C NARRATIVE -This subroutine associates a file name with
C the graphics output file (KOUTFL). If this
C routine is not called, a system dependent
C default name is used. VDGNAM must be called
C before VDINIT.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
SAVE
CHARACTER*(*) NAME
CHARACTER*2048 PSTNAM
INTEGER LENGTH,ISTART,IEND,I
integer*4 koutff, koutfl
DATA PSTNAM /'vdicps.ps'/
DATA ISTAT /0/
LENGTH = MIN(LEN(NAME),132)
C Strip off any leading blanks
ISTART = 0
DO I=1,LENGTH
IF(NAME(I:I) .NE. ' ')THEN
ISTART = I
GOTO 11
ENDIF
end do
11 CONTINUE
C Strip off trailing blanks
IEND = 0
IF(ISTART.GT.0)THEN
DO I=LENGTH,1,-1
IF(NAME(I:I) .NE. ' ')THEN
IEND = I
GOTO 21
ENDIF
end do
ENDIF
21 CONTINUE
PSTNAM=NAME(ISTART:IEND)
RETURN
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
ENTRY PSTOFS(KOUTFL)
IF(ISTAT.EQ.0) THEN
OPEN(KOUTFL,FILE=PSTNAM,FORM='FORMATTED',STATUS='UNKNOWN',
& ERR=202,IOSTAT=ISTAT)
ISTAT=1
END IF
GO TO 210
202 WRITE(6,203) ISTAT,PSTNAM(1:128)
203 FORMAT(//,' ERROR OPENING PST OUTPUT FILE UNIT =',I8,/,
&1X,A)
STOP 'NOOPEN'
210 CONTINUE
RETURN
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
ENTRY PSTCFS(KOUTFF,KK)
IF(ISTAT.NE.0) THEN
CLOSE(KOUTFF,ERR=303)
303 ISTAT=0
END IF
RETURN
END
SUBROUTINE VDINIT(ASPECT,JUSTIF)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDINIT -Initialize SVDI.
C R.W.Simons -08APR81
C 30SEP81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -ASPECT = real ratio of X dimension to Y dimension.
C Range >0.0. Default: 0.0 (device dependent).
C JUSTIF = integer justification of NDC space on the
C device. Range 0-9. Default: 0 (device dependent).
C CALLS -PSTJOB, VBERRH, VIINIT.
C EXIT CONDITIONS -XNDCMX,YNDCMX = real NDC maximum valid values.
C VECTOR = real array of default attribute values (all
C device-dependent except VECTOR(4)=0.0).
C NARRATIVE -This must be the first SVDI call made. All
C attribute values, the color table, and current
C position are set to appropriate defaults for the
C device. All necessary input device initialization
C is done. The screen is cleared or paper advanced
C if necessary to guarantee a blank view surface for
C drawing.
C ASPECT specifies the ratio of the X dimension to the
C Y dimension. Maximum NDC values (at least one of
C which will be 1.0) are computed to give the ASPECT
C specified. The default ASPECT (0.0) is device
C dependent and equals the aspect ratio of the
C physical device, except for variable aspect devices
C (such as drum plotters) which are assigned a default
C aspect of 1.0. The NDC rectangle is scaled until
C one dimension fills the corresponding dimension of
C the device.
C JUSTIF determines where the rectangle is located on
C the device as diagrammed below:
C ---------
C | 7 8 9 |
C | 4 5 6 |
C | 1 2 3 |
C ---------
C For example, JUSTIF = 7 indicates NDC space will be
C upper left justified on the device.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL ASPECT
INTEGER JUSTIF
C JOB ID INFORMATION. (HC1, DIC)
include 'vcjob.blk'
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C set common variables
KWRTFL=6
KRDFL=0
KOUTFL=77
KINFL=5
KWRDSZ=0
KBYTEL=0
KCPW=0
KBAUD=0
KCOMTP=0
C CHECK FOR VALID CLASSIFICATION. Because of output format ignore.
CALL PSTJOB
C IF(KSECUR.NE.0) THEN
C CALL VBERRH(957,13)
C END IF
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VIINIT.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VIINIT(ASPECT,JUSTIF)
RETURN
END
SUBROUTINE VDIQND(XNDC,YNDC)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQND -Inquire NDC Space.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -XNDCMX,YNDCMX = real maximum valid NDC values.
C CALLS -
C EXIT CONDITIONS -XNDC,YNDC = real maximum valid NDC values (XNDCMX,
C YNDCMX).
C NARRATIVE -Return the maximum NDC values as set to realize the
C aspect defined by VDINIT.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL XNDC,YNDC
C MAXIMUM VALID NDC VALUES. (DEVICE-INDEPENDENT)
REAL XNDCMX,YNDCMX
COMMON /VCNDCM/ XNDCMX,YNDCMX
C RETURN THE MAXIMUM VALID NDC VALUES.
XNDC=XNDCMX
YNDC=YNDCMX
RETURN
END
SUBROUTINE VDIQOS(ATTARR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQOS -Inquire Output Status (of Attributes).
C K.M. ERICKSON -14 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -VECTOR = real array of current attribute values.
C CALLS -
C EXIT CONDITIONS -ATTARR = real array of current attribute value
C (VECTOR).
C NARRATIVE -Return the current attribute values in ATTARR as
C given below.
C ATTARR(1)=Foreground Color
C (2)=Background Color
C (3)=Intensity
C (4)=Line Style
C (5)=Line Width
C (6)=Character Box Y
C (7)=Character Box X
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL ATTARR(7)
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
INTEGER I
DO I=1,7
ATTARR(I)=VECTOR(I)
end do
RETURN
END
SUBROUTINE VDLINA(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDLINA -Line Absolute.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VILINA.
C EXIT CONDITIONS -
C NARRATIVE -Draw a line from current position to absolute NDC
C position X,Y and update current position.
C Attributes foreground color, intensity, line style,
C and line width apply.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VILINA.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VILINA(X,Y)
RETURN
END
SUBROUTINE VDLOGE(ERRNUM,ERRSEV)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDLOGE -Log Error.
C R.W.Simons -08APR81
C K.M.Erickson -8OCT84 - add buffer flush
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -ERRNUM = integer error number.
C ERRSEV = integer error severity.
C CALLS -PSTTBK, VDBUFL
C EXIT CONDITIONS -
C NARRATIVE -Report error with message to user and possibly
C terminate job depending on severity. Notice that
C by judicious use of the error routines (see VBERRH)
C it is possible to write very "nice" error routines
C that, for example, only report the first two
C occurrences of a particular error, or terminate
C if more than 10 errors of a particular severity
C occur.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ERRNUM,ERRSEV
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C flush buffer before we do a write
CALL VDBUFL
C WRITE THE ERROR TO THE LISTING.
WRITE(KWRTFL,10)ERRNUM,ERRSEV
10 FORMAT(' SVDI ERROR NUMBER ',I5,' SEVERITY CODE ',I5)
C TRACEBACK.
csam CALL PSTTBK
RETURN
END
SUBROUTINE VDMONI(ISTATE)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDMONI -Logs Usage Information..
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -ISTATE = 0 - initialization
C 1 - new page
C 2 - terminate
C CALLS
C EXIT CONDITIONS -
C NARRATIVE -For ISTATE=0, job information is initialized, and
C timers are initialized called by VIINIT.
C ISTATE=1 will increment a common block page
C counter called by VINWPG.
C ISTATE=2 is called by VITERM and will cause
C the collected usage monitoring information to
C be written to a file.
C Contains entry points VBPKG which will has
C an 8 character parameter which will set a common
C block variable specifying the package being used.
C Entry point VBDEV has an 8 character parameter
C which will set a common block variable specifying
C the device being used.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C dummy routine
CHARACTER*(*) C1,C2
RETURN
C Usage Monitoring Information
ENTRY VBPKG (C1)
RETURN
ENTRY VBDEV (C2)
RETURN
ENTRY VBIQPK(C1)
C1=' '
RETURN
ENTRY VBIQDV(C2)
C2=' '
RETURN
END
SUBROUTINE VDMOVA(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDMOVA -Move Absolute.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VIMOVA
C EXIT CONDITIONS -
C NARRATIVE -Set current position to absolute NDC position X,Y.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VIMOVA.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VIMOVA(X,Y)
RETURN
END
SUBROUTINE VDNWPG
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDNWPG -New Page.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -
C CALLS -VINWPG.
C EXIT CONDITIONS -
C NARRATIVE -Physically advance the medium or clear the screen,
C whichever is appropriate. Also flood the screen
C with the background color on devices that support
C this function. The current position is not changed.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VINWPG.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VINWPG
RETURN
END
SUBROUTINE VDPNTA(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDPNTA -Point Absolute.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VIPNTA.
C EXIT CONDITIONS -
C NARRATIVE -Set current position to absolute NDC position X,Y
C and put a visible point there. Attributes
C foreground color and intensity apply.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VIPNTA.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VIPNTA(X,Y)
RETURN
END
SUBROUTINE VDPOLY(XARRAY,YARRAY,NPTS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDPOLY -POLYGON FILL ROUTINE
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -XARRAY-ARRAY OF X VALUES OF THE POLYGON
C YARRAY-CORRESPONDING ARRAY OF Y VALUES
C NPTS- NUMBER OF POINTS IN (XARRAY,YARRAY)
C CALLS -VIPOLY
C EXIT CONDITIONS -
C NARRATIVE -The polygon defined by XARRAY,YARRAY will be drawn
C and filled (constrained by any limitations of the
C physical device -- see below). No checking will be
C done -- all points will be passed to the device.
C Current foreground color is used and the polygon
C boundary is drawn using the solid line style.
C VDI will close the polygon (i.e. the last point
C will be connected to the first).
C The level of support for this primitive is device-
C dependent. The level of support is categorized
C as follows:
C Level 0 -- no polygon fill. Only the polygon
C boundary is drawn.
C Level 1 -- the device fills convex polygons.
C Level 2 -- the device fills simple polygons (may
C be concave but not self-crossing)
C Level 3 -- full support for complex polygons (may
C be self-crossing). In general, the interior of
C a complex polygon is defined by the set of points
C such that, for each point, when an imaginary line
C is drawn to that point from a point far outside
C the polygon, that line intersects the polygon
C boundary an odd number of times.
C Note that the level of support for a particular device
C can be inquired using the function VDIQDC.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER NPTS
REAL XARRAY(NPTS),YARRAY(NPTS)
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VIPOLY.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
IF(MOPOLY.EQ.0) THEN
CALL VIPOLY(XARRAY,YARRAY,NPTS)
END IF
RETURN
END
SUBROUTINE VDSTOS(ATTARR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTOS -Set Output Status (of Attributes).
C K.M. ERICKSON -14 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -ATTARR = real array of attribute values.
C CALLS -VDSTBC,VDSTCS,VDSTFC,VDSTIN,VDSTLS,VDSTLW
C EXIT CONDITIONS -VECTOR = real updated attribute values (ATTARR).
C NARRATIVE -Set the attribute values from ATTARR as given below.
C ATTARR(1)=Foreground Color
C (2)=Background Color
C (3)=Intensity
C (4)=Line Style
C (5)=Line Width
C (6)=Character Box Y
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL ATTARR(6)
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C CALL EACH OF THE INDIVIDUAL ATTRIBUTE SETTING ROUTINES.
C CHECK FOR VALIDITY OF INPUT VALUES WILL BE DONE IN EACH INDIVIDUAL
C ROUTINE.
CALL VDSTFC(NINT(ATTARR(1)))
CALL VDSTBC(NINT(ATTARR(2)))
CALL VDSTIN(ATTARR(3))
CALL VDSTLS(NINT(ATTARR(4)))
CALL VDSTLW(ATTARR(5))
c CALL VDSTCS(ATTARR(6))
RETURN
END
SUBROUTINE VDTERM
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDTERM -Terminate SVDI.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -
C CALLS -VITERM.
C EXIT CONDITIONS -
C NARRATIVE -Terminate the SVDI by flushing buffers, etc. This
C should be the last SVDI call made.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VITERM.
C THIS ORGANIZATION FACILITATES ADDING SECURITY MARKINGS TO SVDI.
CALL VITERM
RETURN
END
SUBROUTINE VDTEXT(LENGTH,CHARS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDTEXT -Text from Array.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Device-independent.
C ENTRY CONDITIONS -LENGTH = integer number of characters in CHARS.
C Range 1-136.
C CHARS = integer array of ASCII characters, one
C character per array element, right justified.
C Range 8,10,32-126.
C CALLS -VITEXT.
C EXIT CONDITIONS -
C NARRATIVE -Draw LENGTH characters in CHARS, starting at
C current position and update current position to
C the point after the last character box where the
C next character would begin. Current position
C indicates the lower left corner of the first
C character box. Only printable characters (32-126
C decimal) and backspace and linefeed are allowed.
C All values in this range must produce "reasonable"
C output; mapping lower case to upper case letters is
C considered reasonable. Attributes foreground color,
C background color, intensity, and character size
C apply.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER LENGTH,CHARS(136)
C THIS IS JUST A DUMMY ROUTINE WHICH DOES NOTHING BUT CALL VITEXT.
C THIS ORGANIZATION FACILITATES ADDING SECURITY NARKINGS TO SVDI.
CALL VITEXT(LENGTH,CHARS)
RETURN
END
SUBROUTINE VDFRAM(ITYPE)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDFRAM - Draw header or trailer frame
C P. Watterberg - 27 Aug 81
C ENVIRONMENT -Computer-independent, system-independent, FORTRAN 77
C ENTRY CONDITIONS - ITYPE = 0 for header frame
C = 1 for trailer frame
C CALLS - VIFRAM
C EXIT CONDITIONS -
C NARRATIVE - Calls vifram to get time and date from the
C system via the computer-dependent routine PSTTOD(entry
C point in PSTJOB) and writes it on an identification frame.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ITYPE
CALL VIFRAM(ITYPE)
RETURN
END
SUBROUTINE VIFRAM(ITYPE)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VIFRAM - Draw header or trailer frame
C P. Watterberg - 27 Aug 81
C ENVIRONMENT -Computer-independent, system-independent, FORTRAN 77
C ENTRY CONDITIONS - ITYPE = 0 for header frame
C = 1 for trailer frame
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -NULL ROUTINE
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ITYPE
RETURN
END
SUBROUTINE VDAABU(BTNNUM)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDAABU -Await Any Button.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -BTNNUM = integer number of the button pressed.
C Range 1 to a device dependent maximum which must be
C at least 8.
C NARRATIVE -When a button has been pressed, its integer button
C number is returned in BTNNUM. This function flushes
C the button buffer, if any. This function flushes
C the output buffers before doing input.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER BTNNUM
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
BTNNUM=32
RETURN
END
SUBROUTINE VDABGL(BTNNUM,X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDABGL -Await Button, Get Locator.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -BTNNUM = integer number of the button pressed.
C Range 1 to a device dependent maximum that must be
C at least 8.
C X,Y = real NDC position of the locator.
C NARRATIVE -Wait until a button is hit, then return the number
C of the button in BTNNUM and the NDC value of the
C locator in X,Y. This function flushes the output
C buffers before doing input.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
INTEGER BTNNUM
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
BTNNUM=32
X=0
Y=0
RETURN
END
SUBROUTINE VDAKGL(CHAR,X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDAKGL -Await Keyboard, Get Locator.
C R.W.SIMONS -02DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -CHAR = integer ASCII character input from the
C keyboard, right-justified, zero fill. Range 32-126.
C X,Y = real NDC position of the locator.
C NARRATIVE -Wait until a key is hit, then return the character
C entered in CHAR and the NDC value of the locator
C in X,Y. If the character entered does not fall in
C the range 32-126, a blank(32) is returned in CHAR.
C This function flushes the output buffers before
C doing input.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
INTEGER CHAR
C dummy routine
CHAR=32
X=0.
Y=0.
RETURN
END
SUBROUTINE VDALOC(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDALOC -Await Locator.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -X,Y = real NDC position of the locator.
C NARRATIVE -Wait until the locator is positioned, then return
C the NDC value of the locator in X,Y. The fact that
C the locator is positioned can be signaled in a
C variety of device dependent ways, such as clicking
C the switch in a tablet pen, hitting a button, or
C hitting a key on the keyboard. Any information
C contained in this signal is ignored by this
C function, as only the locator position is returned.
C This function flushes the output buffers before
C doing input.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
X=0
Y=0
RETURN
END
SUBROUTINE VDBELL
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDBELL -Ring Bell
C R.W.SIMONS -02DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Ring user's bell to get his attention. This
C function is ignored by batch devices.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C THIS FUNCTION IS IGNORED BY BATCH DEVICES.
RETURN
END
SUBROUTINE VDBUFL
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDBUFL -Buffer Flush.
C R.W.Simons -19DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Assure that the picture is up-to-date by flushing
C buffers if necessary. Also prepare the device to
C operate in alphanumeric (as opposed to graphic)
C mode. This is necessary on some devices so that
C alphanumeric data from FORTRAN I/O won't be
C misinterpreted as graphic data.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C THIS FUNCTION IS IGNORED BY BATCH DEVICES.
RETURN
END
SUBROUTINE VDSTLA(LOCX,LOCY)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTLA -Set Initial Locator Position.
C R.W.Simons -08APR81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -LOCX,LOCY = real NDC position that the locator is
C initilaized to.
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Set the initial locator position (light pen tracking
C cross, for example) each time this function is
C called.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL LOCX,LOCY
C BATCH DEVICES IGNORE THIS FUNCTION.
RETURN
END
SUBROUTINE VDWAIT
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDWAIT -Wait for User.
C R.W.SIMONS -02DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Batch Devices.
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Wait for the user to view the screen and signal he
C is done, normally by hitting any key. This function
C flushes the output buffers before doing input.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C BATCH DEVICES IGNORE THIS COMMAND.
RETURN
END
SUBROUTINE VDIQCO(NUM,INDEX,CLRARY,CLRMOD)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQCO -Inquire Color Table.
C R.W.Simons -08APR81
C H. S. LAUSON 29MAY86 - changed for current HLS interpretation
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Black and White Devices. (LXY, HC1, ALP)
C ENTRY CONDITIONS -NUM = integer number of color indexes to inquire.
C Range 1-256.
C INDEX = integer array of indexes to inquire. Range
C 0-255.
C CLRMOD = integer color model to be used. Range 0,1.
C CALLS -VBERRH
C EXIT CONDITIONS -CLRARY = real array of 3 by NUM elements returning
C the values of the components of the indexes inquired.
C Range for RGB: red 0.0-1.0
C green 0.0-1.0
C blue 0.0-1.0
C Range for HLS: hue 0.0-360.0
C lightness 0.0-1.0
C saturation 0.0-1.0
C NARRATIVE -Inquire one or more color table entries. NUM and
C INDEX specify how many and which indexes are being
C inquired. CLRMOD specifies which color model
C (0=RGB, 1=HLS) should be used in constructing values
C to return in CLRARY. A device which does not
C support a color table index specified will
C return -1.0 in the first element of the CLRARY value
C for that index.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER NUM,INDEX(NUM),CLRMOD
REAL CLRARY(3,NUM)
COMMON /PCOLST/ PCOLS(3,256)
C CHECK FOR VALID NUM.
IF(NUM.LT.1.OR.NUM.GT.256) THEN
CALL VBERRH(723,5)
GOTO 999
END IF
C CHECK FOR VALID CLRMOD.
IF(CLRMOD.NE.0.AND.CLRMOD.NE.1) THEN
CALL VBERRH(725,5)
GOTO 999
END IF
IF(CLRMOD.NE.0) STOP 'HLS COLORS NOT SUPPORTED'
C CHECK FOR VALID INDEXES.
DO 100 I=1,NUM
INDEXN=INDEX(I)
IF(INDEXN.LT.0.OR.INDEXN.GT.255) THEN
CALL VBERRH(724,5)
GOTO 100
END IF
CLRARY(1,I)=PCOLS(1,INDEXN)
CLRARY(2,I)=PCOLS(2,INDEXN)
CLRARY(3,I)=PCOLS(3,INDEXN)
100 CONTINUE
999 RETURN
END
SUBROUTINE VDIQCP(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQCP -Inquire Where Current Position Is.
C R.W.Simons -02DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Devices that support a software CP.
C (AP5,GER,H50,HC1,HCB,HPP,I10,I30,LXY,QCR,QMS,XYN)
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -X,Y = real NDC position.
C NARRATIVE -Return the value of current position.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C CURRENT POSITION.
REAL XCP,YCP
COMMON /VCCRPS/ XCP,YCP
C ASSIGN THE CP TO X,Y.
X=XCP
Y=YCP
RETURN
END
SUBROUTINE VDSTBC(COLOR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTBC -Set Background Color.
C R.W.Simons -05DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Devices with a constant white background. (LXY,
C HC1, ALP)
C ENTRY CONDITIONS -COLOR = integer color table index. Range 0-255.
C Default: device dependent, in range 0-7.
C CALLS -VBERRH
C EXIT CONDITIONS -VECTOR(2) = real updated background color (COLOR).
C NARRATIVE -Set the background color for following VDNWPG or
C TEXT primitives for devices supporting these
C features. For example, many raster devices support
C both an overall background color and a background
C for character drawing(e.g.,red letters on a green
C box).
C All devices must support at least a single device
C dependent value in the range 0-7.
C If an unsupported value is specified, set to
C default.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER COLOR
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C CHECK FOR VALID COLOR.
IF(COLOR.LT.0.OR.COLOR.GT.255) THEN
CALL VBERRH(724,5)
GOTO 999
END IF
C ONLY THE SINGLE BACKGROUND COLOR 7 (WHITE) IS SUPPORTED,
C SO NO ACTION IS NECESSARY.
vector(2) = color
999 RETURN
END
SUBROUTINE VDSTCO(NUM,INDEX,CLRARY,CLRMOD)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTCO -Set Color Table.
C R.W.SIMONS -02DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Black and White Devices. (LXY, HC1, ALP)
C ENTRY CONDITIONS -NUM = integer number of color indexes to be set.
C Range 1-256.
C INDEX = integer array of indexes to be set. Range
C 0-255.
C CLRARY = real array of 3 by NUM elements specifying
C the values of the components of the index to be
C set.
C Range for RGB: red 0.0-1.0
C green 0.0-1.0
C blue 0.0-1.0
C Range for HLS: hue 0.0-360.0
C lightness 0.0-1.0
C saturation 0.0-1.0
C Default:
C Index Color RGB Values
C 0 black 0.,0.,0.
C 1 red 1.,0.,0.
C 2 green 0.,1.,0.
C 3 yellow 1.,1.,0.
C 4 blue 0.,0.,1.
C 5 magenta 1.,0.,1.
C 6 cyan 0.,1.,1.
C 7 white 1.,1.,1.
C CLRMOD = integer color model being used. Range 0,1.
C Default: 0 (RGB).
C CALLS -VBERRH
C EXIT CONDITIONS -
C NARRATIVE -Set one or more color table entries. This is a
C dynamic setting, if the device will support it.
C "Dynamic" neans that primitives which have already
C been drawn will change their appearance when a
C dynamic setting is changed. INDEX is the
C position (or array of positions) in the table
C (0-255). CLRARY is a three-element vector (or 3 by
C NUM array) with the fractions (0.-1.) of RGB or
C values (0.0-360.0, 0.0-1.0, 0.0-1.0) of HLS.
C A translator for HLS to RGB will be used from
C GSPC79. CLRMOD specifies which color model is being
C used (0=RGB, 1=HLS).
C All devices must support at least a single device
C dependent value for each of red, green, and blue and
C the corresponding values for hue, lightness, and
C saturation. If unsupported values are specified,
C set to the closest supported values.
C All devices must support both RGB and HLS color
C models.
C All devices must support at least a single device
C dependent INDEX value in the range 0-7. If an
C unsupported value is specified, it should be ignored.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER NUM,INDEX(NUM),CLRMOD
REAL CLRARY(3,NUM)
CHARACTER*6 KOLIND
CHARACTER*20 KOLCOM
COMMON /VCVEC1/ IVECT
INTEGER IVECT
C ARRAY TO CONTAIN COMPLETE COLOR TABLE
COMMON /PCOLST/ PCOLS(3,256)
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
C CHECK FOR VALID NUM.
IF(NUM.LT.1.OR.NUM.GT.256) THEN
CALL VBERRH(723,5)
GOTO 999
END IF
C CHECK FOR VALID CLRMOD.
IF(CLRMOD.NE.0.AND.CLRMOD.NE.1) THEN
CALL VBERRH(725,5)
GOTO 999
END IF
C CHECK FOR VALID INDEXES.
DO 100 I=1,NUM
INDEXN=INDEX(I)
IF(INDEXN.LT.0.OR.INDEXN.GT.255) THEN
CALL VBERRH(724,5)
GOTO 100
END IF
C CHECK FOR VALID CLRARY.
CLRAR1=CLRARY(1,I)
CLRAR2=CLRARY(2,I)
CLRAR3=CLRARY(3,I)
IF(CLRMOD.EQ.0) THEN
IF(CLRAR1.LT.0..OR.CLRAR1.GT.1.
X .OR.CLRAR2.LT.0..OR.CLRAR2.GT.1.
X .OR.CLRAR3.LT.0..OR.CLRAR3.GT.1.) THEN
CALL VBERRH(727,5)
GOTO 100
END IF
C 256 INDEXES ARE SUPPORTED:
PCOLS(1,INDEXN+1)=CLRARY(1,I)
PCOLS(2,INDEXN+1)=CLRARY(2,I)
PCOLS(3,INDEXN+1)=CLRARY(3,I)
C define symbol for color reference
IF(MOCOLR.NE.0) GO TO 390
C if a set of vectors was in process, issue stroke command
C to draw them - then start a new path.
IF(IVECT.NE.0) THEN
CALL PSTBUF(2,'s ')
IVECT=0
END IF
CALL PSTBUF(0,' ')
CALL PSTBUF(2,'r ')
KOLIND='/c'
IF(INDEXN.LE.9) THEN
WRITE(KOLIND(3:3),'(I1)',ERR=310) INDEXN
NNN=4
ELSEIF(INDEXN.LE.99) THEN
WRITE(KOLIND(3:4),'(I2)',ERR=310) INDEXN
NNN=5
ELSE
WRITE(KOLIND(3:5),'(I3)',ERR=310) INDEXN
NNN=6
END IF
WRITE(KOLCOM,300,ERR=310) (PCOLS(IC,INDEXN+1),IC=1,3)
300 FORMAT(F5.3,2F6.3,' q}')
CALL PSTBUF(NNN+26,KOLIND(1:NNN)//'{'//KOLCOM//' def ')
310 CONTINUE
C save and restore can not be in same line - why?
CALL PSTBUF(0,' ')
CALL PSTBUF(1,'v')
CALL PSTBUF(0,' ')
390 CONTINUE
ELSE
IF(CLRAR1.LT.0..OR.CLRAR1.GT.360.
X .OR.CLRAR2.LT.0..OR.CLRAR2.GT.1.
X .OR.CLRAR3.LT.0..OR.CLRAR3.GT.1.) THEN
CALL VBERRH(727,5)
GOTO 100
END IF
C 256 INDEXES ARE SUPPORTED:
STOP 'HLS COLORS NOT AVAILABLE'
END IF
100 CONTINUE
999 RETURN
END
SUBROUTINE VDSTFC(COLOR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTFC -Set Foreground Color.
C R.W.Simons -05DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Devices with a constant black foreground. (LXY,
C HC1)
C ENTRY CONDITIONS -COLOR = integer color table index . Range 0-255.
C Default is device dependent, in range 0-7.
C CALLS -VBERRH
C EXIT CONDITIONS -VECTOR(1) = real updated foreground color (COLOR).
C NARRATIVE -Set the foreground color index, i.e., the color
C table index used for drawing future primitives.
C Color is an integer from 0-255 which is used as an
C index into the color table (see VDSTCO).
C All devices must support at least a single device
C dependent value in the range 0-7.
C If an unsupported value is specified, set to
C default.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER COLOR
CHARACTER*5 KOLIND
C ARRAY TO CONTAIN COMPLETE COLOR TABLE
COMMON /PCOLST/ PCOLS(3,256)
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
COMMON /VCVEC1/ IVECT
INTEGER IVECT
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C CHECK FOR VALID COLOR.
IF(COLOR.LT.0.OR.COLOR.GT.255) THEN
CALL VBERRH(724,5)
GO TO 999
END IF
VECTOR(1)=COLOR
IF(MOCOLR.EQ.0) THEN
C draw any vectors in stack before changing colors
IF(IVECT.NE.0) THEN
CALL PSTBUF(4,'s r ')
CALL PSTBUF(0,' ')
CALL PSTBUF(4,'v o ')
CALL PSTBUF(0,' ')
IVECT=0
END IF
C code using symbols
KOLIND='c'
IF(COLOR.LE.9) THEN
KOLOR=COLOR
C test for interchange of colors 0 and 7
IF(KPSTCI.NE.0) THEN
IF(KOLOR.EQ.7) THEN
KOLOR=0
ELSEIF(KOLOR.EQ.0) THEN
KOLOR=7
END IF
END IF
WRITE(KOLIND(2:2),'(I1)',ERR=999) KOLOR
NNN=3
ELSEIF(COLOR.LE.99) THEN
WRITE(KOLIND(2:3),'(I2)',ERR=999) COLOR
NNN=4
ELSE
WRITE(KOLIND(2:4),'(I3)',ERR=999) COLOR
NNN=5
END IF
CALL PSTBUF(NNN,KOLIND(1:NNN))
END IF
999 RETURN
END
SUBROUTINE VDSTIN(INTEN)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTIN -Set Intensity.
C R.W.Simons -05DEC80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Single Intensity Devices. (LXY, HC1)
C ENTRY CONDITIONS -INTEN = real intensity of the image of an output
C primitive. Range 0.-1. Default: device dependent.
C CALLS -
C EXIT CONDITIONS -VECTOR(3) = real updated intensity (INTEN).
C NARRATIVE -Set the intensity value indicated for future
C primitives. Intensity is a real value between 0
C (not visible) and 1 (maximum). Intensities are
C monotonically increasing within this range.
C All devices must support at least a single value:
C 1.0. If an unsupported value is specified, set to
C the closest supported intensity.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL INTEN
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C CHECK FOR VALID INTEN.
IF(INTEN.LT.0.0.OR.INTEN.GT.1.0) THEN
CALL VBERRH(401,5)
GOTO 999
END IF
C ONLY THE SINGLE INTENSITY 1.0 (MAXIMUM) IS SUPPORTED,
C SO NO ACTION IS NECESSARY.
999 RETURN
END
SUBROUTINE VITERM
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VITERM -TERMINATE.
C D.L. CAMPBELL -1-DEC-1986
C J.P. LONG -9-NOV-1987
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Terminate graphics device. Close output file.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
COMMON /VCPAGE/ TOTPAG
INTEGER TOTPAG
CHARACTER*10 KPAGE
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
C put out the last page and restore postscript environment so
C nothing is left on the stack
CALL VINWPG
CALL PSTBUF(2,'r ')
C FLUSH BUFFER
CALL PSTBUF(0,' ')
C write end of data message
WRITE(KPAGE,'(I10)',ERR=345) TOTPAG
GO TO 349
345 KPAGE=' ???'
349 CONTINUE
CALL PSTBUF(9, '%%Trailer')
CALL PSTBUF(0,' ')
IF(MOCOLR.EQ.0) THEN
CALL PSTBUF(3,'end')
CALL PSTBUF(0,' ')
END IF
CALL PSTBUF(19,'%%Pages: '//KPAGE)
CALL PSTBUF(0,' ')
CALL PSTBUF(5, '%%EOF')
CALL PSTBUF(0,' ')
C CLOSE OUTPUT FILE
CALL PSTCFS(KOUTFL,1)
CALL VDMONI(2)
RETURN
END
SUBROUTINE VIMOVA(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VIMOVA -Move Absolute.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -
C EXIT CONDITIONS -XCP,YCP = real updated current position. (X,Y)
C NARRATIVE -Set current position to absolute NDC position X,Y.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
C move
CALL VBVECT(0,X,Y)
RETURN
END
SUBROUTINE VIPNTA(X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VIPNTA -Point Absolute.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VIMOVA,VILINA
C EXIT CONDITIONS -
C NARRATIVE -Set current position to absolute NDC position X,Y
C and put a visible point there. Attributes
C foreground color and intensity apply.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL X,Y
CALL VIMOVA(X,Y)
CALL VILINA(X,Y)
RETURN
END
SUBROUTINE VIPOLY(XARRAY,YARRAY,NPTS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VIPOLY -POLYGON FILL ROUTINE
C D.L. CAMPBELL -1-DEC-1986
C J.P. LONG -9-NOV-1987
C ENVIRONMENT -Fortran77, QMS
C ENTRY CONDITIONS -XARRAY-ARRAY OF X VALUES OF THE POLYGON
C YARRAY-CORRESPONDING ARRAY OF Y VALUES
C NPTS- NUMBER OF POINTS IN (XARRAY,YARRAY)
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -The polygon defined by XARRAY,YARRAY will be drawn
C and filled (constrained by any limitations of the
C physical device -- see below). No checking will be
C done -- all points will be passed to the device.
C Current foreground color is used and the polygon
C boundary is drawn using the solid line style.
C VDI will close the polygon (i.e. the last point
C will be connected to the first).
C The level of support for this primitive is device-
C dependent. The level of support is categorized
C as follows:
C Level 0 -- no polygon fill. Only the polygon
C boundary is drawn.
C Level 1 -- the device fills convex polygons.
C Level 2 -- the device fills simple polygons (may
C be concave but not self-crossing)
C Level 3 -- full support for complex polygons (may
C be self-crossing). In general, the interior of
C a complex polygon is defined by the set of points
C such that, for each point, when an imaginary line
C is drawn to that point from a point far outside
C the polygon, that line intersects the polygon
C boundary an odd number of times.
C Note that the level of support for a particular device
C can be inquired using the function VDIQDC.
********************************************************************************
C The level for this device is level 2.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL XARRAY(NPTS),YARRAY(NPTS)
C ESCAPE FLAGS
C PATNO AND BORDER USED BY VIPOLY FOR PATTERN FILL AND BORDER ON/OFF. DEFAULT
C COMPLETE FILL AND BORDER ON
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
COMMON /VCESCP/ PGFORM,PATNO,BORDER
INTEGER PGFORM,PATNO,BORDER
COMMON /VCVEC1/ IVECT
COMMON /VCVEC2/ COORD, LSTCRD
CHARACTER COORD*20, LSTCRD*20
INTEGER IVECT
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
C CHECK FOR VALID N
IF (NPTS.LT.1 .OR. NPTS.GT.1490) THEN
CALL VBERRH(802,5)
GO TO 999
END IF
C IF A SET OF VECTORS WAS IN PROCESS, ISSUE STROKE COMMAND TO DRAW THEM
C Start a new path.
IF(IVECT.NE.0) THEN
CALL PSTBUF(2,'s ')
IVECT=0
END IF
CALL PSTBUF(2,'r ')
CALL PSTBUF(0,' ')
CALL PSTBUF(4,'v o ')
WSAVE=VECTOR(5)
CALL PSTBUF(4,'0 w ')
C CALL VDSTLW(0.)
IF(MOCOLR.EQ.0) THEN
CALL VDSTFC(NINT(VECTOR(1)))
END IF
CALL PSTBUF(0,' ')
C DRAW POLYGON VECTORS
C MOVE TO FIRST POINT
CALL VIMOVA(XARRAY(1),YARRAY(1))
C CALL VDLINA TO DRAW POINTS FROM 1ST POINT TO NTH POINT
DO I=2,NPTS
CALL VILINA(XARRAY(I),YARRAY(I))
end do
C THEN DRAW A LINE TO THE FIRST POINT TO CLOSE THE POLYGON
CALL VILINA(XARRAY(1),YARRAY(1))
C CLOSE THE POLYGON, GRAPHICS SAVE, FILL IT, GRAPHICS RESTORE, STROKE
C TO PROVIDE THE SAME FILLED AREA AS IF IT WERE FILLED WITH VECTORS
C THEN RESTORE AND SAVE POSTSCRIPT ENVIRONMENT TO AVOID INPUT BUFFER OVERFLOW
CALL PSTBUF(12,'c d f u s r ')
IVECT=0
CALL PSTBUF(0,' ')
CALL PSTBUF(4,'v o ')
CALL VDSTLW(WSAVE)
C ... if color is on (mocolr = 0), then font is set in vdstfc
IF(MOCOLR.EQ.0) THEN
CALL VDSTFC(NINT(VECTOR(1)))
ELSE
c CALL VDSTCS(VECTOR(6))
END IF
CALL PSTBUF(0,' ')
C INIT THE CURRENT POSITION WITHIN POSTSCRIPT
CALL VDMOVA(XARRAY(NPTS),YARRAY(NPTS))
IVECT=0
999 RETURN
END
SUBROUTINE VINWPG
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VINWPG -New Page.
C D.L. CAMPBELL -1-DEC-1986
C J.P. LONG -9-NOV-1987
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Physically advance the medium or clear the screen,
C whichever is appropriate. Also flood the screen
C with the background color on devices that support
C this. The current position is not changed.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
COMMON /VCVEC1/ IVECT
COMMON /VCVEC2/ COORD,LSTCRD
C vcpstd variables control what to do with empty frames with
C command is received to dump data to output
C kempty=0, frame is void - do not draw
C >0, frame has data - draw it
COMMON /VCPSTD/ KEMPTY
CHARACTER COORD*20, LSTCRD*20
CHARACTER*10 KPAGE
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
INTEGER IVECT
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
COMMON /VCPAGE/ TOTPAG
INTEGER TOTPAG
DATA NPAGE /0/
C check for void page draw request
C if nothing is on page, skip request
NPAGE=NPAGE+1
TOTPAG = NPAGE
WRITE(KPAGE,'(I10)',ERR=345) NPAGE
GO TO 349
345 KPAGE=' ???'
349 IF(KEMPTY.EQ.0) GO TO 350
C stroke the path in case there are any vectors and show text
CALL PSTBUF(2,'s ')
IVECT=0
C showpage and restore postscript environment to avoid buffer overflow
C flush buffer because save and restore won't work back-to-back
CALL PSTBUF(4,'p r ')
CALL PSTBUF(0,' ')
C comment frame number in output file
CALL PSTBUF(31,'%%Page: "'//KPAGE//'" '//KPAGE)
CALL PSTBUF(0,' ')
CALL PSTBUF(28, '%%PageOrientation: Landscape')
CALL PSTBUF(0,' ')
CALL PSTBUF(32, '%%PageBoundingBox: 36 30 574 750')
CALL PSTBUF(0,' ')
CALL PSTBUF(4,'v o ')
CALL VDMONI(1)
C shade background if appropriate
IF(KPSTBG.NE.0) THEN
CALL PSTBBG
END IF
GO TO 370
C void frame -- First Page
350 CALL PSTBUF(2, 'r ')
CALL PSTBUF(0,' ')
CALL PSTBUF(31,'%%Page: "'//KPAGE//'" '//KPAGE)
CALL PSTBUF(0,' ')
CALL PSTBUF(28, '%%PageOrientation: Landscape')
CALL PSTBUF(0,' ')
CALL PSTBUF(32, '%%PageBoundingBox: 36 30 574 750')
CALL PSTBUF(0,' ')
CALL PSTBUF(4, 'v o ')
370 CALL VDSTLW(VECTOR(5))
c CALL VDSTCS(VECTOR(6))
CALL VDSTFC(NINT(VECTOR(1)))
CALL PSTBUF(0,' ')
KEMPTY=0
RETURN
END
SUBROUTINE VDESCP(ESCPCD,N,ARGS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDESCP -Escape Code Routine.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -ESCPCD = integer escape function code.
C N = integer number of arguments in ARG. RANGE >=0.
C ARGS = real array of arguments for the escape
C function specified.
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -Invoke the nonstandard, device-dependent function
C ESCPCD. N is the number of arguments used by this
C function and ARGS is a real array containing those
C arguments. Unsupported values of ESCPCD are
C ignored, not causing an error.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ESCPCD,N
REAL ARGS(*)
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
INTEGER XPAD,YPAD,XDEVIC,YDEVIC
COMMON /VCDDIM/ XPAD,YPAD,XDEVIC,YDEVIC
C USED BY VIPOLY FOR PATTERN FILL AND BORDER ON/OFF. DEFAULT COMPLETE FILL
C AND BORDER ON. PLC.
COMMON/VCESCP/PGFORM,PATNO,BORDER
INTEGER PGFORM,PATNO,BORDER
C CHECK FOR VALID N.
IF(N.LT.0) THEN
CALL VBERRH(802,5)
GOTO 999
END IF
C 2100 - PAGE FORMAT (0=LANDSCAPE,1=PORTRAIT)
IF (ESCPCD.EQ.2100) THEN
IF (ARGS(1).EQ.0) THEN
PGFORM=0
ELSE
PGFORM=1
ENDIF
C set output format
ELSEIF (ESCPCD.EQ.2101) THEN
CALL PSTSEL('1')
ELSEIF (ESCPCD.EQ.2102) THEN
CALL PSTSEL('2')
ELSEIF (ESCPCD.EQ.2103) THEN
CALL PSTSEL('3')
ELSEIF (ESCPCD.EQ.2104) THEN
CALL PSTSEL('4')
ELSEIF (ESCPCD.EQ.2105) THEN
CALL PSTSEL('5')
ELSEIF (ESCPCD.EQ.2106) THEN
CALL PSTSEL('6')
ELSEIF (ESCPCD.EQ.2107) THEN
CALL PSTSEL('7')
ELSEIF (ESCPCD.EQ.2108) THEN
CALL PSTSEL('8')
ELSEIF (ESCPCD.EQ.2109) THEN
CALL PSTSEL('9')
ELSEIF (ESCPCD.EQ.2110) THEN
CALL PSTSEL('10')
ENDIF
999 RETURN
END
SUBROUTINE VILINA (X,Y)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VILINA
C D.L. CAMPBELL -1-DEC-1986
C J.P. LONG -9-NOV-1987
C ENVIRONMENT -DEVICE DEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -X,Y REAL NDC COORDINATES
C CALLS -
C EXIT CONDITIONS -CURRENT POSITION IS SET
C NARRATIVE
C LINE-DRAW A LINE FROM CP TO ABSOLUTE NDC POSITION X,Y
C AND UPDATE CP . ATTRIBUTES COLOR,INTEN,LINSTY AND
C LINWTH APPLY.
C OTHER VARIABLES:
C XCP,YCP-NDC COORDINATES
C***************************************************************************
REAL X,Y
C vcpstd variables control what to do with empty frames with
C command is received to dump data to output
C kempty=0, frame is void - do not draw
C >0, frame has data - draw it
COMMON /VCPSTD/ KEMPTY
C draw
ENTRY VBLINA(X,Y)
CALL VBVECT(1,X,Y)
KEMPTY=1
RETURN
END
SUBROUTINE VBVECT(IPEN,X,Y)
C****************************************************
C vbvect - do move or draw to x,y (depending on ipen)
C ipen = 0 for move, 1 for draw
C x,y = NDC coordinates to be moved/drawn to
C******************************************************
REAL X,Y,XOFF,YOFF
CHARACTER CTEMP*20,XCOORD*4,YCOORD*4
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
INTEGER XPAD,YPAD,XDEVIC,YDEVIC
COMMON /VCDDIM/ XPAD,YPAD,XDEVIC,YDEVIC
C CURRENT POSITION.
REAL XCP,YCP
COMMON /VCCRPS/ XCP,YCP
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
COMMON /VCVEC1/ IVECT
COMMON /VCVEC2/ COORD, LSTCRD
CHARACTER COORD*20, LSTCRD*20
INTEGER IVECT
C compute new point in dev. coord.
C convert to floating offsets
XOFF=XPAD
YOFF=YPAD
IXDC=X*XSCALE+XOFF
IYDC=Y*YSCALE+YOFF
C write(xcoord,'(i5)')ixdc
C write(ycoord,'(i5)')iydc
C ...include both x,y
CALL PSTI2C(IXDC,4,XCOORD)
CALL PSTI2C(IYDC,4,YCOORD)
COORD = XCOORD(1:3)//'.'//XCOORD(4:4)//' '//
1 YCOORD(1:3)//'.'//YCOORD(4:4)
C pack up move/draw command, send it down
C if (lstcrd(1:11) .ne. coord(1:11)) then
IF (IPEN.EQ.0) THEN
CTEMP= COORD(1:11) // ' m '
ELSE
CTEMP= COORD(1:11) // ' l '
ENDIF
CALL PSTBUF(14,CTEMP)
C ...count the coordinate pair
IVECT=IVECT+1
C end if
lstcrd(1:11) = coord(1:11)
C stroke the path if we are approaching the 1500-coord pair limit
C also restore and save postscript environment to avoid
C input buffer overflow (must have a c/r between restore
C and save)
IF(IVECT.GT.1400) THEN
lstcrd(1:11) = ' '
CALL PSTBUF(4,'s r ')
CALL PSTBUF(0,' ')
CALL PSTBUF(4,'v o ')
CALL VDSTLW(VECTOR(5))
IF(MOCOLR.EQ.0) THEN
CALL VDSTFC(NINT(VECTOR(1)))
END IF
C ...reset the vector count - vdstls (called by vdstlw)
C reinitted the current posn
IVECT=1
ENDIF
C UPDATE CURRENT POSITION
XCP=X
YCP=Y
RETURN
END
SUBROUTINE VITEXT(LENGT1,CHARS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VITEXT - Text from Array.
C P. Watterberg - 24 MAR 81
C J. P. LONG - 3 DEC 87
C ENVIRONMENT - COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS - LENGT1 = integer number of characters in CHARS.
C Range 1-136.
C CHARS = integer array of ASCII characters, one
C character per array element, right justified.
C Range 8,10,32-126.
C CALLS - vbout
C EXIT CONDITIONS - XCP,YCP = integer updated current position (at the end
C of the string).
C NARRATIVE - Draw LENGT1 characters in CHARS, starting at
C current position and update current position to
C the point after the last character box where the
C next character would begin. Current position
C indicates the lower left corner of the first
C character box. Only printable characters (32-126
C decimal) and backspace and linefeed are allowed.
C All values in this range must produce "reasonable"
C output; mapping lower case to upper case letters is
C considered reasonable. Attributes foreground color,
C background color, intensity, and character size
C apply.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER LENGT1, CHARS(136), LENGTH
CHARACTER CTEMP*150,STR*3
C CURRENT POSITION.
REAL XCP,YCP
COMMON /VCCRPS/ XCP,YCP
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
INTEGER XPAD,YPAD,XDEVIC,YDEVIC
COMMON /VCDDIM/ XPAD,YPAD,XDEVIC,YDEVIC
C vcpstd variables control what to do with empty frames with
C command is received to dump data to output
C kempty=0, frame is void - do not draw
C >0, frame has data - draw it
COMMON /VCPSTD/ KEMPTY
C check for valid length.
call vdstcs(vector(6))
KEMPTY=1
LENGTH = LENGT1
IF(LENGTH.LT.1) THEN
CALL VBERRH(212,5)
GO TO 999
END IF
C if(length.gt.136) then call vberrh(213,5), and use the
C maximum length of 136.
IF(LENGTH.GT.136) THEN
CALL VBERRH(213,5)
LENGTH = 136
ENDIF
CTEMP='('
LENOUT=1
C loop through length characters.
DO 100 I=1,LENGTH
C check for valid chars.
C ignore control characters, except for:
C 8 is backspace
C 10 is linefeed
C 13 is carriage return
IF(CHARS(I).LT.32 .OR. CHARS(I).GT.126) THEN
IF(CHARS(I).EQ.8) THEN
DX=-VECTOR(7)
DY=0.
ELSE IF(CHARS(I).EQ.10) THEN
DX=0.
DY= -VECTOR(6)
ELSE IF(CHARS(I).EQ.13) THEN
DX=XPAD-XCP
DY=0.
ELSE
DX=0.
DY=0.
CALL VBERRH(208,5)
GOTO 100
ENDIF
C finish the string, emulate the control char, and start a new one
C send the buffered chars to the printer if there are any
IF(LENOUT.NE.1) THEN
CTEMP(LENOUT+1:150)=') t '
LENOUT=LENOUT+4
CALL PSTBUF(LENOUT,CTEMP)
C reset the cp from the characters
XCP=XCP+(LENOUT-5)*VECTOR(7)
ENDIF
C calculate the new current position after the control char
XCP=XCP+DX
YCP=YCP+DY
CALL VBVECT(0,XCP,YCP)
C start a new string
CTEMP='('
LENOUT=1
ELSE
C Char value is 32-126 inclusive. Put \ before these:
C 92 is \
C 40 is (
C 41 is )
IF(CHARS(I).EQ.40.OR.CHARS(I).EQ.41.OR.CHARS(I).EQ.92) THEN
CTEMP(LENOUT+1:150)='\\'
LENOUT=LENOUT+1
ENDIF
C now pack the chars into the buffer
CALL PSTA2C(CHARS(I),STR)
CTEMP(LENOUT+1:150)=STR(1:1)
LENOUT=LENOUT+1
ENDIF
100 CONTINUE
C send the chars to the printer
CTEMP(LENOUT+1:150)=') t '
LENOUT=LENOUT+4
CALL PSTBUF(LENOUT,CTEMP)
C reset the cp from the characters
XCP=XCP+(LENOUT-5)*VECTOR(7)
999 RETURN
END
SUBROUTINE VDSTLS(LINSTY)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTLS -Set Line Style.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -LINSTY = integer linestyle of line drawing output
C primitives. Range 0-5. Default:0.
C CALLS -
C EXIT CONDITIONS -VECTOR(4) = real updated line style (LINSTY).
C NARRATIVE -Set the style of line as below. This applies only
C to line drawing primitives. The line styles are:
C 0 - solid
C 1 - dotted
C 2 - dot dash
C 3 - short dash
C 4 - long dash
C 5 - medium dash
C All devices must support at least the values 0 and
C 5. If an unsupported value is specified, set to 5.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL LW
INTEGER LINSTY,ILL,JLL
COMMON /VCVEC1/ IVECT
COMMON /VCVEC2/ COORD,LSTCRD
CHARACTER COORD*20, LSTCRD*20
INTEGER IVECT
CHARACTER CTEMP*30,STRL*3,STRS*3,STRG*3
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C CURRENT POSITION.
REAL XCP,YCP
COMMON /VCCRPS/ XCP,YCP
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
C REAL VECTOR(7)
C COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
ENTRY VBSTLS(LINSTY)
C CHECK FOR VALID LINSTY.
IF(LINSTY.LT.0.OR.LINSTY.GT.5) THEN
CALL VBERRH(401,5)
VECTOR(4) = 0
GOTO 999
END IF
IF(IVECT.NE.0) THEN
CALL PSTBUF(2,'s ')
IVECT=0
END IF
C GENERATE THE LINESTYLE COMMANDS
IF(LINSTY.EQ.0) THEN
CALL PSTBUF(7,'[] 0 h ')
ENDIF
C calculate the linewidth -- it's needed below in every case
C actual xscale is xscale*.1; linewidth=1 => .01 in NDC
LW=VECTOR(5)
LW=XSCALE*VECTOR(5)*.001
C a linewidth of zero isn't good with postscript
IF(LW.LT.1.) LW=1.
C from here on, set up patterns that depend on the linewidth and
C the extra length added to the line segment
C by the hemispherical end cap
IF(LINSTY.EQ.1) THEN
ILL=NINT(0.5*LW)
IGAP=NINT(3.*LW)
CALL PSTI2C(ILL,3,STRL)
CALL PSTI2C(IGAP,3,STRG)
CTEMP='['//STRL(1:3)//' '//STRG(1:3)//'] 0 h '
CALL PSTBUF(14,CTEMP)
ELSE IF(LINSTY.EQ.2) THEN
ILL=NINT(18.*LW)
JLL=NINT(1.5*LW)
IGAP=NINT(3.*LW)
CALL PSTI2C(ILL,3,STRL)
CALL PSTI2C(JLL,3,STRS)
CALL PSTI2C(IGAP,3,STRG)
CTEMP='['//STRS(1:3)//' '//STRG(1:3)//' '//STRL(1:3)
* //' '//STRG(1:3)//'] 0 h '
CALL PSTBUF(22,CTEMP)
C call pstbuf(14,'[2 2 6 2] 0 h ')
ELSE IF(LINSTY.EQ.3) THEN
ILL=NINT(6.*LW)
IGAP=NINT(7.*LW)
CALL PSTI2C(ILL,3,STRL)
CALL PSTI2C(IGAP,3,STRG)
CTEMP='['//STRL(1:3)//' '//STRG(1:3)//'] 0 h '
CALL PSTBUF(14,CTEMP)
C call pstbuf(8,'[4] 0 h ')
ELSE IF(LINSTY.EQ.4) THEN
ILL=NINT(24.*LW)
IGAP=NINT(18.*LW)
CALL PSTI2C(ILL,3,STRL)
CALL PSTI2C(IGAP,3,STRG)
CTEMP='['//STRL(1:3)//' '//STRG(1:3)//'] 0 h '
CALL PSTBUF(14,CTEMP)
C call pstbuf(8,'[8] 0 h ')
ELSE IF(LINSTY.EQ.5) THEN
ILL=NINT(12.*LW)
IGAP=NINT(10.*LW)
CALL PSTI2C(ILL,3,STRL)
CALL PSTI2C(IGAP,3,STRG)
CTEMP='['//STRL(1:3)//' '//STRG(1:3)//'] 0 h '
CALL PSTBUF(14,CTEMP)
ENDIF
C redefine the postscript current position
C the code below is equivalent to
C call vbvect(0,xcp,ycp)
C but can't do it because vbvect calls vdstlw which calls this routine
CTEMP=COORD(1:11)//' m '
CALL PSTBUF(14,CTEMP)
VECTOR(4)=LINSTY
999 RETURN
END
SUBROUTINE VDSTCS(YSIZE)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTCS -Set Character Size.
C R.W.Simons -05DEC80
C J. P. LONG -03 DEC 87
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C All Devices that support only software characters.
C (LXY, HC1)
C ENTRY CONDITIONS -YSIZE = real Y dimension of the character box in NDC
C space. Range 0.-1. Default: device dependent,
C typically the smallest hardware size.
C CALLS -
C EXIT CONDITIONS -VECTOR(6) = real updated character box Y (YSIZE).
C VECTOR(7) = real updated character box X.
C NARRATIVE -Set the character size for text primitives. Size
C is given by YSIZE as the Y dimension of the
C character box. The SVDI will assign the X dimension
C of the character box and X and Y character size
C within the box according to the font used. Applies
C only to text primitives.
C All devices must support at least a single device
C dependent value that is the default. If an
C unsupported value is specified, set to the largest
C supported character size that does not exceed the
C specified size.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL YSIZE
CHARACTER STR*4,CTEMP*10
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C CHECK FOR VALID YSIZE.
IF(YSIZE.LT.0.0.OR.YSIZE.GT.1.0) THEN
CALL VBERRH(401,5)
GOTO 999
END IF
C PROTECT INPUT PARAMETER FROM BEING CHANGED.
YSIZE1=YSIZE
C DON'T ALLOW VALUES BELOW THE MINIMUM "HARDWARE" SIZE.
IF(YSIZE1.LT.0.01) YSIZE1=0.01
C VALUES ESTABLISHED HERE ARE USED BY VBSIM IN SIMULATING CHARACTERS.
C ALWAYS USE A CHARACTER ASPECT RATIO OF 5/7.
VECTOR(6)=YSIZE1
VECTOR(7)=YSIZE1*5./7.
C convert the character size into device coords
IYSIZE=NINT(XSCALE*YSIZE1)
C output the postscript command
CALL PSTI2C(IYSIZE,4,STR)
C iysize is in tenths of device units
CTEMP='y '//STR(1:3)//' x '
CALL PSTBUF(8,CTEMP)
999 RETURN
END
SUBROUTINE VDSTLW(LINWTH)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDSTLW -Set Line Width.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -LINWTH = real line width of line drawing output
C primitives. Range 0.-1. Default: device dependent.
C CALLS -
C EXIT CONDITIONS -VECTOR(5) = real updated line width (LINWTH).
C NARRATIVE -Set the relative width of an output line. Values
C are 0.-1. with 1. being .01 in NDC space.
C All devices must support at least a single device
C dependent value that is the default. If an
C unsupported value is specified, set to the closest
C supported line width.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
REAL LINWTH,LW
CHARACTER CTEMP*19,STR*5
COMMON /VCVEC1/ IVECT
INTEGER IVECT
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL XSCALE,YSCALE
COMMON /VCSCAL/ XSCALE,YSCALE
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
C CHECK FOR VALID LINWTH.
IF(LINWTH.LT.0.0.OR.LINWTH.GT.1.) THEN
CALL VBERRH(401,5)
GOTO 999
END IF
C test user define minimum
WIDTH=MAX(PSTMLW,LINWTH)
C CONVERT LINE-WIDTH TO NDC
LW=WIDTH*.005
C CONVERT WIDTH TO DEVICE COORDINATES AND ADD A DIGIT; NEED IT TO HUNDREDTHS
ILW=NINT(XSCALE*LW*10.)
C A LINEWIDTH OF ZERO WORKS ONLY PART OF THE TIME
IF(ILW.LT.10) ILW=10
C SET LINE WIDTH
CALL PSTI2C(ILW,5,STR)
IF(IVECT.NE.0) THEN
CTEMP='s '//STR(1:3)//'.'//STR(4:5)//' w '
CALL PSTBUF(11,CTEMP)
IVECT=0
ELSE
CTEMP=STR(1:3)//'.'//STR(4:5)//' w '
CALL PSTBUF(9,CTEMP)
END IF
VECTOR(5)=WIDTH
C since linestyle uses the linewidth in setting the pattern, call it
LINSTY=VECTOR(4)
CALL VBSTLS(LINSTY)
999 RETURN
END
SUBROUTINE VDIQES(ESCPCD,SUPPORT)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VDIQES -Inquire Escape.
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -ESCPCD = integer escape function code.
C CALLS -
C EXIT CONDITIONS -SUPPRT = integer level of support for the escape
C function specified. Range 0,1,2.
C NARRATIVE -An integer value indicating 2=hardware supported,
C 1=software supported, 0=unsupported is returned in
C SUPPORT for the escape function ESCPCD.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER ESCPCD,SUPPORT
IF (ESCPCD.EQ.2100) THEN
SUPPORT=2
ELSEIF ((ESCPCD.GE.2101).AND.(ESCPCD.LE.2110)) THEN
SUPPORT=2
C ELSE THERE IS NO SUPPORT OF ANY OTHER ESCAPE CODES
ELSE
SUPPORT=0
END IF
RETURN
END
SUBROUTINE PSTBUF(NCHRS,OUT)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C PSTBUF -Output PostScript data
C C. D. Brown -DEC 1986 (Adapted from QMSBUF)
C ENVIRONMENT -COMPUTER/DEVICE DEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -NCHRS = integer number of characters in OUT.
C = 0 means flush the buffer.
C OUT = character string of input data
C KOUTFL = integer number of the graphics output file.
C CALLS -
C EXIT CONDITIONS -
C NARRATIVE -The data in OUT is buffered for output to KOUTFL.
C The buffer is output when it is "full" or a buffer
C flush is requested by specifying NCHRS<=0.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
SAVE
INTEGER NCHRS
CHARACTER OUT*(*)
character*132 lstout
integer lstchr
C COMPUTER DEPENDENT COMMON VARIABLES AND CONSTANTS.
include 'vcpstc.blk'
C **NOTE: BUFFER SIZE (IN BITS) MUST BE AN EXACT MULTIPLE OF 8 (8-BIT DATA
C MUST END EXACTLY AT WORD BOUNDARY)
INTEGER CHARLN,ICNT,REMAIN
CHARACTER CBUF*130
C CHARLN=BUFFER SIZE IN CHARS
DATA ICNT/1/,CHARLN/130/,LSTCHR/-1/,LSTOUT/' '/
C ...Check that last output string does not match current output GDS
if (lstchr .eq. nchrs) then
if (lstout(:lstchr) .eq. out(:nchrs)) return
end if
lstchr = nchrs
lstout(:nchrs) = out(:nchrs)
C COMPUTE REMAINING AVAILABLE CHARACTERS IN BUFFER
REMAIN=CHARLN-ICNT+1
C CHECK FOR BUFFER FLUSH REQUEST OR NOT ENOUGH ROOM IN BUFFER.
IF((NCHRS.LE.0).OR.(NCHRS.GT.REMAIN)) THEN
C TEST IF THERE'S ANYTHING TO FLUSH.
IF (ICNT.GT.1) THEN
C PAD TO END OF RECORD AND OUTPUT THE BUFFER.
IF (ICNT .LE. CHARLN) THEN
CBUF(ICNT:CHARLN)=' '
WRITE(KOUTFL,'(A)') CBUF(1:ICNT)
ELSE
WRITE(KOUTFL,'(A)') CBUF
END IF
ICNT=1
ENDIF
ENDIF
C ADD TO BUFFER
IF (NCHRS.GT.0) THEN
CBUF(ICNT:ICNT+NCHRS-1)=OUT(1:NCHRS)
ICNT=ICNT+NCHRS
ENDIF
RETURN
END
SUBROUTINE PSTA2C(ASCI,CHARAC)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C PSTA2C - CONVERT FROM ASCII TO CHARACTER
C P. Watterberg - 19 Jan 1982
C ENVIRONMENT - computer dependent, system dependent, fortran 77
C ENTRY CONDITIONS - ASCI is an integer representing an ascii character
C CALLS -
C EXIT CONDITIONS - CHARAC is the character represented by ASCI
C NARRATIVE -
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
CHARACTER CHARAC*(*)
INTEGER ASCI
CHARAC = CHAR(ASCI)
return
end
SUBROUTINE PSTI2C(INT,NDIGIT,ISTR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C
C PSTI2C - convert positive integer to decimal character
C string equivalent
C
C ENVIRONMENT - COMPUTER-INdependent
C
C ENTRY CONDITIONS - int = positive integer to be converted
C ndigit = number of digits to be produced in string
C form (pad left with zeros)
C istr = character string of at least ndigit characters
C
C CALLS -
C
C EXIT CONDITIONS - istr contains decimal-string equivalent of int
C (ndigits left-justified in istr)
C
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
INTEGER INT,NDIGIT
CHARACTER ISTR*(*)
CHARACTER*1 KA(10)
DATA KA /'0','1','2','3','4','5','6','7','8','9'/
C
C check input parameters
INT1=MAX(INT,0)
LENGTH=LEN(ISTR)
NDIG1=MAX(1,MIN(LENGTH,NDIGIT))
ISTR='00000000000000000000000000000000000000000'
ND=LENGTH
DO I=1,NDIG1
J=INT1/10
K=INT1-10*J
ISTR(ND:ND)=KA(K+1)
ND=ND-1
INT1=J
end do
RETURN
END
SUBROUTINE PSTBBG
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C Color background black for white paper device.
C Should only be called from vdnwpg and viinit.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
REAL VECTOR(7)
COMMON /VCATTR/ VECTOR
C VECTOR(1)=FOREGROUND COLOR
C (2)=BACKGROUND COLOR
C (3)=INTENSITY
C (4)=LINE STYLE
C (5)=LINE WIDTH
C (6)=CHARACTER BOX Y
C (7)=CHARACTER BOX X
COMMON /VCVEC1/ IVECT
INTEGER IVECT
COMMON /VCESCP/ PGFORM,PATNO,BORDER
INTEGER PGFORM,PATNO,BORDER
DIMENSION X(4),Y(4)
PARAMETER (ONEN=0.99999)
PARAMETER (ASP=0.75)
IF(MOPOLY.EQ.0) THEN
IF(PGFORM.EQ.0) THEN
X(1)=0.
X(2)=0.
X(3)=ONEN
X(4)=ONEN
Y(1)=0.
Y(2)=ASP
Y(3)=ASP
Y(4)=0.
ELSE
X(1)=0.
X(2)=0.
X(3)=ASP
X(4)=ASP
Y(1)=0.
Y(2)=ONEN
Y(3)=ONEN
Y(4)=0.
END IF
KOLSAV=NINT(VECTOR(1))
CALL VDSTFC(nint(vector(2)))
CALL VIPOLY(X,Y,4)
CALL VDSTFC(KOLSAV)
END IF
RETURN
END
SUBROUTINE PSTJOB
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C PSTJOB - GET JOB ID AND ROUTING INFORMATION
C ENVIRONMENT - COMPUTER-DEPENDENT FOR CTSS
C ENTRY CONDITIONS -
C CALLS -
C EXIT CONDITIONS - KJTIME - TIME HOLLERITH STRING
C KJDATE - DATE HOLLERITH STRING
C KUSRID - USER IDENTIFICATION
C KJROUT - ROUTING INFORMATION
C NARRATIVE - THIS ROUTINE INQUIRES THE SYSTEM TO FIND THE ABOVE
C INFORMATION. THE INFO IS PACKED INTO THE ARRAYS AS
C HOLLERITH (INTERNAL DISPLAY CODE) STRINGS. A TERMI
C CHARACTER "\" IS APPENDED TO EACH STRING SO THE CAL
C ROUTINE CAN FIND THE END IF FOR SOME REASON THE LEN
C VARIABLES ARE NOT SUFFICIENT.
C None of functions are used in pst driver
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C JOB ID INFORMATION. (HC1, DIC)
include 'vcjob.blk'
C FOR SECURITY MARKINGS, CTSS CODES NEED TO MAP TO THESE SILLY
C OLD SCOPE SECURITY CODES
C SCOPE 3 CODE
C 0 UNCL
C 1 UNDEFINED
C 2 UNDEFINED
C 3 PARD
C 4 C
C 5 CNSI
C 6 CFRD
C 7 CRD
C 8 S
C 9 SNSI
C 10 SFRD
C 11 SRD
C GET CLASSIFICATION LEVEL
KSECUR = 0
C GET USER ID
KUSRSZ = 8
KUSRID(1)=0
KUSRID(2)=0
KUSRID(3)=0
KUSRID(4)=0
C GET JOB ID AND USERS NAME
KJOBID(1) = 0
KJOBID(2) = 0
KJOBID(3) = 0
KJOBID(4) = 0
KIDSIZ = 24
C GET BOX NUMBER
KSZROU = 777
KJROUT(1) = 0
KJROUT(2) = 0
KJROUT(3) = 0
KJROUT(4) = 0
C GET MACHINE ID
MACHIN(1) = 0
MACHIN(2) = 0
MACHIN(3) = 0
MACLEN=1
C GET THE TIME AND DATE
KJTIME(1)=0
KJTIME(2)=0
KJTIME(3)=0
KJDATE(1)=0
KJDATE(2)=0
KJDATE(3)=0
END
SUBROUTINE PSTSEL(KARG)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C Select type of desired output. Four options are
C device number
C 1. black & white, batch, no poly fill 799.1
C 2. black & white, interactive, no poly 799.2
C 3. black & white, batch, poly fill 799.3
C 4. black & white, interactive, poly fill 799.4
C 5. color, batch 799.5
C 6. color, interactive 799.6
C 7. color, batch, black-white interchange 799.7
C 8. color, interactive, black-white interchange 799.8
C 9. color, batch, black background 799.9
C 10.color, interactive, black background 799.11
C A second function of this routine is to set the minimum line
C width. For most systems the minimum width line is too narrow.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
SAVE
CHARACTER*(*) KARG
C pstmlw controls minimum line width
C kpstbg controls background coloring
C = 0, not colored (white ground from paper)
C = 1, colored black
C kpstci controls black-white interchange (colors 0 & 7 only)
C = 0, no interchange
C = 1, colors interchanged
COMMON /VCPSTA/ PSTMLW, KPSTBG, KPSTCI
C mopoly controls polygon fill =0, on ; =1, off
C mocolr controls color =0, on ; =1, off
COMMON /VCPSTB/ MOPOLY, MOCOLR
COMMON /DEVCAP/ DEV(33)
common /blotans/ BLTANS
character*2 BLTANS
CHARACTER*2 ANS,ARG
DATA IONCE /0/
ARG=KARG
IF(IONCE.EQ.0) THEN
KPSTBG=0
KPSTCI=0
IONCE=1
IF(ARG.EQ.' ' .and. bltans .eq. ' ') THEN
WRITE(*,10)
10 FORMAT(/,' This VDI PostScript driver has seven options.',/,
& ' 1. black & white, no polygon fill',/,
& ' 3. black & white, polygon fill',/,
& ' 5. color,',/,
& ' 7. color, black-white interchange',/,
$ ' 8. gray-scale, black-white interchange',/,
& ' 9. color, black background',/,
$ ' 10. gray-scale, black background',/,
& ' Enter option number')
READ(5,'(A)',ERR=30) ANS
ELSE
if (arg .ne. ' ') then
ANS=ARG
else if (bltans .ne. ' ') then
ans = bltans
end if
END IF
IF(ANS.EQ.'6') THEN
DEV(4)=256.
DEV(23)=799.6
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
ELSEIF(ANS.EQ.'5') THEN
DEV(4)=256.
DEV(23)=799.5
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
ELSEIF(ANS.EQ.'2') THEN
DEV(4)=1.
DEV(23)=799.2
DEV(26)=1.
DEV(27)=1.
DEV(32)=0.
MOPOLY=1
MOCOLR=1
ELSEIF(ANS.EQ.'1') THEN
DEV(4)=1.
DEV(23)=799.1
DEV(26)=1.
DEV(27)=1.
DEV(32)=0.
MOPOLY=1
MOCOLR=1
ELSEIF(ANS.EQ.'4') THEN
DEV(4)=1.
DEV(23)=799.4
DEV(26)=1.
DEV(27)=1.
DEV(32)=0.
MOPOLY=0
MOCOLR=1
ELSEIF(ANS.EQ.'3') THEN
DEV(4)=1.
DEV(23)=799.3
DEV(26)=1.
DEV(27)=1.
DEV(32)=0.
MOPOLY=0
MOCOLR=1
ELSEIF(ANS.EQ.'7') THEN
DEV(4)=256.
DEV(23)=799.7
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
KPSTCI=1
ELSEIF(ANS.EQ.'8') THEN
DEV(4)=256.
DEV(23)=799.8
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
KPSTCI=1
ELSEIF(ANS.EQ.'9') THEN
DEV(4)=256.
DEV(23)=799.9
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
KPSTBG=1
ELSEIF(ANS.EQ.'10') THEN
DEV(4)=256.
DEV(23)=799.10
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
KPSTBG=1
ELSE
GO TO 30
END IF
GO TO 50
30 WRITE(6,40)
40 FORMAT(' Bad input - defaulting to 7')
DEV(4)=256.
DEV(23)=799.7
DEV(26)=1.
DEV(27)=256.
DEV(32)=1.
MOPOLY=0
MOCOLR=0
KPSTCI=1
ARG=' '
50 CONTINUE
*- INCLUDE PSTMLW
C set minimum line width (range 0 to 1)
PSTMLW=0.025
*-
END IF
RETURN
END
SUBROUTINE PSTINI
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C Generate any system dependent records which must be at the first
C of PostScript output file. For example, a SUN laser printer
C requires the first record of the file to be %! for the file
C recognized as a PostScript file. This routine writes these
C initial records.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
SAVE
DATA KWAY /0/
IF(KWAY.EQ.0) THEN
KWAY=1
C generate first records in output file
*- INCLUDE PSTHEAD
C the following is for a SUN UNIX system
C record is a comment except for sun lpr
CALL PSTBUF(14,'%!PS-Adobe-2.0')
C clear line buffer
CALL PSTBUF(0,' ')
*-
END IF
RETURN
END