lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
2 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: b1e2a11951
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'b1e2a11951'
${ noResults }
EXODUS/packages/seacas/libraries/svdi/cgi/met_vdimet.f

3028 lines
92 KiB
Raw Blame History

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
C VDMOVA VDMONI VDGNAM VBIQDV VBIQPK VDLINA VDTEXT VDPNTA VDPOLY VDIQCP VDSTOS
C WMETMV WMETMO WMETGN WMETIV WMETQP WMETLN WMETTX WMETPT WMETPY WMETCP WMETOS
C VDIQOS VDSTFC VDSTBC VDSTIN VDSTLS VDSTLW VDSTCS VDAABU VDALOC VDABGL VDAKGL
C WMETIO WMETFC WMETBC WMETIN WMETLS WMETLW WMETCS WMETBU WMETLO WMETBL WMETKL
C VDSTLA VDINIT VDFRAM VDTERM VDIQDC VDNWPG VDBELL VDWAIT VDBUFL VDSTCO VDIQCO
C WMETLA WMETNT WMETFR WMETTR WMETDC WMETPG WMETBE WMETWT WMETFL WMETCO WMETIC
C VDESCP VDIQES VDIQND VIMOVA VILINA VIPNTA VITEXT VIINIT VITERM VINWPG CDRCOM
C WMETES WMETIE WMETID WMETIM WMETIL WMETIP WMETIX WMETII WMETIT WMETIG CDRCOM
C VCJOB VCONOD VBERRH VDLOGE CDRWFS CDRRFS CDROFS CDROF3 CDRCFS CDROFF CDROAB
C VCJOB VCONOD WMETER WMETLE WMETWF WMETRF WMETOF WMETO3 WMETCF WMETFF WMETAB
C BGPBUF QMSBUF QMSBU1 DDCBUF H75BUF BTKBUF NMTBUF VBIMBF VBPKG VBDEV VDIQRS
C WMETBF WMETQM WMETBF WMETBF WMETBF WMETBF WMETBF WMETIB WMETPK WMETDV WMETQR
C VDSTMP VDSTRS VDSTRV VDBRGB VDFRGB VDPIXL VDPIXI VDRPIX VDRPXI VDRSCL VDIQCI
C WMETMP WMETRS WMETRV WMETBG WMETFG WMETPX WMETPI WMETRP WMETRI WMETRL WMETCI
C VBSTMP VIFRAM VCNDCM VCATTR VBINI1 VB2HLS VB2RGB VCCOLT VCCRPS VCSCAL VCDDIM
C WMET01 WMET02 WMET03 WMET04 WMET05 WMET06 WMET07 WMET08 WMET09 WMET10 WMET11
C VIPOLY VBOUT
C WMET12 WMET13
SUBROUTINE WMET01( IMAP )
integer*4 imap
GOTO (1,2,3,4,5),IMAP
CALL WMETMP('UNKNOWN')
RETURN
1 CALL WMETMP('1-TO-1')
RETURN
2 CALL WMETMP('REPLICATE')
RETURN
3 CALL WMETMP('VIRTUAL')
RETURN
4 CALL WMETMP('NODISTORT')
RETURN
5 CALL WMETMP('FREEFORM')
RETURN
END
SUBROUTINE WMETRS(I1,I2)
c*************************************************************************
c This routine is to satisfy entry points used with raster vdi stuff
c but not with regular vdi stuff. This is done so raster vdi programs
c can link with regular vdi.
c*************************************************************************
INTEGER*4 i1, i2, i3
CHARACTER C1*(*)
REAL*4 RA1(1),RA2(1),RA3(1)
INTEGER*4 IA1(1),IA2(1)
real*4 r1, r2, r3, r4
ENTRY WMETRV(R1,R2,R3,R4)
ENTRY WMETMP(C1)
ENTRY WMETPX(I1,I2,RA1,RA2,RA3,I3)
ENTRY WMETRP(I1,I2,I3,RA1,RA2,RA3,IA1)
ENTRY WMETPI(I1,I2,IA1,I3)
ENTRY WMETRI(I1,I2,I3,IA1,IA2)
ENTRY WMETQR(I1,RA1)
ENTRY WMETRL
ENTRY WMETFG(R1,R2,R3)
ENTRY WMETBG(R1,R2,R3)
ENTRY WMETCI(R1,R2,R3,I1)
RETURN
END
SUBROUTINE WMETFR(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 CDRTOD(entry
c point in CDRJOB) 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*4 ITYPE
CALL WMET02(ITYPE)
RETURN
END
SUBROUTINE WMET02(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*4 ITYPE
RETURN
END
SUBROUTINE WMETGN(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 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
CHARACTER*(*) NAME
INTEGER*4 LENGTH,ISTART,IEND,I
LENGTH = MIN(LEN(NAME),132)
C Strip off any leading blanks
ISTART = 0
DO 10 I=1,LENGTH
IF(NAME(I:I) .NE. ' ')THEN
ISTART = I
GOTO 11
ENDIF
10 CONTINUE
11 CONTINUE
C Strip off trailing blanks
IEND = 0
IF(ISTART.GT.0)THEN
DO 20 I=LENGTH,1,-1
IF(NAME(I:I) .NE. ' ')THEN
IEND = I
GOTO 21
ENDIF
20 CONTINUE
ENDIF
21 CONTINUE
IF(ISTART .GT. 0)THEN
LENGTH = IEND-ISTART+1
CALL CDRGNM(NAME(ISTART:IEND),LENGTH)
ENDIF
RETURN
END
SUBROUTINE WMETNT(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 -CDRJOB, 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*4 ASPECT
INTEGER*4 JUSTIF
CALL WMETII(ASPECT,JUSTIF)
RETURN
END
SUBROUTINE WMETLE(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 -CDRTBK, 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
INTEGER ERRSEV
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C flush buffer before we do a write
CALL WMETFL
C WRITE THE ERROR TO THE LISTING.
WRITE(KWRTFL,10)ERRNUM,ERRSEV
10 FORMAT(' SVDI ERROR NUMBER ',I5,' SEVERITY CODE ',I5)
C TRACEBACK.
CALL CDRTBK
RETURN
END
SUBROUTINE WMETID(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*4 XNDC,YNDC
REAL*4 XNDCMX,YNDCMX
COMMON /WMET03/ XNDCMX,YNDCMX
C RETURN THE MAXIMUM VALID NDC VALUES.
XNDC=XNDCMX
YNDC=YNDCMX
RETURN
END
SUBROUTINE WMETIO(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*4 ATTARR(7)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
INTEGER*4 I
DO 100 I=1,7
ATTARR(I)=VECTOR(I)
100 CONTINUE
RETURN
END
SUBROUTINE WMETLN(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*4 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 WMETIL(X,Y)
RETURN
END
SUBROUTINE WMETMO(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 -CDRMON
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
CHARACTER *8 C1,C2,MDEV,MPKG
INTEGER ISTATE
INTEGER*4 MPAGES
SAVE MDEV,MPKG,MPAGES
DATA MPKG /' '/
DATA MDEV /' '/
DATA MPAGES /0/
IF(ISTATE.EQ.0) THEN
CALL CDRELA(0)
ELSEIF (ISTATE.EQ.1) THEN
MPAGES=MPAGES+1
ELSE
CALL CDRELA(1)
CALL CDRMON(MDEV,MPKG,MPAGES)
ENDIF
RETURN
C Usage Monitoring Information
ENTRY WMETPK (C1)
MPKG = C1
RETURN
ENTRY WMETDV (C2)
MDEV = C2
RETURN
ENTRY WMETQP(C1)
C1 = MPKG
RETURN
ENTRY WMETIV(C2)
C2 = MDEV
RETURN
END
SUBROUTINE WMETMV(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*4 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 WMETIM(X,Y)
RETURN
END
SUBROUTINE WMETPG
C C C C C C C C C C C C C 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 WMETIG
RETURN
END
SUBROUTINE WMETPT(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*4 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 WMETIP(X,Y)
RETURN
END
SUBROUTINE WMETPY(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*4 NPTS
REAL*4 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.
CALL WMET12(XARRAY,YARRAY,NPTS)
RETURN
END
SUBROUTINE WMETOS(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*4 ATTARR(6)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
integer*4 i4
C CALL EACH OF THE INDIVIDUAL ATTRIBUTE SETTING ROUTINES.
C CHECK FOR VALIDITY OF INPUT VALUES WILL BE DONE IN EACH INDIVIDUAL
C ROUTINE.
i4 = INT(ATTARR(1))
CALL WMETFC(i4)
i4 = INT(ATTARR(2))
CALL WMETBC(i4)
CALL WMETIN(ATTARR(3))
i4 = INT(ATTARR(4))
CALL WMETLS(i4)
CALL WMETLW(ATTARR(5))
CALL WMETCS(ATTARR(6))
RETURN
END
SUBROUTINE WMETTR
C C C C C C C C C C C C C 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 WMETIT
RETURN
END
SUBROUTINE WMETTX(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*4 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 WMETIX(LENGTH,CHARS)
RETURN
END
SUBROUTINE WMETER(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
INTEGER ERRSEV
C REPORT THE ERROR USING VDLOGE.
CALL WMETLE(ERRNUM,ERRSEV)
C CHECK FOR FATAL ERROR.
IF(ERRSEV.GT.12) STOP
RETURN
END
SUBROUTINE WMETBU(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*4 BTNNUM
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
C READ A RECORD FROM COMPUTER DEPENDENT FILE KINFL IN I5 FORMAT.
READ(KINFL,10) BTNNUM
10 FORMAT(I5)
C CHECK FOR VALID BTNNUM.
C RANGE FOR BATCH DEVICES IS 1-99999. IF OUT OF RANGE, MAP IT BACK IN:
C MAPPING (-1)-(-9999) TO 1-9999 AND MAPPING 0 TO 10000.
IF(BTNNUM.LT.0) BTNNUM=-BTNNUM
IF(BTNNUM.EQ.0) BTNNUM=10000
RETURN
END
SUBROUTINE WMETBL(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*4 X,Y
INTEGER*4 BTNNUM
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
C READ A RECORD FROM COMPUTER DEPENDENT FILE KINFL IN I5,2F10.7 FORMAT.
READ(KINFL,10) BTNNUM,X,Y
10 FORMAT(I5,2F10.7)
C CHECK FOR VALID BTNNUM.
C RANGE FOR BATCH DEVICES IS 1-99999. IF OUT OF RANGE, MAP IT BACK IN:
C MAPPING (-1)-(-9999) TO 1-9999 AND MAPPING 0 TO 10000.
IF(BTNNUM.LT.0) BTNNUM=-BTNNUM
IF(BTNNUM.EQ.0) BTNNUM=10000
RETURN
END
SUBROUTINE WMETKL(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*4 X,Y
INTEGER*4 CHAR
INTEGER*4 IN,CHR
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
C READ A CHARACTER AND AN X,Y POSITION FROM COMPUTER DEPENDENT FILE
C KINFL WITH FORMAT A1,2F10.7.
READ(KINFL,10) CHR,X,Y
10 FORMAT(A1,2F10.7)
C CONVERT CHARACTER TO INTEGER ASCII AND CHECK FOR VALID RANGE.
CALL CDR1CH(1,CHR,IN)
CALL CDRCVT(IN,CHAR)
IF(CHAR.LT.32.OR.CHAR.GT.126) CHAR=32
RETURN
END
SUBROUTINE WMETLO(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*4 X,Y
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C BATCH DEVICES DON'T NEED TO FLUSH BUFFERS.
C READ AN X,Y POSITION FROM COMPUTER DEPENDENT FILE
C KINFL WITH FORMAT 2F10.7.
READ(KINFL,10) X,Y
10 FORMAT(2F10.7)
RETURN
END
SUBROUTINE WMETBE
C C C C C C C C C C C C C 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 WMETLA(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*4 LOCX,LOCY
C BATCH DEVICES IGNORE THIS FUNCTION.
RETURN
END
SUBROUTINE WMETWT
C C C C C C C C C C C C C 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 WMET05(N,NSTR)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VBINI1 -Virtual Device Initialization String Output.
C R.W.Simons -18MAY81
C ENVIRONMENT -Computer-independent, System-independent, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -N = integer number of words in NSTR. (max=4)
C NSTR = integer array containing the string to be
C converted and output. The last character must
C be the string terminator.
C CALLS -CDRCVT,CDR1CH,VBOUT.
C EXIT CONDITIONS -
C NARRATIVE -This routine converts a string from
C internal computer-dependent format to
C ASCII and sends it to 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
INTEGER N
INTEGER*4 NSTR(4)
integer i, j
integer*4 itemp
integer*4 itemp1, itemp2
integer itemp8
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C KTERM = STRING TERMINATOR CHARACTER (\).
INTEGER*4 KTERM
DATA KTERM /92/
C LOOP THROUGH EACH CHARACTER IN EACH WORD OF NSTR.
DO I=1,N
DO J=1,KCPW
CALL CDR1CH(J,NSTR(I),ITEMP)
C CONVERT CHARACTER.
CALL CDRCVT(ITEMP,ITEMP1)
C
C CHECK FOR END-OF-STRING CHARACTER.
IF (ITEMP1.EQ.KTERM) GO TO 20
C
C SEND PAIRS OF CHARACTERS TO THE OUTPUT FILE.
IF(MOD(J,2).EQ.1) THEN
ITEMP2=ITEMP1
ELSE
ITEMP8=256*ITEMP2+ITEMP1
CALL WMET13S(ITEMP8)
ENDIF
END DO
END DO
C
C PAD WITH A BLANK IF NECESSARY TO MAKE NUMBER OF CHARS EVEN.
20 CONTINUE
IF(MOD(J,2).EQ.0) THEN
ITEMP8=256*ITEMP2+32
CALL WMET13S(ITEMP8)
ENDIF
RETURN
END
SUBROUTINE WMET06(RGB,MAXVAL,HLS)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VB2HLS - Transform RGB to HLS
C P. Watterberg - 2 APR 81
C ENVIRONMENT - COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS - RGB = integer array with 3 elements specifying
C Red, RGB(1), range 0 - MAXVAL
C Green, RGB(2), range 0 - MAXVAL
C Blue, RGB(3), range 0 - MAXVAL
C MAXVAL = integer, largest value that each of R, G or B
C can assume
C CALLS - none
C EXIT CONDITIONS - HLS = Real array with 3 elements specifying
C Hue, HLS(1), range 0. - 360.
C Lightness, HLS(2), range 0. - 1.
C Saturation, HLS(3), range 0. - 1.
C NARRATIVE - This routine converts RGB to HLS. The interpretation
C of HLS is the one adopted by GSPC 79.
C C C C C C C C C C C C 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 maxval
REAL*4 HLS(3), temp
INTEGER*4 RGB(3)
integer*4 ired, igre, iblu, maxc, minc, isum, idif
integer*4 maxlit
C copy the inputs to locals
IRED = RGB(1)
IGRE = RGB(2)
IBLU = RGB(3)
c compute some useful quantities
MAXC = MAX(IRED,IGRE,IBLU)
MINC = MIN(IRED,IGRE,IBLU)
ISUM = MAXC + MINC
IDIF = MAXC - MINC
MAXLIT = 2*MAXVAL
c getting lightness is easy
HLS(2) = DBLE(ISUM)/DBLE(MAXLIT)
c getting saturation is a little more difficult
IF(IDIF.EQ.0) THEN
HLS(3) = 0.
ELSE
IF(ISUM.LE.MAXVAL) THEN
HLS(3) = DBLE(IDIF)/ISUM
ELSE
HLS(3) = DBLE(IDIF)/(MAXLIT-ISUM)
ENDIF
ENDIF
c getting hue is a little harder yet
IF(IDIF.EQ.0) THEN
TEMP = 0.
ELSE
TEMP = 60./IDIF
ENDIF
c is the maximum color red?
IF(MAXC.EQ.IRED) THEN
HLS(1) = 120. + ((IGRE-MINC) - (IBLU-MINC))*TEMP
c is it green?
ELSE IF(MAXC.EQ.IGRE) THEN
HLS(1) = 240. + ((IBLU-MINC) - (IRED-MINC))*TEMP
c well then, it must be blue
ELSE
IF(IRED.GE.IGRE) THEN
HLS(1) = (IRED-MINC)*TEMP
ELSE
HLS(1) = 360. - (IGRE-MINC)*TEMP
ENDIF
ENDIF
RETURN
END
SUBROUTINE WMET07(HLS,RGB,MAXVAL)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VB2RGB - Transform HLS to RGB
C P. Watterberg - 30 MAR 81
C ENVIRONMENT - COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS - HLS = Real array with 3 elements specifying
C Hue, HLS(1), range 0. - 360.
C Lightness, HLS(2), range 0. - 1.
C Saturation, HLS(3), range 0. - 1.
C MAXVAL = integer, largest value that any of R, G or B
C can assume
C CALLS - none
C EXIT CONDITIONS - RGB = integer array with 3 elements specifying
C Red, RGB(1), range 0 - MAXVAL
C Green, RGB(2), range 0 - MAXVAL
C Blue , RGB(3), range 0 - MAXVAL
C NARRATIVE - This routine converts HLS to RGB. The interpretation
C of HLS is the one adopted by GSPC 79.
C C C C C C C C C C C C 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 MAXVAL
REAL*4 HLS(3), LIT, HUE, SAT, f
INTEGER*4 RGB(3), inten, irange, irang2, isplus
integer*4 iv1, iv2, iv3, iv4, ib, ig, ir
integer*4 ijump, zero
integer*4 imaxval
zero = 0
imaxval = maxval
C copy the inputs to locals
HUE = HLS(1)
LIT = HLS(2)
SAT = HLS(3)
C find out which major hue (0 - 5) we are interested in
HUE = HUE/60.
C avoid the maximum boundary conditions
IF(HUE.GE.6.) HUE = 5.99
IF(SAT.GE.1.) SAT = .99
IF(LIT.GE.1.) LIT = .99
C the conversions and convolutions that happen here are not
C very easy to understand. It's best to talk to Peter but
C if you need to try to decipher it yourself, you might try
C by first assuming a saturation of 1. That way, irang2=irange,
C isplus goes away and you are left with the outer shell of
C rgb color cube to deal with.
C ijump represents one of the six edges of the color cube
C connecting the six major hues.
IJUMP = HUE
c f is the distance (0.-.999) along an edge between two major hues
F = HUE - IJUMP
INTEN = LIT*DBLE(2*IMAXVAL+1)
c irange is the range a color may take on (i.e. maxval adjusted for
c intensity
c irang2 is irange adjusted for saturation
IRANGE = IMAXVAL - ABS(INTEN-IMAXVAL)
C ... This is done for the 8-byte systems so we can pass native int to mod intrinsic
IRANGT = IRANGE
IRANG2 = 2*(INT((IRANGT/2+1)*SAT)) + MOD(IRANGT,2)
c isplus is an additive to account for saturation
ISPLUS = (IRANGE-IRANG2)/2
IV1 = MIN(INTEN,IMAXVAL) - ISPLUS
IV2 = MAX(zero,INTEN-IMAXVAL) + ISPLUS
IV3 = F*IRANG2 + .5 + IV2
IV4 = (1.-F)*IRANG2 + .5 + IV2
GOTO (610,620,630,640,650,660),IJUMP+1
610 IB = IV1
IG = IV2
IR = IV3
GOTO 670
620 IR = IV1
IG = IV2
IB = IV4
GOTO 670
630 IR = IV1
IB = IV2
IG = IV3
GOTO 670
640 IG = IV1
IB = IV2
IR = IV4
GOTO 670
650 IG = IV1
IR = IV2
IB = IV3
GOTO 670
660 IB = IV1
IR = IV2
IG = IV4
670 RGB(1) = IR
RGB(2) = IG
RGB(3) = IB
RETURN
END
SUBROUTINE WMETFL
C C C C C C C C C C C C C 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 K.M.ERICKSON -04 MAY 81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -
C CALLS -VBOUT
C EXIT CONDITIONS -
C NARRATIVE -Assure that the picture is up-to-date by flushing
C buffers if necessary. This is necessary to
C guarantee that the picture is in a certain state
C before interacting with it.
C -set terminal to alpha mode in order to facilitate
c fortran IO.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
c flush buffers
c modified 2-23-87 to be a dummy routine by JFM.
C** CALL VBOUT(0,1)
RETURN
END
SUBROUTINE WMETIC(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 K.M.Erickson - 04 May 81
C ENVIRONMENT - COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
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 - vb2hls
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: 0. - 1.
C Range for hls: hue 0. - 360.
C l & s 0. - 1.
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 the color table indexes specified will
C return -1. 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*4 NUM,INDEX(NUM),CLRMOD, RGB(3)
REAL*4 CLRARY(3,NUM)
INTEGER*4 CLRTAB(256,3)
COMMON /WMET08/ CLRTAB
C check for valid num.
integer*4 i, indexn
IF(NUM.LT.1.OR.NUM.GT.256) THEN
CALL WMETER(723,5)
GOTO 999
END IF
C check for valid clrmod.
IF(CLRMOD.NE.0.AND.CLRMOD.NE.1) THEN
CALL WMETER(725,5)
GOTO 999
END IF
C check for valid indexes.
DO I=1,NUM
INDEXN=INDEX(I)
IF(INDEXN.LT.0.OR.INDEXN.GT.255) THEN
CALL WMETER(724,5)
GOTO 100
END IF
RGB(1) =CLRTAB(INDEX(I)+1,1)
RGB(2) =CLRTAB(INDEX(I)+1,2)
RGB(3) =CLRTAB(INDEX(I)+1,3)
IF(CLRMOD.EQ.0) THEN
CLRARY(1,I) = RGB(1)/255.
CLRARY(2,I) = RGB(2)/255.
CLRARY(3,I) = RGB(3)/255.
ELSE
CALL WMET06(RGB,255,CLRARY(1,I))
ENDIF
100 continue
end do
999 RETURN
END
SUBROUTINE WMETCP(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 K.M. ERICKSON -14 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
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
COMMON /WMET09/XCP,YCP
REAL*4 XCP,YCP
REAL*4 X,Y
C ASSIGN THE CP TO X,Y
X=XCP
Y=YCP
RETURN
END
SUBROUTINE WMETCO(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 K.M.ERICKSON -04 MAY 81
C ENVIRONMENT - COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
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 - VBOUT
C EXIT CONDITIONS - The Dicomed color table has been set
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
C 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*4 NUM, INDEX(NUM), CLRMOD, RGB(3), i
REAL*4 CLRARY(3,NUM)
INTEGER*4 CLRTAB(256,3)
COMMON /WMET08/ CLRTAB
c batch update mode--c700
INTEGER IBATUP
c send color table--c800
INTEGER ISNDCO
INTEGER*4 IBUF(6)
DATA IBUF/36869,5*0/
c ibuf (1) (2) (3) (4) (5) (6)
c 9005 index z R g Y B M C W
DATA IBATUP/50944/
DATA ISNDCO/51200/
c check for valid NUM.
IF(NUM.LT.1.OR.NUM.GT.256) THEN
CALL WMETER(723,5)
GOTO 999
END IF
c check for valid clrmod.
IF(CLRMOD.NE.0.AND.CLRMOD.NE.1) THEN
CALL WMETER(725,5)
GOTO 999
END IF
c send batch update mode
CALL WMET13S(IBATUP)
c check for valid indexes.
DO 100 I=1,NUM
IF(INDEX(I).LT.0.OR.INDEX(I).GT.255) THEN
CALL WMETER(724,5)
GOTO 100
END IF
IBUF(2) = INDEX(I)
c check for valid clrary.
c rgb
IF(CLRMOD.EQ.0) THEN
IF( CLRARY(1,I).LT.0..OR.CLRARY(1,I).GT.1.
X .OR.CLRARY(2,I).LT.0..OR.CLRARY(2,I).GT.1.
X .OR.CLRARY(3,I).LT.0..OR.CLRARY(3,I).GT.1.) THEN
CALL WMETER(727,5)
GOTO 100
END IF
IBUF(3)=INT(255.99*CLRARY(1,I))
c zero/red
IBUF(4)=INT(255.99*CLRARY(2,I))*256
c green/yellow
IBUF(5)=INT(255.99*CLRARY(3,I)) *256
c blue/magenta
ELSE
c hls
IF( CLRARY(1,I).LT.0..OR.CLRARY(1,I).GT.360.
X .OR.CLRARY(2,I).LT.0..OR.CLRARY(2,I).GT.1.
X .OR.CLRARY(3,I).LT.0..OR.CLRARY(3,I).GT.1.) THEN
CALL WMETER(727,5)
GOTO 100
END IF
CALL WMET07(CLRARY(1,I),RGB,15)
IBUF(3)=INT(255.99*RGB(1))
c red
IBUF(4)=INT(255.99*RGB(2))*256
c green
IBUF(5)=INT(255.99*RGB(3))*256
c blue
END IF
c store color table values
CLRTAB(IBUF(2)+1,1)=IBUF(3)
CLRTAB(IBUF(2)+1,2)=IBUF(4)/256
CLRTAB(IBUF(2)+1,3)=IBUF(5)/256
CALL WMET13(6,IBUF)
100 CONTINUE
999 CALL WMET13S(ISNDCO)
c send color table
RETURN
END
SUBROUTINE WMETFC(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 K.M. ERICKSON -12 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -COLOR = integer color table index . Range 0-255.
C Default is device dependent, in range 0-7.
C CALLS -
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*4 COLOR
INTEGER*4 COL(2)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
DATA COL/37121,0/
C CHECK FOR VALID COLOR.
IF(COLOR.LT.0.OR.COLOR.GT.255) THEN
CALL WMETER(724,5)
GOTO 999
END IF
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
VECTOR(1)=COLOR
COL(2)=COLOR
CALL WMET13(2,COL)
999 RETURN
END
SUBROUTINE WMETLW(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 K.M. ERICKSON -14 NOV 80
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*4 LINWTH
INTEGER*4 LW(2)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
C REAL*4 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
DATA LW/43265,0/
C CHECK FOR VALID LINWTH.
IF(LINWTH.LT.0.0.OR.LINWTH.GT.1.0) THEN
CALL WMETER(401,5)
GOTO 999
END IF
C ASSIGN VECTOR(5)
VECTOR(5)=LINWTH
C MAP 0.-1. INTO 0.-32767; FOR DICOMED
C 1. IS .01 IN NDC SPACE
C LW(2)=LINWTH*32767*.01
LW(2)=LINWTH*32767
C SEND BGP COMMAND
CALL WMET13(2,LW)
999 RETURN
END
SUBROUTINE WMETIG
C C C C C C C C C C C C C 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 R.W.Simons -15MAY81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -
C CALLS -VBOUT.
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
C OUTARY = NEW PAGE COMMAND
C = 8505,FFFF,FFFF,FFFF,PAGE NUMBER,0 IN HEX
C = 34053,65535,65535,65535,PAGE NUMBER,0
INTEGER*4 OUTARY(6)
DATA OUTARY /34053,65535,65535,65535,0,0/
C SEND A NEW PAGE COMMAND TO THE PLOT FILE.
C INCREMENT THE PAGE NUMBER.
OUTARY(5)=OUTARY(5)+1
CALL WMET13(6,OUTARY)
CALL WMETMO(1)
RETURN
END
SUBROUTINE WMETIM(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 R.W.Simons -15MAY81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VBOUT.
C EXIT CONDITIONS -XCP,YCP = real updated current position. (XNDC,YNDC)
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*4 X,Y
INTEGER*4 OUTARY(2)
C CURRENT POSITION. (LXY,HC1)
REAL*4 XCP,YCP
COMMON /WMET09/ XCP,YCP
C Include '[VDIMAINT.COMMON]VCCRPS'
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY)
REAL*4 XSCALE,YSCALE
COMMON /WMET10/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
REAL*4 XPAD,YPAD,XDEVIC,YDEVIC
COMMON /WMET11/ XPAD,YPAD,XDEVIC,YDEVIC
C CONVERT TO SCREEN UNITS.
C SET BIT 15 OF X = 0 TO INDICATE A COORDINATE POSITIONING COMMAND.
C SET BIT 15 OF Y = 0 TO INDICATE A DRAW COMMAND.
C ASSUME X AND Y ARE < 32768, WHICH WILL BE TRUE IF XNDC AND YNDC
C ARE IN THE PROPER RANGE.
OUTARY(1)=X*XSCALE+XPAD
OUTARY(2)=Y*YSCALE+YPAD
C SEND THE COMMAND TO THE PLOT FILE.
CALL WMET13(2,OUTARY)
C UPDATE CURRENT POSITION.
XCP=X
YCP=Y
RETURN
END
SUBROUTINE WMETES(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 K.M. ERICKSON -4 MAY 81
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 -vbout
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.
C C C C C C C C C C C C 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*4 ESCPCD,N, i
C N COULD BE EQUAL TO 0 SO:
REAL*4 ARGS(N+1), ARG
REAL*4 ONE
INTEGER*4 IBUF(4)
ONE = 1.0
C CHECK FOR VALID N.
IF(N.LT.0) THEN
CALL WMETER(802,5)
GOTO 999
END IF
C meta file escapes 800 -
IF(ESCPCD.EQ.800) THEN
C SEND ASPECT RATIO
IBUF(1) = 33539
IBUF(2) = 32767.*MIN(ARGS(1),ONE)
IBUF(3) = 32767./MAX(ARGS(1),ONE)
IBUF(4) = 0
CALL WMET13(4,IBUF)
ENDIF
C ALL OTHER ESCAPE CODES
C FIRST CHECK IF THIS IS AN ESCAPE WITH ALPHA ARGUMENTS
IF(ESCPCD.EQ.250) THEN
ELSE
C ALL OTHER ESCAPES HAVE REAL NUMBER ARGUMENTS
C SEND 82xx 01nn ESCPCD ARGS(1) ... ARGS(N)
C xx is 2*(N+1) and nn is 2*N+1
C and each arg is sent as a fixed point real with sixteen bits
C integer and sixteen bits fraction.
IBUF(1) = 33280 + 2*(N+1)
IBUF(2) = 256 + 2*N + 1
IBUF(3) = ESCPCD
CALL WMET13(3,IBUF)
DO 10 I=1,N
ARG = ARGS(I)
IBUF(1) = ARG
IBUF(2) = (ARG-IBUF(1))*32768.
IF(ARGS(I).LT.0.) IBUF(1) = IBUF(1) + 32768
CALL WMET13(2,IBUF)
10 CONTINUE
ENDIF
999 RETURN
END
SUBROUTINE WMET12(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 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 -
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
integer*4 i, nn, npts
REAL*4 XARRAY(NPTS),YARRAY(NPTS)
REAL*4 ATTARR(7)
C MAX NPTS IS 508. Constraint imposed by postprocessor.
INTEGER*4 OUTARY(2)
INTEGER*4 zero, i4
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY)
REAL*4 XSCALE,YSCALE
COMMON /WMET10/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
REAL*4 XPAD,YPAD,XDEVIC,YDEVIC
COMMON /WMET11/ XPAD,YPAD,XDEVIC,YDEVIC
C CHECK FOR VALID N
IF (NPTS.LT.1) THEN
CALL WMETER(802,5)
GO TO 999
END IF
C SAVE CURRENT ATTRIBUTES
CALL WMETIO(ATTARR)
C SET CURRENT LINESTYLE TO SOLID
zero = 0
CALL WMETLS(zero)
C BEGIN POLYGON COMMAND = AA00
C = 43520
C END POLYGON COMMAND = AB00
C = 43776
CALL WMET13S(43520)
NN=NPTS
C CHECK MAXIMUM POINTS LIMIT
IF (NN.GT.508) NN=508
C CONVERT EACH X,Y TO SCREEN UNITS AND WRITE OUT
DO 100 I = 1,NN
OUTARY(1) = XARRAY(I) * XSCALE + XPAD
OUTARY(2) = YARRAY(I) * YSCALE + YPAD
CALL WMET13(2,OUTARY)
100 CONTINUE
CALL WMET13S(43776)
C MOVE SOMEWHERE TO UPDATE CURRENT POSITION
CALL WMETIM(XARRAY(1),YARRAY(1))
C RESTORE LINESTYLE
i4 = ATTARR(4)
CALL WMETLS(i4)
999 RETURN
END
SUBROUTINE WMET13(NUMWDS,OUTARY)
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C VBOUT -Output 16 Bits of Data.
CC ENVIRONMENT -Computer-independent, System-independent, FORTRAN 77
C ENTRY CONDITIONS -NUMWDS = integer number of words in OUTARY.
C = 0 means flush the buffer.
C OUTARY = integer array of output data, 16 bits/word,
C right-justified.
C NARRATIVE - This routine used to do all the work but due to
C complex computer, device and software (COMDQ)
C dependencies, the work has moved to the computer
C dependent, device dependent, COMQ dependent routine
C BGPBUF.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C DIMENSION OUTARY TO NUMWDS+1 TO AVOID PROBLEMS WHEN NUMWDS = 0.
INTEGER NUMWDS
INTEGER*4 OUTARY(NUMWDS+1)
CALL WMETBF(NUMWDS,OUTARY)
RETURN
END
SUBROUTINE WMET13S(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 VBOUT -Output 16 Bits of Data.
CC ENVIRONMENT -Computer-independent, System-independent, FORTRAN 77
C ENTRY CONDITIONS -NUMWDS = integer number of words in OUTARY.
C = 0 means flush the buffer.
C OUTARY = integer array of output data, 16 bits/word,
C right-justified.
C NARRATIVE - This routine used to do all the work but due to
C complex computer, device and software (COMDQ)
C dependencies, the work has moved to the computer
C dependent, device dependent, COMQ dependent routine
C BGPBUF.
C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C C
C DIMENSION OUTARY TO NUMWDS+1 TO AVOID PROBLEMS WHEN NUMWDS = 0.
INTEGER*4 OUTARY(1)
INTEGER OUT
OUTARY(1) = OUT
CALL WMETBF(1,OUTARY)
RETURN
END
SUBROUTINE WMETDC(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
INTEGER*4 INDEX
REAL*4 VALUE
REAL*4 DEV(33)
SAVE DEV
C SET DEVICE CAPABILITIES
C THE VALUES CONTAINED IN DEV ARE:
c ** Jan 16, 1991 -- Dino Pavlakos
c changed polygon support level (entry# 24) from 2 to 3
DATA DEV/ 0.,0.,256.,256.,4096.,31.,32767.,0.,0.,0.,
* 0.,0.,0.,0.,32767.,32767.,0.0,0.0,8.,8.,
* 0.,0.,11.,3.,508.,1.,16777216.,0.,0.,21298.,
* 32767.,1.,0./
C CHECK FOR VALID INDEX.
IF(INDEX.LT.1.OR.INDEX.GT.33) THEN
CALL WMETER(726,5)
GOTO 999
END IF
C RETURN INDEXED VALUE.
VALUE=DEV(INDEX)
999 RETURN
END
SUBROUTINE WMETIE(ESCPCD,SUPPRT)
C C C C C C C C C C C C C 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 K.M.ERICKSON -04 may 81
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 SUPPRT 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*4 ESCPCD,SUPPRT
IF(ESCPCD .GE. 200 .AND. ESCPCD .LE. 205)THEN
SUPPRT=2
C ELSE THERE IS NO SUPPORT OF ANY OTHER ESCAPE CODES
ELSE
SUPPRT=0
END IF
RETURN
END
SUBROUTINE WMETBC(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 K.M. ERICKSON -12 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C ENTRY CONDITIONS -COLOR = integer color table index. Range 0-255.
C Default: device dependent, in range 0-7.
C CALLS -
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*4 COLOR
INTEGER*4 SETBC(2)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
DATA SETBC(1) / 37633 /
C CHECK FOR VALID COLOR.
IF(COLOR.LT.0.OR.COLOR.GT.255) THEN
CALL WMETER(724,5)
GOTO 999
END IF
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
VECTOR(2)=COLOR
SETBC(2) = COLOR
CALL WMET13(2,SETBC)
999 RETURN
END
SUBROUTINE WMETCS(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 K.M.ERICKSON -04 May 81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
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*4 YSIZE
INTEGER*4 IBUF(4)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
COMMON/WMET10/XSCALE,YSCALE
REAL*4 XSCALE,YSCALE
C CHECK FOR VALID YSIZE.
IF(YSIZE.LT.0.0.OR.YSIZE.GT.1.0) THEN
CALL WMETER(401,5)
GOTO 999
END IF
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 SET CHARACTER BOX = SPACING OF LETTERS TO A 5/7 BOX
VECTOR(6)=YSIZE
VECTOR(7)=VECTOR(6)*(5./7.)
C SEND 15 BITS FOR THE HEIGHT AND WIDTH TO BGP. NOTE THAT CHARACTER SIZES
C ARE MAPPED FROM THE SMALLEST TO THE LARGEST CHARACTER DEFINED TO BE A
C CHARACTER FILLING THE SMALLEST DIMENSION OF THE SCREEN ASPECT RATIO.
C SEND BGP COMMAND ,B202-HEIGHT-WIDTH
IBUF(1)=45570
IBUF(2)=.65*VECTOR(6)*YSCALE
IBUF(3)=.65*VECTOR(7)*XSCALE
CALL WMET13(3,IBUF)
999 RETURN
END
SUBROUTINE WMETIN(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 K.M. ERICKSON -12 NOV 80
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
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*4 INTEN
INTEGER*4 INTE(2)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
DATA INTE/37377,0/
C CHECK FOR VALID INTEN.
IF(INTEN.LT.0.0.OR.INTEN.GT.1.0) THEN
CALL WMETER(401,5)
GOTO 999
END IF
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
VECTOR(3)=INTEN
C MAP INTEN VALUE OF 0.-1. INTO 0.-32767. (15 BITS OF INFO)
INTE(2)=INTEN*32767.
CALL WMET13(2,INTE)
999 RETURN
END
SUBROUTINE WMETLS(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 K.M. ERICKSON -12 NOV 80
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
INTEGER*4 LINSTY
INTEGER*4 LS(2)
INTEGER*4 LINS(6)
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
C REAL*4 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
DATA LS/43009,0/
DATA LINS/32767,0,16382,5461,27305,16383/
C CHECK FOR VALID LINSTY.
IF(LINSTY.LT.0.OR.LINSTY.GT.5)THEN
CALL WMETER(401,5)
GOTO 99999
END IF
VECTOR(4)=LINSTY
C LINE STYLE (15 BITS) VARIES FROM 0. : DOTTED , 1-32755 :DASHED, 32767: SOLID
LS(2)=LINS(LINSTY+1)
C SEND BGP COMMAND
CALL WMET13(2,LS)
99999 RETURN
END
SUBROUTINE WMETII(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 VIINIT -Initialize SVDI. Metafile
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C DICOMED
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,CDROFS,VBOUT,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
REAL*4 ASPECT
INTEGER*4 JUSTIF
integer iidsiz, iusrsz, iszrou
integer*4 i, just, aspe
integer istat
INTEGER*4 CLRTAB(256,3)
COMMON /WMET08/ CLRTAB
C MAXIMUM VALID NDC VALUES. (DEVICE-INDEPENDENT)
REAL*4 XNDCMX,YNDCMX
COMMON /WMET03/ XNDCMX,YNDCMX
C CURRENT ATTRIBUTE VALUES. (DEVICE-INDEPENDENT)
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
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
C CURRENT POSITION. (LXY,HC1)
REAL*4 XCP,YCP
COMMON /WMET09/ XCP,YCP
C Include '[VDIMAINT.COMMON]VCCRPS'
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY,HC1)
REAL*4 XSCALE,YSCALE
COMMON /WMET10/ XSCALE,YSCALE
C Include '[VDIMAINT.COMMON]VCSCAL'
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
REAL*4 XPAD,YPAD,XDEVIC,YDEVIC
COMMON /WMET11/ XPAD,YPAD,XDEVIC,YDEVIC
INTEGER*4 MACHIN(3),MACLEN
INTEGER*4 KIDSIZ,KJOBID(4),KUSRSZ,KUSRID(4),KSZROU
INTEGER*4 KJROUT(4),KSECUR,KJTIME(4),KJDATE(4)
COMMON / VCJOB/ KIDSIZ,KJOBID,KUSRSZ,KUSRID,KSZROU,
1 KJROUT,KSECUR,KJTIME,KJDATE,MACHIN,MACLEN
C DECLARE FILE INITIALIZATION COMMANDS.
integer*4 idfile(2),isecur(3), zero(1)
real*4 rzero
DATA ISECUR/33282,1,0/
RZERO= 0
ZERO(1) = 0
XPAD = 0
YPAD = 0
C SET DEFAULT ATTRIBUTE VALUES. ALL ARE DEVICE DEPENDENT EXCEPT
C VECTOR(4)=0.0.
VECTOR(1)=7.
C FOREGROUND COLOR - white
VECTOR(2)=0.
C BACKGROUND COLOR - black
VECTOR(3)=1.0
C INTENSITY -
VECTOR(4)=0.
C LINE STYLE - SOLID
VECTOR(5)=.00024414
C LINE WIDTH - 1/4096
VECTOR(6)=.01
C CHARACTER BOX Y - NORMAL PRINT SIZE (100 LINES/PAGE)
VECTOR(7)=.00714286
C CHARACTER BOX X - NORMAL PRINT SIZE (VECTOR(6)*5/7)
C ESTABLISH DEVICE UNITS (MAX ADDRESSABLE UNITS)
XDEVIC=32767
YDEVIC=32767
C ASSIGN INPUT PARAMETERS TO ASPE AND JUST
ASPE=ASPECT
JUST=JUSTIF
C CHECK FOR VALID ASPECT. IF(ASPECT.LT.0.0) THEN CALL VBERRH(721,5),
C AND USE DEFAULT ASPECT.
IF(ASPE.LT.0.) THEN
CALL WMETER(721,5)
ASPE=XDEVIC/YDEVIC
END IF
C ESTABLISH ASPECT RATIO
C IF=0 SET TO DEVICE DEPENDENT ASPECT RATIO(FOR dic ASPECT=32148/21698
IF(ASPE .EQ. 0.) ASPE = XDEVIC/YDEVIC
IF (ASPE .GT. 1.) THEN
XNDCMX = 1.
YNDCMX = 1./ASPE
ELSE
XNDCMX=ASPE
YNDCMX=1.
END IF
C DEFINE MAPPING FUNCTION FOR ANY DEVICE
C ESTABLISH SCALE FACTOR FOR MAXIMUM SCREEN DIMENSIONS OF THE DEVICE
XSCALE = XDEVIC /XNDCMX
YSCALE= YDEVIC / YNDCMX
XSCALE = MIN( XSCALE, YSCALE)
YSCALE = XSCALE
C CHECK FOR VALID JUSTIF. IF(JUSTIF.LT.0 .OR. JUSTIF.GT.9) THEN
C CALL VBERRH(720,5), AND USE DEFAULT JUSTIF.
IF(JUST .LT. 0 .OR. JUST .GT. 9) CALL WMETER(720,5)
C MAKE OUTPUT FILE FOR THE METAFILE BE UNIT 55
KOUTFL=55
C SET UP MONITORING INFORMATION
CALL WMETDV('C MET ')
CALL WMETMO(0)
C INITIALIZE THE OUTPUT FILE.
CALL WMETFF(KOUTFL,1440,1,ISTAT)
C COMPUTE LENGTH OF FILE ID INSTRUCTION.
IIDSIZ=(KIDSIZ+1)/2
IUSRSZ=(KUSRSZ+1)/2
ISZROU=(KSZROU+1)/2
IDFILE(1)=33792+12+IIDSIZ+IUSRSZ+ISZROU
IDFILE(2)=KCOMTP
c SEND FILE ID.
CALL WMET13(2,IDFILE)
C SEND DATE AND TIME.
CALL WMET05(3,KJDATE)
CALL WMET05(3,KJTIME)
C SEND LENGTH OF JOB ID AND JOB ID.
CALL WMET13S(IIDSIZ)
CALL WMET05(4,KJOBID)
C SEND LENGTH OF USER ID AND USER ID.
CALL WMET13S(IUSRSZ)
CALL WMET05(4,KUSRID)
C SEND LENGTH OF ROUTING INFO AND ROUTING INFO.
CALL WMET13S(ISZROU)
CALL WMET05(4,KJROUT)
C SEND SECURITY AND FLUSH BUFFER.
ISECUR(3)=KSECUR
CALL WMET13(3,ISECUR)
zero(1) = 0
CALL WMET13(0,zero)
C SEND ASPECT RATIO
CALL WMET13S(33539)
CALL WMET13S(INT(XNDCMX*XDEVIC))
CALL WMET13S(INT(YNDCMX*YDEVIC))
CALL WMET13S(0)
C SET UP COLOR TABLE
DO 10 I=2,256
CLRTAB(I,1) = 255
CLRTAB(I,2) = 255
CLRTAB(I,3) = 255
10 CONTINUE
CLRTAB(1,1) = 0
CLRTAB(1,2) = 0
CLRTAB(1,3) = 0
CLRTAB(2,2) = 0
CLRTAB(2,3) = 0
CLRTAB(3,1) = 0
CLRTAB(3,3) = 0
CLRTAB(4,3) = 0
CLRTAB(5,1) = 0
CLRTAB(5,2) = 0
CLRTAB(6,2) = 0
CLRTAB(7,1) = 0
C SET CURRENT POSITION TO (0.,0.)
CALL WMETIM(rzero, rzero)
RETURN
END
SUBROUTINE WMETIL(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 VILINA -Line Absolute.
C R.W.Simons -08MAY81
C ENVIRONMENT -Computer-independent, system-independent, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -XNDC,YNDC = real NDC position.
C CALLS -
C EXIT CONDITIONS -XCP,YCP = real updated current position. (XNDC,YNDC)
C NARRATIVE -Draw a line from current position to absolute NDC
C position XNDC,YNDC and update 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
REAL*4 XNDC,YNDC
INTEGER*4 OUTARY(2)
C CURRENT POSITION. (LXY,HC1)
REAL*4 XCP,YCP
COMMON /WMET09/ XCP,YCP
C Include '[VDIMAINT.COMMON]VCCRPS'
C SCALE FACTORS FOR NDC TO DC MAPPING. (LXY)
REAL*4 XSCALE,YSCALE
COMMON /WMET10/ XSCALE,YSCALE
C DC DIMENSIONS OF OFFSETS AND PICTURE. (LXY,HC1)
REAL*4 XPAD,YPAD,XDEVIC,YDEVIC
COMMON /WMET11/ XPAD,YPAD,XDEVIC,YDEVIC
C CONVERT TO SCREEN UNITS.
C SET BIT 15 OF X = 0 TO INDICATE A COORDINATE POSITIONING COMMAND.
C SET BIT 15 OF Y = 1 TO INDICATE A DRAW COMMAND.
C ASSUME X AND Y ARE < 32768, WHICH WILL BE TRUE IF XNDC AND YNDC
C ARE IN THE PROPER RANGE.
OUTARY(1)=XNDC*XSCALE+XPAD
OUTARY(2)=YNDC*YSCALE+YPAD+32768
C SEND THE COMMAND TO THE PLOT FILE.
CALL WMET13(2,OUTARY)
C UPDATE CURRENT POSITION.
XCP=XNDC
YCP=YNDC
RETURN
END
SUBROUTINE WMETIP(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 R.W.Simons -15MAY81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -X,Y = real NDC position.
C CALLS -VIMOVA,VBOUT.
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*4 X,Y
C MOVE TO THE POSITION SPECIFIED.
CALL WMETIM(X,Y)
C plot marker at current position (A400 HEX = 41984) TO THE OUTPUT FILE.
CALL WMET13S(41984)
RETURN
END
SUBROUTINE WMETIT
C C C C C C C C C C C C C 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 SVDI.
C R.W.Simons -13MAY81
C ENVIRONMENT -COMPUTER-INDEPENDENT, SYSTEM-INDEPENDENT, FORTRAN 77
C Hard Copy Format 1.
C ENTRY CONDITIONS -
C CALLS -VBOUT,VBERRH.
C EXIT CONDITIONS -
C NARRATIVE -Terminate the SVDI. Flush buffers, etc.
C C C C C C C C C C C C 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*4 i
INTEGER*4 KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,KBAUD,
1KCOMTP
COMMON /CDRCOM/ KWRTFL,KRDFL,KOUTFL,KINFL,KWRDSZ,KBYTEL,KCPW,
1 KBAUD,KCOMTP
INTEGER FILLER
C FILLER IS 1440 BYTES WORTH OF DECIMAL 8100 PADD CHARACTERS
DATA FILLER /33024/
integer*4 zero(1)
C SEND AN END OF DATA COMMAND TO THE OUTPUT FILE.
C 8600 HEX = 34304 = END OF DATA COMMAND.
CALL WMET13S(34304)
C UPON TERMINATION, WE WANT TO SEND AN EXTRA BUFFER FULL OF PADD
C CHARACTERS. BY DOING THIS, WE CAN EASILY BUILD A STANDARD
C METAFILE WHICH CAN BE PASSED AROUND SYSTEMS. IT MAY BE
C NECESSARY FOR SOME SYSTEMS TO THROW AWAY DATA AT THE END OF
C THE FILE, AND THIS WILL ENSURE THAT NOTHING WORTHWHILE GETS
C DISCARDED.
zero(1) = 0
DO 10 I=1,2048
CALL WMET13S(FILLER)
10 CONTINUE
C FLUSH OUTPUT BUFFERS.
CALL WMET13(0,zero)
CALL WMETCF(KOUTFL,1)
CALL WMETMO(2)
RETURN
END
SUBROUTINE WMETIX(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 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 JSPOT
INTEGER*4 LENGT1, CHARS(136), LENGTH, i
REAL*4 VECTOR(7)
COMMON /WMET04/ VECTOR
COMMON /WMET09/XCP,YCP
REAL*4 XCP,YCP
LOGICAL ODD
INTEGER*4 TBUF(73)
c check for valid length.
LENGTH = LENGT1
IF(LENGTH.LT.1) THEN
CALL WMETER(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 WMETER(213,5)
LENGTH = 136
ENDIF
c initialized the number of chars in tbuf,
c the spot marker and the odd/even flag
ODD = .TRUE.
JSPOT = 1
c loop through length characters.
DO 100 I=1,LENGTH
c check for valid chars.
c ignore control characters, except backspace and linefeed.
IF(CHARS(I).LT.32 .OR. CHARS(I).GT.126) THEN
IF(CHARS(I).NE.8.AND.CHARS(I).NE.10) THEN
CALL WMETER(208,5)
GOTO 100
ENDIF
END IF
c now pack the chars into the buffer
IF(ODD) THEN
JSPOT = JSPOT + 1
TBUF(JSPOT) = CHARS(I)*256
ELSE
TBUF(JSPOT) = TBUF(JSPOT) + CHARS(I)
ENDIF
ODD = .NOT. ODD
C UPDATE THE CURRENT POSITION
IF(CHARS(I).GE.32) THEN
XCP = XCP + VECTOR(7)
ELSE IF(CHARS(I).EQ.10) THEN
YCP = YCP - VECTOR(6)
ELSE
XCP = XCP - VECTOR(7)
ENDIF
100 CONTINUE
c send the chars to the bgp file
c 45056 :: b000 tbuf(1)=45056 + jspot -1
c jspot is the number of words filled or partially filled up in tbuf
c including the 1st word with the command
TBUF(1)=JSPOT+45055
CALL WMET13(JSPOT,TBUF)
999 RETURN
END