home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / utilities / utilsp / pgplot / SYS_ARC / f77 / PSDriver < prev   
Encoding:
Text File  |  1994-02-27  |  25.6 KB  |  764 lines

  1. C*GRPS01 -- 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 Archimedes version 1994 Feb 24 - pgplot/ps default file name
  29. C                                  set Postscript file type
  30. C                                         D.J. Crennell (Fortran Friends)
  31. C
  32. C Supported device: 
  33. C   Any printer that accepts the PostScript page description language, 
  34. C   eg, the LaserWriter (Apple Computer, Inc.).
  35. C   PostScript is a trademark of Adobe Systems Incorporated.
  36. C
  37. C Device type code: 
  38. C   /PS (monochrome landscape mode, long edge of paper horizontal).
  39. C   /CPS (color landscape mode, long edge of paper horizontal).
  40. C   /VPS (monochrome portrait mode, short edge of paper horizontal).
  41. C   /VCPS (color portrait mode, short edge of paper horizontal).
  42. C
  43. C Default file name:
  44. C   pgplot.ps
  45. C
  46. C Default view surface dimensions:
  47. C   10.5 inches horizontal x  7.8 inches vertical (landscape mode),
  48. C    7.8 inches horizontal x 10.5 inches vertical (portrait mode).
  49. C   These dimensions can be changed with environment variables.
  50. C
  51. C Resolution:
  52. C   The driver uses coordinate increments of 0.001 inch, giving an
  53. C   ``apparent'' resolution of 1000 pixels/inch. The true resolution is
  54. C   device-dependent; eg, on an Apple LaserWriter it is 300 pixels/inch
  55. C   (in both dimensions). 
  56. C
  57. C Color capability (monochrome mode): 
  58. C   Color indices 0-255 are supported. Color index 0 is white (erase
  59. C   or background color), indices 1-13 are black, 14 is light grey,
  60. C   and 15 is dark grey. It is not possible to change the color
  61. C   representation.
  62. C
  63. C Color capability (color mode):
  64. C   Color indices 0-255 are supported. Color index 0 is white (erase
  65. C   or background color), index 1 is black, and indices 2-15 have the
  66. C   standard PGPLOT color assignments.
  67. C   It is possible to change the color representation using PGSCR.
  68. C
  69. C Input capability: none.
  70. C
  71. C File format: the file contains variable length records (maximum 132
  72. C characters) containing PostScript commands. The commands use only
  73. C printable ASCII characters, and the file can be examined or modified 
  74. C with a text editor. 
  75. C
  76. C Obtaining hardcopy: use the operating system print or copy command to
  77. C send the file to a suitable device.
  78. C
  79. C Environment variables:
  80. C
  81. C  PGPLOT_PS_WIDTH      default  7800
  82. C  PGPLOT_PS_HEIGHT     default 10500
  83. C  PGPLOT_PS_HOFFSET    default   350
  84. C  PGPLOT_PS_VOFFSET    default   250
  85. C These variables tell PGPLOT how big an image to produce. The defaults
  86. C are appropriate for 8.5 x 11-inch paper. The maximum dimensions of
  87. C a PGPLOT image are WIDTH by HEIGHT, with the lower left corner offset
  88. C by HOFFSET horizontally and VOFFSET vertically from the lower left
  89. C corner of the paper. The units are milli-inches. The "top" of the
  90. C paper is the edge that comes out of the printer first.
  91. C
  92. C  PGPLOT_PS_EOF
  93. C Normally the output file does not contain special end-of-file
  94. C characters. But if environment variable PGPLOT_PS_EOF is defined
  95. C (with any value) PGPLOT writes a control-D job-separator character at 
  96. C the beginning and at the end of the file. This is appropriate for
  97. C Apple LaserWriters using the serial interface, but it may not be 
  98. C appropriate for other PostScript devices.
  99. C
  100. C Document Structuring Conventions:
  101. C
  102. C  The PostScript files conform to Version 3.0 of the Adobe Document 
  103. C  Structuring Conventions (see ref.3) and to version 3.0 of the
  104. C  encapsulated PostScript file (EPSF) format. This should allow
  105. C  the files to be read by other programs that accept the EPSF format.
  106. C  Note, though, that multi-page plots are not valid EPSF files. The
  107. C  files do not contain a screen preview section.
  108. C
  109. C References:
  110. C
  111. C (1) Adobe Systems, Inc.: PostScript Language Reference Manual.
  112. C Addison-Wesley, Reading, Massachusetts, 1985.
  113. C (2) Adobe Systems, Inc.: PostScript Language Tutorial and Cookbook.
  114. C Addison-Wesley, Reading, Massachusetts, 1985.
  115. C (3) Adobe Systems, Inc.: PostScript Language Reference Manual, Second 
  116. C Edition. Addison-Wesley, Reading, Massachusetts, 1990.
  117. C-----------------------------------------------------------------------
  118.       INTEGER DWD, DHT, DOFFW, DOFFH
  119.       CHARACTER*(*) PTYPE, LTYPE, CPTYPE, CLTYPE, DEFNAM
  120.       PARAMETER (
  121.      : PTYPE= 'VPS   (PostScript file, portrait orientation)',
  122.      : LTYPE= 'PS    (PostScript file, landscape orientation)',
  123.      : CPTYPE='VCPS  (Colour PostScript file, portrait orientation)',
  124.      : CLTYPE='CPS   (Colour PostScript file, landscape orientation)')
  125. C     PARAMETER (PTYPE='VPS', LTYPE='PS', CPTYPE='VCPS', CLTYPE='CPS')
  126.       PARAMETER (DEFNAM='pgplot/ps')
  127. C -- printable paper area: in milli-inches; (WIDTH, HEIGHT) are
  128. C    the dimensions of the printable area; OFFW, OFFH the offset from
  129. C    the lower left corner of the paper
  130.       PARAMETER (DWD=7800, DHT=10500, DOFFW=350, DOFFH=250)
  131. C
  132.       INTEGER WIDTH, HEIGHT, OFFW, OFFH
  133.       SAVE    WIDTH, HEIGHT, OFFW, OFFH
  134.       INTEGER  IER, I0, J0, I1, J1, L, LASTI, LASTJ, UNIT, LOBUF
  135.       SAVE                             LASTI, LASTJ, UNIT, LOBUF
  136.       INTEGER  CI, LW, NPTS, NPAGE, JUNK, IOERR, LFNAME
  137.       SAVE             NPTS, NPAGE,       IOERR, LFNAME
  138.       INTEGER  GROPTX
  139.       LOGICAL  START, LANDSC, COLOR
  140.       SAVE     START,         COLOR
  141.       REAL RVALUE(0:255), GVALUE(0:255), BVALUE(0:255)
  142.       SAVE RVALUE,       GVALUE,       BVALUE
  143.       CHARACTER*80  INSTR, MSG
  144.       CHARACTER*132 OBUF
  145.       SAVE          OBUF
  146.       CHARACTER*255 FNAME
  147.       SAVE          FNAME
  148.       INTEGER       MARKER(0:31), NSYM
  149.       SAVE          MARKER
  150.       REAL          MFAC
  151.       SAVE          MFAC
  152.       CHARACTER*4   SHADE(0:255)
  153.       SAVE          SHADE
  154. C              opened file name
  155.       CHARACTER*30  OPFILE
  156.       SAVE          OPFILE
  157.       DATA SHADE /'1.00', 13*'0.00', '0.67', '0.33', 240*'0.00'/
  158.       DATA RVALUE 
  159.      1     / 1.00, 0.00, 1.00, 0.00, 0.00, 0.00, 1.00, 1.00,
  160.      2       1.00, 0.50, 0.00, 0.00, 0.50, 1.00, 0.33, 0.67,
  161.      3       240*0.00 /
  162.       DATA GVALUE
  163.      1     / 1.00, 0.00, 0.00, 1.00, 0.00, 1.00, 0.00, 1.00,
  164.      2       0.50, 1.00, 1.00, 0.50, 0.00, 0.00, 0.33, 0.67,
  165.      3       240*0.00 /
  166.       DATA BVALUE
  167.      1     / 1.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 0.00,
  168.      2       0.00, 0.00, 0.50, 1.00, 1.00, 0.50, 0.33, 0.67,
  169.      3       240*0.00 /
  170. C-----------------------------------------------------------------------
  171. C
  172.       GOTO( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
  173.      1     110,120,130,140,150,160,170,180,190,200,
  174.      2     210,220,230,900,900,900,900,280), IFUNC
  175.       GOTO 900
  176. C
  177. C--- IFUNC = 1, Return device name.-------------------------------------
  178. C
  179.    10 IF (MODE.EQ.1) THEN
  180. C         -- landscape, monochrome
  181.           CHR = LTYPE
  182.           LCHR = LEN(LTYPE)
  183.       ELSE IF (MODE.EQ.2) THEN
  184. C         -- portrait, monochrome
  185.           CHR = PTYPE
  186.           LCHR = LEN(PTYPE)
  187.       ELSE IF (MODE.EQ.3) THEN
  188. C         -- landscape, color
  189.           CHR = CLTYPE
  190.           LCHR = LEN(CLTYPE)
  191.       ELSE
  192. C         -- portrait, color
  193.           CHR = CPTYPE
  194.           LCHR = LEN(CPTYPE)
  195.       END IF
  196.       RETURN
  197. C
  198. C--- IFUNC = 2, Return physical min and max for plot device, and range
  199. C               of color indices.---------------------------------------
  200. C
  201.    20 RBUF(1) = 0
  202.       RBUF(3) = 0
  203.       RBUF(5) = 0
  204.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  205.       IF (LANDSC) THEN
  206.           RBUF(2) = HEIGHT-1
  207.           RBUF(4) = WIDTH-1
  208.       ELSE
  209.           RBUF(2) = WIDTH-1
  210.           RBUF(4) = HEIGHT-1
  211.       END IF
  212.       RBUF(6) = 255
  213.       NBUF = 6
  214.       RETURN
  215. C
  216. C--- IFUNC = 3, Return device resolution. ------------------------------
  217. C
  218.    30 RBUF(1) = 1000.0
  219.       RBUF(2) = 1000.0
  220.       RBUF(3) = 5
  221.       NBUF = 3
  222.       RETURN
  223. C
  224. C--- IFUNC = 4, Return misc device info. -------------------------------
  225. C    (This device is Hardcopy, No cursor, No dashed lines, Area fill, 
  226. C    Thick lines, Markers)
  227. C
  228.    40 CHR = 'HNNATNNNNM'
  229.       LCHR = 10
  230.       RETURN
  231. C
  232. C--- IFUNC = 5, Return default file name. ------------------------------
  233. C
  234.    50 CHR = DEFNAM
  235.       LCHR = LEN(DEFNAM)
  236.       RETURN
  237. C
  238. C--- IFUNC = 6, Return default physical size of plot. ------------------
  239. C
  240.    60 RBUF(1) = 0
  241.       RBUF(3) = 0
  242.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  243.       IF (LANDSC) THEN
  244.           RBUF(2) = HEIGHT-1
  245.           RBUF(4) = WIDTH-1
  246.       ELSE
  247.           RBUF(2) = WIDTH-1
  248.           RBUF(4) = HEIGHT-1
  249.       END IF
  250.       NBUF = 4
  251.       RETURN
  252. C
  253. C--- IFUNC = 7, Return misc defaults. ----------------------------------
  254. C
  255.    70 RBUF(1) = 8
  256.       NBUF = 1
  257.       RETURN
  258. C
  259. C--- IFUNC = 8, Select plot. -------------------------------------------
  260. C
  261.    80 CONTINUE
  262.       RETURN
  263. C
  264. C--- IFUNC = 9, Open workstation. --------------------------------------
  265. C
  266.    90 CONTINUE
  267. C     -- Color mode?
  268.       CALL GRGENV('PS_COLOR', INSTR, L)
  269.       COLOR = L.GT.0 .OR. MODE.EQ.3 .OR. MODE.EQ.4
  270. C     -- Device dimensions
  271.       WIDTH = DWD
  272.       HEIGHT = DHT
  273.       OFFW = DOFFW
  274.       OFFH = DOFFH
  275.       CALL GRGENV('PS_WIDTH', INSTR, L)
  276.       IF (L.GT.0) READ(INSTR(:L),'(BN,I10)',IOSTAT=JUNK) WIDTH
  277.       CALL GRGENV('PS_HEIGHT', INSTR, L)
  278.       IF (L.GT.0) READ(INSTR(:L),'(BN,I10)',IOSTAT=JUNK) HEIGHT
  279.       CALL GRGENV('PS_HOFFSET', INSTR, L)
  280.       IF (L.GT.0) READ(INSTR(:L),'(BN,I10)',IOSTAT=JUNK) OFFW
  281.       CALL GRGENV('PS_VOFFSET', INSTR, L)
  282.       IF (L.GT.0) READ(INSTR(:L),'(BN,I10)',IOSTAT=JUNK) OFFH
  283.       CALL GRGLUN(UNIT)   
  284.       NBUF = 2
  285.       RBUF(1) = UNIT
  286.       OPFILE = CHR(1:LCHR)
  287.       IER = GROPTX(UNIT, CHR(1:LCHR), DEFNAM, 1)
  288.       IF (IER.NE.0) THEN
  289.           MSG = 'Cannot open output file for PostScript plot: '//
  290.      1                CHR(:LCHR)
  291.           CALL GRWARN(MSG)
  292.           RBUF(2) = 0
  293.           CALL GRFLUN(UNIT)
  294.           RETURN
  295.       ELSE
  296.           INQUIRE (UNIT=UNIT, NAME=CHR)
  297.           LCHR = LEN(CHR)
  298.    91     IF (CHR(LCHR:LCHR).EQ.' ') THEN
  299.               LCHR = LCHR-1
  300.               GOTO 91
  301.           END IF
  302.           RBUF(2) = 1
  303.           FNAME = CHR(:LCHR)
  304.           LFNAME = LCHR
  305.       END IF
  306.       IOERR = 0
  307.       LOBUF = 0
  308.       LASTI = -1
  309.       LASTJ = - 1
  310.       NPTS = 0
  311.       CALL GRGENV('PS_EOF', INSTR, L)
  312.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, CHAR(4))
  313.       CALL GRPS02(IOERR, UNIT, '%!PS-Adobe-3.0 EPSF-3.0')
  314.       CALL GRUSER(INSTR, L)
  315.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, '%%For: '//INSTR(1:L))
  316.       CALL GRPS02(IOERR, UNIT, '%%Title: PGPLOT PostScript plot')
  317.       CALL GRPS02(IOERR, UNIT, '%%Creator: PGPLOT')
  318.       CALL GRDATE(INSTR, L)
  319.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT,
  320.      :    '%%CreationDate: '//INSTR(1:L))
  321. C -- bounding box is based on maximum plot dimensions, not
  322. C    actual dimensions
  323.       CALL GRFAO('%%BoundingBox: # # # #', L, INSTR,
  324.      1   NINT(OFFW*0.072), NINT(OFFH*0.072), NINT((WIDTH+OFFW)*0.072), 
  325.      2   NINT((HEIGHT+OFFH)*0.072))
  326.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  327.       CALL GRPS02(IOERR, UNIT, '%%DocumentFonts: (atend)')
  328.       CALL GRPS02(IOERR, UNIT, '%%LanguageLevel: 1')
  329.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  330.       IF (LANDSC) THEN
  331.           CALL GRPS02(IOERR, UNIT, '%%Orientation: Landscape')
  332.       ELSE
  333.           CALL GRPS02(IOERR, UNIT, '%%Orientation: Portrait')
  334.       END IF
  335.       CALL GRPS02(IOERR, UNIT, '%%Pages: (atend)')
  336.       CALL GRPS02(IOERR, UNIT, '%%EndComments')
  337.       CALL GRPS02(IOERR, UNIT, '%%BeginProlog')
  338.       CALL GRPS02(IOERR, UNIT, 
  339.      1  '/l {moveto rlineto currentpoint stroke moveto} bind def')
  340.       CALL GRPS02(IOERR, UNIT, 
  341.      1  '/c {rlineto currentpoint stroke moveto} bind def')
  342.       CALL GRPS02(IOERR, UNIT, 
  343.      1  '/d {moveto 0 0 rlineto currentpoint stroke moveto} bind def')
  344.       CALL GRPS02(IOERR, UNIT, '/SLW {5 mul setlinewidth} bind def')
  345.       CALL GRPS02(IOERR, UNIT, '/SCF /pop load def')
  346.       CALL GRPS02(IOERR, UNIT, '/BP {newpath moveto} bind def')
  347.       CALL GRPS02(IOERR, UNIT, '/LP /rlineto load def')
  348.       CALL GRPS02(IOERR, UNIT, 
  349.      1  '/EP {rlineto closepath eofill} bind def')
  350.       CALL GRPS02(IOERR, UNIT, '/MB {gsave translate MFAC dup scale '//
  351.      1 '1 setlinewidth 2 setlinecap 0 setlinejoin newpath} bind def')
  352.       CALL GRPS02(IOERR, UNIT, '/ME /grestore load def')
  353.       CALL GRPS02(IOERR, UNIT, '/C {0 360 arc stroke} bind def')
  354.       CALL GRPS02(IOERR, UNIT, '/FC {0 360 arc fill} bind def')
  355.       CALL GRPS02(IOERR, UNIT, '%%EndProlog')
  356.       NPAGE = 0
  357.       RETURN
  358. C
  359. C--- IFUNC=10, Close workstation. --------------------------------------
  360. C
  361.   100 CONTINUE
  362.       CALL GRPS02(IOERR, UNIT, ' ')
  363.       CALL GRPS02(IOERR, UNIT, '%%Trailer')
  364.       CALL GRPS02(IOERR, UNIT, '%%DocumentFonts: ')
  365.       CALL GRFAO('%%Pages: #', L, INSTR, NPAGE, 0, 0, 0)
  366.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  367.       CALL GRPS02(IOERR, UNIT, '%%EOF')
  368.       CALL GRGENV('PS_EOF', INSTR, L)
  369.       IF (L.GT.0) CALL GRPS02(IOERR, UNIT, CHAR(4))
  370.       IF (IOERR.NE.0) THEN
  371.           CALL GRWARN('++WARNING++ Error '//
  372.      1       'writing PostScript file: file is incomplete')
  373.           CALL GRWARN('Check for device full or quota exceeded')
  374.           CALL GRWARN('Filename: '//FNAME(:LFNAME))
  375.       END IF      
  376.       CLOSE (UNIT, IOSTAT=IOERR)
  377.       IF (IOERR.NE.0) CALL GRWARN('Error closing PostScript file '//
  378.      :                            FNAME(:LFNAME))
  379.       CALL GRFLUN(UNIT)
  380.       CALL OSCLI('SETTYPE '//OPFILE//' FF5')
  381.       RETURN
  382. C
  383. C--- IFUNC=11, Begin picture. ------------------------------------------
  384. C
  385.   110 CONTINUE
  386.       NPAGE = NPAGE+1
  387.       CALL GRPS02(IOERR, UNIT, ' ')
  388.       CALL GRFAO('%%Page: # #', L, INSTR, NPAGE, NPAGE, 0, 0)
  389.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  390.       CALL GRPS02(IOERR, UNIT, '%%BeginPageSetup')
  391.       CALL GRPS02(IOERR, UNIT, '/PGPLOT save def')
  392.       CALL GRPS02(IOERR, UNIT, '0.072 0.072 scale')
  393.       LANDSC = MODE.EQ.1 .OR. MODE.EQ.3
  394.       IF (LANDSC) THEN
  395.           CALL GRFAO('# # translate 90 rotate', L, INSTR, WIDTH+OFFW, 
  396.      1               OFFH, 0, 0)
  397.       ELSE
  398.           CALL GRFAO('# # translate', L, INSTR, OFFW, OFFH, 0, 0)
  399.       END IF
  400.       CALL GRPS02(IOERR, UNIT, INSTR(:L))
  401.       CALL GRPS02(IOERR, UNIT, '1 setlinejoin 1 setlinecap 1 SLW 1 SCF')
  402.       CALL GRPS02(IOERR, UNIT, '%%EndPageSetup')
  403.       DO 111 NSYM=0,31
  404.           MARKER(NSYM) = 0
  405.   111 CONTINUE
  406.       MFAC = 0.0
  407.       RETURN
  408. C
  409. C--- IFUNC=12, Draw line. ----------------------------------------------
  410. C
  411.   120 CONTINUE
  412.       I0 = NINT(RBUF(1))
  413.       J0 = NINT(RBUF(2))
  414.       I1 = NINT(RBUF(3))
  415.       J1 = NINT(RBUF(4))
  416.       IF (I0.EQ.LASTI .AND. J0.EQ.LASTJ) THEN
  417.           CALL GRFAO('# # c', L, INSTR, (I1-I0), (J1-J0), 0, 0)
  418.       ELSE
  419.           CALL GRFAO('# # # # l', L, INSTR, (I1-I0), (J1-J0), I0, J0)
  420.       END IF
  421.       LASTI = I1
  422.       LASTJ = J1
  423.       GOTO 800
  424. C
  425. C--- IFUNC=13, Draw dot. -----------------------------------------------
  426. C
  427.   130 CONTINUE
  428.       I1 = NINT(RBUF(1))
  429.       J1 = NINT(RBUF(2))
  430.       CALL GRFAO('# # d', L, INSTR, I1, J1, 0, 0)
  431.       LASTI = I1
  432.       LASTJ = J1
  433.       GOTO 800
  434. C
  435. C--- IFUNC=14, End picture. --------------------------------------------
  436. C
  437.   140 CONTINUE
  438.       IF (LOBUF.NE.0) THEN
  439.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  440.           LOBUF = 0
  441.       END IF
  442.       CALL GRPS02(IOERR, UNIT, 'showpage PGPLOT restore')
  443.       RETURN
  444. C
  445. C--- IFUNC=15, Select color index. -------------------------------------
  446. C
  447.   150 CONTINUE
  448.       CI = NINT(RBUF(1))
  449.       IF (COLOR) THEN
  450.           WRITE(INSTR,'(3(F5.3,1X),''setrgbcolor'')')
  451.      1          RVALUE(CI), GVALUE(CI), BVALUE(CI)
  452.           L = 29
  453.       ELSE
  454.           INSTR = SHADE(CI)//' setgray'
  455.           L = LEN(SHADE(CI))+8
  456.       END IF
  457.       LASTI = -1
  458.       GOTO 800
  459. C
  460. C--- IFUNC=16, Flush buffer. -------------------------------------------
  461. C
  462.   160 CONTINUE
  463.       IF (LOBUF.NE.0) THEN
  464.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  465.           LOBUF = 0
  466.       END IF
  467.       RETURN
  468. C
  469. C--- IFUNC=17, Read cursor. --------------------------------------------
  470. C    (Not implemented: should not be called.)
  471. C
  472.   170 GOTO 900
  473. C
  474. C--- IFUNC=18, Erase alpha screen. -------------------------------------
  475. C    (Null operation: there is no alpha screen.)
  476. C
  477.   180 CONTINUE
  478.       RETURN
  479. C
  480. C--- IFUNC=19, Set line style. -----------------------------------------
  481. C    (Not implemented: should not be called.)
  482. C
  483.   190 GOTO 900
  484. C
  485. C--- IFUNC=20, Polygon fill. -------------------------------------------
  486. C
  487.   200 CONTINUE
  488.       IF (NPTS.EQ.0) THEN
  489.           NPTS = RBUF(1)
  490.           START = .TRUE.
  491.           RETURN
  492.       ELSE
  493.           NPTS = NPTS-1
  494.           I0 = NINT(RBUF(1))
  495.           J0 = NINT(RBUF(2))
  496.           IF (START) THEN
  497.               CALL GRFAO('# # BP', L, INSTR, I0, J0, 0, 0)
  498.               START = .FALSE.
  499.               LASTI = I0
  500.               LASTJ = J0
  501.           ELSE IF (NPTS.EQ.0) THEN
  502.               CALL GRFAO('# # EP', L, INSTR, (I0-LASTI), 
  503.      1                     (J0-LASTJ), 0, 0)
  504.               LASTI = -1
  505.               LASTJ = -1
  506.           ELSE
  507.               CALL GRFAO('# # LP', L, INSTR, (I0-LASTI), 
  508.      1                     (J0-LASTJ), 0, 0)
  509.               LASTI = I0
  510.               LASTJ = J0
  511.           END IF
  512.           GOTO 800
  513.       END IF
  514. C
  515. C--- IFUNC=21, Set color representation. -------------------------------
  516. C
  517.   210 CONTINUE
  518.       IF (COLOR) THEN
  519.           CI = RBUF(1)
  520.           RVALUE(CI) = RBUF(2)
  521.           GVALUE(CI) = RBUF(3)
  522.           BVALUE(CI) = RBUF(4)
  523.       END IF
  524.       RETURN
  525. C
  526. C--- IFUNC=22, Set line width. -----------------------------------------
  527. C
  528.   220 CONTINUE
  529.       LW = NINT(RBUF(1))
  530.       CALL GRFAO('# SLW', L, INSTR, LW, 0, 0, 0)
  531.       LASTI = -1
  532.       GOTO 800
  533. C
  534. C--- IFUNC=23, Escape. -------------------------------------------------
  535. C
  536.   230 CONTINUE
  537.       CALL GRPS02(IOERR, UNIT, CHR(:LCHR))
  538.       LASTI = -1
  539.       RETURN
  540. C
  541. C--- IFUNC=28, Marker.--------------------------------------------------
  542. C
  543.   280 CONTINUE
  544.       NSYM = NINT(RBUF(1))
  545. C     -- Output code for this marker if necessary
  546.       IF (MARKER(NSYM).EQ.0) THEN
  547.           IF (LOBUF.GT.0) CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  548.           LOBUF = 0
  549.           CALL GRPS03(IOERR, NSYM, UNIT)
  550.           MARKER(NSYM) = 1
  551.       END IF
  552. C     -- Output scale factor
  553.       IF (RBUF(4).NE.MFAC) THEN
  554.           IF (LOBUF.GT.0) CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  555.           LOBUF = 0
  556.           MFAC = RBUF(4)
  557.           WRITE (INSTR, '(''/MFAC '',F10.3,'' def'')') MFAC
  558.           CALL GRPS02(IOERR, UNIT, INSTR(1:24))
  559.       END IF
  560. C     -- Output an instruction to draw one marker
  561.       I1 = NINT(RBUF(2))
  562.       J1 = NINT(RBUF(3))
  563.       CALL GRFAO('# # M#', L, INSTR, I1, J1, NSYM, 0)
  564.       LASTI = -1
  565.       GOTO 800
  566. C-----------------------------------------------------------------------
  567. C Buffer output if possible.
  568. C
  569.   800 IF ( (LOBUF+L+1). GT. 132) THEN
  570.           CALL GRPS02(IOERR, UNIT, OBUF(1:LOBUF))
  571.           OBUF(1:L) = INSTR(1:L)
  572.           LOBUF = L
  573.       ELSE
  574.           IF (LOBUF.GT.1) THEN
  575.               LOBUF = LOBUF+1
  576.               OBUF(LOBUF:LOBUF) = ' '
  577.           END IF
  578.           OBUF(LOBUF+1:LOBUF+L) = INSTR(1:L)
  579.           LOBUF = LOBUF+L
  580.       END IF
  581.       RETURN
  582. C-----------------------------------------------------------------------
  583. C Error: unimplemented function.
  584. C
  585.   900 WRITE (MSG,
  586.      1  '(''Unimplemented function in PS device driver: '',I10)') IFUNC
  587.       CALL GRWARN(MSG)
  588.       NBUF = -1
  589.       RETURN
  590. C-----------------------------------------------------------------------
  591.       END
  592.  
  593.       SUBROUTINE GRPS03(IOERR, NSYM, UNIT)
  594.       INTEGER IOERR, NSYM, UNIT
  595. C
  596. C Write PostScript instructions for drawing graph marker number NSYM
  597. C on Fortran unit UNIT.
  598. C-----------------------------------------------------------------------
  599.       CHARACTER*80 T(6)
  600.       INTEGER I, N
  601. C
  602.       IF (NSYM.LT.0 .OR. NSYM.GT.31) RETURN
  603.       GOTO (100, 101, 102, 103, 104, 105, 106, 107, 108,
  604.      1      109, 110, 111, 112, 113, 114, 115, 116, 117,
  605.      2      118, 119, 120, 121, 122, 123, 124, 125, 126,
  606.      3      127, 128, 129, 130, 131) NSYM+1
  607. C
  608.   100 T(1)='/M0 {MB -6 -6 moveto 0 12 rlineto 12 0 rlineto'
  609.       T(2)='0 -12 rlineto closepath stroke ME} bind def'
  610.       N=2
  611.       GOTO 200
  612.   101 T(1)='/M1 {MB 0 0 1 FC ME} bind def'
  613.       N=1
  614.       GOTO 200
  615.   102 T(1)='/M2 {MB 0 7 moveto 0 -14 rlineto -7 0 moveto'
  616.       T(2)='14 0 rlineto stroke ME} bind def'
  617.       N=2
  618.       GOTO 200
  619.   103 T(1)='/M3 {MB 0 6 moveto 0 -6 lineto -5 3 moveto 5 -3 lineto'
  620.       T(2)='5 3 moveto -5 -3 lineto stroke ME} bind def'
  621.       N=2
  622.       GOTO 200
  623.   104 T(1)='/M4 {MB 0 0 7 C ME} bind def'
  624.       N=1
  625.       GOTO 200
  626.   105 T(1)='/M5 {MB -5 -5 moveto 10 10 rlineto -5 5 moveto'
  627.       T(2)='10 -10 rlineto stroke ME} bind def'
  628.       N=2
  629.       GOTO 200
  630.   106 T(1)='/M6 {MB -6 -6 moveto 0 12 rlineto 12 0 rlineto'
  631.       T(2)='0 -12 rlineto closepath stroke ME} bind def'
  632.       N=2
  633.       GOTO 200
  634.   107 T(1)='/M7 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  635.       T(2)='stroke ME} bind def'
  636.       N=2
  637.       GOTO 200 
  638.   108 T(1)='/M8 {MB 0 7 moveto 0 -14 rlineto -7 0 moveto 14 0 rlineto'
  639.       T(2)='stroke 0 0 7 C ME} bind def'
  640.       N=2
  641.       GOTO 200
  642.   109 T(1)='/M9 {MB 0 0 1 FC 0 0 7 C ME} bind def'
  643.       N=1
  644.       GOTO 200
  645.   110 T(1)='/M10 {MB -9 9 moveto -8 7 lineto -7 3 lineto -7 -3 lineto'
  646.       T(2)='-8 -7 lineto -9 -9 lineto -7 -8 lineto -3 -7 lineto'
  647.       T(3)='3 -7 lineto 7 -8 lineto 9 -9 lineto 8 -7 lineto'
  648.       T(4)='7 -3 lineto 7 3 lineto 8 7 lineto 9 9 lineto 7 8 lineto'
  649.       T(5)='3 7 lineto -3 7 lineto  -7 8 lineto closepath stroke'
  650.       T(6)='ME} bind def'
  651.       N=6
  652.       GOTO 200
  653.   111 T(1)='/M11 {MB 0 10 moveto -6 0 lineto 0 -10 lineto 6 0 lineto'
  654.       T(2)='closepath stroke ME} bind def'
  655.       N=2
  656.       GOTO 200
  657.   112 T(1)='/M12 {MB 0 9 moveto -2 3 lineto -8 3 lineto -3 -1 lineto'
  658.       T(2)='-5 -7 lineto 0 -3 lineto 5 -7 lineto 3 -1 lineto 8 3'
  659.       T(3)='lineto 2 3 lineto closepath stroke ME} bind def'
  660.       N=3
  661.       GOTO 200
  662.   113 T(1)='/M13 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  663.       T(2)='fill ME} bind def'
  664.       N=2
  665.       GOTO 200
  666.   114 T(1)='/M14 {MB -2 6 moveto -2 2 lineto -6 2 lineto -6 -2 lineto'
  667.       T(2)='-2 -2 lineto -2 -6 lineto 2 -6 lineto 2 -2 lineto'
  668.       T(3)='6 -2 lineto 6 2 lineto 2 2 lineto 2 6 lineto closepath'
  669.       T(4)='stroke ME} bind def'
  670.       N=4
  671.       GOTO 200
  672.   115 T(1)='/M15 {MB 0 8 moveto -7 -4 lineto 7 -4 lineto closepath'
  673.       T(2)='0 -8 moveto 7 4 lineto -7 4 lineto closepath stroke ME}'
  674.       T(3)='bind def'
  675.       N=3
  676.       GOTO 200
  677.   116 T(1)='/M16 {MB -4 -4 moveto 0 8 rlineto 8 0 rlineto 0 -8'
  678.       T(2)='rlineto closepath fill ME} bind def'
  679.       N=2
  680.       GOTO 200
  681.   117 T(1)='/M17 {MB 0 0 4.5 FC ME} bind def'
  682.       N=1
  683.       GOTO 200
  684.   118 T(1)='/M18 {MB 0 9 moveto -2 3 lineto -8 3 lineto -3 -1 lineto'
  685.       T(2)=' -5 -7 lineto 0 -3 lineto 5 -7 lineto 3 -1 lineto 8 3'
  686.       T(3)='lineto 2 3 lineto closepath fill ME} bind def'
  687.       N=3
  688.       GOTO 200
  689.   119 T(1)='/M19 {MB -12 -12 moveto 0 24 rlineto 24 0 rlineto 0 -24'
  690.       T(2)='rlineto closepath stroke ME} bind def'
  691.       N=2
  692.       GOTO 200
  693.   120 T(1)='/M20 {MB 0 0 2 C ME} bind def'
  694.       N=1
  695.       GOTO 200
  696.   121 T(1)='/M21 {MB 0 0 4 C ME} bind def'
  697.       N=1
  698.       GOTO 200
  699.   122 T(1)='/M22 {MB 0 0 5 C ME} bind def'
  700.       N=1
  701.       GOTO 200
  702.   123 T(1)='/M23 {MB 0 0 7 C ME} bind def'
  703.       N=1
  704.       GOTO 200
  705.   124 T(1)='/M24 {MB 0 0 11 C ME} bind def'
  706.       N=1
  707.       GOTO 200
  708.   125 T(1)='/M25 {MB 0 0 17 C ME} bind def'
  709.       N=1
  710.       GOTO 200
  711.   126 T(1)='/M26 {MB 0 0 22 C ME} bind def'
  712.       N=1
  713.       GOTO 200
  714.   127 T(1)='/M27 {MB 0 0 41 C ME} bind def'
  715.       GOTO 200
  716.   128 T(1)='/M28 {MB -6 2 moveto -9 0 lineto -6 -2 lineto -3 5'
  717.       T(2)='moveto -8 0 lineto -3 -5 lineto -8 0 moveto 9 0 lineto'
  718.       T(3)='stroke ME} bind def'
  719.       N=3
  720.       GOTO 200
  721.   129 T(1)='/M29 {MB 6 2 moveto 9 0 lineto 6 -2 lineto 3 5 moveto'
  722.       T(2)='8 0 lineto 3 -5 lineto 8 0 moveto -9 0 lineto stroke ME}'
  723.       T(3)='bind def'
  724.       N=3
  725.       GOTO 200
  726.   130 T(1)='/M30 {MB 2 6 moveto 0 9 lineto -2 6 lineto 5 3 moveto'
  727.       T(2)='0 8 lineto -5 3 lineto 0 8 moveto 0 -9 lineto stroke ME}'
  728.       T(3)='bind def'
  729.       N=3
  730.       GOTO 200
  731.   131 T(1)='/M31 {MB 2 -6 moveto 0 -9 lineto -2 -6 lineto 5 -3'
  732.       T(2)='moveto 0 -8 lineto -5 -3 lineto 0 -8 moveto 0 9 lineto'
  733.       T(3)='stroke ME} bind def'
  734.       N=3
  735.       GOTO 200
  736. C
  737.   200 DO 210 I=1,N
  738.           CALL GRPS02(IOERR, UNIT, T(I))
  739.   210 CONTINUE
  740. C
  741.       END
  742.  
  743. C*GRPS02 -- PGPLOT PostScript driver, copy buffer to file
  744. C+
  745.       SUBROUTINE GRPS02 (IER, UNIT, S)
  746. C
  747. C Support routine for PSdriver: write character string S on
  748. C specified Fortran unit.
  749. C
  750. C Error handling: if IER is not 0 on input, the routine returns
  751. C immediately. Otherwise IER receives the I/O status from the Fortran
  752. C write (0 => success).
  753. C-----------------------------------------------------------------------
  754.       INTEGER IER, UNIT
  755.       CHARACTER*(*) S
  756. C
  757.       IF (IER.EQ.0) THEN
  758.           WRITE (UNIT, '(A)', IOSTAT=IER) S
  759.           IF (IER.NE.0) CALL 
  760.      1        GRWARN('++WARNING++ Error writing PostScript file')
  761.       END IF
  762. C-----------------------------------------------------------------------
  763.       END
  764.