program capchg ! !******************************************************************************* ! ! +-----------------------------------------------------------------+ ! | | ! | Copyright (C) 1987,1988 by UCAR | ! | University Corporation for Atmospheric Research | ! | All Rights Reserved | ! | | ! | NCARGRAPHICS Version 3.00 | ! | | ! +-----------------------------------------------------------------+ ! !! CAPCHG converts the ASCII graphcap files into binary graphcap files. ! ! ! The binary graphcap files are read by the CGM translator. ! ! Execution of this program will create a request for the ! name of the ASCII graphcap file and a request for the name ! of the binary output file. If the program is executed in ! a batch environment, appropriate changes must be made to ! ensure the proper file names are supplied and OPENed. ! ! This program contains the following labeled common blocks: ! ! CAPASC ! CAPASI ! CAPBND ! CAPCOL ! CAPDEV ! CAPERR ! CAPIO2 ! CAPIOB ! CAPLIN ! CAPMAR ! CAPPLG ! CAPSCN ! CAPSKP ! CAPSPC ! CAPTXT ! CAPUSR ! PARTB1 ! PARTB2 ! ! We now describe the variables in each of these commons. ! After each variable name there is a pair of values in ! brackets; the first value indicates the type of the ! common variable, and the second value indicates its ! default initial value. The possibilities for the first ! entry in the bracketed pair are: ! ! I -- Integer ! IA -- Integer array ! R -- Real ! RA -- Real array ! CH -- Character ! CA -- Character array ! L -- Logical ! ! CAPASC ! ------ ! ASCTB1 [CA, - ] Table containing all 3-character sequences ! which have special meaning to the translator. ! This includes the special ASCII characters ! with ADE values between 0 and 31 (decimal). ! ASCTB2 [CA, - ] Table of all ASCII characters with ADE values ! between 33 and 126 (decimal). ! ! CAPASI ! ------ ! ASCVL1 [IA, - ] A table containing decimal equivalents to the ! characters in ASCTB1. Special negative values ! are assigned to the strings which are significant ! to the translator, but are not part of the ASCII ! character set. ! ASCVL2 [IA, - ] A table containing decimal equivalents for the ! ASCII characters in table ASCTB2. ! ! ! ! CAPBND (Common for the bundle tables.) ! ------ ! PLBTEC [ I, -1] Number of POLYLINE bundle tables. ! PLIBTB [IA, - ] Array of indices for POLYLINE bundle tables. ! PLTBTB [IA, - ] Array of POLYLINE LINETYPE bundle table entries. ! PLWBTB [RA, - ] Array of POLYLINE LINEWIDTH bundle table entries. ! PLCBTB [IA, - ] Array of POLYLINE COLOR INDEX bundle table entries. ! PMBTEC [ I, -1] Number of POLYMARKER bundle tables. ! PMIBTB [IA, - ] Array of indices for POLYMARKER bundle tables. ! PMTBTB [IA, - ] Array of POLYMARKER MARKERTYPE bundle table entries. ! PMSBTB [RA, - ] Array of POLYMARKER MARKERSIZE bundle table entries. ! PMCBTB [IA, - ] Array of POLYMARKER COLOR INDEX bundle tbl. entries. ! TXBTEC [ I, -1] Number of TEXT bundle tables. ! TXIBTB [IA, - ] Array of indices for TEXT bundle tables. ! TXFBTB [IA, - ] Array of TEXT FONT bundle table entries. ! TXPBTB [IA, - ] Array of TEXT PRECISION bundle table entries. ! TCXBTB [RA, - ] Array of character EXPANSION FACTOR table entries. ! TCSBTB [RA, - ] Array of character SPACING bundle table entries. ! TXCBTB [IA, - ] Array of TEXT COLOR INDEX bundle table entries. ! FABTEC [ I, -1] Number of FILL AREA bundle tables. ! FAIBTB [IA, - ] Array of indices for FILL AREA bundle tables. ! FISBTB [IA, - ] Array of FILL AREA INTERIOR STYLE bundle table entries. ! FASBTB [IA, - ] Array of FILL AREA STYLE INDEX bundle table entries. ! FACBTB [IA, - ] Array of FILL AREA COLOR INDEX bundle table entries. ! ! ! CAPCOL (Contains device color information.) ! ------ ! COLINT [IA, 0] Contains the DEVICE_MAP_INIT table of color intensities ! (COLINT is dimensioned for 3*(max number of colors)). ! COLIDX [IA, - ] Array of indices associated with the table of color ! intensities defined in COLINT above. ! IDXCUR [ I, 0] DEVICE_MAP_INDEX_RANGE_DEFINED ! VDMINT [ -, - ] Unused. ! DMPAVL [ L,.FALSE.] DEVICE_MAP_AVAILABLE ! COLFMT [IA, 0] A two-dimensional array (dimensioned for ! COLMAX x 4) containing the DEVICE_COLOR_INDEX_FORMAT ! COLFIN [IA, 0] Array dimensioned for 8 describing the ! color indices as follows: ! COLFIN(1) -- DEVICE_COLOR_INDEX_ENCODING ! COLFIN(2) -- Number of 4-entry lines defined ! in COLFMT. ! COLFIN(3) -- Maximum number of lines allowed ! in COLFMT. ! COLFIN(4) -- Number of entries in each ! line of COLFMT. ! ! If COLFIN(1) is not equal to 5, then ! COLFIN(5) is int (ALOG10( real (IDXMAX+1))+1). ! ! The integer array COLFIN is equivalenced to ! the REAL array COLRIN, and ! if COLFIN(1) equals 5, then ! COLRIN(5) -- Minimum data value input to encoder ! COLRIN(6) -- Maximum data value input to encoder ! COLRIN(7) -- Minimum data value output from ! encoder. ! COLRIN(8) -- Maximum data value output from ! encoder. ! obtained from DEVICE_COLOR_INDEX_FLOATING_INFO ! IDXMAX [ I, -1] DEVICE_MAP_INDEX_RANGE_MAX ! MSTSTR [IA, 0] Contains the string DEVICE_MAP_INSTRUCTION_START ! MSTSIZ [ I, 0] Number of characters in MSTSTR. ! MTRSTR [IA, 0] Contains the string DEVICE_MAP_INSTRUCTION_TERMINATOR ! DMPMDL [ I, 1] DEVICE_MAP_MODEL ! MTRSIZ [ I, 0] Number of characters in MTRSTR. ! DMPIDV [ L,.FALSE.] DEVICE_MAP_INDIVIDUAL ! DMPFIN [IA, 0] Array dimensioned for 8 describing the ! device map intensities as follows: ! DMPFIN(1) -- DEVICE_MAP_INTENSITY_ENCODING ! DMPFIN(2) -- Number of 4-entry lines defined ! in DMPFMT. ! DMPFIN(3) -- Maximum number of lines allowed ! in DMPFMT. ! DMPFIN(4) -- Number of entries in each ! line of DMPFMT. ! ! If DMPFIN(1) equals 5, then ! DMPFIN(5) is int (ALOG10( real (INTMAX+1))+1), ! where INTMAX is the maximum value in the ! COLINT array. ! ! The integer array DMPFIN is equivalenced to ! the REAL array DMPRIN, and ! if DMPFIN(1) equals 5, then ! DMPRIN(5) -- Minimum data value input to encoder ! DMPRIN(6) -- Maximum data value input to encoder ! DMPRIN(7) -- Minimum data value output from ! encoder. ! DMPRIN(8) -- Maximum data value output from ! encoder. ! as obtained from ! DEVICE_MAP_INTENSITY_FLOATING_INFO ! DMPFMT [IA, 0] A two-dimensional array (dimensioned for ! DMPMAX x 4) containing the DEVICE_MAP_INTENSITY_FORMAT ! ! ! CAPDEV (Contains all device class data.) ! ------ ! DGISTR [IA, - ] Array containing the DEVICE_GRAPHIC_INIT string. ! DGISIZ [ I, - ] Number of defined elements in DGISTR. ! DGESTR [IA, - ] Array containing the DEVICE_ERASE string. ! DGESIZ [ I, - ] Number of defined elements in DGESIZ. ! DTISTR [IA, - ] Array containing the DEVICE_TEXT_INIT string. ! DTISIZ [ I, - ] Number of defined elements in DTISTR. ! DCDLLX [ I, 0] DEVICE_COORD_LOWER_LEFT_X ! DCDLLY [ I, 0] DEVICE_COORD_LOWER_LEFT_Y ! DCDURX [ I, 0] DEVICE_COORD_UPPER_RIGHT_X ! DCDURY [ I, 0] DEVICE_COORD_UPPER_RIGHT_Y ! DCOAVL [ L,.FALSE.] DEVICE_COLOR_AVAILABLE ! CORFMT [IA, 0] A two-dimensional array (dimensioned for ! DCFTMX x 4) containing the DEVICE_COORD_FORMAT. ! CORFIN [IA, 0] Array dimensioned for 8 describing the ! device coordinates as follows: ! CORFIN(1) -- DEVICE_COORD_ENCODING ! CORFIN(2) -- Number of lines defined ! in CORFMT. ! CORFIN(3) -- Maximum number of lines allowed ! in CORFMT. ! CORFIN(4) -- Number of entries in each ! line of CORFMT. ! ! The integer array CORFIN is equivalenced to ! the REAL array CORRIN, and ! if encoding is ASCII real, then ! CORRIN(5) -- Minimum data value input to encoder ! CORRIN(6) -- Maximum data value input to encoder ! CORRIN(7) -- Minimum data value output from ! encoder. ! CORRIN(8) -- Maximum data value output from ! encoder. ! as obtained from DEVICE_COORD_FLOATING_INFO ! BATCH [ L,.FALSE.] DEVICE_BATCH ! DHCSIZ [ I, - ] Number of defined characters in DEVICE_CURSOR_HOME. ! DHCSTR [ I, - ] Array containing the DEVICE_CURSOR_HOME string. ! CORXOF [ I, 0] DEVICE_COORD_XOFFSET ! CORYOF [ I, 0] DEVICE_COORD_YOFFSET ! DASBIT [ I,100] DASH_BIT_LENGTH ! CORXSC [ R,1.0] DEVICE_COORD_XSCALE ! CORYSC [ R,1.0] DEVICE_COORD_YSCALE ! ! ! CAPERR (Error flags) ! ------ ! ALLOK [ I, 0] No error condition obtains. ! EOFFL [ I, 1] End-of-file encountered. ! INTERR [ I, 2] Error decoding an integer value. ! MAXINT [ I, 3] Integer exceeds the maximum number of digits ! allowed. ! PLBERR [ I, 4] Error in defining the polyline bundle tables ! indicating that not all of the tables in the ! class are of the same length. ! PMBERR [ I, 5] Error in defining the polymarker bundle tables ! indicating that not all of the tables in the ! class are of the same length. ! FABERR [ I, 6] Error in defining the fill area bundle tables ! indicating that not all of the tables in the ! class are of the same length. ! TXBERR [ I, 7] Error in defining the text bundle tables ! indicating that not all of the tables in the ! class are of the same length. ! FLTERR [ I, 8] Error in decoding a floating point value. ! MAXFLT [ I, 9] Floating point value exceeds the maximum ! number of digits allowed. ! NOTINT [ I,10] An integer field is being decoded, but the ! value in the input graphcap file is not integer. ! SIZERR [ I,11] The string buffer is not big enough to hold ! the input string. ! UNDASC [ I,12] A value was encountered which is not in the ! local ASCII tables. ! KEYERR [ I,13] Not used. ! DOCERR [ I,14] Not used. ! TBLERR [ I,15] Not used. ! STSZER [ I,16] Not used. ! ENTERR [ I,17] Not used. ! TABERR [ I,18] Not used. ! TABSER [ I,19] Not used. ! PRSFIL [ I,20] Not used. ! ! ! CAPIO2 ! ------ ! LINE [CA, - ] Array containing the current line buffer. ! ! ! CAPIOB ! ------ ! UNIT [ I, - ] Used for the unit number for reading the ! input file, and for writing the output file. ! IPTR [ I, - ] Points to the current position in the LINE buffer. ! LSIZE [ I, - ] The number of useable characters in LINE. ! ! CAPLIN (Contains the POLYLINE information.) ! ------ ! PLAVBL [ L,.FALSE.] LINE_DRAW_POLY_FLAG ! LDSSTR [IA, - ] LINE_DRAW_INSTRUCTION_START ! LDSSIZ [ I, - ] Number of characters in LDSSTR. ! LDTSTR [IA, - ] LINE_DRAW_INSTRUCTION_TERMINATOR ! LDTSIZ [ I, - ] Number of characters in LDTSTR. ! LMSSTR [IA, - ] LINE_MOVE_INSTRUCTION_START ! LMSSIZ [ I, - ] Number of characters in LMSSTR. ! LMTSTR [IA, - ] LINE_MOVE_INSTRUCTION_TERMINATOR ! LMTSIZ [ I, - ] Number of characters in LMTSTR. ! LCSSTR [IA, - ] LINE_COLOR_INSTRUCTION_START ! LCSSIZ [ I, - ] Number of characters in LCSSTR. ! LCTSTR [IA, - ] LINE_COLOR_INSTRUCTION_TERMINATOR ! LCTSIZ [ I, - ] Number of characters in LCTSTR. ! LINFIN [IA, 0] Array dimensioned for 8 describing the ! device vector counts as follows: ! LINFIN(1) -- DEVICE_VECTOR_COUNT_ENCODING ! LINFIN(2) -- Number of lines defined ! in LINFMT. ! LINFIN(3) -- Maximum number of lines allowed ! in LINFMT. ! LINFIN(4) -- Number of entries in each ! line of LINFMT. ! ! The integer array LINFIN is equivalenced to ! the REAL array LINRIN, and ! if encoding is ASCII real, then ! LINRIN(5) -- Minimum data value input to encoder ! LINRIN(6) -- Maximum data value input to encoder ! LINRIN(7) -- Minimum data value output from ! encoder. ! LINRIN(8) -- Maximum data value output from ! encoder. ! obtained from DEVICE_VECTOR_COUNT_FLOATING_INFO ! ! if encoding is not ASCII real, then ! LINFIN(5) equals 5 . ! LINFMT [IA, 0] A two-dimensional array (dimensioned for ! LVCFMX x 4) containing the ! DEVICE_VECTOR_COUNT_FORMAT ! LWSSTR [IA, - ] LINE_WIDTH_INSTRUCTION_START ! LWSSIZ [ I, - ] Number of characters in LWSSTR. ! LWTSTR [IA, - ] LINE_WIDTH_INSTRUCTION_TERMINATOR ! LWTSIZ [ I, - ] Number of characters in LWTSTR. ! LWTFIN [IA, 0] Array dimensioned for 8 describing the ! line widths as follows: ! LWTFIN(1) -- LINE_WIDTH_ENCODING ! LWTFIN(2) -- Number of lines defined ! in LWTFMT. ! LWTFIN(3) -- Maximum number of lines allowed ! in LWTFMT. ! LWTFIN(4) -- Number of entries in each ! line of LWTFMT. ! ! The integer array LWTFIN is equivalenced to ! the REAL array LWTRIN, and ! if encoding is ASCII real, then ! LWTRIN(5) -- Minimum data value input to encoder ! LWTRIN(6) -- Maximum data value input to encoder ! LWTRIN(7) -- Minimum data value output from ! encoder. ! LWTRIN(8) -- Maximum data value output from ! encoder. ! obtained from LINE_WIDTH_FLOATING_INFO ! ! if encoding is not ASCII real, then ! LWTFIN(5) equals 5 . ! LWTFMT [IA, 0] A two-dimensional array (dimensioned for ! LWTFMX x 4) containing the ! LINE_WIDTH_FORMAT ! LWTRNG [IA, - ] Two values specifying the LINE_WIDTH_RANGE. ! LWTSCF [ R,1.0] LINE_WIDTH_SCALE ! ! ! CAPMAR (Contains POLYMARKER information.) ! ------ ! MCSSTR [IA, - ] MARKER_COLOR_INSTRUCTION_START ! MCSSIZ [ I, - ] Number of characters in MCSSTR. ! MCTSTR [IA, - ] MARKER_COLOR_INSTRUCTION_TERMINATOR ! MCTSIZ [ I, - ] Number of characters in MCTSTR. ! MARFIN [IA, 0] Array dimensioned for 5 describing the ! marker vector counts as follows: ! MARFIN(1) -- MARKER_VECTOR_COUNT_ENCODING ! MARFIN(2) -- Number of lines defined ! in MARFMT. ! MARFIN(3) -- Currently undefined. ! MARFIN(4) -- Currently undefined. ! MARFIN(5) -- Currently undefined. ! MARFMT [IA, 0] A two-dimensional array (dimensioned for ! MVCFMX x 4) containing the ! MARKER_VECTOR_COUNT_ENCODING ! MRSSTR [IA, - ] MARKER_INSTRUCTION_START ! MRSSIZ [ I, - ] Number of characters in MRSSTR. ! MRTSTR [IA, - ] MARKER_INSTRUCTION_TERMINATOR ! MRTSIZ [ I, - ] Number of charactgers in MRTSTR. ! ! ! CAPPLG (Polygon class information.) ! ------ ! PCSSTR [IA, - ] POLYGON_COLOR_INSTRUCTION_START ! PCSSIZ [ I, - ] Number of characters in PCSSTR. ! PCTSTR [IA, - ] POLYGON_COLOR_INSTRUCTION_TERMINATOR ! PCTSIZ [ I, - ] Number of characters in PCTSTR. ! PLSSTR [IA, - ] POLYGON_INSTRUCTION_START ! PLSSIZ [ I, - ] Number of characters in PLSSTR. ! PLTSTR [IA, - ] POLYGON_INSTRUCTION_TERMINATOR ! PLTSIZ [ I, - ] Number of characters in PLTSTR. ! ! ! CAPSCN (RASTER class information.) ! ------ ! SCSSTR [IA, - ] RASTER_HORIZONTAL_INSTRUCTION_START ! SCSSIZ [ I, - ] Number of characters in SCSSTR. ! SCTSTR [IA, - ] RASTER_HORIZONTAL_INSTRUCTION_TERMINATOR ! SCTSIZ [ I, - ] Number of characters in SCTSTR. ! SCNLLX [ I, - ] RASTER_COORD_LOWER_LEFT_X ! SCNLLY [ I, - ] RASTER_COORD_LOWER_LEFT_Y ! SCNURX [ I, - ] RASTER_COORD_UPPER_RIGHT_X ! SCNURY [ I, - ] RASTER_COORD_UPPER_RIGHT_Y ! SCNXOF [ I, - ] RASTER_COORD_XOFF ! SCNYOF [ I, - ] RASTER_COORD_YOFF ! SCNXSC [ R, - ] RASTER_COORD_XSCALE ! SCNYSC [ R, - ] RASTER_COORD_YSCALE ! SCNFMT [IA, 0] A two-dimensional array (dimensioned for ! SFMFMX x 4) containing the ! RASTER_DATA_FORMAT ! SCNFIN [IA, 0] Array dimensioned for 8 describing the ! raster data format as follows: ! SCNFIN(1) -- RASTER_DATA_ENCODING ! SCNFIN(2) -- Number of lines defined ! in SCNFMT. ! SCNFIN(3) -- Maximum number of lines allowed ! in SCNFMT. ! SCNFIN(4) -- Number of entries in each ! line of SCNFMT. ! ! The integer array SCNFIN is equivalenced to ! the REAL array SCNRIN, and ! if encoding is ASCII real, then ! SCNRIN(5) -- Minimum data value input to encoder ! SCNRIN(6) -- Maximum data value input to encoder ! SCNRIN(7) -- Minimum data value output from ! encoder. ! SCNRIN(8) -- Maximum data value output from ! encoder. ! obtained from RASTER_DATA_FLOATING_INFO ! SCVFMT [IA, 0] A two-dimensional array (dimensioned for ! SCVFMX x 4) containing the ! RASTER_VECTOR_COUNT_FORMAT ! SCVFIN [IA, 0] Array dimensioned for 8 describing the ! raster vector count format as follows: ! SCVFIN(1) -- RASTER_VECTOR_COUNT_ENCODING ! SCVFIN(2) -- Number of lines defined ! in SCVFMT. ! SCVFIN(3) -- Maximum number of lines allowed ! in SCVFMT. ! SCVFIN(4) -- Number of entries in each ! line of SCVFMT. ! ! The integer array SCVFIN is equivalenced to ! the REAL array SCVRIN, and ! if encoding is ASCII real, then ! SCVRIN(5) -- Minimum data value input to encoder ! SCVRIN(6) -- Maximum data value input to encoder ! SCVRIN(7) -- Minimum data value output from ! encoder. ! SCVRIN(8) -- Maximum data value output from ! encoder. ! obtained from RASTER_VECTOR_COUNT_FLOATING_INFO ! SCNSIM [ L,.FALSE.] RASTER_SIMULATE ! ! ! CAPSKP (Controls printing of the input lines.) ! ------ ! SKIPIT [ L,.TRUE.] Controls printing of the input lines, if ! SKIPIT is .TRUE., then the input lines are ! not printed; if SKIPIT is .FALSE., then ! the input lines are printed. ! ! ! CAPSPC (Dummy graphcap space for future expansion, the first ! ------ 5 locations are temporarily defined to support the NCAR ! color DICOMED--this situation will be cleaned up for ! release 3.0 .) ! VDWLLX [ I, 0] TMP_WINDOW_LOWER_LEFT_X ! VDWLLY [ I, 0] TMP_WINDOW_LOWER_LEFT_X ! VDWURX [ I, 32767] TMP_WINDOW_UPPER_RIGHT_Y ! VDWURY [ I, 32767] TMP_WINDOW_UPPER_RIGHT_Y ! PLGSIM [ L, .TRUE.] TMP_SIMULATE ! DUMSPC [ I, - ] SCRATCH SPACE (DIMENSIONED FOR DUMSIZ) ! ! ! CAPTXT (TEXT class information.) ! ------ ! TCSSTR [IA, - ] TEXT_COLOR_INSTRUCTION_START ! TCSSIZ [ I, - ] Number of characters in TCSSTR. ! TCTSTR [IA, - ] TEXT_COLOR_INSTRUCTION_TERMINATOR ! TCTSIZ [ I, - ] Number of characters in TCTSTR. ! TXTFMT [IA, 0] A two-dimensional array (dimensioned for ! TVCFMX x 4) containing the ! TEXT_VECTOR_COUNT_FORMAT ! TXTFIN [IA, 0] Array dimensioned for 5 describing the ! text vector count format as follows: ! TXTFIN(1) -- TEXT_VECTOR_COUNT_ENCODING ! TXTFIN(2) -- Number of lines defined ! in TXTFMT. ! TXTFIN(3) -- Currently not used. ! TXTFIN(4) -- Currently not used. ! TXSSTR [IA, - ] TEXT_INSTRUCTION_START ! TXSSIZ [ I, - ] Number of characters in TXSSTR. ! TXTSTR [IA, - ] TEXT_INSTRUCTION_TERMINATOR ! TXTSIZ [ I, - ] Number of characters in TXTSIZ. ! ! ! CAPUSR ! ------ ! UPRSTR [IA, - ] USER_PROMPT ! UPRSIZ [ I, - ] Number of characters in UPRSTR. ! ! ! PARTB1 ! ------ ! PART1 [CA, - ] Contains all character sequences ! which are pertinent to parsing then ! input graphcap file. PART1 is ! initialized in the BLOCKDATA. ! KEYSEP [ C,'_'] A character*1 variable containing ! the keyword separator. ! KEYTER [ C,' '] A character*1 variable containing the ! keyword terminator. ! FRCOM [CA,'/','*'] A character*1 array of dimension 2 ! containing the two initial characters ! which will cause a line in the input ! grpaphcap to be regarded as a comment line. ! ! PARTB2 ! ------ ! PART2 [IA, - ] An array of pointers indicating the ! the next jump in the parse tree. See ! the example after the description of ! PART5 to see how the parse tables ! interact.For ! ! we should go to the 24th section of ! keywords in PART1 to find our next ! keyword. ! PART4(24) = 786 indicating we should ! ! indicates we should go to PART2(88) ! to see where the next row of keywords ! is. PART2(88) = 24, and PART3(24) = ! 5 ! PART3 [IA, - ] Contains pointers into PART4. ! PART4 [IA, - ] Contains pointers into PART1. These pointers ! indicate where the first character ! of sections of keywords are located in PART1. ! PART5 [IA, - ] Pairs of integers indicating how many keywords ! are in a given section in PART1, and how ! many characters in length each keyword ! in that section is. Currently there are ! 24 different keyword sections in PART1, i.e. ! PART1 is segmented into 24 different sections. ! ! DISCUSSION of the parse tables: ! The keywords necessary to the parsing are ! stored in PART1 in groups. Within each ! group, all keywords have the same length ! (some may have to be blank padded to satisfy ! this.) The values in PART4 indicate where ! in PART1 groups of keywords begin. The ! values in PART5 indicate, for each group of ! keywords in PART1, how many keywords are ! in that group, and the length of each word ! in the group. The values in PART3 are pointers ! to the various keyword groups. ! ! EXAMPLE: Let us consider an example of how ! the various parse tables interact. Suppose ! the input keyword string being parsed is ! RASTER_HORIZONTAL_INSTRUCTION_TERMINATOR. ! The keyword RASTER is the 9th entry ! in the initial group of keywords in PART1 ! (the 9 entries being: DEVICE, LINE, USER, ! BUNDLE, TEXT, MARKER, POLYGON, DASH, ! and RASTER.) PART2 is used to determine ! which group of keywords to search next after ! RASTER has been found. If PART2(9) = N, ! and PART3(N) = M, then the next group of ! keywords to be searched is the Mth group ! which starts at PART4(M). If the keyword ! matched within the current keyword group is ! number L, then PART2(N+L-1) provides the ! pointer into PART3 which will produce the ! number of the next keyword group to be ! searched. This procedure is continued ! until the entry in PART2 is 0, indicating ! the final keyword has been found. ! CTSTR [ I, - ] Currently unused. ! CTLOC [ I, - ] Currently unused. ! ! ! ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer, parameter :: LNMAX = 80 character LINE(LNMAX) integer unit, IPTR, LSIZE ! ! CONTROL THE PRINTING OF INPUT LINES ! common /CAPSKP/ SKIPIT LOGICAL SKIPIT ! integer IOS, status, II character DFLNAM(80) character*80 ARG1, ARG2 ! ! Initialize STATUS to ALLOK. ! status = allok ! ! Get the file name of the ASCII input graphcap. ! call getarg(1,ARG1) do II = 1,80 DFLNAM(II) = ARG1(II:II) end do UNIT = 1 ! ! Open the input graphcap for reading. ! call chropn ( unit, DFLNAM, ios, status ) ! ! Error opening the input file. ! if ( STATUS /= allok ) then write ( *, * ) ' ' write ( *, * ) 'CAPCHG - Fatal error!' write ( *, * ) ' Could not open the ASCII graphcap file.' write ( *, * ) ' IOS = ', ios stop end if ! ! Parse the character graphcap file. ! call cappar ( ios, status ) if ( STATUS /= allok .and. STATUS /= EOFFL ) then ! ! Error reading the file. ! write ( *, * ) ' ' write ( *, * ) 'CAPCHG - Fatal error!' write ( *, * ) ' Error reading the ASCII graphcap file.' write ( *, * ) ' status = ', status write ( *, * ) ' IOS = ', ios call chrcls ( unit, ios, status ) stop end if ! ! Close the input graphcap file. ! call chrcls ( unit, ios, status ) ! ! Get the file name for the binary output file. ! call getarg ( 2, arg2 ) do II = 1, 80 DFLNAM(II) = ARG2(II:II) end do UNIT = 1 ! ! Open the binary graphcap output file. ! call binopn ( unit, DFLNAM, ios, status ) if ( STATUS /= 0 ) then write ( *, * ) ' ' write ( *, * ) 'CAPCHG - Fatal error!' write ( *, * ) ' Could not open the binary graphcap file.' stop end if ! ! Write the output file. ! call binput ( unit, ios, status ) if ( STATUS /= 0 ) then ! ! Error writing the file. ! write ( *, * ) ' ' write ( *, * ) 'CAPCHG - Fatal error!' write ( *, * ) ' Could not write the binary graphcap file.' write ( *, * ) ' status = ', status write ( *, * ) ' IOS = ', ios call bincls ( unit, ios, status ) stop end if ! ! Close the output file. ! call bincls ( unit, ios, status ) stop end subroutine bincls ( unit, ios, status ) ! !******************************************************************************* ! !! BINCLS closes the binary graphcap file. ! ! ! Modified: ! ! 06 August 2001 ! ! Parameters: ! ! Input, integer unit, the unit number of the output unit. ! ! Output, integer IOS, the I/O status word, this is valid only if STATUS ! indicates an error. ! ! Output, integer STATUS, the error status as defined by common CAPERR. ! integer ios integer status integer unit ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL ! ! Initialize STATUS to ALLOK. ! status = allok close ( unit = unit, iostat = ios ) if ( ios /= 0 ) then status = allok + 1 end if return end subroutine binput ( unit, ios, status ) ! !******************************************************************************* ! !! BINPUT writes out the binary graphcap file. ! ! ! Parameters: ! ! Input, integer unit, the unit number of the output unit. ! ! Output, integer IOS, the I/O status word, this is valid only if STATUS ! indicates an error. ! ! Output, integer STATUS, the error status as defined by common CAPERR. ! ! All information put to the output file is contained in ! common blocks. Following is a list of the common blocks ! which are written out, and their sizes. One record is ! written for each common block. ! ! common SIZE ! ------ ------ ! CAPDEV LENDEV ! CAPLIN LENLIN ! CAPUSR LENUSR ! CAPCOL LENCOL ! CAPTXT LENTXT ! CAPMAR LENMAR ! CAPPLG LENPLG ! CAPBND LENBND ! CAPSCN LENSCN ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) common /CAPLIN/ PLAVBL, & LDSSTR, LDSSIZ, LDTSTR, & LDTSIZ, LMSSTR, LMSSIZ, & LMTSTR, LMTSIZ, LCSSTR, LCSSIZ, & LCTSTR, LCTSIZ, LINFIN, LINFMT, & LWSSTR, LWSSIZ, LWTSTR, LWTSIZ, & LWTFIN, LWTFMT, LWTRNG, LWTSCF integer LDSMAX, LDTMAX, LMSMAX, LMTMAX, & LCSMAX, LCTMAX, LVCFMX, LWSMAX, LWTMAX, LWTFMX parameter (LDSMAX=10, LDTMAX=10, LMSMAX=10, & LMTMAX=10, LCSMAX=10, & LCTMAX=10, LVCFMX=5, LWSMAX=10, LWTMAX=10, & LWTFMX=5) LOGICAL PLAVBL integer LDSSTR(LDSMAX), LDSSIZ, & LDTSTR(LDTMAX), LDTSIZ, LMSSTR(LMSMAX), LMSSIZ, & LMTSTR(LMTMAX), LMTSIZ, & LCSSTR(LCSMAX), LCSSIZ, & LCTSTR(LCTMAX), LCTSIZ, & LINFIN(8), LINFMT(LVCFMX,4), & LWSSTR(LWSMAX), LWSSIZ, LWTSTR(LWTMAX), LWTSIZ, & LWTFIN(8), LWTFMT(LWTFMX,4), LWTRNG(2) REAL LWTSCF,LINRIN(8),LWTRIN(8) ! SIZE OF THE common BLOCK integer LENLIN parameter(LENLIN=1+LDSMAX+1+LDTMAX+1+LMSMAX+1+ & LMTMAX+1+LCSMAX+1+ & LCTMAX+1+8+LVCFMX*4 & +LWSMAX+1+LWTMAX+1+8+LWTFMX*4+2+1) equivalence (LINFIN,LINRIN), (LWTFIN,LWTRIN) common /CAPUSR/ UPRSTR, UPRSIZ integer UPRMAX parameter (UPRMAX=50) integer UPRSTR(UPRMAX), UPRSIZ ! SIZE OF common BLOCK integer LENUSR parameter (LENUSR=UPRMAX+1) common /CAPCOL/ COLINT, COLIDX, IDXCUR, VDMINT, DMPAVL, COLFMT & ,COLFIN, IDXMAX, MSTSTR, MSTSIZ, MTRSTR, DMPMDL & ,MTRSIZ, DMPIDV, DMPFIN, DMPFMT integer MAPMAX, COLMAX, MSTMAX, MTRMAX, DMPMAX parameter (MAPMAX=256, COLMAX=10, MSTMAX=30, MTRMAX=10) parameter (DMPMAX=50) integer COLINT(MAPMAX*3), COLIDX(MAPMAX), IDXCUR, VDMINT, & IDXMAX, COLFMT(COLMAX,4), COLFIN(8), DMPMDL, & MSTSTR(MSTMAX), MSTSIZ, MTRSTR(MTRMAX), MTRSIZ, & DMPFIN(8), DMPFMT(DMPMAX,4) LOGICAL DMPAVL, DMPIDV integer LENCOL REAL COLRIN(8),DMPRIN(8) parameter (LENCOL=MAPMAX*4+3+COLMAX*4+8+1+MSTMAX+1+MTRMAX+1+3 & +DMPMAX*4+7) equivalence (COLFIN,COLRIN),(DMPFIN,DMPRIN) common/CAPBND/PLBTEC,PLIBTB,PLTBTB,PLWBTB,PLCBTB, & PMBTEC,PMIBTB,PMTBTB,PMSBTB,PMCBTB, & TXBTEC,TXIBTB,TXFBTB,TXPBTB,TCXBTB, & TCSBTB,TXCBTB, & FABTEC,FAIBTB,FISBTB,FASBTB,FACBTB integer TBLSIZ parameter (TBLSIZ=6) integer PLBTEC,PLIBTB(TBLSIZ),PLTBTB(TBLSIZ),PLCBTB(TBLSIZ), & PMBTEC,PMIBTB(TBLSIZ),PMTBTB(TBLSIZ),PMCBTB(TBLSIZ), & TXBTEC,TXIBTB(TBLSIZ),TXFBTB(TBLSIZ),TXPBTB(TBLSIZ), & TXCBTB(TBLSIZ),FACBTB(TBLSIZ), & FABTEC,FAIBTB(TBLSIZ),FISBTB(TBLSIZ),FASBTB(TBLSIZ) REAL PLWBTB(TBLSIZ),PMSBTB(TBLSIZ),TCXBTB(TBLSIZ),TCSBTB(TBLSIZ) integer LENBND parameter (LENBND=4+18*TBLSIZ) common /CAPTXT/ TCSSTR, TCSSIZ, TCTSTR, TCTSIZ, TXTFIN, TXTFMT, & TXSSTR, TXSSIZ, TXTSTR, TXTSIZ integer TCSMAX, TCTMAX, TVCFMX, TXSMAX, TXTMAX parameter (TCSMAX=10, TCTMAX=10, TVCFMX=5, TXSMAX=20, TXTMAX=20) integer TCSSTR(TCSMAX), TCSSIZ, & TCTSTR(TCTMAX), TCTSIZ, & TXTFIN(5), TXTFMT(TVCFMX,4), TXSSTR(TXSMAX), TXSSIZ, & TXTSTR(TXTMAX), TXTSIZ ! ! SIZE OF common CAPTXT ! integer LENTXT parameter (LENTXT=TCSMAX+TCTMAX+2+5+TVCFMX*4+TXSMAX+1+TXTMAX+1) common /CAPMAR/ MCSSTR, MCSSIZ, MCTSTR, MCTSIZ, MARFIN, MARFMT, & MRSSTR, MRSSIZ, MRTSTR, MRTSIZ integer MCSMAX, MCTMAX, MVCFMX, MRSMAX, MRTMAX parameter (MCSMAX=10, MCTMAX=10, MVCFMX=5, MRSMAX=20, MRTMAX=10) integer MCSSTR(MCSMAX), MCSSIZ, & MCTSTR(MCTMAX), MCTSIZ, & MRSSTR(MRSMAX), MRSSIZ, MRTSTR(MRTMAX), MRTSIZ, & MARFIN(5), MARFMT(MVCFMX,4) ! ! SIZE OF common CAPMAR ! integer LENMAR parameter (LENMAR=MCSMAX+MCTMAX+2+MRSMAX+1+MRTMAX+1+5+MVCFMX*4) common /CAPPLG/ PCSSTR, PCSSIZ, PCTSTR, PCTSIZ, & PLSSTR, PLSSIZ, PLTSTR, PLTSIZ integer PCSMAX, PCTMAX, PLSMAX, PLTMAX parameter (PCSMAX=10, PCTMAX=10, PLSMAX=20, PLTMAX=10) integer PCSSTR(PCSMAX), PCSSIZ, & PCTSTR(PCTMAX), PCTSIZ, & PLSSTR(PLSMAX), PLSSIZ, PLTSTR(PLTMAX), PLTSIZ ! ! SIZE OF common CAPPLG ! integer LENPLG parameter (LENPLG=PCSMAX+PCTMAX+2+PLSMAX+1+PLTMAX+1) common /CAPSPC/ VDWLLX,VDWLLY,VDWURX,VDWURY,PLGSIM,DUMSPC integer DUMSIZ parameter (DUMSIZ=1288) integer DUMSPC(DUMSIZ) integer VDWLLX,VDWLLY,VDWURX,VDWURY LOGICAL PLGSIM common /CAPSCN/ SCSSTR, SCSSIZ, SCTSTR, SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNXSC, SCNYSC, SCNFMT, SCNFIN, SCVFMT, SCVFIN, & SCNSIM integer SCSMAX, SCTMAX, SFMMAX, SFNMAX, SCVFMX, SCVFIX parameter(SCSMAX=50, SCTMAX=50, SFMMAX=10, SFNMAX=8) parameter(SCVFMX=10, SCVFIX=8) integer SCSSTR(SCSMAX), SCSSIZ, & SCTSTR(SCTMAX), SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNFMT(SFMMAX, 4), SCNFIN(SFNMAX), SCVFMT(SCVFMX,4), & SCVFIN(SCVFIX) REAL SCNXSC, SCNYSC, SCNRIN(SFNMAX), SCVRIN(SCVFIX) LOGICAL SCNSIM integer LENSCN parameter (LENSCN=SCSMAX+1+SCTMAX+7+(SFMMAX*4)+SFNMAX+(SCVFMX*4) & +SCVFIX+3) equivalence (SCNFIN,SCNRIN), (SCVFIN,SCVRIN) ! integer unit, ios, status REAL ALOG10 integer II ! ! Initialize STATUS to ALLOK. ! status = allok ! ! Set the size of the device color map if it has not been defined. ! if ( IDXMAX == -1 ) then IDXMAX = IDXCUR end if ! ! if necessary, reduce the map size to the maximum allowed ! in the translator. ! if ( IDXMAX > MAPMAX ) then IDXMAX = MAPMAX end if ! ! Write out the workstation DEVICE definitions. ! CORFIN(3) = DCFTMX CORFIN(4) = 4 call binwri(unit, LENDEV, DGISTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the workstation LINE drawing definitions. ! LINFIN(3) = LVCFMX LINFIN(4) = 4 if (LINFIN(1) /= 5) LINFIN(5) = 5 LWTFIN(3) = LWTFMX LWTFIN(4) = 4 if (LWTFIN(1) /= 5) LWTFIN(5) = 5 call binwri(unit, LENLIN, PLAVBL, ios, status) if (STATUS /= allok ) then return end if ! ! Write out the USER interface data. ! call binwri(unit, LENUSR, UPRSTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the DEVICE color map information. ! COLFIN(3) = COLMAX COLFIN(4) = 4 ! ! Set the number of characters required to encode a color index, ! if the encoding is not ASCII real. ! if (COLFIN(1) /= 5) then COLFIN(5) = int ( ALOG10 ( real ( IDXMAX + 1 ) ) + 1 ) end if DMPFIN(3) = DMPMAX DMPFIN(4) = 4 ! ! Set the number of characters required to encode a color intensity, ! if the encoding is not ASCII real. ! if (DMPFIN(1) /= 5) then IDX3 = MAPMAX*3 INTMAX = 0 do I=1,IDX3 INTMAX = MAX0(COLINT(I),INTMAX) end do DMPFIN(5) = int ( ALOG10 ( real ( INTMAX + 1 ) ) + 1 ) end if call binwri(unit, LENCOL, COLINT, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the device TEXT data. ! call binwri(unit, LENTXT, TCSSTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the device MARKER data. ! call binwri(unit, LENMAR, MCSSTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the device POLYGON data. ! call binwri(unit, LENPLG, PCSSTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the BUNDLE tables. ! call binwri(unit, LENBND, PLBTEC, ios, status) if ( STATUS /= allok ) then return end if ! ! Write out the RASTER class data. ! SCVFIN(3) = SCVFMX SCVFIN(4) = 4 SCNFIN(3) = SFMMAX SCNFIN(4) = 4 call binwri(unit, LENSCN, SCSSTR, ios, status) if ( STATUS /= allok ) then return end if ! ! Zero out the dummy space and put to the output file. ! Currently the first five locations of the dummy space ! are defined to support the NCAR color DICOMED--this ! situation will be cleaned up for Release 3.0 . ! DUMSPC(1:DUMSIZ) = 0 call binwri(unit, DUMSIZ+5, VDWLLX, ios, status) return end subroutine bndcls ( which, ios, status) ! !******************************************************************************* ! !! BNDCLS processes the BUNDLE class keywords. ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common/CAPBND/PLBTEC,PLIBTB,PLTBTB,PLWBTB,PLCBTB, & PMBTEC,PMIBTB,PMTBTB,PMSBTB,PMCBTB, & TXBTEC,TXIBTB,TXFBTB,TXPBTB,TCXBTB, & TCSBTB,TXCBTB, & FABTEC,FAIBTB,FISBTB,FASBTB,FACBTB integer TBLSIZ parameter (TBLSIZ=6) integer PLBTEC,PLIBTB(TBLSIZ),PLTBTB(TBLSIZ),PLCBTB(TBLSIZ), & PMBTEC,PMIBTB(TBLSIZ),PMTBTB(TBLSIZ),PMCBTB(TBLSIZ), & TXBTEC,TXIBTB(TBLSIZ),TXFBTB(TBLSIZ),TXPBTB(TBLSIZ), & TXCBTB(TBLSIZ),FACBTB(TBLSIZ), & FABTEC,FAIBTB(TBLSIZ),FISBTB(TBLSIZ),FASBTB(TBLSIZ) REAL PLWBTB(TBLSIZ),PMSBTB(TBLSIZ),TCXBTB(TBLSIZ),TCSBTB(TBLSIZ) integer LENBND parameter (LENBND=4+18*TBLSIZ) ! integer WHICH(WHSIZE), ios, status integer ROW1, ROW2 integer DUMMY ! ! Branch to the proper level 2 processing. ! ROW1 = WHICH(2) ROW2 = WHICH(3) ! ! BUNDLE processing-- ! ! ROW1 ROW2 Keyword ! ---- ---- ------------------------- ! 1 1 BUNDLE_LINE_INDEX ! 1 2 BUNDLE_LINE_TYPE ! 1 3 BUNDLE_LINE_WIDTH ! 1 4 BUNDLE_LINE_COLOR ! 2 1 BUNDLE_MARKER_INDEX ! 2 2 BUNDLE_MARKER_TYPE ! 2 3 BUNDLE_MARKER_SIZE ! 2 4 BUNDLE_MARKER_COLOR ! 3 1 BUNDLE_POLYGON_INDEX ! 3 2 BUNDLE_POLYGON_INTERIOR ! 3 3 BUNDLE_POLYGON_STYLE ! 3 4 BUNDLE_POLYGON_COLOR ! 4 1 BUNDLE_TEXT_INDEX ! 4 2 BUNDLE_TEXT_FONT ! 4 3 BUNDLE_TEXT_PRECISION ! 4 4 BUNDLE_TEXT_CEXPN ! 4 5 BUNDLE_TEXT_CSPACE ! 4 6 BUNDLE_TEXT_COLOR ! ! Branch to proper level 2 . ! go to (100,200,300,400),ROW1 ! ! BUNDLE_LINE class. ! 100 go to (110,120,130,140),ROW2 110 CONTINUE call gtint(PLIBTB, TBLSIZ, dummy, ios, status) go to 190 120 CONTINUE call gtint(PLTBTB, TBLSIZ, dummy, ios, status) go to 190 130 CONTINUE call gtflt(PLWBTB, TBLSIZ, dummy, ios, status) go to 190 140 CONTINUE call gtint(PLCBTB, TBLSIZ, dummy, ios, status) 190 CONTINUE if (STATUS /= allok) return ! ! Check if the lengths of all the tables are the same. ! if (PLBTEC == -1) then PLBTEC = DUMMY else if (PLBTEC /= DUMMY) status = PLBERR end if return ! ! BUNDLE_MARKER class. ! 200 continue if ( ROW2 == 1 ) then call gtint(PMIBTB, TBLSIZ, dummy, ios, status) else if ( ROW2 == 2 ) then call gtint(PMTBTB, TBLSIZ, dummy, ios, status) else if ( ROW2 == 3 ) then call gtflt(PMSBTB, TBLSIZ, dummy, ios, status) else if ( ROW2 == 4 ) then call gtint(PMCBTB, TBLSIZ, dummy, ios, status) end if if (STATUS /= allok) return ! ! Check if the lengths of all the tables are the same. ! if (PMBTEC == -1) then PMBTEC = DUMMY else if (PMBTEC /= DUMMY) status = PMBERR end if return ! ! BUNDLE_POLYGON class. ! 300 go to (310,320,330,340),ROW2 310 CONTINUE call gtint(FAIBTB, TBLSIZ, dummy, ios, status) go to 390 320 CONTINUE call gtint(FISBTB, TBLSIZ, dummy, ios, status) go to 390 330 CONTINUE call gtint(FASBTB, TBLSIZ, dummy, ios, status) go to 390 340 CONTINUE call gtint(FACBTB, TBLSIZ, dummy, ios, status) 390 CONTINUE if (STATUS /= allok) return ! ! Check if the lengths of all the tables are the same. ! if (FABTEC == -1) then FABTEC = DUMMY else if (FABTEC /= DUMMY) status = FABERR end if return ! ! BUNDLE_TEXT class. ! 400 go to (410,420,430,440,450,460),ROW2 410 CONTINUE call gtint(TXIBTB, TBLSIZ, dummy, ios, status) go to 490 420 CONTINUE call gtint(TXFBTB, TBLSIZ, dummy, ios, status) go to 490 430 CONTINUE call gtint(TXPBTB, TBLSIZ, dummy, ios, status) go to 490 440 CONTINUE call gtflt(TCXBTB, TBLSIZ, dummy, ios, status) go to 490 450 CONTINUE call gtflt(TCSBTB, TBLSIZ, dummy, ios, status) go to 490 460 CONTINUE call gtint(TXCBTB, TBLSIZ, dummy, ios, status) 490 CONTINUE if (STATUS /= allok) return ! ! Check if the lengths of all the tables are the same. ! if ( TXBTEC == -1 ) then TXBTEC = DUMMY else if ( TXBTEC /= DUMMY ) then status = TXBERR end if end if return end blockdata CAPAST ! !******************************************************************************* ! !! CAPAST is a set of block data defining the ASCII conversion tables. ! common /CAPASC/ ASCTB1, ASCTB2 integer TBLLE1, TBLWT1, INTVAL, TBLLE2, CORDVL parameter (TBLLE1=41, TBLWT1=3, INTVAL=-1, TBLLE2=94, CORDVL=-7) character*1 ASCTB1(TBLLE1, TBLWT1), ASCTB2(TBLLE2) common /CAPASI/ ASCVL1, ASCVL2 integer ASCVL1(TBLLE1), ASCVL2(TBLLE2) ! integer II, JJ ! ! ASCTB1 ! Table containing all 3-character sequences ! which have special meaning to the translator. ! This includes the special ASCII characters ! with ADE values between 0 and 31 (decimal). ! DATA ((ASCTB1(II, JJ),JJ=1,TBLWT1),II=1,TBLLE1)/ & 'R','L',' ', & 'M','A','D','X','Y','C','X','C',' ','Y','C',' ','V','C',' ', & 'I','N','T','N','U','L','S','O','H','S','T','X','E','T','X', & 'E','O','T', & 'E','N','Q','A','C','K','B','E','L','B','S',' ','H','T',' ', & 'L','F',' ','V','T',' ','F','F',' ','C','R',' ','S','O',' ', & 'S','I',' ','D','L','E','D','C','1','D','C','2','D','C','3', & 'D','C','4','N','A','K','S','Y','N','E','T','B','C','A','N', & 'E','M',' ','S','U','B','E','S','C','F','S',' ','G','S',' ', & 'R','S',' ','U','S',' ','S','P','C','D','E','L'/ ! ! ASCTB2 ! Table of all ASCII characters with ADE values ! between 33 and 126 (decimal). ! DATA ASCTB2 /'!','"','#','$','%','&','''','(',')','*','+',',', & '-','.','/','0','1','2','3','4','5','6','7','8','9',':',';', & '<','=','>','?','@','A','B','C','D','E','F','G','H','I','J', & 'K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y', & 'Z','[','\\',']','^','_','`','a','b','c','d','e','f','g','h', & 'i','j','k','l','m','n','o','p','q','r','s','t','u','v','w', & 'x','y','z','{','|','}','~'/ ! ! ASCVL1 ! A table containing decimal equivalents to the ! characters in ASCTB1. Special negative values ! are assigned to the strings which are significant ! to the translator, but are not part of the ASCII ! character set. DATA ASCVL1/ & -7, & -6,-5,-4,-3,-2, & -1,0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19, & 20,21,22,23,24,25,26,27,28,29,30,31,32,127/ ! ! ASCVL2 ! A table containing decimal equivalents for the ! ASCII characters in table ASCTB2. ! DATA ASCVL2/33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50, & 51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71, & 72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92, & 93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109, & 110,111,112,113,114,115,116,117,118,119,120,121,122,123,124, & 125,126/ ! end blockdata CAPDAT ! !******************************************************************************* ! !! CAPDAT is block data defining the data used by the CAPCHG program. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) common /CAPLIN/ PLAVBL, & LDSSTR, LDSSIZ, LDTSTR, & LDTSIZ, LMSSTR, LMSSIZ, & LMTSTR, LMTSIZ, LCSSTR, LCSSIZ, & LCTSTR, LCTSIZ, LINFIN, LINFMT, & LWSSTR, LWSSIZ, LWTSTR, LWTSIZ, & LWTFIN, LWTFMT, LWTRNG, LWTSCF integer LDSMAX, LDTMAX, LMSMAX, LMTMAX, & LCSMAX, LCTMAX, LVCFMX, LWSMAX, LWTMAX, LWTFMX parameter (LDSMAX=10, LDTMAX=10, LMSMAX=10, & LMTMAX=10, LCSMAX=10, & LCTMAX=10, LVCFMX=5, LWSMAX=10, LWTMAX=10, & LWTFMX=5) LOGICAL PLAVBL integer LDSSTR(LDSMAX), LDSSIZ, & LDTSTR(LDTMAX), LDTSIZ, LMSSTR(LMSMAX), LMSSIZ, & LMTSTR(LMTMAX), LMTSIZ, & LCSSTR(LCSMAX), LCSSIZ, & LCTSTR(LCTMAX), LCTSIZ, & LINFIN(8), LINFMT(LVCFMX,4), & LWSSTR(LWSMAX), LWSSIZ, LWTSTR(LWTMAX), LWTSIZ, & LWTFIN(8), LWTFMT(LWTFMX,4), LWTRNG(2) REAL LWTSCF,LINRIN(8),LWTRIN(8) ! SIZE OF THE common BLOCK integer LENLIN parameter(LENLIN=1+LDSMAX+1+LDTMAX+1+LMSMAX+1+ & LMTMAX+1+LCSMAX+1+ & LCTMAX+1+8+LVCFMX*4 & +LWSMAX+1+LWTMAX+1+8+LWTFMX*4+2+1) equivalence (LINFIN,LINRIN), (LWTFIN,LWTRIN) common /CAPUSR/ UPRSTR, UPRSIZ integer UPRMAX parameter (UPRMAX=50) integer UPRSTR(UPRMAX), UPRSIZ ! SIZE OF common BLOCK integer LENUSR parameter (LENUSR=UPRMAX+1) common /CAPCOL/ COLINT, COLIDX, IDXCUR, VDMINT, DMPAVL, COLFMT & ,COLFIN, IDXMAX, MSTSTR, MSTSIZ, MTRSTR, DMPMDL & ,MTRSIZ, DMPIDV, DMPFIN, DMPFMT integer MAPMAX, COLMAX, MSTMAX, MTRMAX, DMPMAX parameter (MAPMAX=256, COLMAX=10, MSTMAX=30, MTRMAX=10) parameter (DMPMAX=50) integer COLINT(MAPMAX*3), COLIDX(MAPMAX), IDXCUR, VDMINT, & IDXMAX, COLFMT(COLMAX,4), COLFIN(8), DMPMDL, & MSTSTR(MSTMAX), MSTSIZ, MTRSTR(MTRMAX), MTRSIZ, & DMPFIN(8), DMPFMT(DMPMAX,4) LOGICAL DMPAVL, DMPIDV integer LENCOL REAL COLRIN(8),DMPRIN(8) parameter (LENCOL=MAPMAX*4+3+COLMAX*4+8+1+MSTMAX+1+MTRMAX+1+3 & +DMPMAX*4+7) equivalence (COLFIN,COLRIN),(DMPFIN,DMPRIN) common/CAPBND/PLBTEC,PLIBTB,PLTBTB,PLWBTB,PLCBTB, & PMBTEC,PMIBTB,PMTBTB,PMSBTB,PMCBTB, & TXBTEC,TXIBTB,TXFBTB,TXPBTB,TCXBTB, & TCSBTB,TXCBTB, & FABTEC,FAIBTB,FISBTB,FASBTB,FACBTB integer TBLSIZ parameter (TBLSIZ=6) integer PLBTEC,PLIBTB(TBLSIZ),PLTBTB(TBLSIZ),PLCBTB(TBLSIZ), & PMBTEC,PMIBTB(TBLSIZ),PMTBTB(TBLSIZ),PMCBTB(TBLSIZ), & TXBTEC,TXIBTB(TBLSIZ),TXFBTB(TBLSIZ),TXPBTB(TBLSIZ), & TXCBTB(TBLSIZ),FACBTB(TBLSIZ), & FABTEC,FAIBTB(TBLSIZ),FISBTB(TBLSIZ),FASBTB(TBLSIZ) REAL PLWBTB(TBLSIZ),PMSBTB(TBLSIZ),TCXBTB(TBLSIZ),TCSBTB(TBLSIZ) integer LENBND parameter (LENBND=4+18*TBLSIZ) common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC ! ! CONTROL THE PRINTING OF INPUT LINES ! common /CAPSKP/ SKIPIT LOGICAL SKIPIT common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE common /CAPSCN/ SCSSTR, SCSSIZ, SCTSTR, SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNXSC, SCNYSC, SCNFMT, SCNFIN, SCVFMT, SCVFIN, & SCNSIM integer SCSMAX, SCTMAX, SFMMAX, SFNMAX, SCVFMX, SCVFIX parameter(SCSMAX=50, SCTMAX=50, SFMMAX=10, SFNMAX=8) parameter(SCVFMX=10, SCVFIX=8) integer SCSSTR(SCSMAX), SCSSIZ, & SCTSTR(SCTMAX), SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNFMT(SFMMAX, 4), SCNFIN(SFNMAX), SCVFMT(SCVFMX,4), & SCVFIN(SCVFIX) REAL SCNXSC, SCNYSC, SCNRIN(SFNMAX), SCVRIN(SCVFIX) LOGICAL SCNSIM integer LENSCN parameter (LENSCN=SCSMAX+1+SCTMAX+7+(SFMMAX*4)+SFNMAX+(SCVFMX*4) & +SCVFIX+3) equivalence (SCNFIN,SCNRIN), (SCVFIN,SCVRIN) common /CAPSPC/ VDWLLX,VDWLLY,VDWURX,VDWURY,PLGSIM,DUMSPC integer DUMSIZ parameter (DUMSIZ=1288) integer DUMSPC(DUMSIZ) integer VDWLLX,VDWLLY,VDWURX,VDWURY LOGICAL PLGSIM ! ! Used for initialization of the device color map. ! integer II integer MAP3TM parameter (MAP3TM=MAPMAX*3) ! ! Set input line printing to off. ! DATA SKIPIT/.TRUE./ ! ! Default the device flag to interactive. ! DATA BATCH /.FALSE./ ! ! Define the error flags. ! DATA ALLOK, EOFFL, INTERR, MAXINT, PLBERR /0, 1, 2, 3, 4/ DATA PMBERR, FABERR, TXBERR, FLTERR, MAXFLT /5, 6, 7, 8, 9/ DATA NOTINT, SIZERR, UNDASC, KEYERR, DOCERR /10, 11, 12,13, 14/ DATA TBLERR, STSZER, ENTERR, TABERR, TABSER/15, 16, 17, 18, 19/ DATA PRSFIL /20/ ! ! Define the keyword separator and terminator. ! DATA KEYSEP/'_'/, KEYTER/' '/ ! ! Define the two-character sequence to indicate comment lines ! in the input file. ! DATA FRMCOM /'/','*'/ ! ! Set the (graphics and text) initialization and erase strings to null. ! DATA DGISIZ, DGESIZ, DTISIZ /0, 0, 0/ ! ! Set the device coordinate space to null. ! DATA DCDLLX, DCDLLY, DCDURX, DCDURY /0, 0, 0, 0/ ! ! Set the device color information. ! DATA DCOAVL, COLFIN(1) /.FALSE., 0/ ! ! Set up the default encoding tables to emulate a Tektronix ! 4014 type addressing scheme. ! DATA CORFIN(1) /0/ ! ! Default the device coordinate offsets. ! DATA CORXOF,CORYOF/0,0/ ! ! Default the device coordinate scaling. ! DATA CORXSC, CORYSC /1.0, 1.0/ ! ! Set up the POLYLINE defaults. ! DATA PLAVBL/.FALSE./ DATA LDSSIZ, LDTSIZ /0,0/ DATA LCSSIZ, LCTSIZ /0,0/ DATA LWSSIZ, LWTSIZ /0,0/ DATA LWTFIN(1) /0/ DATA LWTSCF /1.0/ ! ! Define the default user prompt. ! DATA UPRSIZ /0/ ! ! Set the device color map data. ! DATA IDXMAX, IDXCUR, DMPAVL/-1, 0, .FALSE./ DATA MSTSIZ, MTRSIZ /0, 0/ DATA DMPIDV, DMPMDL /.FALSE., 1/ DATA DMPFIN(1) /0/ DATA COLINT /MAP3TM*0/ ! ! Set all bundle tables to empty. ! DATA PLBTEC, PMBTEC, TXBTEC, FABTEC /-1, -1, -1, -1/ ! ! Set the ratio of VDC units to dash pattern bits to 1/100 VDC. ! DATA DASBIT /100/ ! ! Scan line instruction set. ! DATA SCNSIM /.FALSE./ DATA SCNXSC, SCNYSC /1.0, 1.0/ ! ! Data for temporary variables (virtual device window and software ! fill flag). These will be cleaned up for Release 3.0. ! DATA VDWLLX,VDWLLY,VDWURX,VDWURY/0,0,32767,32767/ DATA PLGSIM/.TRUE./ ! ! Initialize the parser tables--see the documentation in the driver ! CAPCHG for details. ! DATA (PART1(II),II= 1, 161) / 'D' & ,'E','V','I','C','E',' ','L','I','N','E',' ',' ',' ','U','S','E' & ,'R',' ',' ',' ','B','U','N','D','L','E',' ','T','E','X','T',' ' & ,' ',' ','M','A','R','K','E','R',' ','P','O','L','Y','G','O','N' & ,'D','A','S','H',' ',' ',' ','R','A','S','T','E','R',' ','T','M' & ,'P',' ',' ',' ',' ','G','R','A','P','H','I','C','T','E','X','T' & ,' ',' ',' ','C','O','O','R','D',' ',' ','C','O','L','O','R',' ' & ,' ','B','A','T','C','H',' ',' ','C','U','R','S','O','R',' ','M' & ,'A','P',' ',' ',' ',' ','E','R','A','S','E',' ',' ','V','E','C' & ,'T','O','R',' ','D','R','A','W',' ','M','O','V','E',' ','C','O' & ,'L','O','R','W','I','D','T','H','I','N','I','T','L','O','W','E' & / DATA (PART1(II),II= 162, 322) / 'R' & ,'_','L','E','F','T','_','X',' ','L','O','W','E','R','_','L','E' & ,'F','T','_','Y',' ','U','P','P','E','R','_','R','I','G','H','T' & ,'_','X','U','P','P','E','R','_','R','I','G','H','T','_','Y','F' & ,'O','R','M','A','T',' ',' ',' ',' ',' ',' ',' ','E','N','C','O' & ,'D','I','N','G',' ',' ',' ',' ',' ','X','O','F','F','S','E','T' & ,' ',' ',' ',' ',' ',' ','Y','O','F','F','S','E','T',' ',' ',' ' & ,' ',' ',' ','X','S','C','A','L','E',' ',' ',' ',' ',' ',' ',' ' & ,'Y','S','C','A','L','E',' ',' ',' ',' ',' ',' ',' ','F','L','O' & ,'A','T','I','N','G','_','I','N','F','O','A','V','A','I','L','A' & ,'B','L','E','I','N','D','E','X',' ',' ',' ',' ','P','O','L','Y' & / DATA (PART1(II),II= 323, 483) / '_' & ,'F','L','A','G',' ',' ','I','N','S','T','R','U','C','T','I','O' & ,'N','I','N','S','T','R','U','C','T','I','O','N','F','O','R','M' & ,'A','T',' ',' ',' ',' ',' ',' ',' ','E','N','C','O','D','I','N' & ,'G',' ',' ',' ',' ',' ','F','L','O','A','T','I','N','G','_','I' & ,'N','F','O','S','T','A','R','T',' ',' ',' ',' ',' ','T','E','R' & ,'M','I','N','A','T','O','R','P','R','O','M','P','T','H','O','M' & ,'E','A','V','A','I','L','A','B','L','E',' ',' ','I','N','D','E' & ,'X',' ',' ',' ',' ',' ',' ','I','N','T','E','N','S','I','T','Y' & ,' ',' ','I','N','D','I','V','I','D','U','A','L',' ','I','N','S' & ,'T','R','U','C','T','I','O','N','I','N','I','T',' ',' ',' ',' ' & / DATA (PART1(II),II= 484, 644) / ' ' & ,' ',' ','M','O','D','E','L',' ',' ',' ',' ',' ',' ','R','A','N' & ,'G','E','_','M','A','X',' ',' ',' ',' ','R','A','N','G','E','_' & ,'D','E','F','I','N','E','D','L','I','N','E',' ',' ',' ','M','A' & ,'R','K','E','R',' ','P','O','L','Y','G','O','N','T','E','X','T' & ,' ',' ',' ','I','N','D','E','X','T','Y','P','E',' ','W','I','D' & ,'T','H','C','O','L','O','R','I','N','D','E','X','T','Y','P','E' & ,' ','S','I','Z','E',' ','C','O','L','O','R','I','N','D','E','X' & ,' ',' ',' ','I','N','T','E','R','I','O','R','S','T','Y','L','E' & ,' ',' ',' ','C','O','L','O','R',' ',' ',' ','I','N','D','E','X' & ,' ',' ',' ',' ','F','O','N','T',' ',' ',' ',' ',' ','P','R','E' & / DATA (PART1(II),II= 645, 805) / 'C' & ,'I','S','I','O','N','C','E','X','P','N',' ',' ',' ',' ','C','S' & ,'P','A','C','E',' ',' ',' ','C','O','L','O','R',' ',' ',' ',' ' & ,'C','O','L','O','R',' ',' ',' ',' ',' ',' ','V','E','C','T','O' & ,'R',' ',' ',' ',' ',' ','I','N','S','T','R','U','C','T','I','O' & ,'N','S','I','M','U','L','A','T','E',' ',' ',' ','C','O','U','N' & ,'T','B','I','T','_','L','E','N','G','T','H','I','N','S','T','R' & ,'U','C','T','I','O','N',' ',' ','F','O','R','M','A','T',' ',' ' & ,' ',' ',' ',' ',' ','E','N','C','O','D','I','N','G',' ',' ',' ' & ,' ',' ','R','A','N','G','E',' ',' ',' ',' ',' ',' ',' ',' ','S' & ,'C','A','L','E',' ',' ',' ',' ',' ',' ',' ',' ','F','L','O','A' & / DATA (PART1(II),II= 806, 884) / 'T' & ,'I','N','G','_','I','N','F','O','C','O','O','R','D',' ',' ',' ' & ,' ',' ','D','A','T','A',' ',' ',' ',' ',' ',' ','V','E','C','T' & ,'O','R',' ',' ',' ',' ','H','O','R','I','Z','O','N','T','A','L' & ,'S','I','M','U','L','A','T','E',' ',' ','V','D','C','_','W','I' & ,'N','D','O','W','P','O','L','Y','G','O','N',' ',' ',' ' & / DATA (PART2(II),II= 1, 97) / 11 & , 20, 46, 57, 79, 79, 79, 84, 91, 96, 24 & , 24, 25, 36, 0, 47, 48, 0, 83, 38, 40 & , 40, 85, 0, 0, 0, 0, 0, 0, 0, 0 & , 0, 0, 0, 0, 0, 41, 0, 44, 44, 0 & , 0, 0, 0, 0, 0, 0, 0, 55, 41, 0 & , 44, 0, 0, 0, 0, 61, 65, 69, 73, 0 & , 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 & , 0, 0, 0, 0, 0, 0, 0, 40, 83, 44 & , 0, 41, 0, 44, 0, 0, 0, 0, 0, 25 & , 41, 83, 40, 0, 25, 91 & / DATA (PART3(II),II= 1, 97) / 1 & , 1, 1, 1, 1, 1, 1, 1, 1, 1, 2 & , 2, 2, 2, 2, 2, 2, 2, 2, 3, 3 & , 3, 3, 4, 5, 5, 5, 5, 5, 5, 5 & , 5, 5, 5, 5, 6, 6, 7, 7, 8, 9 & , 9, 9, 10, 10, 11, 12, 13, 13, 13, 13 & , 13, 13, 13, 14, 14, 15, 15, 15, 15, 16 & , 16, 16, 16, 17, 17, 17, 17, 18, 18, 18 & , 18, 19, 19, 19, 19, 19, 19, 20, 20, 20 & , 20, 21, 22, 23, 23, 23, 23, 23, 23, 24 & , 24, 24, 24, 24, 25, 25 & / DATA (PART4(II),II= 1, 25) / 1 & , 71, 134, 154, 158, 301, 319, 341, 352, 391, 411 & , 417, 421, 498, 524, 552, 572, 592, 624, 678, 722 & , 727, 737, 815, 865 & / DATA (PART5(II),II= 1, 50) / 10 & , 7, 9, 7, 4, 5, 1, 4, 11, 13, 2 & , 9, 2, 11, 1, 11, 3, 13, 2, 10, 1 & , 6, 1, 4, 7, 11, 2, 13, 4, 7, 4 & , 5, 4, 5, 4, 8, 6, 9, 4, 11, 1 & , 5, 1, 10, 6, 13, 5, 10, 2, 10 & / end subroutine cappar ( ios, status ) ! !******************************************************************************* ! !! CAPPAR calls MTCHIT to parse keywords and then processes various classes. ! ! ! Parameters: ! ! Output, ios - The I/O status flag. This flag is valid only ! if the output variable STATUS indicates an error. ! ! Output, status - The error status: = 0 - All OK. ! = 1 - END OF FILE ! > 1 - Error as defined in the CAPERR ! common block. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer, parameter :: LNMAX = 80 character LINE(LNMAX) integer unit, IPTR, LSIZE common /CAPUSR/ UPRSTR, UPRSIZ integer UPRMAX parameter (UPRMAX=50) integer UPRSTR(UPRMAX), UPRSIZ ! SIZE OF common BLOCK integer LENUSR parameter (LENUSR=UPRMAX+1) common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character KEYSEP,KEYTER character FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPSPC/ VDWLLX,VDWLLY,VDWURX,VDWURY,PLGSIM,DUMSPC integer DUMSIZ parameter (DUMSIZ=1288) integer DUMSPC(DUMSIZ) integer VDWLLX,VDWLLY,VDWURX,VDWURY LOGICAL PLGSIM ! integer IOS, status integer WHICH(WHSIZE), ROW ! ! Get the first line of the file. ! call rdline ( IOS, status ) if ( STATUS /= allok ) then return end if ! ! Continue processing, look for the next keyword. ! 1 CONTINUE call SKPBLK(IOS, status) if ( STATUS /= allok ) return ! ! Locate the keyword segment and store the encoded path ! in WHICH. ! call MTCHIT (WHICH, ios, status) if ( STATUS /= allok ) return ! ! If there was no match, get a new line. ! if ( WHICH(1) == 0 ) go to 1 ! ! Set ROW to the level one command flag. ! ROW = WHICH(1) ! ! Branch to the proper class processor. ! go to (100,200,300,400,500,600,700,800,900,1000),ROW ! ! DEVICE class processing. ! 100 CONTINUE call DEVCLS(WHICH, ios, status) go to 9000 ! ! LINE class processing. ! 200 CONTINUE call LINCLS(WHICH, ios, status) go to 9000 ! ! USER Class processing, get the user prompt. ! 300 CONTINUE call gtstr(UPRSTR, UPRMAX, UPRSIZ, ios, status) go to 9000 ! ! BUNDLE class processing. ! 400 CONTINUE call BNDCLS(WHICH, ios, status) go to 9000 ! ! TEXT class processing. ! 500 CONTINUE call TXTCLS(WHICH, ios, status) go to 9000 ! ! MARKER class processing. ! 600 CONTINUE call MARCLS(WHICH, ios, status) go to 9000 ! ! POLYGON class processing. ! 700 CONTINUE call PLGCLS(WHICH, ios, status) ! ! DASH class processing. ! 800 CONTINUE call DASCLS(WHICH, ios, status) go to 9000 ! ! RASTER class processing. ! 900 CONTINUE call RASCLS(WHICH, ios, status) go to 9000 ! ! TMP class processing. ! 1000 CONTINUE call TMPCLS(WHICH, ios, status) go to 9000 ! ! Class processing over, check STATUS. ! 9000 CONTINUE if ( STATUS /= allok ) then return end if ! ! Go back and start the scan again. ! go to 1 end subroutine chrcls ( unit, ios, status ) ! !******************************************************************************* ! !! CHRCLS closes the ASCII graphcap file. ! ! ! Modified: ! ! 06 August 2001 ! ! Parameters: ! ! Input, integer unit, the unit number of the output unit. ! ! Output, integer IOS, the I/O status word, this is valid only if STATUS ! indicates an error. ! ! Output, integer STATUS, the error status as defined by common CAPERR. ! integer ios integer status integer unit ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL ! ! Initialize STATUS to ALLOK. ! status = allok close ( unit = unit, iostat = ios ) if ( ios /= 0 ) then status = allok + 1 end if return end subroutine dascls ( which, ios, status ) ! !******************************************************************************* ! !! DASCLS carries out level two DASH class processing. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) ! integer WHICH(WHSIZE), ios, status integer ROW2, dummy ! ! Branch to the proper level 2 processing. ! ROW2 = WHICH(2) ! ! DASH class processing-- ! ! ROW2 KEYWORD ! ---- --------------- ! 1 DASH_BIT_LENGTH ! if ( ROW2 == 1 ) then call gtint(DASBIT, 1, dummy, ios, status) end if return end subroutine devcls ( which, ios, status) ! !******************************************************************************* ! !! DEVCLS carries out level two DEVICE class processing. ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) common /CAPLIN/ PLAVBL, & LDSSTR, LDSSIZ, LDTSTR, & LDTSIZ, LMSSTR, LMSSIZ, & LMTSTR, LMTSIZ, LCSSTR, LCSSIZ, & LCTSTR, LCTSIZ, LINFIN, LINFMT, & LWSSTR, LWSSIZ, LWTSTR, LWTSIZ, & LWTFIN, LWTFMT, LWTRNG, LWTSCF integer LDSMAX, LDTMAX, LMSMAX, LMTMAX, & LCSMAX, LCTMAX, LVCFMX, LWSMAX, LWTMAX, LWTFMX parameter (LDSMAX=10, LDTMAX=10, LMSMAX=10, & LMTMAX=10, LCSMAX=10, & LCTMAX=10, LVCFMX=5, LWSMAX=10, LWTMAX=10, & LWTFMX=5) LOGICAL PLAVBL integer LDSSTR(LDSMAX), LDSSIZ, & LDTSTR(LDTMAX), LDTSIZ, LMSSTR(LMSMAX), LMSSIZ, & LMTSTR(LMTMAX), LMTSIZ, & LCSSTR(LCSMAX), LCSSIZ, & LCTSTR(LCTMAX), LCTSIZ, & LINFIN(8), LINFMT(LVCFMX,4), & LWSSTR(LWSMAX), LWSSIZ, LWTSTR(LWTMAX), LWTSIZ, & LWTFIN(8), LWTFMT(LWTFMX,4), LWTRNG(2) REAL LWTSCF,LINRIN(8),LWTRIN(8) ! SIZE OF THE common BLOCK integer LENLIN parameter(LENLIN=1+LDSMAX+1+LDTMAX+1+LMSMAX+1+ & LMTMAX+1+LCSMAX+1+ & LCTMAX+1+8+LVCFMX*4 & +LWSMAX+1+LWTMAX+1+8+LWTFMX*4+2+1) equivalence (LINFIN,LINRIN), (LWTFIN,LWTRIN) ! integer WHICH(WHSIZE), ios, status integer ROW1, ROW2, ROW3 integer DUMMY, HOLDER(DCFTMX*4), II, JJ ! ! Branch to the proper level 2 processing. ! ROW1 = WHICH(2) ROW2 = WHICH(3) ! ! DEVICE class processing-- ! ! ROW1 ROW2 ROW3 Keyword ! ---- ---- ---- ------------------------------------ ! 1 1 DEVICE_GRAPHIC_INIT ! 2 1 DEVICE_TEXT_INIT ! 3 1 DEVICE_COORD_LOWER_LEFT_X ! 3 2 DEVICE_COORD_LOWER_LEFT_Y ! 3 3 DEVICE_COORD_UPPER_RIGHT_X ! 3 4 DEVICE_COORD_UPPER_RIGHT_Y ! 3 5 DEVICE_COORD_FORMAT ! 3 6 DEVICE_COORD_ENCODING ! 3 7 DEVICE_COORD_XOFFSET ! 3 8 DEVICE_COORD_YOFFSET ! 3 9 DEVICE_COORD_XSCALE ! 3 10 DEVICE_COORD_YSCALE ! 3 11 DEVICE_COORD_FLOATING_INFO ! 4 * * DEVICE_COLOR_ (Invoke subroutine DEVCOL) ! 5 DEVICE_BATCH ! 6 1 DEVICE_CURSOR_HOME ! 7 * * DEVICE_MAP_ (Invoke subroutine DEVMAP) ! 8 DEVICE_ERASE ! 9 1 1 DEVICE_VECTOR_COUNT_FORMAT ! 9 1 2 DEVICE_VECTOR_COUNT_ENCODING ! 9 1 3 DEVICE_VECTOR_COUNT_FLOATING_INFO ! if (ROW1 == 1 .and. ROW2 == 1) then call gtstr(DGISTR, DGIMAX, DGISIZ, ios, status) else if (ROW1 == 2 .and. ROW2 == 1) then call gtstr(DTISTR, DTIMAX, DTISIZ, ios, status) else if (ROW1 == 3 .and. ROW2 == 1) then call gtint(DCDLLX, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 2) then call gtint(DCDLLY, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 3) then call gtint(DCDURX, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 4) then call gtint(DCDURY, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 5) then call gtint(HOLDER, DCFTMX*4, dummy, ios, status) if (DUMMY /= 0) then CORFIN(2) = DUMMY/4 do II = 1,CORFIN(2) do JJ = 1,4 CORFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW1 == 3 .and. ROW2 == 6) then call gtint(CORFIN(1), 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 7) then call gtint(CORXOF, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 8) then call gtint(CORYOF, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 9) then call gtflt(CORXSC, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 10) then call gtflt(CORYSC, 1, dummy, ios, status) else if (ROW1 == 3 .and. ROW2 == 11) then call gtflt(CORRIN(5), 4, dummy, ios, status) else if (ROW1 == 4) then call DEVCOL(WHICH, ios, status) else if (ROW1 == 5) then call gtlog(BATCH, 1, dummy, ios, status) else if (ROW1 == 6) then call gtstr(DHCSTR, DHCMAX, DHCSIZ, ios, status) else if (ROW1 == 7) then call DEVMAP(WHICH, ios, status) else if (ROW1 == 8) then call gtstr(DGESTR, DGEMAX, DGESIZ, ios, status) else if (ROW1 == 9 .and.ROW2 == 1) then ROW3 = WHICH(4) if (ROW3 == 1) then call gtint(HOLDER, LVCFMX*4, dummy, ios, status) if (DUMMY /= 0) then LINFIN(2) = DUMMY/4 do II = 1,LINFIN(2) do JJ = 1,4 LINFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW3 == 2) then call gtint(LINFIN(1), 1, dummy, ios, status) else if (ROW3 == 3) then call gtflt(LINRIN(5), 4, dummy, ios, status) end if end if return end subroutine devcol ( which, ios, status) ! !******************************************************************************* ! !! DEVCOL processes the DEVICE_COLOR keywords. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPCOL/ COLINT, COLIDX, IDXCUR, VDMINT, DMPAVL, COLFMT & ,COLFIN, IDXMAX, MSTSTR, MSTSIZ, MTRSTR, DMPMDL & ,MTRSIZ, DMPIDV, DMPFIN, DMPFMT integer MAPMAX, COLMAX, MSTMAX, MTRMAX, DMPMAX parameter (MAPMAX=256, COLMAX=10, MSTMAX=30, MTRMAX=10) parameter (DMPMAX=50) integer COLINT(MAPMAX*3), COLIDX(MAPMAX), IDXCUR, VDMINT, & IDXMAX, COLFMT(COLMAX,4), COLFIN(8), DMPMDL, & MSTSTR(MSTMAX), MSTSIZ, MTRSTR(MTRMAX), MTRSIZ, & DMPFIN(8), DMPFMT(DMPMAX,4) LOGICAL DMPAVL, DMPIDV integer LENCOL REAL COLRIN(8),DMPRIN(8) parameter (LENCOL=MAPMAX*4+3+COLMAX*4+8+1+MSTMAX+1+MTRMAX+1+3 & +DMPMAX*4+7) equivalence (COLFIN,COLRIN),(DMPFIN,DMPRIN) ! integer IOS, status, WHICH(WHSIZE) integer ROW3, ROW4, dummy, II, JJ integer HOLDER(COLMAX*4) ! ! Get levels 3 and 4 of the parse path. ! ROW3 = WHICH(3) ROW4 = WHICH(4) ! ! Branch to proper keyword processing. ! ! ROW3 ROW4 Keyword ! ---- ---- ------------------------------------ ! 1 DEVICE_COLOR_AVAILABLE ! 2 1 DEVICE_COLOR_INDEX_FORMAT ! 2 2 DEVICE_COLOR_INDEX_ENCODING ! 2 3 DEVICE_COLOR_INDEX_FLOATING_INFO ! if (ROW3 == 1) then call gtlog(DCOAVL, 1, dummy, ios, status) else if (ROW3 == 2) then if (ROW4 == 2) then call gtint(COLFIN(1), 1, dummy, ios, status) else if (ROW4 == 3) then call gtflt(COLRIN(5), 4, dummy, ios, status) else if (ROW4 == 1) then call gtint(HOLDER, COLMAX*4, dummy, ios, status) if (DUMMY /= 0) then COLFIN(2) = DUMMY/4 do II = 1,COLFIN(2) do JJ = 1,4 COLFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if end if end if return end subroutine devmap ( which, ios, status) ! !******************************************************************************* ! !! DEVMAP processes the DEVICE_MAP keywords. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /CAPDEV/ DGISTR, DGISIZ, DGESTR, DGESIZ, & DTISTR, DTISIZ, & DCDLLX, DCDLLY, DCDURX, DCDURY, & DCOAVL, CORFMT, CORFIN, & BATCH , DHCSIZ, DHCSTR, CORXOF, CORYOF, & DASBIT, CORXSC, CORYSC integer DGIMAX, DGEMAX, DTIMAX, DCFTMX, DHCMAX parameter (DGIMAX=100, DGEMAX=50, DTIMAX=100) parameter (DCFTMX=20, DHCMAX=20) integer DGISTR(DGIMAX), DGISIZ, DGESTR(DGEMAX), DGESIZ integer DTISTR(DTIMAX), DTISIZ integer DCDLLX, DCDLLY, DCDURX, DCDURY integer CORFIN(8), CORFMT(DCFTMX, 4) integer DHCSIZ, DHCSTR(DHCMAX), CORXOF, CORYOF, DASBIT LOGICAL DCOAVL, BATCH REAL CORXSC, CORYSC, CORRIN(8) ! SIZE OF THE common integer LENDEV parameter (LENDEV=DGIMAX+1+DGEMAX+1+DTIMAX+1+4+ & 4*DCFTMX+8+DHCMAX+1+3+2+2) equivalence (CORFIN,CORRIN) common /CAPCOL/ COLINT, COLIDX, IDXCUR, VDMINT, DMPAVL, COLFMT & ,COLFIN, IDXMAX, MSTSTR, MSTSIZ, MTRSTR, DMPMDL & ,MTRSIZ, DMPIDV, DMPFIN, DMPFMT integer MAPMAX, COLMAX, MSTMAX, MTRMAX, DMPMAX parameter (MAPMAX=256, COLMAX=10, MSTMAX=30, MTRMAX=10) parameter (DMPMAX=50) integer COLINT(MAPMAX*3), COLIDX(MAPMAX), IDXCUR, VDMINT, & IDXMAX, COLFMT(COLMAX,4), COLFIN(8), DMPMDL, & MSTSTR(MSTMAX), MSTSIZ, MTRSTR(MTRMAX), MTRSIZ, & DMPFIN(8), DMPFMT(DMPMAX,4) LOGICAL DMPAVL, DMPIDV integer LENCOL REAL COLRIN(8),DMPRIN(8) parameter (LENCOL=MAPMAX*4+3+COLMAX*4+8+1+MSTMAX+1+MTRMAX+1+3 & +DMPMAX*4+7) equivalence (COLFIN,COLRIN),(DMPFIN,DMPRIN) common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC ! integer IOS, status, WHICH(WHSIZE) integer ROW3, ROW4, dummy, II, JJ, HOLDER(DMPMAX*4) ! ! Get levels 3 and 4 of the parse path. ! ROW3 = WHICH(3) ROW4 = WHICH(4) ! ! Branch to proper keyword processing. ! ! ROW3 ROW4 Keyword ! ---- ---- --------------------------------------- ! 1 DEVICE_MAP_AVAILABLE ! 2 1 DEVICE_MAP_INDEX_RANGE_MAX ! 2 2 DEVICE_MAP_INDEX_RANGE_DEFINED ! 3 1 DEVICE_MAP_INTENSITY_FORMAT ! 3 2 DEVICE_MAP_INTENSITY_ENCODING ! 3 3 DEVICE_MAP_INTENSITY_FLOATING_INFO ! 4 DEVICE_MAP_INDIVIDUAL ! 5 1 DEVICE_MAP_INSTRUCTION_START ! 5 2 DEVICE_MAP_INSTRUCTION_TERMINATOR ! 6 DEVCIE_MAP_INIT ! 7 DEVICE_MAP_MODEL ! if ( ROW3 == 1 ) then call gtlog(DMPAVL, 1, dummy, ios, status) else if ( ROW3 == 2 ) then if ( ROW4 == 1 ) then call gtint(IDXMAX, 1, dummy, ios, status) else if ( ROW4 == 2 ) then call gtint(IDXCUR, 1, dummy, ios, status) ! ! Set the index user map up through IDXCUR. ! do II = 1, IDXCUR COLIDX(II) = II-1 end do ! ! If the map maximum index is not set, set it to the current size. ! if ( IDXMAX == 0 ) IDXMAX = IDXCUR end if else if ( ROW3 == 3 ) then if ( ROW4 == 1 ) then call gtint(HOLDER, DMPMAX*4, dummy, ios, status) if ( DUMMY /= 0 ) then DMPFIN(2) = DUMMY/4 do II = 1,DMPFIN(2) do JJ = 1,4 DMPFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if ( ROW4 == 2 ) then call gtint(DMPFIN(1), 1, dummy, ios, status) else if ( ROW4 == 3 ) then call gtflt(DMPRIN(5), 4, dummy, ios, status) end if else if ( ROW3 == 4 ) then call gtlog(DMPIDV, 1, dummy, ios, status) else if ( ROW3 == 5 .and. ROW4 == 1 ) then call gtstr(MSTSTR, MSTMAX, MSTSIZ, ios, status) else if ( ROW3 == 5 .and. ROW4 == 2 ) then call gtstr(MTRSTR, MTRMAX, MTRSIZ, ios, status) else if ( ROW3 == 6 ) then call gtint(COLINT, MAPMAX*3, dummy, ios, status) else if ( ROW3 == 7 ) then call gtint(DMPMDL, 1, dummy, ios, status) end if return end function FNDCHR (CHAR) ! !******************************************************************************* ! !! FNDCHR tests the current position in the input buffer for a match with CHAR. ! ! If a match is found, FNDCHR is set to .TRUE. and the ! buffer pointer is bumped by one; if no match is found, FNDCHR ! is set to .FALSE. and the buffer pointer is unchanged. No ! reloading of the input buffer is done. As a special condition, ! a match is found if CHAR is blank and the buffer is at the ! end-of-line. ! ! OUTPUT ! FNDCHR -- Logical value indicating whether a match was found. ! common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE LOGICAL FNDCHR integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! character*1 CHAR character*1 BLANK DATA BLANK/' '/ ! ! If at END-OF-LINE and CHAR is blank, then set match. ! if (IPTR > LSIZE .and. CHAR == BLANK) then FNDCHR = .TRUE. IPTR = IPTR + 1 return end if ! ! Check for a match. ! if (LINE(IPTR) == CHAR) then FNDCHR = .TRUE. IPTR = IPTR + 1 return end if ! ! No match. ! FNDCHR = .FALSE. return end subroutine gtflt ( string, strmax, strsiz, ios, status) ! !******************************************************************************* ! !! GTFLT gets a string of floating point values from the input file. ! ! INPUT ! STRMAX -- The maximum number of floating point values ! to transfer. ! ! OUTPUT ! STRING -- The array of floating point values. ! STRSIZ -- The number of floating point values ! actually transfered. ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! ! FLTMX specifies the maximum number of characters allowed in any ! floating point number occuring in the input file. If FLTMX is ! changed, then a corresponding change will have to be made in the ! format statement at statement lebel 80. ! integer FLTMX parameter (FLTMX=10) ! integer STRMAX, STRSIZ, ios, status integer II, TPTR, NUMSZ REAL STRING(STRMAX) character*1 DECPT, MINUS, ZERO, NINE character*1 BUF1(FLTMX),BLANK character*(FLTMX) BUF2 ! DATA DECPT, MINUS, ZERO, NINE /'.', '-', '0', '9'/ DATA BLANK/' '/ ! ! Set STRING size to null. ! STRSIZ = 0 ! ! Skip blanks. ! 10 CONTINUE call SKPBLK(IOS, status) if (STATUS /= allok) return ! ! Check for a numeric string. ! if (LINE(IPTR) /= DECPT .and. LINE(IPTR) /= MINUS .AND. & (LINE(IPTR) < ZERO .OR. LINE(IPTR) > NINE ) ) & return ! ! Extract characters from the floating-point input string until ! a blank or end-of-line is encountered. ! NUMSZ = 0 do II = IPTR, LSIZE if (LINE(II) /= BLANK) then NUMSZ = NUMSZ + 1 ! ! NUMSZ exceeds the maximum number of digits allowed, set error ! condition and return. ! if ( NUMSZ > FLTMX ) then status = MAXFLT return end if BUF1(NUMSZ) = LINE(II) TPTR = II + 1 else go to 55 end if end do ! ! Set the buffer pointer to the current location. ! 55 CONTINUE IPTR = TPTR ! ! Zero out the conversion buffer. ! BUF2(1:FLTMX) = ZERO ! ! Move the input string to the conversion buffer. ! do II = 1,NUMSZ BUF2((FLTMX-II+1):(FLTMX-II+1)) = BUF1((NUMSZ-II)+1) end do ! ! Convert to a floating value and store in STRING. ! STRSIZ = STRSIZ + 1 READ(BUF2,80,ERR=1000) STRING(STRSIZ) 80 FORMAT(F10.6) ! ! If the requested number of values has been extracted, return. ! if ( STRSIZ >= STRMAX) return ! ! Continue to get next number. ! go to 10 ! ! Formatting error. ! 1000 CONTINUE status = FLTERR return end subroutine gtint ( string, strmax, strsiz, ios, status) ! !******************************************************************************* ! !! GTINT gets a string of integers from the input file. ! ! ! INPUT ! STRMAX -- The maximum number of integer values ! to transfer. ! ! OUTPUT ! STRING -- The array of integer values. ! STRSIZ -- The number of integer values actually ! transfered. ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! integer STRMAX, STRING(STRMAX), STRSIZ, ios, status integer CURVAL, II ! ! Set STRING size to null. ! STRSIZ = 0 ! ! Skip blanks. ! 10 CONTINUE call SKPBLK ( IOS, status ) if (STATUS /= allok) return ! ! Try to get an integer. ! II = IPTR call INTCNV(CURVAL, II, ios, status) if ( STATUS /= allok ) then if ( status == NOTINT ) STATUS = allok return end if ! ! If the requested number of values has not been extracted, ! try to get another value, otherwise set error condition and ! return. ! if (STRSIZ < STRMAX) then STRSIZ = STRSIZ + 1 STRING(STRSIZ) = CURVAL go to 10 end if status = SIZERR return end subroutine gtlog ( string, strmax, strsiz, ios, status ) ! !******************************************************************************* ! !! GTLOG gets a string of logical values from the input file. ! ! INPUT ! STRMAX -- Maximum number of logical values to transfer. ! ! OUTPUT ! STRING -- The array of logical values. ! STRSIZ -- The number of logical values actually transfered. ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! integer STRMAX, STRSIZ, ios, status LOGICAL STRING(STRMAX) integer LL, II LOGICAL TEMP character*1 T(4),F(5) ! ! Define the true and false strings. ! DATA T /'T','R','U','E'/ DATA F /'F','A','L','S','E'/ ! ! Set STRING size to null. ! STRSIZ = 0 ! ! Skip blanks. ! 10 CONTINUE call SKPBLK(IOS, status) if (STATUS /= allok) return LL = 1 ! ! Test for a true. ! do II = IPTR, LSIZE if ( LINE(II) /= T(LL) ) then exit end if LL = LL + 1 if ( LL == 5 ) then TEMP = .TRUE. IPTR = II + 1 go to 40 end if end do ! ! Test for a false. ! LL = 1 do II = IPTR, LSIZE if ( LINE(II) /= F(LL) ) then return end if LL = LL + 1 if ( LL == 6 ) then TEMP = .FALSE. IPTR = II + 1 go to 40 end if end do ! ! Store the value found in STRING. ! 40 CONTINUE STRSIZ = STRSIZ + 1 STRING(STRSIZ) = TEMP if ( STRSIZ < STRMAX ) then go to 10 end if return end subroutine gtstr ( string, strmax, strsiz, ios, status) ! !******************************************************************************* ! !! GTSTR gets a string of ASCII data values from the input file. ! ! ! Discussion: ! ! Each legal data value must be terminated by a blank or by an ! end-of-line. ! ! INPUT ! STRMAX -- Maximum number of characters to transfer. ! ! OUTPUT ! STRING -- An integer array containing the ADE of the ! characters transferred. ! STRSIZ -- The number of characters actually transferred. ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE common /CAPASC/ ASCTB1, ASCTB2 integer TBLLE1, TBLWT1, INTVAL, TBLLE2, CORDVL parameter (TBLLE1=41, TBLWT1=3, INTVAL=-1, TBLLE2=94, CORDVL=-7) character*1 ASCTB1(TBLLE1, TBLWT1), ASCTB2(TBLLE2) common /CAPASI/ ASCVL1, ASCVL2 integer ASCVL1(TBLLE1), ASCVL2(TBLLE2) ! integer STRMAX, STRING(STRMAX), STRSIZ, ios, status ! integer II,JJ,KK, AV, CURVAL character*1 BLANK, CURCHR DATA BLANK/' '/ ! ! Set STRING size to null. ! STRSIZ = 0 ! ! Skip blanks. ! 10 CONTINUE call SKPBLK(IOS, status) if (STATUS /= allok) return ! ! Initialize search for an ASCII character (or processor dependent ! strings, such as XYC, INT, etc.) which is represented ! by a multi-character string. ! JJ = 1 40 CONTINUE KK = 1 II = IPTR 50 CONTINUE CURCHR = ASCTB1(JJ,KK) ! ! Search the ASCII definition table. ! if ( LINE(II) == CURCHR) then ! ! Match found with the current single character; if we ! have matched TBLWT1 single characters, then we have ! an ASCII character match. ! if (KK == TBLWT1) then AV = ASCVL1(JJ) go to 200 end if ! ! Increment the width pointer and get the next character. ! KK = KK + 1 CURCHR = ASCTB1(JJ,KK) ! ! If the current character extracted from ASCTB1 is a blank, then ! we must have a multi-character match. ! if (CURCHR == BLANK) then AV = ASCVL1(JJ) go to 200 end if ! ! If end of input line branch to new table entry. ! if (II < LSIZE) then II = II + 1 go to 50 end if end if ! ! Go to new table entry. ! if (JJ == TBLLE1) go to 100 JJ = JJ + 1 go to 40 ! ! Initialize the search for an ASCII character which ! has an ADE between 33 (decimal) and 126 (decimal). ! 100 CONTINUE JJ = 1 II = IPTR 140 CONTINUE CURCHR = ASCTB2(JJ) ! ! Search the ASCII definition table. ! if ( LINE(II) == CURCHR) then ! ! The current position is a match. ! AV = ASCVL2(JJ) go to 200 end if ! ! Go to a new table entry. ! if (JJ == TBLLE2) then ! ! No match, so set the buffer pointer and return. ! IPTR = II return end if JJ = JJ + 1 go to 140 ! ! 200 CONTINUE ! ! ASCII table match, add value to STRING. ! if ( AV >= 0 ) then ! ! Make certain that the next input position is a blank or ! end-of-line, otherwise we don't really have a match. ! II = II + 1 if ( II <= LSIZE ) then ! ! Not a match. ! if (LINE(II) /= BLANK) return end if ! ! A true (non processor dependent) ASCII character has been matched, ! put it in STRING and search for another. ! CURVAL = AV IPTR = II ! else if (AV == INTVAL) then ! ! INT flag has been matched, so decode the integer value following it. ! II = II + 1 call INTCNV(CURVAL,II,IOS,STATUS) if (STATUS /= allok) then if (STATUS /= NOTINT) return status = allok return end if else if (AV >= CORDVL) then ! ! Processor-dependent coordinate indicator has been matched, ! put it into STRING. ! CURVAL = AV IPTR = II + 1 else ! ! Undefined pattern. ! status = UNDASC end if ! ! Set the current value in the output string if there is room. ! if ( STRSIZ < STRMAX) then STRSIZ = STRSIZ + 1 STRING(STRSIZ) = CURVAL go to 10 end if ! ! Error -- No room left in STRING buffer. ! status = SIZERR return end subroutine intcnv ( intval, curptr, ios, status) ! !******************************************************************************* ! !! INTCNV decodes an integer starting at position CURPTR in the input buffer. ! ! ! Parameters: ! ! Input, CURPTR -- The current location in the input buffer. ! ! Output, INTVAL -- The decoded integer value. ! ! Output, ios -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! ! Output, status -- The error status as defined in common CAPERR. ! ! Note: If the request is successful, then IPTR will be updated to ! point to the next position past the integer; if the request ! fails, IPTR will remain unchanged. ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! integer INTVAL, CURPTR, ios, status ! ! Define the maximum number of digits allowed in the input stream. ! If this number is changed, then the integer width in the format ! statement with label 80 must be changed to the same value as ! INTMX. ! integer, parameter :: INTMX = 6 integer II, TPTR, NUMSZ character*1 DECPT, MINUS, ZERO, NINE character*1 BUF1(INTMX),BLANK character*(INTMX) BUF2 ! DATA DECPT, MINUS, ZERO, NINE /'.', '-', '0', '9'/ DATA BLANK/' '/ ! ! Check that the input string is numeric. ! if (LINE(CURPTR) /= DECPT .and. LINE(CURPTR).NE.MINUS .AND. & (LINE(CURPTR) < ZERO .OR. LINE(CURPTR).GT.NINE)) then status = NOTINT return end if ! ! Process until a blank or end-of-line is encountered. ! NUMSZ = 0 do II = CURPTR, LSIZE if (LINE(II) /= BLANK) then NUMSZ = NUMSZ + 1 if (NUMSZ > INTMX) then status = MAXINT return end if BUF1(NUMSZ) = LINE(II) TPTR = II + 1 else exit end if end do ! ! Set buffer pointer to current location. ! IPTR = TPTR ! ! Blank out the conversion buffer. ! BUF2(1:INTMX) = BLANK ! ! Move the string to the conversion buffer. ! do II = 1,NUMSZ BUF2((INTMX-II+1):(INTMX-II+1)) = BUF1((NUMSZ-II)+1) end do ! ! Convert to an integer. ! READ ( BUF2, '(i6)', ERR=1000 ) INTVAL return ! ! Error exit. ! 1000 CONTINUE status = INTERR return end subroutine lincls ( which, ios, status) ! !******************************************************************************* ! !! LINCLS carries out the level two line class keyword parsing. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPLIN/ PLAVBL, & LDSSTR, LDSSIZ, LDTSTR, & LDTSIZ, LMSSTR, LMSSIZ, & LMTSTR, LMTSIZ, LCSSTR, LCSSIZ, & LCTSTR, LCTSIZ, LINFIN, LINFMT, & LWSSTR, LWSSIZ, LWTSTR, LWTSIZ, & LWTFIN, LWTFMT, LWTRNG, LWTSCF integer LDSMAX, LDTMAX, LMSMAX, LMTMAX, & LCSMAX, LCTMAX, LVCFMX, LWSMAX, LWTMAX, LWTFMX parameter (LDSMAX=10, LDTMAX=10, LMSMAX=10, & LMTMAX=10, LCSMAX=10, & LCTMAX=10, LVCFMX=5, LWSMAX=10, LWTMAX=10, & LWTFMX=5) LOGICAL PLAVBL integer LDSSTR(LDSMAX), LDSSIZ, & LDTSTR(LDTMAX), LDTSIZ, LMSSTR(LMSMAX), LMSSIZ, & LMTSTR(LMTMAX), LMTSIZ, & LCSSTR(LCSMAX), LCSSIZ, & LCTSTR(LCTMAX), LCTSIZ, & LINFIN(8), LINFMT(LVCFMX,4), & LWSSTR(LWSMAX), LWSSIZ, LWTSTR(LWTMAX), LWTSIZ, & LWTFIN(8), LWTFMT(LWTFMX,4), LWTRNG(2) REAL LWTSCF,LINRIN(8),LWTRIN(8) ! SIZE OF THE common BLOCK integer LENLIN parameter(LENLIN=1+LDSMAX+1+LDTMAX+1+LMSMAX+1+ & LMTMAX+1+LCSMAX+1+ & LCTMAX+1+8+LVCFMX*4 & +LWSMAX+1+LWTMAX+1+8+LWTFMX*4+2+1) equivalence (LINFIN,LINRIN), (LWTFIN,LWTRIN) ! integer WHICH(WHSIZE), ios, status integer ROW1, ROW2, ROW3 integer DUMMY, HOLDER(LVCFMX*4), II, JJ ! ! Branch to the proper level 2 processing. ! ROW1 = WHICH(2) ROW2 = WHICH(3) ROW3 = WHICH(4) ! ! POLYLINE processing-- ! ! ROW1 ROW2 ROW3 Keyword ! ---- ---- ---- ----------------------------------- ! 1 1 LINE_DRAW_POLY_FLAG ! 1 2 1 LINE_DRAW_INSTRUCTION_START ! 1 2 2 LINE_DRAW_INSTRUCTION_TERMINATOR ! 2 1 1 LINE_MOVE_INSTRUCTION_START ! 2 1 2 LINE_MOVE_INSTRUCTION_TERMINATOR ! 3 1 1 LINE_COLOR_INSTRUCTION_START ! 3 1 2 LINE_COLOR_INSTRUCTION_TERMINATOR ! 4 1 1 LINE_WIDTH_INSTRUCTION_START ! 4 1 2 LINE_WIDTH_INSTRUCTION_TERMINATOR ! 4 2 LINE_WIDTH_FORMAT ! 4 3 LINE_WIDTH_ENCODING ! 4 4 LINE_WIDTH_RANGE ! 4 5 LINE_WIDTH_SCALE ! 4 6 LINE_WIDTH_FLOATING_INFO ! if (ROW1 == 1 .and. ROW2 == 1) then call gtlog(PLAVBL, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 2) then if (ROW3 == 1) then call gtstr(LDSSTR, LDSMAX, LDSSIZ, ios, status) else if (ROW3 == 2) then call gtstr(LDTSTR, LDTMAX, LDTSIZ, ios, status) end if else if (ROW1 == 2 .and. ROW2 == 1) then if (ROW3 == 1) then call gtstr(LMSSTR, LMSMAX, LMSSIZ, ios, status) else if (ROW3 == 2) then call gtstr(LMTSTR, LMTMAX, LMTSIZ, ios, status) end if else if (ROW1 == 3 .and. ROW2 == 1) then if (ROW3 == 1) then call gtstr(LCSSTR, LCSMAX, LCSSIZ, ios, status) else if (ROW3 == 2) then call gtstr(LCTSTR, LCTMAX, LCTSIZ, ios, status) end if else if (ROW1 == 4) then if (ROW2 == 1) then if (ROW3 == 1) then call gtstr(LWSSTR, LWSMAX, LWSSIZ, ios, status) else if (ROW3 == 2) then call gtstr(LWTSTR, LWTMAX, LWTSIZ, ios, status) end if else if (ROW2 == 2) then call gtint(HOLDER, LWTFMX*4, dummy, ios, status) if (DUMMY /= 0) then LWTFIN(2) = DUMMY/4 do II = 1,LWTFIN(2) do JJ = 1,4 LWTFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW2 == 3) then call gtint(LWTFIN(1), 1, dummy, ios, status) else if (ROW2 == 4) then call gtint(LWTRNG, 2, dummy, ios, status) else if (ROW2 == 5) then call gtflt(LWTSCF, 1, dummy, ios, status) else if (ROW2 == 6) then call gtflt(LWTRIN(5), 4, dummy, ios, status) end if end if return end subroutine marcls ( which, ios, status) ! !******************************************************************************* ! !! MARCLS carries out level two MARKER class keyword parsing. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPMAR/ MCSSTR, MCSSIZ, MCTSTR, MCTSIZ, MARFIN, MARFMT, & MRSSTR, MRSSIZ, MRTSTR, MRTSIZ integer MCSMAX, MCTMAX, MVCFMX, MRSMAX, MRTMAX parameter (MCSMAX=10, MCTMAX=10, MVCFMX=5, MRSMAX=20, MRTMAX=10) integer MCSSTR(MCSMAX), MCSSIZ, & MCTSTR(MCTMAX), MCTSIZ, & MRSSTR(MRSMAX), MRSSIZ, MRTSTR(MRTMAX), MRTSIZ, & MARFIN(5), MARFMT(MVCFMX,4) ! ! SIZE OF common CAPMAR ! integer LENMAR parameter (LENMAR=MCSMAX+MCTMAX+2+MRSMAX+1+MRTMAX+1+5+MVCFMX*4) ! integer WHICH(WHSIZE), ios, status integer ROW2, ROW3, ROW4 integer DUMMY, HOLDER(MVCFMX*4), II, JJ ! ! Branch to the proper level 2 processing. ! ROW2 = WHICH(2) ROW3 = WHICH(3) ROW4 = WHICH(4) ! ! MARKER class processing-- ! ! ROW2 ROW3 ROW4 Keyword ! ---- ---- ---- ------------------------------------ ! 1 1 1 MARKER_COLOR_INSTRUCTION_START ! 1 1 2 MARKER_COLOR_INSTRUCTION_TERMINATOR ! 2 1 1 MARKER_VECTOR_COUNT_FORMAT ! 2 1 2 MARKER_VECTOR_COUNT_ENCODING ! 3 1 MARKER_INSTRUCTION_START ! 3 2 MARKER_INSTRUCTION_TERMINATOR ! ! if (ROW2 == 1 .and. ROW3 == 1) then if (ROW4 == 1) then call gtstr(MCSSTR, MCSMAX, MCSSIZ, ios, status) else if (ROW4 == 2) then call gtstr(MCTSTR, MCTMAX, MCTSIZ, ios, status) end if else if (ROW2 == 2 .and. ROW3 == 1) then if (ROW4 == 1) then call gtint(HOLDER, MVCFMX*4, dummy, ios, status) if (DUMMY /= 0) then MARFIN(2) = DUMMY/4 do II = 1,MARFIN(2) do JJ = 1,4 MARFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW4 == 2) then call gtint(MARFIN(1), 1, dummy, ios, status) end if else if (ROW2 == 3 .and. ROW3 == 1) then call gtstr(MRSSTR, MRSMAX, MRSSIZ, ios, status) else if (ROW2 == 3 .and. ROW3 == 2) then call gtstr(MRTSTR, MRTMAX, MRTSIZ, ios, status) end if return end subroutine mtchit ( which, ios, status) ! !******************************************************************************* ! !! MTCHIT scans the input buffer for a keyword. ! ! OUTPUT ! WHICH -- Array of flags which serve as an encoding of ! the matched keyword; WHICH(1) is returned if ! there was no match. ! IOS -- The I/O status word. IOS is valid only if STATUS ! is set to an error (non-zero). ! STATUS -- The error status, as defined in common CAPERR. ! ! Note: ! ! If a match is found, the line buffer pointer IPTR in common CAPIOB ! is updated to point to the next position after the matched keyword. ! If no match is found, IPTR is unchanged. ! common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC ! integer IOS, status, WHICH(WHSIZE) ! character*1 BLANK integer ROW, II, IPOS, IEND, TPTR, LEVEL, ROWNUM, TBIDX, DIM1 & ,DIM2, CHSTRT, RPTR LOGICAL FNDCHR ! DATA BLANK/' '/ ! ! Initialize WHICH to indicate no match. ! WHICH(1) = 0 ! ! Skip over any blanks in the input buffer. ! call SKPBLK(IOS, status) if (STATUS /= allok) then return end if ! ! Set a temporary buffer pointer. ! TPTR = IPTR ! ! Initialize the keyword level counter. ! LEVEL = 0 ! ! Start the search at at the first keyword group in PART1. ! ROWNUM = 1 ! ! Continue search. ! 10 CONTINUE TBIDX = PART3(ROWNUM) CHSTRT = PART4(TBIDX) DIM1 = PART5((TBIDX*2)-1) DIM2 = PART5(TBIDX*2) LEVEL = LEVEL + 1 ! ! Loop through all the keywords in the current group. ! do ROW = 1,DIM1 IEND = DIM2 * ROW + CHSTRT IPOS = DIM2 * (ROW-1) + CHSTRT ! ! Check for a keyword match starting at the current buffer position. ! do II = TPTR, LSIZE ! ! Continue as long as the characters match. ! if ( LINE(II) /= PART1(IPOS) ) then exit end if ! ! Increment the position pointer. ! IPOS = IPOS + 1 ! ! If we are at the end of a table entry, then we have a match. ! if ( IPOS >= IEND .OR. PART1(IPOS) == BLANK) then ! ! Set WHICH for this level to flag the number of the keyword in ! the current group of keywords and go to the next level (group ! of keywords) in the parse table. ! WHICH(LEVEL) = ROW TPTR = II go to 1000 end if end do ! ! No match, check next the next keyword in the current group for a match. ! end do ! ! No match, increment the buffer pointer and return. ! WHICH(1) = 0 IPTR = IPTR + 1 return ! ! Match found in the current group of keywords, go to the next ! level of keywords. ! 1000 CONTINUE ROWNUM = PART2(ROWNUM+ROW-1) if ( ROWNUM == 0 ) then ! ! End of search, check that the keyword terminates with a blank. ! RPTR = IPTR IPTR = TPTR + 1 if ( FNDCHR(KEYTER) ) then return else ! ! Fail, so reset buffer pointer to the start, clear WHICH, and return. ! IPTR = RPTR WHICH(1) = 0 return end if end if ! ! Check for a keyword separator. ! RPTR = IPTR IPTR = TPTR + 1 if (FNDCHR(KEYSEP)) then ! ! All OK, so continue. ! TPTR = IPTR go to 10 else ! ! Failure. ! WHICH(1) = 0 IPTR = RPTR return end if end subroutine plgcls ( which, ios, status) ! !******************************************************************************* ! !! PLGCLS processes the POLYGON keywords. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPPLG/ PCSSTR, PCSSIZ, PCTSTR, PCTSIZ, & PLSSTR, PLSSIZ, PLTSTR, PLTSIZ integer PCSMAX, PCTMAX, PLSMAX, PLTMAX parameter (PCSMAX=10, PCTMAX=10, PLSMAX=20, PLTMAX=10) integer PCSSTR(PCSMAX), PCSSIZ, & PCTSTR(PCTMAX), PCTSIZ, & PLSSTR(PLSMAX), PLSSIZ, PLTSTR(PLTMAX), PLTSIZ ! ! SIZE OF common CAPPLG ! integer LENPLG parameter (LENPLG=PCSMAX+PCTMAX+2+PLSMAX+1+PLTMAX+1) ! integer WHICH(WHSIZE), ios, status integer ROW2, ROW3, ROW4 ! ! Branch to the proper level 2 processing. ! ROW2 = WHICH(2) ROW3 = WHICH(3) ROW4 = WHICH(4) ! ! POLYGON class processing. ! ! ROW2 ROW3 ROW4 Keyword ! ---- ---- ---- --------------------------------------- ! 1 1 1 POLYGON_COLOR_INSTRUCTION_START ! 1 1 2 POLYGON_COLOR_INSTRUCTION_TERMINATOR ! 3 1 POLYGON_INSTRUCTION_START ! 3 2 POLYGON_INSTRUCTION_TERMINATOR ! ! if ( ROW2 == 1 .and. ROW3 == 1 ) then if (ROW4 == 1) then call gtstr(PCSSTR, PCSMAX, PCSSIZ, ios, status) else if (ROW4 == 2) then call gtstr(PCTSTR, PCTMAX, PCTSIZ, ios, status) end if else if (ROW2 == 3 .and. ROW3 == 1) then call gtstr(PLSSTR, PLSMAX, PLSSIZ, ios, status) else if (ROW2 == 3 .and. ROW3 == 2) then call gtstr(PLTSTR, PLTMAX, PLTSIZ, ios, status) end if return end subroutine rascls ( which, ios, status) ! !******************************************************************************* ! !! RASCLS processes the RASTER keywords. ! ! ! Parameters: ! ! Input, WHICH -- the encoded path flags. ! ! Output, ios -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! ! Output, status -- The error status as defined in common CAPERR. ! ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPSCN/ SCSSTR, SCSSIZ, SCTSTR, SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNXSC, SCNYSC, SCNFMT, SCNFIN, SCVFMT, SCVFIN, & SCNSIM integer SCSMAX, SCTMAX, SFMMAX, SFNMAX, SCVFMX, SCVFIX parameter(SCSMAX=50, SCTMAX=50, SFMMAX=10, SFNMAX=8) parameter(SCVFMX=10, SCVFIX=8) integer SCSSTR(SCSMAX), SCSSIZ, & SCTSTR(SCTMAX), SCTSIZ, & SCNLLX, SCNLLY, SCNURX, SCNURY,SCNXOF, SCNYOF, & SCNFMT(SFMMAX, 4), SCNFIN(SFNMAX), SCVFMT(SCVFMX,4), & SCVFIN(SCVFIX) REAL SCNXSC, SCNYSC, SCNRIN(SFNMAX), SCVRIN(SCVFIX) LOGICAL SCNSIM integer LENSCN parameter (LENSCN=SCSMAX+1+SCTMAX+7+(SFMMAX*4)+SFNMAX+(SCVFMX*4) & +SCVFIX+3) equivalence (SCNFIN,SCNRIN), (SCVFIN,SCVRIN) ! integer WHICH(WHSIZE), ios, status integer ROW1, ROW2, ROW3 integer DUMMY, HOLDER(SFNMAX*4), II, JJ ! ! Branch to the proper level 2 processing. ! ROW1 = WHICH(2) ROW2 = WHICH(3) ! ! RASTER class processing-- ! ! ROW1 ROW2 ROW3 Keyword ! ---- ---- ---- -------------------------------------- ! 1 1 RASTER_COORD_LOWER_LEFT_X ! 1 2 RASTER_COORD_LOWER_LEFT_Y ! 1 3 RASTER_COORD_UPPER_RIGHT_X ! 1 4 RASTER_COORD_UPPER_RIGHT_Y ! 1 7 RASTER_COORD_XOFFSET ! 1 8 RASTER_COORD_YOFFSET ! 1 9 RASTER_COORD_XSCALE ! 1 10 RASTER_COORD_YSCALE ! 2 1 RASTER_DATA_FORMAT ! 2 2 RASTER_DATA_ENCODING ! 2 3 RASTER_DATA_FLOATING_INFO ! 3 1 1 RASTER_VECTOR_COUNT_FORMAT ! 3 1 2 RASTER_VECTOR_COUNT_ENCODING ! 3 1 3 RASTER_VECTOR_COUNT_FLOATING_INFO ! 4 1 1 RASTER_HORIZONTAL_INSTRUCTION_START ! 4 1 2 RASTER_HORIZONTAL_INSTRUCTION_TERMINATOR ! 5 RASTER_SIMULATE ! if (ROW1 == 1 .and. ROW2 == 1) then call gtint(SCNLLX, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 2) then call gtint(SCNLLY, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 3) then call gtint(SCNURX, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 4) then call gtint(SCNURY, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 7) then call gtint(SCNXOF, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 8) then call gtint(SCNYOF, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 9) then call gtflt(SCNXSC, 1, dummy, ios, status) else if (ROW1 == 1 .and. ROW2 == 10) then call gtflt(SCNYSC, 1, dummy, ios, status) else if (ROW1 == 2 .and. ROW2 == 1) then call gtint(HOLDER, SFMMAX*4, dummy, ios, status) if (DUMMY /= 0) then SCNFIN(2) = DUMMY/4 do II = 1,SCNFIN(2) do JJ = 1,4 SCNFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW1 == 2 .and. ROW2 == 2) then call gtint(SCNFIN(1), 1, dummy, ios, status) else if (ROW1 == 2 .and. ROW2 == 3) then call gtflt(SCNRIN(5), 4, dummy, ios, status) else if (ROW1 == 5) then call gtlog(SCNSIM, 1, dummy, ios, status) else if (ROW1 == 4) then ROW3 = WHICH(4) if ( ROW2 == 1 .and. ROW3 == 1) then call gtstr(SCSSTR, SCSMAX, SCSSIZ, ios, status) else if (ROW2 == 1 .and. ROW3 == 2) then call gtstr(SCTSTR, SCTMAX, SCTSIZ, ios, status) end if else if (ROW1 == 3 .and.ROW2 == 1) then ROW3 = WHICH(4) if (ROW3 == 1) then call gtint(HOLDER, SCVFMX*4, dummy, ios, status) if (DUMMY /= 0) then SCVFIN(2) = DUMMY/4 do II = 1,SCVFIN(2) do JJ = 1,4 SCVFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW3 == 2) then call gtint(SCVFIN(1), 1, dummy, ios, status) else if (ROW3 == 3) then call gtflt(SCVRIN(5), 4, dummy, ios, status) end if end if return end subroutine rdline ( ios, status) ! !******************************************************************************* ! !! RDLINE returns the next non-comment line in the file. ! ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC ! ! CONTROL THE PRINTING OF INPUT LINES ! common /CAPSKP/ SKIPIT LOGICAL SKIPIT ! integer IOS, status integer II ! ! Read in the next buffer from the file. ! 10 CONTINUE call chrred ( unit, LNMAX, LINE, IPTR, ios, status) ! ! If error, then return. ! if ( STATUS /= allok) return ! ! Set the buffer size. ! LSIZE = IOS IOS = 0 ! ! Echo the line if requested. ! if ( .NOT. SKIPIT .and. LSIZE /= 0 ) then write ( *, '(a)' ) LINE(1:LSIZE) end if ! ! Check if this line is big enough to be a comment line. ! if ( LSIZE < 2) return ! ! Check if this line is a comment line. ! if (FRMCOM(1) == LINE(IPTR) .and. & FRMCOM(2) == LINE(IPTR+1) ) then go to 10 end if return end subroutine skpblk ( ios, status) ! !******************************************************************************* ! !! SKPBLK positions the buffer pointer to the next non-blank character. ! ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPIOB/ unit, IPTR, LSIZE common /CAPIO2/ LINE integer LNMAX parameter (LNMAX=80) character*1 LINE(LNMAX) integer unit, IPTR, LSIZE ! integer IOS, status character BLANK integer II ! DATA BLANK/' '/ ! ! Scan the current buffer for a non-blank. ! do do ii = IPTR, LSIZE if ( LINE(ii) /= BLANK ) then IPTR = ii return end if end do ! ! End of current buffer and no non-blank, get another line. ! call rdline ( ios, status) ! ! Return if EOF or bad read. ! if ( status /= allok ) then exit end if end do return end subroutine tmpcls ( which, ios, status ) ! !******************************************************************************* ! !! TMPCLS carries out level two TMP class processing. ! ! ! Parameters: ! ! Input, WHICH -- the encoded path flags. ! ! Output, ios -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! ! Output, status -- The error status as defined in common CAPERR. ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer, parameter :: WHSIZE = 20 ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPSPC/ VDWLLX,VDWLLY,VDWURX,VDWURY,PLGSIM,DUMSPC integer DUMSIZ parameter (DUMSIZ=1288) integer DUMSPC(DUMSIZ) integer VDWLLX,VDWLLY,VDWURX,VDWURY LOGICAL PLGSIM ! integer WHICH(WHSIZE), ios, status integer ROW1, ROW2 integer DUMMY ! ! Branch to the proper level 2 processing. ! ROW1 = WHICH(2) ROW2 = WHICH(3) ! ! TMP class processing-- ! ! ROW1 ROW2 ROW3 Keyword ! ---- ---- ---- ------------------------------------ ! 1 1 TMP_VDC_WINDOW_LOWER_LEFT_X ! 1 2 TMP_VDC_WINDOW_LOWER_LEFT_Y ! 1 3 TMP_VDC_WINDOW_UPPER_RIGHT_X ! 1 4 TMP_VDC_WINDOW_UPPER_RIGHT_Y ! 2 5 POLYGON_SIMULATE ! if ( ROW1 == 1 .and. ROW2 == 1 ) then call gtint ( VDWLLX, 1, dummy, ios, status ) else if ( ROW1 == 1 .and. ROW2 == 2 ) then call gtint ( VDWLLY, 1, dummy, ios, status ) else if ( ROW1 == 1 .and. ROW2 == 3 ) then call gtint ( VDWURX, 1, dummy, ios, status ) else if ( ROW1 == 1 .and. ROW2 == 4 ) then call gtint ( VDWURY, 1, dummy, ios, status ) else if ( ROW1 == 2 .and. ROW2 == 5 ) then call gtlog ( PLGSIM, 1, dummy, ios, status ) end if return end subroutine txtcls ( which, ios, status ) ! !******************************************************************************* ! !! TXTCLS processes the TEXT keywords. ! ! ! INPUT ! WHICH -- the encoded path flags. ! ! OUTPUT ! IOS -- I/O status flag. This flag is valid only ! if STATUS indicates an error. ! STATUS -- The error status as defined in common CAPERR. ! ! common /PARTB1/ PART1, KEYSEP, KEYTER, FRMCOM common /PARTB2/ PART2, PART3, PART4, PART5, CTSTR, CTLOC ! ! THE NUMBER OF WORDS IN THE SEARCH PATH MUST BE BIG ENOUGH TO HOLD ! THE NUMBER OF BITS PER PATH TIMES THE NUMBER OF LEVELS ! integer WHSIZE parameter (WHSIZE=20) ! integer PARTSZ, OTHSZ, NTABLE parameter(PARTSZ=3000, OTHSZ=150, NTABLE=50) character*1 KEYSEP,KEYTER character*1 FRMCOM(2) integer PART2(OTHSZ), PART3(OTHSZ), PART4(NTABLE), PART5(NTABLE*2) character*1 PART1(PARTSZ) integer CTSTR, CTLOC common /CAPERR/ ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, & UNDASC, KEYERR, DOCERR, TBLERR , STSZER, ENTERR, & TABERR, TABSER, PRSFIL integer ALLOK, EOFFL, INTERR, MAXINT, PLBERR, PMBERR, & FABERR, TXBERR, FLTERR, MAXFLT, NOTINT, SIZERR, UNDASC, & KEYERR, DOCERR, STSZER, ENTERR, TABERR, TABSER, TBLERR, & PRSFIL common /CAPTXT/ TCSSTR, TCSSIZ, TCTSTR, TCTSIZ, TXTFIN, TXTFMT, & TXSSTR, TXSSIZ, TXTSTR, TXTSIZ integer TCSMAX, TCTMAX, TVCFMX, TXSMAX, TXTMAX parameter (TCSMAX=10, TCTMAX=10, TVCFMX=5, TXSMAX=20, TXTMAX=20) integer TCSSTR(TCSMAX), TCSSIZ, & TCTSTR(TCTMAX), TCTSIZ, & TXTFIN(5), TXTFMT(TVCFMX,4), TXSSTR(TXSMAX), TXSSIZ, & TXTSTR(TXTMAX), TXTSIZ ! ! SIZE OF common CAPTXT ! integer LENTXT parameter (LENTXT=TCSMAX+TCTMAX+2+5+TVCFMX*4+TXSMAX+1+TXTMAX+1) ! integer WHICH(WHSIZE), ios, status integer ROW2, ROW3, ROW4 integer DUMMY, HOLDER(TVCFMX*4), II, JJ ! ! Branch to the proper level 2 processing. ! ROW2 = WHICH(2) ROW3 = WHICH(3) ROW4 = WHICH(4) ! ! TEXT class processing. ! ! ROW2 ROW3 ROW4 Keyword ! ---- ---- ---- --------------------------------------- ! 1 1 1 TEXT_COLOR_INSTRUCTION_START ! 1 1 2 TEXT_COLOR_INSTRUCTION_TERMINATOR ! 2 1 1 TEXT_VECTOR_COUNT_FORMAT ! 2 1 2 TEXT_VECTOR_COUNT_ENCODING ! 3 1 TEXT_INSTRUCTION_START ! 3 2 TEXT_INSTRUCTION_TERMINATOR ! ! if (ROW2 == 1 .and. ROW3 == 1) then if (ROW4 == 1 ) then call gtstr(TCSSTR, TCSMAX, TCSSIZ, ios, status) else if (ROW4 == 2) then call gtstr(TCTSTR, TCTMAX, TCTSIZ, ios, status) end if else if (ROW2 == 2 .and. ROW3 == 1) then if (ROW4 == 1) then call gtint(HOLDER, TVCFMX*4, dummy, ios, status) if (DUMMY /= 0) then TXTFIN(2) = DUMMY/4 do II = 1,TXTFIN(2) do JJ = 1,4 TXTFMT(II,JJ) = HOLDER((II-1)*4+JJ) end do end do end if else if (ROW4 == 2) then call gtint(TXTFIN(1), 1, dummy, ios, status) end if else if (ROW2 == 3 .and. ROW3 == 1) then call gtstr(TXSSTR, TXSMAX, TXSSIZ, ios, status) else if (ROW2 == 3 .and. ROW3 == 2) then call gtstr(TXTSTR, TXTMAX, TXTSIZ, ios, status) end if return end