home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / pgplot_1 / SYS_ARC / f77 / PSDriver < prev   
Text File  |  1996-11-05  |  36KB  |  1,050 lines
  1. C*PSDRIV -- PGPLOT PostScript drivers
  2. C+
  3.       SUBROUTINE PSDRIV (IFUNC, RBUF, NBUF, CHR, LCHR, MODE)
  4.       INTEGER IFUNC, NBUF, LCHR, MODE
  5.       REAL    RBUF(*)
  6.       CHARACTER*(*) CHR
  7. C
  8. C PGPLOT driver for PostScript devices.
  9. C
  10. C Version 1.2  - 1987 Aug  5 - T. J. Pearson.
  11. C Version 1.3  - 1987 Nov 16 - add "bind" commands to prolog - TJP.
  12. C Version 1.4  - 1988 Jan 28 - change dimensions so whole field can be
  13. C                              plotted - TJP.
  14. C Version 1.5  - 1988 Oct 27 - make EOF characters optional - TJP.
  15. C Version 1.6  - 1988 Dec 15 - standard Fortran - TJP.
  16. C Version 1.7  - 1989 Jul  5 - change color indices so most colors
  17. C                              are black - TJP.
  18. C Version 2.0  - 1990 Sep 10 - parameterize dimensions; correct
  19. C                              bounding box; add color support (from
  20. C                              D. Meier's CPdriver) - TJP.
  21. C Version 2.1  - 1991 Nov 29 - update Document Structuring Conventions
  22. C                              to version 3.0.
  23. C Version 3.0  - 1992 Sep 22 - add marker support; add CPS and VCPS
  24. C                              modes - TJP.
  25. C Version 3.1  - 1992 Nov 12 - up to 256 colors.
  26. C Version 3.2  - 1993 May 26 - correct error in marker support.
  27. C Version 4.0  - 1993 Sep 20 - trap Fortran I/O errors.
  28. C Version 4.1  - 1994 Aug  4 - make marker support optional.
  29. C Version 5.0  - 1994 Aug 30 - support for images.
  30. C Version 5.1  - 1994 Sep  7 - support for PGQCR.
  31. C Version 5.2  - 1994 Oct 12 - add IDENT option.
  32. C Version 5.3  - 1995 May  8 - recognise '-' as standard output; keep
  33. C                              track of bounding box; use upper case
  34. C                              for all defined commands; move
  35. C                              showpage outside save/restore.
  36. C Version 5.4  - 1995 Aug 19 - correct usage of PS_BBOX.
  37. C Version 6.0  - 1995 Dec 28 - reject concurrent access.
  38. C Version 6.1  - 1996 Apr 29 - decode environment variables using GRCTOI.
  39. C Version 6.2  - 1996 Oct  7 - correct bounding-box error (K-G Adams);
  40. C                              correct error in use of GCTOI (G Gonczi);
  41. C                              suppress <0 0 C> commands (R Scharroo);
  42. C                              allow arbitrary page size.
  43. C              - 1996 Nov  5 - sets postscript file type for Acorn (D.J.C)
  44. C
  45. C Supported device: 
  46. C   Any printer that accepts the PostScript page description language, 
  47. C   eg, the LaserWriter (Apple Computer, Inc.).
  48. C   PostScript is a trademark of Adobe Systems Incorporated.
  49. C
  50. C Device type code: 
  51. C   /PS (monochrome landscape mode, long edge of paper horizontal).
  52. C   /CPS (color landscape mode, long edge of paper horizontal).
  53. C   /VPS (monochrome portrait mode, short edge of paper horizontal).
  54. C   /VCPS (color portrait mode, short edge of paper horizontal).
  55. C
  56. C Default file name:
  57. C   pgplot.ps
  58. C
  59. C Default view surface dimensions:
  60. C   10.5 inches horizontal x  7.8 inches vertical (landscape mode),
  61. C    7.8 inches horizontal x 10.5 inches vertical (portrait mode).
  62. C   These dimensions can be changed with environment variables.
  63. C
  64. C Resolution:
  65. C   The driver uses coordinate increments of 0.001 inch, giving an
  66. C   ``apparent'' resolution of 1000 pixels/inch. The true resolution is
  67. C   device-dependent; eg, on an Apple LaserWriter it is 300 pixels/inch
  68. C   (in both dimensions). 
  69. C
  70. C Color capability (monochrome mode): 
  71. C   Color indices 0-255 are supported. Color index 0 is white (erase
  72. C   or background color), indices 1-13 are black, 14 is light grey,
  73. C   and 15 is dark grey.
  74. C
  75. C Color capability (color mode):
  76. C   Color indices 0-255 are supported. Color index 0 is white (erase
  77. C   or background color), index 1 is black, and indices 2-15 have the
  78. C   standard PGPLOT color assignments.
  79. C
  80. C Input capability: none.
  81. C
  82. C File format: the file contains variable length records (maximum 132
  83. C characters) containing PostScript commands. The commands use only
  84. C printable ASCII characters, and the file can be examined or modified 
  85. C with a text editor. 
  86. C
  87. C Obtaining hardcopy: use the operating system print or copy command to
  88. C send the file to a suitable device.
  89. C
  90. C Environment variables:
  91. C
  92. C  PGPLOT_PS_WIDTH      default  7800
  93. C  PGPLOT_PS_HEIGHT     default 10500
  94. C  PGPLOT_PS_HOFFSET    default   350
  95. C  PGPLOT_PS_VOFFSET    default   250
  96. C These variables tell PGPLOT how big an image to produce. The defaults
  97. C are appropriate for 8.5 x 11-inch paper. The maximum dimensions of
  98. C a PGPLOT image are WIDTH by HEIGHT, with the lower left corner offset
  99. C by HOFFSET horizontally and VOFFSET vertically from the lower left
  100. C corner of the paper. The units are milli-inches. The "top" of the
  101. C paper is the edge that comes out of the printer first.
  102. C
  103. C  PGPLOT_IDENT
  104. C If this variable is set, the user name, date and time are written
  105. C in the bottom right corner of each page.
  106. C
  107. C  PGPLOT_PS_BBOX
  108. C If this variable has value MAX, PGPLOT puts standard (full-page)
  109. C bounding-box information in the header of the PostScript file. If
  110. C the variable is unset or has some other value, PGPLOT puts the
  111. C correct (smallest) bounding box information in the trailer of the
  112. C PostScript file.
  113. C
  114. C  PGPLOT_PS_EOF
  115. C Normally the output file does not contain special end-of-file
  116. C characters. But if environment variable PGPLOT_PS_EOF is defined
  117. C (with any value) PGPLOT writes a control-D job-separator character at 
  118. C the beginning and at the end of the file. This is appropriate for
  119. C Apple LaserWriters using the serial interface, but it may not be 
  120. C appropriate for other PostScript devices.
  121. C
  122. C  PGPLOT_PS_MARKERS
  123. C Specify "NO" to suppress use of a PostScript font for the graph
  124. C markers; markers are then emulated by line-drawing. 
  125. C
  126. C Document Structuring Conventions:
  127. C
  128. C  The PostScript files conform to Version 3.0 of the Adobe Document 
  129. C  Structuring Conventions (see ref.3) and to version 3.0 of the
  130. C  encapsulated PostScript file (EPSF) format. This should allow
  131. C  the files to be read by other programs that accept the EPSF format.
  132. C  Note, though, that multi-page plots are not valid EPSF files. The
  133. C  files do not contain a screen preview section.
  134. C
  135. C References:
  136. C
  137. C (1) Adobe Systems, Inc.: PostScript Language Reference Manual.
  138. C Addison-Wesley, Reading, Massachusetts, 1985.
  139. C (2) Adobe Systems, Inc.: PostScript Language Tutorial and Cookbook.
  140. C Addison-Wesley, Reading, Massachusetts, 1985.
  141. C (3) Adobe Systems, Inc.: PostScript Language Reference Manual, Second 
  142. C Edition. Addison-Wesley, Reading, Massachusetts, 1990.
  143. C-----------------------------------------------------------------------
  144.       INTEGER DWD, DHT, DOFFW, DOFFH
  145.       CHARACTER*(*) PTYPE, LTYPE, CPTYPE, CLTYPE, DEFNAM
  146.       PARAMETER (
  147.      : PTYPE= 'VPS   (PostScript file, portrait orientation)',
  148.      : LTYPE= 'PS    (PostScript file, landscape orientation)',
  149.      : CPTYPE='VCPS  (Colour PostScript file, portrait orientation)',
  150.      : CLTYPE='CPS   (Colour PostScript file, landscape orientation)')
  151. C     PARAMETER (PTYPE='VPS', LTYPE='PS', CPTYPE='VCPS', CLTYPE='CPS')
  152.       PARAMETER (DEFNAM='pgplot/ps')
  153. C -- printable paper area: in milli-inches; (WIDTH, HEIGHT) are
  154. C    the dimensions of the printable area; OFFW, OFFH the offset from
  155. C    the lower left corner of the paper
  156.       PARAMETER (DWD=7800, DHT=10500, DOFFW=350, DOFFH=250)
  157. C
  158.       INTEGER WIDTH, HEIGHT, OFFW, OFFH
  159.       SAVE    WIDTH, HEIGHT, OFFW, OFFH
  160.       INTEGER  IER, I0, J0, I1, J1, L, LL, LASTI, LASTJ, UNIT, LOBUF
  161.       SAVE                                 LASTI, LASTJ, UNIT, LOBUF
  162.       INTEGER  CI, LW, NPTS, NPAGE, IOERR, LFNAME
  163.       SAVE         LW, NPTS, NPAGE, IOERR, LFNAME
  164.       INTEGER  STATE
  165.       SAVE     STATE
  166.       INTEGER  NXP, NYP, XORG, YORG, XLEN, YLEN, N, RGB(3)
  167.       INTEGER  HIGH, LOW, I, K, KMAX, POSN, LD, LU
  168.       INTEGER  BBOX(4), BB1, BB2, BB3, BB4
  169.       SAVE     BBOX
  170.       INTEGER  GROPTX, GRCTOI
  171.       LOGICAL  START, LANDSC, COLOR, STDOUT
  172.       SAVE     START,         COLOR, STDOUT
  173.       REAL     BBXMIN, BBXMAX, BBYMIN, BBYMAX
  174.       SAVE     BBXMIN, BBXMAX, BBYMIN, BBYMAX
  175.       REAL     RVALUE(0:255), GVALUE(0:255), BVALUE(0:255)
  176.       SAVE     RVALUE,        GVALUE,        BVALUE
  177.       CHARACTER*20  SUSER, SDATE
  178.       CHARACTER*120 INSTR, MSG
  179.       CHARACTER*132 OBUF
  180.       SAVE          OBUF
  181.       CHARACTER*255 FNAME
  182.       SAVE          FNAME
  183.       INTEGER       MARKER(0:31), NSYM, RAD(0:31)
  184.       SAVE          MARKER, RAD
  185.       REAL          MFAC
  186.       SAVE          MFAC
  187.       REAL          SHADE(0:15), RINIT(0:15), GINIT(0:15), BINIT(0:15)
  188.       SAVE          SHADE,       RINIT,       GINIT,       BINIT
  189.       CHARACTER*1   HEXDIG(0:15)
  190.       INTEGER IREGS(0:7)
  191.       DATA HEXDIG/'0','1','2','3','4','5','6','7',
  192.      1            '8','9','A','B','C','D','E','F'/
  193.       DATA SHADE /1.00, 13*0.00, 0.33, 0.67/
  194.       DATA RINIT 
  195.      1     / 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00,
  196.      2       1.00, 0.50, 0.00, 0.00, 0.50, 1.00, 0.33, 0.67/
  197.       DATA GINIT
  198.      1     / 1.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00,
  199.      2       0.50, 1.00, 1.00, 0.50, 0.00, 0.00, 0.33, 0.67/
  200.       DATA BINIT
  201.      1     / 1.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 0.00,
  202.      2       0.00, 0.00, 0.50, 1.00, 1.00, 0.50, 0.33, 0.67/
  203.       DATA RAD/ 6,  1,  7,  6, 7, 5, 6, 8,
  204.      :          7,  7,  9, 10, 9, 8, 6, 8,
  205.      :          4,  5,  9, 12, 2, 4, 5, 7,
  206.      :         11, 17, 22, 41, 9, 9, 9, 9/
  207.       DATA STATE/0/
  208. C-----------------------------------------------------------------------
  209. C
  210.       GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
  211.      1     110,120,130,140,150,160,170,180,190,200,
  212.      2     210,220,230,900,900,260,900,280,290), IFUNC
  213.       GOTO 900
  214. C
  215. C--- IFUNC = 1, Return device name.-------------------------------------
  216. C
  217.    10 IF (MODE.EQ.1) THEN
  218. C         -- landscape, monochrome
  219.           CHR = LTYPE
  220.           LCHR = LEN(LTYPE)
  221.       ELSE IF (MODE.EQ.2) THEN
  222. C         -- portrait, monochrome
  223.           CHR = PTYPE
  224.           LCHR = LEN(PTYPE)
  225.       ELSE IF (MODE.EQ.3) THEN
  226. C         -- landscape, color
  227.           CHR = CLTYPE
  228.           LCHR = LEN(CLTYPE)
  229.       ELSE
  230. C         -- portrait, color
  231.           CHR = CPTYPE
  232.           LCHR = LEN(CPTYPE)
  233.       END IF
  234.       RETURN
  235. C
  236. C--- IFUNC = 2, Return physical min and max for plot device, and range
  237. C               of color indices.---------------------------------------
  238. C
  239.    20 RBUF(1) = 0
  240.       RBUF(2) = -1
  241.       RBUF(3) = 0
  242.       RBUF(4) = -1
  243.       RBUF(5) = 0
  244.       RBUF(6) = 255
  245.       NBUF = 6
  246.       RETURN
  247. C
  248. C--- IFUNC = 3, Return device resolution. ------------------------------
  249. C
  250.    30 RBUF(1) = 1000.0
  251.       RBUF(2) = 1000.0
  252.       RBUF(3) = 5
  253.       NBUF = 3
  254.       RETURN
  255. C
  256. C--- IFUNC = 4, Return misc device info. -------------------------------
  257. C    (This device is Hardcopy, No cursor, No dashed lines, Area fill, 
  258. C    Thick lines, QCR, Markers [optional])
  259. C
  260.    40 CONTINUE
  261.       CHR = 'HNNATNQNYM'
  262. C     -- Marker support suppressed?
  263.       CALL GRGENV('PS_MARKERS', INSTR, L)
  264.       IF (L.GE.2) THEN
  265.          IF (INSTR(1:L).EQ.'NO' .OR. INSTR(1:L).EQ.'no') THEN
  266.             CHR(10:10) = 'N'
  267.          END IF
  268.       END IF
  269.       LCHR = 10
  270.       RETURN
  271. C
  272. C--- IFUNC = 5, Return default file name. ------------------------------
  273. C
  274.    50 CHR = DEFNAM
  275.       LCHR = LEN(DEFNAM)
  276.       RETURN
  277. C
  278. C--- IFUNC = 6, Return default physical size of plot. ------------------
  279. C
  280.    60 RBUF(1) = 0
  281.       RBUF(3) = 0
  282.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  283.       IF (LANDSC) THEN
  284.           RBUF(2) = HEIGHT-1
  285.           RBUF(4) = WIDTH-1
  286.       ELSE
  287.           RBUF(2) = WIDTH-1
  288.           RBUF(4) = HEIGHT-1
  289.       END IF
  290.       NBUF = 4
  291.       RETURN
  292. C
  293. C--- IFUNC = 7, Return misc defaults. ----------------------------------
  294. C
  295.    70 RBUF(1) = 8
  296.       NBUF = 1
  297.       RETURN
  298. C
  299. C--- IFUNC = 8, Select plot. -------------------------------------------
  300. C
  301.    80 CONTINUE
  302.       RETURN
  303. C
  304. C--- IFUNC = 9, Open workstation. --------------------------------------
  305. C
  306.    90 CONTINUE
  307. C     -- check for concurrent access
  308.       IF (STATE.EQ.1) THEN
  309.          CALL GRWARN('a PGPLOT PostScript file is already open')
  310.          RBUF(1) = 0
  311.          RBUF(2) = 0
  312.          RETURN
  313.       END IF
  314. C     -- Color mode?
  315.       CALL GRGENV('PS_COLOR', INSTR, L)
  316.       COLOR = L.GT.0 .OR. MODE.EQ.3 .OR. MODE.EQ.4
  317.       IF (COLOR) THEN
  318.          DO 91 CI=0,15
  319.             RVALUE(CI) = RINIT(CI)
  320.             GVALUE(CI) = GINIT(CI)
  321.             BVALUE(CI) = BINIT(CI)
  322.  91      CONTINUE
  323.       ELSE
  324.          DO 92 CI=0,15
  325.             RVALUE(CI) = SHADE(CI)
  326.             GVALUE(CI) = SHADE(CI)
  327.             BVALUE(CI) = SHADE(CI)
  328.  92      CONTINUE
  329.       END IF
  330.       DO 93 CI=16,255
  331.          RVALUE(CI) = 0.0
  332.          GVALUE(CI) = 0.0
  333.          BVALUE(CI) = 0.0
  334.  93   CONTINUE
  335. C     -- Device dimensions
  336.       WIDTH = DWD
  337.       HEIGHT = DHT
  338.       OFFW = DOFFW
  339.       OFFH = DOFFH
  340.       CALL GRGENV('PS_WIDTH', INSTR, L)
  341.       LL = 1
  342.       IF (L.GT.0) WIDTH = GRCTOI(INSTR(:L),LL)
  343.       CALL GRGENV('PS_HEIGHT', INSTR, L)
  344.       LL = 1
  345.       IF (L.GT.0) HEIGHT = GRCTOI(INSTR(:L),LL)
  346.       CALL GRGENV('PS_HOFFSET', INSTR, L)
  347.       LL = 1
  348.       IF (L.GT.0) OFFW = GRCTOI(INSTR(:L),LL)
  349.       CALL GRGENV('PS_VOFFSET', INSTR, L)
  350.       LL = 1
  351.       IF (L.GT.0) OFFH = GRCTOI(INSTR(:L),LL)
  352.       STDOUT =CHR(1:LCHR).EQ.'-'
  353.       IF (STDOUT) THEN
  354.          UNIT = 6
  355. C        -- machine-dependent!
  356.       ELSE
  357.          CALL GRGLUN(UNIT)
  358.       END IF
  359.       NBUF = 2
  360.       RBUF(1) = UNIT
  361.       IF (.NOT.STDOUT) THEN
  362.          IER = GROPTX(UNIT, CHR(1:LCHR), DEFNAM, 1)
  363.          IF (IER.NE.0) THEN
  364.             MSG = 'Cannot open output file for PostScript plot: '//
  365.      1           CHR(:LCHR)
  366.             CALL GRWARN(MSG)
  367.             RBUF(2) = 0
  368.             CALL GRFLUN(UNIT)
  369.             RETURN
  370.          ELSE
  371.             INQUIRE (UNIT=UNIT, NAME=CHR)
  372.             LCHR = LEN(CHR)
  373.  94         IF (CHR(LCHR:LCHR).EQ.' ') THEN
  374.                LCHR = LCHR-1
  375.                GOTO 94
  376.             END IF
  377.             RBUF(2) = 1
  378.             FNAME = CHR(:LCHR)
  379.             LFNAME = LCHR
  380.          END IF
  381.       ELSE
  382.          RBUF(2) = 1
  383.          FNAME = '-'
  384.          LFNAME= 1
  385.       END IF
  386.       STATE = 1
  387.       IOERR = 0
  388.       LOBUF = 0
  389.       LASTI = -1
  390.       LASTJ = -1
  391.       LW = 1
  392.       NPTS = 0
  393.       CALL GRGENV('PS_EOF', INSTR, L)
  394.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, CHAR(4))
  395.       CALL GRPS02(IOERR, UNIT, '%!PS-Adobe-3.0 EPSF-3.0')
  396.       CALL GRUSER(INSTR, L)
  397.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, '%%For: '//INSTR(1:L))
  398.       CALL GRPS02(IOERR, UNIT, '%%Title: PGPLOT PostScript plot')
  399.       CALL GRPS02(IOERR, UNIT, '%%Creator: PGPLOT')
  400.       CALL GRDATE(INSTR, L)
  401.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT,
  402.      :    '%%CreationDate: '//INSTR(1:L))
  403.       CALL GRGENV('PS_BBOX', INSTR, L)
  404.       CALL GRTOUP(INSTR(1:3), INSTR(1:3))
  405.       IF (INSTR(1:3).EQ.'MAX') THEN
  406. C        -- bounding box is based on maximum plot dimensions, not
  407. C           actual dimensions
  408.          CALL GRFAO('%%BoundingBox: # # # #', L, INSTR,
  409.      :        NINT(OFFW*0.072), NINT(OFFH*0.072),
  410.      :        NINT((WIDTH+OFFW)*0.072), NINT((HEIGHT+OFFH)*0.072))
  411.          CALL GRPS02(IOERR, UNIT, INSTR(:L))
  412.       ELSE
  413.          CALL GRPS02(IOERR, UNIT, '%%BoundingBox: (atend)')
  414.       END IF
  415.       CALL GRPS02(IOERR, UNIT, '%%DocumentFonts: (atend)')
  416.       CALL GRPS02(IOERR, UNIT, '%%LanguageLevel: 1')
  417.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  418.       IF (LANDSC) THEN
  419.           CALL GRPS02(IOERR, UNIT, '%%Orientation: Landscape')
  420.       ELSE
  421.           CALL GRPS02(IOERR, UNIT, '%%Orientation: Portrait')
  422.       END IF
  423.       CALL GRPS02(IOERR, UNIT, '%%Pages: (atend)')
  424.       CALL GRPS02(IOERR, UNIT, '%%EndComments')
  425.       CALL GRPS02(IOERR, UNIT, '%%BeginProlog')
  426.       CALL GRPS02(IOERR, UNIT, 
  427.      1  '/L {moveto rlineto currentpoint stroke moveto} bind def')
  428.       CALL GRPS02(IOERR, UNIT, 
  429.      1  '/C {rlineto currentpoint stroke moveto} bind def')
  430.       CALL GRPS02(IOERR, UNIT, 
  431.      1  '/D {moveto 0 0 rlineto currentpoint stroke moveto} bind def')
  432.       CALL GRPS02(IOERR, UNIT, '/SLW {5 mul setlinewidth} bind def')
  433.       CALL GRPS02(IOERR, UNIT, '/SCF /pop load def')
  434.       CALL GRPS02(IOERR, UNIT, '/BP {newpath moveto} bind def')
  435.       CALL GRPS02(IOERR, UNIT, '/LP /rlineto load def')
  436.       CALL GRPS02(IOERR, UNIT, 
  437.      1  '/EP {rlineto closepath eofill} bind def')
  438.       CALL GRPS02(IOERR, UNIT, '/MB {gsave translate MFAC dup scale '//
  439.      1 '1 setlinewidth 2 setlinecap 0 setlinejoin newpath} bind def')
  440.       CALL GRPS02(IOERR, UNIT, '/ME /grestore load def')
  441.       CALL GRPS02(IOERR, UNIT, '/CC {0 360 arc stroke} bind def')
  442.       CALL GRPS02(IOERR, UNIT, '/FC {0 360 arc fill} bind def')
  443.       CALL GRGENV('IDENT', INSTR, L)
  444.       IF (L.GT.0) THEN
  445.          CALL GRPS02(IOERR, UNIT,
  446.      :        '/RS{findfont exch scalefont setfont moveto dup'//
  447.      :        ' stringwidth neg exch neg exch rmoveto show} bind def')
  448.       END IF
  449.       CALL GRPS02(IOERR, UNIT, '%%EndProlog')
  450.       NPAGE = 0
  451.       RETURN
  452. C
  453. C--- IFUNC=10, Close workstation. --------------------------------------
  454. C
  455.   100 CONTINUE
  456.       CALL GRPS02(IOERR, UNIT, ' ')
  457.       CALL GRPS02(IOERR, UNIT, '%%Trailer')
  458.       CALL GRGENV('PS_BBOX', INSTR, L)
  459.       CALL GRTOUP(INSTR(1:3), INSTR(1:3))
  460.       IF (INSTR(1:3).NE.'MAX') THEN
  461.          CALL GRFAO('%%BoundingBox: # # # #', L, INSTR,
  462.      :        BBOX(1), BBOX(2), BBOX(3), BBOX(4))
  463.          CALL GRPS02(IOERR, UNIT, INSTR(:L))
  464.       END IF
  465.       CALL GRPS02(IOERR, UNIT, '%%DocumentFonts: ')
  466.       CALL GRFAO('%%Pages: #', L, INSTR, NPAGE, 0, 0, 0)
  467.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  468.       CALL GRPS02(IOERR, UNIT, '%%EOF')
  469.       CALL GRGENV('PS_EOF', INSTR, L)
  470.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, CHAR(4))
  471.       IF (IOERR.NE.0) THEN
  472.           CALL GRWARN('++WARNING++ Error '//
  473.      1       'writing PostScript file: file is incomplete')
  474.           CALL GRWARN('Check for device full or quota exceeded')
  475.           CALL GRWARN('Filename: '//FNAME(:LFNAME))
  476.       END IF
  477.       IF (.NOT.STDOUT) THEN
  478.          CLOSE (UNIT, IOSTAT=IOERR)
  479.          IF (IOERR.NE.0) THEN
  480.            CALL GRWARN('Error closing PostScript file '//FNAME(:LFNAME))
  481.          END IF
  482. C             set Acorn postscript file type
  483.          IREGS(0)=18
  484.          FNAME(LFNAME+1:LFNAME+1)=?H00
  485.          IREGS(1)=LOCC(FNAME(1:LFNAME+1))
  486.          IREGS(2)=?I0FF5
  487. C             do OS_File,18,"name",&FF5
  488.          CALL SWIF77(8,IREGS,IDUM)
  489. C             end Acorn mod.
  490.          CALL GRFLUN(UNIT)
  491.       END IF
  492.       STATE = 0
  493.       RETURN
  494. C
  495. C--- IFUNC=11, Begin picture. ------------------------------------------
  496. C
  497.   110 CONTINUE
  498.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  499.       IF (LANDSC) THEN
  500.          HEIGHT = RBUF(1)
  501.          WIDTH = RBUF(2)
  502.       ELSE
  503.          WIDTH = RBUF(1)
  504.          HEIGHT = RBUF(2)
  505.       END IF
  506.       NPAGE = NPAGE+1
  507.       CALL GRPS02(IOERR, UNIT, ' ')
  508.       CALL GRFAO('%%Page: # #', L, INSTR, NPAGE, NPAGE, 0, 0)
  509.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  510.       CALL GRPS02(IOERR, UNIT, '%%BeginPageSetup')
  511.       CALL GRPS02(IOERR, UNIT, '/PGPLOT save def')
  512.       CALL GRPS02(IOERR, UNIT, '0.072 0.072 scale')
  513.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  514.       IF (LANDSC) THEN
  515.           CALL GRFAO('# # translate 90 rotate', L, INSTR, WIDTH+OFFW, 
  516.      1               OFFH, 0, 0)
  517.       ELSE
  518.           CALL GRFAO('# # translate', L, INSTR, OFFW, OFFH, 0, 0)
  519.       END IF
  520.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  521.       CALL GRPS02(IOERR, UNIT, '1 setlinejoin 1 setlinecap 1 SLW 1 SCF')
  522.       CALL GRPS02(IOERR, UNIT, '%%EndPageSetup')
  523.       CALL GRPS02(IOERR, UNIT, '%%PageBoundingBox: (atend)')
  524.       DO 111 NSYM=0,31
  525.           MARKER(NSYM) = 0
  526.   111 CONTINUE
  527.       MFAC = 0.0
  528.       BBXMIN = WIDTH
  529.       BBYMIN = HEIGHT
  530.       BBXMAX = 0.0
  531.       BBYMAX = 0.0
  532.       RETURN
  533. C
  534. C--- IFUNC=12, Draw line. ----------------------------------------------
  535. C
  536.   120 CONTINUE
  537.       I0 = NINT(RBUF(1))
  538.       J0 = NINT(RBUF(2))
  539.       I1 = NINT(RBUF(3))
  540.       J1 = NINT(RBUF(4))
  541.       IF (I0.EQ.LASTI .AND. J0.EQ.LASTJ) THEN
  542. C        -- suppress zero-length continuation segment
  543.          IF (I0.EQ.I1 .AND. J0.EQ.J1) RETURN
  544.          CALL GRFAO('# # C', L, INSTR, (I1-I0), (J1-J0), 0, 0)
  545.       ELSE
  546.          CALL GRFAO('# # # # L', L, INSTR, (I1-I0), (J1-J0), I0, J0)
  547.       END IF
  548.       LASTI = I1
  549.       LASTJ = J1
  550.       BBXMIN = MIN(BBXMIN, I0-LW*5.0, I1-LW*5.0)
  551.       BBXMAX = MAX(BBXMAX, I0+LW*5.0, I1+LW*5.0)
  552.       BBYMIN = MIN(BBYMIN, J0-LW*5.0, J1-LW*5.0)
  553.       BBYMAX = MAX(BBYMAX, J0+LW*5.0, J1+LW*5.0)
  554.       GOTO 800
  555. C
  556. C--- IFUNC=13, Draw dot. -----------------------------------------------
  557. C
  558.   130 CONTINUE
  559.       I1 = NINT(RBUF(1))
  560.       J1 = NINT(RBUF(2))
  561.       CALL GRFAO('# # D', L, INSTR, I1, J1, 0, 0)
  562.       LASTI = I1
  563.       LASTJ = J1
  564.       BBXMIN = MIN(BBXMIN, I1-LW*5.0)
  565.       BBXMAX = MAX(BBXMAX, I1+LW*5.0)
  566.       BBYMIN = MIN(BBYMIN, J1-LW*5.0)
  567.       BBYMAX = MAX(BBYMAX, J1+LW*5.0)
  568.       GOTO 800
  569. C
  570. C--- IFUNC=14, End picture. --------------------------------------------
  571. C
  572.   140 CONTINUE
  573.       IF (LOBUF.NE.0) THEN
  574.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  575.           LOBUF = 0
  576.       END IF
  577.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  578. C     -- optionally write identification
  579.       CALL GRGENV('IDENT', INSTR, L)
  580.       IF (L.GT.0) THEN
  581.          CALL GRUSER(SUSER, LU)
  582.          CALL GRDATE(SDATE, LD)
  583.          POSN = WIDTH - 1
  584.          IF (LANDSC) POSN = HEIGHT - 1
  585.          CALL GRFAO('('//SUSER(:LU)//' '//SDATE(:LD)//
  586.      :        ' [#]) # # 100 /Helvetica RS',
  587.      :        L, INSTR, NPAGE, POSN, 50, 0)
  588.          CALL GRPS02(IOERR, UNIT, '0.0 setgray')
  589.          CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  590.       END IF
  591. C     -- optionally draw bounding box
  592.       CALL GRGENV('PS_DRAW_BBOX', INSTR, L)
  593.       IF (L.GT.0) THEN
  594.          CALL GRFAO('0.0 setgray 0 SLW newpath # # moveto', L, INSTR,
  595.      :              NINT(BBXMIN), NINT(BBYMIN), 0, 0)
  596.          CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  597.          CALL GRFAO('# # lineto # # lineto', L, INSTR,
  598.      :        NINT(BBXMIN), NINT(BBYMAX), NINT(BBXMAX), NINT(BBYMAX))
  599.          CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  600.          CALL GRFAO('# # lineto closepath stroke', L,INSTR,
  601.      :              NINT(BBXMAX), NINT(BBYMIN), 0, 0)
  602.          CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  603.       END IF
  604.       CALL GRPS02(IOERR, UNIT, 'PGPLOT restore showpage')
  605.       CALL GRPS02(IOERR, UNIT, '%%PageTrailer')
  606.       IF (LANDSC) THEN
  607.          BB1 = INT((WIDTH-BBYMAX+OFFW)*0.072)
  608.          BB2 = INT((BBXMIN+OFFH)*0.072)
  609.          BB3 = 1+INT((WIDTH-BBYMIN+OFFW)*0.072)
  610.          BB4 = 1+INT((BBXMAX+OFFH)*0.072)
  611.       ELSE
  612.          BB1 = INT((BBXMIN+OFFW)*0.072)
  613.          BB2 = INT((BBYMIN+OFFH)*0.072)
  614.          BB3 = 1+INT((BBXMAX+OFFW)*0.072)
  615.          BB4 = 1+INT((BBYMAX+OFFH)*0.072)
  616.       END IF
  617.       CALL GRFAO('%%PageBoundingBox: # # # #', L, INSTR,
  618.      :           BB1, BB2, BB3, BB4)
  619.       CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  620.       IF (NPAGE.EQ.1) THEN
  621.          BBOX(1) = BB1
  622.          BBOX(2) = BB2
  623.          BBOX(3) = BB3
  624.          BBOX(4) = BB4
  625.       ELSE
  626.          BBOX(1) = MIN(BBOX(1),BB1)
  627.          BBOX(2) = MIN(BBOX(2),BB2)
  628.          BBOX(3) = MAX(BBOX(3),BB3)
  629.          BBOX(4) = MAX(BBOX(4),BB4)
  630.       END IF
  631.       RETURN
  632. C
  633. C--- IFUNC=15, Select color index. -------------------------------------
  634. C
  635.   150 CONTINUE
  636.       CI = NINT(RBUF(1))
  637.       IF (COLOR) THEN
  638.           WRITE(INSTR,'(3(F5.3,1X),''setrgbcolor'')')
  639.      1          RVALUE(CI), GVALUE(CI), BVALUE(CI)
  640.           L = 29
  641.       ELSE
  642.           WRITE(INSTR,'(F5.3,1X,''setgray'')') RVALUE(CI)
  643.           L = 13
  644.       END IF
  645.       LASTI = -1
  646.       GOTO 800
  647. C
  648. C--- IFUNC=16, Flush buffer. -------------------------------------------
  649. C
  650.   160 CONTINUE
  651.       IF (LOBUF.NE.0) THEN
  652.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  653.           LOBUF = 0
  654.       END IF
  655.       RETURN
  656. C
  657. C--- IFUNC=17, Read cursor. --------------------------------------------
  658. C    (Not implemented: should not be called.)
  659. C
  660.   170 GOTO 900
  661. C
  662. C--- IFUNC=18, Erase alpha screen. -------------------------------------
  663. C    (Null operation: there is no alpha screen.)
  664. C
  665.   180 CONTINUE
  666.       RETURN
  667. C
  668. C--- IFUNC=19, Set line style. -----------------------------------------
  669. C    (Not implemented: should not be called.)
  670. C
  671.   190 GOTO 900
  672. C
  673. C--- IFUNC=20, Polygon fill. -------------------------------------------
  674. C
  675.   200 CONTINUE
  676.       IF (NPTS.EQ.0) THEN
  677.           NPTS = RBUF(1)
  678.           START = .TRUE.
  679.           RETURN
  680.       ELSE
  681.           NPTS = NPTS-1
  682.           I0 = NINT(RBUF(1))
  683.           J0 = NINT(RBUF(2))
  684.           IF (START) THEN
  685.               CALL GRFAO('# # BP', L, INSTR, I0, J0, 0, 0)
  686.               START = .FALSE.
  687.               LASTI = I0
  688.               LASTJ = J0
  689.           ELSE IF (NPTS.EQ.0) THEN
  690.               CALL GRFAO('# # EP', L, INSTR, (I0-LASTI), 
  691.      1                     (J0-LASTJ), 0, 0)
  692.               LASTI = -1
  693.               LASTJ = -1
  694.           ELSE
  695.               CALL GRFAO('# # LP', L, INSTR, (I0-LASTI), 
  696.      1                     (J0-LASTJ), 0, 0)
  697.               LASTI = I0
  698.               LASTJ = J0
  699.           END IF
  700.           BBXMIN = MIN(BBXMIN, I0-LW*5.0)
  701.           BBXMAX = MAX(BBXMAX, I0+LW*5.0)
  702.           BBYMIN = MIN(BBYMIN, J0-LW*5.0)
  703.           BBYMAX = MAX(BBYMAX, J0+LW*5.0)
  704.           GOTO 800
  705.       END IF
  706. C
  707. C--- IFUNC=21, Set color representation. -------------------------------
  708. C
  709.   210 CONTINUE
  710.       IF (COLOR) THEN
  711.           CI = RBUF(1)
  712.           RVALUE(CI) = RBUF(2)
  713.           GVALUE(CI) = RBUF(3)
  714.           BVALUE(CI) = RBUF(4)
  715.       ELSE
  716.           CI = RBUF(1)
  717.           RVALUE(CI) = 0.30*RBUF(2) + 0.59*RBUF(3) + 0.11*RBUF(4)
  718.           GVALUE(CI) = RVALUE(CI)
  719.           BVALUE(CI) = RVALUE(CI)
  720.       END IF
  721.       RETURN
  722. C
  723. C--- IFUNC=22, Set line width. -----------------------------------------
  724. C
  725.   220 CONTINUE
  726.       LW = NINT(RBUF(1))
  727.       CALL GRFAO('# SLW', L, INSTR, LW, 0, 0, 0)
  728.       LASTI = -1
  729.       GOTO 800
  730. C
  731. C--- IFUNC=23, Escape. -------------------------------------------------
  732. C
  733.   230 CONTINUE
  734.       IF (LOBUF.NE.0) THEN
  735. C         -- flush buffer first
  736.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  737.           LOBUF = 0
  738.       END IF
  739.       CALL GRPS02(IOERR, UNIT, CHR(:LCHR))
  740.       LASTI = -1
  741.       RETURN
  742. C
  743. C--- IFUNC=26, Image.---------------------------------------------------
  744. C
  745.   260 CONTINUE
  746.       N = RBUF(1)
  747.       IF (N.EQ.0) THEN
  748. C         -- First: setup for image
  749. C         -- Set clipping region (RBUF(2...5))
  750.           NXP = RBUF(2)
  751.           NYP = RBUF(3)
  752.           XORG = RBUF(4)
  753.           XLEN = RBUF(5) - RBUF(4)
  754.           YORG = RBUF(6) 
  755.           YLEN = RBUF(7) - RBUF(6)
  756.           BBXMIN = MIN(BBXMIN, RBUF(4), RBUF(5))
  757.           BBXMAX = MAX(BBXMAX, RBUF(4), RBUF(5))
  758.           BBYMIN = MIN(BBYMIN, RBUF(6), RBUF(7))
  759.           BBYMAX = MAX(BBYMAX, RBUF(6), RBUF(7))
  760. C      
  761.           CALL GRPS02(IOERR, UNIT, 'gsave newpath')
  762.           CALL GRFAO('# # moveto # 0 rlineto 0 # rlineto', L, INSTR,
  763.      :               XORG, YORG, XLEN, YLEN)
  764.           CALL GRPS02(IOERR, UNIT, INSTR(:L))
  765.           CALL GRFAO('# 0 rlineto closepath clip', L, INSTR, -XLEN,
  766.      :                0, 0, 0)
  767.           CALL GRPS02(IOERR, UNIT, INSTR(:L))
  768. C         -- 
  769.           CALL GRFAO('/picstr # string def', L, INSTR, NXP, 0, 0, 0)
  770.           CALL GRPS02(IOERR, UNIT, INSTR(:L))
  771.           CALL GRFAO('# # 8 [', L, INSTR, NXP, NYP, 0, 0)
  772.           CALL GRPS02(IOERR, UNIT, INSTR(:L))
  773.           WRITE (INSTR, '(6(1PE10.3, 1X), '']'')') (RBUF(I),I=8,13)
  774.           CALL GRPS02(IOERR, UNIT, INSTR(:67))
  775.           IF (COLOR) THEN
  776.               CALL GRPS02(IOERR, UNIT, 
  777.      :      '{currentfile picstr readhexstring pop} false 3 colorimage')
  778.           ELSE
  779.               CALL GRPS02(IOERR, UNIT, 
  780.      :      '{currentfile picstr readhexstring pop} image')
  781.           END IF
  782.       ELSE IF (N.EQ.-1) THEN
  783. C         -- Last: terminate image
  784.           CALL GRPS02(IOERR, UNIT, 'grestore')
  785.       ELSE 
  786. C         -- Middle: write N image pixels; each pixel uses 6 chars
  787. C            in INSTR, so N must be <= 20.
  788.           L = 0
  789.           KMAX = 1
  790.           IF (COLOR) KMAX = 3
  791.           DO 262 I=1,N
  792.               CI = RBUF(I+1)
  793.               RGB(1) = NINT(255.0*RVALUE(CI))
  794.               RGB(2) = NINT(255.0*GVALUE(CI))
  795.               RGB(3) = NINT(255.0*BVALUE(CI))
  796.               DO 261 K=1,KMAX
  797.                   HIGH = RGB(K)/16
  798.                   LOW  = RGB(K)-16*HIGH
  799.                   L = L+1
  800.                   INSTR(L:L) = HEXDIG(HIGH)
  801.                   L = L+1
  802.                   INSTR(L:L) = HEXDIG(LOW)
  803.  261          CONTINUE
  804.  262      CONTINUE
  805.           CALL GRPS02(IOERR, UNIT, INSTR(1:L))
  806.       END IF
  807.       RETURN
  808. C
  809. C--- IFUNC=28, Marker.--------------------------------------------------
  810. C
  811.   280 CONTINUE
  812.       NSYM = NINT(RBUF(1))
  813. C     -- Output code for this marker if necessary
  814.       IF (MARKER(NSYM).EQ.0) THEN
  815.           IF (LOBUF.GT.0) CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  816.           LOBUF = 0
  817.           CALL GRPS03(IOERR, NSYM, UNIT)
  818.           MARKER(NSYM) = 1
  819.       END IF
  820. C     -- Output scale factor
  821.       IF (RBUF(4).NE.MFAC) THEN
  822.           IF (LOBUF.GT.0) CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  823.           LOBUF = 0
  824.           MFAC = RBUF(4)
  825.           WRITE (INSTR, '(''/MFAC '',F10.3,'' def'')') MFAC
  826.           CALL GRPS02(IOERR, UNIT, INSTR(1:24))
  827.       END IF
  828. C     -- Output an instruction to draw one marker
  829.       I1 = NINT(RBUF(2))
  830.       J1 = NINT(RBUF(3))
  831.       CALL GRFAO('# # M#', L, INSTR, I1, J1, NSYM, 0)
  832.       LASTI = -1
  833.       BBXMIN = MIN(BBXMIN, I1-MFAC*RAD(NSYM))
  834.       BBXMAX = MAX(BBXMAX, I1+MFAC*RAD(NSYM))
  835.       BBYMIN = MIN(BBYMIN, J1-MFAC*RAD(NSYM))
  836.       BBYMAX = MAX(BBYMAX, J1+MFAC*RAD(NSYM))
  837.       GOTO 800
  838. C
  839. C--- IFUNC=29, Query color representation.------------------------------
  840. C
  841.  290  CONTINUE
  842.       CI = NINT(RBUF(1))
  843.       NBUF = 4
  844.       RBUF(2) = RVALUE(CI)
  845.       RBUF(3) = GVALUE(CI)
  846.       RBUF(4) = BVALUE(CI)
  847.       RETURN
  848. C
  849. C-----------------------------------------------------------------------
  850. C Buffer output if possible.
  851. C
  852.   800 IF ( (LOBUF+L+1). GT. 132) THEN
  853.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  854.           OBUF(1:L) = INSTR(1:L)
  855.           LOBUF = L
  856.       ELSE
  857.           IF (LOBUF.GT.1) THEN
  858.               LOBUF = LOBUF+1
  859.               OBUF(LOBUF:LOBUF) = ' '
  860.           END IF
  861.           OBUF(LOBUF+1:LOBUF+L) = INSTR(1:L)
  862.           LOBUF = LOBUF+L
  863.       END IF
  864.       RETURN
  865. C-----------------------------------------------------------------------
  866. C Error: unimplemented function.
  867. C
  868.   900 WRITE (MSG,
  869.      1  '(''Unimplemented function in PS device driver: '',I10)') IFUNC
  870.       CALL GRWARN(MSG)
  871.       NBUF = -1
  872.       RETURN
  873. C-----------------------------------------------------------------------
  874.       END
  875.  
  876. C*GRPS03 -- PGPLOT PostScript driver, marker support
  877. C+
  878.       SUBROUTINE GRPS03(IOERR, NSYM, UNIT)
  879.       INTEGER IOERR, NSYM, UNIT
  880. C
  881. C Write PostScript instructions for drawing graph marker number NSYM
  882. C on Fortran unit UNIT.
  883. C-----------------------------------------------------------------------
  884.       CHARACTER*80 T(6)
  885.       INTEGER I, N
  886. C
  887.       IF (NSYM.LT.0 .OR. NSYM.GT.31) RETURN
  888.       GOTO (100, 101, 102, 103, 104, 105, 106, 107, 108,
  889.      1      109, 110, 111, 112, 113, 114, 115, 116, 117,
  890.      2      118, 119, 120, 121, 122, 123, 124, 125, 126,
  891.      3      127, 128, 129, 130, 131) NSYM+1
  892. C
  893.   100 T(1)='/M0 {MB -6 -6 moveto 0 12 rlineto 12 0 rlineto'
  894.       T(2)='0 -12 rlineto closepath stroke ME} bind def'
  895.       N=2
  896.       GOTO 200
  897.   101 T(1)='/M1 {MB 0 0 1 FC ME} bind def'
  898.       N=1
  899.       GOTO 200
  900.   102 T(1)='/M2 {MB 0 7 moveto 0 -14 rlineto -7 0 moveto'
  901.       T(2)='14 0 rlineto stroke ME} bind def'
  902.       N=2
  903.       GOTO 200
  904.   103 T(1)='/M3 {MB 0 6 moveto 0 -6 lineto -5 3 moveto 5 -3 lineto'
  905.       T(2)='5 3 moveto -5 -3 lineto stroke ME} bind def'
  906.       N=2
  907.       GOTO 200
  908.   104 T(1)='/M4 {MB 0 0 7 CC ME} bind def'
  909.       N=1
  910.       GOTO 200
  911.   105 T(1)='/M5 {MB -5 -5 moveto 10 10 rlineto -5 5 moveto'
  912.       T(2)='10 -10 rlineto stroke ME} bind def'
  913.       N=2
  914.       GOTO 200
  915.   106 T(1)='/M6 {MB -6 -6 moveto 0 12 rlineto 12 0 rlineto'
  916.       T(2)='0 -12 rlineto closepath stroke ME} bind def'
  917.       N=2
  918.       GOTO 200
  919.   107 T(1)='/M7 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  920.       T(2)='stroke ME} bind def'
  921.       N=2
  922.       GOTO 200 
  923.   108 T(1)='/M8 {MB 0 7 moveto 0 -14 rlineto -7 0 moveto 14 0 rlineto'
  924.       T(2)='stroke 0 0 7 CC ME} bind def'
  925.       N=2
  926.       GOTO 200
  927.   109 T(1)='/M9 {MB 0 0 1 FC 0 0 7 CC ME} bind def'
  928.       N=1
  929.       GOTO 200
  930.   110 T(1)='/M10 {MB -9 9 moveto -8 7 lineto -7 3 lineto -7 -3 lineto'
  931.       T(2)='-8 -7 lineto -9 -9 lineto -7 -8 lineto -3 -7 lineto'
  932.       T(3)='3 -7 lineto 7 -8 lineto 9 -9 lineto 8 -7 lineto'
  933.       T(4)='7 -3 lineto 7 3 lineto 8 7 lineto 9 9 lineto 7 8 lineto'
  934.       T(5)='3 7 lineto -3 7 lineto  -7 8 lineto closepath stroke'
  935.       T(6)='ME} bind def'
  936.       N=6
  937.       GOTO 200
  938.   111 T(1)='/M11 {MB 0 10 moveto -6 0 lineto 0 -10 lineto 6 0 lineto'
  939.       T(2)='closepath stroke ME} bind def'
  940.       N=2
  941.       GOTO 200
  942.   112 T(1)='/M12 {MB 0 9 moveto -2 3 lineto -8 3 lineto -3 -1 lineto'
  943.       T(2)='-5 -7 lineto 0 -3 lineto 5 -7 lineto 3 -1 lineto 8 3'
  944.       T(3)='lineto 2 3 lineto closepath stroke ME} bind def'
  945.       N=3
  946.       GOTO 200
  947.   113 T(1)='/M13 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  948.       T(2)='fill ME} bind def'
  949.       N=2
  950.       GOTO 200
  951.   114 T(1)='/M14 {MB -2 6 moveto -2 2 lineto -6 2 lineto -6 -2 lineto'
  952.       T(2)='-2 -2 lineto -2 -6 lineto 2 -6 lineto 2 -2 lineto'
  953.       T(3)='6 -2 lineto 6 2 lineto 2 2 lineto 2 6 lineto closepath'
  954.       T(4)='stroke ME} bind def'
  955.       N=4
  956.       GOTO 200
  957.   115 T(1)='/M15 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  958.       T(2)='0 -8 moveto 7 4 lineto -7 4 lineto closepath stroke ME}'
  959.       T(3)='bind def'
  960.       N=3
  961.       GOTO 200
  962.   116 T(1)='/M16 {MB -4 -4 moveto 0 8 rlineto 8 0 rlineto 0 -8'
  963.       T(2)='rlineto closepath fill ME} bind def'
  964.       N=2
  965.       GOTO 200
  966.   117 T(1)='/M17 {MB 0 0 4.5 FC ME} bind def'
  967.       N=1
  968.       GOTO 200
  969.   118 T(1)='/M18 {MB 0 9 moveto -2 3 lineto -8 3 lineto -3 -1 lineto'
  970.       T(2)=' -5 -7 lineto 0 -3 lineto 5 -7 lineto 3 -1 lineto 8 3'
  971.       T(3)='lineto 2 3 lineto closepath fill ME} bind def'
  972.       N=3
  973.       GOTO 200
  974.   119 T(1)='/M19 {MB -12 -12 moveto 0 24 rlineto 24 0 rlineto 0 -24'
  975.       T(2)='rlineto closepath stroke ME} bind def'
  976.       N=2
  977.       GOTO 200
  978.   120 T(1)='/M20 {MB 0 0 2 CC ME} bind def'
  979.       N=1
  980.       GOTO 200
  981.   121 T(1)='/M21 {MB 0 0 4 CC ME} bind def'
  982.       N=1
  983.       GOTO 200
  984.   122 T(1)='/M22 {MB 0 0 5 CC ME} bind def'
  985.       N=1
  986.       GOTO 200
  987.   123 T(1)='/M23 {MB 0 0 7 CC ME} bind def'
  988.       N=1
  989.       GOTO 200
  990.   124 T(1)='/M24 {MB 0 0 11 CC ME} bind def'
  991.       N=1
  992.       GOTO 200
  993.   125 T(1)='/M25 {MB 0 0 17 CC ME} bind def'
  994.       N=1
  995.       GOTO 200
  996.   126 T(1)='/M26 {MB 0 0 22 CC ME} bind def'
  997.       N=1
  998.       GOTO 200
  999.   127 T(1)='/M27 {MB 0 0 41 CC ME} bind def'
  1000.       N=1
  1001.       GOTO 200
  1002.   128 T(1)='/M28 {MB -6 2 moveto -9 0 lineto -6 -2 lineto -3 5'
  1003.       T(2)='moveto -8 0 lineto -3 -5 lineto -8 0 moveto 9 0 lineto'
  1004.       T(3)='stroke ME} bind def'
  1005.       N=3
  1006.       GOTO 200
  1007.   129 T(1)='/M29 {MB 6 2 moveto 9 0 lineto 6 -2 lineto 3 5 moveto'
  1008.       T(2)='8 0 lineto 3 -5 lineto 8 0 moveto -9 0 lineto stroke ME}'
  1009.       T(3)='bind def'
  1010.       N=3
  1011.       GOTO 200
  1012.   130 T(1)='/M30 {MB 2 6 moveto 0 9 lineto -2 6 lineto 5 3 moveto'
  1013.       T(2)='0 8 lineto -5 3 lineto 0 8 moveto 0 -9 lineto stroke ME}'
  1014.       T(3)='bind def'
  1015.       N=3
  1016.       GOTO 200
  1017.   131 T(1)='/M31 {MB 2 -6 moveto 0 -9 lineto -2 -6 lineto 5 -3'
  1018.       T(2)='moveto 0 -8 lineto -5 -3 lineto 0 -8 moveto 0 9 lineto'
  1019.       T(3)='stroke ME} bind def'
  1020.       N=3
  1021.       GOTO 200
  1022. C
  1023.   200 DO 210 I=1,N
  1024.           CALL GRPS02(IOERR, UNIT, T(I))
  1025.   210 CONTINUE
  1026. C
  1027.       END
  1028.  
  1029. C*GRPS02 -- PGPLOT PostScript driver, copy buffer to file
  1030. C+
  1031.       SUBROUTINE GRPS02 (IER, UNIT, S)
  1032. C
  1033. C Support routine for PSdriver: write character string S on
  1034. C specified Fortran unit.
  1035. C
  1036. C Error handling: if IER is not 0 on input, the routine returns
  1037. C immediately. Otherwise IER receives the I/O status from the Fortran
  1038. C write (0 => success).
  1039. C-----------------------------------------------------------------------
  1040.       INTEGER IER, UNIT
  1041.       CHARACTER*(*) S
  1042. C
  1043.       IF (IER.EQ.0) THEN
  1044.           WRITE (UNIT, '(A)', IOSTAT=IER) S
  1045.           IF (IER.NE.0) CALL 
  1046.      1        GRWARN('++WARNING++ Error writing PostScript file')
  1047.       END IF
  1048. C-----------------------------------------------------------------------
  1049.       END
  1050.