subroutine gbytes ( NPACK, ISAM, IBIT, NBITS, NSKIP, ITER ) ! !******************************************************************************* ! !! GBYTES unpacks bit chunks. ! ! ! Discussion: ! ! GBYTES unpacks bit chunks from the input array NPACK ! into the output array ISAM. "ITER" bit chunks of length ! "NBITS" with "NSKIP" bits being skipped between each bit ! chunk in the input array are unpacked into ISAM. Each ! bit chunk in the input array it unpacked into a separate ! word in ISAM, right-justified with zero-fill. Initially ! "IBIT" bits will be skipped at the beginning of the ! input array before unpacking. ! ! Example: ! ! call GBYTES(NPB,ISB,3,6,9,2) ! ! In this call, 3 bits would be skipped at the beginning of NPB; ! the next 6 bits would be unpacked into ISB(1) right-justified with ! zero-fill; 9 bits would be skipped in NPB; the next six bits of ! NPB would be unpacked into ISB(2) right-justified with zero-fill. ! ! Parameters: ! ! NPACK ! Address of the first word of the array to be unpacked. ! ! ISAM ! Array to receive the unpacked bit chunks. They will be ! right-justified with zero-fill in this array. ISAM ! should be dimensioned for ITER. ! ! IBIT ! A bit-count offset to be used before the first bit chunk is ! unpacked. For example, if IBIT=3 and NBITS=5, then ! 3 bits in NPACK will be skipped and the next 5 bits ! will be unpacked into ISAM(1). ! ! NBITS ! The number of bits in each bit chunk to be unpacked. ! ! NSKIP ! The number of bits to skip between each bit chunk to be ! unpacked (after the first bit chunk has been unpacked.) ! ! ITER ! The number of bit chunks to be unpacked. ! implicit integer (A-Z) ! integer isam(*) integer mask(64) integer, save :: ncall = 0 integer npack(*) ! save BPERI save MASK ! ! Do initialization which needs to be done only on the first call. ! if ( NCALL == 0 ) then ! ! Get number of bits in an integer (word size) ! BPERI = I1MACH(5) ! ! Set up masks ! MASK(1) = 1 do I = 2, BPERI MASK(I) = IOR(ISHFT(MASK(I-1),1),1) end do NCALL = 1 end if ! ! Check if NBITS is valid ! if ( NBITS > BPERI .or. NBITS <= 0 ) then write ( *,*) ' GBYTES--NBITS OUT OF RANGE' STOP end if ! ! Define bit mask to be used for the words in ISAM ! MSK1 = MASK(NBITS) ! ! Calculate the total number of bits used in the input array ! by a bit-chunk move. ! BITSEP = NBITS+NSKIP ! ! Fill the output array ! do I=1,ITER ! ! Calculate the bit position in the input array where the bits ! are to be unpacked. ! BPO = IBIT+(I-1)*BITSEP ! ! Calculate the word position in the input array where the bits ! are to be unpacked. ! WPO = BPO/BPERI+1 ! ! Calculate the number of bits in the current input word which ! are to be unpacked. ! RBITS = BPERI*WPO-BPO ! ! Compute shift. ! SHFT = NBITS-RBITS ! ! Treat the case where there are enough bits in the current ! word of the input word to be unpacked. ! if ( SHFT <= 0 ) then ISAM(I) = IAND(MSK1,ISHFT(NPACK(WPO),SHFT)) ! ! Treat the case where the bits to be unpacked cross a word ! boundary. ! else BTMPL = ISHFT(IAND(NPACK(WPO),MASK(RBITS)),SHFT) BTMPR = IAND(ISHFT(NPACK(WPO+1),SHFT-BPERI),MASK(SHFT)) ISAM(I) = IOR(BTMPL,BTMPR) end if end do return end function i1mach ( i ) ! !******************************************************************************* ! !! I1MACH returns integer machine constants. ! ! ! Discussion: ! ! Input/output unit numbers. ! ! I1MACH(1) = the standard input unit. ! I1MACH(2) = the standard output unit. ! I1MACH(3) = the standard punch unit. ! I1MACH(4) = the standard error message unit. ! ! Words. ! ! I1MACH(5) = the number of bits per integer storage unit. ! I1MACH(6) = the number of characters per integer storage unit. ! ! Integers. ! ! Assume integers are represented in the S digit base A form: ! ! Sign * (X(S-1)*A**(S-1) + ... + X(1)*A + X(0)) ! ! where 0<=X(I) 16 ) then write ( *, * ) ' ' write ( *, * ) 'I1MACH - Fatal error!' write ( *, * ) ' I is out of bounds:', i i1mach = 0 stop else i1mach = imach(i) end if return end subroutine sbytes (NPACK,ISAM,IBIT,NBITS,NSKIP,ITER) ! !******************************************************************************* ! !! SBYTES packs bits from the input array ISAM to the output array NPACK. ! ! ! Discussion: ! ! After skipping "IBIT" bits in NPACK, the "NBITS" rightmost bits from ! "ITER" successive words in "ISAM" are packed into "NPACK" with "NSKIP" ! bits between each moved block. ! ! Example: ! ! call SBYTES(NPC,ISB,45,6,3,2) ! ! In this call, 45 bits would be skipped at the beginning of NPC; ! the right-most 6 bits of ISB(1) would be packed into NPC; 3 bits ! would be skipped in NPC; the right-most 6 bits of ISB(2) would ! be packed into NPC. ! ! Parameters: ! ! NPACK ! Address of the first word of the array to be packed. ! ! ISAM ! Array to be packed into NPACK. The right-most NBITS ! bits of each word will be packed. ISAM should be ! dimensioned for at least ITER. ! ! IBIT ! A bit-count offset to be used before the first bits are ! packed into NPACK. For example, if IBIT=3 and NBITS=5, ! 3 bits in NPACK will be skipped before the right-most ! 5 bits of ISAM(1) are packed into it. ! ! NBITS ! The number of bits in each word of ISAM to be unpacked. ! NBITS must not exceed the word size on the given machine. ! ! ITER ! The number of bit chunks to be packed. ! implicit integer (A-Z) ! DIMENSION ISAM(*) integer mask(64) integer, save :: ncall = 0 integer NPACK(*) ! SAVE BPERI,MASK ! ! Do initialization which needs to be done only on the ! first call to SBYTES. ! if ( NCALL == 0 ) then ! ! Get number of bits in an integer ! BPERI = I1MACH(5) ! ! Set up masks ! MASK(1) = 1 do I = 2, BPERI MASK(I) = IOR(ISHFT(MASK(I-1),1),1) end do NCALL = 1 end if ! ! Check if NBITS is valid ! if ( NBITS > BPERI .or. NBITS <= 0) then write ( *, * ) ' ' write ( *, * ) 'SBYTES - Fatal error!' write ( *, * ) ' NBITS OUT OF RANGE' stop end if ! ! Define bit mask to be used for the words in ISAM ! MSK1 = MASK(NBITS) ! ! Define bit mask to be used for bits in NPACK ! if (BPERI == NBITS) then MSK2 = 0 else MSK2 = MASK(BPERI-NBITS) end if ! ! Calculate the total number of bits in the output array ! used by each move from words in the input array ! BITSEP = NBITS+NSKIP ! ! Loop through the input array ! do I = 1, ITER ! ! Get bits to be moved from ISAM ! SBITS = IAND(MSK1,ISAM(I)) ! ! Calculate the bit position in the output array where ! the bits from the input word are to go ! BPO = IBIT+(I-1)*BITSEP ! ! Calculate the word position in the output array where ! the bits from the input word are to go ! WPO = BPO/BPERI+1 ! ! Calculate the number of bits in the current output word ! which still remain to be filled ! RBITS = BPERI*WPO-BPO ! ! Calculate the number of bits in the current output word ! which have already been filled ! UBITS = BPERI-RBITS ! ! Treat the case where there are enough bits in the current ! output word to receive the bits from the input word ! if ( RBITS >= NBITS) then ! ! Calculate the number of bits to left shift SBITS ! LSHIFT = BPERI-UBITS-NBITS ! ! Fill the output word ! NPACK(WPO) = IAND(NPACK(WPO),ISHFT(MSK2,LSHIFT+NBITS)) NPACK(WPO) = IOR(NPACK(WPO),ISHFT(SBITS,LSHIFT)) ! ! Treat the case where the moved bits cross a word boundary ! in the output buffer ! else RSHIFT = RBITS-NBITS BTMP = ISHFT(SBITS,RSHIFT) NPACK(WPO) = IAND(NPACK(WPO),ISHFT(MASK(UBITS),RBITS)) NPACK(WPO) = IOR(NPACK(WPO),BTMP) BTMP = ISHFT(IAND(MASK(-RSHIFT),SBITS),BPERI+RSHIFT) NPACK(WPO+1) = IAND(NPACK(WPO+1),MASK(BPERI+RSHIFT)) NPACK(WPO+1) = IOR(NPACK(WPO+1),BTMP) end if end do return end BLOCK DATA G01BKD ! !******************************************************************************* ! !! G01BKD is a BLOCK DATA MODULE FOR WORKSTATION DRIVER TYPE 1. ! ! ! G01WSL -- workstation state list for workstation type 1, ! a vdm subset mo for level 0a GKS. ! ! Contains all of the items mandated GKS for the ! state list, plus supplementary items such as ! array dimensions, plus some state variables (such ! as clipping control parameters) which are not ! specified as part of the structure by GKS. ! ! ! mwkid - workstation identifier. ! mconid - connection identifier (lun for metafile output). ! mwtype - workstation type (should be 1 for this workstation). ! ! (The previous 3 items are initialized by 'OPEN WORKSTATION') ! ! mstate - workstation state (0=ginact, 1=gactiv). ! mopen - marks workstation open/close (0=closed, 1=open) ! mdefmo - deferral mode (0=gasap,1=gbnil,2=gbnig,3=gasti), ! not settable at level 0, default 3 (gasti). ! mregmo - implicit regeneration mode (0=gssupd,1=gallow), ! not settable at level 0, default 1 (gallow). ! mdempt - display surface empty (0=gnempt,1=gempty), ! default 1 (gempty). ! mnfram - new frame action necessary at update (0=gno,1=gyes), ! should always be 0 (gno), because of 'mregmo', plus ! the fact that level 0 has only the functions SET ! COLOR REPRESENTATION and workstation transformation ! that have potential regeneration implications, and ! the treatment of these as IMM (the WDT for MO does ! not contain IRG/IMM information). ! mtus - workstation transformation update state (0=gnpend, ! 1=gpend); default 0 (gnpend). This item should ! always be 0 in this MO workstation, because of ! assumption discussed in 'mnfram'. See also the above ! discussion of "Workstation Transformation". ! rwindo - requested workstation window in NDC; in order, the ! entries in 'rwindo' are rwxmin,rwxmax,rwymin,rwymax. ! Default 0,1,0,1. ! cwindo - current workstation window in NDC; in order, the ! entries in 'cwindo' are cwxmin,cwxmax,cwymin,cwymax. ! See above discussion on "Workstation Transformation". ! Default 0,1,0,1. ! mrwkvp - requested workstation viewport (mrvxmn,mrvxmx,mrvymn, ! mrvymx, converted from real DC to integer DC/VDC). ! Default 0,32767,0,32767. ! mcwkvp - current workstation viewport (mrvxmn,mrvxmx,mrvymn, ! mrvymx, converted from real DC to integer DC/VDC). ! See above discussion on "Workstation Window" ! Default 0,32767,0,32767. ! molmax - size of color table arrays (in'zd in block data). ! mol - number of indexes currently defined in color table, ! even for MO GKS mandates that this be at least 2 -- ! indexes 0 and 1 are supposed to be defined in the WDT ! for every workstation (default 2). ! mcovfl - overflow flag for color index arrays, indicating ! whether number of simultaneously defined indexes, ! 'mol', on MO has exceeded 'molmax' (0=no, 1=yes). ! Default 0. ! mcsort - sort flag for color index arrays, indicating whether ! 'mcoli' and the color arrays are known to be in ! sort order or may not be (0=nosort, 1=sort). ! Default value is 1. ! mcoli - array molmax long to hold color indexes which have ! been defined; default (1)=0, (2)=1. ! sred - array molmax long to hold red components of defined ! color indexes; default (1)=0.0, (2)=0.8. ! sgreen - array molmax long to hold green components of defined ! color indexes; default (1)=0.0, (2)=0.8. ! sblue - array molmax long to hold blue components of defined ! color indexes; default (1)=0.0, (2)=0.8. ! ! ! mrcrec - clipping rectangle (mxmin,mymin,mxmax,mymax; ! transformed by MO from real NDC and stored as ! corner pts, integer VDC (default: 0,0,32767,32767) ! mrclip - clipping indicator (default: 0 [GNCLIP]) ! common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP ! ! G01WDT -- Workstation Description Table for workstation ! type 1, a VDM-subset MO for level 0a GKS. ! ! lwtype - workstation type, 1 for this workstation. ! lwkcat - workstation category, 4 (gmo) ! mversn - version number for metafile (METAFILE ELEM LIST) ! common /G01WDT/ LWTYPE, LWKCAT, MVERSN integer LWTYPE, LWKCAT, MVERSN ! ! G01INS -- Structure for preservation of miscellaneous ! internal state variables which may be needed ! and should be non-volatile. ! ! mcodes - set equal to function code of current invocation ! upon entry, after check for continuation error. ! mconts - continuation flag of last interface invocation. ! mvdcfw - field width for metafile coordinates, i.e., the ! number of bits per coordinate component in the ! metafile output stream; default 16 set in blockdata. ! mcixfw - field width for color indices, measured in bits; ! default 8 set in blockdata. ! mdccfw - field width for direct color components, measured ! in bits; default 8 set in blockdata. ! mixfw - field width for CGM parameters of type index, ! measured in bits; default 16 set in blockdata. ! mintfw - field width for CGM parameters of type integer, ! measured in bits; default 16 set in blockdata. ! mefw - field width for CGM parameters of type enumerated, ! measured in bits; fixed at 16, set in blockdata. ! mdccrg - normalized direct color component range, 2**mdccfw-1, ! 0.0 to 1.0 real is mapped to 0 to mdccrg integer, ! and recorded thus in the metafile; default 255. ! Default; mxscal=32767. ! minxvd - minimum metafile x address; default 0. ! maxxvd - maximum metafile address; default 32767. ! minyvd - minimum metafile y address; default 0. ! maxyvd - maximuim metafile y address; default 32767. ! mxoff - x offset (additive constant) for transformation which ! converts real [0-1] NDC to integer VDC (dflt 0-32767). ! VDC(x) = mxoff + mxscal*NDC(x). Default; mxoff=0. ! mxscal - x scaling factor for NDC to VDC transformation. ! Default; mxscal=32767. Scale and offset would only ! be changeable if the scheme for Workstation Transform- ! tion handling by mapping a subset of NDC into VDC ! were realized. In this case, offset and scaling ! would be computed based on the NDC window and the ! VDC viewport, for both x and y. ! myoff - y offset (additive constant) for transformation which ! converts real [0-1] NDC to integer VDC (dflt 0-32767). ! VDC(y) = myoff + myscal*NDC(y). Default; myoff=0. ! myscal - y scaling factor for NDC to VDC transformation. ! Default; myscal=32767. ! mcfpp - the bit precision of each of the two components that ! make up a flaoting point number in the metacode. ! Default; mcfpp=16 ! mcfrm - the current frame number for VDM ! mcopcl - the opcode class for the current VDM instruction ! mcopid - the opcode id for the current VDM instruction ! mcnbyt - the remainder byte count for the continue of a VDM ! instruction ! mccbyt - the current number of bytes being transfered to a ! VDM operand set ! mslfmt - indicator as to whether the current instruction being ! put out is a short format or long format instruction. ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! G01ADF -- Contains the default values of the workstation ! independent attributes. These are the values which ! the attributes implicitly assume after BEGIN PICTURE. ! BEGIN PICTURE effectively causes these to be the ! "sent" variables, even though the send is implicit. ! ! The first part of the structure exactly parallels ! the structure G01ARQ. Following the first part ! are defaults for clipping control parameters, ... ! ! ! mdplix - polyline index (default: 1) ! mdltyp - line type (default: 1 [GLSOLI]) ! mdplci - polyline color index (default: 1) ! adlwsc - line width scale factor (default: 1.0) ! ! mdpmix - polymarker index (default: 1) ! mdmtyp - marker type (default: 3 [GAST]) ! mdpmci - polymarker color index (default: 1) ! admszs - marker size scale factor (default: 1.0) ! ! mdtxix - text index (default: 1) ! mdtxp - text path (default: 0 [GRIGHT]) ! mdtxal - text alignment (default: 1,4 [GLEFT,GBASE]) ! mdtxfo - text font (default: 1) ! mdtxpr - text precision (default: 0 [GSTRP]) ! mdtxci - text color index (default: 1) ! mdchh - character height (default: 328) ! mdchov - character orientation vectors ! (default: 0,328 and 328,0) ! adchxp - character expansion factor (default: 1.0) ! adchsp - character spacing (default: 0.0) ! ! mdfaix - fill area index (default: 1) ! mdpasz - pattern size (default: 0,32767, ! 32767,0) ! mdparf - pattern reference point (default: 0,0) ! mdfais - fill area interior style (default: 0 [GHOLLO]) ! mdfasi - fill area style index (default: 1) ! mdfaci - fill area color index (default: 1) ! ! mdasf - ASFs, in order: ! 1 - linetype (default: 1 [GINDIV]) ! 2 - linewidth scale factor (default: 1 [GINDIV]) ! 3 - polyline color index (default: 1 [GINDIV]) ! 4 - marker type (default: 1 [GINDIV]) ! 5 - marker size scale factor (default: 1 [GINDIV]) ! 6 - polymarker color index (default: 1 [GINDIV]) ! 7 - text font and precision (default: 1 [GINDIV]) ! 8 - character expansion factor (default: 1 [GINDIV]) ! 9 - character spacing (default: 1 [GINDIV]) ! 10 - text color index (default: 1 [GINDIV]) ! 11 - fill area interior style (default: 1 [GINDIV]) ! 12 - fill area style index (default: 1 [GINDIV]) ! 13 - fill area color index (default: 1 [GINDIV]) ! common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF ! ! G01ADC -- Control variables for attribute deferral scheme. ! ! ! valchg - array of logical variables indicating whether ! value changes are pending for each of the ! attributes. There is a one-to-one relationship ! between the elements of valchng and and the ! aspect/pen variables in G01ARQ, etc. ! ! asfchg - array of logical variables indicating whether ! changes are pending for each of the ASFs. The ! is a one-to-one relationship between the elements ! of this array and the ASF array passed by the ! workstation interface. ! ! anyasf - logical scalar that says whether any ASF has ! changed -- the logical OR of asfchg(*). ! ! [The following set of integer variables are pointers into ! 'valchg', associating each valchg element with the proper ! attribute. Values of the pointers are first column of ! numbers in parentheses.] ! ! ivplix - polyline pen ( 1) ( 1) ! ivltyp - linetype ( 2) ( 2) ! ivlwsc - linewidth scale factor ( 3) (- 3) ! ivplci - polyline color index ( 4) ( 4) ! ! ivpmix - polymarker pen ( 5) ( 5) ! ivmtyp - marker type ( 6) ( 6) ! ivmszs - marker size scale factor ( 7) (- 7) ! ivpmci - polymarker color index ( 8) ( 8) ! ! ivtxix - text pen ( 9) ( 9) ! ivtxp - text path (10) ( 10) ! ivtxal - text alignment (11) ( 11) ! ivchh - character height (12) ( 13) ! ivchov - character orientation vectors (13) ( 14) ! ivtxfo - text font (14) ( 18) ! ivtxpr - text precision (15) ( 19) ! ivchxp - character expansion factor (16) (-20) ! ivchsp - character spacing (17) (-21) ! ivtxci - text color index (18) ( 22) ! ! ivfaix - fill area pen (19) ( 23) ! ivpasz - fill area pattern size (20) ( 24) ! ivparf - fill area pattern ref point (21) ( 28) ! ivfais - fill area interior style (22) ( 30) ! ivfasi - fill area style index (23) ( 31) ! ivfaci - fill area color index (24) ( 32) ! ! ivasf - ASFs (25) ( 33) ! ! ip2aea - array of integer pointers that associated each ! of the above indexes with the start position of ! the attribute in the attribute equivalencing ! arrays. Second column of values in parentheses ! above are values. The absolute value of the item ! is the pointer, the sign means that the quantities ! stored in the attribute arrays are real-valued if ! negative, integer-valued if positive. Note that ! there is one last entry in IP2AEA giving the location ! beyond the last attribute item stored in the ! equivalencing arrays. ! ! il2aea - lengths of the items pointed to by the ip2aea. ! ! [The integer variables in the following set are pointers ! into asfchg, associating each asfchg element with the proper ! attribute. Values of the pointers are in parentheses. ! Note these indexes correspond exactly with the ASF array ! passed by the workstation interface.] ! ! ialtyp - linetype ( 1) ! ialwsc - linewidth scale factor ( 2) ! iaplci - polyline color index ( 3) ! ! iamtyp - marker type ( 4) ! iamszs - marker size scale factor ( 5) ! iapmci - polymarker color index ( 6) ! ! iatxfp - text font and precision ( 7) ! iachxp - character expansion factor ( 8) ! iachsp - character spacing ( 9) ! iatxci - text color index (10) ! ! iafais - fill area interior style (11) ! iafasi - fill area style index (12) ! iafaci - fill area color index (13) ! ! ! agpend - logical array indicating for each geometric primitive ! whether any changes to the attribute context of any ! sort (pen, aspect, ASF) are pending (deferred). ! The order of the array elements is: ! polyline, polymarker, text, fill area (note that cell ! array has no attributes). ! ! ncgasf - number of ASFs defined in CGM standard (18 currently). ! ngkasf - number of ASFs defined in GKS standard (13 currently). ! masmap(ncgasf) - mapping array from CGM ASFs to GKS ASFs. For ! ix=1..ncgasf, masmap(ix) is the index (into ASFCHG, ! MRASF, MSASF) of the functionally corresponding GKS ! ASF. Note that multiple CGM ASFs may correspond with ! a single GKS ASF (e.g., font and precision -->font/prec). ! Also a CGM ASF may correspond with no GKS ASFs, e.g., ! the perimeter attributes. In this case, the pointer ! is set to zero. ! common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! ! G01IO -- Output buffer(s), pointers, etc. ! ! mpxysz - size in words of mpxpy. ! mpxpy - holding buffer, for results of coordinate ! conversions. ! mobfsz - size in words of moutbf. ! moutbf - primary output buffer, integer array. ! mbfpos - next available storage location in moutbf, ! offset in bits from beginning of moutbf. ! mfglun - logical unit number for metafile generator output. ! mxbits - number of bits in moutbf ! mdtype - metacode data type id ! mnfflg - new-frame flag set to 1 (GYES) by a 'begin picture', ! cleared (GNO) by the metafile writing routines ! mbmflg - begin-metafile flag, set to 1 (GYES) on 'open ! wkstn', cleared (GNO) by metafile writing routines. ! mbmflg - end-metafile flag, set to 0 (GNO) on 'open ! wkstn', set to 1 (GYES) upon 'close workstation'. ! mrecnm - the current record to be written out ! mioflg - this is a flag value which is set to -9999; it ! is to be used by independent utilities which may ! want to write to the metafile output unit of this ! GKS package if it has been opened. ! common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! G01OPC -- Common containing all CGM opcodes that are ! used/needed by the metafile generator wkstn. ! ! Each CGM element has a class and an id that ! together make up the opcode. The following table ! gives the element name, class parameter name, ! and id parameter name. ! ! The CGM elements are grouped in classes. The ! class code is invariant within a class. For each ! class, a parameter is defined that is equivalent ! to all the individual named class parameters ! within the class, which are defined as locals. ! ! ! Element name Class Id ! ------------ ------ ------ ! ! (Delimiter class) (cldelm) ! noop clnoop idnoop ! BEGIN METAFILE clbegm idbegm ! end METAFILE clendm idendm ! BEGIN PICTURE clbegp idendp ! BEGIN PICTURE BODY clbgpb idbgpb ! end PICTURE clendp idendp ! ! (Metafile Descriptor Class) (clmdes) ! METAFILE VERSION clmver idmver ! METAFILE ELEMENTS LIST clmelt idmelt ! METAFILE DEFAULTS REPLACEMENT cldrep iddrep ! METAFILE DESCRIPTION cldscr iddscr ! ! (Picture Delimiter Class) (clpdes) ! COLOUR SELECTION MODE clcsel idcsel ! VDC EXTENT clvext idvext ! BACKGROUND COLOR clbkgc idbkgc ! ! (Control Class) (clcntl) ! VDC INTEGER PRECISION clvint idvint ! CLIP RECTANGLE clcrec idcrec ! CLIP INDICATOR clclin idclin ! ! (Graphical Primitives Class) (clprim) ! POLYLINE clplin idplin ! POLYMARKER clpmrk idpmrk ! TEXT cltext idtext ! POLYGON clpgon idpgon ! CELL ARRAY clcary idcary ! GENERALIZED DRAWING PRIMITIVE clgdp idgdp ! ! (Primitive Attributes Class) (clprat) ! LINE BUNDLE INDEX cllbix idlbix ! LINE TYPE clltyp idltyp ! LINE WIDTH cllwid idlwid ! LINE COLOUR cllclr idlclr ! MARKER BUNDLE INDEX clmbix idmbix ! MARKER TYPE clmtyp idmtyp ! MARKER SIZE clmsiz idmsiz ! MARKER COLOUR clmclr idmclr ! TEXT BUNDLE INDEX cltbix idtbix ! TEXT FONT INDEX cltfon idtfon ! TEXT PRECISION cltpre idtpre ! character EXPANSION FACTOR clchex idchex ! character SPACING clchsp idchsp ! TEXT COLOUR cltclr idtclr ! character HEIGHT clchht idchht ! character ORIENTATION clchor idchor ! TEXT PATH cltxpa idtxpa ! TEXT ALIGNMENT cltxal idtxal ! FILL BUNDLE INDEX clfbix idfbix ! INTERIOR STYLE clints idints ! FILL COLOUR clfclr idfclr ! HATCH INDEX clhaix idhaix ! PATTERN INDEX clptix idptix ! FILL REFERENCE POINT clfrpt idfrpt ! PATTERN TABLE clptbl idptbl ! PATTERN SIZE clptsz idptsz ! COLOUR TABLE clctbl idctbl ! ASPECT SOURCE FLAGS clasfs idasfs ! ! (Escape Elements Class) (clesce) ! ESCAPE clesc idesc ! ! (External Elements Class) (clexte) ! MESSAGE clmess idmess ! APPLICATION DATA clapld idapld ! ! ! ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) ! ! WORKSTATION STATE LIST. ! ! LENGTH OF COLOR TABLE ARRAYS. DATA MOLMAX/256/ ! ! WORKSTATION DESCRIPTION TABLE ! ! WORKSTATION TYPE AND CATEGORY DATA LWTYPE,LWKCAT/1,4/ ! ! METAFILE VERSION. DATA MVERSN/-32767/ ! ! INTERNAL CONSTANTS. ! ! ! LAST FUNCTION CODE, LAST CONTINUATION FLAG. DATA MCODES/0/, MCONTS/0/ ! ! VDC, COLOR INDEX, DIRECT COLOR COMPONENT FIELD WIDTHS. DATA MVDCFW/16/, MCIXFW/8/, MDCCFW/8/ DATA MIXFW/16/, MINTFW/16/, MEFW/16/ ! ! 2**MDCCFW - 1 ! (SHOULD BE TIED PARAMETRICALLY TO MCIXFW). DATA MDCCRG/255/ ! ! MIN AND MAX VDC ADDRESS LIMITS IN X AND Y DIRECTIONS, ! THE VDC EXTENT (THE TWO CONCEPTS SHOULD BE SEPARATED LATER). DATA MINXVD/0/, MAXXVD/32767/, MINYVD/0/, MAXYVD/32767/ ! ! NDC TO VDC MAPPING COEFFICIENTS, X AND Y DIRECTIONS. DATA MXOFF/0/, MXSCAL/32767/, MYOFF/0/, MYSCAL/32767/ ! ! COLOR TABLE CHANGE, BACKGROUND COLOR CHANGE. DATA MCTCHG/0/, MBCCHG/0/ ! ! SIZE OF HOLDING BUFFER DATA MPXYSZ/256/ ! ! INITIAL VALUE FOR CURRENT FRAME NUMBER DATA MCFRM/1/ ! ! PRECISION (IN BITS) OF THE TWO COMPONENTS OF THE REPRESENTATION ! OF REAL NUMBERS IN THE METAFILE DATA MCFPP/16/ ! ! DEFAULT ATTRIBUTE CONTEXT. ! ! ! POLYLINE INDEX, LINETYPE, LINE COLOR INDEX, LINEWIDTH SCALE. DATA MDPLIX/1/, MDLTYP/1/, MDPLCI/1/, ADLWSC/1.0/ ! ! POLYMARKER INDEX, MARKER TYPE, MARKER COLOR INDEX, MARKER SCALE. DATA MDPMIX/1/, MDMTYP/3/, MDPMCI/1/, ADMSZS/1.0/ ! ! TEXT INDEX, TEXT PATH, TEXT ALIGNMENT, TEXT FONT. DATA MDTXIX/1/, MDTXP/0/, MDTXAL/0,0/, MDTXFO/1/ ! ! TEXT PRECISION, TEXT COLOR INDEX, character HEIGHT. ! (MDCHH SHOULD EVENTUALLY BE TIED PARAMETRICALLY TO VDC EXTENT). DATA MDTXPR/0/, MDTXCI/1/, MDCHH/328/ ! ! character ORIENTATION VECTORS. ! (MDCHOV SHOULD EVENTUALLY BE TIED PARAMETRICALLY TO VDC EXTENT). DATA MDCHOV/0,328,328,0/ ! ! character EXPANSION FACTOR, CHARACTER SPACING. DATA ADCHXP/1.0/, ADCHSP/0.0/ ! ! FILL AREA INDEX, PATTERN SIZE, PATTERN REF POINT. ! (MDPASZ SHOULD EVENTUALLY BE TIED PARAMETRICALLY TO VDC EXTENT). DATA MDFAIX/1/, MDPASZ/0,32767,32767,0/, MDPARF/0,0/ ! ! FILL AREA INTERIOR STYLE, STYLE INDEX, COLOR INDEX. DATA MDFAIS/0/, MDFASI/1/, MDFACI/1/ ! ! ASF VALUES. DATA MDASF/13*1/ ! ! POINTERS INTO ATTRIBUTE STRUCTURE, VALCHG VARIABLES. ! DATA IVPLIX/ 1/, IVLTYP/ 2/, IVLWSC/ 3/, IVPLCI/ 4/ DATA IVPMIX/ 5/, IVMTYP/ 6/, IVMSZS/ 7/, IVPMCI/ 8/ DATA IVTXIX/ 9/, IVTXP/10/, IVTXAL/11/, IVCHH/12/ DATA IVCHOV/13/, IVTXFO/14/, IVTXPR/15/, IVCHXP/16/ DATA IVCHSP/17/, IVTXCI/18/, IVFAIX/19/, IVPASZ/20/ DATA IVPARF/21/, IVFAIS/22/, IVFASI/23/, IVFACI/24/ DATA IVASF/25/ ! ! POINTERS INTO ATTRIBUTE EQUIVALENCING ARRAYS. ! DATA IP2AEA/ 1, 2, -3, 4, 5, 6, -7, 8, 9, 10, 11, 13, & 14, 18, 19,-20,-21, 22, 23, 24, 28, 30, 31, 32, & 33, 46 / ! ! POINTERS INTO ASF ARRAYS. ! DATA IALTYP/ 1/, IALWSC/ 2/, IAPLCI/ 3/, IAMTYP/ 4/ DATA IAMSZS/ 5/, IAPMCI/ 6/, IATXFP/ 7/, IACHXP/ 8/ DATA IACHSP/ 9/, IATXCI/10/, IAFAIS/11/, IAFASI/12/ DATA IAFACI/13/ ! ! NBR OF GKS AND CGM ASFS, CGM TO GKS MAPPING ARRAY. ! DATA NCGASF/18/, NGKASF/13/ DATA MASMAP/1,2,3,4,5,6,7,7,8,9,10,11,12,13,13,0,0,0/ ! ! GKS ENUMERATIVES. ! DATA GNO/0/, GYES/1/, GCONDI/0/, GALWAY/1/ DATA GINACT/0/, GACTIV/1/, GNEMPT/0/, GEMPTY/1/ DATA GNPEND/0/, GPEND/1/, GNCLIP/0/ ! ! CGM OPCODES, CLASS AND ID CODES. ! DATA IDNOOP/0/, IDBEGM/1/, IDENDM/2/, IDBEGP/3/ DATA IDBGPB/4/, IDENDP/5/, IDMVER/1/, IDMELT/11/ DATA IDDREP/12/, IDCSEL/2/, IDVEXT/6/, IDVINT/1/ DATA IDCREC/5/, IDCLIN/6/, IDPLIN/1/, IDPMRK/3/ DATA IDTEXT/4/, IDPGON/7/, IDCARY/9/, IDGDP/10/ DATA IDLBIX/1/, IDLTYP/2/, IDLWID/3/, IDLCLR/4/ DATA IDMBIX/5/, IDMTYP/6/, IDMSIZ/7/, IDMCLR/8/ DATA IDTBIX/9/, IDTFON/10/, IDTPRE/11/, IDCHEX/12/ DATA IDCHSP/13/, IDTCLR/14/, IDCHHT/15/, IDCHOR/16/ DATA IDTXPA/17/, IDTXAL/18/, IDFBIX/21/, IDINTS/22/ DATA IDFCLR/23/, IDHAIX/24/, IDPTIX/25/, IDFRPT/31/ DATA IDPTBL/32/, IDPTSZ/33/, IDCTBL/34/, IDASFS/35/ DATA IDESC/1/, IDMESS/1/, IDAPLD/2/, IDBKGC/7/ DATA IDDSCR/2/ DATA CLDELM/0/, CLMDES/1/, CLPDES/2/, CLCNTL/3/ DATA CLPRIM/4/, CLPRAT/5/, CLESCE/6/, CLEXTE/7/ ! ! FLAG VALUE IN IO common BLOCK ! DATA MIOFLG/-9999/ end subroutine G01CA ! !******************************************************************************* ! !! G01CA processes the GKS cell ARRAY INSTRUCTION, PUT OUT CGM CELL ARRAY. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) ! integer DX, DY, KALL, NBYPCW, ROWLEN, ROWPAD, NBYTES integer NBYTE1, NBYTE2, GPAD, GDFCP, GNORUN integer CARPOS, ROWPOS, IDPOS, NCLOUT, NBPROW, IX ! SAVE ! DATA KALL/0/, NBYPCW/2/, GPAD/0/, GDFCP/0/, GNORUN/1/ ! KALL = KALL+1 if ( KALL == 1 ) then ! ! TREAT FIRST CASE (SET-UP CALL, ONLY P,Q,DX,DY PASSED, ! FIRST COLOR INDICES NOT PASSED TILL SECOND CALL) ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "NOT EMPTY" ! MDEMPT = GNEMPT ! ! TRANSFORM P AND Q CORNER POINTS TO VDC, GENERATE THE ! THE R CORNER POINT, STORE ALL IN MPXPY. ! MPXPY(1) = MXOFF+ int ( real (MXSCAL)*RX(1)) MPXPY(2) = MXOFF+ int ( real (MYSCAL)*RY(1)) MPXPY(3) = MYOFF+ int ( real (MXSCAL)*RX(2)) MPXPY(4) = MYOFF+ int ( real (MYSCAL)*RY(2)) MPXPY(5) = MPXPY(3) MPXPY(6) = MPXPY(2) ! ! SAVE DX, DY FOR SUBSEQUENT CALLS. ! DX = ID(1) DY = ID(2) ! ! COMPUTE TOTAL BYTE LENGTH -- ROWS MUST ALL START ON ! CGM WORD BOUNDARIES, INCLUDING THE FIRST ROW. ! ! BYTE COUNT FOR P,Q,R POINTS, DX,DY, LOCAL COLOR PRECISION, ! RUN-LENGTH/PACKED FLAG, ROUND TO NEAREST CGM METAFILE WORD. ! NBYTE1 = 1 + (6*MVDCFW + 2*MINTFW + MINTFW + MEFW -1)/8 NBYTE2 = NBYPCW*( 1 + (NBYTE1-1)/NBYPCW ) ! ! NUMBER OF BYTES TO HOLD A ROW OF COLOR INDEXES, ROUND TO ! CGM WORD BOUNDARY, COMPUTE PADDING BYTES PER ROW (IF ANY). ! NBPROW = 1 + (DX*MCIXFW-1)/8 ROWLEN = NBYPCW*( 1 + (NBPROW-1)/NBYPCW ) ROWPAD = ROWLEN - NBPROW ! ! TOTAL BYTE LENGTH OF CELL ARRAY ELEMENT. ! NBYTES = NBYTE2 + DY*ROWLEN ! ! PUT OUT OPCODE (CLASS AND ID) AND TOTAL LENGTH. ! call GPUTNI (CLCARY, IDCARY, NBYTES, RERR) ! ! PUT OUT P, Q, R POINTS. ! call GPUTPR (MPXPY, MVDCFW, 6, RERR) ! ! PUT OUT DX AND DY, LOCAL COLOR PRECISION, PACKED/RUN-LENGTH FLG. ! call GPUTPR (ID, MINTFW, 2, RERR) call GPUTPR (GDFCP, MINTFW, 1, RERR) call GPUTPR (GNORUN, MEFW, 1, RERR) ! ! PAD TO START OF FIRST ROW IF NECESSARY. ! if (NBYTE1 < NBYTE2) then do IX = 1, (NBYTE2-NBYTE1) call GPUTPR (GPAD, 8, 1, RERR) end do end if if ( RERR /= 0 ) then return end if ! ! INITIALIZE POINTER INTO CELL ARRAY AND POINTER INTO CURRENT ROW. ! CARPOS = 1 ROWPOS = 1 ! ! PROCESSING OF FIRST call IS COMPLETE ! end if ! ! TREAT THE CONTINUATION CALLS (THE COLOR INDEX ARRAY) ! if (KALL > 1) then ! ! INITIALIZE POINTER INTO CURRENT CHUNK OF CELL ARRAY. ! IDPOS = 1 20 continue ! ! NBR OF CELLS TO PUT OUT, TO END OF CURRENT ROW OR ! ALL CELLS REMAINING, WHICHEVER IS LESS. ! NCLOUT = MIN0 (DX-ROWPOS+1, IL2-IDPOS+1) call GPUTPR (ID(IDPOS), MCIXFW, NCLOUT, RERR) if (RERR /= 0) return ! ! UPDATE ROW POSITION, PAD TO CGM WORD BOUNDARY IF ! JUST COMPLETED A ROW (NEXT GPUTPR STARTS NEW ROW). ! ROWPOS = ROWPOS + NCLOUT if (ROWPOS > DX) ROWPOS = 1 if (ROWPAD > 0 .and. ROWPOS==1) then do IX = 1, ROWPAD call GPUTPR (GPAD, 8, 1, RERR) end do end if ! ! UPDATE POSITION IN INDEX ARRAY. ! IDPOS = IDPOS + NCLOUT ! ! GO BACK TO PROCESS NEXT ROW (OR PARTIAL ROW) IF MORE ! CELLS REMAIN THIS CALL. ! if (IDPOS <= IL2) go to 20 end if if (CONT==0) then KALL=0 end if return end subroutine G01CLP ! !******************************************************************************* ! !! G01CLP processes clipping parameters. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) ! integer NBYTES, I logical CHANGE ! ! IF CLIPPING INDICATOR HAS CHANGED, SEND IT AND STORE IT IN WSL. ! if (ID(1) /= MRCLIP) then MRCLIP = ID(1) ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH ! NBYTES = 1+(MEFW-1)/8 call GPUTNI (CLCLIN, IDCLIN, NBYTES, RERR) if (RERR /= 0) return ! ! PUT OUT CLIPPING INDICATOR PARAMETER. ! call GPUTPR (MRCLIP, MEFW, 1, RERR) if (RERR /= 0) return end if ! ! NORMALIZE CLIPPING RECTANGLE, SEND AND STORE IT IF CHANGED. ! ! NORMALIZE NDC LIMITS OF RECTANGLE (ASSUME BOUNDS CHECK ! ABOVE WSI), STORE AS RECTANGLE CORNER POINTS. ! ID(1) = MXOFF + MXSCAL*RX(1) ID(3) = MXOFF + MXSCAL*RX(2) ID(2) = MYOFF + MYSCAL*RY(1) ID(4) = MYOFF + MYSCAL*RY(2) CHANGE = .FALSE. do I = 1, 4 if (ID(I) /= MRCREC(I)) then CHANGE = .TRUE. MRCREC(I) = ID(I) end if end do if (CHANGE) then ! ! TOTAL BYTE LENGTH, BASED ON VDC BIT PRECISION. NBYTES = 1 + (4*MVDCFW-1)/8 ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH. ! CLASS, ID, LENGTH call GPUTNI (CLCREC, IDCREC, NBYTES, RERR) if (RERR /= 0) return ! ! PUT OUT CLIPPING RECTANGLE CORNER POINTS. ! DATA, PRECIS, COUNT call GPUTPR (MRCREC, MVDCFW, 4, RERR) end if return end subroutine G01CLW ! !******************************************************************************* ! !! G01CLW clears a workstation. ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer NBYTES, I integer ITMP(4) ! if (MDEMPT==GNEMPT .or. ID(2)==GALWAY) then ! ! PUT OUT END PICTURE ELEMENT. ! NBYTES = 0 call GPUTNI (CLENDP, IDENDP, NBYTES, RERR) ! ! FLUSH BUFFER ! call G01FLB (RERR) ! ! START NEW PICTURE. ! call G01SNP (RERR) if (RERR /= 0) go to 77 ! ! RESET ALL ATTRIBUTE DEFERRAL CONTROL VARIABLES ! call GUPDVA ! ! RESEND COLOR TABLE IF IT HAS BEEN EXPLICITLY CHANGED. ! if (MCTCHG == GYES) then NBYTES = 1 + (3*MDCCFW + MCIXFW - 1)/8 do I = 1, MOL ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH. CLASS, ID, LENGTH ! call GPUTNI (CLCTBL, IDCTBL, NBYTES, RERR) if (RERR /= 0) go to 77 ! ! PUT OUT PARAMETER INDEX. ! ! call GPUTPR (MCOLI(I), MCIXFW, 1, RERR) if (RERR /= 0) go to 77 ! ! PUT OUT 3 COLOR COMPONENTS. ! ITMP(1) = SRED(I)* real (MDCCRG) ITMP(2) = SGREEN(I)* real (MDCCRG) ITMP(3) = SBLUE(I)* real (MDCCRG) call GPUTPR (ITMP, MDCCFW, 3, RERR) end do end if ! ! PUT OUT CLIPPING INDICATOR AND RECTANGLE. ! SPECIFICATION IS CORNER POINT FORM. ! ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH (2-BYTE INTEGER). ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLCLIN, IDCLIN, NBYTES, RERR) if (RERR /= 0) go to 77 ! ! PUT OUT CLIPPING INDICATOR PARAMETER. ! call GPUTPR (MRCLIP, MIXFW, 1, RERR) if (RERR /= 0) go to 77 ! ! TOTAL BYTE LENGTH, BASED ON VDC BIT PRECISION. ! NBYTES = 1 + (4*MVDCFW-1)/8 ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH. ! CLASS, ID, LENGTH call GPUTNI (CLCREC, IDCREC, NBYTES, RERR) if (RERR /= 0) go to 77 ! ! PUT OUT CLIPPING RECTANGLE PARAMETERS (XMIN,XMAX,YMIN,YMAX). ! call GPUTPR (MRCREC, MVDCFW, 4, RERR) end if ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "EMPTY" ! MDEMPT = GEMPTY ! ! SET WSL ENTRY "NEW FRAME ACTION NECESSARY AT UPDATE" TO "NO" ! MNFRAM = GNO ! ! IF UPDATE STATE IS PENDING, SET CURRENT WINDOW AND VIEWPORT ! ENTRIES TO THOSE REQUESTED. ! if (MTUS == GPEND) then CWINDO(1) = RWINDO(1) CWINDO(2) = RWINDO(2) CWINDO(3) = RWINDO(3) CWINDO(4) = RWINDO(4) CWKVP(1) = RWKVP(1) CWKVP(2) = RWKVP(2) CWKVP(3) = RWKVP(3) CWKVP(4) = RWKVP(4) ! ! SET WORKSTATION UPDATE STATE TO "NOT PENDING" ! MTUS = GNPEND end if 77 continue return end subroutine G01CTB ! !******************************************************************************* ! !! G01CTB sets color REPRESENTATION (DEFINE COLOR TABLE ENTRY). ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer NCIX, NBYTES, I, IPTR ! ! SCAN COLOR TABLE TO SEE IF INDEX ALREADY EXISTS, ! FIND ITS POSITION IN TABLE OTHERWISE (BINARY SEARCH ! SHOULD BE USED HERE). ! NCIX = ID(2) do 10 I=1,MOL IPTR = I if (MCOLI(I)-NCIX) 10, 20, 15 10 continue ! ! FALL THRU MEANS INDEX NOT DEFINED YET, AND ITS ! HIGHER THAN THE HIGHEST DEFINED INDEX. ! IPTR = MOL + 1 ! ! INDEX UNDEFINED, BELONGS AT POSITION IPTR IN THE TABLE. ! TEST FOR ROOM IN THE TABLE, MOVE TABLE DOWN. ! 15 continue if (MOL >= MOLMAX) then ! ! ERROR; TABLE IS FULL, SET ERROR, MARK OVERFLOW, AND return. ! (WHICH ERROR IS APPLICABLE?) ! RERR = 86? RERR = 301 MCOVFL = 1 return else ! ! MOVE TABLE DOWN, INCREMENT COUNT OF DEFINED INDICES. ! do I=MOL,IPTR,-1 MCOLI(I+1) = MCOLI(I) SRED(I+1) = SRED(I) SGREEN(I+1) = SGREEN(I) SBLUE(I+1) = SBLUE(I) end do MOL = MOL + 1 end if ! ! INSERT/REPLACE NEW COLOR TABLE ENTRY. ! 20 continue MCOLI(IPTR) = NCIX SRED(IPTR) = RX(1) SGREEN(IPTR) = RX(2) SBLUE(IPTR) = RX(3) ! ! MARK CHANGE TO COLOR TABLE. MARK BACKGROUND COLOR ! CHANGE IF APPROPRIATE. ! MCTCHG = GYES if (NCIX==0) MBCCHG = GYES ! ! NORMALIZE REAL COMPONENTS TO INTEGER RANGE. ! ID(1) = RX(1)*MDCCRG ID(2) = RX(2)*MDCCRG ID(3) = RX(3)*MDCCRG ! ! GENERATE METAFILE INSTRUCTION WITH NEW ENTRY. ! ! COMPUTE INSTRUCTION PARAMETER LIST LENGTH -- NUMBER OF BYTES ! TO HOLD START INDEX + RED + GREEN + BLUE ! NBYTES = 1 + (3*MDCCFW + MCIXFW - 1)/8 ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH. ! call GPUTNI (CLCTBL, IDCTBL, NBYTES, RERR) if (RERR /= 0) return ! ! PUT OUT PARAMETER INDEX. ! call GPUTPR (NCIX, MCIXFW, 1, RERR) if (RERR /= 0) return ! ! PUT OUT 3 COLOR COMPONENTS. ! call GPUTPR (ID, MDCCFW, 3, RERR) return end subroutine G01D2R ! !******************************************************************************* ! !! G01D2R copies "default" ATTRIBUTE CONTEXT TO "REQUESTED" CONTEXT. ! ! (THERE IS NOW SUFFICIENT INFORMATION IN /G01ADC/ ! TO PUT A do LOOP STRUCTURE IN TO EFFECT THE COPY, ! USING THE EQUIVALENCING ARRAYS AND THE SIGN OF ! IP2AEA). ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF ! ! integer I ! ! POLYLINE ATTRIBUTES. MRPLIX = MDPLIX MRLTYP = MDLTYP ARLWSC = ADLWSC MRPLCI = MDPLCI ! ! POLYMARKER ATTRIBUTES. ! MRPMIX = MDPMIX MRMTYP = MDMTYP ARMSZS = ADMSZS MRPMCI = MDPMCI ! ! TEXT ATTRIBUTES. ! MRTXIX = MDTXIX MRTXP = MDTXP MRTXAL(1) = MDTXAL(1) MRTXAL(2) = MDTXAL(2) MRCHH = MDCHH MRCHOV(1:4) = MDCHOV(1:4) MRTXFO = MDTXFO MRTXPR = MDTXPR ARCHXP = ADCHXP ARCHSP = ADCHSP MRTXCI = MDTXCI ! ! FILL AREA ATTRIBUTES. ! MRFAIX = MDFAIX MRPASZ(1) = MDPASZ(1) MRPASZ(2) = MDPASZ(2) MRPARF(1) = MDPARF(1) MRPARF(2) = MDPARF(2) MRFAIS = MDFAIS MRFASI = MDFASI MRFACI = MDFACI ! ! ASPECT SOURCE FLAGS. ! MRASF(1:13) = MDASF(1:13) return end subroutine G01D2S ! !******************************************************************************* ! !! G01D2S copies "default" ATTRIBUTE CONTEXT TO "SET" CONTEXT. ! ! (THERE IS NOW SUFFICIENT INFORMATION IN /G01ADC/ ! TO PUT A do LOOP STRUCTURE IN TO EFFECT THE COPY, ! USING THE EQUIVALENCING ARRAYS AND THE SIGN OF ! IP2AEA). ! common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF ! integer I ! ! POLYLINE ATTRIBUTES. ! MSPLIX = MDPLIX MSLTYP = MDLTYP ASLWSC = ADLWSC MSPLCI = MDPLCI ! ! POLYMARKER ATTRIBUTES. ! MSPMIX = MDPMIX MSMTYP = MDMTYP ASMSZS = ADMSZS MSPMCI = MDPMCI ! ! TEXT ATTRIBUTES. ! MSTXIX = MDTXIX MSTXP = MDTXP MSTXAL(1) = MDTXAL(1) MSTXAL(2) = MDTXAL(2) MSCHH = MDCHH do I = 1, 4 MSCHOV(I) = MDCHOV(I) end do MSTXFO = MDTXFO MSTXPR = MDTXPR ASCHXP = ADCHXP ASCHSP = ADCHSP MSTXCI = MDTXCI ! ! FILL AREA ATTRIBUTES. ! MSFAIX = MDFAIX MSPASZ(1) = MDPASZ(1) MSPASZ(2) = MDPASZ(2) MSPARF(1) = MDPARF(1) MSPARF(2) = MDPARF(2) MSFAIS = MDFAIS MSFASI = MDFASI MSFACI = MDFACI ! ! ASPECT SOURCE FLAGS. ! MSASF(1:13) = MDASF(1:13) return end subroutine G01DIQ ! !******************************************************************************* ! !! G01DIQ is a WORKSTATION DESCRIPTION TABLE (WDT) INQUIRY. ! (OPCODE -100 THRU -199) ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WDT/ LWTYPE, LWKCAT, MVERSN integer LWTYPE, LWKCAT, MVERSN common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! integer ICODE ! ! ! ALL DEFINED WDT INQUIRY CODES LIE IN RANGE -11O THRU -128. ! ONLY -127 IS LEGAL FOR MO. THE REST ARE ERROR 31 OR 39, ! EXCEPT -125 AND -126, WHICH IS ARE UNDEFINED. SEE DESIGN ! SPEC OR INTERFACE SPEC FOR OPCODE DEFINITIONS. ! ! ICODE = abs (MCODES) - 109 ! ! CODE -110 -111 -112 -113 -114 -115 -116 -117 -118 -119 go to ( 39, 39, 39, 39, 31, 39, 39, 39, 39, 39, & 39, 39, 39, 39, 39, 5, 5, 127, 31 ) ICODE ! CODE -120 -121 -122 -123 -124 -125 -126 -127 -128 ! ! FALL THROUGH IS UNDEFINED OPCODE. ! 5 continue RERR = 320 return ! ! ERROR 31, "SPECIFIED WORKSTATION IS OF CATEGORY MO". ! 31 continue RERR = 31 return ! ! ERROR 39, "SPECIFIED WORKSTATION IS NEITHER OF CATEGORY OUTPUT ! NOR OF CATEGORY OUTIN". ! 39 continue RERR = 39 return ! ! INQUIRE WORKSTATION CATEGORY. ! 127 continue ID(2) = LWKCAT return end subroutine G01ESC ! !******************************************************************************* ! !! G01ESC processes ESCAPE SEQUENCES. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! integer KALL, NBYTES, LNTH SAVE KALL DATA KALL/0/ KALL = KALL+1 ! ! TREAT FIRST CALL, PUT OUT OPCODE, FCTID, AND FIRST DATA ! RECORD IF THERE IS ONE. ! if (KALL == 1) then ! ! PUT OUT OPCODE (CLASS AND ID) AND LENGTH. ! NBYTES = 1+(2*MVDCFW-1)/8+STRL1 call GPUTNI (6, 1, NBYTES, RERR) if (RERR /= 0) return ! ! PUT OUT FUNCTION IDENTIFIER (2-BYTE INTEGER). ! call GPUTPR (ID(1), MVDCFW, 1, RERR) if (RERR /= 0) return ! ! PUT OUT LENGTH OF DATA RECORD. ! LNTH = 80*ID(2) call GPUTPR (LNTH , MVDCFW, 1, RERR) if (RERR /= 0) return ! ! PUT OUT FIRST DATA RECORD IF THERE IS ONE ! if (ID(2) > 0) then call GPUTPS (STR, 80, 80, 1, RERR) if (RERR /= 0) return end if ! ! IF THERE IS TO BE NO CONTINUATION, CHECK FOR CONSISTENCY, AND ! RESET THE PARAMETER "KALL". ! if (CONT == 0) then if (ID(2) <= 1) then KALL = 0 return else RERR = 325 return end if end if end if ! ! TREAT THE CONTINUATION CALLS ! if (KALL > 1) then if (CONT == 0) then call GPUTPS (STR, 80, 80, 1, RERR) if (RERR /= 0) return if (KALL /= ID(2)) then RERR = 325 return end if KALL = 0 else call GPUTPS (STR, 80, 80, 1, RERR) if (RERR /= 0) return end if end if return end subroutine G01FA ! !******************************************************************************* ! !! G01FA processes GKS fill area INSTRUCTION, SEND CGM POLYGON. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer KALL, IPRIM, NBYTES, INDX1, INDX2, IX SAVE KALL ! DATA KALL/0/, IPRIM/4/ ! KALL = KALL+1 IF (KALL == 1) then ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "NOT EMPTY". ! MDEMPT = GNO ! ! PROCESS PENDING ATTRIBUTES. ! if (AGPEND(IPRIM)) then ! ! SOME CHANGES ARE PENDING. ! if (VALCHG(IVFAIX)) then ! ! GKS FILL AREA INDEX, SEND CGM FILL BUNDLE INDEX. ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLFBIX, IDFBIX, NBYTES, RERR) call GPUTPR (MRFAIX, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSFAIX = MRFAIX VALCHG(IVFAIX) = .FALSE. end if if (VALCHG(IVFAIS)) then ! ! GKS FILL AREA INTERIOR STYLE, SEND CGM INTERIOR STYLE. ! NBYTES = 1+(MEFW-1)/8 call GPUTNI (CLINTS, IDINTS, NBYTES, RERR) call GPUTPR (MRFAIS, MEFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSFAIS = MRFAIS VALCHG(IVFAIS) = .FALSE. end if if (VALCHG(IVFASI)) then ! ! GKS FILL AREA STYLE INDEX, SEND BOTH CGM PATTERN ! INDEX AND HATCH INDEX. ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLHAIX, IDHAIX, NBYTES, RERR) call GPUTPR (MRFASI, MIXFW, 1, RERR) call GPUTNI (CLPTIX, IDPTIX, NBYTES, RERR) call GPUTPR (MRFASI, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSFASI = MRFASI VALCHG(IVFASI) = .FALSE. end if if (VALCHG(IVFACI)) then ! ! GKS FILL AREA COLOR INDEX, SEND CGM FILL COLOR. ! NBYTES = 1+(MCIXFW-1)/8 call GPUTNI (CLFCLR, IDFCLR, NBYTES, RERR) call GPUTPR (MRFACI, MCIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSFACI = MRFACI VALCHG(IVFACI) = .FALSE. end if if (VALCHG(IVPASZ)) then ! ! GKS PATTERN SIZE, SEND CGM PATTERN SIZE VECTORS. ! NBYTES = 1+(4*MVDCFW-1)/8 call GPUTNI (CLPTSZ, IDPTSZ, NBYTES, RERR) call GPUTPR (MRPASZ(1) , MVDCFW, 4, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! do IX = 1, 4 MSPASZ(IX) = MRPASZ(IX) end do VALCHG(IVPASZ) = .FALSE. end if if (VALCHG(IVPARF)) then ! ! GKS PATTERN REFERENCE POINT, SEND CGM FILL REFERENCE POINT. ! NBYTES = 1+(2*MVDCFW-1)/8 call GPUTNI (CLFRPT, IDFRPT, NBYTES, RERR) call GPUTPR (MRPARF(1), MVDCFW, 2, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSPARF(1) = MRPARF(1) MSPARF(2) = MRPARF(2) VALCHG(IVPARF) = .FALSE. end if if (ANYASF) then ! ! SOME GKS ASF HAS CHANGED, SEND CGM ASFS. ! call G01SAS (IPRIM, RERR) if (RERR /= 0) return end if ! ! CLEAR AGGREGATE CHANGE VARIABLE. ! AGPEND(IPRIM) = .FALSE. end if ! ! TREAT FIRST CALL, PUT OUT OPCODE, AND POINTS ! PUT OUT OPCODE (CLASS AND ID) AND TOTAL LENGTH. ! NBYTES = 1+(2*RL1*MVDCFW-1)/8 call GPUTNI (CLPGON, IDPGON, NBYTES, RERR) if (RERR /= 0 ) return ! ! PUT OUT FIRST POINTS ARRAY ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do IX = 1, RL2 INDX1 = 2*IX-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF+ int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(IX))))) MPXPY(INDX2) = MYOFF+ int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(IX))))) end do ! ! SEND OUT POINTS ! call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return ! ! IF THERE IS TO BE NO CONTINUATION, RESET THE PARAMETER "KALL". ! if (CONT == 0) then KALL = 0 return end if end if ! ! TREAT THE CONTINUATION CALLS ! if (KALL > 1) then ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do IX = 1, RL2 INDX1 = 2*IX-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF+ int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(IX))))) MPXPY(INDX2) = MYOFF+ int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(IX))))) end do if (CONT == 0) then call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return KALL = 0 else call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return end if end if return end subroutine G01FLB ( GKSERR ) ! !******************************************************************************* ! !! G01FLB writes the metafile RECORD OUT TO THE DISK. ! ! ! Parameters: ! ! Output, integer GKSERR, THE ERROR STATUS FLAG ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) ! common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! DIMENSION FLAGS(12) ! ! INITIALIZE FLAGS ARRAY ! DATA FLAGS( 1),FLAGS( 2),FLAGS( 3),FLAGS( 4)/0,0,0,0/ DATA FLAGS( 5),FLAGS( 6),FLAGS( 7),FLAGS( 8)/0,0,0,0/ DATA FLAGS( 9),FLAGS(10),FLAGS(11),FLAGS(12)/0,0,0,0/ ! ! DEFINE THE ALL OK STATUS, BUFFER RESET POINT, BUFFER write ERROR, ! CLEAR THE NEW FRAME FLAG ! DATA ALLOK,BFREST,WRIERR,CLEAR/0,32,304,0/ ! ! SET THE BIT LENGTH FOR ID ID PART OF A RECORD, THE NUMBER OF BITS PER ! BYTE, THE FIELD SIZE FOR THE RECORD BIT START FOR THE RECORD BYTE ! LENGTH AND THE FIELD SIZE FOR THE RECORD BYTE LENGTH ! DATA IDLEN,BYTSIZ,SIZST,SIZSZ/32,8,0,16/ ! ! SET THE DATA TYPE START BIT IN RECORD, THE DATA TYPE LENGTH , ! THE NEW FRAME BIT START BIT, THE NEW FRAME LENGTH ! DATA MDTST,MDTSZ,MNFST,MNFSZ/16,4,20,1/ ! ! ENTER THE BYTE COUNT ! BCOUNT = (MBFPOS - IDLEN) / BYTSIZ ! ! return IF NOTHING IN BUFFER ! if (BCOUNT <= 0) return call SBYTES(MOUTBF,BCOUNT,SIZST,SIZSZ,0,1) ! ! ENTER THE DATA TYPE ID ! call SBYTES(MOUTBF,MDTYPE,MDTST,MDTSZ,0,1) ! ! PUT AWAY NEW FRAME, BEGIN METAFILE, AND END METAFILE BITS, ! AND THEN CLEAR THEM. ! FLAGS(1) = MNFFLG FLAGS(2) = MBMFLG FLAGS(3) = MEMFLG call SBYTES(MOUTBF,FLAGS,MNFST,MNFSZ,0,12) MNFFLG = CLEAR MBMFLG = CLEAR MEMFLG = CLEAR ! ! write OUT THE RECORD ! call G01MIO (3, MFGLUN, MOUTBF, MOBFSZ, GKSERR) MRECNM = MRECNM + 1 ! ! RESET THE RECORD POINTER ! MBFPOS = BFREST ! return ! ! ERROR WRITING THE METAFILE RECORD ! 1000 continue GKSERR = WRIERR return end subroutine G01IAC ! !******************************************************************************* ! !! G01IAC initializes the ATTRIBUTE CONTEXT, AS AT OPEN WORKSTATION. ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! integer IX ! ! COMPUTE LENGTH OF EACH ATTRIBUTE, BASED ON POINTERS. ! do IX = 1, 25 IL2AEA(IX) = abs (IP2AEA(IX+1)) - abs (IP2AEA(IX)) end do ! ! COPY DEFAULT ATTRIBUTE CONTEXT TO "SET" CONTEXT. ! call G01D2S ! ! COPY DEFAULT ATTRIBUTE CONTEXT TO "REQUESTED" CONTEXT. ! call G01D2R ! ! INITIALIZE ATTRIBUTE DEFERRAL SCHEME. ! ! logical CHANGE VARIABLE FOR EACH PRIMITIVE. ! do IX=1,4 AGPEND(IX) = .FALSE. end do ! ! VALUE CHANGE VARIABLES FOR EACH ATTRIBUTE. ! do IX=1,24 VALCHG(IX) = .FALSE. end do ! ! AGGREGATE ASF VALUE CHANGE VARIABLE. ! ANYASF = .FALSE. ! ! VALUE CHANGE VARIABLES FOR EACH ASF. ! ASFCHG(1:13) = .FALSE. return end subroutine G01IWS ! !******************************************************************************* ! !! G01IWS initializes constants. ! ! ! INITIALIZE WORKSTATION STATE LIST AND OTHER INTERNAL CONSTANTS ! AS REQUIRED UPON OPEN WORKSTATION. ! common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! ! INTERNAL CONSTANTS. ! ! MIN AND MAX VDC ADDRESS LIMITS IN X AND Y DIRECTIONS, ! THE VDC EXTENT. ! MINXVD = 0 MAXXVD = 32767 MINYVD = 0 MAXYVD = 32767 ! ! NDC TO VDC MAPPING COEFFICIENTS, X AND Y DIRECTIONS. ! MXOFF = 0 MXSCAL = 32767 MYOFF = 0 MYSCAL = 32767 ! ! COLOR TABLE CHANGE, BACKGROUND COLOR CHANGE. ! MCTCHG = GNO MBCCHG = GNO ! ! WSL ITEMS. ! ! STATE IS INACTIVE (0=GINACT) MSTATE = GINACT ! ! DEFERRAL MODE IS ASTI (3=GASTI) MDEFMO = 3 ! ! IMPLICIT REGENERATION MODE IS ALLOWED (1=GALLOW) MREGMO = 1 ! ! DISPLAY SURFACE IS EMPTY (1=GEMPTY) MDEMPT = GEMPTY ! ! NEW FRAME NECESSARY AT UPDATE IS NO (0=GNO) MNFRAM = GNO ! ! WORKSTATION TRANSFORMATION UPDATE STATE IS NOTPENDING (0=GNPEND) MTUS = GNPEND ! ! REQUESTED WORKSTATION WINDOW IN NDC IS UNIT SQUARE RWINDO(1) = 0.0 RWINDO(2) = 1.0 RWINDO(3) = 0.0 RWINDO(4) = 1.0 ! ! CURRENT WORKSTATION WINDOW IN NDC IS UNIT SQUARE. ! CWINDO(1) = 0.0 CWINDO(2) = 1.0 CWINDO(3) = 0.0 CWINDO(4) = 1.0 ! ! REQUESTED WORKSTATION VIEWPORT IS REAL METACODE ADDRESS SPACE ! RWKVP(1) = 0. RWKVP(2) = 32767. RWKVP(3) = 0. RWKVP(4) = 32767. ! ! CURRENT WORKSTATION VIEWPORT IS METACODE ADDRESS SPACE. CWKVP(1) = 0. CWKVP(2) = 32767. CWKVP(3) = 0. CWKVP(4) = 32767. ! ! COLOR INDICES ARE SORTED BY DEFAULT. MCSORT = 1 ! ! NUMBER OF CURRENTLY DEFINED COLOR INDICES IS 2. MOL = 2 ! ! OVERFLOW FLAG FOR COLOR INDEX ARRAYS IS NO (0=GNO). MCOVFL = GNO ! ! COLOR INDEX VALUES WHICH ARE DEFINED (0=BACKGROUND,1=FOREGROUND) MCOLI(1) = 0 MCOLI(2) = 1 ! ! RGB VALUES FOR INDEXES 0 AND 1 (HIGHLY PHONEY FOR MO). SRED(1) = 0.0 SGREEN(1) = 0.0 SBLUE(1) = 0.0 SRED(2) = 0.8 SGREEN(2) = 0.8 SBLUE(2) = 0.8 ! ! WSL CLIPPING CONTROL PARAMETERS. ! ! CLIPPING INDICATOR IS OFF (0=GNCLIP) MRCLIP = GNCLIP ! ! CLIPPING RECTANGLE IS METACODE ADDRESS SPACE, CORNER-PT FORM. MRCREC(1) = MINXVD MRCREC(2) = MINYVD MRCREC(3) = MAXXVD MRCREC(4) = MAXYVD return end subroutine G01MIO (OP, UNIT, BUFFER, LENGTH, ERROR) ! !******************************************************************************* ! !! G01MIO gets environmental metafile names, and can fork a translator. ! ! * provides for specification of metafile names through environment variables. ! ! * provides for forking a translator and feed metacode directly to it. ! ! Don Middleton - NCAR Graphics Group - Sprint 1988 ! ! CENTRAL I/O ROUTINE FOR METAFILE GENERATOR. ! ! INPUT PARAMETERS ! OP - OPERATION, ! =1, OPEN WORKSTATION FOR OUTPUT ON abs (UNIT). ! =2, CLOSE WORKSTATION FOR OUTPUT ON abs (UNIT). ! =3, write BUFFER TO abs (UNIT). ! UNIT - abs (UNIT) IS THE FORTRAN LUN ON WHICH OP IS ! TO OCCUR. ! BUFFER - BUFFER CONTAINING DATA FOR A write OPERATION. ! LENGTH - LENGTH OF DATA IN BUFFER. ! ! OUTPUT PARAMETERS ! ERROR - ERROR INDICATOR, =0 IF NO ERRORS. ! ! ! subroutine ARGUMENTS. ! integer OP, UNIT, LENGTH, BUFFER(LENGTH), ERROR ! ! common BLOCKS. ! common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! integer iaunt ! error = 0 iaunt = iabs(unit) if ( op == 1 ) then call opnwks ( iaunt, error ) else if ( op == 2 ) then call clswks ( iaunt, error ) else if ( op == 3 ) then call wrtwks ( iaunt, buffer, error ) end if return end subroutine G01PAT ! !******************************************************************************* ! !! G01PAT processes PRIMITIVE ATTRIBUTES. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! real UP, BASE, DMAX, FACTOR ! go to (210, 220, 230, 240, & 250, 260, 270, 280, & 290, 300, 310, 320, 330, 340, 350, 360, & 370, 380, 390, 400, 410, 420, 430) MCODES-20 ! ! ! GKS POLYLINE INDEX. ! 210 continue call GUPDVI (ID(1), IVPLIX, 1) return ! ! GKS LINETYPE. ! 220 continue call GUPDVI (ID, IVLTYP, 1) ! ! GKS LINEWIDTH SCALE FACTOR. ! 230 continue call GUPDVR (RX, IVLWSC, 1) return ! ! GKS POLYLINE COLOR INDEX. ! 240 continue call GUPDVI (ID, IVPLCI, 1) return ! ! GKS POLYMARKER INDEX. ! 250 continue call GUPDVI (ID, IVPMIX, 2) return ! ! MARKER TYPE. ! 260 continue call GUPDVI (ID, IVMTYP, 2) return ! ! MARKER SIZE SCALE FACTOR. ! 270 continue call GUPDVR (RX, IVMSZS, 2) return ! ! GKS POLYMARKER COLOR INDEX. ! 280 continue call GUPDVI (ID, IVPMCI, 2) return ! ! TEXT INDEX. ! 290 continue call GUPDVI (ID, IVTXIX, 3) return ! ! TEXT FONT AND PRECISION. ! 300 continue ! ! FONT. call GUPDVI (ID, IVTXFO, 3) ! ! PRECISION. call GUPDVI (ID(2), IVTXPR, 3) return ! ! character EXPANSION FACTOR. ! 310 continue call GUPDVR (RX, IVCHXP, 3) return ! ! character SPACING. ! 320 continue call GUPDVR (RX, IVCHSP, 3) return ! ! TEXT COLOR INDEX. ! 330 continue call GUPDVI (ID, IVTXCI, 3) return ! ! character ORIENTATION VECTORS. ! 340 continue ! ! EXTRACT AND PROCESS HEIGHT. UP = SQRT (RX(1)**2+RY(1)**2) BASE = SQRT (RX(2)**2+RY(2)**2) DMAX = max (UP,BASE) if (DMAX > 1.0) then ! ! A VECTOR IS LONGER THAN 1.0 NDC, ! SCALE DOWN BOTH VECTORS EQUALLY. ! FACTOR = 1.0/DMAX RX(1) = FACTOR*RX(1) RY(1) = FACTOR*RY(1) RX(2) = FACTOR*RX(2) RY(2) = FACTOR*RY(2) end if ! ! FIX HEIGHT AND PROCESS IT. RTMP = 0.5+UP*REAL(MYSCAL) ID(1) = MAXYVD if (RTMP < REAL(MAXYVD)) ID(1) = INT(RTMP) call GUPDVI (ID, IVCHH, 3) ! ! CONVERT NDC VECTORS TO VDC AND PROCESS. ID(1) = MIN0 (MAXYVD, IFIX (0.5 + MXSCAL*RX(1))) ID(2) = MIN0 (MAXYVD, IFIX (0.5 + MYSCAL*RY(1))) ID(3) = MIN0 (MAXYVD, IFIX (0.5 + MXSCAL*RX(2))) ID(4) = MIN0 (MAXYVD, IFIX (0.5 + MYSCAL*RY(2))) call GUPDVI (ID, IVCHOV, 3) return ! ! TEXT PATH. ! 350 continue call GUPDVI (ID, IVTXP, 3) return ! ! TEXT ALIGNMENT. ! 360 continue call GUPDVI (ID, IVTXAL, 3) return ! ! GKS FILL AREA INDEX. ! 370 continue call GUPDVI (ID, IVFAIX, 4) return ! ! GKS FILL AREA INTERIOR STYLE. ! 380 continue call GUPDVI (ID, IVFAIS, 4) return ! ! GKS FILL AREA STYLE INDEX. ! 390 continue call GUPDVI (ID, IVFASI, 4) return ! ! GKS FILL AREA COLOR INDEX. ! 400 continue call GUPDVI (ID, IVFACI, 4) return ! ! GKS PATTERN SIZE. ! 410 continue ! ! TRUNCATE DX,DY TO LIMITS OF NDC UNIT SQUARE, ! CONVERT TO VDC, STORE AS HEIGHT AND WIDTH VECTORS. ID(4) = 0 ID(3) = int ( real (MXSCAL)*( max (0.0, min (1.0,RX(1))))) ID(2) = int ( real (MYSCAL)*( max (0.0, min (1.0,RY(1))))) ID(1) = 0 call GUPDVI (ID, IVPASZ, 4) return ! ! GKS PATTERN REFERENCE POINT. ! 420 continue ! ! TRUNCATE X,Y TO LIMITS OF NDC UNIT SQUARE, ! CONVERT TO VDC. ID(1) = int ( real (MXSCAL)*( max (0.0, min (1.0,RX(1))))) ID(2) = int ( real (MYSCAL)*( max (0.0, min (1.0,RX(2))))) call GUPDVI (ID, IVPARF, 4) return ! ! GKS ASPECT SOURCE FLAGS. ! 430 continue call GUPASF return ! ! ! 700 continue return end function G01PBL (NCHARS, NBYTES) ! !******************************************************************************* ! !! G01PBL returns the parameter list length of an element that contains NCHARS ! characters of string data and NBYTES bytes of other data. ! ! The length will be either NCHARS+NBYTES+1 or NCHARS+NBYTES+3, ! depending upon whether a short form or long form string is ! called for. ! integer g01pbl integer NCHARS, NBYTES, LEN ! ! FOR SHORT FORM. ! LEN = 1 + NCHARS + NBYTES ! ! SHORT FORM CAN HANDLE AT MOST 254 characterS IN STRING. ! if (NCHARS > 254) LEN = LEN + 2 ! G01PBL = LEN return end subroutine G01PL ! !******************************************************************************* ! !! G01PL processes the POLYLINE INSTRUCTION ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer KALL, IPRIM, NBYTES, NUMO, K, INDX1, INDX2 DIMENSION NUMO(2) SAVE KALL ! ! DATA KALL/0/ , IPRIM/1/ ! KALL = KALL+1 IF (KALL == 1) then ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "NOT EMPTY" ! MDEMPT = GNEMPT ! ! PROCESS PENDING ATTRIBUTES. ! if (AGPEND(IPRIM)) then ! ! SOME CHANGES ARE PENDING. ! if (VALCHG(IVPLIX)) then ! ! SEND BUNDLE INDEX ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLLBIX, IDLBIX, NBYTES, RERR) call GPUTPR (MRPLIX, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSPLIX = MRPLIX VALCHG(IVPLIX) = .FALSE. end if if (VALCHG(IVLTYP)) then ! ! SEND LINETYPE ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLLTYP, IDLTYP, NBYTES, RERR) call GPUTPR (MRLTYP, MIXFW, 1, RERR) if (RERR /= 0) return MSLTYP = MRLTYP VALCHG(IVLTYP) = .FALSE. end if if (VALCHG(IVLWSC)) then ! ! LINEWIDTH SCALE FACTOR ! NBYTES = 1+(2*MCFPP-1)/8 call GPUTNI (CLLWID, IDLWID, NBYTES, RERR) call GFLCNV (ARLWSC,NUMO) call GPUTPR (NUMO, MCFPP, 2, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! ASLWSC = ARLWSC VALCHG(IVLWSC) = .FALSE. end if if (VALCHG(IVPLCI)) then ! ! LINE COLOR INDEX. ! NBYTES = 1+(MCIXFW-1)/8 call GPUTNI (CLLCLR, IDLCLR, NBYTES, RERR) call GPUTPR (MRPLCI, MCIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSPLCI = MRPLCI VALCHG(IVPLCI) = .FALSE. end if if (ANYASF) then ! ! SOME ASF HAS CHANGED. ! call G01SAS (IPRIM, RERR) if (RERR /= 0) return end if ! ! CLEAR AGGREGATE CHANGE VARIABLE. ! AGPEND(IPRIM) = .FALSE. end if ! ! TREAT FIRST CALL, PUT OUT OPCODE, AND POINTS ! ! PUT OUT OPCODE (CLASS AND ID) AND TOTAL LENGTH. ! NBYTES = 1+(2*RL1*MVDCFW-1)/8 call GPUTNI (CLPLIN, IDPLIN, NBYTES, RERR) if (RERR /= 0) return ! ! PUT OUT FIRST POINTS ARRAY ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do K = 1, RL2 INDX1 = 2*K-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF + int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(K))))) MPXPY(INDX2) = MYOFF + int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(K))))) end do ! ! SEND OUT POINTS ! call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return ! ! IF THERE IS TO BE NO CONTINUATION, RESET THE PARAMETER "KALL". ! if (CONT == 0) then KALL = 0 return end if end if ! ! TREAT THE CONTINUATION CALLS ! if ( KALL > 1 ) then ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do K = 1, RL2 INDX1 = 2*K-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF + int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(K))))) MPXPY(INDX2) = MYOFF + int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(K))))) end do if (CONT == 0) then call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return KALL = 0 else call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return end if end if return end subroutine G01PM ! !******************************************************************************* ! !! G01PM PROCESS POLYMARKER INSTRUCTION ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer KALL, IPRIM, NBYTES, NUMO, K, INDX1, INDX2 DIMENSION NUMO(2) SAVE KALL DATA KALL/0/ , IPRIM/2/ ! KALL = KALL+1 IF (KALL == 1) then ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "NOT EMPTY" ! MDEMPT = GNEMPT ! ! PROCESS PENDING ATTRIBUTES. ! if (AGPEND(IPRIM)) then ! ! SOME CHANGES ARE PENDING. ! if (VALCHG(IVPLIX)) then ! ! SEND BUNDLE INDEX ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLMBIX, IDMBIX, NBYTES, RERR) call GPUTPR (MRPMIX, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED. CLEAR CHANGE FLAG. ! MSPMIX = MRPMIX VALCHG(IVPMIX) = .FALSE. end if if (VALCHG(IVMTYP)) then ! ! MARKER TYPE ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLMTYP, IDMTYP, NBYTES, RERR) call GPUTPR (MRMTYP, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED. CLEAR CHANGE FLAG. ! MSMTYP = MRMTYP VALCHG(IVMTYP) = .FALSE. end if if (VALCHG(IVMSZS)) then ! ! MARKER SIZE ! NBYTES = 1+(2*MCFPP-1)/8 call GPUTNI (CLMSIZ, IDMSIZ, NBYTES, RERR) call GFLCNV (ARMSZS,NUMO) call GPUTPR (NUMO, MCFPP, 2, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED. CLEAR CHANGE FLAG. ! ASMSZS = ARMSZS VALCHG(IVMSZS) = .FALSE. end if if (VALCHG(IVPMCI)) then ! ! MARKER COLOR ! NBYTES = 1+(MCIXFW-1)/8 call GPUTNI (CLMCLR, IDMCLR, NBYTES, RERR) call GPUTPR (MRPMCI, MCIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED. CLEAR CHANGE FLAG. ! MSPMCI = MRPMCI VALCHG(IVPMCI) = .FALSE. end if if (ANYASF) then ! ! SOME ASF HAS CHANGED. ! call G01SAS (IPRIM, RERR) if (RERR /= 0) return end if ! ! CLEAR AGGREGATE CHANGE VARIABLE. ! AGPEND(IPRIM) = .FALSE. ! end if ! ! TREAT FIRST CALL, PUT OUT OPCODE, AND POINTS ! ! ! PUT OUT OPCODE (CLASS AND ID) AND TOTAL LENGTH. ! NBYTES = 1+(2*RL1*MVDCFW-1)/8 call GPUTNI (CLPMRK, IDPMRK, NBYTES, RERR) ! ! PUT OUT FIRST POINTS ARRAY ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do K = 1, RL2 INDX1 = 2*K-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF + int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(K))))) MPXPY(INDX2) = MYOFF + int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(K))))) end do ! ! SEND OUT POINTS ! call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return ! ! IF THERE IS TO BE NO CONTINUATION, RESET THE PARAMETER "KALL". ! if (CONT == 0) then KALL = 0 return end if end if ! ! TREAT THE CONTINUATION CALLS ! if (KALL > 1) then ! ! TRUNCATE POINTS TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! do K = 1, RL2 INDX1 = 2*K-1 INDX2 = INDX1+1 MPXPY(INDX1) = MXOFF + int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(K))))) MPXPY(INDX2) = MYOFF + int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(K))))) end do if (CONT == 0) then call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return KALL = 0 else call GPUTPR (MPXPY, MVDCFW, 2*RL2, RERR) if (RERR /= 0) return end if end if return end subroutine G01SAS (IPRIM, RERR) ! !******************************************************************************* ! !! G01SAS sends ASPECT SOURCE FLAGS (TO THE METAFILE). ! integer IPRIM, RERR ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) ! integer IX, MIX, NCHANG, ASPAIR(2), NBYTES ! ! COUNT THE NUMBER OF CHANGED (CGM) ASFS FIRST. ! NCHANG = 0 do IX = 1, NCGASF ! GET INDEX OF ASSOCIATED GKS ASF. MIX = MASMAP(IX) if (MIX > 0) then if (ASFCHG(MIX)) NCHANG = NCHANG + 1 end if end do if (NCHANG==0) go to 30 ! ! COMPUTE BYTE LENGTH OF INSTRUCTION, PUT OUT OPCODE/LENGTH. ! NBYTES = 1 + (NCHANG*2*MEFW-1)/8 call GPUTNI (CLASFS, IDASFS, NBYTES, RERR) if (RERR /= 0) go to 777 ! ! PUT OUT EACH CHANGED ASF. ! do IX = 1, NCGASF MIX = MASMAP(IX) if (MIX > 0) then if (ASFCHG(MIX)) then ! ! FORM INDEX/VALUE PAIR FOR CHANGED ASF, SEND IT. ! ASPAIR(1) = IX - 1 ASPAIR(2) = MRASF(MIX) call GPUTPR (ASPAIR, MEFW, 2, RERR) if (RERR /= 0) return ! ! COPY REQUESTED (GKS) ASF TO SENT, CLEAR CHANGE FLAG. ! MSASF(MIX) = MRASF(MIX) ASFCHG(MIX) = .FALSE. end if end if end do ! ! CLEAR AGGREGATE ASF CHANGE INDICATOR. ! 30 continue ANYASF = .FALSE. ! 777 continue return ! end subroutine G01SIQ ! !******************************************************************************* ! !! G01SIQ WORKSTATION STATE LIST (WSL) INQUIRY. ! (OPCODE -200 THRU -299) ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! integer INDX, IPTR, I, NCI ! ! ! CODE -200 -201 -202 go to (200, 201, 202) -199-MCODES ! ! CODE -226 if (MCODES == -226) go to 226 ! ! CODE -256 -257 go to (256, 257) -255-MCODES ! ! CODE -290 -291 -292 -293 go to ( 39, 39, 39, 39) -289-MCODES ! ! FALL THROUGH MEANS UNDEFINED OPCODE. ! 5 continue RERR = 320 return ! ! ERROR 39, "SPECIFIED WORKSTATION IS NEITHER OF CATEGORY OUTPUT ! NOR OF CATEGORY OUTIN". ! 39 continue RERR = 39 return ! ! INQUIRE WORKSTATION DEFERRAL AND UPDATE STATE. ! 200 continue ID(2) = MDEFMO ID(3) = MREGMO ID(4) = MDEMPT ID(5) = MNFRAM return ! ! INQUIRE WORKSTATION STATE. ! 201 continue ID(2) = MSTATE return ! ! INQUIRE WORKSTATION TRANSFORMATION. ! 202 continue ID(2) = MTUS RX(1) = RWINDO(1) RX(2) = RWINDO(2) RX(3) = RWINDO(3) RX(4) = RWINDO(4) RX(5) = CWINDO(1) RX(6) = CWINDO(2) RX(7) = CWINDO(3) RX(8) = CWINDO(4) RY(1) = RWKVP(1) RY(2) = RWKVP(2) RY(3) = RWKVP(3) RY(4) = RWKVP(4) RY(5) = CWKVP(1) RY(6) = CWKVP(2) RY(7) = CWKVP(3) RY(8) = CWKVP(4) return ! ! INQUIRE WORKSTATION CONNECTION AND TYPE. ! 226 continue ID(2) = MCONID ID(3) = MWTYPE return ! ! INQUIRE COLOR REPRESENTATION. ! 256 continue ! ! SEARCH FOR INDEX IN INDEX LIST. ! INDX = ID(2) IPTR = 0 do I = 1, MOL if (INDX==MCOLI(I)) then IPTR = I go to 2562 end if end do 2562 continue if (IPTR /= 0) then ! ! INDEX WAS FOUND, COPY COLOR COMPONENTS. RX(1) = SRED(IPTR) RX(2) = SGREEN(IPTR) RX(3) = SBLUE(IPTR) else ! ! INDEX NOT FOUND, return ERROR 87. ! RERR = 87 end if return ! ! INQUIRE LIST ELEMENT OF COLOR INDICES. ! 257 continue ! ! return THE COUNT BEFORE CHECKING FOR THE ERROR CONDITION ! (INDEX HAS NOT BEEN DEFINED). ! ID(3) = MOL ! ! CHECK THAT INDEX IS DEFINED. ! NCI = ID(2) if (NCI > MOL) then ! ! UNDEFINED. RERR = 502 else ! ! DEFINED. ID(4) = MCOLI(NCI) end if return end subroutine G01SNP (ERROR) ! !******************************************************************************* ! !! G01SNP starts a new picture. ! integer ERROR ! integer G01PBL, HOLD(3), NBYTES character*1 NULSTR ! common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! ! INCREMENT FRAME (PICTURE COUNT), SET 'NEW FRAME' FLAG. ! MCFRM = MCFRM + 1 MNFFLG = GYES ! ! PUT OUT 'BEGIN PICTURE' ELEMENT, NULL ID STRING. ! call GPUTNI (CLBEGP, IDBEGP, G01PBL(0,0), ERROR) call GPUTPS (NULSTR, 0, 0, 0, ERROR) if (ERROR /= 0) go to 77 ! ! PUT OUT PICTURE DESCRIPTOR. ! ! PUT OUT BACKGROUND COLOR, CONDITIONALLY DEPENDING UPON ! WHETHER IT HAS BEEN EXPLICITLY CHANGED. ! if (MBCCHG == GYES) then NBYTES = 1 + (3*MDCCFW-1)/8 call GPUTNI (CLBKGC, IDBKGC, NBYTES, ERROR) HOLD(1) = SRED(1)*MDCCRG HOLD(2) = SGREEN(1)*MDCCRG HOLD(3) = SBLUE(1)*MDCCRG call GPUTPR (HOLD, MDCCFW, 3, ERROR) if (ERROR /= 0) go to 77 end if ! ! PUT OUT 'BEGIN PICTURE BODY' ELEMENT. ! call GPUTNI (CLBGPB, IDBGPB, 0, ERROR) if (ERROR /= 0) go to 77 ! 77 continue return end subroutine G01TX ! !******************************************************************************* ! !! G01TX processes TEXT INSTRUCTION. ! ! ** WARNING: CONTINUATION IS NOT HANDLED PROPERLY ** ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer NUMO(2), KALL, IPRIM, NBYTES integer GFINAL, G01PBL SAVE KALL ! ! DATA KALL/0/, IPRIM/3/, GFINAL/0/ ! KALL = KALL+1 IF (KALL==1) then ! ! FIRST call OF TEXT ELEMENT. ! ! SET WSL ENTRY "DISPLAY SURFACE EMPTY" TO "NOT EMPTY" ! MDEMPT = GNEMPT ! ! PROCESS PENDING ATTRIBUTES. ! if (AGPEND(IPRIM)) then ! ! SOME CHANGES ARE PENDING. ! if (VALCHG(IVTXIX)) then ! ! GKS TEXT INDEX, SEND CGM TEXT BUNDLE INDEX. ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLTBIX, IDTBIX, NBYTES, RERR) call GPUTPR (MRTXIX, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXIX = MRTXIX VALCHG(IVTXIX) = .FALSE. end if if (VALCHG(IVTXFO)) then ! ! FONT COMPONENT OF GKS TEXT FONT/PRECISION, SEND ! CGM TEXT PRECISION. ! NBYTES = 1+(MEFW-1)/8 call GPUTNI (CLTFON, IDTFON, NBYTES, RERR) call GPUTPR (MRTXFO, MEFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXFO = MRTXFO VALCHG(IVTXFO) = .FALSE. end if if (VALCHG(IVTXPR)) then ! ! PRECISION COMPONENT OF GKS TEXT FONT/PRECISION, ! SEND CGM TEXT PRECSION. ! NBYTES = 1+(MIXFW-1)/8 call GPUTNI (CLTPRE, IDTPRE, NBYTES, RERR) call GPUTPR (MRTXPR, MIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXPR = MRTXPR VALCHG(IVTXPR) = .FALSE. end if if (VALCHG(IVCHXP)) then ! ! GKS character EXPANSION FACTOR, SEND CGM ! character EXPANSION FACTOR. ! NBYTES = 1+(2*MCFPP-1)/8 call GPUTNI (CLCHEX, IDCHEX, NBYTES, RERR) call GFLCNV (ARCHXP, NUMO) call GPUTPR (NUMO, MCFPP, 2, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! ASCHXP = ARCHXP VALCHG(IVCHXP) = .FALSE. end if if (VALCHG(IVCHSP)) then ! ! GKS character SPACING, SEND CGM CHARACTER SPACING. ! NBYTES = 1+(2*MCFPP-1)/8 call GPUTNI (CLCHSP, IDCHSP, NBYTES, RERR) call GFLCNV (ARCHSP, NUMO) call GPUTPR (NUMO, MCFPP, 2, RERR) ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! ASCHSP = ARCHSP VALCHG(IVCHSP) = .FALSE. end if if (VALCHG(IVTXCI)) then ! ! GKS TEXT COLOR INDEX, SEND CGM TEXT COLOR. ! NBYTES = 1+(MCIXFW-1)/8 call GPUTNI (CLTCLR, IDTCLR, NBYTES, RERR) call GPUTPR (MRTXCI, MCIXFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXCI = MRTXCI VALCHG(IVTXCI) = .FALSE. end if if (VALCHG(IVTXP)) then ! ! GKS TEXT PATH, SEND CGM TEXT PATH. ! NBYTES = 1+(MEFW-1)/8 call GPUTNI (CLTXPA, IDTXPA, NBYTES, RERR) call GPUTPR (MRTXP , MEFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXP = MRTXP VALCHG(IVTXP) = .FALSE. end if if (VALCHG(IVTXAL)) then ! ! GKS TEXT ALIGNMENT, SEND CGM TEXT ALIGNMENT. ! NBYTES = 1+(2*MEFW + 4*MCFPP - 1)/8 call GPUTNI (CLTXAL, IDTXAL, NBYTES, RERR) ! ! PUT IN GKS/CGM DISCRETE ALIGNMENT VALUES. call GPUTPR (MRTXAL, MEFW, 2, RERR) ! ! ADD (UNUSED) CGM CONTINUOUS PARAMETERS. NUMO(1) = 0 NUMO(2) = 0 call GPUTPR (NUMO, MCFPP, 2, RERR) call GPUTPR (NUMO, MCFPP, 2, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSTXAL(1) = MRTXAL(1) MSTXAL(2) = MRTXAL(2) VALCHG(IVTXAL) = .FALSE. end if if (VALCHG(IVCHH)) then ! ! GKS character HEIGHT (DERIVED FROM INTERFACE VECTOR PAIR), ! PUT OUT CGM character HEIGHT. ! NBYTES = 1+(MVDCFW-1)/8 call GPUTNI (CLCHHT, IDCHHT, NBYTES, RERR) call GPUTPR (MRCHH, MVDCFW, 1, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSCHH = MRCHH VALCHG(IVCHH) = .FALSE. end if if (VALCHG(IVCHOV)) then ! ! GKS character UP (AS PER INTERFACE VECTOR PAIR), ! SEND CGM character ORIENTATION (VECTOR PAIR). ! NBYTES = 1+(4*MVDCFW-1)/8 call GPUTNI (CLCHOR, IDCHOR, NBYTES, RERR) call GPUTPR (MRCHOV(1) , MVDCFW, 4, RERR) if (RERR /= 0) return ! ! SET SENT VALUE TO REQUESTED, CLEAR CHANGE FLAG. ! MSCHOV(1) = MRCHOV(1) MSCHOV(2) = MRCHOV(2) MSCHOV(3) = MRCHOV(3) MSCHOV(4) = MRCHOV(4) VALCHG(IVCHOV) = .FALSE. end if if (ANYASF) then ! ! SOME ASF HAS CHANGED. ! call G01SAS (IPRIM, RERR) if (RERR /= 0) return end if ! ! CLEAR AGGREGATE CHANGE VARIABLE. ! AGPEND(IPRIM) = .FALSE. end if ! ! TREAT FIRST CALL, PUT OUT OPCODE, AND POINTS ! ! ! PUT OUT OPCODE (CLASS AND ID) AND TOTAL LENGTH. ! NBYTES = G01PBL (STRL1, 1+(MEFW+2*MVDCFW-1)/8 ) call GPUTNI (CLTEXT, IDTEXT, NBYTES, RERR) ! ! PUT OUT STARTING POINT. ! ! TRUNCATE POINT TO LIMITS OF NDC UNIT SQUARE, CONVERT TO VDC, ! AND STORE IN MPXPY. ! MPXPY(1) = MXOFF + int ( real (MXSCAL)* & ( max (0.0, min (1.0,RX(1))))) MPXPY(2) = MYOFF + int ( real (MYSCAL)* & ( max (0.0, min (1.0,RY(1))))) call GPUTPR (MPXPY, MVDCFW, 2, RERR) ! ! PUT OUT FINAL FLAG. call GPUTPR (GFINAL, MEFW, 1, RERR) ! ! PUT OUT FIRST (AND PERHAPS ONLY) PART OF character STRING call GPUTPS (STR, STRL1, STRL2, 0, RERR) if (RERR /= 0) return ! ! end OF PROCESSING FOR FIRST call OF ELEMENT. ! else if (KALL > 1) then ! ! THIS IS A CONTINUATION call FOR THE ELEMENT. ! call GPUTPS (STR, STRL1, STRL2, 1, RERR) if (RERR /= 0) return end if ! ! IF THERE IS TO BE NO CONTINUATION, RESET THE PARAMETER "KALL". ! if (CONT == 0) then KALL = 0 end if return end subroutine G01WDR ! !******************************************************************************* ! !! G01WDR is a WORKSTATION DRIVER FOR WORKSTATION TYPE 1. ! ! implicit integer (A-Z) ! ! ! DEFINITION OF ALL commonS USED BY WORKSTATION. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WDT/ LWTYPE, LWKCAT, MVERSN integer LWTYPE, LWKCAT, MVERSN common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADF/ MDPLIX ,MDLTYP ,ADLWSC ,MDPLCI , & MDPMIX ,MDMTYP ,ADMSZS ,MDPMCI , & MDTXIX ,MDTXP ,MDTXAL(2) ,MDCHH , & MDCHOV(4) ,MDTXFO ,MDTXPR ,ADCHXP , & ADCHSP ,MDTXCI , & MDFAIX ,MDPASZ(4) ,MDPARF(2) , & MDFAIS ,MDFASI ,MDFACI , & MDASF(13) integer MDPLIX ,MDLTYP ,MDPLCI real ADLWSC integer MDPMIX ,MDMTYP ,MDPMCI real ADMSZS integer MDTXIX ,MDTXP ,MDTXAL ,MDTXFO integer MDTXPR ,MDTXCI ,MDCHH ,MDCHOV real ADCHXP ,ADCHSP integer MDFAIX ,MDPASZ ,MDPARF ,MDFAIS ,MDFASI integer MDFACI ,MDASF common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /GKSENU/ GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT common /GKSENU/ GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer GYES, GNO, GCONDI, GALWAY, GACTIV, GINACT integer GEMPTY,GNEMPT,GPEND, GNPEND, GNCLIP ! integer G01PBL ! ! INITIALIZE FOR THIS ENTRY. ! ! CLEAR WSI ERROR PARAMETER. ! RERR = 0 ! ! CHECK FCODE IF LAST INVOCATION INDICATED CONTINUATION. ! if (MCONTS==1 .and. FCODE /= MCODES) go to 905 ! ! COPY AND SAVE FUNCTION CODE AND CONTINUATION FLAG. ! MCODES = FCODE MCONTS = CONT ! ! BRANCH FOR FUNCTION PROCESSING. TESTING OF CODE ORGANIZED TO ! MINIMIZE NUMBER OF TESTS, BY TESTING FOR MOST FREQUENTLY EXPECTED ! FUNCTIONS FIRST. ! ! ! OUTPUT PRIMITIVES. ! ! CODE 11 12 13 14 15 16 go to (110, 120, 130, 140, 150, 160) MCODES-10 ! ! ! PRIMITIVE ATTRIBUTES. ! if (MCODES >= 21 .and. MCODES <= 43) then ! ! INVOKE PRIMITIVE ATTRIBUTE PROCESSING ROUTINE AND return. ! call G01PAT return end if ! ! CONTROL AND ESCAPE FUNCTIONS. ! ! CODE -3 -2 -1 0 1 go to (210, 220, 230, 240, 250, & 910, 270, 910, 910, 300) MCODES+4 ! CODE 2 3 4 5 6 ! ! ! CLIPPING CONTROL FUNCTION(S). ! if (MCODES==61) then call G01CLP return end if ! ! ! COLOR TABLE. ! if (MCODES==56) then call G01CTB return end if ! ! ! WORKSTATION TRANSFORMATION. ! if (MCODES==71 .or. MCODES==72) then call G01WKT return end if ! ! ! WDT INQUIRY (-100 THRU -199) ! if (MCODES <= -100 .and. MCODES >= -199) then call G01DIQ return end if ! ! ! WSL INQUIRY (-200 THRU -299) ! if (MCODES <= -200 .and. MCODES >= -299) then call G01SIQ return end if ! ! ! FALL THROUGH MEANS UNDEFINED OPCODE. ! ! go to 910 ! ! * * ! * ========== OUTPUT PRIMITIVE PROCESSING ========== * ! * * ! ! POLYLINE. ! 110 continue call G01PL return ! ! POLYMARKER. ! 120 continue call G01PM return ! ! TEXT. ! 130 continue call G01TX return ! ! FILL AREA. ! 140 continue call G01FA return ! ! CELL ARRAY. ! 150 continue call G01CA return ! ! GDP (NOT SUPPORTED AT ALL, JUST GENERATES ERROR). ! 160 continue RERR = 104 return ! ! * * ! * ---------- CONTROL FUNCTION PROCESSING ---------- * ! * * ! ! OPEN WORKSTATION. ! 210 continue ! ! MARK WORKSTATION OPEN IN WSL, SET WORKSTATION ID, CONNECTION ! ID, WORKSTATION TYPE. ! MOPEN = GYES MWKID = ID(1) MCONID = ID(2) MWTYPE = ID(3) ! ! INITIALIZE METACODE RECORD NUMBER ! MRECNM = 1 ! ! COPY LUN FOR OUTPUT. ! MFGLUN = MCONID ! ! OPEN METACODE OUTPUT UNIT ! call G01MIO (1, MFGLUN, MOUTBF, 1, RERR) if (RERR /= 0) return ! ! INITIALIZE CURRENT-BUFFER-POSITION POINTER. ! MBFPOS = 32 ! ! SET NUMBER OF BITS PER METACODE RECORD. ! MXBITS = 11520 ! ! COMPUTE NUMBER OF INTEGER WORDS NEEDED FOR OUTPUT BUFFER ! (MOUTBF) ! MOBFSZ = 1 + (MXBITS-1)/I1MACH(5) ! ! SET DATA TYPE FOR NEW METACODE ! MDTYPE = 3 ! ! INITIALIZE WORKSTATION STATE LIST PARAMETERS. ! call G01IWS ! ! INITIALIZE ATTRIBUTE CONTEXT. ! call G01IAC ! ! INITIALIZE NEW-FRAME, BEGIN-METAFILE, END-METAFILE FLAGS. ! MNFFLG = GNO MBMFLG = GYES MEMFLG = GNO ! ! GENERATE BEGIN METAFILE INSTRUCTION, NULL ID FOR NOW. ! call GPUTNI (CLBEGM, IDBEGM, G01PBL(0,0), RERR) call GPUTPS ('NULL', 0, 0, 0, RERR) if (RERR /= 0) return ! ! PUT OUT METAFILE DESCRIPTOR AND FLUSH. ! call GPUTMD (RERR) call G01FLB (RERR) if (RERR /= 0) return ! ! INITIALIZE CURRENT FRAME SEQUENCE NUMBER. ! MCFRM = 0 ! ! START NEW PICTURE. ! call G01SNP (RERR) if (RERR /= 0) return ! return ! ! ACTIVATE WORKSTATION. ! 220 continue MSTATE = GACTIV return ! ! DEACTIVATE WORKSTATION. ! 230 continue MSTATE = GINACT return ! ! CLOSE WORKSTATION. ! 240 continue ! ! MARK WORKSTATION CLOSED, FLUSH BUFFER, CLOSE THE OUTPUT UNIT ! MOPEN = GNO ! SET PARAMETER TO TELL G01CLW TO CONDITIONALLY FINISH PICTURE. ID(2) = GCONDI call G01CLW ! KILL RESULTING RECORD WITH NEW BEGIN PICTURE, REPLACE WITH ! end METAFILE RECORD AND FLUSH. MCFRM = MCFRM - 1 MNFFLG = GNO MEMFLG = GYES MBFPOS = 32 call GPUTNI (CLENDM, IDENDM, 0, RERR) call G01FLB (RERR) ! call CENTRAL I/O ROUTINE TO INDICATE 'CLOSE WORKSTATION'. call G01MIO (2, MFGLUN, MOUTBF, 1, RERR) return ! ! CLEAR WORKSTATION. ! 250 continue call G01CLW return ! ! UPDATE WORKSTATION. ! 270 continue ! ! FLUSH OUTPUT BUFFER. ! call G01FLB (RERR) return ! ! ESCAPE. ! 300 continue call G01ESC return ! ! ! NEW CODE ON 1ST WSI call AFTER A CALL INDICATING CONTINUATION. ! 905 continue RERR = 325 return ! ! UNDEFINED/UNSUPPORTED OPCODE. ! 910 continue RERR = 320 return ! ! OPEN FAILURE ON METACODE OUTPUT FILE ! 915 continue RERR = 304 return end subroutine G01WKT ! !******************************************************************************* ! !! G01WKT processes a WORKSTATION TRANSFORMATION. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01WSL/ MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN , & MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS , & RWINDO(4) ,CWINDO(4) , & RWKVP (4) ,CWKVP (4) , & MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI(256), & SRED(256) ,SGREEN(256) ,SBLUE(256), & MRCREC(4) ,MRCLIP integer MWKID ,MCONID ,MWTYPE ,MSTATE ,MOPEN integer MDEFMO ,MREGMO ,MDEMPT ,MNFRAM ,MTUS integer MOLMAX ,MOL ,MCOVFL ,MCSORT ,MCOLI real RWINDO ,CWINDO real RWKVP ,CWKVP real SRED ,SGREEN ,SBLUE integer MRCREC ,MRCLIP common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! WINDOW OR VIEWPORT? ! go to (10,20) MCODES-70 ! ! WORKSTATION WINDOW. ! 10 continue ! ! (ERROR CHECK OF RECTANGLE DEFINITION ABOVE WSI IS ASSUMED) ! SET 'REQUESTED' AND 'CURRENT' WINDOW IN WSL. ! CWINDO(1) = RX(1) CWINDO(2) = RX(2) CWINDO(3) = RY(1) CWINDO(4) = RY(2) RWINDO(1) = RX(1) RWINDO(2) = RX(2) RWINDO(3) = RY(1) RWINDO(4) = RY(2) go to 70 ! ! WORKSTATION VIEWPORT. ! 20 continue ! ! (RECTANGLE DEFINITION CHECK ABOVE WSI IS ASSUMED) ! CHECK LIMITS AND STORE IN WSL. ! if (RX(1) < 0. .or. RX(2) > 32767. .or. & RY(1) < 0. .or. RY(2) > 32767.) then ! ! VIEWPORT DEFINITION OUT OF BOUNDS. ! RERR = 54 go to 70 else ! ! SET 'REQUESTED' AND 'CURRENT' VIEWPORT IN WSL. ! RWKVP(1) = RX(1) RWKVP(2) = RX(2) RWKVP(3) = RY(1) RWKVP(4) = RY(2) CWKVP(1) = RX(1) CWKVP(2) = RX(2) CWKVP(3) = RY(1) CWKVP(4) = RY(2) end if 70 continue return end subroutine gacwk ( WKID ) ! !******************************************************************************* ! !! GACWK activates a workstation. ! integer, parameter :: EACWK = 4 ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,LASF(13) ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(6,EACWK,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,EACWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,EACWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE call GZCKWK(29,EACWK,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK IF THERE IS ROOM FOR ANOTHER ACTIVE WORKSTATION ! if (NACWK >= MACWK) then ers = 1 call gerhnd ( -101, eacwk, erf ) ers = 0 return end if ! ! SET GKS OPERATING STATE TO WSAC ! OPS = GWSAC ! ! ADD THE WORKSTATION IDENTIFIER TO THE SET OF ACTIVE WORKSTATIONS ! IN THE GKS STATE LIST ! NACWK = NACWK+1 SACWK(NACWK) = WKID ! ! INVOKE THE WORKSTATION INTERFACE SO THAT THE WORKSTATION ! CAN BE MARKED ACTIVE IN THE WORKSTATION STATE LIST ! FCODE = -2 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if ( RERR /= 0 ) then ers = 1 call gerhnd ( rerr, eacwk, erf ) ers = 0 return end if ! ! ESTABLISH CURRENT ATTRIBUTES ! call gsclip ( CCLIP ) call GSPLI (CPLI ) call GSLN (CLN ) call GSLWSC (CLWSC) call GSPLCI (CPLCI) call GSPMI (CPMI ) call GSMK (CMK ) call GSMKSC (CMKS ) call GSPMCI (CPMCI) call GSTXI (CTXI ) call GSTXFP (CTXFP(1),CTXFP(2)) call GSCHXP (CCHXP) call GSCHSP (CCHSP) call GSTXCI (CTXCI) call GSCHH (CCHH ) call GSCHUP (CCHUP(1),CCHUP(2)) call GSTXP (CTXP ) call GSTXAL (CTXAL(1),CTXAL(2)) call GSFAI (CFAI ) call GSFAIS (CFAIS) call GSFASI (CFASI) call gsfaci (CFACI) call GSPA (CPA (1),CPA (2)) call GSPARF (CPARF(1),CPARF(2)) LASF( 1) = CLNA LASF( 2) = CLWSCA LASF( 3) = CPLCIA LASF( 4) = CMKA LASF( 5) = CMKSA LASF( 6) = CPMCIA LASF( 7) = CTXFPA LASF( 8) = CCHXPA LASF( 9) = CCHSPA LASF(10) = CTXCIA LASF(11) = CFAISA LASF(12) = CFASIA LASF(13) = CFACIA call GSASF (LASF ) return end subroutine GCA(PX,PY,QX,QY,DIMX,DIMY,NCS,NRS,DX,DY,COLIA) ! !******************************************************************************* ! !! GCA ??? ! integer ECA PARAMETER (ECA=16) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/ FCODE, CONT, IL1, IL2, ID(128), RL1, RL2, RX(128), & RY(128), STRL1, STRL2, RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer DIMX,DIMY,DX,DY,COLIA(DIMX,*) real PX,PY,QX,QY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,ECA,IER) if (IER /= 0) return ! ! CHECK THAT THE INDICES OF THE COLOR ARRAY ARE VALID ! if (DIMX <= 0 .or. DIMY <= 0 .or. NRS+DY-1 > DIMY.OR.NCS+DX-1 > DIMX & ) then ers = 1 call gerhnd ( 91,ECA,ERF) ers = 0 return end if ! ! ADJUST CORNER POINTS AS PER NCS AND NRS ! DELX = ABS(PX-QX)/DIMX DELY = ABS(PY-QY)/DIMY if (PX < QX) then if (PY < QY) then PXN = PX+(NCS-1)*DELX PYN = PY+(NRS-1)*DELY QXN = PXN+DX*DELX QYN = PYN+DY*DELY else if (QY < PY) then PXN = PX+(NCS-1)*DELX PYN = PY-(NRS-1)*DELY QXN = PXN+DX*DELX QYN = PYN-DY*DELY else return end if else if (QX < PX) then if (PY < QY) then PXN = PX-(NCS-1)*DELX PYN = PY+(NRS-1)*DELY QXN = PXN-DX*DELX QYN = PYN+DY*DELY else if (QY < PY) then PXN = PX-(NCS-1)*DELX PYN = PY-(NRS-1)*DELY QXN = PXN-DX*DELX QYN = PYN-DY*DELY else return end if else return end if ! ! FIND A THIRD CORNER ! OXN = PXN OYN = QYN ! ! CONVERT CORNERS TO NDC SPACE. ! call GZW2NX(1,OXN,OXP) call GZW2NX(1,PXN,PXP) call GZW2NX(1,QXN,QXP) call GZW2NY(1,OYN,OYP) call GZW2NY(1,PYN,PYP) call GZW2NY(1,QYN,QYP) ! ! THIS subroutine PASSES DATA ACROSS THE INTERFACE WITH A ! MINIMUM OF TWO INVOCATIONS OF THE WORKSTATION INTERFACE. ! IN THE FIRST INVOCATION OF THE INTERFACE, RX(1) IS SET ! TO PXP (IN NDC SPACE), RY(1) IS SET TO PYP (IN NDC SPACE), ! RX(2) IS SET TO QXP (IN NDC SPACE), RY(2) IS SET TO QYP (IN ! NDC SPACE), RX(3) IS SET TO OXP (IN NDC SPACE) AND RY(3) ! IS SET TO OYP (IN NDC SPACE); ID(1) IS SET TO DX, ! AND ID(2) IS SET TO DY. ! IN SUBSEQUENT INVOCATIONS OF THE INTERFACE, THE RELEVANT PART OF ! THE COLOR INDEX ARRAY (OF LENGTH DX*DY) IS SENT VIA ! common ARRAY ID. ! FCODE = 15 CONT = 1 IL1 = 2 IL2 = 2 ID(1) = DX ID(2) = DY RL1 = 3 RL2 = 3 RX(1) = PXP RY(1) = PYP RX(2) = QXP RY(2) = QYP RX(3) = OXP RY(3) = OYP call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( rerr, eca, erf ) ers = 0 return end if ! ! INTERFACE CALLS FOR COLOR INDEX ARRAY ! N = DX*DY J = (N-1)/128 IL1 = N if (J==0) then ! ! CASE WHERE THERE IS NO CONTINUATION ! CONT = 0 IL2 = N INDX = 0 do K=1,DY do I=1,DX INDX = INDX+1 ID(INDX) = COLIA(NCS+I-1,NRS+K-1) end do end do call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( rerr, eca, erf ) ers = 0 return end if else ! ! CASE WITH CONTINATION ! CONT = 1 IL2 = 128 INDX = 0 do 202 M=1,DY do 203 L=1,DX INDX = INDX+1 JM = mod ( INDX,128) if (JM==0 .and. INDX < N) then ID(128) = COLIA(NCS+L-1,NRS+M-1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( rerr, eca, erf ) ers = 0 return end if else if (JM /= 0 .and. INDX < N) then ID(JM) = COLIA(NCS+L-1,NRS+M-1) else ! ! FINAL CASE WHERE INDX=N ! CONT = 0 if (JM==0) then ID(128) = COLIA(NCS+L-1,NRS+M-1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( rerr, eca, erf ) ers = 0 return end if else ID(JM) = COLIA(NCS+L-1,NRS+M-1) IL2 = mod ( N,128) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( rerr, eca, erf ) ers = 0 return end if end if end if 203 continue 202 continue end if return end subroutine gclks ! !******************************************************************************* ! !! GCLKS closes GKS. ! ! ! Discussion: ! ! This should be the last call to the GKS package. ! integer ECLKS PARAMETER (ECLKS=1) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! ! SET GKS STATE VALUE TO GKCL IF IN PROPER STATE, call ERROR ! HANDLING OTHERWISE. ! if ( OPS /= GGKOP ) then ers = 1 call gerhnd ( 2,ECLKS,ERF) ers = 0 return else OPS = GGKCL end if return end subroutine GCLRWK(WKID,COFL) ! !******************************************************************************* ! !! GCLRWK ??? ! integer ECLRWK PARAMETER (ECLRWK=6) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,COFL ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(6,ECLRWK,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,ECLRWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,ECLRWK,WKID,IDUM,IER) if (IER /= 0) return ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 1 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WKID ID(2) = COFL call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ECLRWK,ERF) ers = 0 end if return end subroutine gclwk ( WKID ) ! !******************************************************************************* ! !! GCLWK closes a workstation. ! ! ! Parameters: ! ! Input, integer WKID, the identifier for the workstation. ! integer ECLWK PARAMETER (ECLWK=3) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(7,ECLWK,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,ECLWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,ECLWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE call GZCKWK(29,ECLWK,WKID,IDUM,IER) if (IER /= 0) return ! ! INVOKE THE WORKSTATION INTERFACE (DO THIS BEFORE FLAGGING ! THE WORKSTATION AS CLOSED) ! FCODE = 0 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ECLWK,ERF) ers = 0 end if ! ! REMOVE THE WORKSTATION IDENTIFIER FROM THE SET ! OF OPEN WORKSTATIONS IN THE GKS STATE LIST ! SOPWK(1) = 0 SWKTP(1) = 0 NOPWK = 0 ! ! SET GKS TO STATE GKOP IF NO WORKSTATIONS REMAIN OPEN ! if (SOPWK(1)==0) then OPS = GGKOP end if return end subroutine gdawk ( WKID ) ! !******************************************************************************* ! !! GDAWK deactivates a workstation. ! ! ! Parameters: ! ! Input, integer WKID, the identifier of the workstation. ! integer EDAWK PARAMETER (EDAWK=5) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128),RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(3,EDAWK,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,EDAWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE call GZCKWK(30,EDAWK,WKID,IDUM,IER) if (IER /= 0) return ! ! DELETE THE WORKSTATION IDENTIFIER FROM THE SET OF ! ACTIVE WORKSTATIONS IN THE GKS STATE LIST ! SACWK(1) = 0 NACWK = 0 ! ! SET GKS OPERATING STATE ! if (NACWK==0) then OPS = GWSOP end if ! ! INVOKE THE WORKSTATION INTERFACE SO THAT THE WORKSTATION ! CAN BE MARKED INACTIVE IN THE WORKSTATION STATE LIST ! FCODE = -1 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EDAWK,ERF) ers = 0 end if return end subroutine GECLKS ! !******************************************************************************* ! !! GECLKS ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! ! UPDATE ALL OPEN WORKSTATIONS ! if (OPS >= GWSOP) then if (NOPWK /= 0) then do I=1,NOPWK call GUWK(SOPWK(I),1) end do end if end if ! ! DEACTIVATE ALL ACTIVE WORKSTATIONS ! if ( OPS >= GWSAC ) then if ( NACWK /= 0 ) then do I = 1, NACWK call gdawk ( SACWK(I) ) end do end if end if ! ! CLOSE ALL OPEN WORKSTATIONS ! if ( OPS >= GWSOP ) then if ( NOPWK /= 0 ) then do I = 1, NOPWK call gclwk ( SOPWK(I) ) end do end if end if ! ! MARK GKS CLOSED ! OPS = GGKCL return end subroutine GERHND ( ERRNR, FCTID, ERRFIL ) ! !******************************************************************************* ! !! GERHND is the GKS error handler. ! ! ! Modified: ! ! 30 July 2001 ! ! Parameters: ! ! Input, integer ERRNR, the error number. ! ! Input, integer FCTID, the index of the routine in which the error occurred. ! ! Input, integer ERRFIL, the identifier for the error log file. ! integer ENUM integer ERRFIL integer ERRNR integer FCTID character*6 FNAME character*6 GNAM ! common /GKSNAM/ GNAM(109) common /GKERR1/ ENUM common /GKERR2/ FNAME ! ENUM = ERRNR FNAME = GNAM(FCTID+1) call gerlog ( ERRNR, FCTID, ERRFIL ) return end subroutine gerlog ( ERRNR, FCTID, ERRFIL ) ! !******************************************************************************* ! !! GERLOG writes the current error message to the error file. ! ! ! Modified: ! ! 30 July 2001 ! ! Parameters: ! ! Input, integer ERRNR, the error number. ! ! Input, integer FCTID, the index of the routine in which the error occurred. ! ! Input, integer ERRFIL, the identifier for the error log file. ! common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRNR,FCTID,ERRFIL character*52 L1 ! ! write FIRST LINE OF ERROR MESSAGE. ! ! write ( L1, 700 ) ERRNR, GNAM(FCTID+1) ! 700 FORMAT(' GKS ERROR NUMBER',I4,' ISSUED FROM subroutine ',A6,':') write ( errfil, * ) ' ' write ( errfil, * ) 'GERLOG - NCAR GKS error number ', errnr write ( errfil, * ) ' Issued from subroutine number ', fctid write ( errfil, * ) ' named ' // gnam(fctid+1) if ( ERRNR == 1 ) then write (ERRFIL, 1) else if (ERRNR==2) then write (ERRFIL, 2) else if (ERRNR==3) then write (ERRFIL, 3) else if (ERRNR==4) then write (ERRFIL, 4) else if (ERRNR==5) then write (ERRFIL, 5) else if (ERRNR==6) then write (ERRFIL, 6) else if (ERRNR==7) then write (ERRFIL, 7) else if (ERRNR==8) then write (ERRFIL, 8) else if (ERRNR==20) then write (ERRFIL, 20) else if (ERRNR==21) then write (ERRFIL, 21) else if (ERRNR==22) then write (ERRFIL, 22) else if (ERRNR==23) then write (ERRFIL, 23) else if (ERRNR==24) then write (ERRFIL, 24) else if (ERRNR==25) then write (ERRFIL, 25) else if (ERRNR==26) then write (ERRFIL, 26) else if (ERRNR==29) then write (ERRFIL, 29) else if (ERRNR==30) then write (ERRFIL, 30) else if (ERRNR==32) then write (ERRFIL, 32) else if (ERRNR==33) then write (ERRFIL, 33) else if (ERRNR==34) then write (ERRFIL, 34) else if (ERRNR==35) then write (ERRFIL, 35) else if (ERRNR==50) then write (ERRFIL, 50) else if (ERRNR==51) then write (ERRFIL, 51) else if (ERRNR==52) then write (ERRFIL, 52) else if (ERRNR==53) then write (ERRFIL, 53) else if (ERRNR==54) then write (ERRFIL, 54) else if (ERRNR==60) then write (ERRFIL, 60) else if (ERRNR==63) then write (ERRFIL, 63) else if (ERRNR==66) then write (ERRFIL, 66) else if (ERRNR==69) then write (ERRFIL, 69) else if (ERRNR==72) then write (ERRFIL, 72) else if (ERRNR==75) then write (ERRFIL, 75) else if (ERRNR==77) then write (ERRFIL, 77) else if (ERRNR==78) then write (ERRFIL, 78) else if (ERRNR==79) then write (ERRFIL, 79) else if (ERRNR==80) then write (ERRFIL, 80) else if (ERRNR==84) then write (ERRFIL, 84) else if (ERRNR==87) then write (ERRFIL, 87) else if (ERRNR==91) then write (ERRFIL, 91) else if (ERRNR==92) then write (ERRFIL, 92) else if (ERRNR==93) then write (ERRFIL, 93) else if (ERRNR==96) then write (ERRFIL, 96) else if (ERRNR==65) then write (ERRFIL, 65) else if (ERRNR==100) then write ( ERRFIL, 100) else if (ERRNR==101) then write ( ERRFIL, 101) else if (ERRNR==102) then write ( ERRFIL, 102) else if (ERRNR==103) then write ( ERRFIL, 103) else if (ERRNR==104) then write ( ERRFIL, 104) else if (ERRNR==160) then write ( ERRFIL, 160) else if (ERRNR==161) then write ( ERRFIL, 161) else if (ERRNR==162) then write ( ERRFIL, 162) else if (ERRNR==163) then write ( ERRFIL, 163) else if (ERRNR==165) then write ( ERRFIL, 165) else if (ERRNR==166) then write ( ERRFIL, 166) else if (ERRNR==167) then write ( ERRFIL, 167) else if (ERRNR==180) then write ( ERRFIL, 180) else if (ERRNR==182) then write ( ERRFIL, 182) else if (ERRNR==168) then write ( ERRFIL, 168) else if (ERRNR==300) then write ( ERRFIL, 300) else if (ERRNR==302) then write ( ERRFIL, 302) else if (ERRNR==303) then write ( ERRFIL, 303) else if (ERRNR==304) then write ( ERRFIL, 304) else if (ERRNR==305) then write ( ERRFIL, 305) else if (ERRNR==306) then write ( ERRFIL, 306) else if (ERRNR==307) then write ( ERRFIL, 307) else if (ERRNR==308) then write ( ERRFIL, 308) else if (ERRNR==2000) then write ( ERRFIL, 2000) else if (ERRNR==2001) then write ( ERRFIL, 2001) else if (ERRNR==2002) then write ( ERRFIL, 2002) else if (ERRNR==2003) then write ( ERRFIL, 2003) else if (ERRNR==-101) then write ( ERRFIL, 922) else if (ERRNR==-102) then write ( ERRFIL, 925) else write ( ERRFIL, 921) end if ! 1 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN STATE GKCL') 2 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN STATE GKOP') 3 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN STATE WSAC') 4 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN STATE SGOP') 5 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE EITHER IN THE ' // & 'STATE WSAC OR IN THE STATE SGOP') 6 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE EITHER IN THE ' // & 'STATE WSOP OR IN THE THE STATE WSAC') 7 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN ONE OF THE ' // & ' STATES WSOP, WSAC, OR SGOP') 8 FORMAT(' --GKS NOT IN PROPER STATE: GKS SHALL BE IN ONE OF THE ' // & 'STATES GKOP, WSOP, WSAC, OR SGOP') 20 FORMAT(' --SPECIFIED WORKSTATION IDENTIFIER IS INVALID') 21 FORMAT(' --SPECIFIED CONNECTION IDENTIFIER IS INVALID') 22 FORMAT(' --SPECIFIED WORKSTATION TYPE IS INVALID') 23 FORMAT(' --SPECIFIED WORKSTATION TYPE DOES NOT EXIST') 24 FORMAT(' --SPECIFIED WORKSTATION IS OPEN') 25 FORMAT(' --SPECIFIED WORKSTATION IS NOT OPEN') 26 FORMAT(' --SPECIFIED WORKSTATION CANNOT BE OPENED') 29 FORMAT(' --SPECIFIED WORKSTATION IS ACTIVE') 30 FORMAT(' --SPECIFIED WORKSTATION IS NOT ACTIVE') 32 FORMAT(' --SPECIFIED WORKSTATION IS NOT OF CATEGORY MO') 33 FORMAT(' --SPECIFIED WORKSTATION IS OF CATEGORY MI') 34 FORMAT(' --SPECIFIED WORKSTATION IS NOT OF CATEGORY MI') 35 FORMAT(' --SPECIFIED WORKSTATION IS OF CATEGORY INPUT') 50 FORMAT(' --TRANSFORMATION NUMBER IS INVALID') 51 FORMAT(' --RECTANGLE DEFINITION IS INVALID') 52 FORMAT(' --VIEWPORT IS NOT WITHIN THE NORMALIZED DEVICE COORDINATE UNIT SQUARE') 53 FORMAT(' --WORKSTATION WINDOW IS NOT WITHIN THE NORMALIZED DEVICE COORDINATE UNIT SQUARE') 54 FORMAT(' --WORKSTATION VIEWPORT IS NOT WITHIN THE DISPLAY SPACE') 60 FORMAT(' --POLYLINE INDEX IS INVALID') 63 FORMAT(' --LINETYPE IS LESS THAN OR EQUAL TO ZERO') 66 FORMAT(' --POLYMARKER INDEX IS INVALID') 69 FORMAT(' --MARKER TYPE IS LESS THAN OR EQUAL TO ZERO') 72 FORMAT(' --TEXT INDEX IS INVALID') 75 FORMAT(' --TEXT FONT IS LESS THAN OR EQUAL TO ZERO') 77 FORMAT(' --CHARACTER EXPANSION FACTOR IS LESS THAN OR EQUAL TO ZERO') 78 FORMAT(' --CHARACTER HEIGHT IS LESS THAN OR EQUAL TO ZERO') 79 FORMAT(' --LENGTH OF character UP VECTOR IS ZERO') 80 FORMAT(' --FILL AREA INDEX IS INVALID') 84 FORMAT(' --STYLE (PATTERN OR HATCH) INDEX IS LESS THAN OR EQUAL TO ZERO') 87 FORMAT(' --PATTERN SIZE VALUE IS NOT POSITIVE') 91 FORMAT(' --DIMENSIONS OF COLOR ARRAY ARE INVALID') 92 FORMAT(' --COLOR INDEX IS LESS THAN ZERO') 93 FORMAT(' --COLOR INDEX IS INVALID') 96 FORMAT(' --COLOR IS OUTSIDE RANGE ZERO TO ONE INCLUSIVE') 65 FORMAT(' --LINEWIDTH SCALE FACTOR LESS THAN OR EQUAL TO ZERO') 100 FORMAT(' --NUMBER OF POINTS IS INVALID') 101 FORMAT(' --INVALID CODE IN STRING') 102 FORMAT(' --GENERALIZED DRAWING PRIMITIVE IDENTIFIER IS INVALID') 103 FORMAT(' --CONTENT OF GENERALIZED DRAWING PRIMITIVE DATA RECORD IS INVALID') 104 FORMAT(' --AT LEAST ONE ACTIVE WORKSTATION IS NOT ABLE TO GENERATE ' // & 'THE SPECIFIED GENERALIZED DRAWING PRIMITIVE') 160 FORMAT(' --ITEM TYPE IS NOT ALLOWED FOR USER ITEMS') 161 FORMAT(' --ITEM LENGTH IS INVALID') 162 FORMAT(' --NO ITEM IS LEFT IN GKS METAFILE INPUT') 163 FORMAT(' --METAFILE ITEM IS INVALID') 165 FORMAT(' --CONTENT OF ITEM DATA RECORD IS INVALID FOR THE SPECIFIED ITEM TYPE') 166 FORMAT(' --MAXIMUM ITEM DATA RECORD LENGTH IS INVALID') 167 FORMAT(' --USER ITEM CANNOT BE INTERPRETED') 180 FORMAT(' --SPECIFIED FUNCTION IS NOT SUPPORTED') 182 FORMAT(' --CONTENTS OF ESCAPE DATA RECORD ARE INVALID') 168 FORMAT(' --SPECIFIED FUNCTION IS NOT SUPPORTED IN THIS LEVEL OF GKS') 300 FORMAT(' --STORAGE OVERFLOW HAS OCCURRED IN GKS') 302 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED WHILE READING') 303 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED WHILE WRITING') 304 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED WHILE SENDING DATA TO A WORKSTATION') 305 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED WHILE RECEIVING DATA FROM A WORKSTATION') 306 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED DURING PROGRAM LIBRARY MANAGEMENT') 307 FORMAT(' --INPUT/OUTPUT ERROR HAS OCCURRED WHILE READING WORKSTATION DESCRIPTION TABLE') 308 FORMAT(' --ARITHMETIC ERROR HAS OCCURRED') 2000 FORMAT(' --ENUMERATION TYPE OUT OF RANGE') 2001 FORMAT(' --OUTPUT PARAMETER SIZE INSUFFICIENT') 2002 FORMAT(' --LIST OR SET ELEMENT NOT AVAILABLE') 2003 FORMAT(' --INVALID DATA RECORD') 921 FORMAT(' --UNKNOWN ERROR CODE') 922 FORMAT(' --NO ADDITIONAL WORKSTATIONS MAY BE ACTIVATED') 925 FORMAT(' --GKS SYSTEM ERROR--IMPROPER CONTINUATION SEQUENCE') return end subroutine GESC(FCTID,LIDR,IDR,MLODR,LODR,ODR) ! !******************************************************************************* ! !! GESC ??? ! integer EESC PARAMETER (EESC=11) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer FCTID,LIDR character*80 IDR(LIDR),ODR(MLODR) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,EESC,IER) if (IER /= 0) return ! ! CHECK IF FUNCTION ID IS VALID ! if (FCTID <= 0) then ers = 1 call GERHND ( 180, EESC, ERF ) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT FCTID IN ID(1) AND THE DATA ! RECORD IN STR. ! FCODE = 6 IL1 = 2 IL2 = 2 ID(1) = FCTID ID(2) = LIDR ! ! SEND OVER THE DATA RECORD IF THERE IS ONE (RECALL THAT THE ! STRING LENGTH OF STR IS DIVISIBLE BY 80). ! if (LIDR >= 1) then if (LIDR==1) then CONT = 0 STRL1 = 80 STRL2 = 80 STR(1:80) = IDR(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EESC,ERF) ers = 0 return end if else ! ! SEND OVER THE DATA RECORD 80 characterS AT A TIME ! CONT = 1 STRL1 = 80*LIDR STRL2 = 80 LDRM1 = LIDR-1 do 200 I=1,LDRM1 STR(1:80) = IDR(I) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EESC,ERF) ers = 0 return end if 200 continue CONT = 0 STR(1:80) = IDR(LIDR) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EESC,ERF) ers = 0 return end if end if else CONT = 0 call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EESC,ERF) ers = 0 return end if end if LODR = 0 return end subroutine GFA(N,PX,PY) ! !******************************************************************************* ! !! GFA ??? ! integer EFA PARAMETER (EFA=15) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real PX(N),PY(N) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,EFA,IER) if (IER /= 0) return ! ! CHECK THAT NUMBER OF POINTS IS VALID ! if (.NOT.(N >= 3)) then ers = 1 call gerhnd ( 100,EFA,ERF) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT THE REAL ARRAYS ACROSS THE ! WORKSTATION INTERFACE. FLAG CONVERSION TO NDC SPACE. ! FCODE = 14 call GZPUTR(N,PX,PY,1,IER) RERR = IER if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EFA,ERF) ers = 0 end if return end subroutine GFLCNV (FNUM,INUM) ! !******************************************************************************* ! !! GFLCNV CONVERTS THE FLOATING-POINT NUMBER IN ! FNUM INTO TWO 16-BIT INTEGERS IN THE LOW ORDER BITS OF ! INUM. THESE TWO 16-BIT QUANTITIES ARE SUITABLE FOR ! INSERTION INTO THE VDM. THE FIRST 16-BIT INTEGER IS ! GIVEN BY THE LOW-ORDER 15 BITS RESULTING FROM INUM(1)=FUNM. ! THE HIGH-ORDER BIT IS SET IF FNUM IS NEGATIVE. THE ! SECOND 16-BIT INTEGER IS THE DECIMAL PART OF FNUM ! MULTIPLIED BY 32767. ! ! real FNUM integer INUM(2) ! real FABS integer IONE, IWL, JNUM, I1MACH ! DATA IONE/1/ ! DETERMINE WORD LENGTH OF AN INTEGER IN BITS IWL = I1MACH(5) ! FIRST 16-BIT PARCEL FABS = ABS(FNUM) JNUM = int (FABS) INUM(1) = 0 call GBYTES (JNUM,INUM(1),IWL-15,15,0,1) if (FNUM < 0.) then call SBYTES (INUM(1),IONE,IWL-16,1,0,1) end if ! SECOND 16-BIT PARCEL INUM(2) = 32767.0 * ( FABS - real ( JNUM ) ) return end subroutine GGDP(N,PX,PY,PRIMID,LDR,DATREC) ! !******************************************************************************* ! !! GGDP ??? ! integer EGDP PARAMETER (EGDP=17) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N,PRIMID,LDR real PX(N),PY(N) character*80 DATREC(LDR) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,EGDP,IER) if (IER /= 0) return ! ! CHECK THAT NUMBER OF POINTS IS VALID ! if (.NOT.(N >= 1)) then ers = 1 call gerhnd ( 100,EGDP,ERF) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT THE REAL ARRAYS ACROSS THE ! WORKSTATION INTERFACE. FLAG CONVERSION TO NDC SPACE. ! ID(1) CONTAINS THE GDP IDENTIFIER. ! IF ID(2)=0, THEN NO DATA RECORD WILL BE SHIPPED. IF ! IF ID(2)=1, THEN THE DATA RECORD WILL BE SHIPPED VIA ! THE FIRST WORKSTATION INVOCATION SUBSEQUENT TO THE ! COMPLETION OF SENDING THE REAL ARRAYS, I.E. THE CONTINUATION ! FLAG FOR SENDING OVER THE REAL ARRAYS WILL BE SET TO ZERO ! AND THE DATA RECORD WILL BE SENT ACROSS THE INTERFACE ! COMPLETELY INDEPENDENTLY AS THE NEXT TRANSMISSION. ! FCODE = 16 ! ! SET UP FLAG IN ID(2) TO INDICATE IF A DATA RECORD IS TO FOLLOW ! SENDING OVER THE REAL ARRAYS. ! IL1 = 2 IL2 = 2 ID(1) = PRIMID if (LDR > 0) then ID(2) = 1 else ID(2) = 0 end if ! ! SEND OVER THE REAL ARRAYS ! call GZPUTR(N,PX,PY,1,IER) RERR = IER if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EGDP,ERF) ers = 0 return end if ! ! SEND OVER THE DATA RECORD IF THERE IS ONE (RECALL THAT THE ! STRING LENGTH OF STR IS DIVISIBLE BY 80). ! if (ID(2)==1) then if (LDR==1) then CONT = 0 STRL1 = 80 STRL2 = 80 STR(1:80) = DATREC(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EGDP,ERF) ers = 0 return end if else ! ! SEND OVER THE DATA RECORD 80 characterS AT A TIME ! CONT = 1 STRL1 = 80*LDR STRL2 = 80 LDRM1 = LDR-1 do 200 I=1,LDRM1 STR(1:80) = DATREC(I) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EGDP,ERF) ers = 0 return end if 200 continue CONT = 0 STR(1:80) = DATREC(LDR) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EGDP,ERF) ers = 0 return end if end if end if return end subroutine GGTITM (WKID,TYPE,LDR) ! !******************************************************************************* ! !! GGTITM ??? ! integer EGTITM PARAMETER (EGTITM=102) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,TYPE,LDR ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,EGTITM,IER) if (IER /= 0) return ! CHECK IF WORKSTATION ID IS VALID call GZCKWK(20,EGTITM,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY OPEN call GZCKWK(25,EGTITM,WKID,IDUM,IER) if (IER /= 0) return ! ! SET FUNCTION CODE AND PUT OUT WKID ! FCODE = 102 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK ! ! CHECK ERROR return ! if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EGTITM,ERF) ers = 0 return else ! ! READ returnED DATA ! TYPE = ID(2) LDR = ID(3) end if return end subroutine GIITM (TYPE,LDR,DATREC) ! !******************************************************************************* ! !! GIITM ??? ! integer EIITM PARAMETER (EIITM=104) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TYPE,LDR character*80 DATREC(LDR) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,EIITM,IER) if (IER /= 0) return ! ! SET FUNCTION CODE AND PUT OUT WKID ! FCODE = 104 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = TYPE if (LDR >= 1) then if (LDR==1) then CONT = 0 STRL1 = 80 STRL2 = 80 STR(1:80) = DATREC(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EIITM,ERF) ers = 0 return end if else ! ! SEND OVER THE DATA RECORD 80 characterS AT A TIME ! CONT = 1 STRL1 = 80*LDR STRL2 = 80 LDRM1 = LDR-1 do 200 I=1,LDRM1 STR(1:80) = DATREC(I) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EIITM,ERF) ers = 0 return end if 200 continue CONT = 0 STR(1:80) = DATREC(LDR) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EIITM,ERF) ers = 0 return end if end if else CONT = 0 call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EIITM,ERF) ers = 0 return end if end if return end subroutine GINLOD(GKSERR) ! !******************************************************************************* ! !! GINLOD loads THE CURRENT INSTRUCTION INTO THE METAFILE. ! ! ! THE CURRENT INSTRUCTION INCLUDES THE OPCODE CLASS AND ID, ! THE AND THE SIZE FILED WHICH MAY BE SHORT OR LONG. ! ! OUTPUT ! GKSERR-THE ERROR STATUS FLAG ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) ! ! common FOR COMMUNICATION OF INSTRUCTION AND LENGTH ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! ! DEFINE THE ALLOK STATUS AND THE OPCODE CLASS AND ID LENGTHS ! DATA ALLOK,OPCLLN,OPIDLN/0,4,7/ ! ! DEFINE THE SHORT FORMAT LENGTH, SHORT FORMAT COUNT, LONG FORMAT FLAG, ! continue FLAG ON, CONTINUE FLAG OFF, CONTINUE LENGTH, LONG FORMAT ! LENGTH ! DATA SHFMLN,SHTFMT,LFMFLG,CONON,CONOFF,CFMLNG,LFMLNG & /5,30,31,1,0,1,15/ DATA SHORT/0/, LONG/1/ ! ! SET ERROR STATUS TO ALL OK ! GKSERR = ALLOK ! ! MAKE SURE INSTRUCTION STARTS ON A 16 BIT BOUNDRY ! TEMP = mod ( MBFPOS,16) if (TEMP /= 0) MBFPOS = MBFPOS + (16-TEMP) ! ! LOAD THE OPCODE CLASS AND ID INTO THE METAFILE ! call GMFLOD(MCOPCL,OPCLLN,1,GKSERR) if (GKSERR /= ALLOK) return call GMFLOD(MCOPID,OPIDLN,1,GKSERR) if (GKSERR /= ALLOK) return ! ! DETERMINE IF A LONG FORMAT OR SHORT FORMAT INSTRUCTION ! if (MCCBYT <= SHTFMT) then ! ! SHORT FORMAT INSTRUCTION ! MSLFMT = SHORT call GMFLOD (MCCBYT,SHFMLN,1,GKSERR) if (GKSERR /= ALLOK) return else ! ! LONG FORMAT INSTRUCTION ! SET THE LONG FORMAT FLAG ! MSLFMT = LONG call GMFLOD (LFMFLG,SHFMLN,1,GKSERR) if (GKSERR /= ALLOK) return ! ! SET THE continue FLAG ! if (MCNBYT /= 0) then ! ! THERE IS ANOTHER PARTITION ! call GMFLOD(CONON,CFMLNG,1,GKSERR) else ! ! LAST PARTITION ! call GMFLOD(CONOFF,CFMLNG,1,GKSERR) end if ! if (GKSERR /= ALLOK) return ! ! SET THE LONG FORMAT OPERAND LIST SIZE ! call GMFLOD(MCCBYT,LFMLNG,1,GKSERR) end if return end function GKASCI (INCODE) ! !******************************************************************************* ! !! GKASCI translates native character code, right-justified in INCODE, ! to ASCII code, right-justified in function value. ! ! The codes are as would be returned by the FORTRAN 77 ICHAR function. ! ! This routine simply copies in to out on ASCII computers. ! integer GKASCI integer INCODE ! GKASCI = INCODE ! return ! end BLOCKDATA GKSBD ! !******************************************************************************* ! !! GKSBD is block data. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! ! DESCRIPTION OF ALL GKS common BLOCKS ! !----------------------------------------------------------------------- ! ! GKINTR: GKS INTERNAL VARIABLES ! ! NOPWK -- NUMBER OF CURRENTLY OPEN WORKSTATIONS ! NACWK -- NUMBER OF CURRENTLY ACTIVE WORKSTATIONS !----------------------------------------------------------------------- ! ! GKOPDT: OPERATING STATE AND DESCRIPTION TABLE VARIABLES ! ! OPS -- THE GKS OPERATING STATE ! KSLEV -- LEVEL OF GKS ! WK -- NUMBER OF AVAILABLE WORKSTATION TYPES ! LSWK -- LIST OF AVAILABLE WORKSTATION TYPES ! MOPWK -- MAXIMUM NUMBER OF SIMULTANEOUSLY OPEN WORKSTATIONS ! MACWK -- MAXIMUM NUMBER OF SIMULTANEOUSLY ACTIVE WORKSTATIONS ! MNT -- MAXIMUM NORMALIZATION TRANSFORMATION NUMBER !----------------------------------------------------------------------- ! ! GKSTAT: GKS STATE LIST VARIABLES-- ! SOPWK -- SET OF OPEN WORKSTATIONS ! SACWK -- SET OF ACTIVE WORKSTATIONS ! SWKTP -- SET OF WORKSTATION TYPES ! CPLI -- CURRENT POLYLINE INDEX ! CLN -- CURRENT LINETYPE ! CLWSC -- CURRENT LINEWIDTH SCALE FACTOR ! CPLCI -- CURRENT POLYLINE COLOR INDEX ! CLNA -- CURRENT LINETYPE ASF ! CLWSCA -- CURRENT LINEWIDTH SCALE FACTOR ASF ! CPLCIA -- CURRENT POLYLINE COLOR INDEX ASF ! CPMI -- CURRENT POLYMARKER INDEX ! CMK -- CURRENT MARKER TYPE ! CMKS -- CURRENT MARKER SIZE SCALE FACTOR ! CPMCI -- CURRENT POLYMARKER COLOR INDEX ! CMKA -- CURRENT MARKER TYPE ASPECT SOURCE FLAG ! CMKSA -- CURRENT MARKER SIZE SCALE FACTOR ASF ! CPMCIA -- CURRENT POLYMARKER COLOR INDEX ASF ! CTXI -- CURRENT TEXT INDEX ! CTXFP -- CURRENT TEXT FONT AND PRECISION ! CCHXP -- CURRENT character EXPANSION FACTOR ! CCHSP -- CURRENT character SPACING ! CTXCI -- CURRENT TEXT COLOR INDEX ! CTXFPA -- CURRENT TEXT FONT AND PRECISION ASF ! CCHXPA -- CURRENT character EXPANSION FACTOR ASF ! CCHSPA -- CURRENT character SPACING ASF ! CTXCIA -- CURRENT TEXT COLOR INDEX ASF ! CCHH -- CURRENT character HEIGHT ! CCHUP -- CURRENT character UP VECTOR ! CTXP -- CURRENT TEXT PATH ! CTXAL -- CURRENT TEXT ALIGNMENT ! CFAI -- CURRENT FILL AREA INDEX ! CFAIS -- CURRENT FILL AREA INTERIOR STYLE ! CFASI -- CURRENT FILL AREA STYLE INDEX ! CFACI -- CURRENT FILL AREA COLOR INDEX ! CFAISA -- CURRENT FILL AREA INTERIOR STYLE ASF ! CFASIA -- CURRENT FILL AREA STYLE INDEX ASF ! CFACIA -- CURRENT FILL AREA COLOR INDEX ASF ! CPA -- CURRENT PATTERN SIZE ! CPARF -- CURRENT PATTERN REFERENCE POINT ! CNT -- CURRENT NORMALIZATION TRANSFORMATION NUMBER ! LSNT -- LIST OF NORMALIZATION TRANSFORMATIONS (ORDERED ! BY VIEWPORT INPUT PRIORITY) ! NTWN -- NORMALIZATION TRANSFORMATION WINDOWS ! NTVP -- NORMALIZATION TRANSFORMATION VIEWPORTS ! CCLIP -- CURRENT CLIPPING INDICATOR !----------------------------------------------------------------------- ! ! GKEROR: GKS ERROR STATE LIST ! ERS -- ERROR STATE ! ERF -- ERROR FILE !----------------------------------------------------------------------- ! ! GKENUM: GKS ENUMERATION TYPE VARIABLESO ! GBUNDL -- BUNDLED ! GINDIV -- INDIVIDUAL ! GGKCL -- GKS CLOSED ! GGKOP -- GKS OPEN ! GWSOP -- WORKSTATION OPEN ! GWSAC -- WORKSTATION ACTIVE ! GSGOP -- SEGMENT OPEN !----------------------------------------------------------------------- ! ! GKSNAM: GKS subroutine NAMES AS PER THE DPANS BINDING ! ! GNAM -- ARRAY OF GKS FUNCTION NAMES IS AS PER THE BINDING !----------------------------------------------------------------------- ! ! GKSIN1 & GKSIN2: WORKSTATION INTERFACE common BLOCKS ! ! FCODE -- FUNCTION CODE FOR THE CURRENT INSTRUCTION ! CONT -- CONTINUATION FLAG (1 MEANS MORE TO COME; 0 MEANS LAST) ! IL1 -- TOTAL NUMBER OF ELEMENTS TO BE PASSED IN THE ID ! ARRAY FOR THE CURRENT INSTRUCTION ! IL2 -- NUMBER OF ELEMENTS IN THE ID ARRAY FOR THE GIVEN ! WORKSTATION INTERFACE INVOCATION ! ID -- ARRAY FOR PASSING INTEGERS ! RL1 -- TOTAL NUMBER OF ELEMENTS TO BE PASSED IN THE RX AND ! RY ARRAYS FOR THE CURRENT INSTRUCTION ! RL2 -- NUMBER OF ELEMENTS IN THE RX AND RY ARRAYS FOR THE ! GIVEN WORKSTATION INTERFACE INVOCATION ! RX -- ARRAY FOR PASSING REAL X COORDINATE VALUES ! RY -- ARRAY FOR PASSING REAL Y COORDINATE VALUES ! STRL1 -- TOTAL NUMBER OF characterS TO BE PASSED IN THE ! character VARIABLE STR FOR THE CURRENT INSTRUCTION ! STRL2 -- NUMBER OF characterS IN THE CHARACTER VARIABLE STR ! FOR THE CURRENT INVOCATION OF THE WORKSTATION ! INTERFACE ! STR -- character VARIABLE FOR PASSING CHARACTERS ! RERR -- return VARIABLE FOR ERROR INDICATOR ! !----------------------------------------------------------------------- DATA KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT & / 0, 1, 1, 1, 1, 1/ DATA OPS/0/ DATA ERS,ERF/0,6/ DATA GBUNDL,GINDIV/0,1/ DATA GGKCL,GGKOP,GWSOP,GWSAC,GSGOP/0,1,2,3,4/ DATA NOPWK ,NACWK /0,0 / DATA GNAM(001),GNAM(002),GNAM(003)/'gopks' ,'gclks' ,'gopwk' / DATA GNAM(004),GNAM(005),GNAM(006)/'gclwk' ,'gacwk' ,'gdawk' / DATA GNAM(007),GNAM(008),GNAM(009)/'GCLRWK','GRSGWK','GUWK' / DATA GNAM(010),GNAM(011),GNAM(012)/'GSDS' ,'GMSG' ,'GESC' / DATA GNAM(013),GNAM(014),GNAM(015)/'GPL' ,'GPM' ,'GTX' / DATA GNAM(016),GNAM(017),GNAM(018)/'GFA' ,'GCA' ,'GGDP' / DATA GNAM(019),GNAM(020),GNAM(021)/'GSPLI' ,'GSLN' ,'GLSWSC'/ DATA GNAM(022),GNAM(023),GNAM(024)/'GSPLCI','GSPMI' ,'GSMK' / DATA GNAM(025),GNAM(026),GNAM(027)/'GSMKSC','GSPMCI','GSTXI' / DATA GNAM(028),GNAM(029),GNAM(030)/'GSTXFP','GSCHXP','GSCHSP'/ DATA GNAM(031),GNAM(032),GNAM(033)/'GSTXCI','GSCHH' ,'GSCHUP'/ DATA GNAM(034),GNAM(035),GNAM(036)/'GSTXP' ,'GSTXAL','GSFAI' / DATA GNAM(037),GNAM(038),GNAM(039)/'GSFAIS','GSFASI','gsfaci'/ DATA GNAM(040),GNAM(041),GNAM(042)/'GSPA' ,'GSPARF','GSASF' / DATA GNAM(043),GNAM(044),GNAM(045)/'GSPKID','GSPLR' ,'GSPMR' / DATA GNAM(046),GNAM(047),GNAM(048)/'GSTXR' ,'GSFAR' ,'GSPAR' / DATA GNAM(049),GNAM(050),GNAM(051)/'GSCR' ,'GSWN' ,'GSVP' / DATA GNAM(052),GNAM(053),GNAM(054)/'GSVPIP','GSELNT','gsclip'/ DATA GNAM(055),GNAM(056),GNAM(057)/'GSWKWN','GSWKVP','GCRSG' / DATA GNAM(058),GNAM(059),GNAM(060)/'GCLSG' ,'GRENSG','GDSG' / DATA GNAM(061),GNAM(062),GNAM(063)/'GDSGWK','GASGWK','GCSGWK'/ DATA GNAM(064),GNAM(065),GNAM(066)/'GINSG' ,'GSSGT' ,'GSVIS' / DATA GNAM(067),GNAM(068),GNAM(069)/'GSHLIT','GSSGP' ,'GSDTEC'/ DATA GNAM(070),GNAM(071),GNAM(072)/'GINLC' ,'GINSK' ,'GINVL' / DATA GNAM(073),GNAM(074),GNAM(075)/'GINCH' ,'GINPK' ,'GINST' / DATA GNAM(076),GNAM(077),GNAM(078)/'GSLCM' ,'GSSKM' ,'GSVLM' / DATA GNAM(079),GNAM(080),GNAM(081)/'GSCHM' ,'GSPKM' ,'GSSTM' / DATA GNAM(082),GNAM(083),GNAM(084)/'GRQLC' ,'GRQSK' ,'GRQVL' / DATA GNAM(085),GNAM(086),GNAM(087)/'GRQCH' ,'GRQPK' ,'GRQST' / DATA GNAM(088),GNAM(089),GNAM(090)/'GSMLC' ,'GSMSK' ,'GSMVL' / DATA GNAM(091),GNAM(092),GNAM(093)/'GSMCH' ,'GSMPK' ,'GSMST' / DATA GNAM(094),GNAM(095),GNAM(096)/'GWAIT' ,'GFLUSH','GGTLC' / DATA GNAM(097),GNAM(098),GNAM(099)/'GGTSK' ,'GGTVL' ,'GGTCH' / DATA GNAM(100),GNAM(101),GNAM(102)/'GGTPK' ,'GGTST' ,'GWITM' / DATA GNAM(103),GNAM(104),GNAM(105)/'GGTITM','GRDITM','GIITM' / DATA GNAM(106),GNAM(107),GNAM(108)/'GEVTM' ,'GACTM' ,'GPREC' / DATA GNAM(109) /'GUREC' / end subroutine GMFLOD(LIST,BITS,COUNT,GKSERR) ! !******************************************************************************* ! !! GMFLODD LOAD THE BIT STRING CONTAINED IN THE LOW ORDER PART OF EACH WORD ! INTO THE METAFILE ! ! INPUT ! LIST-A LIST OF WORDS WHICH HAVE BIT STRINGS RIGHT JUSTIFIED ! BITS-NUMBER OF BITS PER WORD TO MOVE ! COUNT-THE REPITITION COUNT (NUMBER OF WORDS IN THE LIST) ! OUTPUT ! GKSERR-THE ERROR STATUS ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) ! DIMENSION LIST(*) ! ! common FOR METAFILE BUFFER ! common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! DATA ALLOK/0/ ! if (COUNT <= 0) return CTEMP = COUNT STRT = 1 ! ! DETERMINE THE NUMBER OF PACKETS OF SIZE BITS LEFT IN BUFFER ! 10 continue BLEFT = (MXBITS-MBFPOS) REPLFT = BLEFT/BITS ! ! COMPUTE HOW MAY PACKETS TO MOVE INTO THE BUFFER ! if (CTEMP <= REPLFT) then ! ! ROOM FOR ALL ! CMOVE = CTEMP CTEMP = 0 else ! ! NOT ENOUGH ROOM FOR ALL BITS ! CMOVE = REPLFT CTEMP = CTEMP - REPLFT end if ! ! MOVE THE CURRENT BIT PACKETS ! call SBYTES(MOUTBF,LIST(STRT),MBFPOS,BITS,0,CMOVE) MBFPOS = MBFPOS + (BITS * CMOVE) ! ! CHECK IF MORE BIT PACKETS REMAINING ! if (CTEMP /= 0) then ! ! MORE REMAINING FLUSH THE CURRENT BUFFER ! call G01FLB(GKSERR) if (GKSERR /= ALLOK) return STRT = STRT + CMOVE go to 10 end if ! ! ALL DONE return TO CALLER ! return end subroutine GMPART(NBYTES,GKSERR) ! !******************************************************************************* ! !! GMPART loads THE NEXT PARTITION OF AN ACTIVE INSTRUCTION ! ! ! OUTPUT ! ! GKSERR-THE ERROR STATUS FLAG ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) ! ! common FOR COMMUNICATION OF INSTRUCTION AND LENGTH ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG common /G01IO/ MPXYSZ ,MPXPY(256) , & MOBFSZ ,MOUTBF(720) ,MBFPOS , & MFGLUN ,MXBITS ,MDTYPE , & MNFFLG ,MBMFLG ,MEMFLG ,MRECNM ,MIOFLG integer MPXYSZ ,MPXPY ,MOBFSZ ,MBFPOS ,MFGLUN ,MOUTBF, & MXBITS ,MDTYPE ,MNFFLG ,MBMFLG ,MEMFLG ,MRECNM, & MIOFLG ! ! DEFINE THE ALLOK STATUS AND THE OPCODE CLASS AND ID LENGTHS ! DATA PARSIZ/32767/ DATA ALLOK/0/ ! ! DEFINE THE SHORT FORMAT LENGTH, SHORT FORMAT COUNT, LONG FORMAT FLAG, ! continue FLAG ON, CONTINUE FLAG OFF, CONTINUE LENGTH, LONG FORMAT ! LENGTH ! DATA CONON,CONOFF,CFMLNG,LFMLNG & /1,0,1,15/ ! ! SET ERROR STATUS TO ALL OK ! GKSERR = ALLOK ! ! SET THE CURRENT PARTITION BYTE COUNT AND THE REMAINDER BYTE COUNT ! if (NBYTES > PARSIZ) then MCCBYT = PARSIZ MCNBYT = NBYTES - PARSIZ else MCCBYT = NBYTES MCNBYT = 0 end if ! ! SET THE continue FLAG ! if (MCNBYT /= 0) then ! ! THERE IS ANOTHER PARTITION ! call GMFLOD(CONON,CFMLNG,1,GKSERR) else ! ! LAST PARTITION ! call GMFLOD(CONOFF,CFMLNG,1,GKSERR) end if if ( GKSERR /= ALLOK ) then return end if ! ! SET THE LONG FORMAT OPERAND LIST SIZE ! call GMFLOD(MCCBYT,LFMLNG,1,GKSERR) return end subroutine gopks ( ERRFIL, BUFA ) ! !******************************************************************************* ! !! GOPKS initializes the GKS package. ! ! ! Discussion: ! ! This routine should be called before using any other NCAR GKS routines. ! ! It forces a load of the default data into the common blocks. ! EXTERNAL GKSBD,G01BKD integer EOPKS PARAMETER (EOPKS=0) integer ERRFIL,BUFA ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! ! CHECK IF GKS IS IN PROPER STATE ! call GZCKST ( 1, EOPKS, IER ) if ( IER /= 0 ) then return end if ! ! INITIALIZE ERROR STATE LIST ! call GZINES ! ! SPECIFY ERROR FILE IN THE GKS ERROR STATE LIST ! ERF = ERRFIL ! ! INITIALIZE THE GKS STATE LIST ! call GZINSL ! ! SET GKS OPERATING STATE TO GKSOP ! OPS = GGKOP return end subroutine gopwk ( WKID, CONID, WTYPE ) ! !******************************************************************************* ! !! GOPWK opens a new workstation. ! integer EOPWK PARAMETER (EOPWK=2) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,CONID,WTYPE logical IOPEN ! ! CHECK THAT GKS IS IN THE PROPER STATE ! call GZCKST(8,EOPWK,IER) if (IER /= 0) return ! ! CHECK IF WORKSTATION IDENTIFIER IS VALID ! call GZCKWK(20,EOPWK,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK THAT THE CONNECTION IDENTIFIER IS VALID ! if (CONID==5 .or. CONID==6) then ers = 1 call gerhnd ( 21,EOPWK,ERF) ers = 0 return end if ! ! CHECK THAT THE WORKSTATION TYPE IS VALID ! call GZCKWK(22,EOPWK,IDUM,WTYPE,IER) if (IER /= 0) return ! ! CHECK IF THE WORKSTATION IS CURRENTLY OPEN ! call GZCKWK(24,EOPWK,IDUM,WTYPE,IER) if (IER /= 0) return ! ! CHECK IF THERE IS ROOM FOR ANOTHER OPEN WORKSTATION ! if (NOPWK >= MOPWK) then ers = 1 call gerhnd ( 26,EOPWK,ERF) ers = 0 return end if ! ! CHECK IF THE SPECIFIED CONNECTION IDENTIFIER IS CURRENTLY OPEN ! INQUIRE (CONID,OPENED=IOPEN) if (IOPEN) then ers = 1 call gerhnd ( 26,EOPWK,ERF) ers = 0 return end if ! ! SET OPERATING STATE TO WSOP IF IN STATE GKOP ! if (OPS==GGKOP) then OPS = GWSOP end if ! ! ADD THE WORKSTATION IDENTIFIER TO THE SET OF OPEN WORKSTATIONS ! NOPWK = NOPWK+1 SOPWK(NOPWK) = WKID SWKTP(NOPWK) = WTYPE ! ! PASS INFORMATION ACROSS THE WORKSTATION INTERFACE ! FCODE = -3 CONT = 0 IL1 = 3 IL2 = 3 ID(1) = WKID ID(2) = CONID ID(3) = WTYPE call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EOPWK,ERF) ers = 0 end if return end subroutine GPL(N,PX,PY) ! !******************************************************************************* ! !! GPL ??? ! integer EPL PARAMETER (EPL=12) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N real PX(N),PY(N) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,EPL,IER) if (IER /= 0) return ! ! CHECK THAT NUMBER OF POINTS IS VALID ! if (.NOT.(N >= 2)) then ers = 1 call gerhnd ( 100,EPL,ERF) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT THE REAL ARRAYS ACROSS THE ! WORKSTATION INTERFACE. FLAG CONVERSION TO NDC SPACE (NO ! CONVERSION NECESSARY FOR TRANSFORMATION 0. ! FCODE = 11 call GZPUTR(N,PX,PY,MIN0(CNT,1),IER) RERR = IER if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EPL,ERF) ers = 0 end if return end subroutine GPM(N,PX,PY) ! !******************************************************************************* ! !! GPM ??? ! integer EPM PARAMETER (EPM=13) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N real PX(N),PY(N) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,EPM,IER) if (IER /= 0) return ! ! CHECK THAT NUMBER OF POINTS IS VALID ! if (.NOT.(N >= 1)) then ers = 1 call gerhnd ( 100,EPM,ERF) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT THE REAL ARRAYS ACROSS THE ! WORKSTATION INTERFACE. FLAG CONVERSION TO NDC SPACE. ! FCODE = 12 call GZPUTR(N,PX,PY,1,IER) RERR = IER if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EPM,ERF) ers = 0 end if return end subroutine GPREC(IL,IA,RL,RA,SL,LSTR,STR,MLDR,ERRIND,LDR,DATREC) ! !******************************************************************************* ! !! GPREC ??? ! integer EPREC PARAMETER (EPREC=107) integer IL,IA(*),RL,SL,LSTR(*),MLDR,LDR,ERRIND real RA(*) character*(*) STR(*) character*80 DATREC(LDR) DATA NCE/1/ ! ! DETERMINE NUMBER OF character*80 RECORDS THE PACKING IS GOING TO ! REQUIRE: THE INTEGERS ARE PACKED IN I20 FORMAT, THE REALS IN ! E20.13 FORMAT, AND THE characterS ARE PACKED IN PACKETS OF ! N PER RECORD, WHERE N IS 80 DIVIDED BY THE character STRING ! OF MAXIMUM LENGTH. ! !--------------------------------------------------------------------- ! ! WHERE: ! MAXSL = MAXIMUM LENGTH OF ALL character STRINGS ! NCE = NUMBER OF character ENTRIES IN EACH DATA RECORD ! NTL = NUMBER OF DATA RECORDS NEEDED TO STORE THE LSTR ARRAY ! NIL = NUMBER OF DATA RECORDS NEEDED TO STORE INTEGER ARRAY ! NRL = NUMBER OF DATA RECORDS NEEDED TO STORE THE REAL ARRAY ! NSL = NUMBER OF DATA RECORDS NEEDED TO STORE THE characterS ! ! THE PACKED DATA RECORD STRUCTURE LOOKS LIKE: ! ! DATA REC NUMBER STORED ITEMS ! --------------- ------------ ! 1 IL,RL,SL,NTL,NIL,NRL,NSL,MAXSL ! (STORED AS 8I10) ! 2 TO NTL+1 LSTR ARRAY STORED AS I10 INTEGERS ! NTL+2 TO NTL+NIL+1 integer ARRAY STORED AS I20 ! NTL+NIL+2 TO real ARRAY STORED AS E20.13 ! NTL+NIL+NRL+1 ! NTL+NIL+NRL+2 TO characterS STORED IN BLOCKS OF NCE ! NTL+NIL+NRL+NSL+1 ! NIL = 0 if (IL > 0) then NIL = IL/4 if (mod ( IL,4) /= 0) then NIL = NIL+1 end if end if NRL = 0 if (RL > 0) then NRL = RL/4 if (mod ( RL,4) /= 0) then NRL = NRL+1 end if end if ! ! FIND MAXIMUM LENGTH OF THE character STRINGS ! MAXSL = 0 if (SL > 0) then do 200 I=1,SL MAXSL = MAX0(MAXSL,LSTR(I)) 200 continue end if ! ! DETERMINE NUMBER OF character ENTRIES TO BE PACKED IN EACH ! DATA RECORD ! if (MAXSL /= 0) then NCE = 80/MAXSL if (NCE <= 1) then NCE = 1 end if end if ! ! DETERMINE THE NUMBER OF DATA RECORDS NEEDED TO STORE THE LSTR ! ARRAY (STORED 8I10) ! NTL = 0 if (SL > 0) then NPER = 8 NTL = SL/NPER if (mod ( SL,NPER) /= 0 .or. NTL==0) then NTL = NTL+1 end if end if ! ! DETERMINE NUMBER OF RECORDS NEEDED TO STORE THE characterS ! NSL = 0 if (SL > 0) then if (NCE > 1) then NSL = SL/NCE if (mod ( SL,NCE) /= 0 .or. NSL==0) then NSL = NSL+1 end if else do 201 I=1,SL K = LSTR(I)/80 if (mod ( LSTR(I),80) /= 0 .or. K==0) then NSL = NSL+K+1 else NSL = NSL+K end if 201 continue end if end if LDR = NTL+NIL+NRL+NSL+1 if (LDR > MLDR) then ERRIND = 2001 return end if ! ! INITIALIZE THE DATA RECORD ! do 202 I=1,LDR DATREC(I) = ' ' 202 continue ! ! PACK THE DATA RECORD ! write ( DATREC(1),501) IL,RL,SL,NTL,NIL,NRL,NSL,MAXSL ! ! write OUT LSTR ARRAY ! NPER = 8 if (SL > 0) then INDX1 = SL/NPER INDX2 = mod ( SL,NPER) if (INDX1==0) then write ( DATREC(2),501) (LSTR(LL),LL=1,SL) else do 203 I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I write ( DATREC(I+1),501) (LSTR(LL),LL=IPNT1,IPNT2) 203 continue if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 write ( DATREC(INDX1+2),501) (LSTR(LL),LL=NPNT1,NPNT2) end if end if end if ! ! write OUT INTEGER ARRAY ! NPER = 4 if (IL > 0) then INDX1 = IL/NPER INDX2 = mod ( IL,NPER) if (INDX1==0) then write ( DATREC(NTL+2),502) (IA(LL),LL=1,IL) else do 204 I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I write ( DATREC(NTL+I+1),502) (IA(LL),LL=IPNT1,IPNT2) 204 continue if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 write ( DATREC(NTL+INDX1+2),502) (IA(LL),LL=NPNT1,NPNT2) end if end if end if ! ! write OUT REAL ARRAY ! NPER = 4 if (RL > 0) then INDX1 = RL/NPER INDX2 = mod ( RL,NPER) if (INDX1==0) then write ( DATREC(NTL+NIL+2),503) (RA(LL),LL=1,RL) else do 205 I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I write ( DATREC(NTL+NIL+I+1),503) (RA(LL),LL=IPNT1,IPNT2) 205 continue if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 write ( DATREC(NTL+NIL+INDX1+2),503) (RA(LL),LL=NPNT1,NPNT2) end if end if end if ! ! write OUT character ARRAYS ! NPER = NCE if (SL > 0) then if (NPER > 1) then INDX1 = SL/NPER INDX2 = mod ( SL,NPER) if (INDX1==0) then do I=1,SL IPNT1 = (I-1)*MAXSL+1 IPNT2 = IPNT1+LSTR(I)-1 DATREC(NTL+NIL+NRL+2)(IPNT1:IPNT2) = STR(I) end do else do I=1,INDX1 do J=1,NCE JPNT1 = (J-1)*MAXSL+1 JPNT2 = JPNT1+LSTR(NPER*(I-1)+J)-1 DATREC(NTL+NIL+NRL+I+1)(JPNT1:JPNT2) = STR(NPER*(I-1)+J) end do end do if (INDX2 /= 0) then do 209 J=1,INDX2 JPNT1 = (J-1)*MAXSL+1 JPNT2 = JPNT1+LSTR(NPER*INDX1+J)-1 DATREC(NTL+NIL+NRL+INDX1+2)(JPNT1:JPNT2) = STR(NPER*INDX1+J) 209 continue end if end if else JNDX = 0 do 210 I=1,SL INDX1 = LSTR(I)/80 INDX2 = mod ( LSTR(I),80) if (INDX1==0) then JNDX = JNDX+1 DATREC(NTL+NIL+NRL+JNDX+1) = STR(I)(1:INDX2) else do 211 J=1,INDX1 JNDX = JNDX+1 DATREC(NTL+NIL+NRL+JNDX+1) = STR(I) (80*(J-1)+1:80*J) 211 continue if (INDX2 /= 0) then JNDX = JNDX+1 DATREC(NTL+NIL+NRL+JNDX+1) = STR(I) (80*INDX1+1:80*INDX1+INDX2) end if end if 210 continue end if end if ! 501 FORMAT(8I10) 502 FORMAT(4I20) 503 FORMAT(4E20.13) ! return end subroutine GPUTMD (ERROR) ! !******************************************************************************* ! !! GPUTMD generates a metafile descriptor. ! ! ! FOR NOW, VERSION AND ELEMENTS LIST. ! integer ERROR ! common /G01WDT/ LWTYPE, LWKCAT, MVERSN integer LWTYPE, LWKCAT, MVERSN ! ! Id code parameters for every element, and class codes for each class. ! common /G01OPC/ IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP common /G01OPC/ IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT common /G01OPC/ IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON common /G01OPC/ IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR common /G01OPC/ IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON common /G01OPC/ IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR common /G01OPC/ IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX common /G01OPC/ IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS common /G01OPC/ IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR common /G01OPC/ CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT common /G01OPC/ CLESCE, CLEXTE ! ! Parameter data types. ! integer IDNOOP, IDBEGM, IDENDM, IDBEGP, IDBGPB, IDENDP integer IDMVER, IDMELT, IDDREP, IDCSEL, IDVEXT, IDVINT integer IDCREC, IDCLIN, IDPLIN, IDPMRK, IDTEXT, IDPGON integer IDCARY, IDGDP, IDLBIX, IDLTYP, IDLWID, IDLCLR integer IDMBIX, IDMTYP, IDMSIZ, IDMCLR, IDTBIX, IDTFON integer IDTPRE, IDCHEX, IDCHSP, IDTCLR, IDCHHT, IDCHOR integer IDTXPA, IDTXAL, IDFBIX, IDINTS, IDFCLR, IDHAIX integer IDPTIX, IDFRPT, IDPTBL, IDPTSZ, IDCTBL, IDASFS integer IDESC, IDMESS, IDAPLD, IDBKGC, IDDSCR integer CLDELM, CLMDES, CLPDES, CLCNTL, CLPRIM, CLPRAT integer CLESCE, CLEXTE ! ! Class code parameters for every element. ! integer CLNOOP, CLBEGM, CLENDM, CLBEGP, CLBGPB, CLENDP integer CLMVER, CLMELT, CLDREP, CLCSEL, CLVEXT, CLVINT integer CLCREC, CLCLIN, CLPLIN, CLPMRK, CLTEXT, CLPGON integer CLCARY, CLGDP, CLLBIX, CLLTYP, CLLWID, CLLCLR integer CLMBIX, CLMTYP, CLMSIZ, CLMCLR, CLTBIX, CLTFON integer CLTPRE, CLCHEX, CLCHSP, CLTCLR, CLCHHT, CLCHOR integer CLTXPA, CLTXAL, CLFBIX, CLINTS, CLFCLR, CLHAIX integer CLPTIX, CLFRPT, CLPTBL, CLPTSZ, CLCTBL, CLASFS integer CLESC, CLMESS, CLAPLD, CLBKGC, CLDSCR ! ! Equivalence all individual class code parameters to the single ! code for the class in which the element(s) belong. ! equivalence (CLDELM, CLNOOP,CLBEGM,CLENDM,CLBEGP,CLBGPB,CLENDP) equivalence (CLMDES, CLMVER,CLMELT,CLDREP,CLDSCR) equivalence (CLPDES, CLCSEL,CLVEXT,CLBKGC) equivalence (CLCNTL, CLVINT,CLCREC,CLCLIN) equivalence (CLPRIM, CLPLIN,CLPMRK,CLTEXT,CLPGON,CLCARY,CLGDP) equivalence (CLPRAT, CLLBIX,CLLTYP,CLLWID,CLLCLR,CLMBIX,CLMTYP) equivalence (CLPRAT, CLMSIZ,CLMCLR,CLTBIX,CLTFON,CLTPRE,CLCHEX) equivalence (CLPRAT, CLCHSP,CLTCLR,CLCHHT,CLCHOR,CLTXPA,CLTXAL) equivalence (CLPRAT, CLFBIX,CLINTS,CLFCLR,CLHAIX,CLPTIX,CLFRPT) equivalence (CLPRAT, CLPTBL,CLPTSZ,CLCTBL,CLASFS) equivalence (CLESCE, CLESC), (CLEXTE, CLMESS,CLAPLD) common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! integer NBYTES, DRSET(2) integer G01PBL ! ! CLASS AND ID FOR DRAWING-SET PSEUDO OP. DATA DRSET /-1, 0/ ! ERROR = 0 ! ! PUT OUT VERSION NUMBER ELEMENT. ! NBYTES = 1 + (MINTFW-1)/8 call GPUTNI (CLMVER, IDMVER, NBYTES, ERROR) call GPUTPR (MVERSN, MINTFW, 1, ERROR) if (ERROR /= 0) return ! ! PUT OUT METAFILE DESCRIPTION. ! NBYTES = G01PBL(10,0) call GPUTNI (CLDSCR, IDDSCR, NBYTES, ERROR) call GPUTPS ('NCAR_GKS0A', 10, 10, 0, ERROR) if (ERROR /= 0) return ! ! PUT OUT METAFILE ELEMENTS LIST, DRAWING-SET PSEUDO OP. ! NBYTES = 1 + (MINTFW + 2*MIXFW - 1)/8 call GPUTNI (CLMELT, IDMELT, NBYTES, ERROR) call GPUTPR (1, MINTFW, 1, ERROR) call GPUTPR (DRSET, MIXFW, 2, ERROR) ! ! return end subroutine GPUTNI(OPCL, OPID, NBYTES, GKSERR) ! !******************************************************************************* ! !! GPUTNI sets up the NEXT INSTRUCTION TO BE PLACED IN THE METAFILE. ! ! AFTER THIS call THE GPUTPR OR GPUTPS ROUTINES ARE CALLED TO LOAD THE ! OPERAND LIST. ! ! ! INPUT ! OPCL-THE OPCODE CLASS OF THE INSTRUCTION ! OPID-THE OPCODE ID OF THE INSTRUCTION ! NBYTES-THE NUMBER OF BYTES IN THE OPERAND LIST ! OUTPUT ! GKSERR-THE ERROR STATUS DEFINED BY common ! ! ALL DATA IS TYPE INTEGE UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) ! ! common FOR COMMUNICATION OF INSTRUCTION AND LENGTH ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! SET THE ALLOK STATUS AND THE PARTITION SIZE IN BYTES ! DATA ALLOK,PARSIZ/0,32767/ ! ! ! LOAD THE CURRENT OPCODE CLASS AND ID INTO common ! MCOPCL = OPCL MCOPID = OPID ! ! SET THE CURRENT PARTITION BYTE COUNT AND THE REMAINDER BYTE COUNT ! if (NBYTES > PARSIZ) then MCCBYT = PARSIZ MCNBYT = NBYTES - PARSIZ else MCCBYT = NBYTES MCNBYT = 0 end if ! ! READY THE CURRENT PARTITION FOR THE OPERAND LIST ! call GINLOD(GKSERR) ! ! return TO CALLER ! return end subroutine GPUTPR (BUFFER,BITS,COUNT,GKSERR) ! !******************************************************************************* ! !! GPUTPR puts the OPERAND STRING INTO THE METAFILE BUFFER ! ! ! INPUT ! BUFFER-LIST OF OPERANDS TO MOVE ! BITS-PRECISION OF THE OPERANDS ! COUNT-NUMBER OF OPERANDS IN THE BUFFER ! OUTPUT ! GKSERR-ERROR STATUS ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) DIMENSION BUFFER(*) ! ! OPERAND AND INSTRUCTION COMMUNICATION ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! DATA ALLOK /0/ ! CTEMP = COUNT STRT = 1 ! 10 continue ! ! DETERMINE THE NUMBER OF OPERAND WORDS LEFT IN THE CURRENT PARTITION ! WCBYT = (MCCBYT*8)/BITS ! ! COMPUTE AND MOVE THE ALLOWED NUMBER OF OPERANDS ! MOVIT = MIN0(WCBYT,CTEMP) call GMFLOD(BUFFER(STRT),BITS,MOVIT,GKSERR) if (GKSERR /= ALLOK) return ! ! CHECK IF ANOTHER PARTITION HAS TO BE STARTED ! CTEMP = CTEMP - MOVIT MCCBYT = MCCBYT - (MOVIT*BITS)/8 if (CTEMP /= 0) then ! ! NEW PARTITION REQUIRED SO SET UP THE INSTRUCTION ! STRT = STRT + MOVIT ! TAKE REMAINDER OF BYTES LEFT IN CURRENT PARTITION (THEY MUST BE USED) TCBYT = MCNBYT + MCCBYT call GMPART(TCBYT,GKSERR) if (GKSERR /= ALLOK) return ! ! MOVE MORE OPERANDS INTO NEW PARTITION ! go to 10 end if ! return end subroutine GPUTPS (BUFFER, COUNT1, COUNT2, CONTIN, GKSERR) ! !******************************************************************************* ! !! GPUTPS puts a character string (TYPE CHARACTER) INTO THE METAFILE BUFFER ! ! ! INPUT ! BUFFER-character STRING TO MOVE, MUST BE TYPE CHARACTER ! COUNT1-TOTAL NUMBER OF characterS TO BE PROCESSED ENTIRE SEQUENCE ! COUNT2-NUMBER OF characterS TO BE PROCESS THIS CALL ! CONTIN-IF 0, COUNT1 IS PUT OUT PRIOR TO THE STRING ITSELF; ! IF 1, ONLY THE character STRING IS PUT OUT. ! OUTPUT ! GKSERR-ERROR STATUS ! ! ALL DATA IS TYPE INTEGER UNLESS OTHERWISE INDICATED ! implicit integer (A-Z) DIMENSION CHARS(256) character*(*) BUFFER ! integer BITSPC integer GKASCI ! ! OPERAND AND INSTRUCTION COMMUNICATION ! common /G01INS/ MCODES ,MCONTS , & MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW , & MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL , & MINXVD ,MAXXVD ,MINYVD ,MAXYVD , & MCFRM ,MCOPCL ,MCOPID ,MCNBYT , & MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG , & MBCCHG integer MCODES ,MCONTS integer MVDCFW ,MCIXFW ,MDCCFW ,MIXFW ,MINTFW integer MDCCRG ,MXOFF ,MXSCAL ,MYOFF ,MYSCAL integer MINXVD ,MAXXVD ,MINYVD ,MAXYVD integer MCFRM ,MCOPCL ,MCOPID ,MCNBYT integer MCCBYT ,MCFPP ,MSLFMT ,MEFW ,MCTCHG integer MBCCHG ! ! MAX NUMBER OF characterS TO TEMP BUFFER ! DATA MXCH/256/ ! ! CGM METAFILE USES ASCII, 8 BITS PER character CODE. ! DATA BITSPC/8/, LSFLF/255/ ! ! FIRST call PROCESSING, SET UP COUNT (OR FLAG/COUNT). ! if (CONTIN==0) then ! NUMBER OF BITS FOR PARAMETER, COUNT+STRING, DEPENDS ON ! WHETHER STRING IS LONG OR SHORT FORM. if (COUNT1 <= 254) then NBCCNT = 8 else NBCCNT = 16 call GMFLOD (LSFLG, 8, 1, GKSERR) if (GKSERR /= 0) return end if call GMFLOD (COUNT1, NBCCNT, 1, GKSERR) if (GKSERR /= 0) return end if ! CTEMP = COUNT2 STRT = 1 ! 10 continue ! ! DETERMINE THE NUMBER OF characterS THAT WILL FIT ! IN THE CURRENT PARTITION ! WCBYT = 1 + (MCCBYT*8-1)/BITSPC ! ! COMPUTE AND MOVE THE ALLOWED NUMBER OF characterS. ! MOVIT = MIN0(WCBYT,CTEMP,MXCH) ! ! MOVE THE character CODES TO THE INTEGER BUFFER ! do II = 1,MOVIT NP = STRT + II - 1 ! GET ASCII EQUIVALENT OF character CODE. CHARS(II) = GKASCI (ICHAR(BUFFER(NP:NP))) end do call GMFLOD (CHARS, BITSPC, MOVIT, GKSERR) if (GKSERR /= 0) return ! ! CHECK IF ANOTHER PARTITION HAS TO BE STARTED ! CTEMP = CTEMP - MOVIT MCCBYT = MCCBYT - (MOVIT*BITSPC)/8 if (CTEMP /= 0) then ! ! CHECK IF MORE ROOM IN PARTITION ! if (MCCBYT /= 0) then ! ! MORE ROOM IN THE CURRENT PARTITION ! STRT = STRT + MOVIT else ! ! NEW PARTITION REQUIRED SO SET UP THE INSTRUCTION ! STRT = STRT + MOVIT ! ! TAKE REMAINDER OF BYTES LEFT IN CURRENT PARTITION (THEY MUST BE USED) ! TCBYT = MCNBYT + MCCBYT call GMPART (TCBYT, GKSERR) if (GKSERR /= 0) return end if ! ! MOVE MORE OPERANDS INTO NEW PARTITION ! go to 10 end if return end subroutine GQASF(ERRIND,LASF) ! !******************************************************************************* ! !! GQASF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA ! common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,LASF(13) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) then LASF(1:13) = -1 else LASF( 1) = CLNA LASF( 2) = CLWSCA LASF( 3) = CPLCIA LASF( 4) = CMKA LASF( 5) = CMKSA LASF( 6) = CPMCIA LASF( 7) = CTXFPA LASF( 8) = CCHXPA LASF( 9) = CCHSPA LASF(10) = CTXCIA LASF(11) = CFAISA LASF(12) = CFASIA LASF(13) = CFACIA end if return end subroutine GQCF(WTYPE,ERRIND,NCOLI,COLA,NPCI) ! !******************************************************************************* ! !! GQCF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,NCOLI,COLA,NPCI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 FCODE = -110 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WTYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NCOLI= ID(2) COLA = ID(3) NPCI = ID(4) return 100 continue NCOLI = -1 COLA = -1 NPCI = -1 return end subroutine GQCHB (ERRIND,CHBX,CHBY) ! !******************************************************************************* ! !! GQCHB ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHBX,CHBY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHBX = CCHUP(2) CHBY = -CCHUP(1) else CHBX = 0.0 CHBY = 0.0 end if return end subroutine GQCHH (ERRIND,CHH) ! !******************************************************************************* ! !! GQCHH ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHH ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHH = CCHH else CHH = -1.0 end if return end subroutine GQCHSP(ERRIND,CHSP) ! !******************************************************************************* ! !! GQCHSP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHSP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHSP = CCHSP else CHSP = -1.E20 end if return end subroutine GQCHUP(ERRIND,CHUX,CHUY) ! !******************************************************************************* ! !! GQCHUP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHUX,CHUY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHUX = CCHUP(1) CHUY = CCHUP(2) else CHUX = 0.0 CHUY = 0.0 end if return end subroutine GQCHW (ERRIND,CHW) ! !******************************************************************************* ! !! GQCHW ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHW ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHW = CCHH*CCHXP else CHW = -1.0 end if return end subroutine GQCHXP(ERRIND,CHXP) ! !******************************************************************************* ! !! GQCHXP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real CHXP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CHXP = CCHXP else CHXP = 0.0 end if return end subroutine GQCLIP(ERRIND,CLSW,CLRECT) ! !******************************************************************************* ! !! GQCLIP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,CLSW real CLRECT(4) ! ! CHECK IF GKS IS IN PROPER STATE ! call GZCKST(8,-1,ERRIND) if ( ERRIND == 0 ) then CLSW = CCLIP INT = CNT+1 CLRECT(1) = NTVP(INT,1) CLRECT(2) = NTVP(INT,2) CLRECT(3) = NTVP(INT,3) CLRECT(4) = NTVP(INT,4) else CLSW = -1 CLRECT(1) = -1.0 CLRECT(2) = -1.0 CLRECT(3) = -1.0 CLRECT(4) = -1.0 end if return end subroutine GQCNTN(ERRIND,CTNR) ! !******************************************************************************* ! !! GQCNTN ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,CTNR ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then CTNR = CNT else CTNR = -1 end if return end subroutine GQCR(WKID,COLI,TYPE,ERRIND,RED,GREEN,BLUE) ! !******************************************************************************* ! !! GQCR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,COLI,TYPE,ERRIND real RED,GREEN,BLUE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK ON WORKSTATION ID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND > 0) go to 100 ! CHECK ON TYPE if (TYPE < 0 .or. TYPE > 1) then ERRIND = 2000 go to 100 end if ! ! CHECK ON COLOR INDEX ! if (COLI < 0) then ERRIND = 93 go to 100 end if ! ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN ! call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND > 0) go to 100 ! ! INVOKE THE WORKSTATION INTERFACE ROUTINE ! FCODE = -256 CONT = 0 IL1 = 3 IL2 = 3 ID(1) = WKID ID(2) = COLI ID(3) = TYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if RED = RX(1) GREEN = RX(2) BLUE = RX(3) return 100 continue RED = -1.0 GREEN = -1.0 BLUE = -1.0 return end subroutine GQDSP(WTYPE,ERRIND,DCUNIT,RXP,RYP,LX,LY) ! !******************************************************************************* ! !! GQDSP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,DCUNIT,LX,LY real RXP,RYP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -114 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WTYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if DCUNIT = ID(2) RXP = RX(1) RYP = RY(1) LX = ID(3) LY = ID(4) return 100 continue DCUNIT = -1 RXP = -1.0 RYP = -1.0 LX = -1 LY = -1 return end subroutine GQECI(WKID,N,ERRIND,OL,COLIND) ! !******************************************************************************* ! !! GQECI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,N,ERRIND,OL,COLIND call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK ON WORKSTATION ID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF LIST ELEMENT IS NON-NEGATIVE ! if (N < 0) then ERRIND = 2002 go to 100 end if ! ! INVOKE THE WORKSTATION INTERFACE ROUTINE ! FCODE = -257 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WKID ID(2) = N call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if OL = ID(3) COLIND = ID(4) return 100 continue OL = -1 COLIND = -1 return end subroutine GQEGDP(WTYPE,N,ERRIND,NGDP,GDPL) ! !******************************************************************************* ! !! GQEGDP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,N,ERRIND,NGDP,GDPL call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALIDLID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK THAT REQUESTED ELEMENT NUMBER IS NON-NEGATIVE ! if (N < 0) then ERRIND = 2002 go to 100 end if ! ! INVOKE THE WORKSTATION INTERFACE ROUTINE ! FCODE = -111 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = N call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NGDP = ID(3) GDPL = ID(4) return 100 continue NGDP = -1 GDPL = -1 return end subroutine GQENTN(N,ERRIND,OL,NPRIO) ! !******************************************************************************* ! !! GQENTN ??? ! ! This routine WILL HAVE TO BE SUBSTANTIALLY CHANGED FOR ! GKS LEVELS HIGHER THAN 0A. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N,ERRIND,OL,NPRIO ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 if (N < 0 .or. N > MNT) then ERRIND = 2002 go to 100 end if NPRIO = N OL = MNT+1 return 100 NPRIO = -1 OL = -1 return end subroutine GQEWK(N,ERRIND,NUMBER,WKTYP) ! !******************************************************************************* ! !! GQEWK ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N,ERRIND,NUMBER,WKTYP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF N IS IN BOUNDS ! if (N < 0 .or. N > WK) then ERRIND = 2002 go to 100 end if NUMBER = WK if (N == 0) return WKTYP = LSWK(N) return 100 continue NUMBER = WK WKTYP = -1 return end subroutine GQFACI(ERRIND,COLI) ! !******************************************************************************* ! !! GQFACI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then COLI = CFACI else COLI = -1 end if return end subroutine GQFAF(WTYPE,NI,NH,ERRIND,NIS,IS,NHS,HS,NPFAI) ! !******************************************************************************* ! !! GQFAF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,NI,NH,ERRIND,NIS,IS,NHS,HS,NPFAI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK ON BOUNDS FOR NI AND NH ! if (NI < 0 .or. NI > 3 .or. NH < 0) then ERRIND = 2000 go to 100 end if ! INVOKE INTERFACE FCODE = -112 CONT = 0 IL1 = 3 IL2 = 3 ID(1) = WTYPE ID(2) = NI ID(3) = NH call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NIS = ID(4) IS = ID(5) NHS = ID(6) HS = ID(7) NPFAI = ID(8) return 100 continue NIS = -1 IS = -1 NHS = -1 HS = -1 NPFAI = -1 return end subroutine GQFAI(ERRIND,INDEX) ! !******************************************************************************* ! !! GQFAI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then INDEX = CFAI else INDEX = -1 end if return end subroutine GQFAIS(ERRIND,INTS) ! !******************************************************************************* ! !! GQFAIS ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,INTS ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then INTS = CFAIS else INTS = -1 end if return end subroutine GQFASI(ERRIND,STYLI) ! !******************************************************************************* ! !! GQFASI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,STYLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then STYLI = CFASI else STYLI = -1 end if return end subroutine GQGDP(WTYPE,GDP,ERRIND,NBND,BNDL) ! !******************************************************************************* ! !! GQGDP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,GDP,ERRIND,NBND,BNDL(4) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -113 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = GDP call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NBND = ID(3) BNDL(1) = ID(4) BNDL(2) = ID(5) BNDL(3) = ID(6) BNDL(4) = ID(7) return 100 continue NBND = -1 BNDL(1) = -1 BNDL(2) = -1 BNDL(3) = -1 BNDL(4) = -1 return end subroutine GQLN(ERRIND,LTYPE) ! !******************************************************************************* ! !! GQLN ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,LTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then LTYPE = CLN else LTYPE = -1 end if return end subroutine GQLVKS(ERRIND,LEVEL) ! !******************************************************************************* ! !! GQLVKS ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,LEVEL ! ! CHECK IF GKS IS IN PROPER STATE ! call GZCKST(8,-1,ERRIND) if (ERRIND==0) then LEVEL = 0 else LEVEL = -4 end if return end subroutine GQLWK(WTYPE,ERRIND,MPLBTE,MPMBTE,MTXBTE,MFABTE,MPAI,MCOLI) ! !******************************************************************************* ! !! GQLWK ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,MPLBTE,MPMBTE,MTXBTE,MFABTE,MPAI,MCOLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 MPLBTE = 5 MPMBTE = 5 MTXBTE = 2 MFABTE = 5 MPAI = 1 MCOLI = 256 return 100 continue MPLBTE = -1 MPMBTE = -1 MTXBTE = -1 MFABTE = -1 MPAI = -1 MCOLI = -1 return end subroutine GQLWSC(ERRIND,LWIDTH) ! !******************************************************************************* ! !! GQLWSC ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real LWIDTH ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then LWIDTH = CLWSC else LWIDTH = 0. end if return end subroutine GQMK(ERRIND,MTYPE) ! !******************************************************************************* ! !! GQMK ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,MTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then MTYPE = CMK else MTYPE = -1 end if return end subroutine GQMKSC(ERRIND,MSZSF) ! !******************************************************************************* ! !! GQMKSC ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real MSZSF ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then MSZSF = CMKS else MSZSF = 0 end if return end subroutine GQMNTN(ERRIND,MAXTNR) ! !******************************************************************************* ! !! GQMNTN ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,MAXTNR call GZCKST(8,-1,ERRIND) if (ERRIND==0) then MAXTNR = MNT else MAXTNR = -1 end if return end subroutine GQNT(NTNR,ERRIND,WINDOW,VIEWPT) ! !******************************************************************************* ! !! GQNT ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer NTNR,ERRIND real WINDOW(4),VIEWPT(4) call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 if ( NTNR < 0 .or. NTNR > MNT ) then ERRIND = 50 go to 100 end if INDX = NTNR+1 WINDOW(1) = NTWN(INDX,1) WINDOW(2) = NTWN(INDX,2) WINDOW(3) = NTWN(INDX,3) WINDOW(4) = NTWN(INDX,4) VIEWPT(1) = NTVP(INDX,1) VIEWPT(2) = NTVP(INDX,2) VIEWPT(3) = NTVP(INDX,3) VIEWPT(4) = NTVP(INDX,4) return 100 continue WINDOW(1) = 0. WINDOW(2) = 0. WINDOW(3) = 0. WINDOW(4) = 0. VIEWPT(1) = -1. VIEWPT(2) = -1. VIEWPT(3) = -1. VIEWPT(4) = -1. return end subroutine GQOPS(OPSTA) ! !******************************************************************************* ! !! GQOPS ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer OPSTA OPSTA = OPS return end subroutine GQOPWK(N,ERRIND,OL,WKID) ! !******************************************************************************* ! !! GQOPWK ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N,ERRIND,OL,WKID call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF N IS IN BOUNDS ! if (N < 0 .or. N > NOPWK) then ERRIND = 2002 go to 100 end if OL = NOPWK if (N == 0) return WKID = SOPWK(N) return 100 continue OL = NOPWK WKID = -1 return end subroutine GQPA(ERRIND,PWX,PWY,PHX,PHY) ! !******************************************************************************* ! !! GQPA ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real PWX,PWY,PHX,PHY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then ! ! Pattern width and height vectors will always be ! along the coordinate axes since no metafile interpretation ! functions are in the package. ! PWX = CPA(1) PWY = 0. PHX = 0. PHY = CPA(2) else PWX = -1. PWY = -1. PHX = -1. PHY = -1. end if return end subroutine GQPAF(WTYPE,ERRIND,NPPAI) ! !******************************************************************************* ! !! GQPAF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,NPPAI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -115 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WTYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NPPAI = ID(2) return 100 continue NPPAI = -1 return end subroutine GQPARF(ERRIND,RFX,RFY) ! !******************************************************************************* ! !! GQPARF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND real RFX,RFY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then RFX = CPARF(1) RFY = CPARF(2) else RFX = -1.E20 RFY = -1.E20 end if return end subroutine GQPCR(WTYPE,PCI,ERRIND,RED,GREEN,BLUE) ! !******************************************************************************* ! !! GQPCR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PCI,ERRIND real RED,GREEN,BLUE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF COLOR INDEX IS VALID ! if (PCI < 0) then ERRIND = 93 go to 100 end if ! INVOKE INTERFACE FCODE = -116 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = PCI call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if RED = RX(1) GREEN = RX(2) BLUE = RX(3) return 100 continue RED = -1. GREEN = -1. BLUE = -1. return end subroutine GQPFAR(WTYPE,PFAI,ERRIND,STYLE,STYLID,COLI) ! !******************************************************************************* ! !! GQPFAR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PFAI,ERRIND,STYLE,STYLID,COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF INDEX IS POSITIVE ! if (PFAI < 0) then ERRIND = 80 go to 100 end if ! INVOKE INTERFACE FCODE = -117 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = PFAI call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if STYLE = ID(3) STYLID = ID(4) COLI = ID(5) return 100 continue STYLE = -1 STYLID = -1 COLI = -1 return end subroutine GQPLCI(ERRIND,COLI) ! !******************************************************************************* ! !! GQPLCI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then COLI = CPLCI else COLI = -1 end if return end subroutine GQPLF(WTYPE,N,ERRIND,NLT,LT,NLW,NOMLW,RLWMIN,RLWMAX,NPPLI) ! !******************************************************************************* ! !! GQPLF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,N,ERRIND,NLT,LT,NLW,NPPLI real NOMLW,RLWMIN,RLWMAX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF INDEX NON-NEGATIVE ! if (N < 0) then ERRIND = 2002 go to 100 end if ! INVOKE INTERFACE FCODE = -118 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = N call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NLT = ID(3) LT = ID(4) NLW = ID(5) NPPLI = ID(6) NOMLW = RX(1) RLWMIN = RX(2) RLWMAX = RX(3) return 100 continue NLT = -1 LT = -1 NLW = -1 NPPLI = -1 NOMLW = -1. RLWMIN = -1. RLWMAX = -1. return end subroutine GQPLI(ERRIND,INDEX) ! !******************************************************************************* ! !! GQPLI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then INDEX = CPLI else INDEX = -1 end if return end subroutine GQPMCI(ERRIND,COLI) ! !******************************************************************************* ! !! GQPMCI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then COLI = CPMCI else COLI = -1 end if return end subroutine GQPMF(WTYPE,N,ERRIND,NMT,MT,NMS,NOMMS,RMSMIN,RMSMAX,NPPMI) ! !******************************************************************************* ! !! GQPMF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,N,ERRIND,NMT,MT,NMS,NPPMI real NOMMS,RMSMIN,RMSMAX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF INDEX IS NON-NEGATIVE ! if (N < 0) then ERRIND = 2002 go to 100 end if ! INVOKE INTERFACE FCODE = -119 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = N call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NMT = ID(3) MT = ID(4) NMS = ID(5) NPPMI = ID(6) NOMMS = RX(1) RMSMIN = RX(2) RMSMAX = RX(3) return 100 continue NMT = -1 MT = -1 NMS = -1 NPPMI = -1 NOMMS = -1. RMSMIN = -1. RMSMAX = -1. return end subroutine GQPMI(ERRIND,INDEX) ! !******************************************************************************* ! !! GQPMI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then INDEX = CPMI else INDEX = -1 end if return end subroutine GQPPAR(WTYPE,PPAI,NMX,MMX,ERRIND,N,M,PARRAY) ! !******************************************************************************* ! !! GQPPAR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PPAI,NMX,MMX,ERRIND,N,M,PARRAY(NMX,MMX) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK IF INDEX IS POSITIVE ! if (PPAI < 1) then ERRIND = 79 go to 100 end if ! INVOKE INTERFACE FCODE = -120 CONT = 0 IL1 = 4 IL2 = 4 ID(1) = WTYPE ID(2) = PPAI ID(3) = NMX ID(4) = MMX call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if N = ID(5) M = ID(6) ! ! BRING OVER PATTERN ARRAY ! INDX = (N*M-1)/128 if (INDX==0) then call GZFMWK INDX = 0 do 200 J=1,M do 201 I=1,N INDX = INDX+1 PARRAY(I,J) = ID(INDX) 201 continue 200 continue else call GZFMWK INDX = 0 do 202 J=1,M do 203 I=1,N INDX = INDX+1 PARRAY(I,J) = ID(INDX) JMD = mod ( INDX,128) if (JMD==0 .and. CONT==1) then call GZFMWK INDX = 0 end if 203 continue 202 continue end if return 100 continue N = -1 M = -1 PARRAY(1,1) = -1 return end subroutine GQPPLR(WTYPE,PLI,ERRIND,LNTYPE,LWIDTH,COLI) ! !******************************************************************************* ! !! GQPPLR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PLI,ERRIND,LNTYPE,COLI real LWIDTH ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK THAT INDEX IS VALID ! if (PLI < 1) then ERRIND = 60 go to 100 end if ! INVOKE INTERFACE FCODE = -121 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = PLI call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if LNTYPE = ID(3) COLI = ID(4) LWIDTH = RX(1) return 100 continue LNTYPE = -1 COLI = -1 LWIDTH = -1. return end subroutine GQPPMR(WTYPE,PMI,ERRIND,MKTYPE,MKSSCF,COLI) ! !******************************************************************************* ! !! GQPPMR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PMI,ERRIND,MKTYPE,COLI real MKSSCF ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK THAT INDEX IS VALID ! if (PMI <= 0) then ERRIND = 66 go to 100 end if ! INVOKE INTERFACE FCODE = -122 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = PMI call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if MKTYPE = ID(3) COLI = ID(4) MKSSCF = RX(1) return 100 continue MKTYPE = -1 COLI = -1 MKSSCF = -1. return end subroutine GQPTXR(WTYPE,PTXI,ERRIND,FONT,PREC,CHARXP,CHARSP,COLI) ! !******************************************************************************* ! !! GQPTXR ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,PTXI,ERRIND,FONT,PREC,COLI real CHARXP,CHARSP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT WORKSTATION TYPE IS VALIDALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! ! CHECK THAT INDEX IS POSITIVE ! if (PTXI < 1) then ERRIND = 72 go to 100 end if ! INVOKE INTERFACE FCODE = -123 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = PTXI call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if FONT = ID(3) PREC = ID(4) COLI = ID(5) CHARXP = RX(1) CHARSP = RX(2) return 100 continue FONT = -1 PREC = -1 COLI = -1 CHARXP = -1. CHARSP = -1.E20 return end subroutine GQPX(WKID,PX,PY,ERRIND,COLI) ! !******************************************************************************* ! !! GQPX ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,COLI real PX,PY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -290 CONT = 0 IL1 = 1 IL2 = 1 RL1 = 2 RL2 = 2 ID(1) = WKID call GZW2NX(1,PX,PXD) call GZW2NY(1,PY,PYD) RX(1) = PXD RX(2) = PYD call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if COLI = ID(2) return 100 continue COLI = -1 return end subroutine GQPXA(WKID,PX,PY,DIMX,DIMY,NCS,NRS,DX,DY,ERRIND,INVVAL,COLIA) ! !******************************************************************************* ! !! GQPXA ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,DX,DY,DIMX,ERRIND,INVVAL,COLIA(DIMX,DY) real PX,PY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF ARRAY IS LARGE ENOUGH if (DX > DIMX .or. DY > DIMY) then ERRIND = 2001 go to 100 end if ! INVOKE INTERFACE FCODE = -291 CONT = 0 IL1 = 7 IL2 = 7 RL1 = 1 RL2 = 1 ID(1) = WKID ID(2) = DIMX ID(3) = DIMY ID(4) = NCS ID(5) = NRS ID(6) = DX ID(7) = DY call GZW2NX(1,PX,PXD) call GZW2NY(1,PY,PYD) RX(1) = PXD RY(1) = PYD call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if INVVAL = ID(8) ! ! BRING OVER THE COLOR INDEX ARRAY ! INDX = (DX*DY-1)/128 if (INDX==0) then call GZFMWK INDX = 0 do J=1,DY do I=1,DX INDX = INDX+1 COLIA(I,J) = ID(INDX) end do end do else call GZFMWK INDX = 0 do 202 J=1,DY do 203 I=1,DX INDX = INDX+1 COLIA(I,J) = ID(INDX) JMD = mod ( INDX,128) if (JMD==0 .and. CONT==1) then call GZFMWK INDX = 0 end if 203 continue 202 continue end if return 100 continue INVVAL = -1 COLIA(1,1) = -1 return end subroutine GQPXAD(WKID,PX,PY,QX,QY,ERRIND,N,M) ! !******************************************************************************* ! !! GQPXAD ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,N,M real PX,PY,QX,QY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -292 CONT = 0 IL1 = 1 IL2 = 1 RL1 = 2 RL2 = 2 ID(1) = WKID call GZW2NX(1,PX,PXD) call GZW2NY(1,PY,PYD) call GZW2NX(1,QX,QXD) call GZW2NY(1,QY,QYD) RX(1) = PXD RY(1) = PYD RX(2) = QXD RX(2) = QYD call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if N = ID(2) M = ID(3) return 100 continue N = -1 M = -1 return end subroutine GQTXAL(ERRIND,TXALH,TXALV) ! !******************************************************************************* ! !! GQTXAL ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,TXALH,TXALV ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then TXALH = CTXAL(1) TXALV = CTXAL(2) else TXALH = -1 TXALV = -1 end if return end subroutine GQTXCI(ERRIND,COLI) ! !******************************************************************************* ! !! GQTXCI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then COLI = CTXCI else COLI = -1 end if return end subroutine GQTXF(WTYPE,N,ERRIND,NFPP,FONT,PREC,NCHH,MINCHH, & MAXCHH,NCHX,MINCHX,MAXCHX,NPTXI) ! !******************************************************************************* ! !! GQTXF ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,N,ERRIND,NFPP,FONT,PREC,NCHH,NCHX,NPTXI real MINCHH,MAXCHH,MINCHX,MAXCHX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -124 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WTYPE ID(2) = N call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if NFPP = ID(3) FONT = ID(4) PREC = ID(5) NCHH = ID(6) NCHX = ID(7) NPTXI = ID(8) MINCHH = RX(1) MAXCHH = RX(2) MINCHX = RX(3) MAXCHX = RX(4) return 100 continue NFPP = -1 FONT = -1 PREC = -1 NCHH = -1 NCHX = -1 NPTXI = -1 MINCHH = 1.E20 MAXCHH = -1.E20 MINCHX = 1.E20 MAXCHX = -1.E20 return end subroutine GQTXFP(ERRIND,FONT,PREC) ! !******************************************************************************* ! !! GQTXFP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,FONT,PREC ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then FONT = CTXFP(1) PREC = CTXFP(2) else FONT = -1 PREC = -1 end if return end subroutine GQTXI(ERRIND,INDEX) ! !******************************************************************************* ! !! GQTXI ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then INDEX = CTXI else INDEX = -1 end if return end subroutine GQTXP(ERRIND,TXP) ! !******************************************************************************* ! !! GQTXP ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ERRIND,TXP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND==0) then TXP = CTXP else TXP = -1 end if return end subroutine GQTXX(WKID,PX,PY,STRX,ERRIND,CPX,CPY,TXEXPX,TXEXPY) ! !******************************************************************************* ! !! GQTXX ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND real PX,PY,CPX,CPY,TXEXPX(4),TXEXPY(4) character*(*) STRX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -293 IL1 = 6 IL2 = 6 RL1 = 7 RL2 = 7 ID(1) = WKID ! INDIVIDUAL SETTINGS ID(2) = CTXFP(1) ID(3) = CTXFP(2) ID(4) = CTXP ID(5) = CTXAL(1) ID(6) = CTXAL(2) ! BUNDLED SETTINGS ID(7) = CTXI ID(8) = CTXFPA ID(9) = CCHXPA ID(8) = CCHSPA RX(1) = CCHXP RX(2) = CCHSP RX(3) = CCHH RX(4) = CCHUP(1) RX(5) = CCHUP(2) call GZW2NX(1,PX,PXD) call GZW2NY(1,PY,PYD) RX(6) = PXD RX(7) = PYD ! PUT OUT character STRING ALONG WITH OTHER INTERFACE VARIABLES call GZPUTS(STRX,RERR) if (RERR /= 0) then ERRIND = RERR go to 100 end if ! ! RECIEVE DESIRED INFORMATION IN NDC SPACE, AND CONVERT TO WC ! call GZN2WX(1,RX(8),CPX) call GZN2WY(1,RX(9),CPY) call GZN2WX(1,RX(10),TXEXPX(1)) call GZN2WX(1,RX(11),TXEXPX(2)) call GZN2WX(1,RX(12),TXEXPX(3)) call GZN2WX(1,RX(13),TXEXPX(4)) call GZN2WY(1,RX(14),TXEXPY(1)) call GZN2WY(1,RX(15),TXEXPY(2)) call GZN2WY(1,RX(16),TXEXPY(3)) call GZN2WY(1,RX(17),TXEXPY(4)) return 100 continue CPX = 1.E20 CPY = 1.E20 TXEXPX(1) = 0. TXEXPX(2) = 0. TXEXPX(3) = 0. TXEXPX(4) = 0. TXEXPY(1) = 0. TXEXPY(2) = 0. TXEXPY(3) = 0. TXEXPY(4) = 0. return end subroutine GQWKC(WKID,ERRIND,CONID,WTYPE) ! !******************************************************************************* ! !! GQWKC ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,CONID,WTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -226 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if CONID = ID(2) WTYPE = ID(3) return 100 continue CONID = -1 WTYPE = -1 return end subroutine GQWKCA(WTYPE,ERRIND,WKCAT) ! !******************************************************************************* ! !! GQWKCA ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,WKCAT ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -127 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WTYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if WKCAT = ID(2) return 100 continue WKCAT = -1 return end subroutine GQWKCL(WTYPE,ERRIND,VRTYPE) ! !******************************************************************************* ! !! GQKWCL ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WTYPE,ERRIND,VRTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION TYPE IS VALID call GZCKWK(22,-1,IDUM,WTYPE,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -128 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WTYPE call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if VRTYPE = ID(2) return 100 continue VRTYPE = -1 return end subroutine GQWKDU(WKID,ERRIND,DEFMOD,REGMOD,DEMPTY,NFRAME) ! !******************************************************************************* ! !! GQWKDU ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,DEFMOD,REGMOD,DEMPTY,NFRAME ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -200 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if DEFMOD = ID(2) REGMOD = ID(3) DEMPTY = ID(4) NFRAME = ID(5) return 100 continue DEFMOD = -1 REGMOD = -1 DEMPTY = -1 NFRAME = -1 return end subroutine GQWKS(WKID,ERRIND,STATE) ! !******************************************************************************* ! !! GQWKS ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,STATE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -201 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if STATE = ID(2) return 100 continue STATE = -1 return end subroutine GQWKT(WKID,ERRIND,TUS,RWINDO,CWINDO,RVIEWP,CVIEWP) ! !******************************************************************************* ! !! GQWKT ??? ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,ERRIND,TUS real RWINDO(4),CWINDO(4),RVIEWP(4),CVIEWP(4) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,-1,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK THAT THE WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,-1,WKID,IDUM,ERRIND) if (ERRIND /= 0) go to 100 ! INVOKE INTERFACE FCODE = -202 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID call GZTOWK if (RERR /= 0) then ERRIND = RERR go to 100 end if TUS = ID(2) RWINDO(1) = RX(1) RWINDO(2) = RX(2) RWINDO(3) = RX(3) RWINDO(4) = RX(4) CWINDO(1) = RX(5) CWINDO(2) = RX(6) CWINDO(3) = RX(7) CWINDO(4) = RX(8) RVIEWP(1) = RY(1) RVIEWP(2) = RY(2) RVIEWP(3) = RY(3) RVIEWP(4) = RY(4) CVIEWP(1) = RY(5) CVIEWP(2) = RY(6) CVIEWP(3) = RY(7) CVIEWP(4) = RY(8) return 100 continue TUS = -1 RWINDO(1) = 0. RWINDO(2) = 0. RWINDO(3) = 0. RWINDO(4) = 0. CWINDO(1) = 0. CWINDO(2) = 0. CWINDO(3) = 0. CWINDO(4) = 0. RVIEWP(1) = 0. RVIEWP(2) = 0. RVIEWP(3) = 0. RVIEWP(4) = 0. CVIEWP(1) = 0. CVIEWP(2) = 0. CVIEWP(3) = 0. CVIEWP(4) = 0. return end subroutine GRDITM (WKID,MLDR,LDR,DATREC) ! !******************************************************************************* ! !! GSDITM ??? ! integer ERDITM PARAMETER (ERDITM=103) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,LDR character*80 DATREC(MLDR) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,ERDITM,IER) if (IER /= 0) return ! CHECK IF WORKSTATION ID IS VALID call GZCKWK(20,ERDITM,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY OPEN call GZCKWK(25,ERDITM,WKID,IDUM,IER) if (IER /= 0) return ! ! SET FUNCTION CODE AND PUT OUT WKID, TYPE, LDR, AND THE DATA ! RECORD IN STR. ! FCODE = 103 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WKID ID(2) = MLDR call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ERDITM,ERF) ers = 0 return else ! ! READ returnED DATA RECORD ! LDR = ID(3) ! ! CHECK ON returnED LENGTH ! if (LDR > MLDR) then ers = 1 call gerhnd ( 2001,ERDITM,ERF) ers = 0 return end if DATREC(1) = STR(1:80) if (LDR > 1) then INDX = 1 200 continue INDX = INDX+1 call GZFMWK DATREC(INDX) = STR(1:80) if (CONT==0 .or. INDX >= LDR) go to 201 go to 200 201 continue end if end if return end subroutine GSASF(LASF) ! !******************************************************************************* ! !! GSASF ??? ! integer ESASF PARAMETER (ESASF=41) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer LASF(13) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESASF,IER) if (IER /= 0) return ! CHECK IF FLAGS ARE 0 OR 1 do 200 I=1,13 if (LASF(I) /= 0 .and. LASF(I).NE.1) then ers = 1 call gerhnd ( 2000,ESASF,ERF) ers = 0 end if 200 continue ! ! SET THE CURRENT ASPECT SOURCE FLAGS IN THE GKS STATE LIST ! CLNA = LASF( 1) CLWSCA = LASF( 2) CPLCIA = LASF( 3) CMKA = LASF( 4) CMKSA = LASF( 5) CPMCIA = LASF( 6) CTXFPA = LASF( 7) CCHXPA = LASF( 8) CCHSPA = LASF( 9) CTXCIA = LASF(10) CFAISA = LASF(11) CFASIA = LASF(12) CFACIA = LASF(13) ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 43 CONT = 0 IL1 = 13 IL2 = 13 do 201 I=1,13 ID(I) = LASF(I) 201 continue call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESASF,ERF) ers = 0 end if return end subroutine GSCHH (CHH ) ! !******************************************************************************* ! !! GSCHH ??? ! integer ESCHH PARAMETER (ESCHH=31) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real CHH ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESCHH,IER) if (IER /= 0) return ! ! CHECK THAT THE character HEIGHT IS VALID ! if (CHH <= 0.) then ers = 1 call gerhnd ( 78,ESCHH,ERF) ers = 0 return end if ! ! SET THE CURRENT character HEIGHT IN THE GKS STATE LIST ! (CHH REMAINS IN WORLD COORDINATES HERE) ! CCHH = CHH ! ! TRANSFORM CHH TO NDC SPACE BEFORE INVOKING THE INTERFACE ! ICNT = CNT+1 CHHN = CHH*(NTVP(ICNT,4)-NTVP(ICNT,3)) & /(NTWN(ICNT,4)-NTWN(ICNT,3)) ! ! INVOKE THE WORKSTATION INTERFACE. TWO REAL VECTORS ARE ! PASSED THROUGH THE INTERFACE. THE FIRST VECTOR IS ! PASSED VIA (RX(1),RY(1)) AND IS A VECTOR PARALLEL TO THE ! CURRENT character UP VECTOR WITH LENGTH EQUAL TO THE ! RECENTLY DEFINED character HEIGHT (THE CHARACTER HEIGHT ! HAVING BEEN TRANSFORMED TO NDC SPACE). THE SECOND VECTOR ! IS PASSED VIA (RX(2),RY(2)) AND IS A VECTOR PERPENDICULAR ! TO THE HEIGHT VECTOR IN THE DIRECTION OF THE character ! BASELINE WITH THE SAME LENGTH AS THE character HEIGHT VECTOR. ! FCODE = 34 CONT = 0 RL1 = 2 RL2 = 2 SCL = CHHN/SQRT(CCHUP(1)*CCHUP(1)+CCHUP(2)*CCHUP(2)) RX(1) = SCL*CCHUP(1) RY(1) = SCL*CCHUP(2) RX(2) = RY(1) RY(2) = -RX(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCHH,ERF) ers = 0 end if return end subroutine GSCHSP (CHSP) ! !******************************************************************************* ! !! GSCHSP ??? ! integer ESCHSP PARAMETER (ESCHSP=29) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real CHSP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESCHSP,IER) if (IER /= 0) return ! ! SET THE CURRENT character SPACING IN THE GKS STATE LIST ! CCHSP = CHSP ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 32 CONT = 0 RL1 = 1 RL2 = 1 RX(1) = CHSP call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCHSP,ERF) ers = 0 end if return end subroutine GSCHUP (CHUX,CHUY) ! !******************************************************************************* ! !! GSCHUP ??? ! integer ESCHUP PARAMETER (ESCHUP=32) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real CHUX,CHUY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESCHUP,IER) if (IER /= 0) return ! ! CHECK THAT THE VECTOR IS NON-ZERO ! if (CHUX==0 .and. CHUY==0) then ers = 1 call gerhnd ( 79,ESCHUP,ERF) ers = 0 return end if ! ! SET THE CURRENT character UP VECTOR IN THE GKS STATE LIST ! (THIS VECTOR REMAINS IN WORLD COORDINATES HERE) ! CCHUP(1) = CHUX CCHUP(2) = CHUY ! ! TRANSFORM CCHH TO NDC SPACE BEFORE INVOKING THE INTERFACE ! ICNT = CNT+1 CHHN = CCHH*(NTVP(ICNT,4)-NTVP(ICNT,3)) & /(NTWN(ICNT,4)-NTWN(ICNT,3)) ! ! INVOKE THE WORKSTATION INTERFACE. TWO REAL VECTORS ARE ! PASSED THROUGH THE INTERFACE. THE FIRST VECTOR IS ! PASSED VIA (RX(1),RX(2)) AND IS A VECTOR PARALLEL TO THE ! CURRENT character UP VECTOR WITH LENGTH EQUAL TO THE ! character HEIGHT (THE CHARACTER HEIGHT ! HAVING BEEN TRANSFORMED TO NDC SPACE). THE SECOND VECTOR ! IS PASSED VIA (RX(2),RY(2)) AND IS A VECTOR PERPENDICULAR ! TO THE HEIGHT VECTOR IN THE DIRECTION OF THE character ! BASELINE WITH THE SAME LENGTH AS THE character HEIGHT VECTOR. ! FCODE = 34 CONT = 0 RL1 = 2 RL2 = 2 SCL = CHHN/SQRT(CCHUP(1)*CCHUP(1)+CCHUP(2)*CCHUP(2)) RX(1) = SCL*CCHUP(1) RY(1) = SCL*CCHUP(2) RX(2) = RY(1) RY(2) = -RX(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCHUP,ERF) ers = 0 end if return end subroutine GSCHXP (CHXP) ! !******************************************************************************* ! !! GSCHXP ??? ! integer ESCHXP PARAMETER (ESCHXP=28) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real CHXP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESCHXP,IER) if (IER /= 0) return ! ! CHECK IF THE EXPANSION FACTOR IS VALID ! if (CHXP <= 0.) then ers = 1 call gerhnd ( 77,ESCHXP,ERF) ers = 0 return end if ! ! SET THE CURRENT EXPANSION FACTOR IN THE GKS STATE LIST ! CCHXP = CHXP ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 31 CONT = 0 RL1 = 1 RL2 = 1 RX(1) = CHXP call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCHXP,ERF) ers = 0 end if return end subroutine gsclip ( CLSW ) ! !******************************************************************************* ! !! GSCLIP sets the clipping indicator. ! ! ! Parameters: ! ! Input, integer CLSW, the clipping indicator. ! 0 = ? ! 1 = ? ! integer ESCLIP PARAMETER (ESCLIP=53) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer CLSW ! ! CHECK IF GKS IS IN PROPER STATE ! call GZCKST(8,ESCLIP,IER) if (IER /= 0) return ! ! CHECK THAT CLSW IS IN RANGE ! if ( CLSW < 0 .or. CLSW > 1 ) then ers = 1 call gerhnd ( 2000,ESCLIP,ERF) ers = 0 return end if ! ! SET CLIPPING INDICATOR IN THE GKS STATE LIST ! CCLIP = CLSW ! ! INVOKE THE WORKSTATION INTERFACE. ! SEND THE CLIPPING INDICATOR IN ID(1) AND ! THE VIEWPORT OF THE CURRENT NORMALIZATION TRANSFORMATION ! IN RX,RY ! FCODE = 61 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = CLSW RL1 = 2 RL2 = 2 ICNT = CNT+1 RX(1) = NTVP(ICNT,1) RX(2) = NTVP(ICNT,2) RY(1) = NTVP(ICNT,3) RY(2) = NTVP(ICNT,4) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCLIP,ERF) ers = 0 end if return end subroutine GSCR (WKID,CI,CR,CG,CB) ! !******************************************************************************* ! !! GSCR ??? ! integer WKID,CI,ESCR real CR,CG,CB PARAMETER (ESCR=48) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! CHECK IF GKS IS IN PROPER STATE call GZCKST(7,ESCR,IER) if (IER /= 0) return ! CHECK IF WORKSTATION ID IS VALID call GZCKWK(20,ESCR,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE WORKSTATION IS CURRENTLY OPEN call GZCKWK(25,ESCR,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK IF COLOR INDEX IS NON-NEGATIVE ! if (CI < 0) then ers = 1 call gerhnd ( 92,ESCR,ERF) ers = 0 return end if ! ! CHECK IF COLORS ARE IN RANGE ! if (CR < 0. .or. CR > 1. .or. CG < 0..OR.CG > 1..OR.CB < 0..OR.CB & > 1.) then ers = 1 call gerhnd ( 96,ESCR,ERF) ers = 0 return end if ! ! SET FUNCTION CODE AND PUT OUT WKID, CI, AND COLORS. ! FCODE = 56 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WKID ID(2) = CI RL1 = 3 RL2 = 3 RX(1) = CR RX(2) = CG RX(3) = CB call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESCR,ERF) ers = 0 end if return end subroutine GSELNT (TNR) ! !******************************************************************************* ! !! GSELNT ??? ! integer ESELNT PARAMETER (ESELNT=52) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TNR ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESELNT,IER) if (IER /= 0) return ! ! CHECK THAT THE NORMALIZATION TRANSFORMATION NUMBER IS VALID ! if ( TNR < 0 .or. TNR > MNT ) then ers = 1 call gerhnd ( 50, ESELNT, ERF ) ers = 0 return end if ! ! SET THE CURRENT NORMALIZATION TRANSFORMATION VARIABLE IN ! THE GKS STATE LIST ! CNT = TNR ! ! REESTABLISH character HEIGHT AND UP VECTOR, AND ! PATTERN SIZE AND REFERENCE POINT, AND CLIPPING RECTANGLE ! call GSCHH(CCHH) call GSCHUP(CCHUP(1),CCHUP(2)) call GSPA(CPA(1),CPA(2)) call GSPARF(CPARF(1),CPARF(2)) call gsclip ( CCLIP ) return end subroutine gsfaci (COLI) ! !******************************************************************************* ! !! GSFACI ??? ! integer ESFACI PARAMETER (ESFACI=38) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESFACI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID ! if (COLI < 0) then ers = 1 call gerhnd ( 92,ESFACI,ERF) ers = 0 return end if ! ! SET THE CURRENT COLOR INDEX IN THE GKS STATE LIST ! CFACI = COLI ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 40 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = COLI call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESFACI,ERF) ers = 0 end if return end subroutine GSFAI (INDEX) ! !******************************************************************************* ! !! GSFAI ??? ! integer ESFAI PARAMETER (ESFAI=35) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESFAI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS POSITIVE (0A SPECIFIC) ! if (INDEX <= 0 .or. INDEX > 5) then ers = 1 call gerhnd ( 80,ESFAI,ERF) ers = 0 return end if ! ! SET THE CURRENT INDEX IN THE GKS STATE LIST ! CFAI = INDEX ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 37 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = INDEX call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESFAI,ERF) ers = 0 end if return end subroutine GSFAIS (INTS) ! !******************************************************************************* ! !! GSFAIS ??? ! integer ESFAIS PARAMETER (ESFAIS=36) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer INTS ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESFAIS,IER) if (IER /= 0) return ! ! CHECK THAT INTS IS IN RANGE ! if (INTS < 0 .or. INTS > 3) then ers = 1 call gerhnd ( 2000,ESFAIS,ERF) ers = 0 return end if ! ! SET THE CURRENT INDEX IN THE GKS STATE LIST ! CFAIS = INTS ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 38 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = INTS call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESFAIS,ERF) ers = 0 end if return end subroutine GSFASI (STYLI) ! !******************************************************************************* ! !! GSFASI ??? ! integer ESFASI PARAMETER (ESFASI=37) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer STYLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESFASI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID ! if (STYLI <= 0) then ers = 1 call gerhnd ( 84,ESFASI,ERF) ers = 0 return end if ! ! SET THE CURRENT INDEX IN THE GKS STATE LIST ! CFASI = STYLI ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 39 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = STYLI call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESFASI,ERF) ers = 0 end if return end subroutine GSLN (LTYPE) ! !******************************************************************************* ! !! GSLN ??? ! integer ESLN PARAMETER (ESLN=19) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer LTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESLN,IER) if (IER /= 0) return ! ! CHECK THAT THE LINETYPE IS VALID ! if (LTYPE <= 0) then ers = 1 call gerhnd ( 63,ESLN,ERF) ers = 0 return end if ! ! SET THE CURRENT LINETYPE ! CLN = LTYPE ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 22 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = LTYPE call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESLN,ERF) ers = 0 end if return end subroutine GSLWSC (LWIDTH) ! !******************************************************************************* ! !! GSLWSC ??? ! integer ESLWSC PARAMETER (ESLWSC=20) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real LWIDTH ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESLWSC,IER) if (IER /= 0) return ! ! CHECK THAT THE SCALE FACTOR IS VALID ! if (LWIDTH <= 0.) then ers = 1 call gerhnd ( 65,ESLWSC,ERF) ers = 0 return end if ! ! SET THE CURRENT LINEWIDTH SCALE FACTOR ! CLWSC = LWIDTH ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 23 CONT = 0 RL1 = 1 RL2 = 1 RX(1) = LWIDTH call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESLWSC,ERF) ers = 0 end if return end subroutine GSMK (MTYPE) ! !******************************************************************************* ! !! GSMK ??? ! integer ESMK PARAMETER (ESMK=23) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer MTYPE ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESMK,IER) if (IER /= 0) return ! ! CHECK THAT THE MARKER TYPE IS POSITIVE ! if (MTYPE <= 0) then ers = 1 call gerhnd ( 69,ESMK,ERF) ers = 0 return end if ! ! SET THE CURRENT MARKER TYPE IN THE GKS STATE LIST ! CMK = MTYPE ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 26 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = MTYPE call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESMK,ERF) ers = 0 end if return end subroutine GSMKSC (MSZSF) ! !******************************************************************************* ! !! GSMKSC ??? ! integer ESMKSC PARAMETER (ESMKSC=24) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real MSZSF ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESMKSC,IER) if (IER /= 0) return ! ! SET THE CURRENT MARKER SCALE FACTOR IN THE GKS STATE LIST ! CMKS = MSZSF ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 27 CONT = 0 RL1 = 1 RL2 = 1 RX(1) = MSZSF call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESMKSC,ERF) ers = 0 end if return end subroutine GSPA (SZX,SZY) ! !******************************************************************************* ! !! GSPA ??? ! integer ESPA PARAMETER (ESPA=39) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real SZX,SZY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPA,IER) if (IER /= 0) return ! ! CHECK THAT SIZE SPECIFICATIONS ARE VALID ! if (SZX <= 0. .or. SZY <= 0.) then ers = 1 call gerhnd ( 87,ESPA,ERF) ers = 0 return end if ! ! SET THE CURRENT PATTERN SIZE VARIABLES ! IN THE GKS STATE LIST (THESE REMAIN IN WORLD COORDINATES) ! CPA(1) = SZX CPA(2) = SZY ! ! TRANSFORM PATTERN SIZES TO NDC SPACE ! call GZW2NX(1,SZX,SZXN) call GZW2NY(1,SZY,SZYN) ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 41 CONT = 0 RL1 = 1 RL2 = 1 RX(1) = SZXN RY(1) = SZYN call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPA,ERF) ers = 0 end if return end subroutine GSPARF (RFX,RFY) ! !******************************************************************************* ! !! GSPARF ??? ! integer ESPARF PARAMETER (ESPARF=40) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real RFX,RFY ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPARF,IER) if (IER /= 0) return ! ! SET THE CURRENT PATTERN REFERENCE POINT ! IN THE GKS STATE LIST (THESE REMAIN IN WORLD COORDINATES) ! CPARF(1) = RFX CPARF(2) = RFY ! ! TRANSFORM PATTERN SIZES TO NDC SPACE ! call GZW2NX(1,RFX,RFXN) call GZW2NY(1,RFY,RFYN) ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 42 CONT = 0 RL1 = 2 RL2 = 2 RX(1) = RFXN RX(2) = RFYN call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPARF,ERF) ers = 0 end if return end subroutine GSPLCI (COLI) ! !******************************************************************************* ! !! GSPLCI ??? ! integer ESPLCI PARAMETER (ESPLCI=21) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPLCI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID ! if (COLI < 0) then ers = 1 call gerhnd ( 92,ESPLCI,ERF) ers = 0 return end if ! ! SET THE CURRENT COLOR INDEX IN THE GKS STATE LIST ! CPLCI = COLI ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 24 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = COLI call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPLCI,ERF) ers = 0 end if return end subroutine GSPLI(INDEX) ! !******************************************************************************* ! !! GSPLI ??? ! integer ESPLI PARAMETER (ESPLI=18) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPLI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID (THIS WILL HAVE TO BE CHANGED ! FOR IMPLEMENTATIONS HIGHER THAN 0A) ! if (INDEX <= 0 .or. INDEX > 5) then ers = 1 call gerhnd ( 60,ESPLI,ERF) ers = 0 return end if ! ! SET THE CURRENT INDEX IN THE GKS STATE LIST ! CPLI = INDEX ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 21 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = INDEX call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPLI,ERF) ers = 0 end if return end subroutine GSPMCI (COLI) ! !******************************************************************************* ! !! GSPMCI ??? ! integer ESPMCI PARAMETER (ESPMCI=25) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPMCI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID ! if (COLI < 0) then ers = 1 call gerhnd ( 92,ESPMCI,ERF) ers = 0 return end if ! ! SET THE CURRENT COLOR INDEX IN THE GKS STATE LIST ! CPMCI = COLI ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 28 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = COLI call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPMCI,ERF) ers = 0 end if return end subroutine GSPMI (INDEX) ! !******************************************************************************* ! !! GSPMI ??? ! integer ESPMI PARAMETER (ESPMI=22) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESPMI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID (LEVEL 0A SPECIFIC) ! if (INDEX < 1 .or. INDEX > 5) then ers = 1 call gerhnd ( 66,ESPMI,ERF) ers = 0 return end if ! ! SET THE CURRENT POLYMARKER INDEX IN THE GKS STATE LIST ! CPMI = INDEX ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 25 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = INDEX call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESPMI,ERF) ers = 0 end if return end subroutine GSTXAL (TXALH,TXALV) ! !******************************************************************************* ! !! GSTXAL ??? ! integer ESTXAL PARAMETER (ESTXAL=34) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TXALH,TXALV ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESTXAL,IER) if (IER /= 0) return ! ! CHECK THAT THE ARGUMENTS ARE VALID ! if (TXALH < 0 .or. TXALH > 3 .or. TXALV < 0.OR.TXALV > 5) then ers = 1 call gerhnd ( 2000,ESTXAL,ERF) ers = 0 return end if ! ! SET THE CURRENT TEXT ALIGNMENT VARIABLES ! IN THE GKS STATE LIST ! CTXAL(1) = TXALH CTXAL(2) = TXALV ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 36 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = TXALH ID(2) = TXALV call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESTXAL,ERF) ers = 0 end if return end subroutine GSTXCI (COLI) ! !******************************************************************************* ! !! GSTXCI ??? ! integer ESTXCI PARAMETER (ESTXCI=30) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer COLI ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESTXCI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID ! if (COLI < 0) then ers = 1 call gerhnd ( 92,ESTXCI,ERF) ers = 0 return end if ! ! SET THE CURRENT COLOR INDEX IN THE GKS STATE LIST ! CTXCI = COLI ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 33 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = COLI call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESTXCI,ERF) ers = 0 end if return end subroutine GSTXFP (FONT,PREC) ! !******************************************************************************* ! !! GSTXFP ??? ! integer ESTXFP PARAMETER (ESTXFP=27) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer FONT,PREC ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESTXFP,IER) if (IER /= 0) return ! ! CHECK THAT THE FONT IS POSITIVE ! if (FONT <= 0) then ers = 1 call gerhnd ( 75,ESTXFP,ERF) ers = 0 return end if ! ! CHECK THAT THE PRECISION IS VALID ! if (PREC < 0 .or. PREC > 2) then ers = 1 call gerhnd ( 2000,ESTXFP,ERF) ers = 0 return end if ! ! SET THE CURRENT FONT AND PRECISION VARIABLES ! IN THE GKS STATE LIST ! CTXFP(1) = FONT CTXFP(2) = PREC ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 30 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = FONT ID(2) = PREC call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESTXFP,ERF) ers = 0 end if return end subroutine GSTXI (INDEX) ! !******************************************************************************* ! !! GSTXI ??? ! integer ESTXI PARAMETER (ESTXI=26) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer INDEX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESTXI,IER) if (IER /= 0) return ! ! CHECK THAT THE INDEX IS VALID (0A SPECIFIC) ! if (INDEX <= 0 .or. INDEX > 2) then ers = 1 call gerhnd ( 72,ESTXI,ERF) ers = 0 return end if ! ! SET THE CURRENT TEXT INDEX IN THE GKS STATE LIST ! CTXI = INDEX ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 29 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = INDEX call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESTXI,ERF) ers = 0 end if return end subroutine GSTXP (TXP) ! !******************************************************************************* ! !! GSTXP ??? ! integer ESTXP PARAMETER (ESTXP=33) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TXP ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESTXP,IER) if (IER /= 0) return ! ! CHECK THAT THE PATH IS VALID ! if (TXP < 0 .or. TXP > 3) then ers = 1 call gerhnd ( 2000,ESTXP,ERF) ers = 0 return end if ! ! SET THE CURRENT TEXT PATH IN THE GKS STATE LIST ! CTXP = TXP ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 35 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = TXP call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESTXP,ERF) ers = 0 end if return end subroutine GSVP(TNR,XMIN,XMAX,YMIN,YMAX) ! !******************************************************************************* ! !! GSVP ??? ! integer ESVP PARAMETER (ESVP=50) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TNR real XMIN,XMAX,YMIN,YMAX ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESVP,IER) if (IER /= 0) return ! ! CHECK THAT THE NORMALIZATION TRANSFORMATION NUMBER IS VALID ! if ( TNR < 1 .or. TNR > MNT ) then ers = 1 call gerhnd ( 50,ESVP,ERF) ers = 0 return end if ! ! CHECK THAT THE RECTANGLE DEFINITION IS VALID ! if ( XMAX <= XMIN .or. YMAX <= YMIN ) then ers = 1 call gerhnd ( 51,ESVP,ERF) ers = 0 return end if ! ! CHECK THAT VIEWPORT LIES IN NDC SPACE ! if (XMIN < 0.0 .or. XMAX > 1.0 .or. YMIN < 0.0 .OR.YMAX > 1.0 ) then ers = 1 call gerhnd ( 52,ESVP,ERF) ers = 0 return end if ! ! SET THE NORMALIZATION TRANSFORMATION VIEWPORT IN THE GKS STATE LIS ! INR = TNR+1 NTVP(INR,1) = XMIN NTVP(INR,2) = XMAX NTVP(INR,3) = YMIN NTVP(INR,4) = YMAX ! ! REESTABLISH character HEIGHT AND UP VECTOR, AND ! PATTERN SIZE AND REFERENCE POINT, AND CLIPPING RECTANGLE ! call GSCHH(CCHH) call GSCHUP(CCHUP(1),CCHUP(2)) call GSPA(CPA(1),CPA(2)) call GSPARF(CPARF(1),CPARF(2)) return end subroutine GSWKVP (WKID,XMIN,XMAX,YMIN,YMAX) ! !******************************************************************************* ! !! GSWKVP ??? ! integer ESWKVP PARAMETER (ESWKVP=55) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID ! ! CHECK THAT GKS IS IN THE PROPER STATE ! call GZCKST(7,ESWKVP,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,ESWKVP,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,ESWKVP,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK THAT THE RECTANGLE DEFINITION IS VALID ! if (XMAX <= XMIN .or. YMAX <= YMIN) then ers = 1 call gerhnd ( 51,ESWKVP,ERF) ers = 0 return end if ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 72 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID RL1 = 2 RL2 = 2 RX(1) = XMIN RX(2) = XMAX RY(1) = YMIN RY(2) = YMAX call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESWKVP,ERF) ers = 0 end if return end subroutine GSWKWN (WKID,XMIN,XMAX,YMIN,YMAX) ! !******************************************************************************* ! !! GSWKWN ??? ! integer ESWKWN PARAMETER (ESWKWN=54) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(7,ESWKWN,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,ESWKWN,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,ESWKWN,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK THAT THE RECTANGLE DEFINITION IS VALID ! if (XMAX <= XMIN .or. YMAX <= YMIN) then ers = 1 call gerhnd ( 51,ESWKWN,ERF) ers = 0 return end if ! ! CHECK THAT THE WINDOW LIES IN NDC SPACE ! if (XMIN < 0.0 .or. XMAX > 1.0 .or. YMIN < 0.0 .OR.YMAX > 1.0 ) then ers = 1 call gerhnd ( 53,ESWKWN,ERF) ers = 0 return end if ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 71 CONT = 0 IL1 = 1 IL2 = 1 ID(1) = WKID RL1 = 2 RL2 = 2 RX(1) = XMIN RX(2) = XMAX RY(1) = YMIN RY(2) = YMAX CONT = 0 call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ESWKWN,ERF) ers = 0 end if return end subroutine gswn (TNR,XMIN,XMAX,YMIN,YMAX) ! !******************************************************************************* ! !! GSWN ??? ! integer ESWN PARAMETER (ESWN=49) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer TNR real XMIN,XMAX,YMIN,YMAX DATA IFRST/0/ ! CHECK IF GKS IS IN PROPER STATE call GZCKST(8,ESWN,IER) if (IER /= 0) return ! ! CHECK THAT THE NORMALIZATION TRANSFORMATION NUMBER IS VALID ! if (TNR < 1 .or. TNR > MNT) then ers = 1 call gerhnd ( 50,ESWN,ERF) ers = 0 return end if ! ! CHECK THAT THE RECTANGLE DEFINITION IS VALID ! if (XMAX <= XMIN .or. YMAX <= YMIN) then if (IFRST==0) then write ( *, * ) ' ' write ( *, * ) 'GSWN - Warning!' write ( *, * ) ' Other GKS implementations may not allow' write ( *, * ) ' XMIN > XMAX or YMIN > YMAX, as this one does.' end if end if ! ! SET THE NORMALIZATION TRANSFORMATION WINDOW IN THE GKS STATE LIST ! INR = TNR+1 NTWN(INR,1) = XMIN NTWN(INR,2) = XMAX NTWN(INR,3) = YMIN NTWN(INR,4) = YMAX ! ! REESTABLISH character HEIGHT AND UP VECTOR, AND ! PATTERN SIZE AND REFERENCE POINT ! call GSCHH(CCHH) call GSCHUP(CCHUP(1),CCHUP(2)) call GSPA(CPA(1),CPA(2)) call GSPARF(CPARF(1),CPARF(2)) ! ! SET FLAG TO INDICATE THAT GSWN HAS BEEN CALLED ! IFRST = 1 return end subroutine GTX(PX,PY,CHARS) ! !******************************************************************************* ! !! GTX ??? ! integer ETX PARAMETER (ETX=14) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR real PX,PY character*(*) CHARS ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,ETX,IER) if (IER /= 0) return ! ! TRANSFORM POSITION COORDINATES TO NDC SPACE AND SET UP ! THE REAL ARRAYS IN THE WORKSTATION INTERFACE common BLOCK ! RL1 = 1 RL2 = 1 call GZW2NX(1,PX,PXN) RX(1) = PXN call GZW2NY(1,PY,PYN) RY(1) = PYN ! ! SET FUNCTION CODE AND PUT OUT THE character ARRAYS ACROSS THE ! WORKSTATION INTERFACE. THE CONTINUATION FLAG SIGNALS ! CONTINUATION OF THE character ARRAY, THE POSITION COORDINATES ! ARE PICKED UP ON THE FIRST INVOCATION OF THE WORKSTATION ! INTERFACE. ! FCODE = 13 call GZPUTS(CHARS,IER) RERR = IER if (RERR /= 0) then ers = 1 call gerhnd ( RERR,ETX,ERF) ers = 0 end if return end subroutine GUPASF ! !******************************************************************************* ! !! GUPASF UPDATE ASPECT SOURCE FLAG CONTEXT. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! integer I ! ! COMPUTE CHANGE FLAGS FOR EACH GKS ASF, ! COMPUTE AGGREGATE AS WELL. ! ANYASF = .FALSE. do I=1,NGKASF MRASF(I) = ID(I) ASFCHG(I) = MRASF(I) /= MSASF(I) ANYASF = ANYASF .or. ASFCHG(I) end do ! ! COMPUTE POLYLINE AGGREGRATE VARIABLE. ! (NOTE THAT LOGIC RELIES ON ASF POINTERS BEING ! A CONTIGUOUS SEQUENCE!!) ! do I=IALTYP,IAPLCI AGPEND(1) = AGPEND(1) .or. ASFCHG(I) end do ! ! COMPUTE POLYMARKER AGGREGRATE VARIABLES. ! (NOTE THAT LOGIC RELIES ON ASF POINTERS BEING ! A CONTIGUOUS SEQUENCE!!) ! do I=IAMTYP,IAPMCI AGPEND(2) = AGPEND(2) .or. ASFCHG(I) end do ! ! COMPUTE TEXT AGGREGRATE VARIABLES. ! (NOTE THAT LOGIC RELIES ON ASF POINTERS BEING ! A CONTIGUOUS SEQUENCE!!) ! do I=IATXFP,IATXCI AGPEND(3) = AGPEND(3) .or. ASFCHG(I) end do ! ! COMPUTE FILL AREA AGGREGRATE VARIABLES. ! (NOTE THAT LOGIC RELIES ON ASF POINTERS BEING ! A CONTIGUOUS SEQUENCE!!) ! do I=IAFAIS,IAFACI AGPEND(4) = AGPEND(4) .or. ASFCHG(I) end do return end subroutine GUPDVA ! !******************************************************************************* ! !! GUPDVA UPDATE ALL ATTRIBUTE DEFERRAL VARIABLES. ! common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), & RY(128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, IL1, IL2, ID, RL1, RL2 integer STRL1, STRL2, RERR real RX, RY character*80 STR common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! ! integer IPRIM, I, IOFF, JOFF, J ! ! COPY DEFAULT ATTRIBUTE CONTEXT TO "SET" CONTEXT. ! call G01D2S ! ! Go through the attribute structures G01ARQ and G01AST to ! reset the attribute context variables. ! ! POLYLINE ATTRIBUTES IPRIM = 1 AGPEND(IPRIM) = .FALSE. do I=IVPLIX,IVPLCI IOFF = abs (IP2AEA(I)) ! ! IS THE REQUESTED VALUE DIFFERENT FROM THE SENT? ! THE FOLLOWING CODE REFLECTS THE FACT THAT ALL ATTRIBUTE ! VARIABLES FOR POLYLINE ARE STORED CONTIGUOUSLY. ! if (IP2AEA(I) > 0) then VALCHG(I) = MSAEQV(IOFF) /= MRAEQV(IOFF) else VALCHG(I) = ASAEQV(IOFF) /= ARAEQV(IOFF) end if ! ! UPDATE AGGREGATE CHANGE PARAMETER. ! AGPEND(IPRIM) = AGPEND(IPRIM) .or. VALCHG(I) end do ! ! POLYMARKER ATTRIBUTES ! IPRIM = 2 AGPEND(IPRIM) = .FALSE. do I=IVPMIX,IVPMCI IOFF = abs (IP2AEA(I)) ! ! IS THE REQUESTED VALUE DIFFERENT FROM THE SENT? ! THE FOLLOWING CODE REFLECTS THE FACT THAT ALL ATTRIBUTE ! VARIABLES FOR POLYMARKER ARE STORED CONTIGUOUSLY. ! if (IP2AEA(I) > 0) then VALCHG(I) = MSAEQV(IOFF) /= MRAEQV(IOFF) else VALCHG(I) = ASAEQV(IOFF) /= ARAEQV(IOFF) end if ! ! UPDATE AGGREGATE CHANGE PARAMETER. ! AGPEND(IPRIM) = AGPEND(IPRIM) .or. VALCHG(I) end do ! ! TEXT ATTRIBUTES ! IPRIM = 3 AGPEND(IPRIM) = .FALSE. do I=IVTXIX,IVTXCI IOFF = abs (IP2AEA(I)) JOFF = IOFF + IL2AEA(I) - 1 ! ! IS THE REQUESTED VALUE DIFFERENT FROM THE SENT? ! if (IP2AEA(I) > 0) then VALCHG(I) = MSAEQV(IOFF) /= MRAEQV(IOFF) do J=IOFF+1,JOFF VALCHG(I) = VALCHG(I) .or. MSAEQV(J) /= MRAEQV(J) end do else VALCHG(I) = ASAEQV(IOFF) /= ARAEQV(IOFF) do J=IOFF+1,JOFF VALCHG(I) = VALCHG(I) .or. ASAEQV(J) /= ARAEQV(J) end do end if ! ! UPDATE AGGREGATE CHANGE PARAMETER. ! AGPEND(IPRIM) = AGPEND(IPRIM) .or. VALCHG(I) end do ! ! FILL AREA ATTRIBUTES ! IPRIM = 4 AGPEND(IPRIM) = .FALSE. do 160 I=IVFAIX,IVFACI ! IOFF = abs (IP2AEA(I)) JOFF = IOFF + IL2AEA(I) - 1 ! ! IS THE REQUESTED VALUE DIFFERENT FROM THE SENT? ! if (IP2AEA(I) > 0) then VALCHG(I) = MSAEQV(IOFF) /= MRAEQV(IOFF) do J=IOFF+1,JOFF VALCHG(I) = VALCHG(I) .or. MSAEQV(J) /= MRAEQV(J) end do else VALCHG(I) = ASAEQV(IOFF) /= ARAEQV(IOFF) do J=IOFF+1,JOFF VALCHG(I) = VALCHG(I) .or. ASAEQV(J) /= ARAEQV(J) end do end if ! ! UPDATE AGGREGATE CHANGE PARAMETER. ! AGPEND(IPRIM) = AGPEND(IPRIM) .or. VALCHG(I) 160 continue ! ! UPDATE ASPECT SOURCE FLAG CONTEXT ! ID(1:13) = MRASF(1:13) call GUPASF return end subroutine GUPDVI (INVAL, IPOINT, IPRIM) ! !******************************************************************************* ! !! GUPDVI UPDATE ATTRIBUTE DEFERRAL VARIABLES FOR A INTEGER-VALUED ATTRIBUTE. ! ! ! PARAMETERS: ! INPUT ! INVAL - NEW VALUE FOR THE ATTRIBUTE ITEM. ! IPOINT - POINTER INTO DEFERRAL CONTROL VARIABLE ! STRUCTURES, AND INTO INDEX ARRAY THAT ! GIVES START OF PRIMITIVE IN ATTRIBUTE ! EQUIVALENCING ARRAY, INTEGER VERSION. ! IPRIM - OUTPUT PRIMITIVE TYPE ASSOCIATED WITH ! THE ATTRIBUTE (1=POLYLINE, 2=POLYMARKER, ! 3=TEXT, 4=FILL AREA). USED TO INDEX INTO ! OTHER OF THE CONTROL VARIABLE STRUCTURES. ! ! OUTPUT ! ADJUSTMENT OF ATTRIBUTE DEFERRAL CONTROL PARAMETERS ! IN common. ! ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! integer INVAL(*), IPOINT, IPRIM ! logical CHGNS integer I, IOFF, LNGVAL ! ! OFFSET AND LENGTH OF ATTRIBUTE IN EQUIVALENCING STRUCTURES. ! IOFF = abs (IP2AEA(IPOINT)) LNGVAL = IL2AEA(IPOINT) ! ! IS THE NEW VALUE DIFFERENT FROM THE LAST SENT.. ! CHGNS = INVAL(1) /= MSAEQV(IOFF) do I=2,LNGVAL CHGNS = CHGNS .or. INVAL(I) /= MSAEQV(IOFF+I-1) end do if (CHGNS) then ! ! NEW AND LAST SENT DIFFER. ! ! SET AGGREGATE CHANGE-PENDING PARAMETER. AGPEND(IPRIM) = .TRUE. end if ! ! COPY NEW VALUE TO REQUESTED. ! MRAEQV(IOFF) = INVAL(1) do I=2,LNGVAL MRAEQV(IOFF+I-1) = INVAL(I) end do ! ! MARK VALUE CHANGE. ! VALCHG(IPOINT) = CHGNS return end subroutine GUPDVR (RNVAL, IPOINT, IPRIM) ! !******************************************************************************* ! !! GUPDVR UPDATE ATTRIBUTE DEFERRAL VARIABLES FOR A REAL-VALUED ATTRIBUTE. ! ! ! PARAMETERS: ! INPUT ! RNVAL - NEW VALUE FOR THE ATTRIBUTE ITEM. ! IPOINT - POINTER INTO DEFERRAL CONTROL VARIABLE ! STRUCTURES, AND INTO INDEX ARRAY THAT ! GIVES START OF PRIMITIVE IN ATTRIBUTE ! EQUIVALENCING ARRAY, REAL VERSION. ! IPRIM - OUTPUT PRIMITIVE TYPE ASSOCIATED WITH ! THE ATTRIBUTE (1=POLYLINE, 2=POLYMARKER, ! 3=TEXT, 4=FILL AREA). USED TO INDEX INTO ! OTHER OF THE CONTROL VARIABLE STRUCTURES. ! ! OUTPUT ! ADJUSTMENT OF ATTRIBUTE DEFERRAL CONTROL PARAMETERS ! IN common. ! ! common /G01ARQ/ MRPLIX ,MRLTYP ,ARLWSC ,MRPLCI , & MRPMIX ,MRMTYP ,ARMSZS ,MRPMCI , & MRTXIX ,MRTXP ,MRTXAL(2) ,MRCHH , & MRCHOV(4) ,MRTXFO ,MRTXPR ,ARCHXP , & ARCHSP ,MRTXCI , & MRFAIX ,MRPASZ(4) ,MRPARF(2) , & MRFAIS ,MRFASI ,MRFACI , & MRASF(13) integer MRPLIX ,MRLTYP ,MRPLCI real ARLWSC integer MRPMIX ,MRMTYP ,MRPMCI real ARMSZS integer MRTXIX ,MRTXP ,MRTXAL ,MRTXFO integer MRTXPR ,MRTXCI ,MRCHH ,MRCHOV real ARCHXP ,ARCHSP integer MRFAIX ,MRPASZ ,MRPARF ,MRFAIS ,MRFASI integer MRFACI ,MRASF integer MRAEQV(45) real ARAEQV(45) equivalence (MRPLIX, MRAEQV, ARAEQV) common /G01AST/ MSPLIX ,MSLTYP ,ASLWSC ,MSPLCI , & MSPMIX ,MSMTYP ,ASMSZS ,MSPMCI , & MSTXIX ,MSTXP ,MSTXAL(2) ,MSCHH , & MSCHOV(4) ,MSTXFO ,MSTXPR ,ASCHXP , & ASCHSP ,MSTXCI , & MSFAIX ,MSPASZ(4) ,MSPARF(2) , & MSFAIS ,MSFASI ,MSFACI , & MSASF(13) integer MSPLIX ,MSLTYP ,MSPLCI real ASLWSC integer MSPMIX ,MSMTYP ,MSPMCI real ASMSZS integer MSTXIX ,MSTXP ,MSTXAL ,MSTXFO integer MSTXPR ,MSTXCI ,MSCHH ,MSCHOV real ASCHXP ,ASCHSP integer MSFAIX ,MSPASZ ,MSPARF ,MSFAIS ,MSFASI integer MSFACI ,MSASF integer MSAEQV(45) real ASAEQV(45) equivalence (MSPLIX, MSAEQV, ASAEQV) common /G01ADC/ VALCHG(37) ,ANYASF ,AGPEND(4) , & IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX , & IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP , & IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR , & IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ , & IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF , & IP2AEA(26) ,IL2AEA(26) , & IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS , & IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI , & IAFAIS ,IAFASI ,IAFACI , & NCGASF ,NGKASF ,MASMAP(18) logical VALCHG ,ANYASF ,AGPEND integer IVPLIX ,IVLTYP ,IVLWSC ,IVPLCI ,IVPMIX integer IVMTYP ,IVMSZS ,IVPMCI ,IVTXIX ,IVTXP integer IVTXAL ,IVCHH ,IVCHOV ,IVTXFO ,IVTXPR integer IVCHXP ,IVCHSP ,IVTXCI ,IVFAIX ,IVPASZ integer IVPARF ,IVFAIS ,IVFASI ,IVFACI ,IVASF integer IP2AEA ,IL2AEA integer IALTYP ,IALWSC ,IAPLCI ,IAMTYP ,IAMSZS integer IAPMCI ,IATXFP ,IACHXP ,IACHSP ,IATXCI integer IAFAIS ,IAFASI ,IAFACI integer NCGASF ,NGKASF ,MASMAP ! logical ASFCHG(13) equivalence (VALCHG(25),ASFCHG(1)) ! real RNVAL(*) integer IPOINT, IPRIM ! logical CHGNS integer I, IOFF, LNGVAL ! ! OFFSET AND LENGTH OF ATTRIBUTE IN EQUIVALENCING STRUCTURES. ! IOFF = abs (IP2AEA(IPOINT)) LNGVAL = IL2AEA(IPOINT) ! ! IS THE NEW VALUE DIFFERENT FROM THE LAST SENT.. ! CHGNS = RNVAL(1) /= ASAEQV(IOFF) do I=2,LNGVAL CHGNS = CHGNS .or. RNVAL(I) /= ASAEQV(IOFF+I-1) end do if (CHGNS) then ! ! NEW AND LAST SENT DIFFER. ! ! SET AGGREGATE CHANGE-PENDING PARAMETER. AGPEND(IPRIM) = .TRUE. end if ! ! COPY NEW VALUE TO REQUESTED. ! ARAEQV(IOFF) = RNVAL(1) do I=2,LNGVAL ARAEQV(IOFF+I-1) = RNVAL(I) end do ! ! MARK VALUE CHANGE. ! VALCHG(IPOINT) = CHGNS return end subroutine GUREC(LDR,DATREC,IIL,IRL,ISL,ERRIND, & IL,IA,RL,RA,SL,LSTR,STR) ! !******************************************************************************* ! !! GUREC ??? ! integer EUREC PARAMETER (EUREC=108) DIMENSION IA(*),RA(*),LSTR(*) integer RL,SL,ERRIND character*80 DATREC(LDR) character*(*) STR(*) DATA NCE/1/ ! ! THIS routine UNPACKS THE DATA RECORDS THAT WERE PACKED USING ! THE routine GPREC. ! ! READ IN IL,RL,SL,NTL,NIL,NRL,NSL,MAXSL: ! OF MAXIMUM LENGTH. ! ! IL -- NUMBER OF INTEGERS TO BE READ ! RL -- NUMBER OF REALS TO BE READ ! SL -- NUMBER OF DISTINCT character VARIABLES TO BE READ ! NTL -- NUMBER OF DATA RECORDS USED TO STORE LSTR ! NIL -- NUMBER OF DATA RECORDS USED TO STORE THE INTEGERS ! NRL -- NUMBER OF DATA RECORDS USED TO STORE THE REALS ! NSL -- NUMBER OF DATA RECORDS USED TO STORE THE character ! VARIABLES ! MAXSL -- MAXIMUM character LENGTH OF ANY OF THE CHARACTER ! VARIABLES READ (DATREC(1),501) IL,RL,SL,NTL,NIL,NRL,NSL,MAXSL ! ! do PARAMETER CHECKING ! ILDR = NTL+NIL+NRL+NSL+1 if (IIL < IL .or. IRL < RL .or. ISL < SL.OR.LDR < ILDR) then ERRIND = 2001 return end if ! ! READ THE LSTR ARRAY IF THERE ARE ANY characterS ! NPER = 8 if (SL > 0) then INDX1 = SL/NPER INDX2 = mod ( SL,NPER) if (INDX1==0) then READ (DATREC(2),501) (LSTR(LL),LL=1,SL) else do 200 I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I READ (DATREC(I+1),501) (LSTR(LL),LL=IPNT1,IPNT2) 200 continue if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 READ (DATREC(INDX1+2),501) (LSTR(LL),LL=NPNT1,NPNT2) end if end if end if ! ! READ THE INTEGER ARRAY ! NPER = 4 if (IL > 0) then INDX1 = IL/NPER INDX2 = mod ( IL,NPER) if (INDX1==0) then READ (DATREC(NTL+2),502) (IA(LL),LL=1,IL) else do I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I READ (DATREC(NTL+I+1),502) (IA(LL),LL=IPNT1,IPNT2) end do if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 READ (DATREC(NTL+INDX1+2),502) (IA(LL),LL=NPNT1,NPNT2) end if end if end if ! ! READ THE REAL ARRAY ! NPER = 4 if (RL > 0) then INDX1 = RL/NPER INDX2 = mod ( RL,NPER) if (INDX1==0) then READ (DATREC(NTL+NIL+2),503) (RA(LL),LL=1,RL) else do I=1,INDX1 IPNT1 = NPER*(I-1)+1 IPNT2 = NPER*I READ (DATREC(NTL+NIL+I+1),503) (RA(LL),LL=IPNT1,IPNT2) end do if (INDX2 /= 0) then NPNT1 = NPER*INDX1+1 NPNT2 = NPER*INDX1+INDX2 READ (DATREC(NTL+NIL+INDX1+2),503) (RA(LL),LL=NPNT1,NPNT2) end if end if end if ! ! READ THE character ARRAYS ! if (MAXSL /= 0) then NCE = 80/MAXSL if (NCE <= 1) then NCE = 1 end if end if NPER = NCE if (SL > 0) then if (NPER > 1) then INDX1 = SL/NPER INDX2 = mod ( SL,NPER) if (INDX1==0) then do 203 I=1,SL IPNT1 = (I-1)*MAXSL+1 IPNT2 = IPNT1+LSTR(I)-1 STR(I)(1:LSTR(I)) = DATREC(NTL+NIL+NRL+2)(IPNT1:IPNT2) 203 continue else do 204 I=1,INDX1 do 205 J=1,NCE JPNT1 = (J-1)*MAXSL+1 NDX = NPER*(I-1)+J JPNT2 = JPNT1+LSTR(NDX)-1 STR(NDX) (1:LSTR(NDX)) = DATREC(NTL+NIL+NRL+I+1)(JPNT1:JPNT2) 205 continue 204 continue if (INDX2 /= 0) then do J=1,INDX2 JPNT1 = (J-1)*MAXSL+1 NDX = NPER*INDX1+J JPNT2 = JPNT1+LSTR(NDX)-1 STR(NDX) (1:LSTR(NDX)) = DATREC(NTL+NIL+NRL+INDX1+2)(JPNT1:JPNT2) end do end if end if else JNDX = 0 do 207 I=1,SL INDX1 = LSTR(I)/80 INDX2 = mod ( LSTR(I),80) if (INDX1==0) then JNDX = JNDX+1 STR(I)(1:INDX2) = DATREC(NTL+NIL+NRL+JNDX+1) else do 208 J=1,INDX1 JNDX = JNDX+1 STR(I) (80*(J-1)+1:80*J) = DATREC(NTL+NIL+NRL+JNDX+1) 208 continue if (INDX2 /= 0) then JNDX = JNDX+1 STR(I) (80*INDX1+1:80*INDX1+INDX2) = & DATREC(NTL+NIL+NRL+JNDX+1) (1:INDX2) end if end if 207 continue end if end if ! 501 FORMAT(8I10) 502 FORMAT(4I20) 503 FORMAT(4E20.13) return end subroutine GUWK(WKID,REGFL) ! !******************************************************************************* ! !! GUWK ??? ! integer EUWK PARAMETER (EUWK=8) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,REGFL ! CHECK THAT GKS IS IN THE PROPER STATE call GZCKST(7,EUWK,IER) if (IER /= 0) return ! CHECK IF WORKSTATION IDENTIFIER IS VALID call GZCKWK(20,EUWK,WKID,IDUM,IER) if (IER /= 0) return ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN call GZCKWK(25,EUWK,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK IF REGFL IS IN BOUNDS ! if (REGFL < 0 .or. REGFL > 1) then ers = 1 call gerhnd ( 2000,EUWK,ERF) ers = 0 return end if ! ! INVOKE THE WORKSTATION INTERFACE ! FCODE = 3 CONT = 0 IL1 = 2 IL2 = 2 ID(1) = WKID ID(2) = REGFL call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EUWK,ERF) ers = 0 end if return end subroutine GWITM (WKID,TYPE,LDR,DATREC) ! !******************************************************************************* ! !! GWITM ??? ! integer EWITM PARAMETER (EWITM=101) ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer WKID,TYPE,LDR character*80 DATREC(LDR) ! CHECK IF GKS IS IN PROPER STATE call GZCKST(5,EWITM,IER) if (IER /= 0) return ! CHECK IF WORKSTATION ID IS VALID call GZCKWK(20,EWITM,WKID,IDUM,IER) if (IER /= 0) return ! ! CHECK IF ITEM TYPE IS VALID (GKS INTERPRETABLE ITEMS ARE ILLEGAL) ! if (TYPE <= 100) then ers = 1 call gerhnd ( 160,EWITM,ERF) ers = 0 return end if ! ! CHECK IF ITEM LENGTH IS VALID ! if (LDR < 1) then ers = 1 call gerhnd ( 161,EWITM,ERF) ers = 0 return end if ! ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE ! call GZCKWK(30,EWITM,WKID,IDUM,IER) if (IER /= 0) return ! ! SET FUNCTION CODE AND PUT OUT WKID, TYPE, LDR, AND THE DATA ! RECORD IN STR. ! FCODE = 101 IL1 = 3 IL2 = 3 ID(1) = WKID ID(2) = TYPE ID(3) = LDR ! ! SEND OVER THE DATA RECORD IF THERE IS ONE (RECALL THAT THE ! STRING LENGTH OF STR IS DIVISIBLE BY 80). ! if (LDR >= 1) then if (LDR==1) then CONT = 0 STRL1 = 80 STRL2 = 80 STR(1:80) = DATREC(1) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EWITM,ERF) ers = 0 return end if else ! ! SEND OVER THE DATA RECORD 80 characterS AT A TIME ! CONT = 1 STRL1 = 80*LDR STRL2 = 80 LDRM1 = LDR-1 do I=1,LDRM1 STR(1:80) = DATREC(I) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EWITM,ERF) ers = 0 return end if end do CONT = 0 STR(1:80) = DATREC(LDR) call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EWITM,ERF) ers = 0 return end if end if else call GZTOWK if (RERR /= 0) then ers = 1 call gerhnd ( RERR,EWITM,ERF) ers = 0 return end if end if return end subroutine GZCKST(NUM,ENAM,IER) ! !******************************************************************************* ! !! GZCKST provides THE CHECKING FOR ERROR NUMBERS 1 THROUGH 8. ! ! ! Parameters: ! ! Input, integer NUM, the ERROR NUMBER TO CHECK FOR. ! ! Input, integer ENAM, the INDEX OF NAME OF CALLING PROGRAM (THIS IS ! NON-ZERO ONLY FOR NON-INQUIRY FUNCTIONS, IN WHICH CASE GERHND ! IS CALLED). ! ! Output, integer IER, 0 IF NO ERROR, THE ERROR NUMBER IF ERROR FOUND ! common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ENAM RERR = 0 IER = 0 go to (10,20,30,40,50,60,70,80) NUM 10 continue if (OPS /= GGKCL) then IER = 1 if (ENAM >= 0) then ers = 1 call gerhnd ( 1,ENAM,ERF) ers = 0 return end if end if go to 100 20 continue if (OPS /= GGKOP) then IER = 2 if (ENAM >= 0) then ers = 1 call gerhnd ( 2,ENAM,ERF) ers = 0 return end if end if go to 100 30 continue if (OPS /= GWSAC) then IER = 3 if (ENAM >= 0) then ers = 1 call gerhnd ( 3,ENAM,ERF) ers = 0 return end if end if go to 100 40 continue if (OPS /= GSGOP) then IER = 4 if (ENAM >= 0) then ers = 1 call gerhnd ( 4,ENAM,ERF) ers = 0 return end if end if go to 100 50 continue if (OPS /= GWSAC .and. OPS.NE.GSGOP) then IER = 5 if (ENAM >= 0) then ers = 1 call gerhnd ( 5,ENAM,ERF) ers = 0 return end if end if go to 100 60 continue if (OPS /= GWSAC .and. OPS.NE.GWSOP) then IER = 6 if (ENAM >= 0) then ers = 1 call gerhnd ( 6,ENAM,ERF) ers = 0 return end if end if go to 100 70 continue if (OPS /= GWSOP .and. OPS.NE.GWSAC.AND.OPS.NE.GSGOP) then IER = 7 if (ENAM >= 0) then ers = 1 call gerhnd ( 7,ENAM,ERF) ers = 0 return end if end if go to 100 80 continue if (OPS /= GGKOP .and. OPS.NE.GWSOP.AND.OPS.NE.GWSAC.AND.OPS.NE.GSGOP& ) then IER = 8 if (ENAM >= 0) then ers = 1 call gerhnd ( 8,ENAM,ERF) ers = 0 return end if end if 100 continue return end subroutine GZCKWK(NUM,ENAM,WKID,WTYPE,IER) ! !******************************************************************************* ! !! GZCKWK PROVIDES THE CHECKING FOR ERROR NUMBERS 20,22,23,24,25,29, AND 30. ! ! ! INPUT: ! NUM -- ERROR NUMBER TO CHECK FOR ! ENAM -- INDEX OF NAME OF CALLING PROGRAM (THIS IS NON-ZERO ! ONLY FOR NON-INQUIRY FUNCTIONS, IN WHICH CASE GERHND ! IS CALLED). ! WKID -- WORKSTATION IDENTIFIER (WHERE APPLICABLE) ! WTYPE -- WORKSTATION TYPE (WHERE APPLICABLE) ! ! OUTPUT: ! IER -- 0 IF NO ERROR, THE ERROR NUMBER IF ERROR FOUND ! common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer ENAM,WKID,WTYPE IER = 0 if (NUM==20) then ! CHECK IF WKID IS VALID if (WKID < 0) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if end if else if (NUM==22) then ! CHECK IF WTYPE IS VALID INDX = 0 200 continue INDX = INDX+1 if (INDX > WK) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if go to 201 else if (LSWK(INDX)==WTYPE) then go to 201 end if end if go to 200 201 continue else if (NUM==23) then ! CHECK IF WTYPE IS VALID INDX = 0 202 continue INDX = INDX+1 if (INDX > WK) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if go to 203 else if (LSWK(INDX)==WTYPE) then go to 203 end if end if go to 202 203 continue else if (NUM==24) then ! CHECK IF THE WORKSTATION IS CURRENTLY OPEN if (NOPWK > 0) then do 204 I=1,NOPWK if (SOPWK(I)==WKID) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if end if 204 continue end if else if (NUM==25) then ! CHECK IF THE SPECIFIED WORKSTATION IS OPEN INDX = 0 205 continue INDX = INDX+1 if (INDX > MOPWK) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if go to 206 else if (SOPWK(INDX)==WKID) then go to 206 end if end if go to 205 206 continue else if (NUM==29) then ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE do 207 I=1,MACWK if (SACWK(I)==WKID) then if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if end if 207 continue else if (NUM==30) then ! CHECK IF THE WORKSTATION IS CURRENTLY ACTIVE INDX = 0 208 continue INDX = INDX+1 if (SACWK(INDX)==WKID) go to 209 if (INDX > MACWK) then IER = NUM if (ENAM >= 0) then ers = 1 call gerhnd ( num, enam, erf ) ers = 0 return end if go to 209 end if go to 208 209 continue end if return end subroutine GZFMWK ! !******************************************************************************* ! !! GZFMWK CAN BE A DUMMY FOR MO WORKSTATIONS ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! RL2 = 0 IL2 = 0 STRL2 = 0 return end subroutine GZINES ! !******************************************************************************* ! !! GZINES initializes THE ERROR STATE LIST ! ! GKS ERROR STATE LIST-- ! ERS -- ERROR STATE ! ERF -- ERROR FILE ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ers = 0 ERF = 6 return end subroutine GZINSL ! !******************************************************************************* ! !! GZINSL initializes THE GKS STATE LIST ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR SOPWK (1) = 0 SACWK (1) = 0 SWKTP (1) = 0 CTXFP (1) = 1 CTXFP (2) = 0 CCHUP (1) = 0. CCHUP (2) = 1. CTXAL (1) = 0 CTXAL (2) = 0 CPA (1) = 1. CPA (2) = 1. CPARF (1) = 0. CPARF (2) = 0. LSNT (1) = 0 LSNT (2) = 1 NTWN(1,1) = 0. NTWN(1,2) = 1. NTWN(1,3) = 0. NTWN(1,4) = 1. NTWN(2,1) = 0. NTWN(2,2) = 1. NTWN(2,3) = 0. NTWN(2,4) = 1. NTVP(1,1) = 0. NTVP(1,2) = 1. NTVP(1,3) = 0. NTVP(1,4) = 1. NTVP(2,1) = 0. NTVP(2,2) = 1. NTVP(2,3) = 0. NTVP(2,4) = 1. CPLI = 1 CLN = 1 CLWSC = 1. CPLCI = 1 CLNA = GINDIV CLWSCA = GINDIV CPLCIA = GINDIV CPMI = 1 CMK = 3 CMKS = 1. CPMCI = 1 CMKA = GINDIV CMKSA = GINDIV CPMCIA = GINDIV CTXI = 1 CCHXP = 1.0 CCHSP = 0. CTXCI = 1 CTXFPA = GINDIV CCHXPA = GINDIV CCHSPA = GINDIV CTXCIA = GINDIV CCHH = .01 CTXP = 0 CFAI = 1 CFAIS = 0 CFASI = 1 CFACI = 1 CFAISA = GINDIV CFASIA = GINDIV CFACIA = GINDIV CNT = 0 CCLIP = 1 return end subroutine GZN2WX(N,P,Q) ! !******************************************************************************* ! !! GZN2WX TAKES THE N POINTS IN THE REAL ARRAY P, ! WHICH ARE ASSUMED TO BE IN NDC COORDINATES, AND, USING ! THE CURRENT NORMALIZATION TRANSFORMATION, CONVERTS THEM ! INTO WORLD COORDINATES AND STORES THEM IN Q. ! THIS routine OPERATES ON X-COORDINATES. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N real P(N),Q(N) ICNT = CNT+1 TMP1 = NTWN(ICNT,1) TMP2 = NTWN(ICNT,2) TMP3 = NTVP(ICNT,1) TMP4 = NTVP(ICNT,2) SCALE = (TMP2-TMP1)/(TMP4-TMP3) do I=1,N Q(I) = TMP1+(P(I)-TMP3)*SCALE end do return end subroutine GZN2WY(N,P,Q) ! !******************************************************************************* ! !! GZN2WY TAKES THE N POINTS IN THE REAL ARRAY P, ! WHICH ARE ASSUMED TO BE IN NDC COORDINATES, AND, USING ! THE CURRENT NORMALIZATION TRANSFORMATION, CONVERTS THEM ! INTO WORLD COORDINATES AND STORES THEM IN Q. ! THIS routine OPERATES ON Y-COORDINATES. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N real P(N),Q(N) ICNT = CNT+1 TMP1 = NTWN(ICNT,3) TMP2 = NTWN(ICNT,4) TMP3 = NTVP(ICNT,3) TMP4 = NTVP(ICNT,4) SCALE = (TMP2-TMP1)/(TMP4-TMP3) do 200 I=1,N Q(I) = TMP1+(P(I)-TMP3)*SCALE 200 continue return end subroutine GZPUTR(N,P,Q,ICONV,IER) ! !******************************************************************************* ! !! GZPUTR FILLS THE REAL ARRAYS OF THE WORKSTATION ! INTERFACE common BLOCK AND INVOKES THE WORKSTATION ! INTERFACE routine. IF ICONV=1, P,Q ARE ASSUMED TO BE ! IN WORLD COORDINATES, AND ARE TRANSFORMED TO NDC ! COORDINATES. IF AN ERROR IS returnED FROM THE WORKSTATION ! INTERFACE, IER IS SET TO THAT ERROR AND A return IS EXECUTED. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR integer N real P(N),Q(N),RP(128),RQ(128) J = (N-1)/128 RL1 = N if (J==0) then ! ! CASE WHERE THERE IS NO CONTINUATION ! CONT = 0 RL2 = N if (ICONV==1) then call GZW2NX(N,P,RP) call GZW2NY(N,Q,RQ) RX(1:n) = RP(1:n) RY(1:n) = RQ(1:n) else RX(1:n) = P(1:n) RY(1:n) = Q(1:n) end if call GZTOWK if (RERR /= 0) then IER = RERR return end if else ! ! CASE WITH CONTINATION ! CONT = 1 RL2 = 128 ! ! LOOP THROUGH PARTS WITH CONTINUATION FLAG SET ! if (ICONV==1) then do K=1,J KPNT = (K-1)*128+1 call GZW2NX(128,P(KPNT),RX) call GZW2NY(128,Q(KPNT),RY) call GZTOWK if (RERR /= 0) then IER = RERR return end if end do else do K=1,J KPNT = (K-1)*128 do I=1,128 RX(I) = P(KPNT+I) RY(I) = Q(KPNT+I) end do call GZTOWK if (RERR /= 0) then IER = RERR return end if end do end if ! ! PUT OUT LAST PART OF ARRAY WITH CONTINUATION FLAG SET TO LAST ! CONT = 0 RL2 = N-J*128 KPNT = J*128 if (ICONV==1) then call GZW2NX(RL2,P(KPNT+1),RX) call GZW2NY(RL2,Q(KPNT+1),RY) call GZTOWK if (RERR /= 0) then IER = RERR return end if else do 205 I=1,RL2 RX(I) = P(KPNT+I) RY(I) = Q(KPNT+I) 205 continue call GZTOWK if (RERR /= 0) then IER = RERR return end if end if end if return end subroutine GZPUTS(ST,IER) ! !******************************************************************************* ! !! GZPUTS FILLS THE STRING character VARIABLE OF THE WORKSTATION ! INTERFACE common BLOCK AND INVOKES THE WORKSTATION ! INTERFACE routine (N IS THE LENGTH OF STRING ST) ! IF AN ERROR IS returnED FROM THE WORKSTATION INTERFACE, ! IER IS SET TO THAT ERROR NUMBER AND A return IS EXECUTED. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR character*(*) ST N = LEN(ST) J = (N-1)/80 STRL1 = N if (J==0) then ! ! CASE WHERE THERE IS NO CONTINUATION ! CONT = 0 STRL2 = N STR(1:N) = ST(1:N) call GZTOWK if (RERR /= 0) then IER = RERR return end if else ! ! CASE WITH CONTINATION ! CONT = 1 STRL2 = 80 ! ! LOOP THROUGH PARTS WITH CONTINUATION FLAG SET ! do K=1,J KPNT = (K-1)*80 STR(1:80) = ST(KPNT+1:KPNT+80+1) call GZTOWK if (RERR /= 0) then IER = RERR return end if end do ! ! PUT OUT LAST PART OF STRING WITH CONTINUATION FLAG SET TO LAST ! CONT = 0 STRL2 = N-J*80 KPNT = J*80 STR(1:STRL2) = ST(KPNT+1:KPNT+STRL2+1) call GZTOWK end if return end subroutine GZTOWK ! !******************************************************************************* ! !! GZTOWK INVOKES THE WORKSTATION DRIVER ! DEPENDING ON THE CURRENT GKS OPERATING STATE. ! THE DRIVER IS ALWAYS CALLED FOR INQUIRY FUNCTIONS, ! AND IS NEVER CALLED FOR OTHER FUNCTIONS UNLESS ! THERE IS AT LEAST ONE OPEN WORKSTATION (EXCEPT FOR ! AN OPEN WORKSTATION CALL.) ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common/GKSNAM/ GNAM(109) character*6 GNAM common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR common /GKSIN2/STR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR character*80 STR ! call GQOPS(IST) ! ! INVOKE WORKSTATION DRIVER FOR ALL INQUIRY FUNCTIONS ! if (FCODE <= -110) then call G01WDR return end if ! ! INVOKE WORKSTATION DRIVER FOR GKOP FUNCTIONS ! if (IST >= 1 .and. FCODE==-3) then call G01WDR return end if ! ! INVOKE WORKSTATION DRIVER FOR GWSOP FUNCTIONS ! if (IST >= 2 .and. (FCODE==-2 .or. FCODE==0 .or. FCODE==1.OR.FCODE & ==3 .or. FCODE==6 .or. FCODE==61.OR.FCODE==56.OR.FCODE==71.OR. & FCODE==72 .or. FCODE==102 .or. FCODE==103.OR.FCODE==104.OR.( & FCODE >= 21 .and. FCODE <= 43))) then call G01WDR return end if ! ! INVOKE WORKSTATION DRIVER FOR GWSAC FUNCTIONS ! if ( IST >= 3 .and. & (FCODE==-1 .or. FCODE==101 .or. (FCODE >= 11 .and. FCODE <= 16))) then call G01WDR return end if return end subroutine GZW2NX ( N, P, Q ) ! !******************************************************************************* ! !! GZW2NX TAKES THE N POINTS IN THE REAL ARRAY P, ! WHICH ARE ASSUMED TO BE IN WORLD COORDINATES, AND, USING ! THE CURRENT NORMALIZATION TRANSFORMATION, CONVERTS THEM ! INTO NDC COORDINATES AND STORES THEM IN Q. ! THIS routine OPERATES ON X-COORDINATES. ! ! common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP ! integer N ! real P(N) real Q(N) ! ICNT = CNT+1 TMP1 = NTWN(ICNT,1) TMP2 = NTWN(ICNT,2) TMP3 = NTVP(ICNT,1) TMP4 = NTVP(ICNT,2) SCALE = (TMP4-TMP3)/(TMP2-TMP1) Q(1:n) = TMP3+(P(1:n)-TMP1)*SCALE return end subroutine GZW2NY(N,P,Q) ! !******************************************************************************* ! !! GZW2NY TAKES THE N POINTS IN THE REAL ARRAY P, ! WHICH ARE ASSUMED TO BE IN WORLD COORDINATES, AND, USING ! THE CURRENT NORMALIZATION TRANSFORMATION, CONVERTS THEM ! INTO NDC COORDINATES AND STORES THEM IN Q. ! THIS routine OPERATES ON Y-COORDINATES. ! ! DETAILS ON ALL GKS common VARIABLES ARE IN THE GKS BLOCKDATA common/GKINTR/ NOPWK,NACWK common/GKOPDT/ OPS,KSLEV,WK,LSWK(1),MOPWK,MACWK,MNT integer OPS,WK common/GKSTAT/ SOPWK(1),SACWK(1),CPLI,CLN,CLWSC,CPLCI,CLNA,CLWSCA, & CPLCIA,CPMI,CMK,CMKS,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP(2),CCHXP, & CCHSP,CTXCI ,CTXFPA,CCHXPA,CCHSPA,CTXCIA,CCHH,CCHUP(2),CTXP, & CTXAL(2),CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA,CFACIA,CPA(2), & CPARF(2),CNT,LSNT(2),NTWN(2,4),NTVP(2,4),CCLIP, SWKTP(1) integer SOPWK,SACWK,CPLI,CLN,CPLCI,CLNA,CLWSCA,CPLCIA,CPMI, & CMK,CPMCI,CMKA,CMKSA,CPMCIA,CTXI,CTXFP,CTXCI,CTXFPA,CCHXPA, & CCHSPA,CTXCIA,CTXP,CTXAL,CFAI,CFAIS,CFASI,CFACI,CFAISA,CFASIA, & CFACIA,CNT,LSNT,CCLIP,SWKTP real NTWN,NTVP common/GKEROR/ ERS,ERF common/GKENUM/ GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP integer GBUNDL,GINDIV,GGKCL,GGKOP,GWSOP,GWSAC,GSGOP,ERS,ERF common /GKSIN1/FCODE,CONT,IL1,IL2,ID(128),RL1,RL2,RX(128), RY( & 128),STRL1,STRL2,RERR integer FCODE, CONT, RL1, RL2, STRL1, STRL2, RERR ! integer N ! real P(N) real Q(N) ! ICNT = CNT+1 TMP1 = NTWN(ICNT,3) TMP2 = NTWN(ICNT,4) TMP3 = NTVP(ICNT,3) TMP4 = NTVP(ICNT,4) SCALE = (TMP4-TMP3)/(TMP2-TMP1) Q(1:n) = TMP3 + ( P(1:n) - TMP1 ) * SCALE return end