home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / pgplot_1 / f77 / PGPLOT < prev    next >
Text File  |  1997-06-11  |  575KB  |  16,803 lines
  1. C*GRAREA -- define a clipping window
  2. C+
  3.       SUBROUTINE GRAREA (IDENT,X0,Y0,XSIZE,YSIZE)
  4. C
  5. C GRPCKG: Define a rectangular window in the current plotting area. All
  6. C graphics (except characters written with GRCHAR) will be blanked
  7. C outside this window.  The default window is the full plotting area
  8. C defined by default or by GRSETS.
  9. C
  10. C Arguments:
  11. C
  12. C IDENT (input, integer): the plot identifier, returned by GROPEN.
  13. C X0, Y0 (input, real): the lower left corner of the window, in absolute
  14. C       device coordinates.
  15. C XSIZE, YSIZE (input, real): width and height of the window in absolute
  16. C       coordinates; if either is negative, the window will be reset to
  17. C       the full plotting area.
  18. C--
  19. C  1-Feb-1983 - [TJP].
  20. C 25-Nov-1994 - use floating-point [TJP].
  21. C-----------------------------------------------------------------------
  22.       INCLUDE 'f77.GRPCKG1/IN'
  23.       INTEGER IDENT
  24.       REAL X0, Y0, XSIZE, YSIZE
  25. C
  26.       CALL GRSLCT(IDENT)
  27. C
  28.       IF ((XSIZE.LE.0.0) .OR. (YSIZE.LE.0.0)) THEN
  29.           GRXMIN(IDENT) = 0
  30.           GRXMAX(IDENT) = GRXMXA(IDENT)
  31.           GRYMIN(IDENT) = 0
  32.           GRYMAX(IDENT) = GRYMXA(IDENT)
  33.       ELSE
  34.           GRXMIN(IDENT) = MAX(X0,0.0)
  35.           GRYMIN(IDENT) = MAX(Y0,0.0)
  36.           GRXMAX(IDENT) = MIN(XSIZE+X0,REAL(GRXMXA(IDENT)))
  37.           GRYMAX(IDENT) = MIN(YSIZE+Y0,REAL(GRYMXA(IDENT)))
  38.       END IF
  39. C
  40.       END
  41. C*GRBPIC -- begin picture
  42. C+
  43.       SUBROUTINE GRBPIC
  44. C
  45. C GRPCKG (internal routine). Send a "begin picture" command to the
  46. C device driver, and send commands to set deferred attributes (color,
  47. C line width, etc.)
  48. C-----------------------------------------------------------------------
  49.       INCLUDE 'f77.GRPCKG1/IN'
  50.       REAL RBUF(2)
  51.       INTEGER NBUF, LCHR
  52.       CHARACTER*20 CHR
  53. C
  54.       GRPLTD(GRCIDE) = .TRUE.
  55.       IF (GRGTYP.GT.0) THEN
  56. C         -- begin picture
  57.           RBUF(1) = GRXMXA(GRCIDE)
  58.           RBUF(2) = GRYMXA(GRCIDE)
  59.           NBUF = 2
  60.           CALL GREXEC(GRGTYP,11,RBUF,NBUF,CHR,LCHR)
  61. C         -- set color index
  62.           RBUF(1) = GRCCOL(GRCIDE)
  63.           NBUF = 1
  64.           CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  65. C         -- set line width
  66.           IF (GRGCAP(GRCIDE)(5:5).EQ.'T') THEN
  67.               RBUF(1) = ABS(GRWIDT(GRCIDE))
  68.               NBUF = 1
  69.               CALL GREXEC(GRGTYP,22,RBUF,NBUF,CHR,LCHR)
  70.           END IF
  71. C         -- set hardware dashing
  72.           IF (GRGCAP(GRCIDE)(3:3).EQ.'D') THEN
  73.               RBUF(1) = GRSTYL(GRCIDE)
  74.               NBUF = 1
  75.               CALL GREXEC(GRGTYP,19,RBUF,NBUF,CHR,LCHR)
  76.           END IF
  77.       END IF
  78. C
  79.       END
  80. C+
  81. ***********************************************************************
  82. *                                                                     *
  83. *  PGPLOT Fortran Graphics Subroutine Library                         *
  84. *                                                                     *
  85. *  T. J. Pearson, California Institute of Technology,                 *
  86. *  Pasadena, California 91125.                                        *
  87. *                                                                     *
  88. *  Routines for handling the obsolete character set                   *
  89. *  ------------------------------------------------                   *
  90. *  These routines are not called by PGPLOT but are called by some     *
  91. *  old user-written programs.                                         *
  92. ***********************************************************************
  93.  
  94. ******* Index of Modules **********************************************
  95.  
  96. * GRCHAR -- draw a string of characters
  97. * GRCHR0 -- support routine for GRCHAR and GRMARK
  98. * GRDAT2 -- character set definition (block data)
  99. * GRGTC0 -- obtain character digitization
  100. * GRMARK -- mark points with specified symbol
  101.  
  102. ***********************************************************************
  103. C--
  104.  
  105. C*GRCHAR -- draw a string of characters
  106. C+
  107.       SUBROUTINE GRCHAR (IDENT,CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  108. C
  109. C GRPCKG: Draw a string of characters. The plot is not windowed
  110. C in the current subarea, but in the full plotting area.
  111. C
  112. C Arguments:
  113. C
  114. C IDENT (input, integer): plot identifier, as returned by GROPEN.
  115. C CENTER (input, logical): if .TRUE., the first character of the string
  116. C      is centered at (X0,Y0); otherwise the bottom left corner of the
  117. C      first character is placed at (X0,Y0).
  118. C ORIENT (input, real): the angle in degrees that the string is to make
  119. C      with the horizontal, increasing anticlockwise.
  120. C ABSXY (input, logical): if .TRUE., (X0,Y0) are absolute device
  121. C      coordinates; otherwise they are world coordinates (the scaling
  122. C      transformation is applied).
  123. C X0, Y0 (input, real): position of first character (see CENTER).
  124. C STRING (input, character): the string of ASCII characters; control
  125. C      characters 0-20 have special representations; all other
  126. C      non-graphic characters are plotted as blank spaces.
  127. C
  128. C (1-Feb-1983)
  129. C-----------------------------------------------------------------------
  130.       CHARACTER*(*) STRING
  131.       INTEGER  IDENT
  132.       LOGICAL  ABSXY, CENTER
  133.       REAL     ORIENT, X0, Y0
  134. C
  135.       CALL GRSLCT(IDENT)
  136.       CALL GRCHR0(.FALSE., CENTER, ORIENT, ABSXY, X0, Y0, STRING)
  137.       RETURN
  138.       END
  139. C*GRCHR0 -- support routine for GRCHAR and GRMARK
  140. C+
  141.       SUBROUTINE GRCHR0 (WINDOW,CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  142. C
  143. C GRPCKG (internal routine): Support routine for GRCHAR and GRMARK.
  144. C Draw a string of characters.
  145. C
  146. C Arguments:
  147. C
  148. C WINDOW (input, logical): if .TRUE., the plot is windowed in the
  149. C      current window.
  150. C CENTER (input, logical): if .TRUE., the first character of the string
  151. C      is centered at (X0,Y0); otherwise the bottom left corner of the
  152. C      first character is placed at (X0,Y0).
  153. C ORIENT (input, real): the angle in degrees that the string is to make
  154. C      with the horizontal, increasing anticlockwise.
  155. C ABSXY (input, logical): if .TRUE., (X0,Y0) are absolute device
  156. C      coordinates; otherwise they are world coordinates (the scaling
  157. C      transformation is applied).
  158. C X0, Y0 (input, real): position of first character (see CENTER).
  159. C STRING (input, character): the string of ASCII characters; control
  160. C      characters 0-20 have special representations; all other
  161. C      non-graphic characters are plotted as blank spaces.
  162. C
  163. C (1-Mar-1983)
  164. C-----------------------------------------------------------------------
  165.       INTEGER  DOT, MOVE, VECSIZ
  166.       REAL     PI
  167.       PARAMETER (DOT = 3)
  168.       PARAMETER (MOVE = 2)
  169.       PARAMETER (VECSIZ = 30)
  170.       PARAMETER (PI = 3.14159265359)
  171.       INCLUDE 'f77.GRPCKG1/IN'
  172.       CHARACTER*(*) STRING
  173.       CHARACTER*1   NEXT
  174.       REAL     XMIN, XMAX, YMIN, YMAX
  175.       INTEGER  MODE,LSTYLE,LEVEL
  176.       INTEGER  I, J, L, CH, POINTS
  177.       LOGICAL  ABSXY, CENTER, MORE, WINDOW
  178.       REAL     ORIENT, X0, Y0
  179.       REAL     ANGLE, FACTOR, BASE, FAC
  180.       REAL     COSA, SINA
  181.       REAL     DX, DY, XORG, YORG
  182.       REAL     XC(VECSIZ), YC(VECSIZ), XT, YT
  183. C
  184.       IF (LEN(STRING).LE.0) RETURN
  185. C
  186. C Compute scaling and orientation.
  187. C
  188.       CALL GRQLS(LSTYLE)
  189.       CALL GRSLS(1)
  190.       ANGLE = (AMOD(ORIENT, 360.0) / 180.0) * PI
  191.       FACTOR = GRCFAC(GRCIDE)
  192.       COSA = FACTOR * COS(ANGLE)
  193.       SINA = FACTOR * SIN(ANGLE)
  194.       DX = 10.0 * COSA
  195.       DY = 10.0 * SINA
  196.       CALL GRTXY0(ABSXY, X0, Y0, XORG, YORG)
  197.       IF (.NOT.WINDOW) THEN
  198.           XMIN = GRXMIN(GRCIDE)
  199.           XMAX = GRXMAX(GRCIDE)
  200.           YMIN = GRYMIN(GRCIDE)
  201.           YMAX = GRYMAX(GRCIDE)
  202.           CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  203.       END IF
  204. C
  205. C Plot the string of characters.
  206. C
  207.       MODE = MOVE
  208.       BASE = 0.0
  209.       FAC = 1.0
  210.       I = 1
  211.       LEVEL = 0
  212.       L = LEN(STRING)
  213. C     -- DO WHILE (I.LE.L)
  214.    10 IF (I.LE.L) THEN
  215.         IF (I.LT.L .AND. STRING(I:I).EQ.CHAR(92)) THEN
  216.             CALL GRTOUP(NEXT,STRING(I+1:I+1))
  217.             IF (NEXT.EQ.'U') THEN
  218.                 LEVEL = LEVEL+1
  219.                 BASE = BASE + 4.0*FAC
  220.                 FAC = 0.6**IABS(LEVEL)
  221.                 I = I+2
  222.             ELSE IF (NEXT.EQ.'D') THEN
  223.                 LEVEL = LEVEL-1
  224.                 FAC = 0.6**IABS(LEVEL)
  225.                 BASE = BASE - 4.0*FAC
  226.                 I = I+2
  227.             ELSE
  228.                 I = I+1
  229.             END IF
  230.         ELSE
  231.           CH = ICHAR(STRING(I:I))
  232.           IF (CH.GT.127 .OR. CH.LT.0) CH = ICHAR(' ')
  233.           MORE = .TRUE.
  234. C         -- DO WHILE (MORE)
  235.    20     IF (MORE) THEN
  236.             CALL GRGTC0(CH, CENTER, POINTS, XC, YC, MORE)
  237.             DO 30 J=1,POINTS
  238.                     XT = XC(J)*FAC
  239.                     YT = YC(J)*FAC + BASE
  240.                     XC(J) = XORG + COSA * XT - SINA * YT
  241.                     YC(J) = YORG + SINA * XT + COSA * YT
  242.    30       CONTINUE
  243.             IF (POINTS.EQ.1) MODE = DOT
  244.             IF (POINTS.GT.0) CALL GRVCT0(MODE,.TRUE.,POINTS,XC,YC)
  245.             IF (POINTS.EQ.1) MODE = MOVE
  246.           GOTO 20
  247.           END IF
  248. C         -- end DO WHILE
  249.           XORG = XORG + DX*FAC
  250.           YORG = YORG + DY*FAC
  251.           I = I+1
  252.         END IF
  253.       GOTO 10
  254.       END IF
  255. C     -- end DO WHILE
  256. C
  257. C Clean up and return.
  258. C
  259.       IF (.NOT.WINDOW) THEN
  260.           GRXMIN(GRCIDE) = XMIN
  261.           GRXMAX(GRCIDE) = XMAX
  262.           GRYMIN(GRCIDE) = YMIN
  263.           GRYMAX(GRCIDE) = YMAX
  264.       END IF
  265.       CALL GRSLS(LSTYLE)
  266.       RETURN
  267.       END
  268.  
  269. C*GRCHSZ -- inquire default character attributes
  270. C+
  271.       SUBROUTINE GRCHSZ (IDENT,XSIZE,YSIZE,XSPACE,YSPACE)
  272. C
  273. C GRPCKG: Obtain the default character attributes.
  274. C
  275. C Arguments:
  276. C
  277. C IDENT (input, integer): the plot identifier, returned by GROPEN.
  278. C XSIZE, YSIZE (output, real): the default character size
  279. C      (absolute device units).
  280. C XSPACE, YSPACE (output, real): the default character spacing
  281. C      (absolute units); XSPACE is the distance between the lower left
  282. C      corners of adjacent characters in a plotted string; YSPACE
  283. C      is the corresponding vertical spacing.
  284. C--
  285. C (1-Feb-1983)
  286. C-----------------------------------------------------------------------
  287.       INCLUDE 'f77.GRPCKG1/IN'
  288.       INTEGER  IDENT
  289.       REAL     FACTOR, XSIZE, YSIZE, XSPACE, YSPACE
  290. C
  291.       CALL GRSLCT(IDENT)
  292.       FACTOR = GRCSCL(IDENT)
  293.       XSIZE = GRCXSZ * FACTOR
  294.       YSIZE = GRCYSZ * FACTOR
  295.       XSPACE = 10.0 * FACTOR
  296.       YSPACE = 13.0 * FACTOR
  297.       END
  298. C*GRCLIP -- clip a point against clipping rectangle
  299. C+
  300.       SUBROUTINE GRCLIP (X,Y,XMIN,XMAX,YMIN,YMAX,C)
  301.       REAL X,Y
  302.       REAL XMIN,XMAX,YMIN,YMAX
  303.       INTEGER C
  304. C
  305. C GRPCKG (internal routine): support routine for the clipping algorithm;
  306. C called from GRLIN0 only. C is a 4 bit code indicating the relationship
  307. C between point (X,Y) and the window boundaries; 0 implies the point is
  308. C within the window.
  309. C
  310. C Arguments:
  311. C--
  312. C (11-Feb-1983)
  313. C Revised 20-Jun-1985 (TJP); use floating arithmetic
  314. C Revised 12-Jun-1992 (TJP); clip exactly on the boundary
  315. C-----------------------------------------------------------------------
  316. C
  317.       C = 0
  318.       IF (X.LT.XMIN) THEN
  319.           C = 1
  320.       ELSE IF (X.GT.XMAX) THEN
  321.           C = 2
  322.       END IF
  323.       IF (Y.LT.YMIN) THEN
  324.           C = C+4
  325.       ELSE IF (Y.GT.YMAX) THEN
  326.           C = C+8
  327.       END IF
  328.       END
  329. C*GRCLOS -- close graphics device
  330. C+
  331.       SUBROUTINE GRCLOS
  332. C
  333. C GRPCKG: Close the open plot on the current device. Any pending output
  334. C is sent to the device, the device is released for other users or the
  335. C disk file is closed, and no further plotting is allowed on the device
  336. C without a new call to GROPEN.
  337. C
  338. C Arguments: none.
  339. C--
  340. C  1-Jun-1984 - [TJP].
  341. C 17-Jul-1984 - ignore call if plot is not open [TJP].
  342. C  1-Oct-1984 - reset color to default (1) and position text cursor
  343. C               at bottom of VT screen [TJP].
  344. C 19-Oct-1984 - add VV device [TJP].
  345. C 22-Dec-1984 - use GRBUFL and GRIOTA parameters [TJP].
  346. C  5-Aug-1986 - add GREXEC support [AFT].
  347. C 21-Feb-1987 - modify END_PICTURE sequence [AFT].
  348. C 11-Jun-1987 - remove built-ins [TJP].
  349. C 31-Aug-1987 - do not eject blank page [TJP].
  350. C-----------------------------------------------------------------------
  351.       INCLUDE 'f77.GRPCKG1/IN'
  352.       REAL    RBUF(6)
  353.       INTEGER NBUF,LCHR
  354.       CHARACTER CHR
  355. C
  356. C Check a plot is open.
  357. C
  358.       IF (GRCIDE.LT.1) RETURN
  359. C
  360. C Reset color to default (1). This is useful
  361. C for VT240 terminals, which use the color tables for text.
  362. C
  363.       CALL GRSCI(1)
  364. C
  365. C Flush buffer.
  366. C
  367.       CALL GRTERM
  368. C
  369. C End picture.
  370. C
  371.       CALL GREPIC
  372. C
  373. C This plot identifier is no longer in use.
  374. C Set state to "workstation closed".
  375. C
  376.       GRSTAT(GRCIDE) = 0
  377.       GRCIDE = 0
  378. C
  379. C Close workstation.
  380. C
  381.       CALL GREXEC(GRGTYP,10,RBUF,NBUF,CHR,LCHR)
  382. C
  383.       END
  384. C*GRCLPL -- clip line against clipping rectangle
  385. C+
  386.       SUBROUTINE GRCLPL (X0,Y0,X1,Y1,VIS)
  387. C
  388. C GRPCKG (internal routine): Change the end-points of the line (X0,Y0)
  389. C (X1,Y1) to clip the line at the window boundary.  The algorithm is
  390. C that of Cohen and Sutherland (ref: Newman & Sproull).
  391. C
  392. C Arguments:
  393. C
  394. C X0, Y0 (input/output, real): device coordinates of starting point
  395. C       of line.
  396. C X1, Y1 (input/output, real): device coordinates of end point of line.
  397. C VIS (output, logical): .TRUE. if line lies wholly or partially
  398. C       within the clipping rectangle; .FALSE. if it lies entirely
  399. C       outside the rectangle.
  400. C--
  401. C 13-Jul-1984 - [TJP].
  402. C 20-Jun-1985 - [TJP] - revise clipping algorithm.
  403. C 28-Jun-1991 - [TJP] - use IAND().
  404. C 12-Jun-1992 - [TJP] - clip exactly on the boundary.
  405. C
  406. C Caution: IAND is a non-standard intrinsic function to do bitwise AND
  407. C of two integers. If it is not supported by your Fortran compiler, you
  408. C will need to modify this routine or supply an IAND function.
  409. C-----------------------------------------------------------------------
  410.       INCLUDE 'f77.GRPCKG1/IN'
  411.       LOGICAL  VIS
  412.       INTEGER  C0,C1,C
  413.       REAL     XMIN,XMAX,YMIN,YMAX
  414.       REAL     X,Y, X0,Y0, X1,Y1
  415.       INTEGER IAND
  416. C
  417.       XMIN = GRXMIN(GRCIDE)
  418.       YMIN = GRYMIN(GRCIDE)
  419.       XMAX = GRXMAX(GRCIDE)
  420.       YMAX = GRYMAX(GRCIDE)
  421.       CALL GRCLIP(X0,Y0,XMIN,XMAX,YMIN,YMAX,C0)
  422.       CALL GRCLIP(X1,Y1,XMIN,XMAX,YMIN,YMAX,C1)
  423.    10 IF (C0.NE.0 .OR. C1.NE.0) THEN
  424.           IF (IAND(C0,C1).NE.0) THEN
  425. C             ! line is invisible
  426.               VIS = .FALSE.
  427.               RETURN
  428.           END IF
  429.           C = C0
  430.           IF (C.EQ.0) C = C1
  431.           IF (IAND(C,1).NE.0) THEN
  432. C             ! crosses XMIN
  433.               Y = Y0 + (Y1-Y0)*(XMIN-X0)/(X1-X0)
  434.               X = XMIN
  435.           ELSE IF (IAND(C,2).NE.0) THEN
  436. C             ! crosses XMAX
  437.               Y = Y0 + (Y1-Y0)*(XMAX-X0)/(X1-X0)
  438.               X = XMAX
  439.           ELSE IF (IAND(C,4).NE.0) THEN
  440. C             ! crosses YMIN
  441.               X = X0 + (X1-X0)*(YMIN-Y0)/(Y1-Y0)
  442.               Y = YMIN
  443.           ELSE IF (IAND(C,8).NE.0) THEN
  444. C             ! crosses YMAX
  445.               X = X0 + (X1-X0)*(YMAX-Y0)/(Y1-Y0)
  446.               Y = YMAX
  447.           END IF
  448.           IF (C.EQ.C0) THEN
  449.               X0 = X
  450.               Y0 = Y
  451.               CALL GRCLIP(X,Y,XMIN,XMAX,YMIN,YMAX,C0)
  452.           ELSE
  453.               X1 = X
  454.               Y1 = Y
  455.               CALL GRCLIP(X,Y,XMIN,XMAX,YMIN,YMAX,C1)
  456.           END IF
  457.       GOTO 10
  458.       END IF
  459.       VIS = .TRUE.
  460.       END
  461. C*GRCTOI -- convert character string to integer
  462. C+
  463.       INTEGER FUNCTION GRCTOI (S, I)
  464.       CHARACTER*(*) S
  465.       INTEGER I
  466. C
  467. C GRCTOI: attempt to read an integer from a character string, and return
  468. C the result. No attempt is made to avoid integer overflow. A valid 
  469. C integer is any sequence of decimal digits.
  470. C
  471. C Returns:
  472. C  GRCTOI           : the value of the integer; if the first character
  473. C                    read is not a decimal digit, the value returned
  474. C                    is zero.
  475. C Arguments:
  476. C  S      (input)  : character string to be parsed.
  477. C  I      (in/out) : on input, I is the index of the first character
  478. C                    in S to be examined; on output, either it points
  479. C                    to the next character after a valid integer, or
  480. C                    it is equal to LEN(S)+1.
  481. C
  482. C--
  483. C  1985 Oct  8 - New routine, based on CTOI (T. J. Pearson).
  484. C  1997 Jun  3 - allow leading + or - sign (TJP).
  485. C-----------------------------------------------------------------------
  486.       INTEGER K, SIGN, X
  487.       CHARACTER*1 DIGITS(0:9)
  488.       DATA  DIGITS/'0','1','2','3','4','5','6','7','8','9'/
  489. C
  490.       X = 0
  491.       SIGN = +1
  492.       IF (I.GT.LEN(S)) GOTO 30
  493.       IF (S(I:I).EQ.'+') THEN
  494.          I = I+1
  495.       ELSE IF (S(I:I).EQ.'-') THEN
  496.          I = I+1
  497.          SIGN = -1
  498.       END IF
  499.  10   IF (I.GT.LEN(S)) GOTO 30
  500.       DO 20 K=0,9
  501.          IF (S(I:I).EQ.DIGITS(K)) THEN
  502.             X = X*10 + K
  503.             I = I+1
  504.             GOTO 10
  505.          END IF
  506.  20   CONTINUE
  507.  30   GRCTOI = X*SIGN
  508.       RETURN
  509.       END
  510. C*GRCURS -- read cursor position
  511. C+
  512.       INTEGER FUNCTION GRCURS (IDENT,IX,IY,IXREF,IYREF,MODE,POSN,CH)
  513.       INTEGER IDENT, IX, IY, IXREF, IYREF, MODE, POSN
  514.       CHARACTER*(*) CH
  515. C
  516. C GRPCKG: Read the cursor position and a character typed by the user.
  517. C The position is returned in absolute device coordinates (pixels).
  518. C GRCURS positions the cursor at the position specified, and
  519. C allows the user to move the cursor using the joystick or
  520. C arrow keys or whatever is available on the device. When he has
  521. C positioned the cursor, the user types a single character on his
  522. C keyboard; GRCURS then returns this character and the new cursor
  523. C position.
  524. C
  525. C "Rubber band" feedback of cursor movement can be requested (although
  526. C it may not be supported on some devices). If MODE=1, a line from
  527. C the anchor point to the current cursor position is displayed as
  528. C the cursor is moved. If MODE=2, a rectangle with vertical and
  529. C horizontal sides and one vertex at the anchor point and the opposite
  530. C vertex at the current cursor position is displayed as the cursor is
  531. C moved.
  532. C
  533. C Returns:
  534. C
  535. C GRCURS (integer): 1 if the call was successful; 0 if the device
  536. C      has no cursor or some other error occurs. 
  537. C
  538. C Arguments:
  539. C
  540. C IDENT (integer, input):  GRPCKG plot identifier (from GROPEN).
  541. C IX    (integer, in/out): the device x-coordinate of the cursor.
  542. C IY    (integer, in/out): the device y-coordinate of the cursor.
  543. C IXREF (integer, input):  x-coordinate of anchor point.
  544. C IYREF (integer, input):  y-coordinate of anchor point.
  545. C MODE  (integer, input):  type of rubber-band feedback.
  546. C CH    (char,    output): the character typed by the user; if the device
  547. C      has no cursor or if some other error occurs, the value CHAR(0)
  548. C      [ASCII NUL character] is returned.
  549. C--
  550. C  1-Aug-1984 - extensively revised [TJP].
  551. C 29-Jan-1985 - add ARGS and HP2648 devices (?) [KS/TJP].
  552. C  5-Aug-1986 - add GREXEC support [AFT].
  553. C 11-Jun-1987 - remove built-ins [TJP].
  554. C 15-Feb-1988 - remove test for batch jobs; leave this to the device
  555. C               handler [TJP].
  556. C 13-Dec-1990 - remove code to abort after 10 cursor errors [TJP].
  557. C  7-Sep-1994 - add support for rubber-band modes [TJP].
  558. C 17-Jan-1995 - start picture if necessary [TJP].
  559. C-----------------------------------------------------------------------
  560.       INCLUDE 'f77.GRPCKG1/IN'
  561.       REAL           RBUF(6)
  562.       INTEGER        NBUF, LCHR, ICURS, ERRCNT
  563.       CHARACTER*16   CHR
  564.       CHARACTER      C
  565.       SAVE           ERRCNT
  566.       DATA           ERRCNT/0/
  567. C
  568. C Validate identifier, and select device.
  569. C
  570.       CALL GRSLCT(IDENT)
  571.       CALL GRTERM
  572. C
  573. C Begin picture if necessary.
  574. C
  575.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  576. C
  577. C Make sure cursor is on view surface. (It does not
  578. C have to be in the viewport.)
  579. C
  580.       IX = MAX(0,MIN(GRXMXA(GRCIDE),IX))
  581.       IY = MAX(0,MIN(GRYMXA(GRCIDE),IY))
  582. C
  583. C Does the device have a cursor?
  584. C
  585.       C = GRGCAP(GRCIDE)(2:2)
  586.       ICURS = 0
  587.       IF (C.EQ.'C' .OR. C.EQ.'X') ICURS=1
  588. C
  589. C Device does have a cursor.
  590. C
  591.       IF (ICURS.GT.0) THEN
  592. C         -- initial position of cursor
  593.           RBUF(1) = IX
  594.           RBUF(2) = IY
  595. C         -- reference point for rubber band
  596.           RBUF(3) = IXREF
  597.           RBUF(4) = IYREF
  598. C         -- rubber band mode
  599.           RBUF(5) = MODE
  600. C         -- position cursor?
  601.           RBUF(6) = POSN
  602.           NBUF = 6
  603.           LCHR = 0
  604.           CALL GREXEC(GRGTYP,17,RBUF,NBUF,CHR,LCHR)
  605.           IX = RBUF(1)
  606.           IY = RBUF(2)
  607.           CH = CHR(1:1)
  608.           GRCURS = 1
  609. C         -- error if driver returns NUL
  610.           IF (ICHAR(CHR(1:1)).EQ.0) GRCURS = 0
  611. C
  612. C Other devices are illegal.
  613. C
  614.       ELSE
  615.           CALL GREXEC(GRGTYP, 1,RBUF,NBUF,CHR,LCHR)
  616.           LCHR = INDEX(CHR,' ')
  617.           IF (ERRCNT.LE.10) CALL 
  618.      1        GRWARN('output device has no cursor: '//CHR(:LCHR))
  619.           CH = CHAR(0)
  620.           GRCURS = 0
  621.           ERRCNT = ERRCNT+1
  622.       END IF
  623. C
  624.       END
  625.  
  626. C*GRDAT2 -- character set definition (block data)
  627. C+
  628.       BLOCK DATA GRDAT2
  629. C
  630. C GRPCKG (internal routine): Block data for to define the character set.
  631. C
  632. C Arguments: none.
  633. C
  634. C (1-Feb-1983)
  635. C-----------------------------------------------------------------------
  636.       INTEGER   CTD1, CTD2
  637.       PARAMETER (CTD1 = 30)
  638.       PARAMETER (CTD2 = 128)
  639. C
  640.       INTEGER   CINDX1, CINDX2
  641.       INTEGER   CHTBL(CTD1,CTD2)
  642.       INTEGER   SPCH00(CTD1), SPCH01(CTD1), SPCH02(CTD1), SPCH03(CTD1)
  643.      1        , SPCH04(CTD1), SPCH05(CTD1), SPCH06(CTD1), SPCH07(CTD1)
  644.      2        , SPCH08(CTD1), SPCH09(CTD1), SPCH10(CTD1), SPCH11(CTD1)
  645.      3        , SPCH12(CTD1), SPCH13(CTD1), SPCH14(CTD1), SPCH15(CTD1)
  646.      4        , SPCH16(CTD1), SPCH17(CTD1), SPCH18(CTD1), SPCH19(CTD1)
  647.      5        , SPCH20(CTD1), SPCH21(CTD1), SPCH22(CTD1), SPCH23(CTD1)
  648.      6        , SPCH24(CTD1), SPCH25(CTD1), SPCH26(CTD1), SPCH27(CTD1)
  649.      7        , SPCH28(CTD1), SPCH29(CTD1), SPCH30(CTD1), SPCH31(CTD1)
  650.      8        , SPACE (CTD1), EXCLAM(CTD1), QUOTE (CTD1), POUND (CTD1)
  651.      9        , DOLLAR(CTD1), PERCNT(CTD1), AMPERS(CTD1), APOSTR(CTD1)
  652.      A        , LPAREN(CTD1), RPAREN(CTD1), ASTER (CTD1), PLUS  (CTD1)
  653.      B        , COMMA (CTD1), MINUS (CTD1), PERIOD(CTD1), SLASH (CTD1)
  654.      C        , ZERO  (CTD1), ONE   (CTD1), TWO   (CTD1), THREE (CTD1)
  655.      D        , FOUR  (CTD1), FIVE  (CTD1), SIX   (CTD1), SEVEN (CTD1)
  656.      E        , EIGHT (CTD1), NINE  (CTD1), COLON (CTD1), SEMICO(CTD1)
  657.      F        , LESS  (CTD1), EQUALS(CTD1), GREATR(CTD1), QUESTN(CTD1)
  658.       INTEGER   ATSIGN(CTD1), AUPPER(CTD1), BUPPER(CTD1), CUPPER(CTD1)
  659.      1        , DUPPER(CTD1), EUPPER(CTD1), FUPPER(CTD1), GUPPER(CTD1)
  660.      2        , HUPPER(CTD1), IUPPER(CTD1), JUPPER(CTD1), KUPPER(CTD1)
  661.      3        , LUPPER(CTD1), MUPPER(CTD1), NUPPER(CTD1), OUPPER(CTD1)
  662.      4        , PUPPER(CTD1), QUPPER(CTD1), RUPPER(CTD1), SUPPER(CTD1)
  663.      5        , TUPPER(CTD1), UUPPER(CTD1), VUPPER(CTD1), WUPPER(CTD1)
  664.      6        , XUPPER(CTD1), YUPPER(CTD1), ZUPPER(CTD1), LBRACK(CTD1)
  665.      7        , BKSLSH(CTD1), RBRACK(CTD1), CARET (CTD1), USCORE(CTD1)
  666.      8        , ACCENT(CTD1), ALOWER(CTD1), BLOWER(CTD1), CLOWER(CTD1)
  667.      9        , DLOWER(CTD1), ELOWER(CTD1), FLOWER(CTD1), GLOWER(CTD1)
  668.      A        , HLOWER(CTD1), ILOWER(CTD1), JLOWER(CTD1), KLOWER(CTD1)
  669.      B        , LLOWER(CTD1), MLOWER(CTD1), NLOWER(CTD1), OLOWER(CTD1)
  670.      C        , PLOWER(CTD1), QLOWER(CTD1), RLOWER(CTD1), SLOWER(CTD1)
  671.      D        , TLOWER(CTD1), ULOWER(CTD1), VLOWER(CTD1), WLOWER(CTD1)
  672.      E        , XLOWER(CTD1), YLOWER(CTD1), ZLOWER(CTD1), LBRACE(CTD1)
  673.      F        , ORSIGN(CTD1), RBRACE(CTD1), TILDE (CTD1), SPC127(CTD1)
  674.       EQUIVALENCE (SPCH00, CHTBL(1,   1)), (SPCH01, CHTBL(1,   2))
  675.      1          , (SPCH02, CHTBL(1,   3)), (SPCH03, CHTBL(1,   4))
  676.      2          , (SPCH04, CHTBL(1,   5)), (SPCH05, CHTBL(1,   6))
  677.      3          , (SPCH06, CHTBL(1,   7)), (SPCH07, CHTBL(1,   8))
  678.      4          , (SPCH08, CHTBL(1,   9)), (SPCH09, CHTBL(1,  10))
  679.      5          , (SPCH10, CHTBL(1,  11)), (SPCH11, CHTBL(1,  12))
  680.      6          , (SPCH12, CHTBL(1,  13)), (SPCH13, CHTBL(1,  14))
  681.      7          , (SPCH14, CHTBL(1,  15)), (SPCH15, CHTBL(1,  16))
  682.      8          , (SPCH16, CHTBL(1,  17)), (SPCH17, CHTBL(1,  18))
  683.      9          , (SPCH18, CHTBL(1,  19)), (SPCH19, CHTBL(1,  20))
  684.      A          , (SPCH20, CHTBL(1,  21)), (SPCH21, CHTBL(1,  22))
  685.      B          , (SPCH22, CHTBL(1,  23)), (SPCH23, CHTBL(1,  24))
  686.      C          , (SPCH24, CHTBL(1,  25)), (SPCH25, CHTBL(1,  26))
  687.      D          , (SPCH26, CHTBL(1,  27)), (SPCH27, CHTBL(1,  28))
  688.      E          , (SPCH28, CHTBL(1,  29)), (SPCH29, CHTBL(1,  30))
  689.      F          , (SPCH30, CHTBL(1,  31)), (SPCH31, CHTBL(1,  32))
  690.       EQUIVALENCE (SPACE , CHTBL(1,  33)), (EXCLAM, CHTBL(1,  34))
  691.      1          , (QUOTE , CHTBL(1,  35)), (POUND , CHTBL(1,  36))
  692.      2          , (DOLLAR, CHTBL(1,  37)), (PERCNT, CHTBL(1,  38))
  693.      3          , (AMPERS, CHTBL(1,  39)), (APOSTR, CHTBL(1,  40))
  694.      4          , (LPAREN, CHTBL(1,  41)), (RPAREN, CHTBL(1,  42))
  695.      5          , (ASTER , CHTBL(1,  43)), (PLUS  , CHTBL(1,  44))
  696.      6          , (COMMA , CHTBL(1,  45)), (MINUS , CHTBL(1,  46))
  697.      7          , (PERIOD, CHTBL(1,  47)), (SLASH , CHTBL(1,  48))
  698.      8          , (ZERO  , CHTBL(1,  49)), (ONE   , CHTBL(1,  50))
  699.      9          , (TWO   , CHTBL(1,  51)), (THREE , CHTBL(1,  52))
  700.      A          , (FOUR  , CHTBL(1,  53)), (FIVE  , CHTBL(1,  54))
  701.      B          , (SIX   , CHTBL(1,  55)), (SEVEN , CHTBL(1,  56))
  702.      C          , (EIGHT , CHTBL(1,  57)), (NINE  , CHTBL(1,  58))
  703.      D          , (COLON , CHTBL(1,  59)), (SEMICO, CHTBL(1,  60))
  704.      E          , (LESS  , CHTBL(1,  61)), (EQUALS, CHTBL(1,  62))
  705.      F          , (GREATR, CHTBL(1,  63)), (QUESTN, CHTBL(1,  64))
  706.       EQUIVALENCE (ATSIGN, CHTBL(1,  65)), (AUPPER, CHTBL(1,  66))
  707.      1          , (BUPPER, CHTBL(1,  67)), (CUPPER, CHTBL(1,  68))
  708.      2          , (DUPPER, CHTBL(1,  69)), (EUPPER, CHTBL(1,  70))
  709.      3          , (FUPPER, CHTBL(1,  71)), (GUPPER, CHTBL(1,  72))
  710.      4          , (HUPPER, CHTBL(1,  73)), (IUPPER, CHTBL(1,  74))
  711.      5          , (JUPPER, CHTBL(1,  75)), (KUPPER, CHTBL(1,  76))
  712.      6          , (LUPPER, CHTBL(1,  77)), (MUPPER, CHTBL(1,  78))
  713.      7          , (NUPPER, CHTBL(1,  79)), (OUPPER, CHTBL(1,  80))
  714.      8          , (PUPPER, CHTBL(1,  81)), (QUPPER, CHTBL(1,  82))
  715.      9          , (RUPPER, CHTBL(1,  83)), (SUPPER, CHTBL(1,  84))
  716.      A          , (TUPPER, CHTBL(1,  85)), (UUPPER, CHTBL(1,  86))
  717.      B          , (VUPPER, CHTBL(1,  87)), (WUPPER, CHTBL(1,  88))
  718.      C          , (XUPPER, CHTBL(1,  89)), (YUPPER, CHTBL(1,  90))
  719.      D          , (ZUPPER, CHTBL(1,  91)), (LBRACK, CHTBL(1,  92))
  720.      E          , (BKSLSH, CHTBL(1,  93)), (RBRACK, CHTBL(1,  94))
  721.      F          , (CARET , CHTBL(1,  95)), (USCORE, CHTBL(1,  96))
  722.       EQUIVALENCE (ACCENT, CHTBL(1,  97)), (ALOWER, CHTBL(1,  98))
  723.      1          , (BLOWER, CHTBL(1,  99)), (CLOWER, CHTBL(1, 100))
  724.      2          , (DLOWER, CHTBL(1, 101)), (ELOWER, CHTBL(1, 102))
  725.      3          , (FLOWER, CHTBL(1, 103)), (GLOWER, CHTBL(1, 104))
  726.      4          , (HLOWER, CHTBL(1, 105)), (ILOWER, CHTBL(1, 106))
  727.      5          , (JLOWER, CHTBL(1, 107)), (KLOWER, CHTBL(1, 108))
  728.      6          , (LLOWER, CHTBL(1, 109)), (MLOWER, CHTBL(1, 110))
  729.      7          , (NLOWER, CHTBL(1, 111)), (OLOWER, CHTBL(1, 112))
  730.      8          , (PLOWER, CHTBL(1, 113)), (QLOWER, CHTBL(1, 114))
  731.      9          , (RLOWER, CHTBL(1, 115)), (SLOWER, CHTBL(1, 116))
  732.      A          , (TLOWER, CHTBL(1, 117)), (ULOWER, CHTBL(1, 118))
  733.      B          , (VLOWER, CHTBL(1, 119)), (WLOWER, CHTBL(1, 120))
  734.      C          , (XLOWER, CHTBL(1, 121)), (YLOWER, CHTBL(1, 122))
  735.      D          , (ZLOWER, CHTBL(1, 123)), (LBRACE, CHTBL(1, 124))
  736.      E          , (ORSIGN, CHTBL(1, 125)), (RBRACE, CHTBL(1, 126))
  737.      F          , (TILDE , CHTBL(1, 127)), (SPC127, CHTBL(1, 128))
  738. C
  739.       COMMON /GRCS02/ CINDX1, CINDX2, CHTBL
  740. C
  741.       DATA CINDX1 /1/
  742.       DATA CINDX2 /0/
  743. C
  744.       DATA SPCH00 /07, 34, 37, 67, 61, 01, 07, 37, 00, 00
  745.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  746.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  747.       DATA SPCH01 /11, 34, 37, 47, 65, 63, 41, 21, 03, 05
  748.      1           , 27, 37, 00, 00, 00, 00, 00, 00, 00, 00
  749.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  750.       DATA SPCH02 /07, 34, 37, 64, 61, 01, 04, 37, 00, 00
  751.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  752.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  753.       DATA SPCH03 /02, 04, 64, 02, 37, 31, 00, 00, 00, 00
  754.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  755.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  756.       DATA SPCH04 /02, 01, 67, 02, 07, 61, 00, 00, 00, 00
  757.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  758.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  759.       DATA SPCH05 /06, 34, 37, 64, 31, 04, 37, 00, 00, 00
  760.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  761.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  762.       DATA SPCH06 /05, 31, 37, 64, 04, 37, 00, 00, 00, 00
  763.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  764.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  765.       DATA SPCH07 /04, 01, 67, 07, 61, 00, 00, 00, 00, 00
  766.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  767.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  768.       DATA SPCH08 /04, 07, 67, 01, 61, 02, 14, 54, 00, 00
  769.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  770.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  771.       DATA SPCH09 /03, 07, 34, 67, 02, 34, 31, 00, 00, 00
  772.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  773.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  774.       DATA SPCH10 /06, 61, 52, 56, 16, 12, 52, 02, 01, 12
  775.      1           , 02, 07, 16, 02, 67, 34, 00, 00, 00, 00
  776.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  777.       DATA SPCH11 /02, 01, 67, 02, 07, 61, 02, 04, 64, 02
  778.      1           , 37, 31, 00, 00, 00, 00, 00, 00, 00, 00
  779.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  780.       DATA SPCH12 /05, 01, 67, 07, 61, 01, 00, 00, 00, 00
  781.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  782.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  783.       DATA SPCH13 /02, 24, 44, 02, 37, 31, 00, 00, 00, 00
  784.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  785.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  786.       DATA SPCH14 /02, 07, 67, 02, 01, 61, 05, 31, 64, 37
  787.      1           , 04, 31, 01, 34, 00, 00, 00, 00, 00, 00
  788.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  789.       DATA SPCH15 /07, 23, 43, 44, 24, 25, 45, 44, 02, 35
  790.      1           , 33, 02, 23, 24, 00, 00, 00, 00, 00, 00
  791.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  792.       DATA SPCH16 /27, 01, 61, 62, 02, 03, 63, 64, 04, 05
  793.      1           , 65, 66, 06, 07, 67, 61, 51, 57, 47, 41
  794.      2           , 31, 37, 27, 21, 11, 17, 07, 01, 00, 00/
  795.       DATA SPCH17 /14, 21, 41, 52, 12, 03, 63, 64, 04, 05
  796.      1           , 65, 56, 16, 27, 47, 14, 03, 05, 16, 12
  797.      2           , 21, 27, 37, 31, 41, 47, 56, 52, 63, 65/
  798.       DATA SPCH18 /12, 31, 42, 22, 13, 53, 64, 04, 15, 55
  799.      1           , 46, 26, 37, 12, 64, 55, 53, 42, 46, 37
  800.      2           , 31, 22, 26, 15, 13, 04, 00, 00, 00, 00/
  801.       DATA SPCH19 /09, 26, 15, 13, 22, 42, 53, 55, 46, 26
  802.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  803.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  804.       DATA SPCH20 /09, 27, 05, 03, 21, 41, 63, 65, 47, 27
  805.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  806.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  807.       DATA SPCH21 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  808.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  809.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  810.       DATA SPCH22 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  811.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  812.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  813.       DATA SPCH23 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  814.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  815.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  816.       DATA SPCH24 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  817.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  818.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  819.       DATA SPCH25 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  820.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  821.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  822.       DATA SPCH26 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  823.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  824.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  825.       DATA SPCH27 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  826.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  827.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  828.       DATA SPCH28 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  829.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  830.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  831.       DATA SPCH29 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  832.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  833.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  834.       DATA SPCH30 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  835.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  836.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  837.       DATA SPCH31 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  838.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  839.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  840.       DATA SPACE  /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  841.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  842.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  843.       DATA EXCLAM /02, 38, 33, 01, 30, 00, 00, 00, 00, 00
  844.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  845.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  846.       DATA QUOTE  /02, 28, 26, 02, 48, 46, 00, 00, 00, 00
  847.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  848.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  849.       DATA POUND  /02, 10, 18, 02, 58, 50, 02, 62, 02, 02
  850.      1           , 06, 66, 00, 00, 00, 00, 00, 00, 00, 00
  851.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  852.       DATA DOLLAR /10, 01, 51, 62, 63, 54, 14, 05, 06, 17
  853.      1           , 67, 02, 38, 30, 00, 00, 00, 00, 00, 00
  854.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  855.       DATA PERCNT /05, 07, 18, 27, 16, 07, 02, 01, 67, 05
  856.      1           , 50, 61, 52, 41, 50, 00, 00, 00, 00, 00
  857.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  858.       DATA AMPERS /11, 60, 06, 07, 18, 48, 46, 02, 01, 10
  859.      1           , 30, 63, 00, 00, 00, 00, 00, 00, 00, 00
  860.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  861.       DATA APOSTR /06, 24, 46, 48, 38, 37, 47, 00, 00, 00
  862.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  863.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  864.       DATA LPAREN /04, 40, 22, 26, 48, 00, 00, 00, 00, 00
  865.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  866.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  867.       DATA RPAREN /04, 20, 42, 46, 28, 00, 00, 00, 00, 00
  868.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  869.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  870.       DATA ASTER  /02, 01, 67, 02, 07, 61, 02, 04, 64, 02
  871.      1           , 37, 31, 00, 00, 00, 00, 00, 00, 00, 00
  872.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  873.       DATA PLUS   /02, 14, 54, 02, 36, 32, 00, 00, 00, 00
  874.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  875.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  876.       DATA COMMA  /06, 20, 42, 44, 34, 33, 43, 00, 00, 00
  877.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  878.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  879.       DATA MINUS  /02, 14, 54, 00, 00, 00, 00, 00, 00, 00
  880.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  881.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  882.       DATA PERIOD /05, 20, 30, 31, 21, 20, 00, 00, 00, 00
  883.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  884.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  885.       DATA SLASH  /02, 01, 67, 00, 00, 00, 00, 00, 00, 00
  886.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  887.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  888.       DATA ZERO   /09, 10, 50, 61, 67, 58, 18, 07, 01, 10
  889.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  890.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  891.       DATA ONE    /02, 10, 50, 03, 30, 38, 16, 00, 00, 00
  892.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  893.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  894.       DATA TWO    /10, 07, 18, 58, 67, 65, 54, 24, 02, 00
  895.      1           , 60, 00, 00, 00, 00, 00, 00, 00, 00, 00
  896.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  897.       DATA THREE  /07, 07, 18, 58, 67, 65, 54, 34, 06, 54
  898.      1           , 63, 61, 50, 10, 01, 00, 00, 00, 00, 00
  899.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  900.       DATA FOUR   /05, 50, 58, 03, 02, 72, 00, 00, 00, 00
  901.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  902.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  903.       DATA FIVE   /10, 01, 10, 40, 62, 63, 45, 05, 08, 68
  904.      1           , 67, 00, 00, 00, 00, 00, 00, 00, 00, 00
  905.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  906.       DATA SIX    /11, 04, 54, 63, 61, 50, 10, 01, 06, 28
  907.      1           , 58, 67, 00, 00, 00, 00, 00, 00, 00, 00
  908.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  909.       DATA SEVEN  /06, 20, 23, 67, 68, 08, 07, 00, 00, 00
  910.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  911.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  912.       DATA EIGHT  /16, 14, 03, 01, 10, 50, 61, 63, 54, 14
  913.      1           , 05, 07, 18, 58, 67, 65, 54, 00, 00, 00
  914.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  915.       DATA NINE   /11, 01, 10, 40, 62, 67, 58, 18, 07, 05
  916.      1           , 14, 64, 00, 00, 00, 00, 00, 00, 00, 00
  917.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  918.       DATA COLON  /05, 22, 32, 33, 23, 22, 05, 26, 36, 37
  919.      1           , 27, 26, 00, 00, 00, 00, 00, 00, 00, 00
  920.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  921.       DATA SEMICO /06, 10, 32, 34, 24, 23, 33, 05, 26, 36
  922.      1           , 37, 27, 26, 00, 00, 00, 00, 00, 00, 00
  923.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  924.       DATA LESS   /03, 50, 14, 58, 00, 00, 00, 00, 00, 00
  925.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  926.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  927.       DATA EQUALS /02, 12, 52, 02, 16, 56, 00, 00, 00, 00
  928.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  929.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  930.       DATA GREATR /03, 10, 54, 18, 00, 00, 00, 00, 00, 00
  931.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  932.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  933.       DATA QUESTN /07, 06, 07, 18, 58, 67, 34, 33, 01, 31
  934.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  935.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  936.       DATA ATSIGN /13, 54, 45, 34, 43, 54, 64, 66, 48, 28
  937.      1           , 06, 02, 20, 50, 00, 00, 00, 00, 00, 00
  938.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  939.       DATA AUPPER /05, 00, 05, 38, 65, 60, 02, 03, 63, 00
  940.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  941.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  942.       DATA BUPPER /06, 00, 50, 61, 63, 54, 14, 05, 08, 58
  943.      1           , 67, 65, 54, 02, 18, 10, 00, 00, 00, 00
  944.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  945.       DATA CUPPER /08, 67, 58, 28, 06, 02, 20, 50, 61, 00
  946.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  947.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  948.       DATA DUPPER /06, 00, 40, 62, 66, 48, 08, 02, 18, 10
  949.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  950.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  951.       DATA EUPPER /04, 60, 00, 08, 68, 02, 34, 04, 00, 00
  952.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  953.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  954.       DATA FUPPER /03, 00, 08, 68, 02, 34, 04, 00, 00, 00
  955.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  956.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  957.       DATA GUPPER /10, 67, 58, 28, 06, 02, 20, 50, 61, 64
  958.      1           , 44, 00, 00, 00, 00, 00, 00, 00, 00, 00
  959.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  960.       DATA HUPPER /02, 00, 08, 02, 60, 68, 02, 04, 64, 00
  961.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  962.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  963.       DATA IUPPER /02, 10, 50, 02, 30, 38, 02, 18, 58, 00
  964.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  965.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  966.       DATA JUPPER /05, 01, 10, 20, 31, 38, 02, 18, 58, 00
  967.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  968.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  969.       DATA KUPPER /02, 00, 08, 02, 68, 02, 02, 24, 60, 00
  970.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  971.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  972.       DATA LUPPER /03, 08, 00, 60, 00, 00, 00, 00, 00, 00
  973.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  974.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  975.       DATA MUPPER /05, 00, 08, 35, 68, 60, 00, 00, 00, 00
  976.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  977.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  978.       DATA NUPPER /02, 00, 08, 02, 07, 61, 02, 60, 68, 00
  979.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  980.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  981.       DATA OUPPER /09, 20, 40, 62, 66, 48, 28, 06, 02, 20
  982.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  983.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  984.       DATA PUPPER /07, 00, 08, 58, 67, 66, 55, 05, 00, 00
  985.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  986.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  987.       DATA QUPPER /09, 20, 40, 62, 66, 48, 28, 06, 02, 20
  988.      1           , 02, 33, 60, 00, 00, 00, 00, 00, 00, 00
  989.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  990.       DATA RUPPER /07, 00, 08, 58, 67, 66, 55, 05, 02, 15
  991.      1           , 60, 00, 00, 00, 00, 00, 00, 00, 00, 00
  992.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  993.       DATA SUPPER /12, 01, 10, 50, 61, 63, 54, 14, 05, 07
  994.      1           , 18, 58, 67, 00, 00, 00, 00, 00, 00, 00
  995.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  996.       DATA TUPPER /02, 30, 38, 02, 08, 68, 00, 00, 00, 00
  997.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  998.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  999.       DATA UUPPER /06, 08, 01, 10, 50, 61, 68, 00, 00, 00
  1000.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1001.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1002.       DATA VUPPER /05, 08, 03, 30, 63, 68, 00, 00, 00, 00
  1003.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1004.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1005.       DATA WUPPER /05, 08, 00, 33, 60, 68, 00, 00, 00, 00
  1006.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1007.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1008.       DATA XUPPER /04, 00, 01, 67, 68, 04, 08, 07, 61, 60
  1009.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1010.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1011.       DATA YUPPER /03, 08, 35, 68, 02, 35, 30, 00, 00, 00
  1012.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1013.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1014.       DATA ZUPPER /06, 08, 68, 67, 01, 00, 60, 00, 00, 00
  1015.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1016.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1017.       DATA LBRACK /04, 40, 20, 28, 48, 00, 00, 00, 00, 00
  1018.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1019.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1020.       DATA BKSLSH /02, 07, 61, 00, 00, 00, 00, 00, 00, 00
  1021.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1022.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1023.       DATA RBRACK /04, 20, 40, 48, 28, 00, 00, 00, 00, 00
  1024.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1025.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1026.       DATA CARET  /03, 05, 38, 65, 00, 00, 00, 00, 00, 00
  1027.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1028.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1029.       DATA USCORE /02,-01,-61, 00, 00, 00, 00, 00, 00, 00
  1030.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1031.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1032.       DATA ACCENT /05, 27, 28, 38, 37, 55, 00, 00, 00, 00
  1033.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1034.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1035.       DATA ALOWER /05, 06, 26, 35, 31, 40, 07, 31, 20, 10
  1036.      1           , 01, 02, 13, 33, 00, 00, 00, 00, 00, 00
  1037.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1038.       DATA BLOWER /02, 08, 00, 08, 02, 20, 30, 41, 44, 35
  1039.      1           , 25, 03, 00, 00, 00, 00, 00, 00, 00, 00
  1040.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1041.       DATA CLOWER /08, 41, 30, 10, 01, 04, 15, 35, 44, 00
  1042.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1043.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1044.       DATA DLOWER /02, 48, 40, 08, 42, 20, 10, 01, 04, 15
  1045.      1           , 25, 43, 00, 00, 00, 00, 00, 00, 00, 00
  1046.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1047.       DATA ELOWER /10, 40, 10, 01, 04, 15, 35, 44, 43, 32
  1048.      1           , 02, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1049.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1050.       DATA FLOWER /04, 10, 17, 28, 37, 02, 04, 24, 00, 00
  1051.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1052.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1053.       DATA GLOWER /11, 40, 10, 01, 04, 15, 35, 44,-41,-23
  1054.      1           ,-13,-02, 00, 00, 00, 00, 00, 00, 00, 00
  1055.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1056.       DATA HLOWER /02, 00, 08, 05, 03, 25, 35, 44, 40, 00
  1057.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1058.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1059.       DATA ILOWER /01, 37, 03, 25, 35, 30, 02, 20, 40, 00
  1060.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1061.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1062.       DATA JLOWER /01, 37, 06, 35,-32,-23,-13,-02,-01, 00
  1063.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1064.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1065.       DATA KLOWER /02, 08, 00, 02, 01, 45, 03, 40, 22, 23
  1066.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1067.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1068.       DATA LLOWER /02, 20, 40, 03, 30, 38, 28, 00, 00, 00
  1069.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1070.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1071.       DATA MLOWER /06, 00, 04, 15, 25, 34, 30, 05, 34, 45
  1072.      1           , 55, 64, 60, 00, 00, 00, 00, 00, 00, 00
  1073.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1074.       DATA NLOWER /02, 00, 05, 05, 03, 25, 35, 44, 40, 00
  1075.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1076.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1077.       DATA OLOWER /09, 01, 04, 15, 35, 44, 41, 30, 10, 01
  1078.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1079.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1080.       DATA PLOWER /02,-03, 05, 08, 03, 25, 35, 44, 41, 30
  1081.      1           , 20, 02, 00, 00, 00, 00, 00, 00, 00, 00
  1082.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1083.       DATA QLOWER /02,-43, 45, 08, 43, 25, 15, 04, 01, 10
  1084.      1           , 20, 42, 00, 00, 00, 00, 00, 00, 00, 00
  1085.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1086.       DATA RLOWER /02, 00, 05, 04, 03, 25, 35, 44, 00, 00
  1087.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1088.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1089.       DATA SLOWER /09, 00, 30, 41, 42, 33, 13, 04, 15, 45
  1090.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1091.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1092.       DATA TLOWER /02, 06, 26, 05, 18, 11, 20, 30, 41, 00
  1093.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1094.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1095.       DATA ULOWER /05, 05, 01, 10, 20, 42, 02, 40, 45, 00
  1096.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1097.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1098.       DATA VLOWER /05, 05, 02, 20, 42, 45, 00, 00, 00, 00
  1099.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1100.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1101.       DATA WLOWER /06, 05, 01, 10, 20, 31, 35, 05, 31, 40
  1102.      1           , 50, 61, 65, 00, 00, 00, 00, 00, 00, 00
  1103.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1104.       DATA XLOWER /02, 00, 55, 02, 05, 50, 00, 00, 00, 00
  1105.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1106.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1107.       DATA YLOWER /05, 05, 01, 10, 30, 41, 05, 45,-42,-33
  1108.      1           ,-23,-12, 00, 00, 00, 00, 00, 00, 00, 00
  1109.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1110.       DATA ZLOWER /04, 05, 55, 00, 50, 00, 00, 00, 00, 00
  1111.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1112.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1113.       DATA LBRACE /06, 40, 30, 21, 23, 14, 04, 05, 14, 25
  1114.      1           , 27, 38, 48, 00, 00, 00, 00, 00, 00, 00
  1115.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1116.       DATA ORSIGN /02, 30, 38, 00, 00, 00, 00, 00, 00, 00
  1117.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1118.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1119.       DATA RBRACE /06, 20, 30, 41, 43, 54, 64, 05, 54, 45
  1120.      1           , 47, 38, 28, 00, 00, 00, 00, 00, 00, 00
  1121.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1122.       DATA TILDE  /04, 06, 28, 46, 68, 00, 00, 00, 00, 00
  1123.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1124.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1125.       DATA SPC127 /00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1126.      1           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00
  1127.      2           , 00, 00, 00, 00, 00, 00, 00, 00, 00, 00/
  1128.       END
  1129. C*GRDOT0 -- draw a dot
  1130. C+
  1131.       SUBROUTINE GRDOT0 (X,Y)
  1132. C
  1133. C GRPCKG (internal routine): Draw a single dot (pixel) at a specified
  1134. C location.
  1135. C
  1136. C Arguments:
  1137. C
  1138. C X, Y (real, input): absolute device coordinates of the dot (these
  1139. C       are rounded to the nearest integer by GRDOT0).
  1140. C--
  1141. C (1-Jun-1984)
  1142. C 22-Oct-1984 - rewrite [TJP].
  1143. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  1144. C  5-Aug-1986 - add GREXEC support [AFT].
  1145. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  1146. C-----------------------------------------------------------------------
  1147.       INCLUDE 'f77.GRPCKG1/IN'
  1148.       INTEGER  NBUF, LCHR
  1149.       REAL     X, Y, RBUF(6)
  1150.       CHARACTER CHR
  1151. C
  1152. C (X,Y) is the new current position.
  1153. C
  1154.       GRXPRE(GRCIDE) = X
  1155.       GRYPRE(GRCIDE) = Y
  1156. C
  1157. C Check window.
  1158. C
  1159.       IF (X .LT. GRXMIN(GRCIDE)) RETURN
  1160.       IF (X .GT. GRXMAX(GRCIDE)) RETURN
  1161.       IF (Y .LT. GRYMIN(GRCIDE)) RETURN
  1162.       IF (Y .GT. GRYMAX(GRCIDE)) RETURN
  1163. C
  1164. C Begin picture if necessary.
  1165. C
  1166.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1167. C
  1168. C If a "thick pen" is to be simulated, use the line-drawing routines
  1169. C instead.
  1170. C
  1171.       IF (GRWIDT(GRCIDE).GT.1) THEN
  1172.           CALL GRLIN3(X,Y,X,Y)
  1173.       ELSE
  1174.           RBUF(1)=X
  1175.           RBUF(2)=Y
  1176.           NBUF=2
  1177.           CALL GREXEC(GRGTYP,13,RBUF,NBUF,CHR,LCHR)
  1178.       END IF
  1179.       END
  1180. C*GRDOT1 -- draw dots
  1181. C+
  1182.       SUBROUTINE GRDOT1(POINTS, X, Y)
  1183.       INTEGER POINTS
  1184.       REAL X(POINTS), Y(POINTS)
  1185. C
  1186. C GRPCKG (internal routine): Draw a set of dots.
  1187. C
  1188. C Arguments:
  1189. C
  1190. C POINTS (input, integer): the number of coordinate pairs.
  1191. C X, Y (input, real arrays, dimensioned POINTS or greater): the
  1192. C       X and Y world coordinates of the points.
  1193. C--
  1194. C 14-Mar-1997 - new routine to optimize drawing many dots [TJP].
  1195. C-----------------------------------------------------------------------
  1196.       INCLUDE 'f77.GRPCKG1/IN'
  1197.       INTEGER  I, NBUF, LCHR
  1198.       REAL     RBUF(2), XP, YP
  1199.       CHARACTER CHR
  1200.       EQUIVALENCE (XP, RBUF(1)), (YP, RBUF(2))
  1201. C
  1202. C Begin picture if necessary.
  1203. C
  1204.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1205. C
  1206. C Loop for points: driver support.
  1207. C
  1208.       IF (GRWIDT(GRCIDE).LE.1) THEN
  1209.          NBUF = 2
  1210.          LCHR = 0
  1211.          DO 10 I=1,POINTS
  1212. C        -- Convert to device coordinates
  1213.             XP = X(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1214.             YP = Y(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1215. C           -- Clip against viewport
  1216.             IF (XP .GE. GRXMIN(GRCIDE) .AND.
  1217.      :          XP .LE. GRXMAX(GRCIDE) .AND.
  1218.      :          YP .GE. GRYMIN(GRCIDE) .AND.
  1219.      :          YP .LE. GRYMAX(GRCIDE)) THEN
  1220.                CALL GREXEC(GRGTYP,13,RBUF,NBUF,CHR,LCHR)
  1221.             END IF
  1222.  10      CONTINUE
  1223. C
  1224. C Thick line emulation required.
  1225. C
  1226.       ELSE
  1227.          DO 20 I=1,POINTS
  1228. C        -- Convert to device coordinates
  1229.             XP = X(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1230.             YP = Y(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1231. C           -- Clip against viewport
  1232.             IF (XP .GE. GRXMIN(GRCIDE) .AND.
  1233.      :          XP .LE. GRXMAX(GRCIDE) .AND.
  1234.      :          YP .GE. GRYMIN(GRCIDE) .AND.
  1235.      :          YP .LE. GRYMAX(GRCIDE)) THEN
  1236.                CALL GRLIN3(XP, YP, XP, YP)
  1237.             END IF
  1238.  20      CONTINUE
  1239.       END IF
  1240. C
  1241. C New pen position.
  1242. C
  1243.       GRXPRE(GRCIDE) = XP
  1244.       GRYPRE(GRCIDE) = YP
  1245. C
  1246.       END
  1247. C*GRDTYP -- decode graphics device type string
  1248. C+
  1249.       INTEGER FUNCTION GRDTYP (TEXT)
  1250. C
  1251. C GRPCKG (internal routine): determine graphics device type code from
  1252. C type name. It compares the argument with the table of known device
  1253. C types in common.
  1254. C
  1255. C Argument:
  1256. C
  1257. C TEXT (input, character): device type name, eg 'PRINTRONIX'; the name
  1258. C       may be abbreviated to uniqueness.
  1259. C
  1260. C Returns:
  1261. C
  1262. C GRDTYP (integer): the device type code, in the range 1 to
  1263. C       GRTMAX, zero if the type name is not recognised, or -1
  1264. C       if the type name is ambiguous.
  1265. C--
  1266. C 27-Dec-1984 - rewrite so that is doesn't have to be modified for
  1267. C               new devices [TJP].
  1268. C  5-Aug-1986 - add GREXEC support [AFT].
  1269. C 10-Nov-1995 - ignore drivers that report no device type [TJP].
  1270. C 30-Aug-1996 - check for an exact match; indicate if type is
  1271. C               ambiguous [TJP].
  1272. C-----------------------------------------------------------------------
  1273.       INCLUDE 'f77.GRPCKG1/IN'
  1274.       CHARACTER*(*) TEXT
  1275.       INTEGER  CODE, I, L, MATCH
  1276.       REAL     RBUF(6)
  1277.       INTEGER NDEV,NBUF,LCHR
  1278.       INTEGER GRTRIM
  1279.       CHARACTER*32 CHR
  1280. C
  1281.       GRDTYP = 0
  1282.       L = GRTRIM(TEXT)
  1283.       IF (L.LT.1) RETURN
  1284.       MATCH = 0
  1285.       CODE = 0
  1286.       CALL GREXEC(0,0,RBUF,NBUF,CHR,LCHR)
  1287.       NDEV=NINT(RBUF(1))
  1288.       DO 30 I=1,NDEV
  1289.          CALL GREXEC(I, 1,RBUF,NBUF,CHR,LCHR)
  1290.          IF (LCHR.GT.0) THEN
  1291.             IF(TEXT(1:L).EQ.CHR(1:L)) THEN
  1292.                IF (CHR(L+1:L+1).EQ.' ') THEN
  1293. C                 -- exact match
  1294.                   GRDTYP = I
  1295.                   GRGTYP = GRDTYP
  1296.                   RETURN
  1297.                ELSE
  1298.                   MATCH = MATCH+1
  1299.                   CODE = I
  1300.                END IF
  1301.             END IF
  1302.          END IF
  1303.    30 CONTINUE
  1304.       IF (MATCH.EQ.0) THEN
  1305. C        -- no match
  1306.          GRDTYP = 0
  1307.       ELSE IF (MATCH.EQ.1) THEN
  1308.          GRDTYP = CODE
  1309.          GRGTYP = GRDTYP
  1310.       ELSE
  1311.          GRDTYP = -1
  1312.       END IF
  1313. C
  1314.       END
  1315. C*GREPIC -- end picture
  1316. C+
  1317.       SUBROUTINE GREPIC
  1318. C
  1319. C GRPCKG: End the current picture.
  1320. C
  1321. C Arguments: none.
  1322. C--
  1323. C 17-Nov-1994 - [TJP].
  1324. C-----------------------------------------------------------------------
  1325.       INCLUDE 'f77.GRPCKG1/IN'
  1326.       REAL    RBUF(6)
  1327.       INTEGER NBUF,LCHR
  1328.       CHARACTER CHR
  1329. C
  1330. C Check a plot is open.
  1331. C
  1332.       IF (GRCIDE.LT.1) RETURN
  1333. C
  1334. C End picture.
  1335. C
  1336.       IF (GRPLTD(GRCIDE)) THEN
  1337.             RBUF(1) = 1.
  1338.             NBUF = 1
  1339.             CALL GREXEC(GRGTYP,14,RBUF,NBUF,CHR,LCHR)
  1340.       END IF
  1341.       GRPLTD(GRCIDE) = .FALSE.
  1342. C
  1343.       END
  1344. C*GRESC -- escape routine
  1345. C+
  1346.       SUBROUTINE GRESC (TEXT)
  1347. C
  1348. C GRPCKG: "Escape" routine. The specified text is sent directly to the
  1349. C selected graphics device, with no interpretation by GRPCKG. This
  1350. C routine must be used with care; e.g., the programmer needs to know
  1351. C the device type of the currently selected device, and the instructions
  1352. C that that device can accept.
  1353. C
  1354. C Arguments: none.
  1355. C  TEXT (input, character*(*)):  text to be sent to the device.
  1356. C
  1357. C 15-May-1985 - new routine [TJP].
  1358. C 26-May-1987 - add GREXEC support [TJP].
  1359. C 19-Dec-1988 - start new page if necessary [TJP].
  1360. C  4-Feb-1997 - RBUF should be an array, not a scalar [TJP].
  1361. C-----------------------------------------------------------------------
  1362.       INCLUDE 'f77.GRPCKG1/IN'
  1363.       CHARACTER*(*) TEXT
  1364.       REAL RBUF(1)
  1365.       INTEGER NBUF
  1366. C
  1367. C If no device is currently selected, do nothing.
  1368. C
  1369.       IF (GRCIDE.GT.0) THEN
  1370.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1371.           NBUF = 0
  1372.           CALL GREXEC(GRGTYP,23,RBUF,NBUF,TEXT,LEN(TEXT))
  1373.       END IF
  1374.       END
  1375.  
  1376. C*GRETXT -- erase text from graphics screen
  1377. C+
  1378.       SUBROUTINE GRETXT
  1379. C
  1380. C GRPCKG: Erase the text screen.  Some graphics devices have
  1381. C two superimposed view surfaces, of which one is used for graphics and
  1382. C the other for alphanumeric text.  This routine erases the text
  1383. C view surface without affecting the graphics view surface. It does
  1384. C nothing if there is no text view surface associated with the device.
  1385. C
  1386. C Arguments: none.
  1387. C--
  1388. C (1-Feb-1983)
  1389. C 16-Oct-1984 - add ID100 device [RSS/TJP].
  1390. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  1391. C  5-Aug-1986 - add GREXEC support [AFT].
  1392. C 11-Jun-1987 - remove built-in devices [TJP].
  1393. C-----------------------------------------------------------------------
  1394.       INCLUDE 'f77.GRPCKG1/IN'
  1395.       CHARACTER*1   CHR
  1396.       REAL    RBUF(6)
  1397.       INTEGER NBUF,LCHR
  1398. C
  1399.       IF (GRCIDE.GE.1) THEN
  1400.           CALL GREXEC(GRGTYP,18,RBUF,NBUF,CHR,LCHR)
  1401.       END IF
  1402. C
  1403.       END
  1404. C*GRFA -- fill area (polygon)
  1405. C+
  1406.       SUBROUTINE GRFA (N,PX,PY)
  1407.       INTEGER N
  1408.       REAL PX(*), PY(*)
  1409. C
  1410. C GRPCKG: FILL AREA: fill a polygon with solid color.  The polygon
  1411. C is defined by the (x,y) world coordinates of its N vertices.  If
  1412. C this is not a function supported by the device, shading is
  1413. C accomplished by drawing horizontal lines spaced by 1 pixel.  By
  1414. C selecting color index 0, the interior of the polygon can be erased
  1415. C on devices which permit it.  The polygon need not be convex, but if
  1416. C it is re-entrant (i.e., edges intersect other than at the vertices),
  1417. C it may not be obvious which regions are "inside" the polygon.  The
  1418. C following rule is applied: for a given point, create a straight line
  1419. C starting at the point and going to infinity. If the number of
  1420. C intersections between the straight line and the polygon is odd, the
  1421. C point is within the polygon; otherwise it is outside. If the
  1422. C straight line passes a polygon vertex tangentially, the
  1423. C intersection  count is not affected. The only attribute which applies
  1424. C to FILL AREA is color index: line-width and line-style are ignored.
  1425. C There is a limitation on the complexity of the polygon: GFA will
  1426. C fail if any horizontal line intersects more than 32 edges of the
  1427. C polygon.
  1428. C
  1429. C Arguments:
  1430. C
  1431. C N (input, integer): the number of vertices of the polygon (at least
  1432. C       3).
  1433. C PX, PY (input, real arrays, dimension at least N): world coordinates
  1434. C       of the N vertices of the polygon.
  1435. C--
  1436. C 16-Jul-1984 - [TJP].
  1437. C  5-Aug-1986 - add GREXEC support [AFT].
  1438. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  1439. C  7-Sep-1994 - avoid driver call for capabilities [TJP].
  1440. C  1-May-1995 - fixed bug for re-entrant polygons, and optimized code
  1441. C               [A.F.Carman].
  1442. C 18-Oct-1995 - fixed bug: emulated fill failed for reversed y-axis
  1443. C               [S.C.Allendorf/TJP].
  1444. C  4-Dec-1995 - remove use of real variable as do-loop variable [TJP].
  1445. C 20-Mar-1996 - use another do loop 40 to avoid gaps between adjacent
  1446. C               polygons [RS]
  1447. C-----------------------------------------------------------------------
  1448.       INCLUDE 'f77.GRPCKG1/IN'
  1449.       INTEGER MAXSEC
  1450.       PARAMETER (MAXSEC=32)
  1451.       INTEGER I, J, NSECT, LW, LS, NBUF, LCHR, LINE
  1452.       REAL    RBUF(6)
  1453.       CHARACTER*32 CHR
  1454.       REAL    X(MAXSEC), Y, YMIN, YMAX, DY, YD, TEMP, S1, S2, T1, T2
  1455.       LOGICAL FORWD
  1456. C
  1457.       IF (GRCIDE.LT.1) RETURN
  1458.       IF (N.LT.3) THEN
  1459.           CALL GRWARN('GRFA - polygon has < 3 vertices.')
  1460.           RETURN
  1461.       END IF
  1462. C
  1463. C Devices with polygon fill capability.
  1464. C
  1465.       IF(GRGCAP(GRCIDE)(4:4).EQ.'A') THEN
  1466.          IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1467.          RBUF(1) = N
  1468.          CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  1469.          DO 10 I=1,N
  1470.             RBUF(1) = PX(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1471.             RBUF(2) = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1472.             CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  1473.  10      CONTINUE
  1474.          RETURN
  1475.       END IF
  1476. C
  1477. C For other devices fill area is simulated.
  1478. C
  1479. C Save attributes.
  1480. C
  1481.       CALL GRQLS(LS)
  1482.       CALL GRQLW(LW)
  1483.       CALL GRSLS(1)
  1484.       CALL GRSLW(1)
  1485. C
  1486. C Find range of raster-lines to be shaded.
  1487. C
  1488.       YMIN = PY(1)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1489.       YMAX = YMIN
  1490.       DO 20 I=2,N
  1491.          YD = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1492.          YMIN = MIN(YMIN,YD)
  1493.          YMAX = MAX(YMAX,YD)
  1494.  20   CONTINUE
  1495.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  1496.       DY = ABS(RBUF(3))
  1497. C
  1498. C Find intersections of edges with current raster line.
  1499. C
  1500.       FORWD = .TRUE.
  1501.       S1 = PX(N)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1502.       T1 = PY(N)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1503. C
  1504.       DO 40 LINE = NINT(YMIN/DY),NINT(YMAX/DY)
  1505.          Y = LINE * DY
  1506.          NSECT = 0
  1507.          DO 30 I=1,N
  1508.             S2 = PX(I)*GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  1509.             T2 = PY(I)*GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  1510.             IF ((T1.LT.Y .AND. Y.LE.T2).OR.
  1511.      :          (T1.GE.Y .AND. Y.GT.T2)) THEN
  1512.                NSECT = NSECT+1
  1513.                IF (NSECT.GT.MAXSEC) THEN
  1514.                   CALL GRWARN('GRFA - polygon is too complex.')
  1515.                   RETURN
  1516.                END IF
  1517.                X(NSECT)=(S1+(S2-S1)*((Y-T1)/(T2-T1)))
  1518.             END IF
  1519.             S1 = S2
  1520.             T1 = T2
  1521.  30      CONTINUE
  1522. C
  1523. C Sort the intersections into increasing x order.
  1524. C
  1525.          DO 34 I=2,NSECT
  1526.             DO 32 J=1,I
  1527.                IF (X(J).GT.X(I)) THEN
  1528.                   TEMP = X(J)
  1529.                   X(J) = X(I)
  1530.                   X(I) = TEMP
  1531.                END IF
  1532.  32         CONTINUE
  1533.  34      CONTINUE
  1534. C
  1535. C Draw the horizontal line-segments.
  1536. C
  1537.          GRYPRE(GRCIDE) = Y
  1538.          IF (FORWD) THEN
  1539.             DO 36 I=1,NSECT-1,2
  1540.                GRXPRE(GRCIDE) = X(I)
  1541.                CALL GRLIN0(X(I+1),Y)
  1542.  36         CONTINUE
  1543.             FORWD = .FALSE.
  1544.          ELSE
  1545.             DO 38 I=NSECT,2,-2
  1546.                GRXPRE(GRCIDE) = X(I)
  1547.                CALL GRLIN0(X(I-1),Y)
  1548.  38         CONTINUE
  1549.             FORWD = .TRUE.
  1550.          END IF
  1551.  40   CONTINUE
  1552. C
  1553. C Restore attributes.
  1554. C
  1555.       CALL GRSLS(LS)
  1556.       CALL GRSLW(LW)
  1557.       END
  1558. C*GRFAO - format character string containing integers
  1559. C+
  1560.       SUBROUTINE GRFAO (FORMAT, L, STR, V1, V2, V3, V4)
  1561.       CHARACTER*(*) FORMAT
  1562.       INTEGER L
  1563.       CHARACTER*(*) STR
  1564.       INTEGER V1, V2, V3, V4
  1565. C
  1566. C The input string FORMAT is copied to the output string STR with
  1567. C the first occurrence of '#' replaced by the value of V1, the second
  1568. C by the value of V2, etc.  The length of the resulting string is 
  1569. C returned in L.
  1570. C-----------------------------------------------------------------------
  1571.       INTEGER I,Q,VAL,GRITOC
  1572. C
  1573.       L = 0
  1574.       Q = 0
  1575.       DO 10 I=1,LEN(FORMAT)
  1576.           IF (L.GE.LEN(STR)) RETURN
  1577.           IF (FORMAT(I:I).NE.'#') THEN
  1578.               L = L+1
  1579.               STR(L:L) = FORMAT(I:I)
  1580.           ELSE
  1581.               Q = Q+1
  1582.               VAL = 0
  1583.               IF (Q.EQ.1) VAL = V1
  1584.               IF (Q.EQ.2) VAL = V2
  1585.               IF (Q.EQ.3) VAL = V3
  1586.               IF (Q.EQ.4) VAL = V4
  1587.               L = L + GRITOC(VAL, STR(L+1:))
  1588.           END IF
  1589.    10 CONTINUE
  1590. C-----------------------------------------------------------------------
  1591.       END
  1592. C*GRGFIL -- find data file
  1593. C+
  1594.       SUBROUTINE GRGFIL(TYPE, NAME)
  1595.       CHARACTER*(*) TYPE, NAME
  1596. C
  1597. C This routine encsapsulates the algorithm for finding the PGPLOT
  1598. C run-time data files.
  1599. C
  1600. C 1. The binary font file: try the following in order:
  1601. C     file specified by PGPLOT_FONT
  1602. C     file "grfont.dat" in directory specified by PGPLOT_DIR
  1603. C                       (with or without '/' appended)
  1604. C     file "grfont.dat" in directory /usr/local/pgplot/
  1605. C
  1606. C 2. The color-name database: try the following in order:
  1607. C     file specified by PGPLOT_RGB
  1608. C     file "rgb.txt" in directory specified by PGPLOT_DIR
  1609. C                       (with or without '/' appended)
  1610. C     file "rgb.txt" in directory /usr/local/pgplot/
  1611. C
  1612. C Arguments:
  1613. C  TYPE (input)  : either 'FONT' or 'RGB' to request the corresponding
  1614. C                  file.
  1615. C  NAME (output) : receives the file name.
  1616. C--
  1617. C  2-Dec-1994 - new routine [TJP].
  1618. C-----------------------------------------------------------------------
  1619.       CHARACTER*(*) DEFDIR, DEFFNT, DEFRGB
  1620.       PARAMETER  (DEFDIR='/usr/local/pgplot/')
  1621.       PARAMETER  (DEFFNT='grfont.dat')
  1622.       PARAMETER  (DEFRGB='rgb.txt')
  1623.       CHARACTER*255 FF
  1624.       CHARACTER*16 DEFLT
  1625.       INTEGER I, L, LD
  1626.       LOGICAL TEST, DEBUG
  1627. C
  1628. C Is debug output requested?
  1629. C
  1630.       CALL GRGENV('DEBUG', FF, L)
  1631.       DEBUG = L.GT.0
  1632. C
  1633. C Which file?
  1634. C
  1635.       IF (TYPE.EQ.'FONT') THEN
  1636.          DEFLT = DEFFNT
  1637.          LD = LEN(DEFFNT)
  1638.       ELSE IF (TYPE.EQ.'RGB') THEN
  1639.          DEFLT = DEFRGB
  1640.          LD = LEN(DEFRGB)
  1641.       ELSE
  1642.          CALL GRWARN('Internal error in routine GRGFIL')
  1643.       END IF
  1644. C
  1645. C Try each possibility in turn.
  1646. C
  1647.       DO 10 I=1,4
  1648.          IF (I.EQ.1) THEN
  1649.             CALL GRGENV(TYPE, FF, L)
  1650.          ELSE IF (I.EQ.2) THEN
  1651.             CALL GRGENV('DIR', FF, L)
  1652.             IF (L.GT.0) THEN
  1653.                FF(L+1:) = DEFLT
  1654.                L = L+LD
  1655.             END IF
  1656.          ELSE IF (I.EQ.3) THEN
  1657.             CALL GRGENV('DIR', FF, L)
  1658.             IF (L.GT.0) THEN
  1659.                FF(L+1:L+1) = '/'
  1660.                FF(L+2:) = DEFLT
  1661.                L = L+1+LD
  1662.             END IF
  1663.          ELSE IF (I.EQ.4) THEN
  1664.             FF = DEFDIR//DEFLT
  1665.             L = LEN(DEFDIR)+LD
  1666.          END IF
  1667.          IF (L.GT.0) THEN
  1668.             IF (DEBUG) THEN
  1669.                CALL GRWARN('Looking for '//FF(:L))
  1670.             END IF
  1671.             INQUIRE (FILE=FF(:L), EXIST=TEST)
  1672.             IF (TEST) THEN
  1673.                NAME = FF(:L)
  1674.                RETURN
  1675.             ELSE IF (DEBUG) THEN
  1676.                CALL GRWARN('WARNING: file not found')
  1677.             END IF
  1678.          END IF
  1679.  10   CONTINUE
  1680. C
  1681. C Failed to find the file.
  1682. C
  1683.       NAME = DEFLT
  1684. C-----------------------------------------------------------------------
  1685.       END
  1686. C*GRGRAY -- gray-scale map of a 2D data array
  1687. C+
  1688.       SUBROUTINE GRGRAY (A, IDIM, JDIM, I1, I2, J1, J2,
  1689.      1                   FG, BG, PA, MININD, MAXIND, MODE)
  1690.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1691.       REAL    A(IDIM,JDIM)
  1692.       REAL    FG, BG
  1693.       REAL    PA(6)
  1694. C
  1695. C This is a device-dependent support routine for PGGRAY.
  1696. C
  1697. C Draw gray-scale map of an array in current window. Array
  1698. C values between FG and BG are shaded in gray levels determined
  1699. C by linear interpolation. FG may be either less than or greater
  1700. C than BG.  Array values outside the range FG to BG are
  1701. C shaded black or white as appropriate.
  1702. C
  1703. C GRGRAY uses GRIMG0 on devices with enough color indices available.
  1704. C Note that it changes the color table to gray-scale.
  1705. C Otherwise in does a random dither with GRIMG3.
  1706. C
  1707. C Arguments:
  1708. C  A      (input)  : the array to be plotted.
  1709. C  IDIM   (input)  : the first dimension of array A.
  1710. C  JDIM   (input)  : the second dimension of array A.
  1711. C  I1, I2 (input)  : the inclusive range of the first index
  1712. C                    (I) to be plotted.
  1713. C  J1, J2 (input)  : the inclusive range of the second
  1714. C                    index (J) to be plotted.
  1715. C  FG     (input)  : the array value which is to appear in
  1716. C                    foreground color.
  1717. C  BG     (input)  : the array value which is to appear in
  1718. C                    background color.
  1719. C  PA     (input)  : transformation matrix between array grid and
  1720. C                    device coordinates (see GRCONT).
  1721. C  MODE   (input)  : transfer function.
  1722. C--
  1723. C 12-Dec-1986 - Speed up plotting [J. Biretta].
  1724. C  3-Apr-1987 - Add special code for /PS, /VPS, /GR.
  1725. C  2-Sep-1987 - Adapted from PGGRAY [TJP].
  1726. C  1-Dec-1988 - Put random-number generator inline [TJP].
  1727. C  3-Apr-1989 - Use "line of pixels" primitive where available [TJP].
  1728. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  1729. C 19-Jan-1990 - Add special code for /CPS, /VCPS [DLM]
  1730. C  3-Sep-1992 - Add special code for NULL device [TJP].
  1731. C 25-Nov-1992 - Add special code for /NEXT [AFT].
  1732. C 17-Mar-1994 - Scale in device coordinates [TJP].
  1733. C 31-Aug-1994 - use GRIMG0 when appropriate [TJP].
  1734. C  7-Sep-1994 - speed up random dither [TJP].
  1735. C  8-Feb-1995 - use color ramp based on color indices 0 and 1 [TJP].
  1736. C-----------------------------------------------------------------------
  1737.       INCLUDE 'f77.GRPCKG1/IN'
  1738.       INTEGER I
  1739.       REAL    A0, A1, CR0, CG0, CB0, CR1, CG1, CB1
  1740.       INTRINSIC REAL
  1741. C-----------------------------------------------------------------------
  1742. C
  1743. C N.B. Arguments are assumed to be valid (checked by PGGRAY).
  1744. C
  1745. C Use GRIMG0 if this an appropriate device; first initialize the
  1746. C color table to a linear ramp between the colors assigned to color
  1747. C indices 0 and 1.
  1748. C
  1749.       IF (GRGCAP(GRCIDE)(7:7).NE.'N' .AND. MAXIND-MININD .GT. 15) THEN
  1750.          CALL GRQCR(0, CR0, CG0, CB0)
  1751.          CALL GRQCR(1, CR1, CG1, CB1)
  1752.          DO 5 I=MININD,MAXIND
  1753.             A0 = REAL(I-MININD)/REAL(MAXIND-MININD)
  1754.             A1 = 1.0 - A0
  1755.             CALL GRSCR(I, A0*CR0+A1*CR1, A0*CG0+A1*CG1, A0*CB0+A1*CB1)
  1756.  5       CONTINUE
  1757.          CALL GRIMG0(A, IDIM, JDIM, I1, I2, J1, J2,
  1758.      :               FG, BG, PA, MININD, MAXIND, MODE)
  1759.          RETURN
  1760. C
  1761. C Otherwise use random dither in current color index.
  1762. C
  1763.       ELSE
  1764.          CALL GRIMG3(A, IDIM, JDIM, I1, I2, J1, J2,
  1765.      :               FG, BG, PA, MODE)
  1766.       END IF
  1767. C-----------------------------------------------------------------------
  1768.       END
  1769.  
  1770. C*GRGTC0 -- obtain character digitization
  1771. C+
  1772.       SUBROUTINE GRGTC0 (CHAR,CENTER,POINTS,X,Y,MORE)
  1773. C
  1774. C GRPCKG (internal routine): obtain character digitization.
  1775. C
  1776. C (10-Feb-1983)
  1777. C-----------------------------------------------------------------------
  1778.       EXTERNAL GRDAT2
  1779.       LOGICAL CENTER
  1780.       INTEGER POINTS, CHAR
  1781.       REAL X(1)
  1782.       REAL Y(1)
  1783.       LOGICAL MORE
  1784. C
  1785.       INTEGER CINDX1, CINDX2
  1786.       INTEGER CTD1, CTD2
  1787.       PARAMETER (CTD1 = 30, CTD2 = 128)
  1788.       INTEGER CHTBL(CTD1, CTD2)
  1789.       COMMON /GRCS02/ CINDX1, CINDX2, CHTBL
  1790. C
  1791.       INTEGER I
  1792.       INTEGER COORDS
  1793.       LOGICAL TAILED
  1794. C-----------------------------------------------------------------------
  1795.       IF (CINDX2.LE.0) CINDX2 = CHAR + 1
  1796. C
  1797. C Get the next segment of the character.
  1798. C
  1799.       POINTS = CHTBL(CINDX1, CINDX2)
  1800.       IF(POINTS .EQ. 0) GO TO 240
  1801.       DO 220 I = 1, POINTS
  1802.           CINDX1 = CINDX1 + 1
  1803.           COORDS = CHTBL(CINDX1, CINDX2)
  1804.           TAILED = COORDS .LT. 0
  1805.           IF(TAILED) COORDS = IABS(COORDS)
  1806.           X(I) = FLOAT(COORDS / 10)
  1807.           Y(I) = FLOAT(MOD(COORDS, 10))
  1808.           IF(TAILED) Y(I) = - Y(I)
  1809.           IF(.NOT. CENTER) GO TO 220
  1810.           X(I) = X(I) - 3.0
  1811.           Y(I) = Y(I) - 4.0
  1812.   220     CONTINUE
  1813.   240 CONTINUE
  1814. C
  1815. C Set status and return.
  1816. C
  1817.       IF(CINDX1 .EQ. CTD1) GO TO 320
  1818.       CINDX1 = CINDX1 + 1
  1819.       IF(CHTBL(CINDX1, CINDX2) .EQ. 0) GO TO 320
  1820.       MORE = .TRUE.
  1821.       RETURN
  1822.   320 MORE = .FALSE.
  1823.       CINDX1 = 1
  1824.       CINDX2 = 0
  1825.       RETURN
  1826.       END
  1827. C*GRIMG0 -- color image of a 2D data array
  1828. C+
  1829.       SUBROUTINE GRIMG0 (A, IDIM, JDIM, I1, I2, J1, J2,
  1830.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1831.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1832.       REAL    A(IDIM,JDIM), A1, A2, PA(6)
  1833. C
  1834. C This is a support routine for PGIMAG.
  1835. C
  1836. C Arguments:
  1837. C  A      (input)  : the array to be plotted.
  1838. C  IDIM   (input)  : the first dimension of array A.
  1839. C  JDIM   (input)  : the second dimension of array A.
  1840. C  I1, I2 (input)  : the inclusive range of the first index
  1841. C                    (I) to be plotted.
  1842. C  J1, J2 (input)  : the inclusive range of the second
  1843. C                    index (J) to be plotted.
  1844. C  A1     (input)  : the array value which is to appear in color
  1845. C                    index MININD.
  1846. C  A2     (input)  : the array value which is to appear in color
  1847. C                    index MAXIND.
  1848. C  PA     (input)  : transformation matrix between array grid and
  1849. C                    device coordinates.
  1850. C  MININD (input)  : minimum color index to use.
  1851. C  MAXIND (input)  : maximum color index to use.
  1852. C  MODE   (input)  : =0 for linear, =1 for logarithmic, =2 for
  1853. C                    square-root mapping of array values to color
  1854. C                    indices.
  1855. C--
  1856. C  7-Sep-1994 - new routine [TJP].
  1857. C-----------------------------------------------------------------------
  1858.       INCLUDE 'f77.GRPCKG1/IN'
  1859.       CHARACTER C
  1860. C-----------------------------------------------------------------------
  1861. C
  1862. C Switch on type of device support.
  1863. C
  1864.       C = GRGCAP(GRCIDE)(7:7)
  1865.       IF (C.EQ.'Q') THEN
  1866. C         -- Image-primitive devices
  1867.           CALL GRIMG1(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  1868.      :                MININD, MAXIND, MODE)
  1869.       ELSE IF (C.EQ.'P') THEN
  1870. C         -- Pixel-primitive devices         
  1871.           CALL GRIMG2(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  1872.      :                MININD, MAXIND, MODE)
  1873.       ELSE IF (C.EQ.'N') THEN
  1874. C         -- Other devices
  1875.           CALL GRWARN(
  1876.      :     'images cannot be displayed on the selected device')
  1877.       ELSE
  1878. C         -- Unknown device code
  1879.           CALL GRWARN('unexpected error in routine GRIMG0')
  1880.       END IF
  1881. C-----------------------------------------------------------------------
  1882.       END
  1883. C*GRIMG1 -- image of a 2D data array (image-primitive devices)
  1884. C+
  1885.       SUBROUTINE GRIMG1 (A, IDIM, JDIM, I1, I2, J1, J2,
  1886.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1887.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1888.       REAL    A(IDIM,JDIM), A1, A2, PA(6)
  1889. C
  1890. C (This routine is called by GRIMG0.)
  1891. C--
  1892. C 7-Sep-1994  New routine [TJP].
  1893. C-----------------------------------------------------------------------
  1894.       INCLUDE 'f77.GRPCKG1/IN'
  1895.       INTEGER NBUF, LCHR
  1896.       REAL    RBUF(21), FAC, AV, SFAC, SFACL
  1897.       CHARACTER*1 CHR
  1898.       INTEGER  I, J, II, NXP, NYP, IV
  1899.       INTRINSIC NINT, LOG
  1900.       PARAMETER (SFAC=65000.0)
  1901. C-----------------------------------------------------------------------
  1902. C Size of image.
  1903. C
  1904.       NXP = I2 - I1 + 1
  1905.       NYP = J2 - J1 + 1
  1906.       RBUF(1) = 0.0
  1907.       RBUF(2) = NXP
  1908.       RBUF(3) = NYP
  1909. C
  1910. C Clipping rectangle.
  1911. C
  1912.       RBUF(4) = GRXMIN(GRCIDE)
  1913.       RBUF(5) = GRXMAX(GRCIDE)
  1914.       RBUF(6) = GRYMIN(GRCIDE)
  1915.       RBUF(7) = GRYMAX(GRCIDE)
  1916. C
  1917. C Image transformation matrix.
  1918. C
  1919.       FAC = PA(2)*PA(6) - PA(3)*PA(5)
  1920.       RBUF(8)  =  PA(6)/FAC
  1921.       RBUF(9)  = (-PA(5))/FAC
  1922.       RBUF(10) = (-PA(3))/FAC
  1923.       RBUF(11) =  PA(2)/FAC
  1924.       RBUF(12) = (PA(3)*PA(4) - PA(1)*PA(6))/FAC - (I1-0.5)
  1925.       RBUF(13) = (PA(5)*PA(1) - PA(4)*PA(2))/FAC - (J1-0.5)
  1926. C
  1927. C Send setup info to driver.
  1928. C
  1929.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  1930.       CALL GRTERM
  1931.       NBUF = 13
  1932.       LCHR = 0
  1933.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1934. C
  1935. C Convert image array to color indices and send to driver.
  1936. C
  1937.       SFACL = LOG(1.0+SFAC)
  1938.       II = 0
  1939.       DO 20 J = J1,J2
  1940.           DO 10 I = I1,I2
  1941.               AV = A(I,J)
  1942.               IF (A2.GT.A1) THEN
  1943.                   AV = MIN(A2, MAX(A1,AV))
  1944.               ELSE
  1945.                   AV = MIN(A1, MAX(A2,AV))
  1946.               END IF
  1947.               IF (MODE.EQ.0) THEN
  1948.                 IV = NINT((MININD*(A2-AV) + MAXIND*(AV-A1))/(A2-A1))
  1949.               ELSE IF (MODE.EQ.1) THEN
  1950.                 IV = MININD + NINT((MAXIND-MININD)*
  1951.      :               LOG(1.0+SFAC*ABS((AV-A1)/(A2-A1)))/SFACL)
  1952.               ELSE IF (MODE.EQ.2) THEN
  1953.                 IV = MININD + NINT((MAXIND-MININD)*
  1954.      :                             SQRT(ABS((AV-A1)/(A2-A1))))
  1955.               ELSE
  1956.                 IV = MININD
  1957.               END IF
  1958.               II = II + 1
  1959.               RBUF(II+1) = IV
  1960.               IF (II.EQ.20) THEN
  1961.                   NBUF = II + 1
  1962.                   RBUF(1) = II
  1963.                   CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1964.                   II = 0
  1965.               END IF
  1966.    10     CONTINUE
  1967.    20 CONTINUE
  1968.       IF (II.GT.0) THEN
  1969.           NBUF = II + 1
  1970.           RBUF(1) = II
  1971.           CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1972.           II = 0
  1973.       END IF
  1974. C
  1975. C Send termination code to driver.
  1976. C
  1977.       NBUF = 1
  1978.       RBUF(1) = -1
  1979.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  1980. C-----------------------------------------------------------------------
  1981.       END
  1982. C*GRIMG2 -- image of a 2D data array (pixel-primitive devices)
  1983. C+
  1984.       SUBROUTINE GRIMG2 (A, IDIM, JDIM, I1, I2, J1, J2,
  1985.      1                   A1, A2, PA, MININD, MAXIND, MODE)
  1986.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MININD, MAXIND, MODE
  1987.       REAL    A(IDIM,JDIM)
  1988.       REAL    A1, A2
  1989.       REAL    PA(6)
  1990. C
  1991. C (This routine is called by GRIMG0.)
  1992. C--
  1993. C 7-Sep-1994  New routine [TJP].
  1994. C-----------------------------------------------------------------------
  1995.       INCLUDE 'f77.GRPCKG1/IN'
  1996.       INTEGER  I,IV,IX,IX1,IX2,IY,IY1,IY2,J, NPIX, LCHR
  1997.       REAL     DEN, AV, SFAC, SFACL
  1998.       REAL     XXAA,XXBB,YYAA,YYBB,XYAA,XYBB,YXAA,YXBB,XYAAIY,YXAAIY
  1999.       REAL     BUFFER(1026)
  2000.       CHARACTER*1 CHR
  2001.       INTRINSIC NINT, LOG
  2002.       PARAMETER (SFAC=65000.0)
  2003. C-----------------------------------------------------------------------
  2004. C
  2005. C Location of current window in device coordinates.
  2006. C
  2007.       IX1 = NINT(GRXMIN(GRCIDE))+1
  2008.       IX2 = NINT(GRXMAX(GRCIDE))-1
  2009.       IY1 = NINT(GRYMIN(GRCIDE))+1
  2010.       IY2 = NINT(GRYMAX(GRCIDE))-1
  2011. C
  2012. C Transformation from array coordinates to device coordinates.
  2013. C
  2014.       DEN = PA(2)*PA(6)-PA(3)*PA(5)
  2015.       XXAA = (-PA(6))*PA(1)/DEN
  2016.       XXBB = PA(6)/DEN
  2017.       XYAA = (-PA(3))*PA(4)/DEN
  2018.       XYBB = PA(3)/DEN
  2019.       YYAA = (-PA(2))*PA(4)/DEN
  2020.       YYBB = PA(2)/DEN
  2021.       YXAA = (-PA(5))*PA(1)/DEN
  2022.       YXBB = PA(5)/DEN
  2023. C
  2024. C Start a new page if necessary.
  2025. C
  2026.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  2027. C
  2028. C Run through every device pixel (IX, IY) in the current window and
  2029. C determine which array pixel (I,J) it falls in.
  2030. C
  2031.       SFACL = LOG(1.0+SFAC)
  2032.       DO 120 IY=IY1,IY2
  2033.           XYAAIY = XXAA-XYAA-XYBB*IY
  2034.           YXAAIY = YYAA+YYBB*IY-YXAA
  2035.           NPIX = 0
  2036.           BUFFER(2) = IY
  2037.           DO 110 IX=IX1,IX2
  2038.             I = NINT(XYAAIY+XXBB*IX)
  2039.             IF (I.LT.I1.OR.I.GT.I2) GOTO 110
  2040.             J = NINT(YXAAIY-YXBB*IX)
  2041.             IF (J.LT.J1.OR.J.GT.J2) GOTO 110
  2042. C
  2043. C           -- determine color index IV of this pixel
  2044. C
  2045.             AV = A(I,J)
  2046.             IF (A2.GT.A1) THEN
  2047.                 AV = MIN(A2, MAX(A1,AV))
  2048.             ELSE
  2049.                 AV = MIN(A1, MAX(A2,AV))
  2050.             END IF
  2051.             IF (MODE.EQ.0) THEN
  2052.                 IV = NINT((MININD*(A2-AV) + MAXIND*(AV-A1))/(A2-A1))
  2053.             ELSE IF (MODE.EQ.1) THEN
  2054.                 IV = MININD + NINT((MAXIND-MININD)*
  2055.      :               LOG(1.0+SFAC*ABS((AV-A1)/(A2-A1)))/SFACL)
  2056.             ELSE IF (MODE.EQ.2) THEN
  2057.                 IV = MININD + NINT((MAXIND-MININD)*
  2058.      :                             SQRT(ABS((AV-A1)/(A2-A1))))
  2059.             ELSE
  2060.                 IV = MININD
  2061.             END IF
  2062. C
  2063.             IF (NPIX.LE.1024) THEN
  2064. C               -- drop pixels if buffer too small (to be fixed!)
  2065.                 NPIX = NPIX+1
  2066.                 IF (NPIX.EQ.1) BUFFER(1) = IX
  2067.                 BUFFER(NPIX+2) = IV
  2068.             END IF
  2069.   110     CONTINUE
  2070.           IF (NPIX.GT.0) CALL 
  2071.      :                   GREXEC(GRGTYP, 26, BUFFER, NPIX+2, CHR, LCHR)
  2072.   120 CONTINUE
  2073. C-----------------------------------------------------------------------
  2074.       END
  2075. C*GRIMG3 -- gray-scale map of a 2D data array, using dither
  2076. C+
  2077.       SUBROUTINE GRIMG3 (A, IDIM, JDIM, I1, I2, J1, J2,
  2078.      1                   BLACK, WHITE, PA, MODE)
  2079.       INTEGER IDIM, JDIM, I1, I2, J1, J2, MODE
  2080.       REAL    A(IDIM,JDIM)
  2081.       REAL    BLACK, WHITE
  2082.       REAL    PA(6)
  2083. C--
  2084. C 2-Sep-1994 - moved from GRGRAY [TJP].
  2085. C-----------------------------------------------------------------------
  2086.       INCLUDE 'f77.GRPCKG1/IN'
  2087.       INTEGER  I,IX,IX1,IX2,IY,IY1,IY2,J
  2088.       REAL     DEN,VALUE,BW
  2089.       REAL     XXAA,XXBB,YYAA,YYBB,XYAA,XYBB,YXAA,YXBB,XYAAIY,YXAAIY
  2090.       INTEGER  M, IAA, ICC, JRAN, ILAST, JLAST, IXSTEP, IYSTEP
  2091.       REAL     RAND, RM, FAC, FACL
  2092.       PARAMETER (M=714025, IAA=1366, ICC=150889, RM=1.0/M)
  2093.       PARAMETER (FAC=65000.0)
  2094.       INTRINSIC MOD, NINT, REAL, LOG
  2095. C-----------------------------------------------------------------------
  2096. C
  2097.       IF (MODE.LT.0 .OR. MODE.GT.2) RETURN
  2098. C
  2099. C Initialize random-number generator (based on RAN2 of Press et al.,
  2100. C Numerical Recipes)
  2101. C
  2102.       JRAN = 76773
  2103. C
  2104.       IX1 = NINT(GRXMIN(GRCIDE))+1
  2105.       IX2 = NINT(GRXMAX(GRCIDE))-1
  2106.       IY1 = NINT(GRYMIN(GRCIDE))+1
  2107.       IY2 = NINT(GRYMAX(GRCIDE))-1
  2108.       DEN = PA(2)*PA(6)-PA(3)*PA(5)
  2109. C
  2110. C Calculate constants.
  2111. C
  2112.       BW   = ABS(BLACK-WHITE)
  2113.       FACL = LOG(1.0+FAC)
  2114.       XXAA = (-PA(6))*PA(1)/DEN
  2115.       XXBB = PA(6)/DEN
  2116.       XYAA = (-PA(3))*PA(4)/DEN
  2117.       XYBB = PA(3)/DEN
  2118.       YYAA = (-PA(2))*PA(4)/DEN
  2119.       YYBB = PA(2)/DEN
  2120.       YXAA = (-PA(5))*PA(1)/DEN
  2121.       YXBB = PA(5)/DEN
  2122. C
  2123. C Choose step size: at least 1/200 inch, assuming the line-width
  2124. C unit is 1/200 inch.
  2125. C
  2126.       IXSTEP = MAX(1,NINT(GRWIDT(GRCIDE)*GRPXPI(GRCIDE)/200.0))
  2127.       IYSTEP = MAX(1,NINT(GRWIDT(GRCIDE)*GRPYPI(GRCIDE)/200.0))
  2128. C
  2129. C Draw dots.
  2130. C
  2131.       ILAST = 0
  2132.       JLAST = 0
  2133.       DO 120 IY=IY1,IY2,IYSTEP
  2134.           XYAAIY = XXAA-XYAA-XYBB*IY
  2135.           YXAAIY = YYAA+YYBB*IY-YXAA
  2136.           DO 110 IX=IX1,IX2,IXSTEP
  2137.               I = NINT(XYAAIY+XXBB*IX)
  2138.               IF (I.LT.I1.OR.I.GT.I2) GOTO 110
  2139.               J = NINT(YXAAIY-YXBB*IX)
  2140.               IF (J.LT.J1.OR.J.GT.J2) GOTO 110
  2141.               IF (I.NE.ILAST .OR. J.NE.JLAST) THEN
  2142.                   ILAST = I
  2143.                   JLAST = J
  2144.                   VALUE = ABS(A(I,J)-WHITE)/BW
  2145.                   IF (MODE.EQ.0) THEN
  2146. C                     -- "linear"
  2147.                       CONTINUE
  2148.                   ELSE IF (MODE.EQ.1) THEN
  2149. C                     -- "logarithmic"
  2150.                       VALUE = LOG(1.0+FAC*VALUE)/FACL
  2151.                   ELSE IF (MODE.EQ.2) THEN
  2152. C                     -- "square root"
  2153.                       VALUE = SQRT(VALUE)
  2154.                   END IF
  2155.               END IF
  2156.               JRAN = MOD(JRAN*IAA+ICC, M)
  2157.               RAND = JRAN*RM
  2158.               IF (VALUE.GT.RAND) CALL GRDOT0(REAL(IX),REAL(IY))
  2159.   110     CONTINUE
  2160.   120  CONTINUE
  2161. C-----------------------------------------------------------------------
  2162.        END
  2163. C*GRINIT -- initialize GRPCKG
  2164. C+
  2165.       SUBROUTINE GRINIT
  2166. C
  2167. C Initialize GRPCKG and read font file. Called by GROPEN, but may be 
  2168. C called explicitly if needed.
  2169. C--
  2170. C 29-Apr-1996 - new routine [TJP].
  2171. C-----------------------------------------------------------------------
  2172.       INCLUDE 'f77.GRPCKG1/IN'
  2173.       INTEGER   I
  2174.       LOGICAL   INIT
  2175.       SAVE      INIT
  2176.       DATA      INIT / .TRUE. /
  2177. C
  2178.       IF (INIT) THEN
  2179.          DO 10 I=1,GRIMAX
  2180.             GRSTAT(I) = 0
  2181.  10      CONTINUE
  2182.          CALL GRSY00
  2183.          INIT = .FALSE.
  2184.       END IF
  2185.       RETURN
  2186.       END
  2187. C*GRINQFONT -- inquire current font [obsolete]
  2188. C
  2189.       SUBROUTINE GRINQFONT (IF)
  2190.       INTEGER IF
  2191.       CALL GRQFNT(IF)
  2192.       END
  2193.  
  2194. C*GRINQLI -- *obsolete routine*
  2195. C+
  2196.       SUBROUTINE GRINQLI (INTEN)
  2197. C
  2198. C GRPCKG: obtain the line intensity of the current graphics device.
  2199. C Obsolete routine.
  2200. C Argument:
  2201. C
  2202. C INTEN (integer, output): always returns 1.
  2203. C--
  2204. C (1-Feb-1983; revised 16-Aug-1987).
  2205. C-----------------------------------------------------------------------
  2206.       INTEGER  INTEN
  2207. C
  2208.       INTEN = 1
  2209.       END
  2210.  
  2211. C*GRINQPEN -- *obsolete routine*
  2212. C+
  2213.       SUBROUTINE GRINQPEN (IP)
  2214. C
  2215. C GRPCKG: obtain the pen number of the current graphics device.
  2216. C Obsolete routine.
  2217. C Argument:
  2218. C
  2219. C IP (integer, output): always receives 1.
  2220. C--
  2221. C 16-Aug-1987 - [TJP].
  2222. C-----------------------------------------------------------------------
  2223.       INTEGER  IP
  2224. C
  2225.       IP = 1
  2226.       END
  2227. C*GRITOC - convert integer to character string
  2228. C+
  2229.       INTEGER FUNCTION GRITOC(INT, STR)
  2230.       INTEGER INT
  2231.       CHARACTER*(*) STR
  2232. C
  2233. C Convert integer INT into (decimal) character string in STR.
  2234. C-----------------------------------------------------------------------
  2235.       CHARACTER*10 DIGITS
  2236.       INTEGER D, I, INTVAL, J, L
  2237.       CHARACTER K
  2238.       DATA DIGITS /'0123456789'/
  2239. C
  2240.       INTVAL = ABS(INT)
  2241.       I = 0
  2242. C
  2243. C Generate digits in reverse order.
  2244. C
  2245.   10  CONTINUE
  2246.           I = I+1
  2247.           D = 1 + MOD(INTVAL, 10)
  2248.           STR(I:I) = DIGITS(D:D)
  2249.           INTVAL = INTVAL/10
  2250.           IF (I.LT.LEN(STR) .AND. INTVAL.NE.0) GOTO 10
  2251. C
  2252. C Add minus sign if necessary.
  2253. C
  2254.       IF (INT.LT.0 .AND. I.LT.LEN(STR)) THEN
  2255.           I = I+1
  2256.           STR(I:I) = '-'
  2257.       END IF
  2258.       GRITOC = I
  2259. C
  2260. C Reverse string in place.
  2261. C
  2262.       L = I/2
  2263.       DO 20 J=1,L
  2264.           K = STR(I:I)
  2265.           STR(I:I) = STR(J:J)
  2266.           STR(J:J) = K
  2267.           I = I-1
  2268.    20 CONTINUE
  2269. C-----------------------------------------------------------------------
  2270.       END
  2271. C*GRLDEV -- list supported device types
  2272. C+
  2273.       SUBROUTINE GRLDEV
  2274. C
  2275. C Support routine for PGLDEV.
  2276. C
  2277. C Arguments: none
  2278. C--
  2279. C  5-Aug-1986 [AFT]
  2280. C 13-Dec-1990 Change warnings to messages [TJP].
  2281. C 18-Jan-1993 Display one per line [TJP].
  2282. C 13-Jan-1995 Change message [TJP].
  2283. C 10-Nov-1995 Ignore device types of zero length [TJP].
  2284. C-----------------------------------------------------------------------
  2285.       INCLUDE 'f77.GRPCKG1/IN'
  2286.       INTEGER I,NDEV,NBUF,LCHR
  2287.       REAL    RBUF(6)
  2288.       CHARACTER*72 CHR
  2289.       CHARACTER*72 TEXT
  2290. C---
  2291.       CALL GRMSG('Device types available:')
  2292. C--- First obtain number of devices.
  2293.       CALL GREXEC(0,0,RBUF,NBUF,CHR,LCHR)
  2294.       NDEV=NINT(RBUF(1))
  2295. C
  2296.       DO 10 I=1,NDEV
  2297.          CALL GREXEC(I, 1,RBUF,NBUF,CHR,LCHR)
  2298.          IF (LCHR.GT.0) THEN
  2299.             TEXT(1:1) = '/'
  2300.             TEXT(2:) = CHR(:LCHR)
  2301.             CALL GRMSG(TEXT)
  2302.          END IF
  2303.  10   CONTINUE
  2304. C
  2305.       END
  2306. C*GRLEN -- inquire plotted length of character string
  2307. C+
  2308.       SUBROUTINE GRLEN (STRING, D)
  2309. C
  2310. C GRPCKG: length of text string (absolute units)
  2311. C--
  2312. C (3-Mar-1983)
  2313. C 19-Jan-1988 - remove unused label [TJP].
  2314. C  9-Sep-1989 - standardize [TJP].
  2315. C-----------------------------------------------------------------------
  2316.       INCLUDE 'f77.GRPCKG1/IN'
  2317.       LOGICAL UNUSED
  2318.       INTEGER XYGRID(300)
  2319.       INTEGER LIST(256)
  2320.       CHARACTER*(*) STRING
  2321.       REAL FACTOR, COSA, SINA, DX, D, RATIO, FNTBAS, FNTFAC
  2322.       INTEGER I, IFNTLV, LX, NLIST
  2323.       INTRINSIC ABS, LEN
  2324. C
  2325.       D = 0.0
  2326.       IF (LEN(STRING).LE.0) RETURN
  2327. C-----------------------------------------------------------------------
  2328. C               Compute scaling and orientation
  2329. C-----------------------------------------------------------------------
  2330.       FACTOR = GRCFAC(GRCIDE)/2.5
  2331.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  2332.       COSA = FACTOR
  2333.       SINA = 0.0
  2334.       FNTBAS = 0.0
  2335.       FNTFAC = 1.0
  2336.       IFNTLV = 0
  2337. C
  2338. C               Convert string to symbol numbers:
  2339. C               \u and \d escape sequences are converted to -1,-2
  2340. C
  2341.       CALL GRSYDS(LIST,NLIST,STRING,GRCFNT(GRCIDE))
  2342. C
  2343. C               Plot the string of characters
  2344. C
  2345.       DO 380 I = 1,NLIST
  2346.           IF (LIST(I).LT.0) THEN
  2347.               IF (LIST(I).EQ.-1) THEN
  2348.                   IFNTLV = IFNTLV+1
  2349.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  2350.                   FNTFAC = 0.6**ABS(IFNTLV)
  2351.               ELSE IF (LIST(I).EQ.-2) THEN
  2352.                   IFNTLV = IFNTLV-1
  2353.                   FNTFAC = 0.6**ABS(IFNTLV)
  2354.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  2355.               END IF
  2356.               GOTO 380
  2357.           END IF
  2358.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  2359.           LX = XYGRID(5)-XYGRID(4)
  2360.           DX = COSA*LX*RATIO
  2361.           D = D + DX*FNTFAC
  2362.   380 CONTINUE
  2363. C
  2364.       END
  2365. C*GRLIN0 -- draw a line
  2366. C+
  2367.       SUBROUTINE GRLIN0 (XP,YP)
  2368. C
  2369. C GRPCKG (internal routine): draw a line from the current position to a
  2370. C specified position, which becomes the new current position. This
  2371. C routine takes care of clipping at the viewport boundary, dashed and
  2372. C thick lines.
  2373. C
  2374. C Arguments:
  2375. C
  2376. C XP, YP (input, real): absolute device coordinates of the end-point of
  2377. C       the line.
  2378. C--
  2379. C 13-Jul-1984
  2380. C  7-May-1985 - add MIN/MAX kluge to prevent integer overflow [TJP].
  2381. C-----------------------------------------------------------------------
  2382.       INCLUDE 'f77.GRPCKG1/IN'
  2383.       LOGICAL  VIS
  2384.       REAL     XP,YP, X0,Y0, X1,Y1
  2385. C
  2386. C End-points of line are (X0,Y0), (X1,Y1).
  2387. C
  2388.       X0 = GRXPRE(GRCIDE)
  2389.       Y0 = GRYPRE(GRCIDE)
  2390.       X1 = MIN(2E9,MAX(-2E9,XP))
  2391.       Y1 = MIN(2E9,MAX(-2E9,YP))
  2392.       GRXPRE(GRCIDE) = X1
  2393.       GRYPRE(GRCIDE) = Y1
  2394. C
  2395. C Change the end-points of the line (X0,Y0) - (X1,Y1)
  2396. C to clip the line at the window boundary.
  2397. C
  2398.       CALL GRCLPL(X0,Y0,X1,Y1,VIS)
  2399.       IF (.NOT.VIS) RETURN
  2400. C
  2401. C Draw the line in the appropriate style.
  2402. C
  2403.       IF (GRDASH(GRCIDE)) THEN
  2404. C         ! dashed line
  2405.          CALL GRLIN1(X0,Y0,X1,Y1,.FALSE.)
  2406.       ELSE IF (GRWIDT(GRCIDE).GT.1) THEN
  2407. C         ! heavy line
  2408.          CALL GRLIN3(X0,Y0,X1,Y1)
  2409.       ELSE
  2410. C         ! full line
  2411.          CALL GRLIN2(X0,Y0,X1,Y1)
  2412.       END IF
  2413.       END
  2414. C*GRLIN1 -- draw a dashed line
  2415. C+
  2416.       SUBROUTINE GRLIN1 (X0,Y0,X1,Y1,RESET)
  2417. C
  2418. C GRPCKG : dashed line. Generate a visible dashed line between points
  2419. C (X0,Y0) and (X1,Y1) according to the dash pattern stored in common.
  2420. C If RESET = .TRUE., the pattern will start from the beginning.
  2421. C Otherwise, it will continue from its last position.
  2422. C     DASHED LINE PATTERN ARRAY CONTAINING LENGTHS OF
  2423. C          MARKS AND SPACES IN UNIT CUBE: GRPATN(*)
  2424. C     OFFSET IN CURRENT PATTERN SEGMENT: GRPOFF
  2425. C     CURRENT PATTERN SEGMENT NUMBER: GRIPAT
  2426. C     NUMBER OF PATTERN SEGMENTS: 8
  2427. C--
  2428. C (1-Feb-1983)
  2429. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  2430. C-----------------------------------------------------------------------
  2431.       INCLUDE 'f77.GRPCKG1/IN'
  2432. C
  2433.       REAL ADJUST, ARG1, ARG2, ALFARG
  2434.       REAL SCALE, SEGLEN, X1, X0, Y1, Y0, DS, DSOLD
  2435.       REAL ALPHA1, ALPHA2, XP, YP, XQ, YQ
  2436.       LOGICAL RESET
  2437.       INTEGER THICK
  2438.       INTRINSIC ABS, MIN, MOD, REAL, SQRT
  2439. C
  2440.       ADJUST(ARG1,ARG2,ALFARG) = ALFARG*(ARG2 - ARG1) + ARG1
  2441. C
  2442.       THICK = GRWIDT(GRCIDE)
  2443.       SCALE = SQRT(REAL(ABS(THICK)))
  2444.       IF (RESET) THEN
  2445.           GRPOFF(GRCIDE) = 0.0
  2446.           GRIPAT(GRCIDE) = 1
  2447.       END IF
  2448.       SEGLEN = SQRT((X1-X0)**2 + (Y1-Y0)**2)
  2449.       IF (SEGLEN .EQ. 0.0) RETURN
  2450.       DS = 0.0
  2451. C
  2452. C       Repeat until (ALPHA2 .GE. 1.0)
  2453. C
  2454. C       Line segments matching the pattern segments are determined
  2455. C       by finding values (ALPHA1,ALPHA2) defining the start and end
  2456. C       of the segment in the parametric equation (1-ALPHA)*P1 + ALPHA*P2
  2457. C       defining the line.  DS measures the progress along the line
  2458. C       segment and defines the starting ALPHA1.  The ending ALPHA2
  2459. C       is computed from the end of the current pattern mark or space
  2460. C       or the segment end, whichever comes first.
  2461. C
  2462.    10 DSOLD = DS
  2463.       ALPHA1 = DS/SEGLEN
  2464.       ALPHA2 = MIN(1.0,(DS+SCALE*GRPATN(GRCIDE,GRIPAT(GRCIDE))-
  2465.      1           GRPOFF(GRCIDE))/SEGLEN)
  2466.       IF (MOD(GRIPAT(GRCIDE),2) .NE. 0) THEN
  2467.           XP = ADJUST(X0,X1,ALPHA1)
  2468.           YP = ADJUST(Y0,Y1,ALPHA1)
  2469.           XQ = ADJUST(X0,X1,ALPHA2)
  2470.           YQ = ADJUST(Y0,Y1,ALPHA2)
  2471.           IF (THICK.GT.1) THEN
  2472.               CALL GRLIN3(XP,YP,XQ,YQ)
  2473.           ELSE
  2474.               CALL GRLIN2(XP,YP,XQ,YQ)
  2475.           END IF
  2476.       END IF
  2477.       DS = ALPHA2*SEGLEN
  2478.       IF (ALPHA2 .GE. 1.0) THEN
  2479.           GRPOFF(GRCIDE) = GRPOFF(GRCIDE) + DS - DSOLD
  2480.           RETURN
  2481.       END IF
  2482.       GRIPAT(GRCIDE) = MOD(GRIPAT(GRCIDE),8) + 1
  2483.       GRPOFF(GRCIDE) = 0.0
  2484.       GO TO 10
  2485.       END
  2486. C*GRLIN2 -- draw a normal line
  2487. C+
  2488.       SUBROUTINE GRLIN2 (X0,Y0,X1,Y1)
  2489. C
  2490. C GRPCKG : plot a visible line segment in absolute coords from
  2491. C (X0,Y0) to (X1,Y1).  The endpoints of the line segment are rounded
  2492. C to the nearest integer and passed to the appropriate device-specific
  2493. C routine. It is assumed that the entire line-segment lies within the
  2494. C view surface, and that the physical device coordinates are
  2495. C non-negative.
  2496. C--
  2497. C (1-Jun-1984)
  2498. C 19-Oct-1984 - rewritten for speed [TJP].
  2499. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  2500. C  5-Aug-1986 - add GREXEC support [AFT].
  2501. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  2502. C-----------------------------------------------------------------------
  2503.       INCLUDE 'f77.GRPCKG1/IN'
  2504.       REAL    X0,Y0,X1,Y1
  2505.       REAL    RBUF(6)
  2506.       INTEGER NBUF,LCHR
  2507.       CHARACTER CHR
  2508. C
  2509. C- If this is first thing plotted then set something plotted flag
  2510. C- and for a GREXEC device call BEGIN_PICTURE.
  2511. C
  2512.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  2513. C---
  2514.       RBUF(1)=X0
  2515.       RBUF(2)=Y0
  2516.       RBUF(3)=X1
  2517.       RBUF(4)=Y1
  2518.       NBUF=4
  2519. C     WRITE(*,'(A,4F10.5)') 'GRLIN2',RBUF(1), RBUF(2), RBUF(3), RBUF(4)
  2520.       CALL GREXEC(GRGTYP,12,RBUF,NBUF,CHR,LCHR)
  2521. C
  2522.       END
  2523. C*GRLIN3 -- draw a thick line (multiple strokes)
  2524. C+
  2525.       SUBROUTINE GRLIN3 (X0,Y0,X1,Y1)
  2526. C
  2527. C GRPCKG: draw a heavy line from (X0,Y0) to (X1,Y1) by making multiple
  2528. C strokes.  In order to simulate a thick pen, the line drawn has
  2529. C circular, rather than square, end points.  If this is not done,
  2530. C thick letters and other figures have an abnormal and unpleasant
  2531. C appearance.
  2532. C
  2533. C Vocabulary:
  2534. C
  2535. C LINEWT: the number of strokes required to draw the line; if
  2536. C       this is odd, one stroke will lie along the requested vector.
  2537. C       The nominal line thickness is (LINEWT-1)*0.005 in.
  2538. C RSQURD: the square of the semi-line thickness.
  2539. C (DX,DY): the vector length of the line.
  2540. C (VX,VY): a vector of length 1 pixel in the direction of the line.
  2541. C (VY,-VX): a vector of length 1 pixel perpendicular to (VX,VY).
  2542. C OFF: the offset parallel to (VY,-VX) of the K'th stroke.
  2543. C (VXK,VYK): the vector increment of the K'th stroke to allow for the
  2544. C       semi-circular terminal on the line.
  2545. C (PXK,PYK): the vector offset of the K'th stroke perpendicular to the
  2546. C       line vector.
  2547. C--
  2548. C (1-Feb-1983)
  2549. C 23-Nov-1994 - change algorithm so that the unit of line-width is
  2550. C               0.005 inch instead of 1 pixel [TJP].
  2551. C March 1995 - added ABS to prevent domain error in SQRT (CTD)
  2552. C-----------------------------------------------------------------------
  2553.       INCLUDE 'f77.GRPCKG1/IN'
  2554.       INTEGER  K,LINEWT
  2555.       REAL     DX,DY, HK, OFF, PXK,PYK, RSQURD, VLEN,VX,VY,VXK,VYK
  2556.       REAL     X0,X1,Y0,Y1
  2557.       REAL     XS0,XS1, YS0,YS1, SPIX,SPIY
  2558.       LOGICAL  VIS
  2559. C
  2560. C Determine number of strokes and line thickness.
  2561. C
  2562.       LINEWT = GRWIDT(GRCIDE)
  2563.       RSQURD = ((LINEWT-1)**2)*0.25
  2564. C
  2565. C Determine the vectors (VX,VY), (VY,-VX). If the line-length is zero,
  2566. C pretend it is a very short horizontal line.
  2567. C
  2568.       DX = X1 - X0
  2569.       DY = Y1 - Y0
  2570.       VLEN = SQRT(DX**2 + DY**2)
  2571.       SPIX = GRPXPI(GRCIDE)*0.005
  2572.       SPIY = GRPYPI(GRCIDE)*0.005
  2573. C
  2574.       IF (VLEN .EQ. 0.0) THEN
  2575.           VX = SPIX
  2576.           VY = 0.0
  2577.       ELSE
  2578.           VX = DX/VLEN*SPIX
  2579.           VY = DY/VLEN*SPIY
  2580.       END IF
  2581. C
  2582. C Draw LINEWT strokes. We have to clip again in case thickening the
  2583. C line has taken us outside the window.
  2584. C
  2585.       OFF = (LINEWT-1)*0.5
  2586.       DO 10 K=1,LINEWT
  2587.           PXK = VY*OFF
  2588.           PYK = -(VX*OFF)
  2589.           HK  = SQRT(ABS(RSQURD - OFF**2))
  2590.           VXK = VX*HK
  2591.           VYK = VY*HK
  2592.           XS1 = X1+PXK+VXK
  2593.           YS1 = Y1+PYK+VYK
  2594.           XS0 = X0+PXK-VXK
  2595.           YS0 = Y0+PYK-VYK
  2596.           CALL GRCLPL(XS1,YS1,XS0,YS0,VIS)
  2597.           IF (VIS) CALL GRLIN2(XS1, YS1, XS0, YS0)
  2598.           OFF = OFF - 1.0
  2599.    10 CONTINUE
  2600.       END
  2601. C*GRLINA -- draw a line (absolute, world coordinates)
  2602. C+
  2603.       SUBROUTINE GRLINA (X,Y)
  2604. C
  2605. C GRPCKG: draw line from current position to a specified position.
  2606. C
  2607. C Arguments:
  2608. C
  2609. C X, Y (real, input): world coordinates of the end-point of the line.
  2610. C--
  2611. C (1-Feb-1983)
  2612. C-----------------------------------------------------------------------
  2613.       INCLUDE 'f77.GRPCKG1/IN'
  2614.       REAL     X,Y
  2615. C
  2616.       IF (GRCIDE.GE.1) THEN
  2617. C         WRITE (*,'(A,2F10.5)') 'GRLINA', X, Y
  2618.           CALL GRLIN0( X * GRXSCL(GRCIDE) + GRXORG(GRCIDE),
  2619.      1                 Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE) )
  2620.       END IF
  2621.       END
  2622.  
  2623. C*GRLINR -- draw a line (relative, world coordinates)
  2624. C+
  2625.       SUBROUTINE GRLINR (DX,DY)
  2626. C
  2627. C GRPCKG: draw a line from the current position by a specified
  2628. C relative displacement.
  2629. C
  2630. C Arguments:
  2631. C
  2632. C DX, DY (real, input): the displacement in world coordinates: the pen
  2633. C       position is incremented by DX in x and DY in y.
  2634. C--
  2635. C (1-Feb-1983)
  2636. C-----------------------------------------------------------------------
  2637.       INCLUDE 'f77.GRPCKG1/IN'
  2638.       REAL     DX,DY
  2639. C
  2640.       IF (GRCIDE.GE.1) THEN
  2641.           CALL GRLIN0( DX * GRXSCL(GRCIDE) + GRXPRE(GRCIDE),
  2642.      1                 DY * GRYSCL(GRCIDE) + GRYPRE(GRCIDE) )
  2643.       END IF
  2644.       END
  2645.  
  2646. C*GRMARK -- mark points with specified symbol
  2647. C+
  2648.       SUBROUTINE GRMARK (IDENT,CENTER,SYMBOL,ABSXY,POINTS,X,Y)
  2649. C
  2650. C GRPCKG: mark a sequence of points with a specified symbol. The
  2651. C plot is windowed in the current subarea.
  2652. C
  2653. C Arguments:
  2654. C
  2655. C IDENT (integer, input): plot identifier from GROPEN.
  2656. C CENTER (input, logical): if .TRUE. the symbol is centered on the point,
  2657. C      otherwise the bottom left corner is placed at the point.
  2658. C SYMBOL (byte or integer, input): code number of symbol in range 0-127
  2659. C      (ASCII character or special symbol); if SYMBOL is outside this
  2660. C      range, nothing is plotted.
  2661. C ABSXY (logical, input): if .TRUE. (X,Y) are absolute (device)
  2662. C      coordinates; otherwise they are world coordinates and the
  2663. C      scaling transformation is applied.
  2664. C POINTS (integer, input): the number of points; if POINTS is less than
  2665. C      or equal to 0, nothing is plotted.
  2666. C X,Y (real arrays, dimension at least POINTS, input): the coordinate
  2667. C      pairs; if POINTS=1, these may be scalars instead of arrays.
  2668. C
  2669. C (9-Mar-1983)
  2670. C-----------------------------------------------------------------------
  2671.       INTEGER  SYMBOL
  2672.       CHARACTER*1 MARK
  2673.       INTEGER  I, IDENT, POINTS
  2674.       LOGICAL  ABSXY, CENTER
  2675.       REAL     X(*), Y(*)
  2676. C-----------------------------------------------------------------------
  2677.       IF (POINTS.LE.0 .OR. SYMBOL.LT.0 .OR. SYMBOL.GT.127) RETURN
  2678.       CALL GRSLCT(IDENT)
  2679.       MARK = CHAR(SYMBOL)
  2680.       DO 10 I=1,POINTS
  2681.           CALL GRCHR0(.TRUE., CENTER, 0.0, ABSXY, X(I), Y(I), MARK)
  2682.    10 CONTINUE
  2683. C-----------------------------------------------------------------------
  2684.       END
  2685.       SUBROUTINE GRMCUR (ICH, ICX, ICY)
  2686.       INTEGER ICH, ICX, ICY
  2687. C
  2688. C Cursor movement:
  2689. C Input: ICH character code
  2690. C In/Out: ICX, ICY cursor position
  2691. C-----------------------------------------------------------------------
  2692.       INTEGER STEP
  2693.       SAVE STEP
  2694.       DATA STEP /4/
  2695. C
  2696. C     Up arrow or keypad 8:
  2697.       IF (ICH.EQ.-1 .OR. ICH.EQ.-28) THEN
  2698.           ICY = ICY+STEP
  2699. C     Down arrow or keypad 2:
  2700.       ELSE IF (ICH.EQ.-2 .OR. ICH.EQ.-22) THEN
  2701.           ICY = ICY-STEP
  2702. C     Right arrow or keypad 6:
  2703.       ELSE IF (ICH.EQ.-3 .OR. ICH.EQ.-26) THEN
  2704.           ICX = ICX+STEP
  2705. C     Left arrow or keypad 4:
  2706.       ELSE IF (ICH.EQ.-4 .OR. ICH.EQ.-24) THEN
  2707.           ICX = ICX-STEP
  2708. C     Keypad 7 (left and up):
  2709.       ELSE IF (ICH.EQ.-27) THEN
  2710.           ICX = ICX-STEP
  2711.           ICY = ICY+STEP
  2712. C     Keypad 9 (right and up):
  2713.       ELSE IF (ICH.EQ.-29) THEN
  2714.           ICX = ICX+STEP
  2715.           ICY = ICY+STEP
  2716. C     Keypad 3 (right and down):
  2717.       ELSE IF (ICH.EQ.-23) THEN
  2718.           ICX = ICX+STEP
  2719.           ICY = ICY-STEP
  2720. C     Keypad 1 (left and down):
  2721.       ELSE IF (ICH.EQ.-21) THEN
  2722.           ICX = ICX-STEP
  2723.           ICY = ICY-STEP
  2724. C     PF1:
  2725.       ELSE IF (ICH.EQ.-11) THEN
  2726.           STEP = 1
  2727. C     PF2:
  2728.       ELSE IF (ICH.EQ.-12) THEN
  2729.           STEP = 4
  2730. C     PF3:
  2731.       ELSE IF (ICH.EQ.-13) THEN
  2732.           STEP = 16
  2733. C     PF4:
  2734.       ELSE IF (ICH.EQ.-14) THEN
  2735.           STEP = 64
  2736.       END IF
  2737.       END
  2738. C*GRMKER -- draw graph markers
  2739. C+
  2740.       SUBROUTINE GRMKER (SYMBOL,ABSXY,N,X,Y)
  2741. C
  2742. C GRPCKG: Draw a graph marker at a set of points in the current
  2743. C window. Line attributes (color, intensity, and  thickness)
  2744. C apply to markers, but line-style is ignored. After the call to
  2745. C GRMKER, the current pen position will be the center of the last
  2746. C marker plotted.
  2747. C
  2748. C Arguments:
  2749. C
  2750. C SYMBOL (input, integer): the marker number to be drawn. Numbers
  2751. C       0-31 are special marker symbols; numbers 32-127 are the
  2752. C       corresponding ASCII characters (in the current font). If the
  2753. C       number is >127, it is taken to be a Hershey symbol number.
  2754. C       If -ve, a regular polygon is drawn.
  2755. C ABSXY (input, logical): if .TRUE., the input corrdinates (X,Y) are
  2756. C       taken to be absolute device coordinates; if .FALSE., they are
  2757. C       taken to be world coordinates.
  2758. C N (input, integer): the number of points to be plotted.
  2759. C X, Y (input, real arrays, dimensioned at least N): the (X,Y)
  2760. C       coordinates of the points to be plotted.
  2761. C--
  2762. C (19-Mar-1983)
  2763. C 20-Jun-1985 - revise to window markers whole [TJP].
  2764. C  5-Aug-1986 - add GREXEC support [AFT].
  2765. C  1-Aug-1988 - add direct use of Hershey number [TJP].
  2766. C 15-Dec-1988 - standardize [TJP].
  2767. C 17-Dec-1990 - add polygons [PAH/TJP].
  2768. C 12-Jun-1992 - [TJP]
  2769. C 22-Sep-1992 - add support for hardware markers [TJP].
  2770. C  1-Sep-1994 - suppress driver call [TJP].
  2771. C 15-Feb-1994 - fix bug (expanding viewport!) [TJP].
  2772. C-----------------------------------------------------------------------
  2773.       INCLUDE 'f77.GRPCKG1/IN'
  2774.       INTEGER  SYMBOL
  2775.       INTEGER  C 
  2776.       LOGICAL  ABSXY, UNUSED, VISBLE
  2777.       INTEGER  I, K, LSTYLE, LX, LY, LXLAST, LYLAST, N, SYMNUM, NV
  2778.       INTEGER  XYGRID(300)
  2779.       REAL     ANGLE, COSA, SINA, FACTOR, RATIO, X(*), Y(*)
  2780.       REAL     XCUR, YCUR, XORG, YORG
  2781.       REAL     THETA, XOFF(40), YOFF(40), XP(40), YP(40)
  2782.       REAL     XMIN, XMAX, YMIN, YMAX
  2783.       REAL     XMINX, XMAXX, YMINX, YMAXX
  2784.       REAL     RBUF(4)
  2785.       INTEGER  NBUF,LCHR
  2786.       CHARACTER*32 CHR
  2787. C
  2788. C Check that there is something to be plotted.
  2789. C
  2790.       IF (N.LE.0) RETURN
  2791. C
  2792. C Check that a device is selected.
  2793. C
  2794.       IF (GRCIDE.LT.1) THEN
  2795.           CALL GRWARN('GRMKER - no graphics device is active.')
  2796.           RETURN
  2797.       END IF
  2798. C
  2799.       XMIN = GRXMIN(GRCIDE)
  2800.       XMAX = GRXMAX(GRCIDE)
  2801.       YMIN = GRYMIN(GRCIDE)
  2802.       YMAX = GRYMAX(GRCIDE)
  2803.       XMINX = XMIN-0.01
  2804.       XMAXX = XMAX+0.01
  2805.       YMINX = YMIN-0.01
  2806.       YMAXX = YMAX+0.01
  2807. C
  2808. C Does the device driver do markers (only markers 0-31 at present)?
  2809. C
  2810.       IF (GRGCAP(GRCIDE)(10:10).EQ.'M' .AND.
  2811.      :     SYMBOL.GE.0 .AND. SYMBOL.LE.31) THEN
  2812.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  2813. C         -- symbol number
  2814.           RBUF(1) = SYMBOL
  2815. C          -- scale factor
  2816.           RBUF(4) = GRCFAC(GRCIDE)/2.5
  2817.           NBUF = 4
  2818.           LCHR = 0
  2819.           DO 10 K=1,N
  2820. C             -- convert to device coordinates
  2821.               CALL GRTXY0(ABSXY, X(K), Y(K), XORG, YORG)
  2822. C             -- is the marker visible?
  2823.               CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2824.               IF (C.EQ.0) THEN
  2825.                   RBUF(2) = XORG
  2826.                   RBUF(3) = YORG
  2827.                   CALL GREXEC(GRGTYP,28,RBUF,NBUF,CHR,LCHR)
  2828.               END IF
  2829.    10     CONTINUE
  2830.           RETURN
  2831.       END IF
  2832. C
  2833. C Otherwise, draw the markers here.
  2834. C
  2835. C Save current line-style, and set style "normal".
  2836. C
  2837.       CALL GRQLS(LSTYLE)
  2838.       CALL GRSLS(1)
  2839. C
  2840. C Save current viewport, and open the viewport to include the full
  2841. C view surface.
  2842. C
  2843.       CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  2844. C
  2845. C Compute scaling and orientation.
  2846. C
  2847.       ANGLE = 0.0
  2848.       FACTOR = GRCFAC(GRCIDE)/2.5
  2849.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  2850.       COSA = FACTOR * COS(ANGLE)
  2851.       SINA = FACTOR * SIN(ANGLE)
  2852. C
  2853. C Convert the supplied marker number SYMBOL to a symbol number and
  2854. C obtain the digitization.
  2855. C
  2856.       IF (SYMBOL.GE.0) THEN
  2857.           IF (SYMBOL.GT.127) THEN
  2858.               SYMNUM = SYMBOL
  2859.           ELSE
  2860.               CALL GRSYMK(SYMBOL,GRCFNT(GRCIDE),SYMNUM)
  2861.           END IF
  2862.           CALL GRSYXD(SYMNUM, XYGRID, UNUSED)
  2863. C
  2864. C Positive symbols.
  2865. C
  2866.       DO 380 I=1,N
  2867.           CALL GRTXY0(ABSXY, X(I), Y(I), XORG, YORG)
  2868.           CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2869.           IF (C.NE.0) GOTO 380
  2870.           VISBLE = .FALSE.
  2871.           K = 4
  2872.           LXLAST = -64
  2873.           LYLAST = -64
  2874.   320       K = K+2
  2875.             LX = XYGRID(K)
  2876.             LY = XYGRID(K+1)
  2877.             IF (LY.EQ.-64) GOTO 380
  2878.             IF (LX.EQ.-64) THEN
  2879.                 VISBLE = .FALSE.
  2880.             ELSE
  2881.                 IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  2882.                     XCUR = XORG + (COSA*LX - SINA*LY)*RATIO
  2883.                     YCUR = YORG + (SINA*LX + COSA*LY)
  2884.                     IF (VISBLE) THEN
  2885.                         CALL GRLIN0(XCUR,YCUR)
  2886.                     ELSE
  2887.                         GRXPRE(GRCIDE) = XCUR
  2888.                         GRYPRE(GRCIDE) = YCUR
  2889.                     END IF
  2890.                 END IF
  2891.                 VISBLE = .TRUE.
  2892.                 LXLAST = LX
  2893.                 LYLAST = LY
  2894.             END IF
  2895.             GOTO 320
  2896.   380 CONTINUE
  2897. C
  2898. C Negative symbols.
  2899. C
  2900.       ELSE
  2901. C         ! negative symbol: filled polygon of radius 8
  2902.           NV = MIN(31,MAX(3,ABS(SYMBOL)))
  2903.           DO 400 I=1,NV
  2904.               THETA = 3.14159265359*(REAL(2*(I-1))/REAL(NV)+0.5) - ANGLE
  2905.               XOFF(I) = COS(THETA)*FACTOR*RATIO/GRXSCL(GRCIDE)*8.0
  2906.               YOFF(I) = SIN(THETA)*FACTOR/GRYSCL(GRCIDE)*8.0
  2907.   400     CONTINUE
  2908.           DO 420 K=1,N
  2909.               CALL GRTXY0(ABSXY, X(K), Y(K), XORG, YORG)
  2910.               CALL GRCLIP(XORG, YORG, XMINX, XMAXX, YMINX, YMAXX, C)
  2911.               IF (C.EQ.0) THEN
  2912.                   DO 410 I=1,NV
  2913.                       XP(I) = X(K)+XOFF(I)
  2914.                       YP(I) = Y(K)+YOFF(I)
  2915.   410             CONTINUE
  2916.                   CALL GRFA(NV, XP, YP)
  2917.               END IF
  2918.   420     CONTINUE
  2919.       END IF
  2920. C
  2921. C Set current pen position.
  2922. C
  2923.       GRXPRE(GRCIDE) = XORG
  2924.       GRYPRE(GRCIDE) = YORG
  2925. C
  2926. C Restore the viewport and line-style, and return.
  2927. C
  2928.       GRXMIN(GRCIDE) = XMIN
  2929.       GRXMAX(GRCIDE) = XMAX
  2930.       GRYMIN(GRCIDE) = YMIN
  2931.       GRYMAX(GRCIDE) = YMAX
  2932.       CALL GRSLS(LSTYLE)
  2933. C
  2934.       END
  2935. C*GRMOVA -- move pen (absolute, world coordinates)
  2936. C+
  2937.       SUBROUTINE GRMOVA (X,Y)
  2938. C
  2939. C GRPCKG: move the pen to a specified location.
  2940. C
  2941. C Arguments:
  2942. C
  2943. C X, Y (real, input): world coordinates of the new pen position.
  2944. C--
  2945. C (1-Feb-1983)
  2946. C-----------------------------------------------------------------------
  2947.       INCLUDE 'f77.GRPCKG1/IN'
  2948.       REAL     X,Y
  2949. C
  2950.       IF (GRCIDE.GE.1) THEN
  2951. C         WRITE (*,'(A,2F10.5)') 'GRMOVA', X, Y
  2952.           GRXPRE(GRCIDE) = X * GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  2953.           GRYPRE(GRCIDE) = Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  2954.       END IF
  2955.       END
  2956.  
  2957. C*GRMOVR -- move pen (relative, world coordinates)
  2958. C+
  2959.       SUBROUTINE GRMOVR (DX,DY)
  2960. C
  2961. C GRPCKG: move the pen through a specified displacement.
  2962. C
  2963. C Arguments:
  2964. C
  2965. C DX, DY (real, input): the displacement in world coordinates: the pen
  2966. C       position is incremented by DX in x and DY in y.
  2967. C--
  2968. C (1-Feb-1983)
  2969. C-----------------------------------------------------------------------
  2970.       INCLUDE 'f77.GRPCKG1/IN'
  2971.       REAL     DX,DY
  2972. C
  2973.       IF (GRCIDE.GE.1) THEN
  2974.           GRXPRE(GRCIDE) = GRXPRE(GRCIDE) + DX*GRXSCL(GRCIDE)
  2975.           GRYPRE(GRCIDE) = GRYPRE(GRCIDE) + DY*GRYSCL(GRCIDE)
  2976.       END IF
  2977.       END
  2978. C*GRMSG -- issue message to user
  2979. C+
  2980.       SUBROUTINE GRMSG (TEXT)
  2981.       CHARACTER*(*) TEXT
  2982. C
  2983. C Display a message on standard output.
  2984. C
  2985. C Argument:
  2986. C  TEXT (input): text of message to be printed (the string
  2987. C      may not be blank).
  2988. C--
  2989. C  8-Nov-1994 [TJP].
  2990. C-----------------------------------------------------------------------
  2991.       INTEGER   GRTRIM
  2992. C
  2993.       IF (TEXT.NE.' ') THEN
  2994.           WRITE (*, '(1X,A)') TEXT(1:GRTRIM(TEXT))
  2995.       END IF
  2996.       END
  2997. C*GROPEN -- open device for graphics
  2998. C+
  2999.       INTEGER FUNCTION GROPEN (TYPE,DUMMY,FILE,IDENT)
  3000.       INTEGER   TYPE, DUMMY, IDENT
  3001.       CHARACTER*(*) FILE
  3002. C
  3003. C GRPCKG: assign a device and prepare for plotting.  GROPEN must be
  3004. C called before all other calls to GRPCKG routines.
  3005. C
  3006. C Returns:
  3007. C
  3008. C GROPEN (output, integer): 1 => success, any other value
  3009. C       indicates a failure (usually the value returned will
  3010. C       be a VMS error code). In the event of an error, a
  3011. C       message will be sent to the standard error unit.
  3012. C
  3013. C Arguments:
  3014. C
  3015. C TYPE (input, integer): default device type (integer code).
  3016. C DUMMY (input, integer): not used at present.
  3017. C FILE (input, character): plot specifier, of form 'device/type'.
  3018. C IDENT (output, integer): plot identifier to be used in later
  3019. C       calls to GRPCKG.
  3020. C
  3021. C  1-Jun-1984 - [TJP].
  3022. C  2-Jul-1984 - change to call GRSLCT [TJP].
  3023. C 13-Jul-1984 - add device initialization [TJP].
  3024. C 23-Jul-1984 - add /APPEND qualifier.
  3025. C 19-Oct-1984 - add VV device [TJP].
  3026. C 26-Dec-1984 - obtain default file name from common [TJP].
  3027. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  3028. C  5-Aug-1986 - add GREXEC support [AFT].
  3029. C 12-Oct-1986 - fix bug causing GREXEC to erase screen [AFT].
  3030. C  3-Jun-1987 - remove declaration of exit handler [TJP].
  3031. C 15-Dec-1988 - standardize [TJP].
  3032. C 25-Jun-1989 - remove code that removes spaces from the device name 
  3033. C               [TJP].
  3034. C 26-Nov-1990 - [TJP].
  3035. C  5-Jan-1993 - [TJP].
  3036. C  1-Sep-1994 - store device capabilities in common for later use [TJP].
  3037. C 17-Apr-1995 - zero-length string fix [TJP].
  3038. C  6-Jun-1995 - explicitly initialize GRSTAT [TJP].
  3039. C 29-Apr-1996 - moved initialization into GRINIT [TJP].
  3040. C-----------------------------------------------------------------------
  3041.       INCLUDE 'f77.GRPCKG1/IN'
  3042.       INTEGER   IER, FTYPE, NBUF, LCHR
  3043.       INTEGER   GRPARS, GRTRIM
  3044.       REAL      RBUF(6)
  3045.       LOGICAL   APPEND
  3046.       CHARACTER*128 FFILE,CHR
  3047. C
  3048. C Initialize GRPCKG; read font file (if necessary).
  3049. C
  3050.       CALL GRINIT
  3051. C
  3052. C Allocate an identifier.
  3053. C
  3054.       IDENT = 1
  3055.    10 IF (GRSTAT(IDENT).NE.0) THEN
  3056.           IDENT = IDENT+1
  3057.           IF (IDENT.GT.GRIMAX) THEN
  3058.               CALL GRWARN('Too many active plots.')
  3059.               GROPEN = -1
  3060.               IDENT = 0
  3061.               RETURN
  3062.           END IF
  3063.       GOTO 10
  3064.       END IF
  3065. C
  3066. C Validate the device specification.
  3067. C
  3068.       IER = GRPARS(FILE,FFILE,FTYPE,APPEND)
  3069.       IF (IER.NE.1) THEN
  3070.           CHR = 'Invalid device specification: '
  3071.           CHR(31:) = FILE
  3072.           CALL GRWARN(CHR)
  3073.           GROPEN = -1
  3074.           RETURN
  3075.       END IF
  3076.       IF (FTYPE.EQ.0) FTYPE = TYPE
  3077.       IF (1.LE.FTYPE) THEN
  3078.           GRTYPE(IDENT) = FTYPE
  3079.           GRGTYP = FTYPE
  3080.       ELSE
  3081.           CHR = 'Device type omitted or invalid: '
  3082.           CHR(33:) = FILE
  3083.           CALL GRWARN(CHR)
  3084.           GROPEN = -1
  3085.           RETURN
  3086.       END IF
  3087. C
  3088. C Install the file name, or assign default.
  3089. C
  3090.       IF (FFILE.EQ.' ') THEN
  3091.           CALL GREXEC(GRGTYP, 5,RBUF,NBUF,FFILE,LCHR)
  3092.       END IF
  3093.       GRFILE(IDENT) = FFILE
  3094.       GRFNLN(IDENT) = MAX(1,GRTRIM(GRFILE(IDENT)))
  3095. C
  3096. C Open workstation.
  3097. C
  3098.       RBUF(3)=0
  3099.       IF (APPEND) RBUF(3)=1
  3100.       NBUF=3
  3101.       CALL GREXEC(GRGTYP, 9,RBUF,NBUF, GRFILE(IDENT),GRFNLN(IDENT))
  3102.       GRUNIT(IDENT)=RBUF(1)
  3103.       GROPEN=RBUF(2)
  3104.       IF (GROPEN.NE.1) RETURN
  3105.       GRPLTD(IDENT) = .FALSE.
  3106.       GRSTAT(IDENT) = 1
  3107.       CALL GRSLCT(IDENT)
  3108. C
  3109. C Install the default plot parameters
  3110. C
  3111. C--- Inquire color-index range.
  3112.       CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  3113.       GRMNCI(IDENT)=RBUF(5)
  3114.       GRMXCI(IDENT)=RBUF(6)
  3115. C--- Inquire resolution.
  3116.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  3117.       GRPXPI(IDENT)=RBUF(1)
  3118.       GRPYPI(IDENT)=RBUF(2)
  3119. C--- Inquire default character size.
  3120.       CALL GREXEC(GRGTYP, 7,RBUF,NBUF,CHR,LCHR)
  3121.       GRCSCL(IDENT) = RBUF(1)
  3122.       GRCFAC(IDENT) = RBUF(1)
  3123. C--- Inquire default plot size.
  3124.       CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  3125.       GRXMXA(IDENT) = RBUF(2)
  3126.       GRYMXA(IDENT) = RBUF(4)
  3127.       GRXMIN(IDENT) = RBUF(1)
  3128.       GRXMAX(IDENT) = RBUF(2)
  3129.       GRYMIN(IDENT) = RBUF(3)
  3130.       GRYMAX(IDENT) = RBUF(4)
  3131. C--- Inquire device capabilities.
  3132.       GRGCAP(IDENT) = 'NNNNNNNNNNN'
  3133.       CALL GREXEC(GRGTYP, 4,RBUF,NBUF,CHR,LCHR)
  3134.       IF (LCHR.GT.LEN(GRGCAP(IDENT))) LCHR = LEN(GRGCAP(IDENT))
  3135.       GRGCAP(IDENT)(1:LCHR) = CHR(:LCHR)
  3136. C--- Current pen position.
  3137.       GRXPRE(IDENT) = 0.0
  3138.       GRYPRE(IDENT) = 0.0
  3139. C--- GRSETS has not been called.
  3140.       GRADJU(IDENT) = .FALSE.
  3141. C---Default scaling.
  3142.       CALL GRTRN0(0.0, 0.0, 1.0, 1.0)
  3143. C
  3144. C Default attributes.
  3145. C  text font (normal)
  3146. C  color (white)
  3147. C  line-style (full)
  3148. C  line-width (minimum)
  3149. C  marker number (dot)
  3150. C
  3151.       GRCFNT(IDENT) = 1
  3152.       GRCCOL(IDENT) = 1
  3153.       GRSTYL(IDENT) = 1
  3154.       GRWIDT(IDENT) = 1
  3155.       GRCMRK(IDENT) = 1
  3156.       GRDASH(IDENT) = .FALSE.
  3157. C
  3158.       GROPEN = 1
  3159. C
  3160.       END
  3161. C*GRPAGE -- end picture
  3162. C+
  3163.       SUBROUTINE GRPAGE
  3164. C
  3165. C GRPCKG: Advance the plotting area to a new page. For video devices,
  3166. C this amounts to erasing the screen; for hardcopy devices, the plot
  3167. C buffer is written to the output file followed by a form-feed to
  3168. C advance the paper to the start of the next page.
  3169. C
  3170. C Arguments: none.
  3171. C--
  3172. C  3-Jun-1983 - [TJP].
  3173. C 18-Feb-1984 - remove unnecessary 'T' initialization of VT125, and add
  3174. C               S(G1) for Rainbow REGIS [TJP].
  3175. C  1-Jun-1984 - add type GMFILE [TJP].
  3176. C  2-Jul-1984 - change initialization of VT125 for color [TJP].
  3177. C 13-Jul-1984 - move initialization of VT125 and Grinnell to GROPEN
  3178. C               [TJP].
  3179. C 19-Oct-1984 - add VV device [TJP].
  3180. C 29-Jan-1985 - add HP2648 terminal [KS/TJP].
  3181. C  5-Aug-1986 - add GREXEC support [AFT].
  3182. C 21-Feb-1987 - fix GREXEC end picture sequence [AFT].
  3183. C 11-Jun-1987 - remove built-in devices [TJP].
  3184. C 11-Feb-1992 - update veiew surface size: it may have changed! [TJP].
  3185. C  5-Jan-1993 - but only if GRSETS has not been called! [TJP]
  3186. C-----------------------------------------------------------------------
  3187.       INCLUDE 'f77.GRPCKG1/IN'
  3188. C
  3189.       INTEGER NBUF,LCHR
  3190.       REAL    RBUF(6)
  3191. C
  3192.       CHARACTER CHR
  3193. C
  3194. C Flush the buffer.
  3195. C
  3196.       CALL GRTERM
  3197. C
  3198. C Erase the text screen (if there is one).
  3199. C
  3200.       CALL GRETXT
  3201. C
  3202. C End picture.
  3203. C
  3204.       CALL GREPIC
  3205. C
  3206. C Update the view surface size: it may have changed (on windowing 
  3207. C devices)
  3208. C
  3209.       IF (.NOT.GRADJU(GRCIDE)) THEN
  3210.           CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  3211.           GRXMXA(GRCIDE) = RBUF(2)
  3212.           GRYMXA(GRCIDE) = RBUF(4)
  3213.       END IF
  3214. C
  3215.       END
  3216. C*GRPARS -- parse device specification string
  3217. C+
  3218.       INTEGER FUNCTION GRPARS (SPEC,DEV,TYPE,APPEND)
  3219.       CHARACTER*(*) SPEC, DEV
  3220.       INTEGER  TYPE
  3221.       LOGICAL  APPEND
  3222. C
  3223. C GRPCKG: decode a device-specification; called by GROPEN.
  3224. C
  3225. C Returns:
  3226. C  GRPARS (output): 1 if the device-specification is
  3227. C       acceptable; any other value indicates an error.
  3228. C
  3229. C Arguments:
  3230. C  SPEC (input): the device specification.
  3231. C  DEV  (output):  device name or file spec.
  3232. C  TYPE (output): device type (integer code); 0 if no device
  3233. C       type is specified.
  3234. C  APPEND (output): .TRUE. if /APPEND specified, .FALSE. otherwise.
  3235. C--
  3236. C 23-Jul-1984 - [TJP].
  3237. C 19-Feb-1988 - allow device part to be quoted [TJP].
  3238. C 30-Mar-1989 - remove logical translation of device and type [TJP].
  3239. C 17-Jun-1991 - ignore comments after ' (' [TJP].
  3240. C 19-Dec-1994 - rewritten to scan backwards [TJP].
  3241. C  6-Jun-1995 - correct a zero-length string problem [TJP].
  3242. C-----------------------------------------------------------------------
  3243.       CHARACTER*32  CTYPE, UPPER
  3244.       CHARACTER*6   APPSTR
  3245.       CHARACTER*256 DESCR
  3246.       INTEGER       GRDTYP, GRTRIM
  3247.       INTEGER       L, LC, LS
  3248.       DATA          APPSTR/'APPEND'/
  3249. C
  3250. C Default results.
  3251. C
  3252.       DEV = ' '
  3253.       TYPE = 0
  3254.       APPEND = .FALSE.
  3255.       GRPARS = 1
  3256.       CTYPE = ' '
  3257. C
  3258. C Null string is acceptable.
  3259. C
  3260.       IF (LEN(SPEC).LT.1) RETURN
  3261.       IF (SPEC.EQ.' ') RETURN
  3262. C
  3263. C On systems where it is possible, perform a "logical name" translation.
  3264. C
  3265.       DESCR = SPEC
  3266.       CALL GRLGTR(DESCR)
  3267. C
  3268. C Discard trailing blanks: L is length of remainder.
  3269. C
  3270.       L = GRTRIM(DESCR)
  3271. C
  3272. C Find last slash in string (position LS or 0).
  3273. C
  3274.       LS = L
  3275.  20   IF (DESCR(LS:LS).NE.'/') THEN
  3276.          LS = LS-1
  3277.          IF (LS.GT.0) GOTO 20
  3278.       END IF
  3279. C
  3280. C Check for /APPEND qualifier; if present, look again for type.
  3281. C
  3282.       IF (LS.GT.0) THEN
  3283.          CTYPE = DESCR(LS+1:L)
  3284.          CALL GRTOUP(UPPER,CTYPE)
  3285.          CTYPE = UPPER
  3286.          IF (CTYPE.EQ.APPSTR) THEN
  3287.             APPEND = .TRUE.
  3288.             L = LS-1
  3289.             LS = L
  3290.  30         IF (DESCR(LS:LS).NE.'/') THEN
  3291.                LS = LS-1
  3292.                IF (LS.GT.0) GOTO 30
  3293.             END IF
  3294.          ELSE
  3295.             APPEND = .FALSE.
  3296.          END IF
  3297.       END IF
  3298. C
  3299. C If LS=0 there is no type field: use PGPLOT_TYPE.
  3300. C
  3301.       IF (LS.EQ.0) THEN
  3302.          CALL GRGENV('TYPE', CTYPE, LC)
  3303.       ELSE
  3304.          CTYPE = DESCR(LS+1:L)
  3305.          LC = L-LS
  3306.          L = LS-1
  3307.       END IF
  3308. C
  3309. C Check for allowed type.
  3310. C
  3311.       IF (LC.GT.0) THEN
  3312.          CALL GRTOUP(UPPER,CTYPE)
  3313.          CTYPE = UPPER
  3314.          TYPE = GRDTYP(CTYPE)
  3315.          IF (TYPE.EQ.0) CALL GRWARN('Unrecognized device type')
  3316.          IF (TYPE.EQ.-1) CALL GRWARN('Device type is ambiguous')
  3317.       ELSE
  3318.          TYPE = 0
  3319.          CALL GRWARN('Device type omitted')
  3320.       END IF
  3321.       IF (TYPE.EQ.0) GRPARS = GRPARS+2
  3322. C
  3323. C Remove quotes from device if necessary.
  3324. C
  3325.       IF (L.GE.1) THEN
  3326.          IF (DESCR(1:1).EQ.'"' .AND. DESCR(L:L).EQ.'"') THEN
  3327.             DEV = DESCR(2:L-1)
  3328.             L = L-2
  3329.          ELSE
  3330.             DEV = DESCR(1:L)
  3331.          END IF
  3332.       END IF
  3333. C
  3334. C      write (*,*) 'Device = [', DEV(1:L), ']'
  3335. C      write (*,*) 'Type   = [', CTYPE, ']', TYPE
  3336. C      write (*,*) 'APPEND = ', APPEND
  3337. C
  3338.       END
  3339. C*GRPIXL -- solid-fill multiple rectangular areas
  3340. C+
  3341.       SUBROUTINE GRPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3342.      1                   X1, X2, Y1, Y2)
  3343.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3344.       INTEGER IA(IDIM,JDIM)
  3345.       REAL    X1, X2, Y1, Y2
  3346. C
  3347. C Determine the size of each rectangular element. If it is equal
  3348. C to the device pen width and the device supports pixel primitives,
  3349. C use pixel primitives. Otherwise, if the size is smaller than the
  3350. C device pen width emulate pixel output by plotting points. If the
  3351. C size is larger than the device pen width, emulate by outputting
  3352. C solid-filled rectangles.
  3353. C
  3354. C Arguments:
  3355. C  IA     (input)  : the array to be plotted.
  3356. C  IDIM   (input)  : the first dimension of array A.
  3357. C  JDIM   (input)  : the second dimension of array A.
  3358. C  I1, I2 (input)  : the inclusive range of the first index
  3359. C                    (I) to be plotted.
  3360. C  J1, J2 (input)  : the inclusive range of the second
  3361. C                    index (J) to be plotted.
  3362. C  X1, Y1 (input)  : world coordinates of one corner of the output
  3363. C                    region
  3364. C  X2, Y2 (input)  : world coordinates of the opposite corner of the
  3365. C                    output region
  3366. C--
  3367. C 18-Jan-1991 - [Ge van Geldorp]
  3368. C 31-Mar-1993 - Include color PostScript GRPXPS [Remko Scharroo]
  3369. C  4-Apr-1993 - New version of GRPXPS incorporated
  3370. C  4-Aug-1993 - Debugging
  3371. C  7-Sep-1994 - Revised for v5.0 [TJP].
  3372. C 24-Jan-1996 - GRXMIN etc changed to REAL as required in grpckg1.inc [RS]
  3373. C-----------------------------------------------------------------------
  3374.       INCLUDE 'f77.GRPCKG1/IN'
  3375.       REAL    RBUF(3)
  3376.       INTEGER NBUF, LCHR
  3377.       CHARACTER*32 CHR
  3378.       REAL    XLL, YLL, XUR, YUR
  3379.       REAL    XMIN, YMIN, XMAX, YMAX, XPIX, YPIX
  3380.       REAL    WIDTH, XSIZE, YSIZE
  3381.       INTEGER IL, IR, JB, JT
  3382. C
  3383.       IF (GRCIDE.LT.1) RETURN
  3384. C
  3385. C Convert to device coordinates
  3386. C
  3387.       CALL GRTXY0(.FALSE., X1, Y1, XLL, YLL)
  3388.       CALL GRTXY0(.FALSE., X2, Y2, XUR, YUR)
  3389.       XMIN = MIN(XLL,XUR)
  3390.       XMAX = MAX(XLL,XUR)
  3391.       YMIN = MIN(YLL,YUR)
  3392.       YMAX = MAX(YLL,YUR)
  3393. C
  3394. C Check if completely outside clipping region
  3395. C
  3396.       IF (XMAX .LT. GRXMIN(GRCIDE) .OR. GRXMAX(GRCIDE) .LT. XMIN .OR.
  3397.      1    YMAX .LT. GRYMIN(GRCIDE) .OR. GRYMAX(GRCIDE) .LT. YMIN)
  3398.      2   RETURN
  3399. C
  3400. C Don't paint "pixels" completely before left clipping boundary
  3401. C
  3402.       XPIX = XMAX - XMIN
  3403.       YPIX = YMAX - YMIN
  3404.       IF (XMIN .LT. GRXMIN(GRCIDE)) THEN
  3405.          IL = I1 + (GRXMIN(GRCIDE) - XMIN) * (I2 - I1 + 1) / XPIX
  3406.          XMIN = XMIN + (XPIX * (IL - I1)) / (I2 - I1 + 1)
  3407.       ELSE
  3408.          IL = I1
  3409.       ENDIF
  3410. C
  3411. C Don't paint "pixels" completely after right clipping boundary
  3412. C
  3413.       IF (GRXMAX(GRCIDE) .LT. XMAX) THEN
  3414.          IR = I2 - (XMAX - GRXMAX(GRCIDE)) * (I2 - I1 + 1) / XPIX + 1
  3415.          XMAX = XMIN + (XPIX * (IR - I1 + 1)) /
  3416.      1                 (I2 - I1 + 1)
  3417.       ELSE
  3418.          IR = I2
  3419.       ENDIF
  3420. C
  3421. C Don't paint "pixels" completely under bottom clipping boundary
  3422. C
  3423.       IF (YMIN .LT. GRYMIN(GRCIDE)) THEN
  3424.          JB = J1 + (GRYMIN(GRCIDE) - YMIN) * (J2 - J1 + 1) / YPIX
  3425.          YMIN = YMIN + (YPIX * (JB - J1)) / (J2 - J1 + 1)
  3426.       ELSE
  3427.          JB = J1
  3428.       ENDIF
  3429. C
  3430. C Don't paint "pixels" completely above top clipping boundary
  3431. C
  3432.       IF (GRYMAX(GRCIDE) .LT. YMAX) THEN
  3433.          JT = J2 - (YMAX - GRYMAX(GRCIDE)) * (J2 - J1 + 1) / YPIX + 1
  3434.          YMAX = YMIN + (YPIX * (JT - J1 + 1)) /
  3435.      1                 (J2 - J1 + 1)
  3436.       ELSE
  3437.          JT = J2
  3438.       ENDIF
  3439. C
  3440. C If device accepts image primitives, use GRPXPS
  3441. C
  3442.       IF (GRGCAP(GRCIDE)(7:7).EQ.'Q') THEN
  3443.          CALL GRPXPS(IA, IDIM, JDIM, IL, IR, JB, JT,
  3444.      1             XMIN,XMAX,YMIN,YMAX)
  3445.          RETURN
  3446.       ENDIF
  3447. C
  3448. C Check against pen width
  3449. C
  3450.       CALL GREXEC(GRGTYP, 3, RBUF, NBUF, CHR, LCHR)
  3451.       WIDTH = RBUF(3)
  3452.       XSIZE = (I2 - I1 + 1) * WIDTH
  3453.       YSIZE = (J2 - J1 + 1) * WIDTH
  3454.       XPIX = XMAX - XMIN + 1
  3455.       YPIX = YMAX - YMIN + 1
  3456. C
  3457. C Use rectangles if "pixel" is too large
  3458. C
  3459.       IF (XPIX .GT. XSIZE + 0.5 * WIDTH .OR.
  3460.      1    YPIX .GT. YSIZE + 0.5 * WIDTH) THEN
  3461. *     write (6,*) 'GRPXRE'
  3462.          CALL GRPXRE(IA, IDIM, JDIM, IL, IR, JB, JT,
  3463.      1             XMIN, XMAX, YMIN, YMAX)
  3464. C
  3465. C Use either pixel primitives or points
  3466. C
  3467.       ELSE
  3468. C
  3469. C Clip pixels lying more than 50% outside clipping boundaries
  3470. C
  3471.          IF (XMIN .LT. GRXMIN(GRCIDE) - 0.5 * WIDTH) THEN
  3472.             XMIN = XMIN + XPIX / (IR - IL + 1)
  3473.             IL = IL + 1
  3474.          ENDIF
  3475.          IF (GRXMAX(GRCIDE) + 0.5 * WIDTH .LT. XMAX) THEN
  3476.             XMAX = XMAX - XPIX / (IR - IL + 1)
  3477.             IR = IR - 1
  3478.          ENDIF
  3479.          IF (YMIN .LT. GRYMIN(GRCIDE) - 0.5 * WIDTH) THEN
  3480.             YMIN = YMIN + YPIX / (JT - JB + 1)
  3481.             JB = JB + 1
  3482.          ENDIF
  3483.          IF (GRYMAX(GRCIDE) + 0.5 * WIDTH .LT. YMAX) THEN
  3484.             YMAX = YMAX - YPIX / (JT - JB + 1)
  3485.             JT = JT - 1
  3486.          ENDIF
  3487. C
  3488. C Recalculate size
  3489. C
  3490.          XSIZE = (IR - IL + 1) * WIDTH
  3491.          YSIZE = (JT - JB + 1) * WIDTH
  3492.          XPIX = XMAX - XMIN + 1
  3493.          YPIX = YMAX - YMIN + 1
  3494. C
  3495. C Use pixel primitives if available and possible
  3496. C
  3497.          IF (GRGCAP(GRCIDE)(7:7) .EQ. 'P' .AND. 
  3498.      1       XSIZE - 0.5 * WIDTH .LE. XPIX .AND.
  3499.      2       YSIZE - 0.5 * WIDTH .LE. YPIX) THEN
  3500. *     write (6,*) 'GRPXPX'
  3501.             CALL GRPXPX(IA, IDIM, JDIM, IL, IR, JB, JT, XMIN, YMIN)
  3502. C
  3503. C Otherwise, use points
  3504. C
  3505.          ELSE
  3506. *     write (6,*) 'GRPXPO'
  3507.             CALL GRPXPO(IA, IDIM, JDIM, IL, IR, JB, JT,
  3508.      1             XMIN, XMAX, YMIN, YMAX)
  3509.          ENDIF
  3510.       ENDIF
  3511.       END
  3512. C*GRPOCL -- polygon clip
  3513. C+
  3514.       SUBROUTINE GRPOCL (N,PX,PY, EDGE, VAL, MAXOUT, NOUT, QX, QY)
  3515.       INTEGER N, NOUT, EDGE, MAXOUT
  3516.       REAL    PX(*), PY(*), QX(*), QY(*)
  3517.       REAL    VAL
  3518. C
  3519. C Clip a polygon against a rectangle: Sutherland-Hodgman algorithm.
  3520. C this routine must be called four times to clip against each of the
  3521. C edges of the rectangle in turn.      
  3522. C
  3523. C Arguments:
  3524. C
  3525. C N (input, integer): the number of vertices of the polygon (at least
  3526. C       3).
  3527. C PX, PY (input, real arrays, dimension at least N): world coordinates
  3528. C       of the N vertices of the input polygon.
  3529. C EDGE (input, integer):
  3530. C     1: clip against left edge,   X > XMIN=VAL
  3531. C     2: clip against right edge,  X < XMAX=VAL
  3532. C     3: clip against bottom edge, Y > YMIN=VAL
  3533. C     4: clip against top edge,    Y < YMIN=VAL
  3534. C VAL  (input, real): coordinate value of current edge.
  3535. C MAXOUT (input, integer): maximum number of vertices allowed in
  3536. C     output polygon (dimension of QX, QY).
  3537. C NOUT (output, integer): the number of vertices in the clipped polygon.
  3538. C QX, QY (output, real arrays, dimension at least MAXOUT): world
  3539. C       coordinates of the NOUT vertices of the output polygon.
  3540. C--
  3541. C 19-Sep-1994 - [TJP].
  3542. C 27-Feb-1996 - fix bug: overflow if coordinates are large [TJP].
  3543. C 11-Jul-1996 - fix bug: left and bottom edges disappeared when precisely
  3544. C               on edge [Remko Scharroo]
  3545. C-----------------------------------------------------------------------
  3546.       INTEGER I
  3547.       REAL FX, FY, SX, SY
  3548. C
  3549.       NOUT = 0
  3550.       DO 100 I=1,N
  3551.          IF (I.EQ.1) THEN
  3552. C           -- save first point
  3553.             FX = PX(I)
  3554.             FY = PY(I)
  3555.          ELSE IF ((EDGE.EQ.1 .OR.EDGE.EQ.2) .AND.
  3556.      :            (SIGN(1.0,PX(I)-VAL).NE.SIGN(1.0,SX-VAL))) THEN
  3557. C           -- SP intersects this edge: output vertex at intersection
  3558.             NOUT = NOUT+1
  3559.             IF (NOUT.LE.MAXOUT) THEN
  3560.                QX(NOUT) = VAL
  3561.                QY(NOUT) = SY + (PY(I)-SY)*((VAL-SX)/(PX(I)-SX))
  3562.             END IF
  3563.          ELSE IF ((EDGE.EQ.3 .OR.EDGE.EQ.4) .AND.
  3564.      :            (SIGN(1.0,PY(I)-VAL).NE.SIGN(1.0,SY-VAL))) THEN
  3565. C           -- SP intersects this edge: output vertex at intersection
  3566.             NOUT = NOUT+1
  3567.             IF (NOUT.LE.MAXOUT) THEN
  3568.                QX(NOUT) = SX + (PX(I)-SX)*((VAL-SY)/(PY(I)-SY))
  3569.                QY(NOUT) = VAL
  3570.             END IF
  3571.          END IF
  3572.          SX = PX(I)
  3573.          SY = PY(I)
  3574.          IF ((EDGE.EQ.1.AND.SX.GE.VAL) .OR.
  3575.      :       (EDGE.EQ.2.AND.SX.LE.VAL) .OR.
  3576.      :       (EDGE.EQ.3.AND.SY.GE.VAL) .OR.
  3577.      :       (EDGE.EQ.4.AND.SY.LE.VAL)) THEN
  3578. C           -- output visible vertex S
  3579.             NOUT = NOUT + 1
  3580.             IF (NOUT.LE.MAXOUT) THEN
  3581.                 QX(NOUT) = SX
  3582.                 QY(NOUT) = SY
  3583.             END IF
  3584.          END IF
  3585.  100  CONTINUE
  3586. C      -- Does SF intersect edge?
  3587.       IF ((EDGE.EQ.1 .OR. EDGE.EQ.2) .AND.
  3588.      :    (SIGN(1.0,SX-VAL).NE.SIGN(1.0,FX-VAL))) THEN
  3589.          NOUT = NOUT+1
  3590.          IF (NOUT.LE.MAXOUT) THEN
  3591.             QX(NOUT) = VAL
  3592.             QY(NOUT) = SY + (FY-SY)*((VAL-SX)/(FX-SX))
  3593.          END IF
  3594.       ELSE IF ((EDGE.EQ.3 .OR. EDGE.EQ.4) .AND.
  3595.      :         (SIGN(1.0,SY-VAL).NE.SIGN(1.0,FY-VAL))) THEN
  3596.          NOUT = NOUT+1
  3597.          IF (NOUT.LE.MAXOUT) THEN
  3598.             QY(NOUT) = VAL
  3599.             QX(NOUT) = SX + (FX-SX)*((VAL-SY)/(FY-SY))
  3600.          END IF
  3601.       END IF
  3602. C
  3603.       END
  3604. C*GRPROM -- prompt user before clearing screen
  3605. C+
  3606.       SUBROUTINE GRPROM
  3607. C
  3608. C If the program is running under control of a terminal, display
  3609. C message and wait for the user to type <CR> before proceeding.
  3610. C
  3611. C Arguments:
  3612. C  none
  3613. C--
  3614. C 18-Aug-1994
  3615. C-----------------------------------------------------------------------
  3616.       INTEGER IER, L, GRGCOM
  3617.       CHARACTER*16 JUNK
  3618. C
  3619.       IER = GRGCOM(JUNK, 'Type <RETURN> for next page: ', L)
  3620.       END
  3621. C*GRPXPO -- Emulate pixel operations using points
  3622. C+
  3623.       SUBROUTINE GRPXPO (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3624.      1                   X1, X2, Y1, Y2)
  3625.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3626.       INTEGER IA(IDIM,JDIM)
  3627.       REAL    X1, X2, Y1, Y2
  3628. C
  3629. C Arguments:
  3630. C  IA     (input)  : the array to be plotted.
  3631. C  IDIM   (input)  : the first dimension of array A.
  3632. C  JDIM   (input)  : the second dimension of array A.
  3633. C  I1, I2 (input)  : the inclusive range of the first index
  3634. C                    (I) to be plotted.
  3635. C  J1, J2 (input)  : the inclusive range of the second
  3636. C                    index (J) to be plotted.
  3637. C  X1, X2 (input)  : the horizontal range of the output region
  3638. C  Y1, Y2 (input)  : the vertical range of the output region
  3639. C--
  3640. C 16-Jan-1991 - [GvG]
  3641. C 28-Jun-1991
  3642. C-----------------------------------------------------------------------
  3643.       INCLUDE 'f77.GRPCKG1/IN'
  3644.       INTEGER LW
  3645.       INTEGER I, J
  3646.       INTEGER ICOL, LSTCOL
  3647. C
  3648. C Save attributes
  3649. C
  3650.       CALL GRQLW(LW)
  3651.       CALL GRQCI(ICOL)
  3652.       CALL GRSLW(1)
  3653.       LSTCOL = ICOL
  3654.       DO 20 J = J1, J2
  3655.          DO 10 I = I1, I2
  3656. C
  3657. C Color changed?
  3658. C
  3659.             IF (IA(I, J) .NE. LSTCOL) THEN
  3660.                CALL GRSCI(IA(I, J))
  3661.                LSTCOL = IA(I, J)
  3662.             ENDIF
  3663. C
  3664. C Output dot
  3665. C
  3666.             CALL GRDOT0(X1 + (X2 - X1) * (I - I1 + 0.5) / (I2 - I1 + 1),
  3667.      1                  Y1 + (Y2 - Y1) * (J - J1 + 0.5) / (J2 - J1 + 1))
  3668.   10     CONTINUE
  3669.   20  CONTINUE
  3670. C
  3671. C Restore attributes
  3672. C
  3673.       CALL GRSCI(ICOL)
  3674.       CALL GRSLW(LW)
  3675.       END
  3676. C*GRPXPS -- pixel dump for color or grey PostScript.
  3677. C+
  3678.       SUBROUTINE GRPXPS (IA, IDIM, JDIM, I1, I2, J1, J2,
  3679.      :                   XMIN, XMAX, YMIN, YMAX)
  3680.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3681.       INTEGER IA(IDIM,JDIM)
  3682.       REAL XMIN, XMAX, YMIN, YMAX
  3683. C
  3684. C This routine is called by GRPIXL.
  3685. C--
  3686. C  4-Apr-93 - Created from GRGRAY by Remko Scharroo - DUT/SSRT
  3687. C  8-Apr-93 - Bugs fixed.
  3688. C  6-Jul-94 - Aligned with PGPLOT V4.9H
  3689. C  7-Sep-94 - updated for V5.0 [TJP].
  3690. C-----------------------------------------------------------------------
  3691.       INCLUDE 'f77.GRPCKG1/IN'
  3692.       INTEGER  I, J, NXP, NYP, NBUF, LCHR, II
  3693.       REAL     DX,DY,RBUF(32)
  3694.       CHARACTER*32 CHR
  3695. C-----------------------------------------------------------------------
  3696.       NXP = I2 - I1 + 1
  3697.       NYP = J2 - J1 + 1
  3698. C
  3699. C Build an image transformation matrix.
  3700. C
  3701.       DX = (XMAX-XMIN)/NXP
  3702.       DY = (YMAX-YMIN)/NYP
  3703.       RBUF(1) = 0
  3704.       RBUF(2) = NXP
  3705.       RBUF(3) = NYP
  3706.       RBUF(4) = GRXMIN(GRCIDE)
  3707.       RBUF(5) = GRXMAX(GRCIDE)
  3708.       RBUF(6) = GRYMIN(GRCIDE)
  3709.       RBUF(7) = GRYMAX(GRCIDE)
  3710.       RBUF(8) = 1.0/DX
  3711.       RBUF(9) = 0.0
  3712.       RBUF(10) = 0.0
  3713.       RBUF(11) = 1.0/DY
  3714.       RBUF(12) = (-XMIN)/DX
  3715.       RBUF(13) = (-YMIN)/DY
  3716. C
  3717. C Send setup info to driver.
  3718. C
  3719.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  3720.       CALL GRTERM
  3721.       NBUF = 13
  3722.       LCHR = 0
  3723.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3724. C
  3725. C Send the array of color indices to the driver.
  3726. C
  3727.       II = 0
  3728.       DO 20 J=J1,J2
  3729.          DO 10 I=I1,I2
  3730.             II = II + 1
  3731.             RBUF(II+1) = IA(I,J)
  3732.             IF (II.EQ.20) THEN
  3733.                NBUF = II+1
  3734.                RBUF(1) = II
  3735.                CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3736.                II = 0
  3737.             END IF
  3738.  10      CONTINUE
  3739.  20   CONTINUE
  3740.       IF (II.GT.0) THEN
  3741.          NBUF = II+1
  3742.          RBUF(1) = II
  3743.          CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3744.          II = 0
  3745.       END IF
  3746. C
  3747. C Send termination code to driver.
  3748. C
  3749.       NBUF = 1
  3750.       RBUF(1) = -1
  3751.       CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3752. C-----------------------------------------------------------------------
  3753.       END
  3754.  
  3755. C*GRPXPX -- Perform pixel operations using pixel primitive
  3756. C+
  3757.       SUBROUTINE GRPXPX (IA, IDIM, JDIM, I1, I2, J1, J2, X, Y)
  3758.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3759.       INTEGER IA(IDIM,JDIM)
  3760.       REAL    X, Y
  3761. C
  3762. C Arguments:
  3763. C  IA     (input)  : the array to be plotted.
  3764. C  IDIM   (input)  : the first dimension of array A.
  3765. C  JDIM   (input)  : the second dimension of array A.
  3766. C  I1, I2 (input)  : the inclusive range of the first index
  3767. C                    (I) to be plotted.
  3768. C  J1, J2 (input)  : the inclusive range of the second
  3769. C                    index (J) to be plotted.
  3770. C  X, Y   (input)  : the lower left corner of the output region
  3771. C                    (device coordinates)
  3772. C--
  3773. C 16-Jan-1991 - [GvG]
  3774. *  4-Aug-1993 - Debugged by Remko Scharroo
  3775. C-----------------------------------------------------------------------
  3776.       INCLUDE 'f77.GRPCKG1/IN'
  3777.       INTEGER     NSIZE
  3778.       PARAMETER   (NSIZE = 1280)
  3779.       REAL        RBUF(NSIZE + 2)
  3780.       REAL        WIDTH
  3781.       INTEGER     IC1, IC2
  3782.       INTEGER     I, J, L
  3783.       INTEGER     NBUF, LCHR
  3784.       CHARACTER*1 CHR
  3785.  
  3786.       IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  3787. C
  3788. C Get allowable color range and pixel width
  3789. C
  3790.       CALL GRQCOL(IC1, IC2)
  3791.       CALL GREXEC(GRGTYP, 3, RBUF, NBUF, CHR, LCHR)
  3792.       WIDTH = RBUF(3)
  3793.       DO 30 J = J1, J2
  3794. C
  3795. C Compute Y coordinate for this line
  3796. C
  3797.          RBUF(2) = Y + (J - J1) * WIDTH
  3798.          I = I1
  3799.   10        L = 1
  3800. C
  3801. C Compute left X coordinate for this line segment
  3802. C
  3803.             RBUF(1) = X + (I - I1) * WIDTH
  3804. C
  3805. C Check color index
  3806. C
  3807.   20           IF (IA(I, J) .LT. IC1 .OR. IC2 .LT. IA(I, J)) THEN
  3808.                   RBUF(L + 2) = 1
  3809.                ELSE
  3810.                   RBUF(L + 2) = IA(I, J)
  3811.                ENDIF
  3812.                L = L + 1
  3813.                I = I + 1
  3814. C
  3815. C Still room in segment and something left?
  3816. C
  3817.             IF (L .LE. NSIZE .AND. I .LE. I2) GOTO 20
  3818. C
  3819. C Output segment
  3820. C
  3821. *           NBUF = L + 2 ! wrong ! should be: (RS)
  3822.             NBUF = L + 1
  3823.             CALL GREXEC(GRGTYP, 26, RBUF, NBUF, CHR, LCHR)
  3824. C
  3825. C Something left?
  3826. C
  3827.          IF (I .LE. I2) GOTO 10
  3828.   30  CONTINUE
  3829.  
  3830.       END
  3831. C*GRPXRE -- Emulate pixel operations using rectangles
  3832. C+
  3833.       SUBROUTINE GRPXRE (IA, IDIM, JDIM, I1, I2, J1, J2, 
  3834.      1                   X1, X2, Y1, Y2)
  3835.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  3836.       INTEGER IA(IDIM,JDIM)
  3837.       REAL    X1, X2, Y1, Y2
  3838. C
  3839. C Arguments:
  3840. C  IA     (input)  : the array to be plotted.
  3841. C  IDIM   (input)  : the first dimension of array A.
  3842. C  JDIM   (input)  : the second dimension of array A.
  3843. C  I1, I2 (input)  : the inclusive range of the first index
  3844. C                    (I) to be plotted.
  3845. C  J1, J2 (input)  : the inclusive range of the second
  3846. C                    index (J) to be plotted.
  3847. C  X1, X2 (input)  : the horizontal range of the output region
  3848. C  Y1, Y2 (input)  : the vertical range of the output region
  3849. C--
  3850. C 18-Jan-1991 - [GvG]
  3851. C-----------------------------------------------------------------------
  3852.       REAL YB, YT
  3853.       INTEGER I, J, ICOL, LSTCOL
  3854. C
  3855. C Save color attribute
  3856. C
  3857.       CALL GRQCI(ICOL)
  3858.       LSTCOL = ICOL
  3859.       DO 20 J = J1, J2
  3860. C
  3861. C Compute Y range for this index
  3862. C
  3863.          YB = Y1 + ((Y2 - Y1) * (J - J1)) / (J2 - J1 + 1)
  3864.          YT = Y1 + ((Y2 - Y1) * (J - J1 + 1)) / (J2 - J1 + 1)
  3865.          DO 10 I = I1, I2
  3866. C
  3867. C Need to change color?
  3868. C
  3869.             IF (IA(I, J) .NE. LSTCOL) THEN
  3870.                CALL GRSCI(IA(I, J))
  3871.                LSTCOL = IA(I, J)
  3872.             ENDIF
  3873. C
  3874. C Output rectangle
  3875. C
  3876.             CALL GRREC0(X1 + ((X2 - X1) * (I - I1)) / (I2 - I1 + 1), YB,
  3877.      1                  X1 + ((X2 - X1) * (I - I1 + 1)) / (I2 - I1 + 1),
  3878.      2                  YT)
  3879.  
  3880.   10     CONTINUE
  3881.   20  CONTINUE
  3882. C
  3883. C Restore color attribute
  3884. C
  3885.       CALL GRSCI(ICOL)
  3886.       END
  3887. C*GRQCAP -- inquire device capabilities
  3888. C+
  3889.       SUBROUTINE GRQCAP (STRING)
  3890.       CHARACTER*(*) STRING
  3891. C
  3892. C GRPCKG: obtain the "device capabilities" string from the device
  3893. C driver for the current device.
  3894. C
  3895. C Arguments:
  3896. C
  3897. C STRING (output, CHARACTER*(*)): receives the device capabilities
  3898. C       string.
  3899. C--
  3900. C 26-Nov-92: new routine [TJP].
  3901. C  1-Sep-94: get from common instead of driver [TJP].
  3902. C-----------------------------------------------------------------------
  3903.       INCLUDE 'f77.GRPCKG1/IN'
  3904. C
  3905.       IF (GRCIDE.LT.1) THEN
  3906.           CALL GRWARN('GRQCAP - no graphics device is active.')
  3907.           STRING = 'NNNNNNNNNN'
  3908.       ELSE
  3909.           STRING = GRGCAP(GRCIDE)
  3910.       END IF
  3911. C
  3912.       END
  3913. C*GRQCI -- inquire current color index
  3914. C+
  3915.       SUBROUTINE GRQCI (C)
  3916. C
  3917. C GRPCKG: obtain the color index of the current graphics device.
  3918. C
  3919. C Argument:
  3920. C
  3921. C C (integer, output): receives the current color index (0-255).
  3922. C--
  3923. C (1-Feb-1983)
  3924. C-----------------------------------------------------------------------
  3925.       INCLUDE 'f77.GRPCKG1/IN'
  3926.       INTEGER  C
  3927. C
  3928.       IF (GRCIDE.LT.1) THEN
  3929.           CALL GRWARN('GRQCI - no graphics device is active.')
  3930.           C = 1
  3931.       ELSE
  3932.           C = GRCCOL(GRCIDE)
  3933.       END IF
  3934.       END
  3935. C*GRQCOL -- inquire color capability
  3936. C+
  3937.       SUBROUTINE GRQCOL (CI1, CI2)
  3938.       INTEGER  CI1, CI2
  3939. C
  3940. C Query the range of color indices available on the current device.
  3941. C
  3942. C Argument:
  3943. C  CI1    (output) : the minimum available color index. This will be
  3944. C                    either 0 if the device can write in the
  3945. C                    background color, or 1 if not.
  3946. C  CI2    (output) : the maximum available color index. This will be
  3947. C                    1 if the device has no color capability, or a
  3948. C                    larger number (e.g., 3, 7, 15, 255).
  3949. C--
  3950. C 31-May-1989 - new routine [TJP].
  3951. C  1-Sep-1994 - avoid driver call [TJP].
  3952. C-----------------------------------------------------------------------
  3953.       INCLUDE 'f77.GRPCKG1/IN'
  3954. C
  3955. C Error if no workstation is open.
  3956. C
  3957.       IF (GRCIDE.LT.1) THEN
  3958.           CI1 = 0
  3959.           CI2 = 0
  3960.       ELSE
  3961.           CI1 = GRMNCI(GRCIDE)
  3962.           CI2 = GRMXCI(GRCIDE)
  3963.       END IF
  3964. C
  3965.       END
  3966. C*GRQCR -- inquire color representation
  3967. C+
  3968.       SUBROUTINE GRQCR (CI, CR, CG, CB)
  3969.       INTEGER  CI
  3970.       REAL     CR, CG, CB
  3971. C
  3972. C Return the color representation (red, green, blue intensities) 
  3973. C currently associated with the specified color index. This may be
  3974. C different from that requested on some devices.
  3975. C
  3976. C Arguments:
  3977. C
  3978. C CI (integer, input): color index.
  3979. C CR, CG, CB (real, output): red, green, and blue intensities,
  3980. C       in range 0.0 to 1.0.
  3981. C--
  3982. C  7-Sep-1994 - rewrite [TJP].
  3983. C-----------------------------------------------------------------------
  3984.       INCLUDE 'f77.GRPCKG1/IN'
  3985.       INTEGER   NBUF, LCHR, K
  3986.       REAL      RBUF(6)
  3987.       CHARACTER CHR
  3988. C
  3989.       CR = 1.0
  3990.       CG = 1.0
  3991.       CB = 1.0
  3992.       K  = CI
  3993.       IF (GRCIDE.LT.1) THEN
  3994. C         -- no device open: return white
  3995.           CALL GRWARN('GRQCR: no plot device is open.')
  3996.       ELSE IF (GRGCAP(GRCIDE)(9:9).NE.'Y') THEN
  3997. C         -- devices that don't allow query color representation:
  3998. C            return black for ci 0, white for all others
  3999.           IF (K.EQ.0) THEN
  4000.              CR = 0.0
  4001.              CG = 0.0
  4002.              CB = 0.0
  4003.           END IF
  4004.       ELSE
  4005. C         -- query device driver; treat invalid ci as 1
  4006.           IF (K.LT.GRMNCI(GRCIDE) .OR. CI.GT.GRMXCI(GRCIDE)) THEN
  4007.              CALL GRWARN('GRQCR: invalid color index.')
  4008.              K = 1
  4009.           END IF
  4010.           RBUF(1) = K
  4011.           NBUF = 1
  4012.           LCHR = 0
  4013.           CALL GREXEC(GRGTYP,29,RBUF,NBUF,CHR,LCHR)
  4014.           IF (NBUF.LT.4) THEN
  4015.              CALL GRWARN('GRSCR: device driver error')
  4016.           ELSE
  4017.               CR = RBUF(2)
  4018.               CG = RBUF(3)
  4019.               CB = RBUF(4)
  4020.           END IF
  4021.       END IF
  4022. C
  4023.       END
  4024.  
  4025. C*GRQDEV -- inquire current device
  4026. C+
  4027.       SUBROUTINE GRQDEV (DEVICE, L)
  4028.       CHARACTER*(*) DEVICE
  4029.       INTEGER L
  4030. C
  4031. C Obtain the name of the current graphics device or file.
  4032. C
  4033. C Argument:
  4034. C  DEVICE (output): receives the device name of the
  4035. C       currently active device.
  4036. C  L (output): number of characters in DEVICE, excluding trailing
  4037. C       blanks.
  4038. C--
  4039. C 19-Feb-1988
  4040. C-----------------------------------------------------------------------
  4041.       INCLUDE 'f77.GRPCKG1/IN'
  4042. C
  4043.       IF (GRCIDE.LT.1) THEN
  4044.           DEVICE = '?'
  4045.           L = 1
  4046.       ELSE
  4047.           DEVICE = GRFILE(GRCIDE)
  4048.           L = GRFNLN(GRCIDE)
  4049.           IF (L.GT.LEN(DEVICE)) L = LEN(DEVICE)
  4050.       END IF
  4051.       END
  4052.  
  4053. C*GRQDT -- inquire current device and type
  4054. C+
  4055.       SUBROUTINE GRQDT (DEVICE)
  4056. C
  4057. C GRPCKG: obtain the name and type of the current graphics device.
  4058. C
  4059. C Argument:
  4060. C
  4061. C DEVICE (output, character): receives the device name and type of the
  4062. C       currently active device in the form 'device/type'; this is a
  4063. C       valid string for input to GROPEN.
  4064. C--
  4065. C  1-Feb-1983
  4066. C 19-Feb-1988 - add quotes if necessary.
  4067. C-----------------------------------------------------------------------
  4068.       INCLUDE 'f77.GRPCKG1/IN'
  4069.       CHARACTER*(*) DEVICE
  4070.       CHARACTER*14 TYPE
  4071.       LOGICAL   JUNK
  4072.       INTEGER   L
  4073. C
  4074.       IF (GRCIDE.LT.1) THEN
  4075.           CALL GRWARN('GRQDT - no graphics device is active.')
  4076.           DEVICE = '/NULL'
  4077.       ELSE
  4078.           CALL GRQTYP(TYPE,JUNK)
  4079.           L = GRFNLN(GRCIDE)
  4080.           IF (L.LE.0) THEN
  4081.               DEVICE = '/'//TYPE
  4082.           ELSE IF (INDEX(GRFILE(GRCIDE)(1:L), '/').EQ.0) THEN
  4083.               DEVICE = GRFILE(GRCIDE)(1:L)//'/'//TYPE
  4084.           ELSE
  4085.               DEVICE = '"'//GRFILE(GRCIDE)(1:L)//'"/'//TYPE
  4086.           END IF
  4087.       END IF
  4088.       END
  4089. C*GRQFNT -- inquire current font
  4090. C+
  4091.       SUBROUTINE GRQFNT (IF)
  4092. C
  4093. C GRPCKG: obtain the font number of the current graphics device.
  4094. C
  4095. C Argument:
  4096. C
  4097. C IF (integer, output): receives the current font number (1-3).
  4098. C--
  4099. C (19-Mar-1983)
  4100. C 15-Dec-1988 - change name [TJP].
  4101. C-----------------------------------------------------------------------
  4102.       INCLUDE 'f77.GRPCKG1/IN'
  4103.       INTEGER  IF
  4104. C
  4105.       IF (GRCIDE.LT.1) THEN
  4106.           CALL GRWARN('GRQFNT - no graphics device is active.')
  4107.           IF = 1
  4108.       ELSE
  4109.           IF = GRCFNT(GRCIDE)
  4110.       END IF
  4111.       END
  4112.  
  4113. C*GRQLS -- inquire current line-style
  4114. C+
  4115.       SUBROUTINE GRQLS (ISTYLE)
  4116.       INTEGER  ISTYLE
  4117. C
  4118. C GRPCKG: obtain the line-style of the current graphics device.
  4119. C
  4120. C Argument:
  4121. C  ISTYLE (output): receives the current line-style code.
  4122. C--
  4123. C (1-Feb-1983)
  4124. C-----------------------------------------------------------------------
  4125.       INCLUDE 'f77.GRPCKG1/IN'
  4126. C
  4127.       IF (GRCIDE.LT.1) THEN
  4128.           CALL GRWARN('GRQLS - no graphics device is active.')
  4129.           ISTYLE = 1
  4130.       ELSE
  4131.           ISTYLE = GRSTYL(GRCIDE)
  4132.       END IF
  4133.       END
  4134. C*GRQLW -- inquire current line width
  4135. C+
  4136.       SUBROUTINE GRQLW (IWIDTH)
  4137.       INTEGER  IWIDTH
  4138. C
  4139. C GRPCKG: obtain the line-width of the current graphics device.
  4140. C
  4141. C Argument:
  4142. C  IWIDTH (output): receives the current line-width.
  4143. C--
  4144. C (1-Feb-1983)
  4145. C-----------------------------------------------------------------------
  4146.       INCLUDE 'f77.GRPCKG1/IN'
  4147. C
  4148.       IF (GRCIDE.LT.1) THEN
  4149.           CALL GRWARN('GRQLW - no graphics device is active.')
  4150.           IWIDTH = 1
  4151.       ELSE
  4152.           IWIDTH = ABS(GRWIDT(GRCIDE))
  4153.       END IF
  4154.       END
  4155. C*GRQPOS -- return current pen position (absolute, world coordinates)
  4156. C+
  4157.       SUBROUTINE GRQPOS(X,Y)
  4158. C
  4159. C GRQPOS: returns the current pen position in absolute, world
  4160. C coordinates.
  4161. C
  4162. C Arguments:
  4163. C
  4164. C X, Y (real, output): world coordinates of the pen position.
  4165. C--
  4166. C  1-Mar-1991 - new routine  [JM].
  4167. C-----------------------------------------------------------------------
  4168.       REAL     X,Y
  4169.       INCLUDE 'f77.GRPCKG1/IN'
  4170. C
  4171.       IF (GRCIDE.GE.1) THEN
  4172.           X = (GRXPRE(GRCIDE) - GRXORG(GRCIDE)) / GRXSCL(GRCIDE)
  4173.           Y = (GRYPRE(GRCIDE) - GRYORG(GRCIDE)) / GRYSCL(GRCIDE)
  4174.       END IF
  4175.       END
  4176. C*GRQTXT -- get text bounding box
  4177. C+
  4178.       SUBROUTINE GRQTXT (ORIENT,X0,Y0,STRING, XBOX, YBOX)
  4179. C
  4180. C GRPCKG: get the bounding box of a string drawn by GRTEXT.
  4181. C--
  4182. C 12-Sep-1993 - [TJP].
  4183. C  8-Nov-1994 - return something even if string is blank [TJP].
  4184. C-----------------------------------------------------------------------
  4185.       INCLUDE 'f77.GRPCKG1/IN'
  4186.       LOGICAL UNUSED, VISBLE, PLOT
  4187.       INTEGER XYGRID(300)
  4188.       INTEGER LIST(256)
  4189.       CHARACTER*(*) STRING
  4190.       REAL XBOX(4), YBOX(4)
  4191.       REAL ANGLE, FACTOR, FNTBAS, FNTFAC, COSA, SINA, DX, DY, XORG, YORG
  4192.       REAL ORIENT, RATIO, X0, Y0, RLX, RLY
  4193.       REAL XG, YG, XGMIN, XGMAX, YGMIN, YGMAX
  4194.       INTEGER I, IFNTLV,NLIST,LX,LY, K, LXLAST,LYLAST
  4195.       INTRINSIC ABS, COS, LEN, MAX, MIN, SIN
  4196. C
  4197. C Default return values.
  4198. C
  4199.       DO 10 I=1,4
  4200.          XBOX(I) = X0
  4201.          YBOX(I) = Y0
  4202.  10   CONTINUE
  4203. C
  4204. C Check that there is something to be plotted.
  4205. C
  4206.       IF (LEN(STRING).LE.0) RETURN
  4207. C
  4208. C Check that a device is selected.
  4209. C
  4210.       IF (GRCIDE.LT.1) THEN
  4211.           CALL GRWARN('GRQTXT - no graphics device is active.')
  4212.           RETURN
  4213.       END IF
  4214. C
  4215.       XORG = GRXPRE(GRCIDE)
  4216.       YORG = GRYPRE(GRCIDE)
  4217. C
  4218. C Compute scaling and orientation.
  4219. C
  4220.       ANGLE = ORIENT*(3.14159265359/180.)
  4221.       FACTOR = GRCFAC(GRCIDE)/2.5
  4222.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  4223.       COSA = FACTOR * COS(ANGLE)
  4224.       SINA = FACTOR * SIN(ANGLE)
  4225.       XORG = X0
  4226.       YORG = Y0
  4227. C
  4228. C Convert the string to a list of symbol numbers; to prevent overflow
  4229. C of array LIST, the length of STRING is limited to 256 characters.
  4230. C
  4231.       CALL GRSYDS(LIST,NLIST,STRING(1:MIN(256,LEN(STRING))),
  4232.      1             GRCFNT(GRCIDE))
  4233. C
  4234. C Run through the string of characters, getting bounding box
  4235. C in character coordinates. (XG, YG) is the starting point
  4236. C of the current character. The x/y limits of the bbox are
  4237. C XGMIN...XGMAX, YGMIN...YGMAX.
  4238. C
  4239.       FNTBAS = 0.0
  4240.       FNTFAC = 1.0
  4241.       IFNTLV = 0
  4242.       DX = 0.0
  4243.       DY = 0.0
  4244.       XG = 0.0
  4245.       YG = 0.0
  4246.       XGMIN = 1E30
  4247.       XGMAX = -1E30
  4248.       YGMIN = 1E30
  4249.       YGMAX = -1E30
  4250.       PLOT  = .FALSE.
  4251.       DO 380 I=1,NLIST
  4252.           IF (LIST(I).LT.0) THEN
  4253.               IF (LIST(I).EQ.-1) THEN
  4254. C                 ! up
  4255.                   IFNTLV = IFNTLV+1
  4256.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  4257.                   FNTFAC = 0.75**ABS(IFNTLV)
  4258.               ELSE IF (LIST(I).EQ.-2) THEN
  4259. C                 ! down
  4260.                   IFNTLV = IFNTLV-1
  4261.                   FNTFAC = 0.75**ABS(IFNTLV)
  4262.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  4263.               ELSE IF (LIST(I).EQ.-3) THEN
  4264. C                 ! backspace
  4265.                   XG = XG - DX*FNTFAC
  4266.               END IF
  4267.               GOTO 380
  4268.           END IF
  4269.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  4270.           VISBLE = .FALSE.
  4271.           DX = XYGRID(5)-XYGRID(4)
  4272.           K = 4
  4273.           LXLAST = -64
  4274.           LYLAST = -64
  4275.   320     K = K+2
  4276.           LX = XYGRID(K)
  4277.           LY = XYGRID(K+1)
  4278.           IF (LY.EQ.-64) GOTO 330
  4279.           IF (LX.EQ.-64) THEN
  4280.               VISBLE = .FALSE.
  4281.           ELSE
  4282.               RLX = (LX - XYGRID(4))*FNTFAC
  4283.               RLY = (LY - XYGRID(2))*FNTFAC + FNTBAS
  4284.               IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  4285.                   XGMIN = MIN(XGMIN,XG+RLX)
  4286.                   XGMAX = MAX(XGMAX,XG+RLX)
  4287.                   YGMIN = MIN(YGMIN,RLY)
  4288.                   YGMAX = MAX(YGMAX,RLY)
  4289.                   PLOT = .TRUE.
  4290.               END IF
  4291.               VISBLE = .TRUE.
  4292.               LXLAST = LX
  4293.               LYLAST = LY
  4294.           END IF
  4295.           GOTO 320
  4296.   330     XG = XG + DX*FNTFAC
  4297.   380 CONTINUE
  4298. C
  4299. C Check whether anything was plotted.
  4300. C
  4301.       IF (.NOT.PLOT) RETURN
  4302. C
  4303. C Expand the box a bit to allow for line-width.
  4304. C
  4305.       XGMIN = XGMIN - 5.0
  4306.       XGMAX = XGMAX + 5.0
  4307.       YGMIN = YGMIN - 4.0
  4308.       YGMAX = YGMAX + 4.0
  4309. C
  4310. C Convert bounding box to device coordinates.
  4311. C
  4312. C     WRITE (*,*) XGMIN, XGMAX, YGMIN, YGMAX
  4313.       XBOX(1) = XORG + (COSA*XGMIN - SINA*YGMIN)*RATIO
  4314.       YBOX(1) = YORG + (SINA*XGMIN + COSA*YGMIN)
  4315.       XBOX(2) = XORG + (COSA*XGMIN - SINA*YGMAX)*RATIO
  4316.       YBOX(2) = YORG + (SINA*XGMIN + COSA*YGMAX)
  4317.       XBOX(3) = XORG + (COSA*XGMAX - SINA*YGMAX)*RATIO
  4318.       YBOX(3) = YORG + (SINA*XGMAX + COSA*YGMAX)
  4319.       XBOX(4) = XORG + (COSA*XGMAX - SINA*YGMIN)*RATIO
  4320.       YBOX(4) = YORG + (SINA*XGMAX + COSA*YGMIN)
  4321. C
  4322.       END
  4323. C*GRQTYP -- inquire current device type
  4324. C+
  4325.       SUBROUTINE GRQTYP (TYPE,INTER)
  4326.       CHARACTER*(*) TYPE
  4327.       LOGICAL INTER
  4328. C
  4329. C GRPCKG: obtain the device type of the currently selected graphics
  4330. C device, and determine whether or not it is an interactive device.
  4331. C
  4332. C Arguments:
  4333. C
  4334. C TYPE (output, CHARACTER*(*)): receives the device type, as a
  4335. C       character string, eg 'PRINTRONIX', 'TRILOG', 'VERSATEC',
  4336. C       'TEK4010', 'TEK4014', 'GRINNELL', or 'VT125'.  The character
  4337. C       string should have a length of at least 8 to ensure that the
  4338. C       type is unique.
  4339. C INTER (output, LOGICAL): receives the value .TRUE. if the device is
  4340. C       interactive, .FALSE. otherwise.
  4341. C--
  4342. C (23-May-1983)
  4343. C  5-Aug-1986 - add GREXEC support [AFT].
  4344. C 18-Jan-1993 - return type only, not description [TJP].
  4345. C  1-Sep-1994 - get capabilities from common [TJP].
  4346. C-----------------------------------------------------------------------
  4347.       INCLUDE 'f77.GRPCKG1/IN'
  4348.       REAL    RBUF(6)
  4349.       INTEGER NBUF,LCHR
  4350.       CHARACTER*32 CHR
  4351. C
  4352.       IF (GRCIDE.LT.1) THEN
  4353.           CALL GRWARN('GRQTYP - no graphics device is active.')
  4354.           TYPE = 'NULL'
  4355.           INTER = .FALSE.
  4356.       ELSE
  4357.           CALL GREXEC(GRGTYP, 1,RBUF,NBUF,CHR,LCHR)
  4358.           LCHR = INDEX(CHR,' ')
  4359.           TYPE = CHR(:LCHR)
  4360.           INTER = (GRGCAP(GRCIDE)(1:1).EQ.'I')
  4361.       END IF
  4362. C
  4363.       END
  4364. C*GRQUIT -- report a fatal error and abort execution
  4365. C+
  4366.       SUBROUTINE GRQUIT (TEXT)
  4367.       CHARACTER*(*) TEXT
  4368. C
  4369. C Report a fatal error (via GRWARN) and exit program.
  4370. C This routine should be called in the event of an unrecoverable 
  4371. C PGPLOT error.
  4372. C
  4373. C Argument:
  4374. C  TEXT (input): text of message to be sent to GRWARN.
  4375. C--
  4376. C 12-Nov-1994
  4377. C-----------------------------------------------------------------------
  4378. C
  4379.       CALL GRWARN(TEXT)
  4380.       CALL GRWARN('Fatal error in PGPLOT library: program terminating.')
  4381.       STOP 
  4382.       END
  4383. C*GRREC0 -- fill a rectangle (device coordinates)
  4384. C+
  4385.       SUBROUTINE GRREC0 (X0,Y0,X1,Y1)
  4386.       REAL X0, Y0, X1, Y1
  4387. C
  4388. C GRPCKG: Fill a rectangle with solid color.  The rectangle
  4389. C is defined by the (x,y) device coordinates of its lower left and
  4390. C upper right corners; the edges are parallel to the coordinate axes.
  4391. C X0 is guaranteed to be <= X1 and Y0 <= Y1. The rectangle possible
  4392. C extends beyond the clipping boundaries
  4393. C
  4394. C Arguments:
  4395. C
  4396. C X0, Y0 (input, real): device coordinates of one corner of the 
  4397. C       rectangle.
  4398. C X1, Y1 (input, real): device coordinates of the opposite corner of 
  4399. C       the rectangle.
  4400. C--
  4401. C 23-Mar-1988 - [TJP].
  4402. C 18-Jan-1991 - Code moved from GRRECT to GRREC0 so that it can also be
  4403. C               used by GRPXRE.
  4404. C  1-Sep-1994 - suppress driver call [TJP].
  4405. C  4-Dec-1995 - avoid use of real variable as do-loop index [TJP].
  4406. C-----------------------------------------------------------------------
  4407.       INCLUDE 'f77.GRPCKG1/IN'
  4408.       REAL    RBUF(6)
  4409.       INTEGER NBUF,LCHR
  4410.       CHARACTER*32 CHR
  4411.       REAL    XMIN, YMIN, XMAX, YMAX, Y, DY
  4412.       INTEGER LS, LW, I, NLINES
  4413. C
  4414. C Clip
  4415. C
  4416.       XMIN = X0
  4417.       XMAX = X1
  4418.       YMIN = Y0
  4419.       YMAX = Y1
  4420.       IF (XMIN .LT. GRXMIN(GRCIDE)) XMIN = GRXMIN(GRCIDE)
  4421.       IF (XMAX .GT. GRXMAX(GRCIDE)) XMAX = GRXMAX(GRCIDE)
  4422.       IF (YMIN .LT. GRYMIN(GRCIDE)) YMIN = GRYMIN(GRCIDE)
  4423.       IF (YMAX .GT. GRYMAX(GRCIDE)) YMAX = GRYMAX(GRCIDE)
  4424.       IF (XMIN .GT. XMAX) RETURN
  4425.       IF (YMIN .GT. YMAX) RETURN
  4426. C
  4427. C Use hardware rectangle fill if available.
  4428. C
  4429.       IF (GRGCAP(GRCIDE)(6:6).EQ.'R') THEN
  4430.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4431.           RBUF(1) = XMIN
  4432.           RBUF(2) = YMIN
  4433.           RBUF(3) = XMAX
  4434.           RBUF(4) = YMAX
  4435.           CALL GREXEC(GRGTYP,24,RBUF,NBUF,CHR,LCHR)
  4436.           RETURN
  4437. C
  4438. C Else use hardware polygon fill if available.
  4439. C
  4440.       ELSE IF (GRGCAP(GRCIDE)(4:4).EQ.'A') THEN
  4441.           IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4442.           RBUF(1) = 4
  4443.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4444.           RBUF(1) = XMIN
  4445.           RBUF(2) = YMIN
  4446.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4447.           RBUF(1) = XMAX
  4448.           RBUF(2) = YMIN
  4449.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4450.           RBUF(1) = XMAX
  4451.           RBUF(2) = YMAX
  4452.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4453.           RBUF(1) = XMIN
  4454.           RBUF(2) = YMAX
  4455.           CALL GREXEC(GRGTYP,20,RBUF,NBUF,CHR,LCHR)
  4456.           RETURN
  4457.       END IF
  4458. C
  4459. C For other devices fill area is simulated.
  4460. C
  4461. C Save attributes.
  4462. C
  4463.       CALL GRQLS(LS)
  4464.       CALL GRQLW(LW)
  4465.       CALL GRSLS(1)
  4466.       CALL GRSLW(1)
  4467.       CALL GREXEC(GRGTYP, 3,RBUF,NBUF,CHR,LCHR)
  4468.       DY = RBUF(3)
  4469. C
  4470. C Draw horizontal raster lines.
  4471. C
  4472.       NLINES = ABS((YMAX-YMIN)/DY)
  4473.       Y = YMIN - DY/2.0
  4474.       DO 40 I=1,NLINES
  4475.          Y = Y + DY
  4476.          GRXPRE(GRCIDE) = XMIN
  4477.          GRYPRE(GRCIDE) = Y
  4478.          CALL GRLIN0(XMAX,Y)
  4479.    40 CONTINUE
  4480. C
  4481. C Restore attributes.
  4482. C
  4483.       CALL GRSLS(LS)
  4484.       CALL GRSLW(LW)
  4485.       END
  4486.  
  4487. C*GRRECT -- fill a rectangle
  4488. C+
  4489.       SUBROUTINE GRRECT (X0,Y0,X1,Y1)
  4490.       REAL X0, Y0, X1, Y1
  4491. C
  4492. C GRPCKG: Fill a rectangle with solid color.  The rectangle
  4493. C is defined by the (x,y) world coordinates of its lower left and upper 
  4494. C right corners; the edges are parallel to the coordinate axes.
  4495. C
  4496. C Arguments:
  4497. C
  4498. C X0, Y0 (input, real): world coordinates of one corner of the 
  4499. C       rectangle.
  4500. C X1, Y1 (input, real): world coordinates of the opposite corner of the 
  4501. C       rectangle.
  4502. C--
  4503. C 23-Mar-1988 - [TJP].
  4504. C 18-Jan-1991 - Code moved from GRRECT to GRREC0 so that it can also be
  4505. C               used by GRPXRE
  4506. C-----------------------------------------------------------------------
  4507.       INCLUDE 'f77.GRPCKG1/IN'
  4508.       REAL    XLL, YLL, XUR, YUR
  4509.       REAL    XMIN, YMIN, XMAX, YMAX
  4510. C
  4511.       IF (GRCIDE.LT.1) RETURN
  4512. C
  4513. C Convert to device coordinates and clip.
  4514. C
  4515.       CALL GRTXY0(.FALSE.,X0,Y0,XLL,YLL)
  4516.       CALL GRTXY0(.FALSE.,X1,Y1,XUR,YUR)
  4517.       XMIN = MIN(XLL,XUR)
  4518.       XMAX = MAX(XLL,XUR)
  4519.       YMIN = MIN(YLL,YUR)
  4520.       YMAX = MAX(YLL,YUR)
  4521. C
  4522. C Do the real work
  4523. C
  4524.       CALL GRREC0(XMIN,YMIN,XMAX,YMAX)
  4525.       END
  4526. C*GRSCI -- set color index
  4527. C+
  4528.       SUBROUTINE GRSCI (IC)
  4529. C
  4530. C GRPCKG: Set the color index for subsequent plotting. Calls to GRSCI
  4531. C are ignored for monochrome devices. The default color index is 1,
  4532. C usually white on a black background for video displays or black on a
  4533. C white background for printer plots. The color index is an integer in
  4534. C the range 0 to a device-dependent maximum. Color index 0 corresponds
  4535. C to the background color; lines may be "erased" by overwriting them
  4536. C with color index 0.
  4537. C
  4538. C Color indices 0-7 are predefined as follows: 0 = black (background
  4539. C color), 1 = white (default), 2 = red, 3 = green, 4 = blue, 5 = cyan
  4540. C (blue + green), 6 = magenta (red + blue), 7 = yellow (red + green).
  4541. C The assignment of colors to color indices can be changed with
  4542. C subroutine GRSCR (set color representation).
  4543. C
  4544. C Argument:
  4545. C
  4546. C IC (integer, input): the color index to be used for subsequent
  4547. C       plotting on the current device (in range 0-255). If the
  4548. C       index exceeds the device-dependent maximum, the result is
  4549. C       device-dependent.
  4550. C--
  4551. C 11-Apr-1983 - [TJP].
  4552. C  3-Jun-1984 - add GMFILE device [TJP].
  4553. C 13-Jun-1984 - add code for TK4100 devices [TJP].
  4554. C  2-Jul-1984 - add code for RETRO and VT125 (REGIS) devices [TJP].
  4555. C  2-Oct-1984 - change REGIS to improve VT240 behavior [TJP].
  4556. C 22-Dec-1984 - add PRTX, TRILOG, VERS and VV devices [TJP].
  4557. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  4558. C  5-Aug-1986 - add GREXEC support [AFT].
  4559. C 21-Feb-1987 - delays setting color if picture not open [AFT].
  4560. C 11-Jun-1987 - remove built-in devices [TJP].
  4561. C 31-May-1989 - add check for valid color index [TJP].
  4562. C  1-Sep-1994 - use common data [TJP].
  4563. C-----------------------------------------------------------------------
  4564.       INCLUDE 'f77.GRPCKG1/IN'
  4565.       INTEGER  IC, COLOR, IC1, IC2, NBUF,LCHR
  4566.       REAL     RBUF(6)
  4567.       CHARACTER*1 CHR
  4568. C
  4569. C Error if no workstation is open.
  4570. C
  4571.       IF (GRCIDE.LT.1) THEN
  4572.           CALL GRWARN('GRSCI - no graphics device is active.')
  4573.           RETURN
  4574.       END IF
  4575. C
  4576. C Use color index 1 if out of range.
  4577. C
  4578.       IC1 = GRMNCI(GRCIDE)
  4579.       IC2 = GRMXCI(GRCIDE)
  4580.       COLOR = IC
  4581.       IF (COLOR.LT.IC1 .OR. COLOR.GT.IC2) COLOR = 1
  4582. C
  4583. C If no change to color index is requested, take no action.
  4584. C
  4585.       IF (COLOR.EQ.GRCCOL(GRCIDE)) RETURN
  4586. C
  4587. C If the workstation is in "picture open" state, send command to
  4588. C driver.
  4589. C
  4590.       IF (GRPLTD(GRCIDE)) THEN
  4591.           RBUF(1) = COLOR
  4592.           CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  4593.       END IF
  4594. C
  4595. C Set the current color index.
  4596. C
  4597.       GRCCOL(GRCIDE)=COLOR
  4598. C
  4599.       END
  4600. C*GRSCR -- set color representation
  4601. C+
  4602.       SUBROUTINE GRSCR (CI, CR, CG, CB)
  4603.       INTEGER  CI
  4604.       REAL     CR, CG, CB
  4605. C
  4606. C GRPCKG: SET COLOUR REPRESENTATION -- define the colour to be
  4607. C associated with a colour index.  Ignored for devices which do not
  4608. C support variable colour or intensity.  On monochrome output
  4609. C devices (e.g. VT125 terminals with monochrome monitors), the
  4610. C monochrome intensity is computed from the specified Red, Green, Blue
  4611. C intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television
  4612. C systems, NTSC encoding.  Note that most devices do not have an
  4613. C infinite range of colours or monochrome intensities available;
  4614. C the nearest available colour is used.
  4615. C
  4616. C Arguments:
  4617. C
  4618. C CI (integer, input): colour index. If the colour index is outside the
  4619. C       range available on the device, the call is ignored. Colour
  4620. C       index 0 applies to the background colour.
  4621. C CR, CG, CB (real, input): red, green, and blue intensities,
  4622. C       in range 0.0 to 1.0.
  4623. C--
  4624. C 20-Feb-1984 - [TJP].
  4625. C  5-Jun-1984 - add GMFILE device [TJP].
  4626. C  2-Jul-1984 - add REGIS device [TJP].
  4627. C  2-Oct-1984 - change use of map tables in Regis [TJP].
  4628. C 11-Nov-1984 - add code for /TK [TJP].
  4629. C  1-Sep-1986 - add GREXEC support [AFT].
  4630. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  4631. C 31-Aug-1994 - suppress call of begin picture [TJP].
  4632. C  1-Sep-1994 - use common data [TJP].
  4633. C 26-Jul-1995 - fix bug: some drivers would ignore a change to the
  4634. C               current color [TJP].
  4635. C-----------------------------------------------------------------------
  4636.       INCLUDE 'f77.GRPCKG1/IN'
  4637.       INTEGER   NBUF, LCHR
  4638.       REAL      RBUF(6)
  4639.       CHARACTER CHR
  4640. C
  4641.       IF (GRCIDE.LT.1) THEN
  4642.           CALL GRWARN('GRSCR - Specified workstation is not open.')
  4643.       ELSE IF (CR.LT.0.0 .OR. CG.LT.0.0 .OR. CB.LT.0.0 .OR.
  4644.      1    CR.GT.1.0 .OR. CG.GT.1.0 .OR. CB.GT.1.0) THEN
  4645.           CALL GRWARN('GRSCR - Colour is outside range [0,1].')
  4646.       ELSE IF (CI.GE.GRMNCI(GRCIDE) .AND. CI.LE.GRMXCI(GRCIDE)) THEN
  4647. C         IF (.NOT.GRPLTD(GRCIDE)) CALL GRBPIC
  4648.           RBUF(1)=CI
  4649.           RBUF(2)=CR
  4650.           RBUF(3)=CG
  4651.           RBUF(4)=CB
  4652.           NBUF=4
  4653.           CALL GREXEC(GRGTYP,21,RBUF,NBUF,CHR,LCHR)
  4654. C         -- If this is the current color, reselect it in the driver.
  4655.           IF (CI.EQ.GRCCOL(GRCIDE)) THEN
  4656.              RBUF(1) = CI
  4657.              CALL GREXEC(GRGTYP,15,RBUF,NBUF,CHR,LCHR)
  4658.           END IF
  4659.       END IF
  4660. C
  4661.       END
  4662. C GRSCRL -- scroll pixels in viewport
  4663. C+
  4664.       SUBROUTINE GRSCRL (DX, DY)
  4665.       INTEGER DX, DY
  4666. C
  4667. C Shift the pixels in the viewport by DX and DY in device coordinates.
  4668. C--
  4669. C 24-Feb-97: new routine [TJP].
  4670. C-----------------------------------------------------------------------
  4671.       INCLUDE 'f77.GRPCKG1/IN'
  4672.       INTEGER NBUF, LCHR
  4673.       REAL RBUF(6)
  4674.       CHARACTER*8 CHR
  4675. C
  4676. C Do nothing if device is not open or not in appropriate state.
  4677. C
  4678.       IF (GRCIDE.LT.1) RETURN
  4679.       IF (.NOT.GRPLTD(GRCIDE)) RETURN
  4680. C
  4681. C If device has scroll capability, use it. The arguments in
  4682. C RBUF are: (1..4) current viewport in device coordinates; 
  4683. C (5..6) scroll displacement in world coordinates.
  4684. C
  4685.       IF (GRGCAP(GRCIDE)(11:11).EQ.'S') THEN
  4686.          RBUF(1) = NINT(GRXMIN(GRCIDE))
  4687.          RBUF(2) = NINT(GRYMIN(GRCIDE))
  4688.          RBUF(3) = NINT(GRXMAX(GRCIDE))
  4689.          RBUF(4) = NINT(GRYMAX(GRCIDE))
  4690.          RBUF(5) = DX
  4691.          RBUF(6) = DY
  4692.          NBUF = 6
  4693.          LCHR = 0
  4694.          CALL GREXEC(GRGTYP,30,RBUF,NBUF,CHR,LCHR)
  4695. C
  4696. C Otherwise, report an error.
  4697. C
  4698.       ELSE
  4699.          CALL GRWARN('Device does not support scrolling')
  4700.       END IF
  4701.       END
  4702.  
  4703. C*GRSETC -- set character size
  4704. C+
  4705.       SUBROUTINE GRSETC (IDENT,XSIZE)
  4706. C
  4707. C GRPCKG : change the character size (user-callable routine).
  4708. C
  4709. C Input:   IDENT : plot identifier
  4710. C          XSIZE : the new character width. The character height
  4711. C                  and spacing will be scaled by the same factor.
  4712. C                  If XSIZE is negative or zero, the character size
  4713. C                  will be set to the default size.
  4714. C--
  4715. C (1-Feb-1983)
  4716. C 16-Sep-1985 - add code for metafile output (TJP).
  4717. C-----------------------------------------------------------------------
  4718.       INCLUDE 'f77.GRPCKG1/IN'
  4719.       INTEGER IDENT
  4720.       REAL XSIZE
  4721. C
  4722. C Record the new size (GRCFAC).
  4723. C
  4724.       CALL GRSLCT(IDENT)
  4725.       IF (XSIZE.LE.0.0) THEN
  4726.           GRCFAC(IDENT) = 1.0
  4727.       ELSE
  4728.           GRCFAC(IDENT) = XSIZE / GRCXSZ
  4729.       END IF
  4730. C
  4731.       END
  4732. C*GRSETFONT -- set text font [obsolete]
  4733. C
  4734.       SUBROUTINE GRSETFONT (IF)
  4735.       INTEGER IF
  4736.       CALL GRSFNT(IF)
  4737.       END
  4738. C*GRSETLI -- *obsolete routine*
  4739. C+
  4740.       SUBROUTINE GRSETLI (IN)
  4741. C
  4742. C GRPCKG: Set the line intensity for subsequent plotting on the current
  4743. C device. *** OBSOLETE ROUTINE *** Intensity is now set with GRSCI
  4744. C and GRSCR. For compatibility, GRSETLI now sets color zero if its
  4745. C argument is 0, and resets the previous color if its argument is
  4746. C non-zero.
  4747. C
  4748. C Argument:
  4749. C
  4750. C IN (integer, input): the intensity to be used for subsequent
  4751. C       plotting on the current device (in range 0-3).
  4752. C--
  4753. C 11-Apr-1983 - [TJP].
  4754. C 12-Jul-1984 - modify to call GRSCI [TJP].
  4755. C-----------------------------------------------------------------------
  4756.       INCLUDE 'f77.GRPCKG1/IN'
  4757.       INTEGER  IN, OLDCOL(GRIMAX)
  4758.       DATA     OLDCOL /GRIMAX*1/
  4759. C
  4760.       IF (GRCIDE.LT.1) THEN
  4761.           CALL GRWARN('GRSETLI - no graphics device is active.')
  4762.       ELSE IF (IN.EQ.0) THEN
  4763.           OLDCOL(GRCIDE) = GRCCOL(GRCIDE)
  4764.           CALL GRSCI(0)
  4765.       ELSE
  4766.           CALL GRSCI(OLDCOL(GRCIDE))
  4767.       END IF
  4768.       END
  4769.  
  4770. C*GRSETPEN -- *obsolete routine*
  4771. C+
  4772.       SUBROUTINE GRSETPEN
  4773. C
  4774. C GRPCKG: Set the pen number for subsequent plotting.  Obsolete
  4775. C routine: ignored.
  4776. C-----------------------------------------------------------------------
  4777.       CALL GRWARN('GRSETPEN is an obsolete routine.')
  4778.       END
  4779. C*GRSETS -- change size of view surface
  4780. C+
  4781.       SUBROUTINE GRSETS (IDENT,XSIZE,YSIZE)
  4782. C
  4783. C GRPCKG : change size of plotting area. The requested dimensions
  4784. C will be reduced to the absolute maximum of the plot device if
  4785. C necessary.
  4786. C
  4787. C Arguments:
  4788. C
  4789. C IDENT (input, integer): plot identifier from GROPEN.
  4790. C XSIZE (input, real): new x dimension of plot area (absolute
  4791. C               units); if less than zero, the default dimension
  4792. C               will be used.
  4793. C YSIZE (input, real): new y dimension of plot area (absolute
  4794. C               units); if less than zero, the default dimension
  4795. C               will be used.
  4796. C--
  4797. C (1-Feb-1983)
  4798. C  5-Aug-1986 - add GREXEC support [AFT].
  4799. C  5-Jan-1993 - set GRADJU [TJP].
  4800. C------------------------------------------------------------------------
  4801.       INCLUDE 'f77.GRPCKG1/IN'
  4802.       INTEGER  I, IDENT, J, IX, IY, NBUF,LCHR
  4803.       REAL     RBUF(6)
  4804.       CHARACTER CHR
  4805.       REAL     XSIZE,YSIZE
  4806. C
  4807.       CALL GRSLCT(IDENT)
  4808. C     write (*,*) 'GRSETS: old size', GRXMXA(IDENT), GRYMXA(IDENT)
  4809.       CALL GRPAGE
  4810.       IF ((XSIZE .LT. 0.0) .OR. (YSIZE .LT. 0.0)) THEN
  4811.           CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  4812.           GRXMXA(IDENT) = RBUF(2)
  4813.           GRYMXA(IDENT) = RBUF(4)
  4814.       ELSE
  4815.           I = NINT(XSIZE)
  4816.           J = NINT(YSIZE)
  4817.           CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  4818.           IX=RBUF(2)
  4819.           IY=RBUF(4)
  4820.           IF (IX.GT.0) I = MIN(I,IX)
  4821.           IF (IY.GT.0) J = MIN(J,IY)
  4822.           GRXMXA(IDENT) = I
  4823.           GRYMXA(IDENT) = J
  4824.       END IF
  4825. C     write (*,*) 'GRSETS: new size', GRXMXA(IDENT), GRYMXA(IDENT)
  4826.       GRXMIN(IDENT) = 0
  4827.       GRXMAX(IDENT) = GRXMXA(IDENT)
  4828.       GRYMIN(IDENT) = 0
  4829.       GRYMAX(IDENT) = GRYMXA(IDENT)
  4830.       GRADJU(IDENT) = .TRUE.
  4831. C
  4832.       END
  4833. C*GRSFNT -- set text font
  4834. C+
  4835.       SUBROUTINE GRSFNT (IF)
  4836.       INTEGER IF
  4837. C
  4838. C GRPCKG: Set the font for subsequent text plotting.
  4839. C The default font is 1 ("Normal" font); others available are 2
  4840. C ("Roman"), 3 ("Italic"), and 4 ("Script").
  4841. C
  4842. C Argument:
  4843. C  IF (input): the font number to be used for subsequent
  4844. C       text plotting on the current device (in range 1-4).
  4845. C--
  4846. C 19-Mar-1983 - [TJP].
  4847. C  4-Jun-1984 - add code for GMFILE device [TJP].
  4848. C 15-Dec-1988 - change name [TJP].
  4849. C-----------------------------------------------------------------------
  4850.       INCLUDE 'f77.GRPCKG1/IN'
  4851.       INTEGER    I
  4852. C
  4853.       IF (GRCIDE.LT.1) THEN
  4854.           CALL GRWARN('GRSFNT - no graphics device is active.')
  4855.           RETURN
  4856.       END IF
  4857. C
  4858. C Set software font index.
  4859. C
  4860.       IF (IF.LT.1 .OR. IF.GT.4) THEN
  4861.           CALL GRWARN('Illegal font selected: font 1 used.')
  4862.           I = 1
  4863.       ELSE
  4864.           I = IF
  4865.       END IF
  4866. C
  4867. C Ignore request if no change is to be made.
  4868. C
  4869.       IF (IF.EQ.GRCFNT(GRCIDE)) RETURN
  4870. C
  4871. C Save font setting.
  4872. C
  4873.       GRCFNT(GRCIDE) = I
  4874. C
  4875.       END
  4876.  
  4877. C*GRSIZE -- inquire device size and resolution
  4878. C+
  4879.       SUBROUTINE GRSIZE (IDENT,XSZDEF,YSZDEF,XSZMAX,YSZMAX,
  4880.      1                   XPERIN,YPERIN)
  4881. C
  4882. C GRPCKG : obtain device parameters (user-callable routine).
  4883. C--
  4884. C (1-Feb-1983)
  4885. C  5-Aug-1986 - add GREXEC support [AFT].
  4886. C-----------------------------------------------------------------------
  4887.       INCLUDE 'f77.GRPCKG1/IN'
  4888.       INTEGER IDENT
  4889.       REAL XSZDEF, YSZDEF, XSZMAX, YSZMAX, XPERIN, YPERIN
  4890.       INTEGER NBUF,LCHR
  4891.       REAL    RBUF(6)
  4892.       CHARACTER CHR
  4893. C
  4894.       CALL GRSLCT(IDENT)
  4895.       CALL GREXEC(GRGTYP, 6,RBUF,NBUF,CHR,LCHR)
  4896.       XSZDEF = RBUF(2)
  4897.       YSZDEF = RBUF(4)
  4898.       CALL GREXEC(GRGTYP, 2,RBUF,NBUF,CHR,LCHR)
  4899.       XSZMAX = RBUF(2)
  4900.       YSZMAX = RBUF(4)
  4901.       XPERIN = GRPXPI(GRCIDE)
  4902.       YPERIN = GRPYPI(GRCIDE)
  4903. C
  4904.       END
  4905. C*GRSKPB -- skip blanks in character string
  4906. C+
  4907.       SUBROUTINE GRSKPB (S, I)
  4908.       CHARACTER*(*) S
  4909.       INTEGER I
  4910. C
  4911. C GRSKPB: increment I so that it points to the next non-blank
  4912. C character in string S.  'Blank' characters are space and tab (ASCII 
  4913. C character value 9).
  4914. C
  4915. C Arguments:
  4916. C  S      (input)  : character string to be parsed.
  4917. C  I      (in/out) : on input, I is the index of the first character
  4918. C                    in S to be examined; on output, either it points
  4919. C                    to the next non-blank character, or it is equal
  4920. C                    to LEN(S)+1 (if all the rest of the string is 
  4921. C                    blank).
  4922. C--
  4923. C  1985 Oct 8 - New routine, based on SKIPBL (T. J. Pearson).
  4924. C-----------------------------------------------------------------------
  4925. C
  4926.    10 IF (I.GT.LEN(S)) RETURN
  4927.       IF (S(I:I).NE.' ' .AND. S(I:I).NE.CHAR(9)) RETURN
  4928.       I = I+1
  4929.       GOTO 10
  4930.       END
  4931.  
  4932. C*GRSLCT -- select active output device
  4933. C+
  4934.       SUBROUTINE GRSLCT (IDENT)
  4935. C
  4936. C GRPCKG: Check that IDENT is a valid plot identifier, and select the
  4937. C corresponding plot as the current plot. All subsequent plotting will
  4938. C be directed to this device until the assignment is changed by another
  4939. C call to GRSLCT.
  4940. C
  4941. C Argument:
  4942. C
  4943. C IDENT (input, integer): the identifier of the plot to be selected, as
  4944. C       returned by GROPEN.
  4945. C--
  4946. C (1-Feb-1983)
  4947. C  5-Aug-1986 - add GREXEC support [AFT].
  4948. C  4-Jun-1987 - skip action if no change in ID [TJP].
  4949. C 26-Nov-1990 - [TJP].
  4950. C-----------------------------------------------------------------------
  4951.       INCLUDE 'f77.GRPCKG1/IN'
  4952.       REAL     RBUF(6)
  4953.       INTEGER  IDENT, NBUF,LCHR
  4954.       CHARACTER CHR
  4955. C
  4956.       IF ((IDENT.LE.0) .OR. (IDENT.GT.GRIMAX) .OR.
  4957.      1    (GRSTAT(IDENT).EQ.0)) THEN
  4958.             CALL GRWARN('GRSLCT - invalid plot identifier.')
  4959.       ELSE IF (IDENT.EQ.GRCIDE) THEN
  4960.           RETURN
  4961.       ELSE
  4962.           GRCIDE = IDENT
  4963.           GRGTYP = GRTYPE(IDENT)
  4964.           RBUF(1)= GRCIDE
  4965.           RBUF(2)= GRUNIT(GRCIDE)
  4966.           NBUF   = 2
  4967.           CALL GREXEC(GRGTYP, 8,RBUF,NBUF,CHR,LCHR)
  4968.       END IF
  4969.       END
  4970. C*GRSLS -- set line style
  4971. C+
  4972.       SUBROUTINE GRSLS (IS)
  4973.       INTEGER IS
  4974. C
  4975. C GRPCKG: Set the line style for subsequent plotting on the current
  4976. C device. The different line styles are generated in hardware on
  4977. C some devices and by GRPCKG software for the other devices. Five
  4978. C different line styles are available, with the following codes:
  4979. C 1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted),
  4980. C 5 (dash-dot-dot-dot). The default is 1 (normal full line). Line
  4981. C style is ignored when drawing characters, which are always drawn with
  4982. C a full line.
  4983. C
  4984. C Argument:
  4985. C
  4986. C IS (input, integer): the line-style code for subsequent plotting on
  4987. C       the current device (in range 1-5).
  4988. C--
  4989. C  9-Feb-1983 - [TJP].
  4990. C  3-Jun-1984 - add GMFILE device [TJP].
  4991. C  5-Aug-1986 - add GREXEC support [AFT].
  4992. C 21-Feb-1987 - If needed, calls begin picture [AFT].
  4993. C 19-Jan-1987 - fix bug in GREXEC call [TJP].
  4994. C 16-May-1989 - fix bug for hardware line dash [TJP].
  4995. C  1-Sep-1994 - do not call driver to get size and capabilities [TJP].
  4996. C-----------------------------------------------------------------------
  4997.       INCLUDE 'f77.GRPCKG1/IN'
  4998.       INTEGER I, L, IDASH, NBUF,LCHR
  4999.       REAL    RBUF(6),TMP
  5000.       CHARACTER*10 CHR
  5001.       REAL PATERN(8,5)
  5002. C
  5003.       DATA PATERN/ 8*10.0,
  5004.      1             8*10.0,
  5005.      2             8.0, 6.0, 1.0, 6.0, 8.0, 6.0, 1.0, 6.0,
  5006.      3             1.0, 6.0, 1.0, 6.0, 1.0, 6.0, 1.0, 6.0,
  5007.      4             8.0, 6.0, 1.0, 6.0, 1.0, 6.0, 1.0, 6.0 /
  5008. C
  5009.       IF (GRCIDE.LT.1) THEN
  5010.           CALL GRWARN('GRSLS - no graphics device is active.')
  5011.           RETURN
  5012.       END IF
  5013. C
  5014.       I = IS
  5015.       IF (I.LT.1 .OR. I.GT.5) THEN
  5016.           CALL GRWARN('GRSLS - invalid line-style requested.')
  5017.           I = 1
  5018.       END IF
  5019. C
  5020. C Inquire if hardware dash is available.
  5021. C
  5022.       IDASH=0
  5023.       IF(GRGCAP(GRCIDE)(3:3).EQ.'D') IDASH=1
  5024. C
  5025. C Set up for hardware dash.
  5026. C
  5027.       IF(IDASH.NE.0) THEN
  5028.           GRDASH(GRCIDE) = .FALSE.
  5029.           IF (GRPLTD(GRCIDE)) THEN
  5030.               RBUF(1)=I
  5031.               NBUF=1
  5032.               CALL GREXEC(GRGTYP,19,RBUF,NBUF,CHR,LCHR)
  5033.           END IF
  5034. C
  5035. C Set up for software dash.
  5036. C
  5037.       ELSE
  5038.           IF (I.EQ.1) THEN
  5039.               GRDASH(GRCIDE) = .FALSE.
  5040.           ELSE
  5041.               GRDASH(GRCIDE) = .TRUE.
  5042.               GRIPAT(GRCIDE) = 1
  5043.               GRPOFF(GRCIDE) = 0.0
  5044.               TMP = GRYMXA(GRCIDE)/1000.
  5045.               DO 10 L=1,8
  5046.                   GRPATN(GRCIDE,L) = PATERN(L,I)*TMP
  5047.    10         CONTINUE
  5048.           END IF
  5049.       END IF
  5050.       GRSTYL(GRCIDE) = I
  5051.       END
  5052. C*GRSLW -- set line width
  5053. C+
  5054.       SUBROUTINE GRSLW (IW)
  5055.       INTEGER IW
  5056. C
  5057. C GRPCKG: Set the line width for subsequent plotting on the current
  5058. C device. If the hardware does not support thick lines, they are
  5059. C simulated by tracing each line with multiple strokes offset in the
  5060. C direction perpendicular to the line. The line width is specified by
  5061. C the number of strokes to be used, which must be in the range 1-201.
  5062. C The actual line width obtained depends on the device resolution.
  5063. C If the hardware does support thick lines, the width of the line
  5064. C is approximately 0.005 inches times the value of argument IW.
  5065. C
  5066. C Argument:
  5067. C
  5068. C IW (integer, input): the number of strokes to be used for subsequent
  5069. C       plotting on the current device (in range 1-201).
  5070. C--
  5071. C  1-Feb-1983 [TJP].
  5072. C  3-Jun-1984 [TJP] - add GMFILE device.
  5073. C 28-Aug-1984 [TJP] - correct bug in GMFILE: redundant SET_LINEWIDTH
  5074. C                     commands were not being filtered out.
  5075. C 26-May-1987 [TJP] - add GREXEC support.
  5076. C 11-Jun-1987 [TJP] - remove built-in devices.
  5077. C 31-May-1989 [TJP] - increase maximum width from 21 to 201.
  5078. C  1-Sep-1994 [TJP] 
  5079. C-----------------------------------------------------------------------
  5080.       INCLUDE 'f77.GRPCKG1/IN'
  5081.       INTEGER I, ITHICK
  5082.       REAL    RBUF(1)
  5083.       INTEGER NBUF,LCHR
  5084.       CHARACTER*32 CHR
  5085. C
  5086. C Check that graphics is active.
  5087. C
  5088.       IF (GRCIDE.LT.1) THEN
  5089.           CALL GRWARN('GRSLW - no graphics device is active.')
  5090.           RETURN
  5091.       END IF
  5092. C
  5093. C Check that requested line-width is valid.
  5094. C
  5095.       I = IW
  5096.       IF (I.LT.1 .OR. I.GT.201) THEN
  5097.           CALL GRWARN('GRSLW - invalid line-width requested.')
  5098.           I = 1
  5099.       END IF
  5100. C
  5101. C Ignore the request if the linewidth is unchanged.
  5102. C
  5103.       IF (I.EQ.ABS(GRWIDT(GRCIDE))) RETURN
  5104. C
  5105. C Inquire if hardware supports thick lines.
  5106. C
  5107.       ITHICK = 0
  5108.       IF (GRGCAP(GRCIDE)(5:5).EQ.'T') ITHICK = 1
  5109. C
  5110. C For devices with hardware support of thick lines, send the
  5111. C appropriate commands to the device driver, and give the "current
  5112. C linewidth" parameter a negative value to suppress software linewidth
  5113. C emulation.
  5114. C
  5115.       IF (ITHICK.EQ.1 .AND. GRPLTD(GRCIDE)) THEN
  5116.           RBUF(1) = I
  5117.           CALL GREXEC(GRGTYP,22,RBUF,NBUF,CHR,LCHR)
  5118.       END IF
  5119. C
  5120. C Save the current linewidth.
  5121. C
  5122.       GRWIDT(GRCIDE) = I
  5123.       IF (ITHICK.EQ.1) GRWIDT(GRCIDE) = -I
  5124. C
  5125.       END
  5126. C*GRSYDS -- decode character string into list of symbol numbers
  5127. C+
  5128.       SUBROUTINE GRSYDS (SYMBOL, NSYMBS, TEXT, FONT)
  5129.       INTEGER SYMBOL(*), NSYMBS, FONT
  5130.       CHARACTER*(*) TEXT
  5131. C
  5132. C Given a character string, this routine returns a list of symbol
  5133. C numbers to be used to plot it. It is responsible for interpreting
  5134. C all escape sequences.  Negative `symbol numbers' are inserted in the
  5135. C list to represent pen movement. The following escape sequences are
  5136. C defined (the letter following the \ may be either upper or lower 
  5137. C case):
  5138. C
  5139. C \u       :      up one level (returns -1)
  5140. C \d       :      down one level (returns -2)
  5141. C \b       :      backspace (returns -3)
  5142. C \A       :      (upper case only) Angstrom symbol, roman font
  5143. C \x       :      multiplication sign
  5144. C \.       :      centered dot
  5145. C \\       :      \, returns the code for backslash
  5146. C \gx      :      greek letter corresponding to roman letter x
  5147. C \fn      :      switch to Normal font
  5148. C \fr      :      switch to Roman font
  5149. C \fi      :      switch to Italic font
  5150. C \fs      :      switch to Script font
  5151. C \mn or \mnn :   graph marker number n or nn (1 or 2 digits)
  5152. C \(nnn)   :      Hershey symbol number nnn (any number of digits)
  5153. C
  5154. C Arguments:
  5155. C  SYMBOL (output) : receives the list of symbol numers.
  5156. C  NSYMBS (output) : receives the actual number of symbols specified
  5157. C                    by the string; it is assumed that the dimension of
  5158. C                    SYMBOL is big enough (not less than LEN(TEXT)).
  5159. C  TEXT   (input)  : the text string to be decoded.
  5160. C  FONT   (input)  : the font number (1..4) to be used for decoding the
  5161. C                    string (this can be overridden by an escape
  5162. C                    sequence within the string).
  5163. C--
  5164. C  3-May-1983 - [TJP].
  5165. C 13-Jun-1984 - add \A [TJP].
  5166. C 15-Dec-1988 - standardize [TJP].
  5167. C 29-Nov-1990 - add \m escapes [TJP].
  5168. C 27-Nov-1991 - add \x escape [TJP].
  5169. C 27-Jul-1995 - extend for 256-character set [TJP]
  5170. C  7-Nov-1995 - add \. escape [TJP].
  5171. C-----------------------------------------------------------------------
  5172.       CHARACTER*8  FONTS
  5173.       CHARACTER*48 GREEK
  5174.       PARAMETER (FONTS = 'nrisNRIS')
  5175.       PARAMETER (GREEK = 'ABGDEZYHIKLMNCOPRSTUFXQW' //
  5176.      1                   'abgdezyhiklmncoprstufxqw' )
  5177.       INTEGER  CH, IG, J, LENTXT, IFONT, MARK
  5178. C
  5179. C Initialize parameters.
  5180. C
  5181.       IFONT = FONT
  5182.       LENTXT = LEN(TEXT)
  5183.       NSYMBS = 0
  5184.       J = 0
  5185. C
  5186. C Get next character; treat non-printing characters as spaces.
  5187. C
  5188.   100 J = J+1
  5189.       IF (J.GT.LENTXT) RETURN
  5190.       CH = ICHAR(TEXT(J:J))
  5191.       IF (CH.LT.0)   CH = 32
  5192.       IF (CH.GT.303) CH = 32
  5193. C
  5194. C Test for escape sequence (\)
  5195. C
  5196.       IF (CH.EQ.92) THEN
  5197.           IF ((LENTXT-J).GE.1) THEN
  5198.             IF (TEXT(J+1:J+1).EQ.CHAR(92)) THEN
  5199.                 J = J+1
  5200.             ELSE IF (TEXT(J+1:J+1).EQ.'u' .OR.
  5201.      1                     TEXT(J+1:J+1).EQ.'U') THEN
  5202.                 NSYMBS = NSYMBS + 1
  5203.                 SYMBOL(NSYMBS) = -1
  5204.                 J = J+1
  5205.                 GOTO 100
  5206.             ELSE IF (TEXT(J+1:J+1).EQ.'d' .OR.
  5207.      1                     TEXT(J+1:J+1).EQ.'D') THEN
  5208.                 NSYMBS = NSYMBS + 1
  5209.                 SYMBOL(NSYMBS) = -2
  5210.                 J = J+1
  5211.                 GOTO 100
  5212.             ELSE IF (TEXT(J+1:J+1).EQ.'b' .OR.
  5213.      1                     TEXT(J+1:J+1).EQ.'B') THEN
  5214.                 NSYMBS = NSYMBS + 1
  5215.                 SYMBOL(NSYMBS) = -3
  5216.                 J = J+1
  5217.                 GOTO 100
  5218.             ELSE IF (TEXT(J+1:J+1).EQ.'A') THEN
  5219.                 NSYMBS = NSYMBS + 1
  5220.                 SYMBOL(NSYMBS) = 2078
  5221.                 J = J+1
  5222.                 GOTO 100
  5223.             ELSE IF (TEXT(J+1:J+1).EQ.'x') THEN
  5224.                 NSYMBS = NSYMBS + 1
  5225.                 SYMBOL(NSYMBS) = 2235
  5226.                 IF (IFONT.EQ.1) SYMBOL(NSYMBS) = 727
  5227.                 J = J+1
  5228.                 GOTO 100
  5229.             ELSE IF (TEXT(J+1:J+1).EQ.'.') THEN
  5230.                 NSYMBS = NSYMBS + 1
  5231.                 SYMBOL(NSYMBS) = 2236
  5232.                 IF (IFONT.EQ.1) SYMBOL(NSYMBS) = 729
  5233.                 J = J+1
  5234.                 GOTO 100
  5235.             ELSE IF (TEXT(J+1:J+1).EQ.'(') THEN
  5236.                 NSYMBS = NSYMBS + 1
  5237.                 SYMBOL(NSYMBS) = 0
  5238.                 J = J+2
  5239. C               -- DO WHILE ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9')
  5240.    90           IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5241.                   SYMBOL(NSYMBS) = SYMBOL(NSYMBS)*10 +
  5242.      1                      ICHAR(TEXT(J:J)) - ICHAR('0')
  5243.                    J = J+1
  5244.                 GOTO 90
  5245.                 END IF
  5246. C               -- end DO WHILE
  5247.                 IF (TEXT(J:J).NE.')') J = J-1
  5248.                 GOTO 100
  5249.             ELSE IF (TEXT(J+1:J+1).EQ.'m' .OR.
  5250.      1               TEXT(J+1:J+1).EQ.'M') THEN
  5251.                 MARK = 0
  5252.                 J = J+2
  5253.                 IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5254.                     MARK = MARK*10 + ICHAR(TEXT(J:J)) - ICHAR('0')
  5255.                     J = J+1
  5256.                 END IF
  5257.                 IF ('0'.LE.TEXT(J:J).AND.TEXT(J:J).LE.'9') THEN
  5258.                     MARK = MARK*10 + ICHAR(TEXT(J:J)) - ICHAR('0')
  5259.                     J = J+1
  5260.                 END IF
  5261.                 J = J-1
  5262.                 NSYMBS = NSYMBS + 1
  5263.                 CALL GRSYMK(MARK, IFONT, SYMBOL(NSYMBS))
  5264.                 GOTO 100
  5265.             ELSE IF (TEXT(J+1:J+1).EQ.'f' .OR.
  5266.      1               TEXT(J+1:J+1).EQ.'F') THEN
  5267.                 IFONT = INDEX(FONTS, TEXT(J+2:J+2))
  5268.                 IF (IFONT.GT.4) IFONT = IFONT-4
  5269.                 IF (IFONT.EQ.0) IFONT = 1
  5270.                 J = J+2
  5271.                 GOTO 100
  5272.             ELSE IF (TEXT(J+1:J+1).EQ.'g' .OR.
  5273.      1               TEXT(J+1:J+1).EQ.'G') THEN
  5274.                 IG = INDEX(GREEK, TEXT(J+2:J+2))
  5275.                 NSYMBS = NSYMBS + 1
  5276.                 CALL GRSYMK(255+IG, IFONT, SYMBOL(NSYMBS))
  5277.                 J = J+2
  5278.                 GOTO 100
  5279.             END IF
  5280.           END IF
  5281.       END IF
  5282. C
  5283. C Decode character.
  5284. C
  5285.       NSYMBS = NSYMBS + 1
  5286.       CALL GRSYMK(CH, IFONT, SYMBOL(NSYMBS))
  5287.       GOTO 100
  5288.       END
  5289. C*GRSYMK -- convert character number into symbol number
  5290. C+
  5291.       SUBROUTINE GRSYMK (CODE, FONT, SYMBOL)
  5292.       INTEGER CODE, FONT, SYMBOL
  5293. C
  5294. C This routine returns the Hershey symbol number (SYMBOL) corresponding
  5295. C to ASCII code CODE in font FONT.
  5296. C
  5297. C Characters 0-31 are the same in all fonts, and are the standard
  5298. C graph markers. Characters 32-127 are standard representations of
  5299. C the ASCII codes. Characters 128-255 are reserved for the upper
  5300. C half of the ISO Latin-1 character set. Characters 256-303 are
  5301. C used for the greek alphabet.
  5302. C
  5303. C Arguments:
  5304. C  CODE   (input)  : the extended ASCII code number.
  5305. C  FONT   (input)  : the font to be used 31 (range 1-4).
  5306. C  SYMBOL (output) : the number of the symbol to be plotted.
  5307. C--
  5308. C 24-Apr-1986.
  5309. C 15-Dec-1988 - standardize [TJP].
  5310. C 29-Nov-1990 - eliminate common block [TJP].
  5311. C 27-Nov-1991 - correct code for backslash [TJP].
  5312. C 27-Jul-1995 - extend for 256-character set; add some defaults for
  5313. C               ISO Latin-1 (full glyph set not available) [TJP].
  5314. C-----------------------------------------------------------------------
  5315.       INTEGER   I, K, HERSH(0:303,4)
  5316.       SAVE      HERSH
  5317. C
  5318. C Special characters (graph markers).
  5319. C
  5320.       DATA (HERSH(  0,K),K=1,4) / 841, 841, 841, 841/
  5321.       DATA (HERSH(  1,K),K=1,4) / 899, 899, 899, 899/
  5322.       DATA (HERSH(  2,K),K=1,4) / 845, 845, 845, 845/
  5323.       DATA (HERSH(  3,K),K=1,4) / 847, 847, 847, 847/
  5324.       DATA (HERSH(  4,K),K=1,4) / 840, 840, 840, 840/
  5325.       DATA (HERSH(  5,K),K=1,4) / 846, 846, 846, 846/
  5326.       DATA (HERSH(  6,K),K=1,4) / 841, 841, 841, 841/
  5327.       DATA (HERSH(  7,K),K=1,4) / 842, 842, 842, 842/
  5328.       DATA (HERSH(  8,K),K=1,4) /2284,2284,2284,2284/
  5329.       DATA (HERSH(  9,K),K=1,4) /2281,2281,2281,2281/
  5330.       DATA (HERSH( 10,K),K=1,4) / 735, 735, 735, 735/
  5331.       DATA (HERSH( 11,K),K=1,4) / 843, 843, 843, 843/
  5332.       DATA (HERSH( 12,K),K=1,4) / 844, 844, 844, 844/
  5333.       DATA (HERSH( 13,K),K=1,4) / 852, 852, 852, 852/
  5334.       DATA (HERSH( 14,K),K=1,4) / 866, 866, 866, 866/
  5335.       DATA (HERSH( 15,K),K=1,4) / 868, 868, 868, 868/
  5336.       DATA (HERSH( 16,K),K=1,4) / 851, 851, 851, 851/
  5337.       DATA (HERSH( 17,K),K=1,4) / 850, 850, 850, 850/
  5338.       DATA (HERSH( 18,K),K=1,4) / 856, 856, 856, 856/
  5339.       DATA (HERSH( 19,K),K=1,4) / 254, 254, 254, 254/
  5340.       DATA (HERSH( 20,K),K=1,4) / 900, 900, 900, 900/
  5341.       DATA (HERSH( 21,K),K=1,4) / 901, 901, 901, 901/
  5342.       DATA (HERSH( 22,K),K=1,4) / 902, 902, 902, 902/
  5343.       DATA (HERSH( 23,K),K=1,4) / 903, 903, 903, 903/
  5344.       DATA (HERSH( 24,K),K=1,4) / 904, 904, 904, 904/
  5345.       DATA (HERSH( 25,K),K=1,4) / 905, 905, 905, 905/
  5346.       DATA (HERSH( 26,K),K=1,4) / 906, 906, 906, 906/
  5347.       DATA (HERSH( 27,K),K=1,4) / 907, 907, 907, 907/
  5348.       DATA (HERSH( 28,K),K=1,4) /2263,2263,2263,2263/
  5349.       DATA (HERSH( 29,K),K=1,4) /2261,2261,2261,2261/
  5350.       DATA (HERSH( 30,K),K=1,4) /2262,2262,2262,2262/
  5351.       DATA (HERSH( 31,K),K=1,4) /2264,2264,2264,2264/
  5352. C
  5353. C US-ASCII (ISO Latin-1 lower half).
  5354. C
  5355. C   32:39 space exclam quotdbl numbersign
  5356. C         dollar percent ampersand quoteright
  5357.       DATA (HERSH( 32,K),K=1,4) / 699,2199,2199,2199/
  5358.       DATA (HERSH( 33,K),K=1,4) / 714,2214,2764,2764/
  5359.       DATA (HERSH( 34,K),K=1,4) / 717,2217,2778,2778/
  5360.       DATA (HERSH( 35,K),K=1,4) / 733,2275,2275,2275/
  5361.       DATA (HERSH( 36,K),K=1,4) / 719,2274,2769,2769/
  5362.       DATA (HERSH( 37,K),K=1,4) /2271,2271,2271,2271/
  5363.       DATA (HERSH( 38,K),K=1,4) / 734,2272,2768,2768/
  5364.       DATA (HERSH( 39,K),K=1,4) / 716,2216,2777,2777/
  5365. C   40:47 parenleft parenright asterisk plus
  5366. C         comma minus period slash
  5367.       DATA (HERSH( 40,K),K=1,4) / 721,2221,2771,2771/
  5368.       DATA (HERSH( 41,K),K=1,4) / 722,2222,2772,2772/
  5369.       DATA (HERSH( 42,K),K=1,4) / 728,2219,2773,2773/
  5370.       DATA (HERSH( 43,K),K=1,4) / 725,2232,2775,2775/
  5371.       DATA (HERSH( 44,K),K=1,4) / 711,2211,2761,2761/
  5372.       DATA (HERSH( 45,K),K=1,4) / 724,2231,2774,2774/
  5373.       DATA (HERSH( 46,K),K=1,4) / 710,2210,2760,2760/
  5374.       DATA (HERSH( 47,K),K=1,4) / 720,2220,2770,2770/
  5375. C   48:55 zero one two three four five six seven
  5376.       DATA (HERSH( 48,K),K=1,4) / 700,2200,2750,2750/
  5377.       DATA (HERSH( 49,K),K=1,4) / 701,2201,2751,2751/
  5378.       DATA (HERSH( 50,K),K=1,4) / 702,2202,2752,2752/
  5379.       DATA (HERSH( 51,K),K=1,4) / 703,2203,2753,2753/
  5380.       DATA (HERSH( 52,K),K=1,4) / 704,2204,2754,2754/
  5381.       DATA (HERSH( 53,K),K=1,4) / 705,2205,2755,2755/
  5382.       DATA (HERSH( 54,K),K=1,4) / 706,2206,2756,2756/
  5383.       DATA (HERSH( 55,K),K=1,4) / 707,2207,2757,2757/
  5384. C   56:63 eight nine colon semicolon less equal greater question
  5385.       DATA (HERSH( 56,K),K=1,4) / 708,2208,2758,2758/
  5386.       DATA (HERSH( 57,K),K=1,4) / 709,2209,2759,2759/
  5387.       DATA (HERSH( 58,K),K=1,4) / 712,2212,2762,2762/
  5388.       DATA (HERSH( 59,K),K=1,4) / 713,2213,2763,2763/
  5389.       DATA (HERSH( 60,K),K=1,4) /2241,2241,2241,2241/
  5390.       DATA (HERSH( 61,K),K=1,4) / 726,2238,2776,2776/
  5391.       DATA (HERSH( 62,K),K=1,4) /2242,2242,2242,2242/
  5392.       DATA (HERSH( 63,K),K=1,4) / 715,2215,2765,2765/
  5393. C   64:71 at A B C D E F G
  5394.       DATA (HERSH( 64,K),K=1,4) /2273,2273,2273,2273/
  5395.       DATA (HERSH( 65,K),K=1,4) / 501,2001,2051,2551/
  5396.       DATA (HERSH( 66,K),K=1,4) / 502,2002,2052,2552/
  5397.       DATA (HERSH( 67,K),K=1,4) / 503,2003,2053,2553/
  5398.       DATA (HERSH( 68,K),K=1,4) / 504,2004,2054,2554/
  5399.       DATA (HERSH( 69,K),K=1,4) / 505,2005,2055,2555/
  5400.       DATA (HERSH( 70,K),K=1,4) / 506,2006,2056,2556/
  5401.       DATA (HERSH( 71,K),K=1,4) / 507,2007,2057,2557/
  5402. C   72:79 H I J K L M N O
  5403.       DATA (HERSH( 72,K),K=1,4) / 508,2008,2058,2558/
  5404.       DATA (HERSH( 73,K),K=1,4) / 509,2009,2059,2559/
  5405.       DATA (HERSH( 74,K),K=1,4) / 510,2010,2060,2560/
  5406.       DATA (HERSH( 75,K),K=1,4) / 511,2011,2061,2561/
  5407.       DATA (HERSH( 76,K),K=1,4) / 512,2012,2062,2562/
  5408.       DATA (HERSH( 77,K),K=1,4) / 513,2013,2063,2563/
  5409.       DATA (HERSH( 78,K),K=1,4) / 514,2014,2064,2564/
  5410.       DATA (HERSH( 79,K),K=1,4) / 515,2015,2065,2565/
  5411. C   80:87 P Q R S T U V W
  5412.       DATA (HERSH( 80,K),K=1,4) / 516,2016,2066,2566/
  5413.       DATA (HERSH( 81,K),K=1,4) / 517,2017,2067,2567/
  5414.       DATA (HERSH( 82,K),K=1,4) / 518,2018,2068,2568/
  5415.       DATA (HERSH( 83,K),K=1,4) / 519,2019,2069,2569/
  5416.       DATA (HERSH( 84,K),K=1,4) / 520,2020,2070,2570/
  5417.       DATA (HERSH( 85,K),K=1,4) / 521,2021,2071,2571/
  5418.       DATA (HERSH( 86,K),K=1,4) / 522,2022,2072,2572/
  5419.       DATA (HERSH( 87,K),K=1,4) / 523,2023,2073,2573/
  5420. C   88:95 X Y Z bracketleft 
  5421. C         backslash bracketright asciicircum underscore
  5422.       DATA (HERSH( 88,K),K=1,4) / 524,2024,2074,2574/
  5423.       DATA (HERSH( 89,K),K=1,4) / 525,2025,2075,2575/
  5424.       DATA (HERSH( 90,K),K=1,4) / 526,2026,2076,2576/
  5425.       DATA (HERSH( 91,K),K=1,4) /2223,2223,2223,2223/
  5426.       DATA (HERSH( 92,K),K=1,4) / 804, 804, 804, 804/
  5427.       DATA (HERSH( 93,K),K=1,4) /2224,2224,2224,2224/
  5428.       DATA (HERSH( 94,K),K=1,4) / 718,2218,2779,2779/
  5429.       DATA (HERSH( 95,K),K=1,4) / 590, 590, 590, 590/
  5430. C   96:103 quoteleft a b c d e f g
  5431.       DATA (HERSH( 96,K),K=1,4) /2249,2249,2249,2249/
  5432.       DATA (HERSH( 97,K),K=1,4) / 601,2101,2151,2651/
  5433.       DATA (HERSH( 98,K),K=1,4) / 602,2102,2152,2652/
  5434.       DATA (HERSH( 99,K),K=1,4) / 603,2103,2153,2653/
  5435.       DATA (HERSH(100,K),K=1,4) / 604,2104,2154,2654/
  5436.       DATA (HERSH(101,K),K=1,4) / 605,2105,2155,2655/
  5437.       DATA (HERSH(102,K),K=1,4) / 606,2106,2156,2656/
  5438.       DATA (HERSH(103,K),K=1,4) / 607,2107,2157,2657/
  5439. C  104:111 h i j k l m n o
  5440.       DATA (HERSH(104,K),K=1,4) / 608,2108,2158,2658/
  5441.       DATA (HERSH(105,K),K=1,4) / 609,2109,2159,2659/
  5442.       DATA (HERSH(106,K),K=1,4) / 610,2110,2160,2660/
  5443.       DATA (HERSH(107,K),K=1,4) / 611,2111,2161,2661/
  5444.       DATA (HERSH(108,K),K=1,4) / 612,2112,2162,2662/
  5445.       DATA (HERSH(109,K),K=1,4) / 613,2113,2163,2663/
  5446.       DATA (HERSH(110,K),K=1,4) / 614,2114,2164,2664/
  5447.       DATA (HERSH(111,K),K=1,4) / 615,2115,2165,2665/
  5448. C  112:119 p q r s t u v w
  5449.       DATA (HERSH(112,K),K=1,4) / 616,2116,2166,2666/
  5450.       DATA (HERSH(113,K),K=1,4) / 617,2117,2167,2667/
  5451.       DATA (HERSH(114,K),K=1,4) / 618,2118,2168,2668/
  5452.       DATA (HERSH(115,K),K=1,4) / 619,2119,2169,2669/
  5453.       DATA (HERSH(116,K),K=1,4) / 620,2120,2170,2670/
  5454.       DATA (HERSH(117,K),K=1,4) / 621,2121,2171,2671/
  5455.       DATA (HERSH(118,K),K=1,4) / 622,2122,2172,2672/
  5456.       DATA (HERSH(119,K),K=1,4) / 623,2123,2173,2673/
  5457. C  120:127 x y z braceleft bar braceright asciitilde -
  5458.       DATA (HERSH(120,K),K=1,4) / 624,2124,2174,2674/
  5459.       DATA (HERSH(121,K),K=1,4) / 625,2125,2175,2675/
  5460.       DATA (HERSH(122,K),K=1,4) / 626,2126,2176,2676/
  5461.       DATA (HERSH(123,K),K=1,4) /2225,2225,2225,2225/
  5462.       DATA (HERSH(124,K),K=1,4) / 723,2229,2229,2229/
  5463.       DATA (HERSH(125,K),K=1,4) /2226,2226,2226,2226/
  5464.       DATA (HERSH(126,K),K=1,4) /2246,2246,2246,2246/
  5465.       DATA (HERSH(127,K),K=1,4) / 699,2199,2199,2199/
  5466. C
  5467. C ISO Latin-1 upper half.
  5468. C
  5469. C  128:135 - - - - - - - -
  5470.       DATA (HERSH(128,K),K=1,4) / 699,2199,2199,2199/
  5471.       DATA (HERSH(129,K),K=1,4) / 699,2199,2199,2199/
  5472.       DATA (HERSH(130,K),K=1,4) / 699,2199,2199,2199/
  5473.       DATA (HERSH(131,K),K=1,4) / 699,2199,2199,2199/
  5474.       DATA (HERSH(132,K),K=1,4) / 699,2199,2199,2199/
  5475.       DATA (HERSH(133,K),K=1,4) / 699,2199,2199,2199/
  5476.       DATA (HERSH(134,K),K=1,4) / 699,2199,2199,2199/
  5477.       DATA (HERSH(135,K),K=1,4) / 699,2199,2199,2199/
  5478. C  136:143 - - - - - - - -
  5479.       DATA (HERSH(136,K),K=1,4) / 699,2199,2199,2199/
  5480.       DATA (HERSH(137,K),K=1,4) / 699,2199,2199,2199/
  5481.       DATA (HERSH(138,K),K=1,4) / 699,2199,2199,2199/
  5482.       DATA (HERSH(139,K),K=1,4) / 699,2199,2199,2199/
  5483.       DATA (HERSH(140,K),K=1,4) / 699,2199,2199,2199/
  5484.       DATA (HERSH(141,K),K=1,4) / 699,2199,2199,2199/
  5485.       DATA (HERSH(142,K),K=1,4) / 699,2199,2199,2199/
  5486.       DATA (HERSH(143,K),K=1,4) / 699,2199,2199,2199/
  5487. C   144:151 dotlessi grave acute circumflex tilde - breve dotaccent
  5488.       DATA (HERSH(144,K),K=1,4) / 699,2182,2196,2199/
  5489.       DATA (HERSH(145,K),K=1,4) / 699,2199,2199,2199/
  5490.       DATA (HERSH(146,K),K=1,4) / 699,2199,2199,2199/
  5491.       DATA (HERSH(147,K),K=1,4) / 699,2199,2199,2199/
  5492.       DATA (HERSH(148,K),K=1,4) / 699,2199,2199,2199/
  5493.       DATA (HERSH(149,K),K=1,4) / 699,2199,2199,2199/
  5494.       DATA (HERSH(150,K),K=1,4) / 699,2199,2199,2199/
  5495.       DATA (HERSH(151,K),K=1,4) / 699,2199,2199,2199/
  5496. C   152:159 dieresis - ring - - - - -
  5497.       DATA (HERSH(152,K),K=1,4) / 699,2199,2199,2199/
  5498.       DATA (HERSH(153,K),K=1,4) / 699,2199,2199,2199/
  5499.       DATA (HERSH(154,K),K=1,4) / 699,2199,2199,2199/
  5500.       DATA (HERSH(155,K),K=1,4) / 699,2199,2199,2199/
  5501.       DATA (HERSH(156,K),K=1,4) / 699,2199,2199,2199/
  5502.       DATA (HERSH(157,K),K=1,4) / 699,2199,2199,2199/
  5503.       DATA (HERSH(158,K),K=1,4) / 699,2199,2199,2199/
  5504.       DATA (HERSH(159,K),K=1,4) / 699,2199,2199,2199/
  5505. C   160:167 space exclamdown cent sterling currency yen brokenbar section
  5506.       DATA (HERSH(160,K),K=1,4) / 699,2199,2199,2199/
  5507.       DATA (HERSH(161,K),K=1,4) / 699,2199,2199,2199/
  5508.       DATA (HERSH(162,K),K=1,4) / 910, 910, 910, 910/
  5509.       DATA (HERSH(163,K),K=1,4) / 272, 272, 272, 272/
  5510.       DATA (HERSH(164,K),K=1,4) / 699,2199,2199,2199/
  5511.       DATA (HERSH(165,K),K=1,4) / 699,2199,2199,2199/
  5512.       DATA (HERSH(166,K),K=1,4) / 699,2199,2199,2199/
  5513.       DATA (HERSH(167,K),K=1,4) /2276,2276,2276,2276/
  5514. C   168:175 - copyright - - - - registered -
  5515.       DATA (HERSH(168,K),K=1,4) / 699,2199,2199,2199/
  5516.       DATA (HERSH(169,K),K=1,4) / 274, 274, 274, 274/
  5517.       DATA (HERSH(170,K),K=1,4) / 699,2199,2199,2199/
  5518.       DATA (HERSH(171,K),K=1,4) / 699,2199,2199,2199/
  5519.       DATA (HERSH(172,K),K=1,4) / 699,2199,2199,2199/
  5520.       DATA (HERSH(173,K),K=1,4) / 699,2199,2199,2199/
  5521.       DATA (HERSH(174,K),K=1,4) / 273, 273, 273, 273/
  5522.       DATA (HERSH(175,K),K=1,4) / 699,2199,2199,2199/
  5523. C   176:183 degree plusminus twosuperior threesuperior
  5524. C           acute mu paragraph periodcentered
  5525.       DATA (HERSH(176,K),K=1,4) / 718,2218,2779,2779/
  5526.       DATA (HERSH(177,K),K=1,4) /2233,2233,2233,2233/
  5527.       DATA (HERSH(178,K),K=1,4) / 702,2202,2752,2752/
  5528.       DATA (HERSH(179,K),K=1,4) / 703,2203,2753,2753/
  5529.       DATA (HERSH(180,K),K=1,4) / 699,2199,2199,2199/
  5530.       DATA (HERSH(181,K),K=1,4) / 638,2138,2138,2138/
  5531.       DATA (HERSH(182,K),K=1,4) / 699,2199,2199,2199/
  5532.       DATA (HERSH(183,K),K=1,4) / 729, 729, 729, 729/
  5533. C   184:191 cedilla onesuperior ordmasculine guillemotright
  5534. C           onequarter onehalf threequarters questiondown
  5535.       DATA (HERSH(184,K),K=1,4) / 699,2199,2199,2199/
  5536.       DATA (HERSH(185,K),K=1,4) / 701,2201,2751,2751/
  5537.       DATA (HERSH(186,K),K=1,4) / 699,2199,2199,2199/
  5538.       DATA (HERSH(187,K),K=1,4) / 699,2199,2199,2199/
  5539.       DATA (HERSH(188,K),K=1,4) / 270, 270, 270, 270/
  5540.       DATA (HERSH(189,K),K=1,4) / 261, 261, 261, 261/
  5541.       DATA (HERSH(190,K),K=1,4) / 271, 271, 271, 271/
  5542.       DATA (HERSH(191,K),K=1,4) / 699,2199,2199,2199/
  5543. C   192:199 Agrave Aacute Acircumflex Atilde Aring AE Ccedilla
  5544.       DATA (HERSH(192,K),K=1,4) / 501,2001,2051,2551/
  5545.       DATA (HERSH(193,K),K=1,4) / 501,2001,2051,2551/
  5546.       DATA (HERSH(194,K),K=1,4) / 501,2001,2051,2551/
  5547.       DATA (HERSH(195,K),K=1,4) / 501,2001,2051,2551/
  5548.       DATA (HERSH(196,K),K=1,4) / 501,2001,2051,2551/
  5549.       DATA (HERSH(197,K),K=1,4) / 501,2078,2051,2551/
  5550.       DATA (HERSH(198,K),K=1,4) / 699,2199,2199,2199/
  5551.       DATA (HERSH(199,K),K=1,4) / 503,2003,2053,2553/
  5552. C   200:207 Egrave Eacute Ecircumflex Edieresis 
  5553. C           Igrave Iacute Icircumflex Idieresis
  5554.       DATA (HERSH(200,K),K=1,4) / 505,2005,2055,2555/
  5555.       DATA (HERSH(201,K),K=1,4) / 505,2005,2055,2555/
  5556.       DATA (HERSH(202,K),K=1,4) / 505,2005,2055,2555/
  5557.       DATA (HERSH(203,K),K=1,4) / 505,2005,2055,2555/
  5558.       DATA (HERSH(204,K),K=1,4) / 509,2009,2059,2559/
  5559.       DATA (HERSH(205,K),K=1,4) / 509,2009,2059,2559/
  5560.       DATA (HERSH(206,K),K=1,4) / 509,2009,2059,2559/
  5561.       DATA (HERSH(207,K),K=1,4) / 509,2009,2059,2559/
  5562. C   208:215 Eth Ntilde Ograve Oacute 
  5563. C           Ocircumflex Otilde Odieresis multiply
  5564.       DATA (HERSH(208,K),K=1,4) / 504,2004,2054,2554/
  5565.       DATA (HERSH(209,K),K=1,4) / 514,2014,2064,2564/
  5566.       DATA (HERSH(210,K),K=1,4) / 515,2015,2065,2565/
  5567.       DATA (HERSH(211,K),K=1,4) / 515,2015,2065,2565/
  5568.       DATA (HERSH(212,K),K=1,4) / 515,2015,2065,2565/
  5569.       DATA (HERSH(213,K),K=1,4) / 515,2015,2065,2565/
  5570.       DATA (HERSH(214,K),K=1,4) / 515,2015,2065,2565/
  5571.       DATA (HERSH(215,K),K=1,4) /2235,2235,2235,2235/
  5572. C   216:223 Oslash Ugrave Uacute Ucircumflex
  5573. C           Udieresis Yacute Thorn germandbls
  5574.       DATA (HERSH(216,K),K=1,4) / 515,2015,2065,2565/
  5575.       DATA (HERSH(217,K),K=1,4) / 521,2021,2071,2571/
  5576.       DATA (HERSH(218,K),K=1,4) / 521,2021,2071,2571/
  5577.       DATA (HERSH(219,K),K=1,4) / 521,2021,2071,2571/
  5578.       DATA (HERSH(220,K),K=1,4) / 521,2021,2071,2571/
  5579.       DATA (HERSH(221,K),K=1,4) / 525,2025,2075,2575/
  5580.       DATA (HERSH(222,K),K=1,4) / 699,2199,2199,2199/
  5581.       DATA (HERSH(223,K),K=1,4) / 699,2199,2199,2199/
  5582. C   224:231 agrave aacute acircumflex atilde aring ae ccedilla
  5583.       DATA (HERSH(224,K),K=1,4) / 601,2101,2151,2651/
  5584.       DATA (HERSH(225,K),K=1,4) / 601,2101,2151,2651/
  5585.       DATA (HERSH(226,K),K=1,4) / 601,2101,2151,2651/
  5586.       DATA (HERSH(227,K),K=1,4) / 601,2101,2151,2651/
  5587.       DATA (HERSH(228,K),K=1,4) / 601,2101,2151,2651/
  5588.       DATA (HERSH(229,K),K=1,4) / 601,2101,2151,2651/
  5589.       DATA (HERSH(230,K),K=1,4) / 699,2199,2199,2199/
  5590.       DATA (HERSH(231,K),K=1,4) / 603,2103,2153,2653/
  5591. C   232:239 egrave eacute ecircumflex edieresis 
  5592. C           igrave iacute icircumflex idieresis
  5593.       DATA (HERSH(232,K),K=1,4) / 605,2105,2155,2655/
  5594.       DATA (HERSH(233,K),K=1,4) / 605,2105,2155,2655/
  5595.       DATA (HERSH(234,K),K=1,4) / 605,2105,2155,2655/
  5596.       DATA (HERSH(235,K),K=1,4) / 605,2105,2155,2655/
  5597.       DATA (HERSH(236,K),K=1,4) / 609,2109,2159,2659/
  5598.       DATA (HERSH(237,K),K=1,4) / 609,2109,2159,2659/
  5599.       DATA (HERSH(238,K),K=1,4) / 609,2109,2159,2659/
  5600.       DATA (HERSH(239,K),K=1,4) / 609,2109,2159,2659/
  5601. C   240:247 eth ntilde ograve oacute 
  5602. C           ocircumflex otilde odieresis divide
  5603.       DATA (HERSH(240,K),K=1,4) / 699,2199,2199,2199/
  5604.       DATA (HERSH(241,K),K=1,4) / 614,2114,2164,2664/
  5605.       DATA (HERSH(242,K),K=1,4) / 615,2115,2165,2665/
  5606.       DATA (HERSH(243,K),K=1,4) / 615,2115,2165,2665/
  5607.       DATA (HERSH(244,K),K=1,4) / 615,2115,2165,2665/
  5608.       DATA (HERSH(245,K),K=1,4) / 615,2115,2165,2665/
  5609.       DATA (HERSH(246,K),K=1,4) / 615,2115,2165,2665/
  5610.       DATA (HERSH(247,K),K=1,4) /2237,2237,2237,2237/
  5611. C   248:255 oslash ugrave uacute ucircumflex
  5612. C           udieresis yacute thorn ydieresis
  5613.       DATA (HERSH(248,K),K=1,4) / 615,2115,2165,2665/
  5614.       DATA (HERSH(249,K),K=1,4) / 621,2121,2171,2671/
  5615.       DATA (HERSH(250,K),K=1,4) / 621,2121,2171,2671/
  5616.       DATA (HERSH(251,K),K=1,4) / 621,2121,2171,2671/
  5617.       DATA (HERSH(252,K),K=1,4) / 621,2121,2171,2671/
  5618.       DATA (HERSH(253,K),K=1,4) / 625,2125,2175,2675/
  5619.       DATA (HERSH(254,K),K=1,4) / 699,2199,2199,2199/
  5620.       DATA (HERSH(255,K),K=1,4) / 625,2125,2175,2675/
  5621. C
  5622. C Greek alphabet.
  5623. C
  5624.       DATA (HERSH(256,K),K=1,4) / 527,2027,2027,2027/
  5625.       DATA (HERSH(257,K),K=1,4) / 528,2028,2028,2028/
  5626.       DATA (HERSH(258,K),K=1,4) / 529,2029,2029,2029/
  5627.       DATA (HERSH(259,K),K=1,4) / 530,2030,2030,2030/
  5628.       DATA (HERSH(260,K),K=1,4) / 531,2031,2031,2031/
  5629.       DATA (HERSH(261,K),K=1,4) / 532,2032,2032,2032/
  5630.       DATA (HERSH(262,K),K=1,4) / 533,2033,2033,2033/
  5631.       DATA (HERSH(263,K),K=1,4) / 534,2034,2034,2034/
  5632.       DATA (HERSH(264,K),K=1,4) / 535,2035,2035,2035/
  5633.       DATA (HERSH(265,K),K=1,4) / 536,2036,2036,2036/
  5634.       DATA (HERSH(266,K),K=1,4) / 537,2037,2037,2037/
  5635.       DATA (HERSH(267,K),K=1,4) / 538,2038,2038,2038/
  5636.       DATA (HERSH(268,K),K=1,4) / 539,2039,2039,2039/
  5637.       DATA (HERSH(269,K),K=1,4) / 540,2040,2040,2040/
  5638.       DATA (HERSH(270,K),K=1,4) / 541,2041,2041,2041/
  5639.       DATA (HERSH(271,K),K=1,4) / 542,2042,2042,2042/
  5640.       DATA (HERSH(272,K),K=1,4) / 543,2043,2043,2043/
  5641.       DATA (HERSH(273,K),K=1,4) / 544,2044,2044,2044/
  5642.       DATA (HERSH(274,K),K=1,4) / 545,2045,2045,2045/
  5643.       DATA (HERSH(275,K),K=1,4) / 546,2046,2046,2046/
  5644.       DATA (HERSH(276,K),K=1,4) / 547,2047,2047,2047/
  5645.       DATA (HERSH(277,K),K=1,4) / 548,2048,2048,2048/
  5646.       DATA (HERSH(278,K),K=1,4) / 549,2049,2049,2049/
  5647.       DATA (HERSH(279,K),K=1,4) / 550,2050,2050,2050/
  5648.       DATA (HERSH(280,K),K=1,4) / 627,2127,2127,2127/
  5649.       DATA (HERSH(281,K),K=1,4) / 628,2128,2128,2128/
  5650.       DATA (HERSH(282,K),K=1,4) / 629,2129,2129,2129/
  5651.       DATA (HERSH(283,K),K=1,4) / 630,2130,2130,2130/
  5652.       DATA (HERSH(284,K),K=1,4) / 684,2184,2184,2184/
  5653.       DATA (HERSH(285,K),K=1,4) / 632,2132,2132,2132/
  5654.       DATA (HERSH(286,K),K=1,4) / 633,2133,2133,2133/
  5655.       DATA (HERSH(287,K),K=1,4) / 685,2185,2185,2185/
  5656.       DATA (HERSH(288,K),K=1,4) / 635,2135,2135,2135/
  5657.       DATA (HERSH(289,K),K=1,4) / 636,2136,2136,2136/
  5658.       DATA (HERSH(290,K),K=1,4) / 637,2137,2137,2137/
  5659.       DATA (HERSH(291,K),K=1,4) / 638,2138,2138,2138/
  5660.       DATA (HERSH(292,K),K=1,4) / 639,2139,2139,2139/
  5661.       DATA (HERSH(293,K),K=1,4) / 640,2140,2140,2140/
  5662.       DATA (HERSH(294,K),K=1,4) / 641,2141,2141,2141/
  5663.       DATA (HERSH(295,K),K=1,4) / 642,2142,2142,2142/
  5664.       DATA (HERSH(296,K),K=1,4) / 643,2143,2143,2143/
  5665.       DATA (HERSH(297,K),K=1,4) / 644,2144,2144,2144/
  5666.       DATA (HERSH(298,K),K=1,4) / 645,2145,2145,2145/
  5667.       DATA (HERSH(299,K),K=1,4) / 646,2146,2146,2146/
  5668.       DATA (HERSH(300,K),K=1,4) / 686,2186,2186,2186/
  5669.       DATA (HERSH(301,K),K=1,4) / 648,2148,2148,2148/
  5670.       DATA (HERSH(302,K),K=1,4) / 649,2149,2149,2149/
  5671.       DATA (HERSH(303,K),K=1,4) / 650,2150,2150,2150/
  5672. C
  5673.       IF ((CODE.LT.0) .OR. (CODE.GT.303)) THEN
  5674.           I = 1
  5675.       ELSE
  5676.           I = CODE
  5677.       END IF
  5678.       SYMBOL = HERSH(I,FONT)
  5679. C
  5680.       END
  5681. C*GRTERM -- flush buffer to output device
  5682. C+
  5683.       SUBROUTINE GRTERM
  5684. C
  5685. C GRPCKG: flush the buffer associated with the current plot. GRTERM
  5686. C should be called only when it is necessary to make sure that all the
  5687. C graphics created up to this point in the program are visible on the
  5688. C device, e.g., before beginning a dialog with the user. GRTERM has no
  5689. C effect on hardcopy devices.
  5690. C
  5691. C Arguments: none.
  5692. C--
  5693. C  6-Oct-1983
  5694. C 29-Jan-1985 - add HP2648 device [KS/TJP].
  5695. C 31-Dec-1985 - do not send CAN code to true Tek [TJP/PCP].
  5696. C  5-Aug-1986 - add GREXEC support [AFT].
  5697. C 11-Jun-1987 - remove built-in devices [TJP].
  5698. C-----------------------------------------------------------------------
  5699.       INCLUDE 'f77.GRPCKG1/IN'
  5700.       INTEGER NBUF,LCHR
  5701.       REAL    RBUF(6)
  5702.       CHARACTER CHR
  5703. C
  5704.       IF (GRCIDE.GE.1) THEN
  5705.           CALL GREXEC(GRGTYP,16,RBUF,NBUF,CHR,LCHR)
  5706.       END IF
  5707.       END
  5708. C*GRTEXT -- draw text
  5709. C+
  5710.       SUBROUTINE GRTEXT (CENTER,ORIENT,ABSXY,X0,Y0,STRING)
  5711. C
  5712. C GRPCKG: Write a text string using the high-quality character set.
  5713. C The text is NOT windowed in the current viewport, but may extend over
  5714. C the whole view surface.  Line attributes (color, intensity thickness)
  5715. C apply to text, but line-style is ignored.  The current pen position
  5716. C after a call to GRTEXT is undefined.
  5717. C
  5718. C Arguments:
  5719. C
  5720. C STRING (input, character): the character string to be plotted. This
  5721. C       may include standard escape-sequences to represent non-ASCII
  5722. C       characters and special commands. The number of characters in
  5723. C       STRING (i.e., LEN(STRING)) should not exceed 256.
  5724. C--
  5725. C (3-May-1983)
  5726. C  5-Aug-1986 - add GREXEC support [AFT].
  5727. C  6-Sep-1989 - standardize [TJP].
  5728. C 20-Apr-1995 - Verbose PS file support.  If PGPLOT_PS_VERBOSE_TEXT is
  5729. C               defined, text strings in PS files are preceded by a 
  5730. C               comment with the text of the string plotted as vectors
  5731. C               [TJP after D.S.Briggs].
  5732. C  4-Feb-1997 - grexec requires an RBUF array, not a scalar [TJP].
  5733. C-----------------------------------------------------------------------
  5734.       INCLUDE 'f77.GRPCKG1/IN'
  5735.       LOGICAL ABSXY,UNUSED,VISBLE,CENTER
  5736.       INTEGER XYGRID(300)
  5737.       INTEGER LIST(256)
  5738.       CHARACTER*(*) STRING
  5739.       REAL ANGLE, FACTOR, FNTBAS, FNTFAC, COSA, SINA, DX, DY, XORG, YORG
  5740.       REAL XCUR, YCUR, ORIENT, RATIO, X0, Y0, RLX, RLY
  5741.       REAL XMIN, XMAX, YMIN, YMAX
  5742.       REAL RBUF(6)
  5743.       INTEGER I, IFNTLV,NLIST,LX,LY, K, LXLAST,LYLAST, LSTYLE
  5744.       INTEGER SLEN, GRTRIM
  5745.       INTRINSIC ABS, COS, LEN, MIN, SIN
  5746.       CHARACTER DEVTYP*14, STEMP*258
  5747.       LOGICAL DEVINT, VTEXT
  5748. C
  5749. C Check that there is something to be plotted.
  5750. C
  5751.       IF (LEN(STRING).LE.0) RETURN
  5752. C
  5753. C Check that a device is selected.
  5754. C
  5755.       IF (GRCIDE.LT.1) THEN
  5756.           CALL GRWARN('GRTEXT - no graphics device is active.')
  5757.           RETURN
  5758.       END IF
  5759. C
  5760. C Save current line-style, and set style "normal".
  5761. C
  5762.       CALL GRQLS(LSTYLE)
  5763.       CALL GRSLS(1)
  5764. C
  5765. C Put device dependent code here or at end
  5766. C
  5767.       VTEXT = .FALSE.
  5768.       CALL GRQTYP (DEVTYP, DEVINT)
  5769.       IF ((DEVTYP.EQ.'PS').OR.(DEVTYP.EQ.'VPS').OR.
  5770.      1    (DEVTYP.EQ.'CPS').OR.(DEVTYP.EQ.'VCPS')) THEN
  5771.          CALL GRGENV ('PS_VERBOSE_TEXT', STEMP, I)
  5772.          VTEXT = (I.GT.0)
  5773.          IF (VTEXT) THEN
  5774.             SLEN = GRTRIM(STRING)
  5775.             STEMP = '% Start "' // STRING(1:SLEN) // '"'
  5776.             CALL GREXEC (GRGTYP, 23, RBUF, 0, STEMP, SLEN+10)
  5777.          END IF
  5778.       END IF
  5779. C
  5780. C Save current viewport, and open the viewport to include the full
  5781. C view surface.
  5782. C
  5783.       XORG = GRXPRE(GRCIDE)
  5784.       YORG = GRYPRE(GRCIDE)
  5785.       XMIN = GRXMIN(GRCIDE)
  5786.       XMAX = GRXMAX(GRCIDE)
  5787.       YMIN = GRYMIN(GRCIDE)
  5788.       YMAX = GRYMAX(GRCIDE)
  5789.       CALL GRAREA(GRCIDE, 0.0, 0.0, 0.0, 0.0)
  5790. C
  5791. C Compute scaling and orientation.
  5792. C
  5793.       ANGLE = ORIENT*(3.14159265359/180.)
  5794.       FACTOR = GRCFAC(GRCIDE)/2.5
  5795.       RATIO = GRPXPI(GRCIDE)/GRPYPI(GRCIDE)
  5796.       COSA = FACTOR * COS(ANGLE)
  5797.       SINA = FACTOR * SIN(ANGLE)
  5798.       CALL GRTXY0(ABSXY, X0, Y0, XORG, YORG)
  5799.       FNTBAS = 0.0
  5800.       FNTFAC = 1.0
  5801.       IFNTLV = 0
  5802.       DX = 0.0
  5803.       DY = 0.0
  5804. C
  5805. C Convert the string to a list of symbol numbers; to prevent overflow
  5806. C of array LIST, the length of STRING is limited to 256 characters.
  5807. C
  5808.       CALL GRSYDS(LIST,NLIST,STRING(1:MIN(256,LEN(STRING))),
  5809.      1             GRCFNT(GRCIDE))
  5810. C
  5811. C Plot the string of characters
  5812. C
  5813.       DO 380 I = 1,NLIST
  5814.           IF (LIST(I).LT.0) THEN
  5815.               IF (LIST(I).EQ.-1) THEN
  5816. C                 ! up
  5817.                   IFNTLV = IFNTLV+1
  5818.                   FNTBAS = FNTBAS + 16.0*FNTFAC
  5819.                   FNTFAC = 0.75**ABS(IFNTLV)
  5820.               ELSE IF (LIST(I).EQ.-2) THEN
  5821. C                 ! down
  5822.                   IFNTLV = IFNTLV-1
  5823.                   FNTFAC = 0.75**ABS(IFNTLV)
  5824.                   FNTBAS = FNTBAS - 16.0*FNTFAC
  5825.               ELSE IF (LIST(I).EQ.-3) THEN
  5826. C                 ! backspace
  5827.                   XORG = XORG - DX*FNTFAC
  5828.                   YORG = YORG - DY*FNTFAC
  5829.               END IF
  5830.               GOTO 380
  5831.           END IF
  5832.           CALL GRSYXD(LIST(I),XYGRID,UNUSED)
  5833.           VISBLE = .FALSE.
  5834.           LX = XYGRID(5)-XYGRID(4)
  5835.           DX = COSA*LX*RATIO
  5836.           DY = SINA*LX
  5837.           K = 4
  5838.           LXLAST = -64
  5839.           LYLAST = -64
  5840.   320     K = K+2
  5841.           LX = XYGRID(K)
  5842.           LY = XYGRID(K+1)
  5843.           IF (LY.EQ.-64) GOTO 330
  5844.           IF (LX.EQ.-64) THEN
  5845.               VISBLE = .FALSE.
  5846.           ELSE
  5847.               RLX = (LX - XYGRID(4))*FNTFAC
  5848.               RLY = (LY - XYGRID(2))*FNTFAC + FNTBAS
  5849.               IF ((LX.NE.LXLAST) .OR. (LY.NE.LYLAST)) THEN
  5850.                   XCUR = XORG + (COSA*RLX - SINA*RLY)*RATIO
  5851.                   YCUR = YORG + (SINA*RLX + COSA*RLY)
  5852.                   IF (VISBLE) THEN
  5853.                       CALL GRLIN0(XCUR,YCUR)
  5854.                   ELSE
  5855.                       GRXPRE(GRCIDE) = XCUR
  5856.                       GRYPRE(GRCIDE) = YCUR
  5857.                   END IF
  5858.               END IF
  5859.               VISBLE = .TRUE.
  5860.               LXLAST = LX
  5861.               LYLAST = LY
  5862.           END IF
  5863.           GOTO 320
  5864.   330     XORG = XORG + DX*FNTFAC
  5865.           YORG = YORG + DY*FNTFAC
  5866.   380 CONTINUE
  5867. C
  5868. C Set pen position ready for next character.
  5869. C
  5870.       GRXPRE(GRCIDE) = XORG
  5871.       GRYPRE(GRCIDE) = YORG
  5872. C
  5873. C Another possible device dependent section
  5874. C
  5875.       IF (VTEXT) THEN
  5876.          STEMP = '% End "' // STRING(1:SLEN) // '"'
  5877.          CALL GREXEC(GRGTYP, 23, RBUF, 0, STEMP, SLEN+8)
  5878.       END IF
  5879. C
  5880. C Restore the viewport and line-style, and return.
  5881. C
  5882.       GRXMIN(GRCIDE) = XMIN
  5883.       GRXMAX(GRCIDE) = XMAX
  5884.       GRYMIN(GRCIDE) = YMIN
  5885.       GRYMAX(GRCIDE) = YMAX
  5886.       CALL GRSLS(LSTYLE)
  5887. C
  5888.       END
  5889.  
  5890. C*GRTOUP -- convert character string to upper case
  5891. C+
  5892.       SUBROUTINE GRTOUP (DST, SRC)
  5893.       CHARACTER*(*) DST, SRC
  5894. C
  5895. C GRPCKG (internal routine): convert character string to upper case.
  5896. C
  5897. C Arguments:
  5898. C  DST    (output) : output string (upper case).
  5899. C  SRC    (input)  : input string to be converted.
  5900. C--
  5901. C 1988-Jan-18 (TJP)
  5902. C-----------------------------------------------------------------------
  5903.       INTEGER I, N, NCHI, NCHO, NCH
  5904.       NCHI = LEN(SRC)
  5905.       NCHO = LEN(DST)
  5906.       NCH = MIN(NCHI, NCHO)
  5907.       DO 10 I=1,NCH
  5908.           N = ICHAR(SRC(I:I))
  5909.           IF ((N .GE. 97) .AND. (N .LE. 122)) THEN
  5910.               DST(I:I) = CHAR(N - 32)
  5911.           ELSE
  5912.               DST(I:I) = CHAR(N)
  5913.           END IF
  5914.    10 CONTINUE
  5915.       IF (NCHO .GT. NCHI) DST(NCHI+1:NCHO) = ' '
  5916.       END
  5917.  
  5918. C*GRTRAN -- define scaling transformation
  5919. C+
  5920.       SUBROUTINE GRTRAN (IDENT,XORG,YORG,XSCALE,YSCALE)
  5921. C
  5922. C GRPCKG (internal routine): Define scaling transformation.
  5923. C
  5924. C Arguments:
  5925. C
  5926. C IDENT (input, integer): plot identifier, as returned by GROPEN.
  5927. C XORG, YORG, XSCALE, YSCALE (input, real): parameters of the scaling
  5928. C       transformation. This is defined by:
  5929. C               XABS = XORG + XWORLD * XSCALE,
  5930. C               YABS = YORG + YWORLD * YSCALE,
  5931. C       where (XABS, YABS) are the absolute device coordinates
  5932. C       corresponding to world coordinates (XWORLD, YWORLD).
  5933. C--
  5934. C (1-Feb-1983)
  5935. C-----------------------------------------------------------------------
  5936.       INTEGER  IDENT
  5937.       REAL     XORG, YORG, XSCALE, YSCALE
  5938. C
  5939.       CALL GRSLCT(IDENT)
  5940.       CALL GRTRN0(XORG, YORG, XSCALE, YSCALE)
  5941. C
  5942.       END
  5943. C*GRTRN0 -- define scaling transformation
  5944. C+
  5945.       SUBROUTINE GRTRN0 (XORG,YORG,XSCALE,YSCALE)
  5946. C
  5947. C GRPCKG (internal routine): Define scaling transformation for current
  5948. C device (equivalent to GRTRAN without device selection).
  5949. C
  5950. C Arguments:
  5951. C
  5952. C XORG, YORG, XSCALE, YSCALE (input, real): parameters of the scaling
  5953. C       transformation. This is defined by:
  5954. C               XABS = XORG + XWORLD * XSCALE,
  5955. C               YABS = YORG + YWORLD * YSCALE,
  5956. C       where (XABS, YABS) are the absolute device coordinates
  5957. C       corresponding to world coordinates (XWORLD, YWORLD).
  5958. C--
  5959. C  1-Feb-83:
  5960. C 11-Feb-92: Add driver support (TJP).
  5961. C  1-Sep-94: Suppress driver call (TJP).
  5962. C-----------------------------------------------------------------------
  5963.       INCLUDE 'f77.GRPCKG1/IN'
  5964.       REAL     XORG, YORG, XSCALE, YSCALE
  5965.       REAL           RBUF(6)
  5966.       INTEGER        NBUF,LCHR
  5967.       CHARACTER*16   CHR
  5968. C
  5969.       GRXORG(GRCIDE) = XORG
  5970.       GRXSCL(GRCIDE) = XSCALE
  5971.       GRYORG(GRCIDE) = YORG
  5972.       GRYSCL(GRCIDE) = YSCALE
  5973. C
  5974. C Pass info to device driver?
  5975. C
  5976.       IF (GRGCAP(GRCIDE)(2:2).EQ.'X') THEN
  5977.           RBUF(1) = XORG
  5978.           RBUF(2) = XSCALE
  5979.           RBUF(3) = YORG
  5980.           RBUF(4) = YSCALE
  5981.           NBUF = 4
  5982.           LCHR = 0
  5983.           CALL GREXEC(GRGTYP,27,RBUF,NBUF,CHR,LCHR)
  5984.       END IF
  5985. C
  5986.       END
  5987.  
  5988. C*GRTXY0 -- convert world coordinates to device coordinates
  5989. C+
  5990.       SUBROUTINE GRTXY0 (ABSXY,X,Y,XT,YT)
  5991. C
  5992. C GRPCKG (internal routine): Convert scaled position to absolute
  5993. C position.
  5994. C
  5995. C Arguments:
  5996. C
  5997. C ABSXY (input, logical): if FALSE, convert world coordinates to
  5998. C       absolute device coordinates; if TRUE, return the input
  5999. C       coordinates unchanged.
  6000. C X, Y (input, real): input coordinates (absolute or world, depending
  6001. C       on setting of ABSXY).
  6002. C XT, YT (output, real): output absolute device coordinates.
  6003. C--
  6004. C (1-Feb-1983)
  6005. C-----------------------------------------------------------------------
  6006.       INCLUDE 'f77.GRPCKG1/IN'
  6007.       LOGICAL  ABSXY
  6008.       REAL     X, Y, XT, YT
  6009. C
  6010.       IF (ABSXY) THEN
  6011.           XT = X
  6012.           YT = Y
  6013.       ELSE
  6014.           XT = X * GRXSCL(GRCIDE) + GRXORG(GRCIDE)
  6015.           YT = Y * GRYSCL(GRCIDE) + GRYORG(GRCIDE)
  6016.       END IF
  6017. C
  6018.       END
  6019.  
  6020. C*GRVCT0 -- draw line segments or dots
  6021. C+
  6022.       SUBROUTINE GRVCT0 (MODE,ABSXY,POINTS,X,Y)
  6023. C
  6024. C GRPCKG (internal routine): Draw a line or a set of dots. This
  6025. C is the same as GRVECT, but without device selection. It can be used to
  6026. C draw a single line-segment, a continuous series of line segments, or
  6027. C one or more single dots (pixels).
  6028. C
  6029. C Arguments:
  6030. C
  6031. C MODE (input, integer): if MODE=1, a series of line segments is drawn,
  6032. C       starting at the current position, moving to X(1),Y(1), ... and
  6033. C       ending at X(POINTS),Y(POINTS).
  6034. C       If MODE=2, the first vector is blanked, so the line starts at
  6035. C       X(1),Y(1).
  6036. C       If MODE=3, a single dot is placed at each coordinate pair, with
  6037. C       no connecting lines.
  6038. C ABSXY (input, logical): if TRUE, the coordinates are absolute device
  6039. C       coordinates; if FALSE, they are world coordinates and the
  6040. C       scaling transformation is applied.
  6041. C POINTS (input, integer): the number of coordinate pairs.
  6042. C X, Y (input, real arrays, dimensioned POINTS or greater): the
  6043. C       X and Y coordinates of the points.
  6044. C--
  6045. C (1-Feb-1983)
  6046. C-----------------------------------------------------------------------
  6047.       INCLUDE 'f77.GRPCKG1/IN'
  6048.       INTEGER  I, MODE, POINTS
  6049.       LOGICAL  ABSXY
  6050.       REAL     X(POINTS), Y(POINTS), XCUR, YCUR
  6051. C
  6052.       IF (MODE.EQ.1) THEN
  6053.           CALL GRTXY0(ABSXY, X(1), Y(1), XCUR, YCUR)
  6054.           CALL GRLIN0(XCUR, YCUR)
  6055.       ELSE IF (MODE.EQ.2) THEN
  6056.           CALL GRTXY0(ABSXY, X(1), Y(1), GRXPRE(GRCIDE), GRYPRE(GRCIDE))
  6057.       END IF
  6058.       IF (MODE.EQ.1 .OR. MODE.EQ.2) THEN
  6059.           DO 10 I=2,POINTS
  6060.               CALL GRTXY0(ABSXY, X(I), Y(I), XCUR, YCUR)
  6061.               CALL GRLIN0(XCUR, YCUR)
  6062.    10     CONTINUE
  6063.       ELSE IF (MODE.EQ.3) THEN
  6064.           DO 20 I=1,POINTS
  6065.               CALL GRTXY0(ABSXY, X(I), Y(I), XCUR, YCUR)
  6066.               CALL GRDOT0(XCUR, YCUR)
  6067.    20     CONTINUE
  6068.       END IF
  6069. C
  6070.       END
  6071.  
  6072. C*GRVECT -- draw line segments or dots
  6073. C+
  6074.       SUBROUTINE GRVECT (IDENT,MODE,ABSXY,POINTS,X,Y)
  6075. C
  6076. C GRPCKG: Draw a line or a set of dots. This routine can be used to
  6077. C draw a single line-segment, a continuous series of line segments, or
  6078. C one or more single dots (pixels).
  6079. C
  6080. C Arguments:
  6081. C
  6082. C IDENT (input, integer): the plot identifier, as returned by GROPEN.
  6083. C MODE (input, integer): if MODE=1, a series of line segments is drawn,
  6084. C       starting at the current position, moving to X(1),Y(1), ... and
  6085. C       ending at X(POINTS),Y(POINTS).
  6086. C       If MODE=2, the first vector is blanked, so the line starts at
  6087. C       X(1),Y(1).
  6088. C       If MODE=3, a single dot is placed at each coordinate pair, with
  6089. C       no connecting lines.
  6090. C ABSXY (input, logical): if TRUE, the coordinates are absolute device
  6091. C       coordinates; if FALSE, they are world coordinates and the
  6092. C       scaling transformation is applied.
  6093. C POINTS (input, integer): the number of coordinate pairs.
  6094. C X, Y (input, real arrays, dimensioned POINTS or greater): the
  6095. C       X and Y coordinates of the points.
  6096. C--
  6097. C (1-Feb-1983)
  6098. C-----------------------------------------------------------------------
  6099.       INTEGER  IDENT, MODE, POINTS
  6100.       LOGICAL  ABSXY
  6101.       REAL     X(POINTS), Y(POINTS)
  6102. C
  6103.       CALL GRSLCT(IDENT)
  6104.       IF (MODE.LE.0 .OR. MODE.GT.3) THEN
  6105.           CALL GRWARN('GRVECT - invalid MODE parameter.')
  6106.       ELSE IF (POINTS.GT.0) THEN
  6107.           CALL GRVCT0(MODE, ABSXY, POINTS, X, Y)
  6108.       END IF
  6109. C
  6110.       END
  6111. C*GRWARN -- issue warning message to user
  6112. C+
  6113.       SUBROUTINE GRWARN (TEXT)
  6114.       CHARACTER*(*) TEXT
  6115. C
  6116. C Report a warning message on standard output, with prefix "%PGPLOT, ".
  6117. C
  6118. C Argument:
  6119. C  TEXT (input): text of message to be printed (the string
  6120. C      may not be blank).
  6121. C--
  6122. C  8-Nov-1994 [TJP]
  6123. C-----------------------------------------------------------------------
  6124.       INTEGER   GRTRIM
  6125. C
  6126.       IF (TEXT.NE.' ') THEN
  6127.           WRITE (*, '(1X,2A)') '%PGPLOT, ', TEXT(1:GRTRIM(TEXT))
  6128.       END IF
  6129.       END
  6130. C*GRXHLS -- convert RGB color to HLS color
  6131. C+
  6132.       SUBROUTINE GRXHLS (R,G,B,H,L,S)
  6133. C
  6134. C GRPCKG: Convert a color specified in the RGB color model to one in
  6135. C the HLS model.  This is a support routine: no graphics I/O occurs.
  6136. C The inverse transformation is accomplished with routine GRXRGB.
  6137. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  6138. C Committee, Computer Graphics, Vol.13, No.3, Association for
  6139. C Computing Machinery, New York, NY, 1979.
  6140. C
  6141. C Arguments:
  6142. C
  6143. C R,G,B (real, input): red, green, blue color coordinates, each in the
  6144. C       range 0.0 to 1.0. Input outside this range causes HLS = (0,1,0)
  6145. C       [white] to be returned.
  6146. C H,L,S (real, output): hue (0 to 360), lightness (0 to 1.0), and
  6147. C       saturation (0 to 1.0).
  6148. C--
  6149. C  2-Jul-1984 - new routine [TJP].
  6150. C 29-Sep-1994 - force H to be in rnage 0-360 [Remko Scharroo; TJP].
  6151. C-----------------------------------------------------------------------
  6152.       REAL     R,G,B, H,L,S, MA, MI, RR, GG, BB, D
  6153. C
  6154.       H = 0.0
  6155.       L = 1.0
  6156.       S = 0.0
  6157.       MA = MAX(R,G,B)
  6158.       MI = MIN(R,G,B)
  6159.       IF (MA.GT.1.0 .OR. MI.LT.0.0) RETURN
  6160.       RR = (MA-R)
  6161.       GG = (MA-G)
  6162.       BB = (MA-B)
  6163. C
  6164. C Lightness
  6165. C
  6166.       L = 0.5*(MA+MI)
  6167. C
  6168. C Achromatic case (R=G=B)
  6169. C
  6170.       IF (MA.EQ.MI) THEN
  6171.           S = 0.0
  6172.           H = 0.0
  6173. C
  6174. C Chromatic case
  6175. C
  6176.       ELSE
  6177. C         -- Saturation
  6178.           D = MA-MI
  6179.           IF (L.LE.0.5) THEN
  6180.               S = D/(MA+MI)
  6181.           ELSE
  6182.               S = D/(2.0-MA-MI)
  6183.           END IF
  6184. C         -- Hue
  6185.           IF (R.EQ.MA) THEN
  6186. C             -- yellow to magenta
  6187.               H = (2.0*D+BB-GG)
  6188.           ELSE IF (G.EQ.MA) THEN
  6189.               H = (4.0*D+RR-BB)
  6190.           ELSE
  6191. C             ! (B.EQ.MA)
  6192.               H = (6.0*D+GG-RR)
  6193.           END IF
  6194.           H = MOD(H*60.0/D,360.0)
  6195.           IF (H.LT.0.0) H = H+360.0
  6196.       END IF
  6197. C
  6198.       END
  6199. C*GRXRGB -- convert HLS color to RGB color
  6200. C+
  6201.       SUBROUTINE GRXRGB (H,L,S,R,G,B)
  6202. C
  6203. C GRPCKG: Convert a color specified in the HLS color model to one in
  6204. C the RGB model.  This is a support routine: no graphics I/O occurs.
  6205. C The inverse transformation is accomplished with routine GRXHLS.
  6206. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  6207. C Committee, Computer Graphics, Vol.13, No.3, Association for
  6208. C Computing Machinery, New York, NY, 1979.
  6209. C
  6210. C Arguments:
  6211. C
  6212. C H,L,S (real, input): hue (0 to 360), lightness (0 to 1.0), and
  6213. C       saturation (0 to 1.0).
  6214. C R,G,B (real, output): red, green, blue color coordinates, each in the
  6215. C       range 0.0 to 1.0.
  6216. C--
  6217. C  2-Jul-1984 - new routine [TJP].
  6218. C 29-Sep-1994 - take H module 360 [TJP].
  6219. C 26-Nov-1996 - force results to be in range (avoid rounding error
  6220. C               problems on some machines) [TJP].
  6221. C-----------------------------------------------------------------------
  6222.       REAL     H,L,S, R,G,B, MA, MI, HM
  6223. C
  6224.       HM = MOD(H, 360.0)
  6225.       IF (HM.LT.0.0) HM = HM+360.0
  6226.       IF (L.LE.0.5) THEN
  6227.           MA = L*(1.0+S)
  6228.       ELSE
  6229.           MA = L + S - L*S
  6230.       END IF
  6231.       MI = 2.0*L-MA
  6232. C
  6233. C R component
  6234. C
  6235.       IF (HM.LT.60.0) THEN
  6236.           R = MI + (MA-MI)*HM/60.0
  6237.       ELSE IF (HM.LT.180.0) THEN
  6238.           R = MA
  6239.       ELSE IF (HM.LT.240.0) THEN
  6240.           R = MI + (MA-MI)*(240.0-HM)/60.0
  6241.       ELSE
  6242.           R = MI
  6243.       END IF
  6244. C
  6245. C G component
  6246. C
  6247.       IF (HM.LT.120.0) THEN
  6248.           G = MI
  6249.       ELSE IF (HM.LT.180.0) THEN
  6250.           G = MI + (MA-MI)*(HM-120.0)/60.0
  6251.       ELSE IF (HM.LT.300.0) THEN
  6252.           G = MA
  6253.       ELSE
  6254.           G = MI + (MA-MI)*(360.0-HM)/60.0
  6255.       END IF
  6256. C
  6257. C B component
  6258. C
  6259.       IF (HM.LT.60.0 .OR. HM.GE.300.0) THEN
  6260.           B = MA
  6261.       ELSE IF (HM.LT.120.0) THEN
  6262.           B = MI + (MA-MI)*(120.0-HM)/60.0
  6263.       ELSE IF (HM.LT.240.0) THEN
  6264.           B = MI
  6265.       ELSE
  6266.           B = MI + (MA-MI)*(HM-240.0)/60.0
  6267.       END IF
  6268. C
  6269.       R = MIN(1.0, MAX(0.0,R))
  6270.       G = MIN(1.0, MAX(0.0,G))
  6271.       B = MIN(1.0, MAX(0.0,B))
  6272. C
  6273.       END
  6274. C*PGADVANCE -- non-standard alias for PGPAGE
  6275. C+
  6276.       SUBROUTINE PGADVANCE
  6277. C
  6278. C See description of PGPAGE.
  6279. C--
  6280.       CALL PGPAGE
  6281.       END
  6282. C*PGARRO -- draw an arrow
  6283. C%void cpgarro(float x1, float y1, float x2, float y2);
  6284. C+
  6285.       SUBROUTINE PGARRO (X1, Y1, X2, Y2)
  6286.       REAL X1, Y1, X2, Y2
  6287. C
  6288. C Draw an arrow from the point with world-coordinates (X1,Y1) to 
  6289. C (X2,Y2). The size of the arrowhead at (X2,Y2) is determined by 
  6290. C the current character size set by routine PGSCH. The default size 
  6291. C is 1/40th of the smaller of the width or height of the view surface.
  6292. C The appearance of the arrowhead (shape and solid or open) is
  6293. C controlled by routine PGSAH.
  6294. C
  6295. C Arguments:
  6296. C  X1, Y1 (input)  : world coordinates of the tail of the arrow.
  6297. C  X2, Y2 (input)  : world coordinates of the head of the arrow.
  6298. C--
  6299. C  7-Feb-92 Keith Horne @ STScI / TJP.
  6300. C 13-Oct-92 - use arrowhead attributes; scale (TJP).
  6301. C-----------------------------------------------------------------------
  6302.       INTEGER AHFS, FS
  6303.       REAL DX, DY, XV1, XV2, YV1, YV2, XL, XR, YB, YT, DINDX, DINDY
  6304.       REAL XINCH, YINCH, RINCH, CA, SA, SO, CO, YP, XP, YM, XM, DHX, DHY
  6305.       REAL PX(4), PY(4)
  6306.       REAL AHANGL, AHVENT, SEMANG, CH, DH, XS1, XS2, YS1, YS2
  6307. C
  6308.       CALL PGBBUF
  6309.       CALL PGQAH(AHFS, AHANGL, AHVENT)
  6310.       CALL PGQFS(FS)
  6311.       CALL PGSFS(AHFS)
  6312.       DX = X2 - X1
  6313.       DY = Y2 - Y1
  6314.       CALL PGQCH(CH)
  6315.       CALL PGQVSZ(1, XS1, XS2, YS1, YS2)
  6316. C     -- length of arrowhead: 1 40th of the smaller of the height or
  6317. C        width of the view surface, scaled by character height.
  6318.       DH = CH*MIN(ABS(XS2-XS1),ABS(YS2-YS1))/40.0
  6319.       CALL PGMOVE(X2, Y2)
  6320. C     -- Is there to be an arrowhead ?
  6321.       IF (DH.GT.0.) THEN
  6322.           IF (DX.NE.0. .OR. DY.NE.0.) THEN
  6323. C             -- Get x and y scales
  6324.               CALL PGQVP(1, XV1, XV2, YV1, YV2)
  6325.               CALL PGQWIN(XL, XR, YB, YT)
  6326.               IF (XR.NE.XL .AND. YT.NE.YB) THEN
  6327.                   DINDX = (XV2 - XV1) / (XR - XL)
  6328.                   DINDY = (YV2 - YV1) / (YT - YB)
  6329.                   DHX = DH / DINDX
  6330.                   DHY = DH / DINDY
  6331. C                 -- Unit vector in direction of the arrow
  6332.                   XINCH = DX * DINDX
  6333.                   YINCH = DY * DINDY
  6334.                   RINCH = SQRT(XINCH*XINCH + YINCH*YINCH)
  6335.                   CA = XINCH / RINCH
  6336.                   SA = YINCH / RINCH
  6337. C                 -- Semiangle in radians
  6338.                   SEMANG = AHANGL/2.0/57.296
  6339.                   SO = SIN(SEMANG)
  6340.                   CO = -COS(SEMANG)
  6341. C                 -- Vector back along one edge of the arrow
  6342.                   XP = DHX * (CA*CO - SA*SO)
  6343.                   YP = DHY * (SA*CO + CA*SO)
  6344. C                 -- Vector back along other edge of the arrow
  6345.                   XM = DHX * (CA*CO + SA*SO)
  6346.                   YM = DHY * (SA*CO - CA*SO)
  6347. C                 -- Draw the arrowhead
  6348.                   PX(1) = X2
  6349.                   PY(1) = Y2
  6350.                   PX(2) = X2 + XP
  6351.                   PY(2) = Y2 + YP
  6352.                   PX(3) = X2 + 0.5*(XP+XM)*(1.0-AHVENT)
  6353.                   PY(3) = Y2 + 0.5*(YP+YM)*(1.0-AHVENT)
  6354.                   PX(4) = X2 + XM
  6355.                   PY(4) = Y2 + YM
  6356.                   CALL PGPOLY(4, PX, PY)
  6357.                   CALL PGMOVE(PX(3), PY(3))
  6358.               END IF
  6359.           END IF
  6360.       END IF
  6361.       CALL PGDRAW(X1, Y1)
  6362.       CALL PGMOVE(X2,Y2)
  6363.       CALL PGSFS(FS)
  6364.       CALL PGEBUF
  6365.       RETURN
  6366.       END
  6367. C*PGASK -- control new page prompting
  6368. C%void cpgask(Logical flag);
  6369. C+
  6370.       SUBROUTINE PGASK (FLAG)
  6371.       LOGICAL FLAG
  6372. C
  6373. C Change the ``prompt state'' of PGPLOT. If the prompt state is
  6374. C ON, PGPAGE will type ``Type RETURN for next page:'' and will wait
  6375. C for the user to type a carriage-return before starting a new page.
  6376. C The initial prompt state (after the device has been opened) is ON
  6377. C for interactive devices. Prompt state is always OFF for
  6378. C non-interactive devices.
  6379. C
  6380. C Arguments:
  6381. C  FLAG   (input)  : if .TRUE., and if the device is an interactive
  6382. C                    device, the prompt state will be set to ON. If
  6383. C                    .FALSE., the prompt state will be set to OFF.
  6384. C--
  6385. C-----------------------------------------------------------------------
  6386.       INCLUDE     'f77.PGPLOT/IN'
  6387.       LOGICAL     PGNOTO
  6388.       CHARACTER*1 TYPE
  6389. C
  6390.       IF (PGNOTO('PGASK')) RETURN
  6391. C
  6392.       IF (FLAG) THEN
  6393.           CALL GRQTYP(TYPE,PGPRMP(PGID))
  6394.       ELSE
  6395.           PGPRMP(PGID) = .FALSE.
  6396.       END IF
  6397.       END
  6398. C*PGAXIS -- draw an axis
  6399. C%void cpgaxis(const char *opt, float x1, float y1, float x2, float y2, \
  6400. C%             float v1, float v2, float step, int nsub, float dmajl, \
  6401. C%             float dmajr, float fmin, float disp, float orient);
  6402. C+
  6403.       SUBROUTINE PGAXIS (OPT, X1, Y1, X2, Y2, V1, V2, STEP, NSUB,
  6404.      :                   DMAJL, DMAJR, FMIN, DISP, ORIENT)
  6405.       CHARACTER*(*) OPT
  6406.       REAL X1, Y1, X2, Y2, V1, V2, STEP, DMAJL, DMAJR, FMIN, DISP
  6407.       REAL ORIENT
  6408.       INTEGER NSUB
  6409. C
  6410. C Draw a labelled graph axis from world-coordinate position (X1,Y1) to
  6411. C (X2,Y2).
  6412. C
  6413. C Normally, this routine draws a standard LINEAR axis with equal
  6414. C subdivisions.   The quantity described by the axis runs from V1 to V2;
  6415. C this may be, but need not be, the same as X or Y. 
  6416. C
  6417. C If the 'L' option is specified, the routine draws a LOGARITHMIC axis.
  6418. C In this case, the quantity described by the axis runs from 10**V1 to
  6419. C 10**V2. A logarithmic axis always has major, labeled, tick marks 
  6420. C spaced by one or more decades. If the major tick marks are spaced
  6421. C by one decade (as specified by the STEP argument), then minor
  6422. C tick marks are placed at 2, 3, .., 9 times each power of 10;
  6423. C otherwise minor tick marks are spaced by one decade. If the axis
  6424. C spans less than two decades, numeric labels are placed at 1, 2, and
  6425. C 5 times each power of ten.
  6426. C
  6427. C If the axis spans less than one decade, or if it spans many decades,
  6428. C it is preferable to use a linear axis labeled with the logarithm of
  6429. C the quantity of interest.
  6430. C
  6431. C Arguments:
  6432. C  OPT    (input)  : a string containing single-letter codes for
  6433. C                    various options. The options currently
  6434. C                    recognized are:
  6435. C                    L : draw a logarithmic axis
  6436. C                    N : write numeric labels
  6437. C                    1 : force decimal labelling, instead of automatic
  6438. C                        choice (see PGNUMB).
  6439. C                    2 : force exponential labelling, instead of
  6440. C                        automatic.
  6441. C  X1, Y1 (input)  : world coordinates of one endpoint of the axis.
  6442. C  X2, Y2 (input)  : world coordinates of the other endpoint of the axis.
  6443. C  V1     (input)  : axis value at first endpoint.
  6444. C  V2     (input)  : axis value at second endpoint.
  6445. C  STEP   (input)  : major tick marks are drawn at axis value 0.0 plus
  6446. C                    or minus integer multiples of STEP. If STEP=0.0,
  6447. C                    a value is chosen automatically.
  6448. C  NSUB   (input)  : minor tick marks are drawn to divide the major
  6449. C                    divisions into NSUB equal subdivisions (ignored if
  6450. C                    STEP=0.0). If NSUB <= 1, no minor tick marks are
  6451. C                    drawn. NSUB is ignored for a logarithmic axis.
  6452. C  DMAJL  (input)  : length of major tick marks drawn to left of axis
  6453. C                    (as seen looking from first endpoint to second), in
  6454. C                    units of the character height.
  6455. C  DMAJR  (input)  : length of major tick marks drawn to right of axis,
  6456. C                    in units of the character height.
  6457. C  FMIN   (input)  : length of minor tick marks, as fraction of major.
  6458. C  DISP   (input)  : displacement of baseline of tick labels to
  6459. C                    right of axis, in units of the character height.
  6460. C  ORIENT (input)  : orientation of label text, in degrees; angle between
  6461. C                    baseline of text and direction of axis (0-360°).
  6462. C--
  6463. C 25-Mar-1997 - new routine [TJP].
  6464. C-----------------------------------------------------------------------
  6465.       REAL V, VMIN, VMAX, DVMAJ, DVMIN
  6466.       REAL PGRND
  6467.       INTEGER I, K, K1, K2, NSUBT, NV, NP, LLAB, CLIP, FORM
  6468.       LOGICAL OPTN, PGNOTO
  6469.       CHARACTER CH, LABEL*32
  6470. C
  6471. C Check arguments.
  6472. C
  6473.       IF (PGNOTO('PGAXIS')) RETURN
  6474.       IF (X1.EQ.X2 .AND. Y1.EQ.Y2) RETURN
  6475.       IF (V1.EQ.V2) RETURN
  6476. C
  6477. C Decode options.
  6478. C
  6479.       FORM = 0
  6480.       OPTN = .FALSE.
  6481.       DO 10 I=1,LEN(OPT)
  6482.          CH = OPT(I:I)
  6483.          CALL GRTOUP(CH, CH)
  6484.          IF (CH.EQ.'N') THEN
  6485. C           -- numeric labels requested
  6486.             OPTN = .TRUE.
  6487.          ELSE IF (CH.EQ.'L') THEN
  6488. C           -- logarithmic axis requested
  6489.             CALL PGAXLG(OPT, X1, Y1, X2, Y2, V1, V2, STEP,
  6490.      :                  DMAJL, DMAJR, FMIN, DISP, ORIENT)
  6491.             RETURN
  6492.          ELSE IF (CH.EQ.'1') THEN
  6493. C           -- decimal labels requested
  6494.             FORM = 1
  6495.          ELSE IF (CH.EQ.'2') THEN
  6496. C           -- exponential labels requested
  6497.             FORM = 2
  6498.          END IF
  6499.  10   CONTINUE
  6500. C
  6501. C Choose major interval if defaulted. Requested interval = STEP,
  6502. C with NSUB subdivisions. We will use interval = DVMAJ with NSUBT
  6503. C subdivisions of size DVMIN. Note that DVMAJ is always positive.
  6504. C
  6505.       IF (STEP.EQ.0.0) THEN
  6506.           DVMAJ = PGRND(0.20*ABS(V1-V2),NSUBT)
  6507.       ELSE
  6508.           DVMAJ = ABS(STEP)
  6509.           NSUBT = MAX(NSUB,1)
  6510.       END IF
  6511.       DVMIN = DVMAJ/NSUBT
  6512. C
  6513. C For labelling, we need to express DVMIN as an integer times a
  6514. C power of 10, NV*(10**NP).
  6515. C
  6516.       NP = INT(LOG10(ABS(DVMIN)))-4
  6517.       NV = NINT(DVMIN/10.0**NP)
  6518.       DVMIN = REAL(NV)*(10.0**NP)
  6519. C
  6520.       CALL PGBBUF
  6521.       CALL PGQCLP(CLIP)
  6522.       CALL PGSCLP(0)
  6523. C
  6524. C Draw the axis.
  6525. C
  6526.       CALL PGMOVE(X1, Y1)
  6527.       CALL PGDRAW(X2, Y2)
  6528. C
  6529. C Draw the tick marks. Minor ticks are drawn at V = K*DVMIN, 
  6530. C major (labelled) ticks where K is a multiple of NSUBT.
  6531. C
  6532.       VMIN = MIN(V1, V2)
  6533.       VMAX = MAX(V1, V2)
  6534.       K1 = INT(VMIN/DVMIN)
  6535.       IF (DVMIN*K1.LT.VMIN) K1 = K1+1
  6536.       K2 = INT(VMAX/DVMIN)
  6537.       IF (DVMIN*K2.GT.VMAX) K2 = K2-1
  6538.       DO 20 K=K1,K2
  6539.          V = (K*DVMIN-V1)/(V2-V1)
  6540.          IF (MOD(K,NSUBT).EQ.0) THEN
  6541. C             -- major tick mark
  6542.             IF (OPTN) THEN
  6543.                CALL PGNUMB(K*NV, NP, FORM, LABEL, LLAB)
  6544.             ELSE
  6545.                LABEL = ' '
  6546.                LLAB = 1
  6547.             END IF
  6548.             CALL PGTICK(X1, Y1, X2, Y2, V, DMAJL, DMAJR,
  6549.      :                  DISP, ORIENT, LABEL(:LLAB))
  6550.          ELSE
  6551. C             -- minor tick mark
  6552.             CALL PGTICK(X1, Y1, X2, Y2, V, DMAJL*FMIN, DMAJR*FMIN,
  6553.      :                  0.0, ORIENT, ' ')
  6554.          END IF
  6555.  20   CONTINUE
  6556. C
  6557.       CALL PGSCLP(CLIP)
  6558.       CALL PGEBUF
  6559.       END
  6560. C PGAXLG -- draw a logarithmic axis [internal routine]
  6561. C
  6562.       SUBROUTINE PGAXLG (OPT, X1, Y1, X2, Y2, V1, V2, STEP,
  6563.      :                   DMAJL, DMAJR, FMIN, DISP, ORIENT)
  6564.       CHARACTER*(*) OPT
  6565.       REAL X1, Y1, X2, Y2, V1, V2, STEP
  6566.       REAL DMAJL, DMAJR, FMIN, DISP, ORIENT
  6567. C
  6568. C Draw a labelled graph axis from world-coordinate position (X1,Y1)
  6569. C  to (X2,Y2). The quantity described by the axis runs from 10**V1 to
  6570. C 10**V2. A logarithmic axis always has major, labeled, tick marks 
  6571. C spaced by one or more decades. If the major tick marks are spaced
  6572. C by one decade (as specified by the STEP argument), then minor
  6573. C tick marks are placed at 2, 3, .., 9 times each power of 10;
  6574. C otherwise minor tick marks are spaced by one decade. If the axis
  6575. C spans less than two decades, numeric labels are placed at 1, 2, and
  6576. C 5 times each power of ten.
  6577. C
  6578. C It is not advisable to use this routine if the axis spans less than
  6579. C one decade, or if it spans many decades. In these cases it is
  6580. C preferable to use a linear axis labeled with the logarithm of the
  6581. C quantity of interest.
  6582. C
  6583. C Arguments:
  6584. C  OPT    (input)  : a string containing single-letter codes for
  6585. C                    various options. The options currently
  6586. C                    recognized are:
  6587. C                    N : write numeric labels
  6588. C                    1 : force decimal labelling, instead of automatic
  6589. C                        choice (see PGNUMB).
  6590. C                    2 : force exponential labelling, instead of
  6591. C                        automatic.
  6592. C  X1, Y1 (input)  : world coordinates of one endpoint of the axis.
  6593. C  X2, Y2 (input)  : world coordinates of the other endpoint of the axis.
  6594. C  V1     (input)  : logarithm of axis value at first endpoint.
  6595. C  V2     (input)  : logarithm of axis value at second endpoint.
  6596. C  STEP   (input)  : the number of decades between major (labeled) tick
  6597. C                    marks.
  6598. C  DMAJL  (input)  : length of major tick marks drawn to left of axis
  6599. C                    (as seen looking from first endpoint to second), in
  6600. C                    units of the character height.
  6601. C  DMAJR  (input)  : length of major tick marks drawn to right of axis,
  6602. C                    in units of the character height.
  6603. C  FMIN   (input)  : length of minor tick marks, as fraction of major.
  6604. C  DISP   (input)  : displacement of baseline of tick labels to
  6605. C                    right of axis, in units of the character height.
  6606. C  ORIENT (input)  : orientation of text label relative to axis (see
  6607. C                    PGTICK).
  6608. C--
  6609. C 25-Mar-1997 - new routine [TJP].
  6610. C-----------------------------------------------------------------------
  6611.       REAL V, VMIN, VMAX, DVMAJ, DVMIN, PGRND
  6612.       INTEGER I, K, K1, K2, LLAB, NSUBT, CLIP, FORM
  6613.       LOGICAL XLAB, OPTN
  6614.       CHARACTER*32 LABEL
  6615.       REAL TAB(9)
  6616. C
  6617. C Table of logarithms 1..9
  6618. C
  6619.       DATA TAB / 0.00000, 0.30103, 0.47712, 0.60206, 0.69897,
  6620.      :           0.77815, 0.84510, 0.90309, 0.95424 /
  6621. C
  6622. C Check arguments.
  6623. C
  6624.       IF (X1.EQ.X2 .AND. Y1.EQ.Y2) RETURN
  6625.       IF (V1.EQ.V2) RETURN
  6626. C
  6627. C Decode options.
  6628. C
  6629.       OPTN = INDEX(OPT,'N').NE.0 .OR. INDEX(OPT,'n').NE.0
  6630.       FORM =0
  6631.       IF (INDEX(OPT,'1').NE.0) FORM = 1
  6632.       IF (INDEX(OPT,'2').NE.0) FORM = 2
  6633. C
  6634. C Choose major interval (DVMAJ in the logarithm, with minimum value
  6635. C 1.0 = one decade). The minor interval is always 1.0.
  6636. C
  6637.       IF (STEP.GT.0.5) THEN
  6638.          DVMAJ = NINT(STEP)
  6639.       ELSE
  6640.          DVMAJ = PGRND(0.20*ABS(V1-V2),NSUBT)
  6641.          IF (DVMAJ.LT.1.0) DVMAJ = 1.0
  6642.       END IF
  6643.       DVMIN = 1.0
  6644.       NSUBT = DVMAJ/DVMIN
  6645. C
  6646.       CALL PGBBUF
  6647.       CALL PGQCLP(CLIP)
  6648.       CALL PGSCLP(0)
  6649. C
  6650. C Draw the axis.
  6651. C
  6652.       CALL PGMOVE(X1, Y1)
  6653.       CALL PGDRAW(X2, Y2)
  6654. C
  6655. C Draw the tick marks. Major ticks are drawn at V = K*DVMAJ.
  6656. C
  6657.       VMIN = MIN(V1, V2)
  6658.       VMAX = MAX(V1, V2)
  6659.       K1 = INT(VMIN/DVMIN)
  6660.       IF (DVMIN*K1.LT.VMIN) K1 = K1+1
  6661.       K2 = INT(VMAX/DVMIN)
  6662.       IF (DVMIN*K2.GT.VMAX) K2 = K2-1
  6663.       XLAB = (K2-K1) .LE. 2
  6664.       DO 20 K=K1,K2
  6665.          V = (K*DVMIN-V1)/(V2-V1)
  6666.          IF (MOD(K,NSUBT).EQ.0) THEN
  6667. C             -- major tick mark
  6668.             IF (OPTN) THEN
  6669.                CALL PGNUMB(1, NINT(K*DVMIN), FORM, LABEL, LLAB)
  6670.             ELSE
  6671.                LABEL = ' '
  6672.                LLAB = 1
  6673.             END IF
  6674.             CALL PGTICK(X1, Y1, X2, Y2, V, DMAJL, DMAJR,
  6675.      :                  DISP, ORIENT, LABEL(:LLAB))
  6676.          ELSE
  6677. C             -- minor tick mark
  6678.             CALL PGTICK(X1, Y1, X2, Y2, V, DMAJL*FMIN, DMAJR*FMIN,
  6679.      :                  0.0, ORIENT, ' ')
  6680.          END IF
  6681.  20   CONTINUE
  6682. C
  6683. C Draw intermediate tick marks if required. 
  6684. C Label them if axis spans less than 2 decades.
  6685. C
  6686.       IF (NSUBT.EQ.1) THEN
  6687.          DO 30 K=K1-1,K2+1
  6688.             DO 25 I=2,9
  6689.                V = (K*DVMIN + TAB(I) -V1)/(V2-V1)
  6690.                IF (V.GE.0.0 .AND. V.LE.1.0) THEN
  6691.                   IF (OPTN.AND.(XLAB .AND.(I.EQ.2 .OR. I.EQ.5))) THEN
  6692. C                    -- labeled minor tick mark
  6693.                      CALL PGNUMB(I, NINT(K*DVMIN), FORM, LABEL, LLAB)
  6694.                   ELSE
  6695. C                    -- unlabeled minor tick mark
  6696.                      LABEL = ' '
  6697.                      LLAB = 1
  6698.                   END IF
  6699.                   CALL PGTICK(X1, Y1, X2, Y2, V, DMAJL*FMIN, DMAJR*FMIN,
  6700.      :                        DISP, ORIENT, LABEL(:LLAB))
  6701.                END IF
  6702.  25         CONTINUE
  6703.  30      CONTINUE
  6704.       END IF
  6705. C
  6706.       CALL PGSCLP(CLIP)
  6707.       CALL PGEBUF
  6708.       END
  6709. C*PGBAND -- read cursor position, with anchor
  6710. C%int cpgband(int mode, int posn, float xref, float yref, float *x,\
  6711. C%            float *y, char *ch_scalar);
  6712. C+
  6713.       INTEGER FUNCTION PGBAND (MODE, POSN, XREF, YREF, X, Y, CH)
  6714.       INTEGER MODE, POSN
  6715.       REAL XREF, YREF, X, Y
  6716.       CHARACTER*(*) CH
  6717. C
  6718. C Read the cursor position and a character typed by the user.
  6719. C The position is returned in world coordinates.  PGBAND positions
  6720. C the cursor at the position specified (if POSN=1), allows the user to
  6721. C move the cursor using the mouse or arrow keys or whatever is available
  6722. C on the device. When he has positioned the cursor, the user types a
  6723. C single character on the keyboard; PGBAND then returns this
  6724. C character and the new cursor position (in world coordinates).
  6725. C
  6726. C Some interactive devices offer a selection of cursor types,
  6727. C implemented as thin lines that move with the cursor, but without
  6728. C erasing underlying graphics. Of these types, some extend between
  6729. C a stationary anchor-point at XREF,YREF, and the position of the
  6730. C cursor, while others simply follow the cursor without changing shape
  6731. C or size. The cursor type is specified with one of the following MODE
  6732. C values. Cursor types that are not supported by a given device, are
  6733. C treated as MODE=0.
  6734. C
  6735. C -- If MODE=0, the anchor point is ignored and the routine behaves
  6736. C like PGCURS.
  6737. C -- If MODE=1, a straight line is drawn joining the anchor point 
  6738. C and the cursor position.
  6739. C -- If MODE=2, a hollow rectangle is extended as the cursor is moved,
  6740. C with one vertex at the anchor point and the opposite vertex at the
  6741. C current cursor position; the edges of the rectangle are horizontal
  6742. C and vertical.
  6743. C -- If MODE=3, two horizontal lines are extended across the width of
  6744. C the display, one drawn through the anchor point and the other
  6745. C through the moving cursor position. This could be used to select
  6746. C a Y-axis range when one end of the range is known.
  6747. C -- If MODE=4, two vertical lines are extended over the height of
  6748. C the display, one drawn through the anchor point and the other
  6749. C through the moving cursor position. This could be used to select an
  6750. C X-axis range when one end of the range is known.
  6751. C -- If MODE=5, a horizontal line is extended through the cursor
  6752. C position over the width of the display. This could be used to select
  6753. C an X-axis value such as the start of an X-axis range. The anchor point
  6754. C is ignored.
  6755. C -- If MODE=6, a vertical line is extended through the cursor
  6756. C position over the height of the display. This could be used to select
  6757. C a Y-axis value such as the start of a Y-axis range. The anchor point
  6758. C is ignored.
  6759. C -- If MODE=7, a cross-hair, centered on the cursor, is extended over
  6760. C the width and height of the display. The anchor point is ignored.
  6761. C
  6762. C Returns:
  6763. C  PGBAND          : 1 if the call was successful; 0 if the device
  6764. C                    has no cursor or some other error occurs.
  6765. C Arguments:
  6766. C  MODE   (input)  : display mode (0, 1, ..7: see above).
  6767. C  POSN   (input)  : if POSN=1, PGBAND attempts to place the cursor
  6768. C                    at point (X,Y); if POSN=0, it leaves the cursor
  6769. C                    at its current position. (On some devices this
  6770. C                    request may be ignored.)
  6771. C  XREF   (input)  : the world x-coordinate of the anchor point.
  6772. C  YREF   (input)  : the world y-coordinate of the anchor point.
  6773. C  X      (in/out) : the world x-coordinate of the cursor.
  6774. C  Y      (in/out) : the world y-coordinate of the cursor.
  6775. C  CH     (output) : the character typed by the user; if the device has
  6776. C                    no cursor or if some other error occurs, the value
  6777. C                    CHAR(0) [ASCII NUL character] is returned.
  6778. C
  6779. C Note: The cursor coordinates (X,Y) may be changed by PGBAND even if
  6780. C the device has no cursor or if the user does not move the cursor.
  6781. C Under these circumstances, the position returned in (X,Y) is that of
  6782. C the pixel nearest to the requested position.
  6783. C--
  6784. C 7-Sep-1994 - new routine [TJP].
  6785. C-----------------------------------------------------------------------
  6786.       INCLUDE      'f77.PGPLOT/IN'
  6787.       INTEGER      GRCURS, I, J, IREF, JREF
  6788.       LOGICAL      PGNOTO
  6789. C
  6790.       IF (PGNOTO('PGBAND')) THEN
  6791.           CH = CHAR(0)
  6792.           PGBAND = 0
  6793.           RETURN
  6794.       END IF
  6795.       IF (MODE.LT.0 .OR. MODE.GT.7) CALL GRWARN(
  6796.      :     'Invalid MODE argument in PGBAND')
  6797.       IF (POSN.LT.0 .OR. POSN.GT.1) CALL GRWARN(
  6798.      :     'Invalid POSN argument in PGBAND')
  6799. C
  6800.       I = NINT(PGXORG(PGID) + X*PGXSCL(PGID))
  6801.       J = NINT(PGYORG(PGID) + Y*PGYSCL(PGID))
  6802.       IREF = NINT(PGXORG(PGID) + XREF*PGXSCL(PGID))
  6803.       JREF = NINT(PGYORG(PGID) + YREF*PGYSCL(PGID))
  6804.       PGBAND = GRCURS(PGID,I,J,IREF,JREF,MODE,POSN,CH)
  6805.       X = (I - PGXORG(PGID))/PGXSCL(PGID)
  6806.       Y = (J - PGYORG(PGID))/PGYSCL(PGID)
  6807.       CALL GRTERM
  6808.       END
  6809. C*PGBBUF -- begin batch of output (buffer)
  6810. C%void cpgbbuf(void);
  6811. C+
  6812.       SUBROUTINE PGBBUF
  6813. C
  6814. C Begin saving graphical output commands in an internal buffer; the
  6815. C commands are held until a matching PGEBUF call (or until the buffer
  6816. C is emptied by PGUPDT). This can greatly improve the efficiency of
  6817. C PGPLOT.  PGBBUF increments an internal counter, while PGEBUF
  6818. C decrements this counter and flushes the buffer to the output
  6819. C device when the counter drops to zero.  PGBBUF and PGEBUF calls
  6820. C should always be paired.
  6821. C
  6822. C Arguments: none
  6823. C--
  6824. C 21-Nov-1985 - new routine [TJP].
  6825. C-----------------------------------------------------------------------
  6826.       INCLUDE 'f77.PGPLOT/IN'
  6827.       LOGICAL PGNOTO
  6828. C
  6829.       IF (.NOT.PGNOTO('PGBBUF')) THEN
  6830.           PGBLEV(PGID) = PGBLEV(PGID) + 1
  6831.       END IF
  6832.       END
  6833. C*PGBEG -- open a graphics device
  6834. C%int cpgbeg(int unit, const char *file, int nxsub, int nysub);
  6835. C+
  6836.       INTEGER FUNCTION PGBEG (UNIT, FILE, NXSUB, NYSUB)
  6837.       INTEGER       UNIT
  6838.       CHARACTER*(*) FILE
  6839.       INTEGER       NXSUB, NYSUB
  6840. C
  6841. C Note: new programs should use PGOPEN rather than PGBEG. PGOPEN
  6842. C is retained for compatibility with existing programs. Unlike PGOPEN,
  6843. C PGBEG closes any graphics devices that are already open, so it 
  6844. C cannot be used to open devices to be used in parallel.
  6845. C
  6846. C PGBEG opens a graphical device or file and prepares it for
  6847. C subsequent plotting. A device must be opened with PGBEG or PGOPEN
  6848. C before any other calls to PGPLOT subroutines for the device.
  6849. C
  6850. C If any device  is already open for PGPLOT output, it is closed before
  6851. C the new device is opened.
  6852. C
  6853. C Returns:
  6854. C  PGBEG         : a status return value. A value of 1 indicates
  6855. C                    successful completion, any other value indicates
  6856. C                    an error. In the event of error a message is
  6857. C                    written on the standard error unit.  
  6858. C                    To test the return value, call
  6859. C                    PGBEG as a function, eg IER=PGBEG(...); note
  6860. C                    that PGBEG must be declared INTEGER in the
  6861. C                    calling program. Some Fortran compilers allow
  6862. C                    you to use CALL PGBEG(...) and discard the
  6863. C                    return value, but this is not standard Fortran.
  6864. C Arguments:
  6865. C  UNIT  (input)   : this argument is ignored by PGBEG (use zero).
  6866. C  FILE  (input)   : the "device specification" for the plot device.
  6867. C                    (For explanation, see description of PGOPEN.)
  6868. C  NXSUB  (input)  : the number of subdivisions of the view surface in
  6869. C                    X (>0 or <0).
  6870. C  NYSUB  (input)  : the number of subdivisions of the view surface in
  6871. C                    Y (>0).
  6872. C                    PGPLOT puts NXSUB x NYSUB graphs on each plot
  6873. C                    page or screen; when the view surface is sub-
  6874. C                    divided in this way, PGPAGE moves to the next
  6875. C                    panel, not the  next physical page. If
  6876. C                    NXSUB > 0, PGPLOT uses the panels in row
  6877. C                    order; if <0, PGPLOT uses them in column order.
  6878. C--
  6879. C 21-Dec-1995 [TJP] - changed for multiple devices; call PGOPEN.
  6880. C 27-Feb-1997 [TJP] - updated description.
  6881. C-----------------------------------------------------------------------
  6882.       INTEGER       IER
  6883.       INTEGER       PGOPEN
  6884. C
  6885. C Initialize PGPLOT if necessary.
  6886. C
  6887.       CALL PGINIT
  6888. C
  6889. C Close the plot-file if it is already open.
  6890. C
  6891.       CALL PGEND
  6892. C
  6893. C Call PGOPEN to open the device.
  6894. C
  6895.       IER = PGOPEN(FILE)
  6896.       IF (IER.GT.0) THEN
  6897.          CALL PGSUBP(NXSUB, NYSUB)
  6898.          PGBEG = 1
  6899.       ELSE
  6900.          PGBEG = IER
  6901.       END IF
  6902. C
  6903.       RETURN
  6904.       END
  6905. C*PGBEGIN -- non-standard alias for PGBEG
  6906. C+
  6907.       INTEGER FUNCTION PGBEGIN (UNIT, FILE, NXSUB, NYSUB)
  6908.       INTEGER       UNIT
  6909.       CHARACTER*(*) FILE
  6910.       INTEGER       NXSUB, NYSUB
  6911. C
  6912. C See description of PGBEG.   
  6913. C--
  6914.       INTEGER       PGBEG
  6915.       PGBEGIN = PGBEG (UNIT, FILE, NXSUB, NYSUB)
  6916.       END
  6917. C*PGBIN -- histogram of binned data
  6918. C%void cpgbin(int nbin, const float *x, const float *data, \
  6919. C% Logical center);
  6920. C+
  6921.       SUBROUTINE PGBIN (NBIN, X, DATA, CENTER)
  6922.       INTEGER NBIN
  6923.       REAL X(*), DATA(*)
  6924.       LOGICAL CENTER
  6925. C
  6926. C Plot a histogram of NBIN values with X(1..NBIN) values along
  6927. C the ordinate, and DATA(1...NBIN) along the abscissa. Bin width is
  6928. C spacing between X values.
  6929. C
  6930. C Arguments:
  6931. C  NBIN   (input)  : number of values.
  6932. C  X      (input)  : abscissae of bins.
  6933. C  DATA   (input)  : data values of bins.
  6934. C  CENTER (input)  : if .TRUE., the X values denote the center of the
  6935. C                    bin; if .FALSE., the X values denote the lower
  6936. C                    edge (in X) of the bin.
  6937. C--
  6938. C 19-Aug-92: change argument check (TJP).
  6939. C-----------------------------------------------------------------------
  6940.       LOGICAL  PGNOTO
  6941.       INTEGER  IBIN
  6942.       REAL     TX(4), TY(4)
  6943. C
  6944. C Check arguments.
  6945. C
  6946.       IF (NBIN.LT.2) RETURN
  6947.       IF (PGNOTO('PGBIN')) RETURN
  6948.       CALL PGBBUF
  6949. C
  6950. C Draw Histogram. Centered an uncentered bins are treated separately.
  6951. C
  6952.       IF (CENTER) THEN
  6953. C         !set up initial point.
  6954.           TX(2) = (3.*X(1) - X(2))/2.
  6955.           TY(2) = DATA(1)
  6956.           TX(3) = (X(1) + X(2))/2.
  6957.           TY(3) = TY(2)
  6958.           CALL GRVCT0(2, .FALSE., 2, TX(2), TY(2))
  6959. C         !draw initial horizontal line
  6960. C         !now loop over bins
  6961.           DO 10 IBIN=2,NBIN-1
  6962.               TX(1) = TX(3)
  6963.               TX(2) = TX(1)
  6964.               TX(3) = ( X(IBIN) + X(IBIN+1) ) / 2.
  6965.               TY(1) = TY(3)
  6966.               TY(2) = DATA(IBIN)
  6967.               TY(3) = TY(2)
  6968.               CALL GRVCT0(2, .FALSE., 3, TX, TY)
  6969.    10     CONTINUE
  6970. C         !now draw last segment.
  6971.           TX(1) = TX(3)
  6972.           TX(2) = TX(1)
  6973.           TX(3) = (3.*X(NBIN) - X(NBIN-1) )/2.
  6974.           TY(1) = TY(3)
  6975.           TY(2) = DATA(NBIN)
  6976.           TY(3) = TY(2)
  6977.           CALL GRVCT0(2, .FALSE., 3, TX, TY)
  6978. C
  6979. C               Uncentered bins
  6980. C
  6981.       ELSE
  6982. C         !set up first line.
  6983.           TX(2) = X(1)
  6984.           TY(2) = DATA(1)
  6985.           TX(3) = X(2)
  6986.           TY(3) = TY(2)
  6987.           CALL GRVCT0(2, .FALSE., 2, TX(2), TY(2))
  6988.           DO 20 IBIN=2,NBIN
  6989.               TX(1) = TX(3)
  6990.               TX(2) = TX(1)
  6991.               IF (IBIN.EQ.NBIN) THEN
  6992.                   TX(3) = 2.*X(NBIN) - X(NBIN-1)
  6993.               ELSE
  6994.                   TX(3) = X(IBIN+1)
  6995.               END IF
  6996.               TY(1) = TY(3)
  6997. C             !get height for last segment.
  6998.               TY(2) = DATA(IBIN)
  6999.               TY(3) = TY(2)
  7000.               CALL GRVCT0(2, .FALSE., 3, TX, TY)
  7001.    20     CONTINUE
  7002.       END IF
  7003. C
  7004.       CALL PGEBUF
  7005.       END
  7006. C*PGBOX -- draw labeled frame around viewport
  7007. C%void cpgbox(const char *xopt, float xtick, int nxsub, \
  7008. C% const char *yopt, float ytick, int nysub);
  7009. C+
  7010.       SUBROUTINE PGBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB)
  7011.       CHARACTER*(*) XOPT, YOPT
  7012.       REAL XTICK, YTICK
  7013.       INTEGER NXSUB, NYSUB
  7014. C
  7015. C Annotate the viewport with frame, axes, numeric labels, etc.
  7016. C PGBOX is called by on the user's behalf by PGENV, but may also be
  7017. C called explicitly.
  7018. C
  7019. C Arguments:
  7020. C  XOPT   (input)  : string of options for X (horizontal) axis of
  7021. C                    plot. Options are single letters, and may be in
  7022. C                    any order (see below).
  7023. C  XTICK  (input)  : world coordinate interval between major tick marks
  7024. C                    on X axis. If XTICK=0.0, the interval is chosen by
  7025. C                    PGBOX, so that there will be at least 3 major tick
  7026. C                    marks along the axis.
  7027. C  NXSUB  (input)  : the number of subintervals to divide the major
  7028. C                    coordinate interval into. If XTICK=0.0 or NXSUB=0,
  7029. C                    the number is chosen by PGBOX.
  7030. C  YOPT   (input)  : string of options for Y (vertical) axis of plot.
  7031. C                    Coding is the same as for XOPT.
  7032. C  YTICK  (input)  : like XTICK for the Y axis.
  7033. C  NYSUB  (input)  : like NXSUB for the Y axis.
  7034. C
  7035. C Options (for parameters XOPT and YOPT):
  7036. C  A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical
  7037. C      line X=0).
  7038. C  B : draw bottom (X) or left (Y) edge of frame.
  7039. C  C : draw top (X) or right (Y) edge of frame.
  7040. C  G : draw Grid of vertical (X) or horizontal (Y) lines.
  7041. C  I : Invert the tick marks; ie draw them outside the viewport
  7042. C      instead of inside.
  7043. C  L : label axis Logarithmically (see below).
  7044. C  N : write Numeric labels in the conventional location below the
  7045. C      viewport (X) or to the left of the viewport (Y).
  7046. C  P : extend ("Project") major tick marks outside the box (ignored if
  7047. C      option I is specified).
  7048. C  M : write numeric labels in the unconventional location above the
  7049. C      viewport (X) or to the right of the viewport (Y).
  7050. C  T : draw major Tick marks at the major coordinate interval.
  7051. C  S : draw minor tick marks (Subticks).
  7052. C  V : orient numeric labels Vertically. This is only applicable to Y.
  7053. C      The default is to write Y-labels parallel to the axis.
  7054. C  1 : force decimal labelling, instead of automatic choice (see PGNUMB).
  7055. C  2 : force exponential labelling, instead of automatic.
  7056. C
  7057. C To get a complete frame, specify BC in both XOPT and YOPT.
  7058. C Tick marks, if requested, are drawn on the axes or frame
  7059. C or both, depending which are requested. If none of ABC is specified,
  7060. C tick marks will not be drawn. When PGENV calls PGBOX, it sets both
  7061. C XOPT and YOPT according to the value of its parameter AXIS:
  7062. C -1: 'BC', 0: 'BCNST', 1: 'ABCNST', 2: 'ABCGNST'.
  7063. C
  7064. C For a logarithmic axis, the major tick interval is always 1.0. The
  7065. C numeric label is 10**(x) where x is the world coordinate at the
  7066. C tick mark. If subticks are requested, 8 subticks are drawn between
  7067. C each major tick at equal logarithmic intervals.
  7068. C
  7069. C To label an axis with time (days, hours, minutes, seconds) or
  7070. C angle (degrees, arcmin, arcsec), use routine PGTBOX.
  7071. C--
  7072. C 19-Oct-1983
  7073. C 23-Sep-1984 - fix bug in labelling reversed logarithmic axes.
  7074. C  6-May-1985 - improve behavior for pen plotters [TJP].
  7075. C 23-Nov-1985 - add 'P' option [TJP].
  7076. C 14-Jan-1986 - use new routine PGBOX1 to fix problem of missing
  7077. C               labels at end of axis [TJP].
  7078. C  8-Apr-1987 - improve automatic choice of tick interval; improve
  7079. C               erroneous rounding of tick interval to 1 digit [TJP].
  7080. C 23-Apr-1987 - fix bug: limit max number of ticks to ~10 [TJP].
  7081. C  7-Nov-1987 - yet another change to algorithm for choosing tick
  7082. C               interval; maximum tick interval is now 0.2*range of
  7083. C               axis, which may round up to 0.5 [TJP].
  7084. C 15-Dec-1988 - correct declaration of MAJOR [TJP].
  7085. C  6-Sep-1989 - use Fortran generic intrinsic functions [TJP].
  7086. C 18-Oct-1990 - correctly initialize UTAB(1) [AFT].
  7087. C 19-Oct-1990 - do all plotting in world coordinates [TJP].
  7088. C  6-Nov-1991 - label logarithmic subticks when necessary [TJP].
  7089. C  4-Jul-1994 - add '1' and '2' options [TJP].
  7090. C 20-Apr-1995 - adjust position of labels slightly, and move out
  7091. C               when ticks are inverted [TJP].
  7092. C 26-Feb-1997 - use new routine pgclp [TJP].
  7093. C-----------------------------------------------------------------------
  7094.       INCLUDE  'f77.PGPLOT/IN'
  7095.       CHARACTER*20  CLBL
  7096.       CHARACTER*64  OPT
  7097.       LOGICAL  XOPTA, XOPTB, XOPTC, XOPTG, XOPTN, XOPTM, XOPTT, XOPTS
  7098.       LOGICAL  YOPTA, YOPTB, YOPTC, YOPTG, YOPTN, YOPTM, YOPTT, YOPTS
  7099.       LOGICAL  XOPTI, YOPTI, YOPTV, XOPTL, YOPTL, XOPTP, YOPTP, RANGE
  7100.       LOGICAL  IRANGE, MAJOR, XOPTLS, YOPTLS, PGNOTO
  7101.       REAL     TAB(9), UTAB(9)
  7102.       INTEGER  I, I1, I2, J, NC, NP, NV, KI, CLIP
  7103.       INTEGER  NSUBX, NSUBY, JMAX, XNFORM, YNFORM
  7104.       REAL     TIKL, TIKL1, TIKL2, XC, YC
  7105.       REAL     XINT, XINT2, XVAL, YINT, YINT2, YVAL
  7106.       REAL     PGRND
  7107.       REAL     A, B, C
  7108.       REAL     XNDSP, XMDSP, YNDSP, YMDSP, YNVDSP, YMVDSP
  7109.       REAL     XBLC, XTRC, YBLC, YTRC
  7110.       INTRINSIC ABS, INDEX, INT, LOG10, MAX, MIN, MOD, NINT, SIGN, REAL
  7111. C
  7112. C Table of logarithms 1..9
  7113. C
  7114.       DATA TAB / 0.00000, 0.30103, 0.47712, 0.60206, 0.69897,
  7115.      1           0.77815, 0.84510, 0.90309, 0.95424 /
  7116. C
  7117.       RANGE(A,B,C) = (A.LT.B.AND.B.LT.C) .OR. (C.LT.B.AND.B.LT.A)
  7118.       IRANGE(A,B,C) = (A.LE.B.AND.B.LE.C) .OR. (C.LE.B.AND.B.LE.A)
  7119. C
  7120.       IF (PGNOTO('PGBOX')) RETURN
  7121.       CALL PGBBUF
  7122.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  7123. C
  7124. C Decode options.
  7125. C
  7126.       CALL GRTOUP(OPT,XOPT)
  7127.       XOPTA = INDEX(OPT,'A').NE.0 .AND. RANGE(YBLC,0.0,YTRC)
  7128.       XOPTB = INDEX(OPT,'B').NE.0
  7129.       XOPTC = INDEX(OPT,'C').NE.0
  7130.       XOPTG = INDEX(OPT,'G').NE.0
  7131.       XOPTI = INDEX(OPT,'I').NE.0
  7132.       XOPTL = INDEX(OPT,'L').NE.0
  7133.       XOPTM = INDEX(OPT,'M').NE.0
  7134.       XOPTN = INDEX(OPT,'N').NE.0
  7135.       XOPTS = INDEX(OPT,'S').NE.0
  7136.       XOPTT = INDEX(OPT,'T').NE.0
  7137.       XOPTP = INDEX(OPT,'P').NE.0 .AND. (.NOT.XOPTI)
  7138.       XNFORM = 0
  7139.       IF (INDEX(OPT,'1').NE.0) XNFORM = 1
  7140.       IF (INDEX(OPT,'2').NE.0) XNFORM = 2
  7141.       CALL GRTOUP(OPT,YOPT)
  7142.       YOPTA = INDEX(OPT,'A').NE.0 .AND. RANGE(XBLC,0.0,XTRC)
  7143.       YOPTB = INDEX(OPT,'B').NE.0
  7144.       YOPTC = INDEX(OPT,'C').NE.0
  7145.       YOPTG = INDEX(OPT,'G').NE.0
  7146.       YOPTI = INDEX(OPT,'I').NE.0
  7147.       YOPTL = INDEX(OPT,'L').NE.0
  7148.       YOPTN = INDEX(OPT,'N').NE.0
  7149.       YOPTM = INDEX(OPT,'M').NE.0
  7150.       YOPTS = INDEX(OPT,'S').NE.0
  7151.       YOPTT = INDEX(OPT,'T').NE.0
  7152.       YOPTV = INDEX(OPT,'V').NE.0
  7153.       YOPTP = INDEX(OPT,'P').NE.0 .AND. (.NOT.YOPTI)
  7154.       YNFORM = 0
  7155.       IF (INDEX(OPT,'1').NE.0) YNFORM = 1
  7156.       IF (INDEX(OPT,'2').NE.0) YNFORM = 2
  7157. C
  7158. C Displacement of labels from edge of box
  7159. C (for X bottom/top, Y left/right, and Y left/right with V option).
  7160. C
  7161.       XNDSP = 1.2
  7162.       XMDSP = 0.7
  7163.       YNDSP = 0.7
  7164.       YMDSP = 1.2
  7165.       YNVDSP = 0.7
  7166.       YMVDSP = 0.7
  7167.       IF (XOPTI) THEN
  7168.          XNDSP = XNDSP + 0.3
  7169.          XMDSP = XMDSP + 0.3
  7170.       END IF
  7171.       IF (YOPTI) THEN
  7172.          YNDSP = YNDSP + 0.3
  7173.          YMDSP = YMDSP + 0.3
  7174.          YNVDSP = YNVDSP + 0.3
  7175.          YMVDSP = YMVDSP + 0.3
  7176.       END IF
  7177. C
  7178. C Disable clipping.
  7179. C
  7180.       CALL PGQCLP(CLIP)
  7181.       CALL PGSCLP(0)
  7182. C
  7183. C Draw box.
  7184. C
  7185.       IF (XOPTB) THEN
  7186.           CALL GRMOVA(XBLC, YBLC)
  7187.           CALL GRLINA(XTRC, YBLC)
  7188.       END IF
  7189.       IF (YOPTC) THEN
  7190.           CALL GRMOVA(XTRC, YBLC)
  7191.           CALL GRLINA(XTRC, YTRC)
  7192.       END IF
  7193.       IF (XOPTC) THEN
  7194.           CALL GRMOVA(XTRC, YTRC)
  7195.           CALL GRLINA(XBLC, YTRC)
  7196.       END IF
  7197.       IF (YOPTB) THEN
  7198.           CALL GRMOVA(XBLC, YTRC)
  7199.           CALL GRLINA(XBLC, YBLC)
  7200.       END IF
  7201. C
  7202. C Draw axes if required.
  7203. C
  7204.       IF (XOPTA.AND..NOT.XOPTG) THEN
  7205.           CALL GRMOVA(XBLC, 0.0)
  7206.           CALL GRLINA(XTRC, 0.0)
  7207.       END IF
  7208.       IF (YOPTA.AND..NOT.YOPTG) THEN
  7209.           CALL GRMOVA(0.0, YBLC)
  7210.           CALL GRLINA(0.0, YTRC)
  7211.       END IF
  7212. C
  7213. C Length of X tick marks.
  7214. C
  7215.       TIKL1 = PGXSP(PGID)*0.6*(YTRC-YBLC)/PGYLEN(PGID)
  7216.       IF (XOPTI) TIKL1 = -TIKL1
  7217.       TIKL2 = TIKL1*0.5
  7218. C
  7219. C Choose X tick intervals. Major interval = XINT,
  7220. C minor interval = XINT2 = XINT/NSUBX.
  7221. C
  7222.       UTAB(1) = 0.0
  7223.       IF (XOPTL) THEN
  7224.           XINT = SIGN(1.0,XTRC-XBLC)
  7225.           NSUBX = 1
  7226.           DO 10 J=2,9
  7227.               UTAB(J) = TAB(J)
  7228.               IF (XINT.LT.0.0) UTAB(J) = 1.0-TAB(J)
  7229.    10     CONTINUE
  7230.       ELSE IF (XTICK.EQ.0.0) THEN
  7231.           XINT = MAX(0.05, MIN(7.0*PGXSP(PGID)/PGXLEN(PGID), 0.20))
  7232.      1           *(XTRC-XBLC)
  7233.           XINT = PGRND(XINT,NSUBX)
  7234.       ELSE
  7235.           XINT = SIGN(XTICK,XTRC-XBLC)
  7236.           NSUBX = MAX(NXSUB,1)
  7237.       END IF
  7238.       IF (.NOT.XOPTS) NSUBX = 1
  7239.       NP = INT(LOG10(ABS(XINT)))-4
  7240.       NV = NINT(XINT/10.**NP)
  7241.       XINT2 = XINT/NSUBX
  7242.       XOPTLS = XOPTL .AND. XOPTS .AND. (ABS(XTRC-XBLC).LT.2.0)
  7243. C
  7244. C Draw X grid.
  7245. C
  7246.       IF (XOPTG) THEN
  7247.           CALL PGBOX1(XBLC, XTRC, XINT, I1, I2)
  7248.           DO 20 I=I1,I2
  7249.               CALL GRMOVA(REAL(I)*XINT, YBLC)
  7250.               CALL GRLINA(REAL(I)*XINT, YTRC)
  7251.    20     CONTINUE
  7252.       END IF
  7253. C
  7254. C Draw X ticks.
  7255. C
  7256.       IF (XOPTT.OR.XOPTS) THEN
  7257.           CALL PGBOX1(XBLC, XTRC, XINT2, I1, I2)
  7258.           JMAX = 1
  7259.           IF (XOPTL.AND.XOPTS) JMAX=9
  7260. C
  7261. C         Bottom ticks.
  7262. C
  7263.           IF (XOPTB) THEN
  7264.             DO 40 I=I1-1,I2
  7265.             DO 30 J=1,JMAX
  7266.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  7267.                 TIKL = TIKL2
  7268.                 IF (MAJOR) TIKL = TIKL1
  7269.                 XVAL = (I+UTAB(J))*XINT2
  7270.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  7271.                     IF (XOPTP.AND.MAJOR) THEN
  7272.                         CALL GRMOVA(XVAL, YBLC-TIKL2)
  7273.                     ELSE
  7274.                         CALL GRMOVA(XVAL, YBLC)
  7275.                     END IF
  7276.                     CALL GRLINA(XVAL, YBLC+TIKL)
  7277.                 END IF
  7278.    30        CONTINUE
  7279.    40       CONTINUE
  7280.           END IF
  7281. C
  7282. C         Axis ticks.
  7283. C
  7284.           IF (XOPTA) THEN
  7285.             DO 60 I=I1-1,I2
  7286.             DO 50 J=1,JMAX
  7287.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  7288.                 TIKL = TIKL2
  7289.                 IF (MAJOR) TIKL = TIKL1
  7290.                 XVAL = (I+UTAB(J))*XINT2
  7291.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  7292.                     CALL GRMOVA(XVAL, -TIKL)
  7293.                     CALL GRLINA(XVAL, TIKL)
  7294.                 END IF
  7295.    50       CONTINUE
  7296.    60       CONTINUE
  7297.           END IF
  7298. C
  7299. C         Top ticks.
  7300. C
  7301.           IF (XOPTC) THEN
  7302.             DO 80 I=I1-1,I2
  7303.             DO 70 J=1,JMAX
  7304.                 MAJOR = (MOD(I,NSUBX).EQ.0).AND.XOPTT.AND.J.EQ.1
  7305.                 TIKL = TIKL2
  7306.                 IF (MAJOR) TIKL = TIKL1
  7307.                 XVAL = (I+UTAB(J))*XINT2
  7308.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  7309.                     CALL GRMOVA(XVAL, YTRC-TIKL)
  7310.                     CALL GRLINA(XVAL, YTRC)
  7311.                 END IF
  7312.    70       CONTINUE
  7313.    80       CONTINUE
  7314.           END IF
  7315.       END IF
  7316. C
  7317. C Write X labels.
  7318. C
  7319.       IF (XOPTN .OR. XOPTM) THEN
  7320.           CALL PGBOX1(XBLC, XTRC, XINT, I1, I2)
  7321.           DO 90 I=I1,I2
  7322.               XC = (I*XINT-XBLC)/(XTRC-XBLC)
  7323.               IF (XOPTL) THEN
  7324.                   CALL PGNUMB(1,NINT(I*XINT),XNFORM,CLBL,NC)
  7325.               ELSE
  7326.                   CALL PGNUMB(I*NV,NP,XNFORM,CLBL,NC)
  7327.               END IF
  7328.               IF (XOPTN) CALL PGMTXT('B', XNDSP, XC, 0.5, CLBL(1:NC))
  7329.               IF (XOPTM) CALL PGMTXT('T', XMDSP, XC, 0.5, CLBL(1:NC))
  7330.    90     CONTINUE
  7331.       END IF
  7332. C
  7333. C Extra X labels for log axes.
  7334. C
  7335.       IF (XOPTLS) THEN
  7336.           CALL PGBOX1(XBLC, XTRC, XINT2, I1, I2)
  7337.           DO 401 I=I1-1,I2
  7338.              DO 301 J=2,5,3
  7339.                 XVAL = (I+UTAB(J))*XINT2
  7340.                 XC = (XVAL-XBLC)/(XTRC-XBLC)
  7341.                 KI = I
  7342.                 IF (XTRC.LT.XBLC) KI = KI+1
  7343.                 IF (IRANGE(XBLC,XVAL,XTRC)) THEN
  7344.                     CALL PGNUMB(J,NINT(KI*XINT2),XNFORM,CLBL,NC)
  7345.                     IF (XOPTN) 
  7346.      1                CALL PGMTXT('B', XNDSP, XC, 0.5, CLBL(1:NC))
  7347.                     IF (XOPTM) 
  7348.      1                CALL PGMTXT('T', XMDSP, XC, 0.5, CLBL(1:NC))
  7349.                 END IF
  7350.   301       CONTINUE
  7351.   401     CONTINUE
  7352.       END IF
  7353. C
  7354. C Length of Y tick marks.
  7355. C
  7356.       TIKL1 = PGXSP(PGID)*0.6*(XTRC-XBLC)/PGXLEN(PGID)
  7357.       IF (YOPTI) TIKL1 = -TIKL1
  7358.       TIKL2 = TIKL1*0.5
  7359. C
  7360. C Choose Y tick intervals. Major interval = YINT,
  7361. C minor interval = YINT2 = YINT/NSUBY.
  7362. C
  7363.       UTAB(1) = 0.0
  7364.       IF (YOPTL) THEN
  7365.           YINT = SIGN(1.0,YTRC-YBLC)
  7366.           NSUBY = 1
  7367.           DO 100 J=2,9
  7368.               UTAB(J) = TAB(J)
  7369.               IF (YINT.LT.0.0) UTAB(J) = 1.0-TAB(J)
  7370.   100     CONTINUE
  7371.       ELSE IF (YTICK.EQ.0.0) THEN
  7372.           YINT = MAX(0.05, MIN(7.0*PGXSP(PGID)/PGYLEN(PGID), 0.20))
  7373.      1           *(YTRC-YBLC)
  7374.           YINT = PGRND(YINT,NSUBY)
  7375.       ELSE
  7376.           YINT  = SIGN(YTICK,YTRC-YBLC)
  7377.           NSUBY = MAX(NYSUB,1)
  7378.       END IF
  7379.       IF (.NOT.YOPTS) NSUBY = 1
  7380.       NP = INT(LOG10(ABS(YINT)))-4
  7381.       NV = NINT(YINT/10.**NP)
  7382.       YINT2 = YINT/NSUBY
  7383.       YOPTLS = YOPTL .AND. YOPTS .AND. (ABS(YTRC-YBLC).LT.2.0)
  7384. C
  7385. C Draw Y grid.
  7386. C
  7387.       IF (YOPTG) THEN
  7388.           CALL PGBOX1(YBLC, YTRC, YINT, I1, I2)
  7389.           DO 110 I=I1,I2
  7390.               CALL GRMOVA(XBLC, REAL(I)*YINT)
  7391.               CALL GRLINA(XTRC, REAL(I)*YINT)
  7392.   110     CONTINUE
  7393.       END IF
  7394. C
  7395. C Draw Y ticks.
  7396. C
  7397.       IF (YOPTT.OR.YOPTS) THEN
  7398.           CALL PGBOX1(YBLC, YTRC, YINT2, I1, I2)
  7399.           JMAX = 1
  7400.           IF (YOPTL.AND.YOPTS) JMAX = 9
  7401. C
  7402. C               Left ticks.
  7403. C
  7404.             IF (YOPTB) THEN
  7405.             DO 130 I=I1-1,I2
  7406.             DO 120 J=1,JMAX
  7407.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  7408.                 TIKL = TIKL2
  7409.                 IF (MAJOR) TIKL = TIKL1
  7410.                 YVAL = (I+UTAB(J))*YINT2
  7411.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  7412.                     IF (YOPTP.AND.MAJOR) THEN
  7413.                         CALL GRMOVA(XBLC-TIKL2, YVAL)
  7414.                     ELSE
  7415.                         CALL GRMOVA(XBLC, YVAL)
  7416.                     END IF
  7417.                     CALL GRLINA(XBLC+TIKL, YVAL)
  7418.                 END IF
  7419.   120       CONTINUE
  7420.   130       CONTINUE
  7421.             END IF
  7422. C
  7423. C               Axis ticks.
  7424. C
  7425.             IF (YOPTA) THEN
  7426.             DO 150 I=I1-1,I2
  7427.             DO 140 J=1,JMAX
  7428.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  7429.                 TIKL = TIKL2
  7430.                 IF (MAJOR) TIKL = TIKL1
  7431.                 YVAL = (I+UTAB(J))*YINT2
  7432.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  7433.                     CALL GRMOVA(-TIKL, YVAL)
  7434.                     CALL GRLINA(TIKL, YVAL)
  7435.                 END IF
  7436.   140       CONTINUE
  7437.   150       CONTINUE
  7438.             END IF
  7439. C
  7440. C               Right ticks.
  7441. C
  7442.             IF (YOPTC) THEN
  7443.             DO 170 I=I1-1,I2
  7444.             DO 160 J=1,JMAX
  7445.                 MAJOR = (MOD(I,NSUBY).EQ.0).AND.YOPTT.AND.J.EQ.1
  7446.                 TIKL = TIKL2
  7447.                 IF (MAJOR) TIKL = TIKL1
  7448.                 YVAL = (I+UTAB(J))*YINT2
  7449.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  7450.                     CALL GRMOVA(XTRC-TIKL, YVAL)
  7451.                     CALL GRLINA(XTRC, YVAL)
  7452.                 END IF
  7453.   160       CONTINUE
  7454.   170       CONTINUE
  7455.             END IF
  7456.         END IF
  7457. C
  7458. C Write Y labels.
  7459. C
  7460.       IF (YOPTN.OR.YOPTM) THEN
  7461.           CALL PGBOX1(YBLC, YTRC, YINT, I1, I2)
  7462.           DO 180 I=I1,I2
  7463.               YC = (I*YINT-YBLC)/(YTRC-YBLC)
  7464.               IF (YOPTL) THEN
  7465.                   CALL PGNUMB(1,NINT(I*YINT),YNFORM,CLBL,NC)
  7466.               ELSE
  7467.                   CALL PGNUMB(I*NV,NP,YNFORM,CLBL,NC)
  7468.               END IF
  7469.               IF (YOPTV) THEN
  7470.                   IF (YOPTN) CALL PGMTXT('LV',YNVDSP,YC,1.0,CLBL(1:NC))
  7471.                   IF (YOPTM) CALL PGMTXT('RV',YMVDSP,YC,0.0,CLBL(1:NC))
  7472.               ELSE
  7473.                   IF (YOPTN) CALL PGMTXT('L',YNDSP,YC,0.5,CLBL(1:NC))
  7474.                   IF (YOPTM) CALL PGMTXT('R',YMDSP,YC,0.5,CLBL(1:NC))
  7475.               END IF
  7476.   180     CONTINUE
  7477.       END IF
  7478. C
  7479. C Extra Y labels for log axes.
  7480. C
  7481.       IF (YOPTLS) THEN
  7482.           CALL PGBOX1(YBLC, YTRC, YINT2, I1, I2)
  7483.           DO 402 I=I1-1,I2
  7484.             DO 302 J=2,5,3
  7485.                 YVAL = (I+UTAB(J))*YINT2
  7486.                 YC = (YVAL-YBLC)/(YTRC-YBLC)
  7487.                 KI = I
  7488.                 IF (YBLC.GT.YTRC) KI = KI+1
  7489.                 IF (IRANGE(YBLC,YVAL,YTRC)) THEN
  7490.                     CALL PGNUMB(J,NINT(KI*YINT2),YNFORM,CLBL,NC)
  7491.                     IF (YOPTV) THEN
  7492.                     IF (YOPTN) 
  7493.      1                CALL PGMTXT('LV', YNVDSP, YC, 1.0, CLBL(1:NC))
  7494.                     IF (YOPTM) 
  7495.      1                CALL PGMTXT('RV', YMVDSP, YC, 0.0, CLBL(1:NC))
  7496.                     ELSE
  7497.                     IF (YOPTN) 
  7498.      1                CALL PGMTXT('L', YNDSP, YC, 0.5, CLBL(1:NC))
  7499.                     IF (YOPTM) 
  7500.      1                CALL PGMTXT('R', YMDSP, YC, 0.5, CLBL(1:NC))
  7501.                     END IF
  7502.                 END IF
  7503.   302       CONTINUE
  7504.   402     CONTINUE
  7505.       END IF
  7506. C
  7507. C Enable clipping.
  7508. C
  7509.       CALL PGSCLP(CLIP)
  7510. C
  7511.       CALL PGEBUF
  7512.       END
  7513. C PGBOX1 -- support routine for PGBOX
  7514. C
  7515.       SUBROUTINE PGBOX1 (XA, XB, XD, I1, I2)
  7516.       REAL XA, XB, XD
  7517.       INTEGER I1, I2
  7518. C
  7519. C This routine is used to determine where to draw the tick marks on
  7520. C an axis. The input arguments XA and XB are the world-coordinate
  7521. C end points of the axis; XD is the tick interval. PGBOX1 returns
  7522. C two integers, I1 and I2, such that the required tick marks are
  7523. C to be placed at world-coordinates (I*XD), for I=I1,...,I2.
  7524. C Normally I2 is greater than or equal to I1, but if there are no
  7525. C values of I such that I*XD lies in the inclusive range (XA, XB),
  7526. C then I2 will be 1 less than I1.
  7527. C
  7528. C Arguments:
  7529. C  XA, XB (input)  : world-coordinate end points of the axis. XA must
  7530. C                    not be equal to XB; otherwise, there are no
  7531. C                    restrictions.
  7532. C  XD     (input)  : world-coordinate tick interval. XD may be positive
  7533. C                    or negative, but may not be zero.
  7534. C  I1, I2 (output) : tick marks should be drawn at world
  7535. C                    coordinates I*XD for I in the inclusive range
  7536. C                    I1...I2 (see above).
  7537. C
  7538. C 14-Jan-1986 - new routine [TJP].
  7539. C 13-Dec-1990 - remove rror check [TJP].
  7540. C-----------------------------------------------------------------------
  7541.       REAL XLO, XHI
  7542. C
  7543.       XLO = MIN(XA/XD, XB/XD)
  7544.       XHI = MAX(XA/XD, XB/XD)
  7545.       I1 = NINT(XLO)
  7546.       IF (I1.LT.XLO) I1 = I1+1
  7547.       I2 = NINT(XHI)
  7548.       IF (I2.GT.XHI) I2 = I2-1
  7549.       END
  7550. C*PGCIRC -- draw a circle, using fill-area attributes
  7551. C%void cpgcirc(float xcent, float ycent, float radius);
  7552. C+
  7553.       SUBROUTINE PGCIRC (XCENT, YCENT, RADIUS)
  7554.       REAL XCENT, YCENT, RADIUS
  7555. C
  7556. C Draw a circle. The action of this routine depends
  7557. C on the setting of the Fill-Area Style attribute. If Fill-Area Style
  7558. C is SOLID (the default), the interior of the circle is solid-filled
  7559. C using the current Color Index. If Fill-Area Style is HOLLOW, the
  7560. C outline of the circle is drawn using the current line attributes
  7561. C (color index, line-style, and line-width).
  7562. C
  7563. C Arguments:
  7564. C  XCENT  (input)  : world x-coordinate of the center of the circle.
  7565. C  YCENT  (input)  : world y-coordinate of the center of the circle.
  7566. C  RADIUS (input)  : radius of circle (world coordinates).
  7567. C--
  7568. C 26-Nov-1992 - [TJP].
  7569. C 20-Sep-1994 - adjust number of points according to size [TJP].
  7570. C-----------------------------------------------------------------------
  7571.       INCLUDE 'f77.PGPLOT/IN'
  7572.       INTEGER MAXPTS
  7573.       PARAMETER (MAXPTS=72)
  7574. C
  7575.       INTEGER NPTS,I,RADPIX
  7576.       REAL ANGLE
  7577.       REAL X(MAXPTS),Y(MAXPTS)
  7578. C
  7579.       RADPIX = NINT(RADIUS*MAX(PGXSCL(PGID), PGYSCL(PGID)))
  7580.       NPTS = MAX(8, MIN(MAXPTS, RADPIX))
  7581.       DO 10 I=1,NPTS
  7582.          ANGLE = I*360.0/REAL(NPTS)/57.3
  7583.          X(I) = XCENT + RADIUS*COS(ANGLE)
  7584.          Y(I) = YCENT + RADIUS*SIN(ANGLE)
  7585.    10 CONTINUE
  7586.       CALL PGPOLY (NPTS,X,Y)
  7587. C     write (*,*) 'PGCIRC', NPTS
  7588. C-----------------------------------------------------------------------
  7589.       END
  7590. C
  7591.       SUBROUTINE PGCL (K, X, Y, Z)
  7592.       INTEGER K
  7593.       REAL X, Y, Z
  7594. C
  7595. C PGPLOT (internal routine): Label one contour segment (for use by
  7596. C PGCONX).
  7597. C
  7598. C Arguments:
  7599. C
  7600. C K (input, integer): if K=0, move the pen to (X,Y); if K=1, draw
  7601. C       a line from the current position to (X,Y); otherwise
  7602. C       do nothing.
  7603. C X (input, real): X world-coordinate of end point.
  7604. C Y (input, real): Y world-coordinate of end point.
  7605. C Z (input, real): the value of the contour level, not used by PGCL.
  7606. C--
  7607. C  5-May-1994 - new routine [TJP]
  7608. C  7-Mar-1995 - correct error in angle; do not draw labels outside
  7609. C               window [TJP].
  7610. C 28-Aug-1995 - check arguments of atan2 [TJP].
  7611. C-----------------------------------------------------------------------
  7612.       INCLUDE  'f77.PGPLOT/IN'
  7613.       REAL     XX, YY, XC, YC, XV1, XV2, YV1, YV2, XL, XR, YB, YT
  7614.       REAL     XN, YN
  7615.       REAL     ANGLE, XO, YO, XP, YP, DINDX, DINDY, XBOX(4), YBOX(4)
  7616.       INTEGER  I, TB
  7617.       SAVE     I
  7618.       DATA     I /0/
  7619. C
  7620. C     -- transform to world coordinates
  7621.       XX = TRANS(1) + TRANS(2)*X + TRANS(3)*Y
  7622.       YY = TRANS(4) + TRANS(5)*X + TRANS(6)*Y
  7623. C
  7624.       IF (K.EQ.0) THEN
  7625. C        -- start of contour: reset segment counter
  7626.          I = 0
  7627.       ELSE
  7628. C        -- increment segment counter and check whether this
  7629. C           segment should be labelled
  7630.          I = MOD(I+1,PGCINT)
  7631.          IF (I.EQ.PGCMIN) THEN
  7632. C           -- find center of this segment (XC, YC)
  7633.             CALL PGQPOS(XP, YP)
  7634.             XC = (XX+XP)*0.5
  7635.             YC = (YY+YP)*0.5
  7636. C            -- find slope of this segment (ANGLE)
  7637.             CALL PGQVP(1, XV1, XV2, YV1, YV2)
  7638.             CALL PGQWIN(XL, XR, YB, YT)
  7639.             ANGLE = 0.0
  7640.             IF (XR.NE.XL .AND. YT.NE.YB) THEN
  7641.                DINDX = (XV2 - XV1) / (XR - XL)
  7642.                DINDY = (YV2 - YV1) / (YT - YB)
  7643.                IF (YY-YP.NE.0.0 .OR. XX-XP.NE.0.0)
  7644.      :           ANGLE = 57.3*ATAN2((YY-YP)*DINDY, (XX-XP)*DINDX)
  7645.             END IF
  7646. C           -- check whether point is in window
  7647.             XN = (XC-XL)/(XR-XL)
  7648.             YN = (YC-YB)/(YT-YB)
  7649.             IF (XN.GE.0.0 .AND. XN.LE.1.0 .AND.
  7650.      :          YN.GE.0.0 .AND. YN.LE.1.0) THEN
  7651. C              -- save current text background and set to erase
  7652.                CALL PGQTBG(TB)
  7653.                CALL PGSTBG(0)
  7654. C              -- find bounding box of label
  7655.                CALL PGQTXT(XC, YC, ANGLE, 0.5, PGCLAB, XBOX, YBOX)
  7656.                XO = 0.5*(XBOX(1)+XBOX(3))
  7657.                YO = 0.5*(YBOX(1)+YBOX(3))
  7658. C              -- plot label with bounding box centered at (XC, YC)
  7659.                CALL PGPTXT(2.0*XC-XO, 2.0*YC-YO, ANGLE, 0.5, PGCLAB)
  7660. C              -- restore text background
  7661.                CALL PGSTBG(TB)
  7662.             END IF
  7663.          END IF
  7664.       END IF
  7665.       CALL PGMOVE(XX,YY)
  7666.       END
  7667. C*PGCLOS -- close the selected graphics device
  7668. C%void cpgclos(void);
  7669. C+
  7670.       SUBROUTINE PGCLOS
  7671. C
  7672. C Close the currently selected graphics device. After the device has
  7673. C been closed, either another open device must be selected with PGSLCT
  7674. C or another device must be opened with PGOPEN before any further
  7675. C plotting can be done. If the call to PGCLOS is omitted, some or all 
  7676. C of the plot may be lost.
  7677. C
  7678. C [This routine was added to PGPLOT in Version 5.1.0. Older programs
  7679. C use PGEND instead.]
  7680. C
  7681. C Arguments: none
  7682. C--
  7683. C 22-Dec-1995 - new routine, derived from the old PGEND.
  7684. C-----------------------------------------------------------------------
  7685.       INCLUDE 'f77.PGPLOT/IN'
  7686.       CHARACTER*16 DEFSTR
  7687.       LOGICAL PGNOTO
  7688. C
  7689.       IF (.NOT.PGNOTO('PGCLOS')) THEN
  7690.          CALL GRTERM
  7691.          IF (PGPRMP(PGID)) THEN
  7692.             CALL GRQCAP(DEFSTR)
  7693.             IF (DEFSTR(8:8).EQ.'V') CALL GRPROM
  7694.          END IF
  7695.          CALL GRCLOS
  7696.          PGDEVS(PGID) = 0
  7697.          PGID = 0
  7698.       END IF
  7699. C     WRITE (*,*) 'PGCLOS', PGID, ':', PGDEVS
  7700.       END
  7701.       SUBROUTINE PGCN01(Z, MX, MY, IA, IB, JA, JB, Z0, PLOT,
  7702.      1                  FLAGS, IS, JS, SDIR)
  7703. C
  7704. C Support routine for PGCNSC. This routine draws a continuous contour,
  7705. C starting at the specified point, until it either crosses the edge of
  7706. C the array or closes on itself.
  7707. C-----------------------------------------------------------------------
  7708.       INTEGER UP, DOWN, LEFT, RIGHT
  7709.       PARAMETER (UP=1, DOWN=2, LEFT=3, RIGHT=4)
  7710.       INTEGER  MAXEMX, MAXEMY
  7711.       PARAMETER (MAXEMX=100, MAXEMY=100)
  7712.       LOGICAL FLAGS(MAXEMX,MAXEMY,2)
  7713.       INTEGER MX, MY, IA, IB, JA, JB, IS, JS, I, J, II, JJ, DIR, SDIR
  7714.       REAL Z(MX,*)
  7715.       REAL Z0, X, Y, STARTX, STARTY
  7716.       EXTERNAL PLOT
  7717. C
  7718.       I = IS
  7719.       J = JS
  7720.       DIR = SDIR
  7721.       II = 1+I-IA
  7722.       JJ = 1+J-JA
  7723.       IF (DIR.EQ.UP .OR. DIR.EQ.DOWN) THEN
  7724.           X = REAL(I) + (Z0-Z(I,J))/(Z(I+1,J)-Z(I,J))
  7725.           Y = REAL(J)
  7726.       ELSE
  7727.           X = REAL(I)
  7728.           Y = REAL(J) + (Z0-Z(I,J))/(Z(I,J+1)-Z(I,J))
  7729.       END IF
  7730. CD    WRITE (*,*) 'SEGMENT'
  7731. C
  7732. C Move to start of contour and record starting point.
  7733. C
  7734.       CALL PLOT(0, X, Y, Z0)
  7735.       STARTX = X
  7736.       STARTY = Y
  7737. C
  7738. C We have reached grid-point (I,J) going in direction DIR (UP, DOWN,
  7739. C LEFT, or RIGHT). Look at the other three sides of the cell we are
  7740. C entering to decide where to go next. It is important to look to the
  7741. C two sides before looking straight ahead, in order to avoid self-
  7742. C intersecting contours. If all 3 sides have unused crossing-points,
  7743. C the cell is "degenerate" and we have to decide which of two possible 
  7744. C pairs of contour segments to draw; at present we make an arbitrary 
  7745. C choice. If we have reached the edge of the array, we have
  7746. C finished drawing an unclosed contour. If none of the other three
  7747. C sides of the cell have an unused crossing-point, we must have
  7748. C completed a closed contour, which requires a final segment back to
  7749. C the starting point.
  7750. C
  7751.   100 CONTINUE
  7752. CD    WRITE (*,*) I,J,DIR
  7753.       II = 1 + I - IA
  7754.       JJ = 1 + J - JA
  7755.       GOTO (110, 120, 130, 140), DIR
  7756. C
  7757. C DIR = UP
  7758. C
  7759.   110 CONTINUE
  7760.       FLAGS(II,JJ,1) = .FALSE.
  7761.       IF (J.EQ.JB) THEN
  7762.           RETURN
  7763.       ELSE IF (FLAGS(II,JJ,2)) THEN
  7764.           DIR = LEFT
  7765.           GOTO 200
  7766.       ELSE IF (FLAGS(II+1,JJ,2)) THEN
  7767.           DIR = RIGHT
  7768.           I = I+1
  7769.           GOTO 200
  7770.       ELSE IF (FLAGS(II,JJ+1,1)) THEN
  7771. C!        DIR = UP
  7772.           J = J+1
  7773.           GOTO 250
  7774.       ELSE
  7775.           GOTO 300
  7776.       END IF
  7777. C
  7778. C DIR = DOWN
  7779. C
  7780.   120 CONTINUE
  7781.       FLAGS(II,JJ,1) = .FALSE.
  7782.       IF (J.EQ.JA) THEN
  7783.           RETURN
  7784.       ELSE IF (FLAGS(II+1,JJ-1,2)) THEN
  7785.           DIR = RIGHT
  7786.           I = I+1
  7787.           J = J-1
  7788.           GOTO 200
  7789.       ELSE IF (FLAGS(II,JJ-1,2)) THEN
  7790.           DIR = LEFT
  7791.           J = J-1
  7792.           GOTO 200
  7793.       ELSE IF (FLAGS(II,JJ-1,1)) THEN
  7794. C!        DIR = DOWN
  7795.           J = J-1
  7796.           GOTO 250
  7797.       ELSE
  7798.           GOTO 300
  7799.       END IF
  7800. C
  7801. C DIR = LEFT
  7802. C
  7803.   130 CONTINUE
  7804.       FLAGS(II,JJ,2) = .FALSE.
  7805.       IF (I.EQ.IA) THEN
  7806.           RETURN
  7807.       ELSE IF (FLAGS(II-1,JJ,1)) THEN
  7808.           DIR = DOWN
  7809.           I = I-1
  7810.           GOTO 250
  7811.       ELSE IF (FLAGS(II-1,JJ+1,1)) THEN
  7812.           DIR = UP
  7813.           I = I-1
  7814.           J = J+1
  7815.           GOTO 250
  7816.       ELSE IF (FLAGS(II-1,JJ,2)) THEN
  7817. C!        DIR = LEFT
  7818.           I = I-1
  7819.           GOTO 200
  7820.       ELSE
  7821.           GOTO 300
  7822.       END IF
  7823. C
  7824. C DIR = RIGHT
  7825. C
  7826.   140 CONTINUE
  7827.       FLAGS(II,JJ,2) = .FALSE.
  7828.       IF (I.EQ.IB) THEN
  7829.           RETURN
  7830.       ELSE IF (FLAGS(II,JJ+1,1)) THEN
  7831.           DIR = UP
  7832.           J = J+1
  7833.           GOTO 250
  7834.       ELSE IF (FLAGS(II,JJ,1)) THEN
  7835.           DIR = DOWN
  7836.           GOTO 250
  7837.       ELSE IF (FLAGS(II+1,JJ,2)) THEN
  7838. C!        DIR = RIGHT
  7839.           I = I+1
  7840.           GOTO 200
  7841.       ELSE
  7842.           GOTO 300
  7843.       END IF
  7844. C
  7845. C Draw a segment of the contour.
  7846. C
  7847.   200 X = REAL(I)
  7848.       Y = REAL(J) + (Z0-Z(I,J))/(Z(I,J+1)-Z(I,J))
  7849.       CALL PLOT(1,X,Y,Z0)
  7850.       GOTO 100
  7851.   250 X = REAL(I) + (Z0-Z(I,J))/(Z(I+1,J)-Z(I,J))
  7852.       Y = REAL(J)
  7853.       CALL PLOT(1,X,Y,Z0)
  7854.       GOTO 100
  7855. C
  7856. C Close the contour and go look for another one.
  7857. C
  7858.   300 CALL PLOT(1,STARTX,STARTY,Z0)
  7859.       RETURN
  7860. C
  7861.       END
  7862.       SUBROUTINE PGCNSC (Z, MX, MY, IA, IB, JA, JB, Z0, PLOT)
  7863.       INTEGER MX, MY, IA, IB, JA, JB
  7864.       REAL Z(MX,*)
  7865.       REAL Z0
  7866.       EXTERNAL PLOT
  7867. C
  7868. C PGPLOT (internal routine): Draw a single contour.  This routine is
  7869. C called by PGCONT, but may be called directly by the user.
  7870. C
  7871. C Arguments:
  7872. C
  7873. C Z (real array dimension MX,MY, input): the array of function values.
  7874. C MX,MY (integer, input): actual declared dimension of Z(*,*).
  7875. C IA,IB (integer, input): inclusive range of the first index of Z to be
  7876. C       contoured.
  7877. C JA,JB (integer, input): inclusive range of the second index of Z to
  7878. C       be contoured.
  7879. C Z0 (real, input): the contour level sought.
  7880. C PLOT (the name of a subroutine declared EXTERNAL in the calling
  7881. C       routine): this routine is called by PGCNSC to do all graphical
  7882. C       output. The calling sequence is CALL PLOT(K,X,Y,Z) where Z is
  7883. C       the contour level, (X,Y) are the coordinates of a point (in the
  7884. C       inclusive range I1<X<I2, J1<Y<J2, and if K is 0, the routine is
  7885. C       to move then pen to (X,Y); if K is 1, it is to draw a line from
  7886. C       the current position to (X,Y).
  7887. C
  7888. C NOTE:  the intervals (IA,IB) and (JA,JB) must not exceed the
  7889. C dimensions of an internal array. These are currently set at 100.
  7890. C--
  7891. C 17-Sep-1989 - Completely rewritten [TJP]. The algorithm is my own,
  7892. C               but it is probably not original. It could probably be
  7893. C               coded more briefly, if not as clearly.
  7894. C  1-May-1994 - Modified to draw contours anticlockwise about maxima,
  7895. C               to prevent contours at different levels from
  7896. C               crossing in degenerate cells [TJP].
  7897. C-----------------------------------------------------------------------
  7898.       INTEGER UP, DOWN, LEFT, RIGHT
  7899.       PARAMETER (UP=1, DOWN=2, LEFT=3, RIGHT=4)
  7900.       INTEGER  MAXEMX, MAXEMY
  7901.       PARAMETER (MAXEMX=100, MAXEMY=100)
  7902. C
  7903.       LOGICAL FLAGS(MAXEMX,MAXEMY,2), RANGE
  7904.       INTEGER I, J, II, JJ, DIR
  7905.       REAL Z1, Z2, Z3, P, P1, P2
  7906. C
  7907. C The statement function RANGE decides whether a contour at level P
  7908. C crosses the line between two gridpoints with values P1 and P2. It is
  7909. C important that a contour cannot cross a line with equal endpoints.
  7910. C
  7911.       RANGE (P,P1,P2) = (P.GT.MIN(P1,P2)) .AND. (P.LE.MAX(P1,P2))
  7912.      1                  .AND. (P1.NE.P2)
  7913. C
  7914. C Check for errors.
  7915. C
  7916.       IF ( (IB-IA+1) .GT. MAXEMX .OR.  (JB-JA+1) .GT. MAXEMY ) THEN
  7917.           CALL GRWARN('PGCNSC - array index range exceeds'//
  7918.      1                ' built-in limit of 100')
  7919.           RETURN
  7920.       END IF
  7921. C
  7922. C Initialize the flags. The first flag for a gridpoint is set if
  7923. C the contour crosses the line segment to the right of the gridpoint
  7924. C (joining [I,J] to [I+1,J]); the second flag is set if if it crosses
  7925. C the line segment above the gridpoint (joining [I,J] to [I,J+1]).
  7926. C The top and right edges require special treatment. (For purposes
  7927. C of description only, we assume I increases horizontally to the right
  7928. C and J increases vertically upwards.)
  7929. C
  7930.       DO 20 I=IA,IB
  7931.           II = I-IA+1
  7932.           DO 10 J=JA,JB
  7933.               JJ = J-JA+1
  7934.               Z1 = Z(I,J)
  7935.               FLAGS(II,JJ,1) = .FALSE.
  7936.               FLAGS(II,JJ,2) = .FALSE.
  7937.               IF (I.LT.IB) THEN
  7938.                 Z2 = Z(I+1,J)
  7939.                 IF (RANGE(Z0,Z1,Z2)) FLAGS(II,JJ,1) = .TRUE.
  7940.               END IF
  7941.               IF (J.LT.JB) THEN
  7942.                 Z3 = Z(I,J+1)
  7943.                 IF (RANGE(Z0,Z1,Z3)) FLAGS(II,JJ,2) = .TRUE.
  7944.               END IF
  7945.    10     CONTINUE
  7946.    20 CONTINUE
  7947. C
  7948. C Search the edges of the array for the start of an unclosed contour.
  7949. C Note that (if the algorithm is implemented correctly) all unclosed
  7950. C contours must begin and end at the edge of the array. When one is
  7951. C found, call PGCN01 to draw the contour, telling it the correct
  7952. C starting direction so that it follows the contour into the array
  7953. C instead of out of it. A contour is only started if the higher
  7954. C ground lies to the left: this is to enforce the direction convention
  7955. C that contours are drawn anticlockwise around maxima. If the high
  7956. C ground lies to the right, we will find the other end of the contour
  7957. C and start there.
  7958. C
  7959. C Bottom edge.
  7960. C
  7961.       J = JA
  7962.       JJ = J-JA+1
  7963.       DO 26 I=IA,IB-1
  7964.           II = I-IA+1
  7965.           IF (FLAGS(II,JJ,1) .AND. (Z(I,J).GT.Z(I+1,J)))
  7966.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7967.      2                      Z0, PLOT, FLAGS, I, J, UP)
  7968.    26 CONTINUE
  7969. C
  7970. C Right edge.
  7971. C
  7972.       I = IB
  7973.       II = I-IA+1
  7974.       DO 27 J=JA,JB-1
  7975.           JJ = J-JA+1
  7976.           IF (FLAGS(II,JJ,2) .AND. (Z(I,J).GT.Z(I,J+1)))
  7977.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7978.      2                      Z0, PLOT, FLAGS, I, J, LEFT)
  7979.    27 CONTINUE
  7980. C
  7981. C Top edge.
  7982. C
  7983.       J = JB
  7984.       JJ = J-JA+1
  7985.       DO 28 I=IB-1,IA,-1
  7986.           II = I-IA+1
  7987.           IF (FLAGS(II,JJ,1) .AND. (Z(I+1,J).GT.Z(I,J)))
  7988.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  7989.      2                      Z0, PLOT, FLAGS, I, J, DOWN)
  7990.    28 CONTINUE
  7991. C
  7992. C Left edge.
  7993. C
  7994.       I = IA
  7995.       II = I-IA+1
  7996.       DO 29 J=JB-1,JA,-1
  7997.           JJ = J-JA+1
  7998.           IF (FLAGS(II,JJ,2)  .AND. (Z(I,J+1).GT.Z(I,J)))
  7999.      1          CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  8000.      2                      Z0, PLOT, FLAGS, I, J, RIGHT)
  8001.    29 CONTINUE
  8002. C
  8003. C Now search the interior of the array for a crossing point, which will
  8004. C lie on a closed contour (because all unclosed contours have been
  8005. C eliminated). It is sufficient to search just the horizontal crossings
  8006. C (or the vertical ones); any closed contour must cross a horizontal
  8007. C and a vertical gridline. PGCN01 assumes that when it cannot proceed
  8008. C any further, it has reached the end of a closed contour. Thus all
  8009. C unclosed contours must be eliminated first.
  8010. C
  8011.       DO 40 I=IA+1,IB-1
  8012.           II = I-IA+1
  8013.           DO 30 J=JA+1,JB-1
  8014.               JJ = J-JA+1
  8015.               IF (FLAGS(II,JJ,1)) THEN
  8016.                   DIR = UP
  8017.                   IF (Z(I+1,J).GT. Z(I,J)) DIR = DOWN
  8018.                   CALL PGCN01(Z, MX, MY, IA, IB, JA, JB,
  8019.      1                        Z0, PLOT, FLAGS, I, J, DIR)
  8020.  
  8021.               END IF
  8022.    30     CONTINUE
  8023.    40 CONTINUE
  8024. C
  8025. C We didn't find any more crossing points: we're finished.
  8026. C
  8027.       RETURN
  8028.       END
  8029. C*PGCONB -- contour map of a 2D data array, with blanking
  8030. C%void cpgconb(const float *a, int idim, int jdim, int i1, int i2, \
  8031. C% int j1, int j2, const float *c, int nc, const float *tr, \
  8032. C% float blank);
  8033. C+
  8034.       SUBROUTINE PGCONB (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR, 
  8035.      1                   BLANK)
  8036.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  8037.       REAL    A(IDIM,JDIM), C(*), TR(6), BLANK
  8038. C
  8039. C Draw a contour map of an array. This routine is the same as PGCONS,
  8040. C except that array elements that have the "magic value" defined by
  8041. C argument BLANK are ignored, making gaps in the contour map. The
  8042. C routine may be useful for data measured on most but not all of the
  8043. C points of a grid.
  8044. C
  8045. C Arguments:
  8046. C  A      (input)  : data array.
  8047. C  IDIM   (input)  : first dimension of A.
  8048. C  JDIM   (input)  : second dimension of A.
  8049. C  I1,I2  (input)  : range of first index to be contoured (inclusive).
  8050. C  J1,J2  (input)  : range of second index to be contoured (inclusive).
  8051. C  C      (input)  : array of contour levels (in the same units as the
  8052. C                    data in array A); dimension at least NC.
  8053. C  NC     (input)  : number of contour levels (less than or equal to
  8054. C                    dimension of C). The absolute value of this
  8055. C                    argument is used (for compatibility with PGCONT,
  8056. C                    where the sign of NC is significant).
  8057. C  TR     (input)  : array defining a transformation between the I,J
  8058. C                    grid of the array and the world coordinates. The
  8059. C                    world coordinates of the array point A(I,J) are
  8060. C                    given by:
  8061. C                      X = TR(1) + TR(2)*I + TR(3)*J
  8062. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  8063. C                    Usually TR(3) and TR(5) are zero - unless the
  8064. C                    coordinate transformation involves a rotation
  8065. C                    or shear.
  8066. C  BLANK   (input) : elements of array A that are exactly equal to
  8067. C                    this value are ignored (blanked).
  8068. C--
  8069. C 21-Sep-1989 - Derived from PGCONS [TJP].
  8070. C-----------------------------------------------------------------------
  8071.       INTEGER  I, IC, ICORN, IDELT(6), J, K, NPT
  8072.       INTEGER  IOFF(8), JOFF(8), IENC, ITMP, JTMP, ILO, ITOT
  8073.       LOGICAL  PGNOTO
  8074.       REAL     CTR, DELTA, DVAL(5), XX, YY, X(4), Y(4)
  8075.       INTRINSIC ABS
  8076.       DATA     IDELT/0,-1,-1,0,0,-1/
  8077.       DATA     IOFF/-2,-2,-1,-1, 0, 0, 1, 1/
  8078.       DATA     JOFF/ 0,-1,-2, 1,-2, 1,-1, 0/
  8079. C
  8080. C Check arguments.
  8081. C
  8082.       IF (PGNOTO('PGCONB')) RETURN
  8083.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  8084.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) RETURN
  8085.       IF (NC.EQ.0) RETURN
  8086.       CALL PGBBUF
  8087. C
  8088.       DO 130 J=J1+1,J2
  8089.       DO 130 I=I1+1,I2
  8090.           DVAL(1) = A(I-1,J)
  8091.           DVAL(2) = A(I-1,J-1)
  8092.           DVAL(3) = A(I,J-1)
  8093.           DVAL(4) = A(I,J)
  8094.           DVAL(5) = DVAL(1)
  8095.           IF (DVAL(1).EQ.BLANK .OR. DVAL(2).EQ.BLANK .OR.
  8096.      1        DVAL(3).EQ.BLANK .OR. DVAL(4).EQ.BLANK) GOTO 130
  8097.       DO 110 IC=1,ABS(NC)
  8098.           CTR = C(IC)
  8099.           NPT = 0
  8100.           DO 120 ICORN=1,4
  8101.           IF( (DVAL(ICORN).LT.CTR .AND. DVAL(ICORN+1).LT.CTR)
  8102.      1    .OR.(DVAL(ICORN).GE.CTR .AND. DVAL(ICORN+1).GE.CTR) ) GOTO 120
  8103.             NPT=NPT+1
  8104.             DELTA = (CTR-DVAL(ICORN))/(DVAL(ICORN+1)-DVAL(ICORN))
  8105.             GOTO (60,70,60,70), ICORN
  8106. C
  8107.    60       XX = I+IDELT(ICORN+1)
  8108.             YY = REAL(J+IDELT(ICORN)) + 
  8109.      1           DELTA*REAL(IDELT(ICORN+1)-IDELT(ICORN))
  8110.             GOTO 80
  8111. C
  8112.    70       XX = REAL(I+IDELT(ICORN+1)) +
  8113.      1           DELTA*REAL(IDELT(ICORN+2)-IDELT(ICORN+1))
  8114.             YY  = J+IDELT(ICORN)
  8115. C
  8116.    80       X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  8117.             Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  8118. C
  8119.   120     CONTINUE
  8120.           IF (NPT.EQ.2) THEN
  8121. C             -- Contour crosses two sides of cell. Draw line-segment.
  8122.               CALL PGMOVE(X(1),Y(1))
  8123.               CALL PGDRAW(X(2),Y(2))
  8124.           ELSE IF (NPT.EQ.4) THEN
  8125. C             -- The 'ambiguous' case.  The routine must draw two line
  8126. C             segments here and there are two ways to do so.  The
  8127. C             following 4 lines would implement the original PGPLOT
  8128. C             method:
  8129. C            CALL PGCP(0,X(1),Y(1),CTR)
  8130. C            CALL PGCP(1,X(2),Y(2),CTR)
  8131. C            CALL PGCP(0,X(3),Y(3),CTR)
  8132. C            CALL PGCP(1,X(4),Y(4),CTR)
  8133. C            -- Choose between \\ and // based on the 8 points just
  8134. C            outside the current box.  If half or more of these points
  8135. C            lie below the contour level, then draw the lines such that
  8136. C            the high corners lie between the lines, otherwise, draw
  8137. C            the lines such that the low corners are enclosed.  Care is
  8138. C            taken to avoid going off the edge.
  8139.             ITOT=0
  8140.             ILO=0
  8141.             DO 140 K=1,8
  8142.                ITMP=I+IOFF(K)
  8143.                JTMP=J+JOFF(K)
  8144.                IF(ITMP.LT.I1 .OR. ITMP.GT.I2) GOTO 140
  8145.                IF(JTMP.LT.J1 .OR. JTMP.GT.J2) GOTO 140
  8146.                IF(A(ITMP,JTMP).EQ.BLANK) GOTO 140
  8147.                ITOT=ITOT+1
  8148.                IF(A(ITMP,JTMP).LT.CTR) ILO=ILO+1
  8149.   140       CONTINUE
  8150.             IENC=+1
  8151.             IF(ILO.LT.ITOT/2) IENC=-1
  8152.             IF(IENC.LT.0 .AND. DVAL(1).LT.CTR .OR.
  8153.      :         IENC.GT.0 .AND. DVAL(1).GE.CTR) THEN
  8154.                CALL PGMOVE(X(1),Y(1))
  8155.                CALL PGDRAW(X(2),Y(2))
  8156.                CALL PGMOVE(X(3),Y(3))
  8157.                CALL PGDRAW(X(4),Y(4))
  8158.             ELSE
  8159.                CALL PGMOVE(X(1),Y(1))
  8160.                CALL PGDRAW(X(4),Y(4))
  8161.                CALL PGMOVE(X(3),Y(3))
  8162.                CALL PGDRAW(X(2),Y(2))
  8163.             END IF
  8164.           END IF
  8165.   110     CONTINUE
  8166.   130 CONTINUE
  8167. C
  8168.       CALL PGEBUF
  8169.       END
  8170. C*PGCONF -- fill between two contours
  8171. C%void cpgconf(const float *a, int idim, int jdim, int i1, int i2, \
  8172. C% int j1, int j2, float c1, float c2, const float *tr);
  8173. C+
  8174.       SUBROUTINE PGCONF (A, IDIM, JDIM, I1, I2, J1, J2, C1, C2, TR)
  8175.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  8176.       REAL    A(IDIM,JDIM), C1, C2, TR(6)
  8177. C
  8178. C Shade the region between two contour levels of a function defined on
  8179. C the nodes of a rectangular grid. The routine uses the current fill
  8180. C attributes, hatching style (if appropriate), and color index.
  8181. C
  8182. C If you want to both shade between contours and draw the contour
  8183. C lines, call this routine first (once for each pair of levels) and 
  8184. C then CALL PGCONT (or PGCONS) to draw the contour lines on top of the
  8185. C shading.
  8186. C
  8187. C Note 1: This routine is not very efficient: it generates a polygon
  8188. C fill command for each cell of the mesh that intersects the desired
  8189. C area, rather than consolidating adjacent cells into a single polygon.
  8190. C
  8191. C Note 2: If both contours intersect all four edges of a particular
  8192. C mesh cell, the program behaves badly and may consider some parts
  8193. C of the cell to lie in more than one contour range.
  8194. C
  8195. C Note 3: If a contour crosses all four edges of a cell, this
  8196. C routine may not generate the same contours as PGCONT or PGCONS
  8197. C (these two routines may not agree either). Such cases are always
  8198. C ambiguous and the routines use different approaches to resolving
  8199. C the ambiguity.
  8200. C
  8201. C Arguments:
  8202. C  A      (input)  : data array.
  8203. C  IDIM   (input)  : first dimension of A.
  8204. C  JDIM   (input)  : second dimension of A.
  8205. C  I1,I2  (input)  : range of first index to be contoured (inclusive).
  8206. C  J1,J2  (input)  : range of second index to be contoured (inclusive).
  8207. C  C1, C2 (input)  : contour levels; note that C1 must be less than C2.
  8208. C  TR     (input)  : array defining a transformation between the I,J
  8209. C                    grid of the array and the world coordinates. The
  8210. C                    world coordinates of the array point A(I,J) are
  8211. C                    given by:
  8212. C                      X = TR(1) + TR(2)*I + TR(3)*J
  8213. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  8214. C                    Usually TR(3) and TR(5) are zero - unless the
  8215. C                    coordinate transformation involves a rotation
  8216. C                    or shear.
  8217. C--
  8218. C 03-Oct-1996 - new routine [TJP].
  8219. C-----------------------------------------------------------------------
  8220.       INTEGER  I, J, IC, NPT, LEV
  8221.       LOGICAL  PGNOTO
  8222.       REAL     DVAL(5), X(8), Y(8), DELTA, XX, YY, C, R
  8223.       INTEGER  IDELT(6)
  8224.       DATA     IDELT/0,-1,-1,0,0,-1/
  8225. C
  8226. C Check arguments.
  8227. C
  8228.       IF (PGNOTO('PGCONF')) RETURN
  8229.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  8230.      :    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) RETURN
  8231.       IF (C1.GE.C2) RETURN
  8232.       CALL PGBBUF
  8233. C
  8234.       DO 140 J=J1+1,J2
  8235.          DO 130 I=I1+1,I2
  8236.             DVAL(1) = A(I-1,J)
  8237.             DVAL(2) = A(I-1,J-1)
  8238.             DVAL(3) = A(I,J-1)
  8239.             DVAL(4) = A(I,J)
  8240.             DVAL(5) = DVAL(1)
  8241. C
  8242.             NPT = 0
  8243.             DO 120 IC=1,4
  8244.                IF (DVAL(IC).GE.C1 .AND. DVAL(IC).LT.C2) THEN
  8245.                   NPT = NPT+1
  8246.                   XX = I+IDELT(IC+1)
  8247.                   YY = J+IDELT(IC)
  8248.                   X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  8249.                   Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  8250.                END IF
  8251.                R = DVAL(IC+1)-DVAL(IC)
  8252.                IF (R.EQ.0.0) GOTO 120
  8253.                DO 110 LEV=1,2
  8254.                   IF (R.GT.0.0) THEN
  8255.                      C = C1
  8256.                      IF (LEV.EQ.2) C = C2
  8257.                   ELSE
  8258.                      C = C2
  8259.                      IF (LEV.EQ.2) C = C1
  8260.                   END IF
  8261.                   DELTA = (C-DVAL(IC))/R
  8262.                   IF (DELTA.GT.0.0 .AND. DELTA.LT.1.0) THEN
  8263.                      IF (IC.EQ.1 .OR. IC.EQ.3) THEN
  8264.                         XX = I+IDELT(IC+1)
  8265.                         YY = REAL(J+IDELT(IC)) + 
  8266.      :                       DELTA*REAL(IDELT(IC+1)-IDELT(IC))
  8267.                      ELSE
  8268.                         XX = REAL(I+IDELT(IC+1)) +
  8269.      :                       DELTA*REAL(IDELT(IC+2)-IDELT(IC+1))
  8270.                         YY = J+IDELT(IC)
  8271.                      END IF
  8272.                      NPT = NPT+1
  8273.                      X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  8274.                      Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  8275.                   END IF
  8276.  110           CONTINUE
  8277.  120        CONTINUE
  8278.             IF (NPT.GE.3) CALL PGPOLY(NPT, X, Y)
  8279.  130     CONTINUE
  8280.  140  CONTINUE
  8281.       CALL PGEBUF
  8282.       END
  8283. C*PGCONL -- label contour map of a 2D data array 
  8284. C%void cpgconl(const float *a, int idim, int jdim, int i1, int i2, \
  8285. C% int j1, int j2, float c, const float *tr, const char *label, \
  8286. C% int intval, int minint);
  8287. C+
  8288.       SUBROUTINE PGCONL (A, IDIM, JDIM, I1, I2, J1, J2, C, TR,
  8289.      1                   LABEL, INTVAL, MININT)
  8290.       INTEGER IDIM, JDIM, I1, J1, I2, J2, INTVAL, MININT
  8291.       REAL A(IDIM,JDIM), C, TR(6)
  8292.       CHARACTER*(*) LABEL
  8293. C
  8294. C Label a contour map drawn with routine PGCONT. Routine PGCONT should
  8295. C be called first to draw the contour lines, then this routine should be
  8296. C called to add the labels. Labels are written at intervals along the
  8297. C contour lines, centered on the contour lines with lettering aligned
  8298. C in the up-hill direction. Labels are opaque, so a part of the under-
  8299. C lying contour line is obscured by the label. Labels use the current
  8300. C attributes (character height, line width, color index, character
  8301. C font).
  8302. C
  8303. C The first 9 arguments are the same as those supplied to PGCONT, and
  8304. C should normally be identical to those used with PGCONT. Note that
  8305. C only one contour level can be specified; tolabel more contours, call
  8306. C PGCONL for each level.
  8307. C
  8308. C The Label is supplied as a character string in argument LABEL.
  8309. C
  8310. C The spacing of labels along the contour is specified by parameters
  8311. C INTVAL and MININT. The routine follows the contour through the
  8312. C array, counting the number of cells that the contour crosses. The
  8313. C first label will be written in the MININT'th cell, and additional
  8314. C labels will be written every INTVAL cells thereafter. A contour
  8315. C that crosses less than MININT cells will not be labelled. Some
  8316. C experimentation may be needed to get satisfactory results; a good
  8317. C place to start is INTVAL=20, MININT=10.
  8318. C
  8319. C Arguments:
  8320. C  A      (input) : data array.
  8321. C  IDIM   (input) : first dimension of A.
  8322. C  JDIM   (input) : second dimension of A.
  8323. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  8324. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  8325. C  C      (input) : the level of the contour to be labelled (one of the
  8326. C                   values given to PGCONT).
  8327. C  TR     (input) : array defining a transformation between the I,J
  8328. C                   grid of the array and the world coordinates.
  8329. C                   The world coordinates of the array point A(I,J)
  8330. C                   are given by:
  8331. C                     X = TR(1) + TR(2)*I + TR(3)*J
  8332. C                     Y = TR(4) + TR(5)*I + TR(6)*J
  8333. C                   Usually TR(3) and TR(5) are zero - unless the
  8334. C                   coordinate transformation involves a rotation or
  8335. C                   shear.
  8336. C  LABEL  (input) : character strings to be used to label the specified
  8337. C                   contour. Leading and trailing blank spaces are
  8338. C                   ignored.
  8339. C  INTVAL (input) : spacing along the contour between labels, in
  8340. C                   grid cells.
  8341. C  MININT (input) : contours that cross less than MININT cells
  8342. C                   will not be labelled.
  8343. C--
  8344. C  5-May-1994 - New routine; this routine is virtually identical to
  8345. C               PGCONT, but calls PGCONX with a different external
  8346. C               routine [TJP].
  8347. C  4-Feb-1997 - PGCONX requires an array argument, not scalar [TJP].
  8348. C-----------------------------------------------------------------------
  8349.       INCLUDE  'f77.PGPLOT/IN'
  8350.       INTEGER  I
  8351.       LOGICAL  PGNOTO
  8352.       REAL     CL(1)
  8353.       EXTERNAL PGCL
  8354. C
  8355.       IF (PGNOTO('PGCONL')) RETURN
  8356. C
  8357. C Save TRANS matrix and other parameters.
  8358. C
  8359.       DO 10 I=1,6
  8360.           TRANS(I) = TR(I)
  8361.    10 CONTINUE
  8362.       PGCINT = INTVAL
  8363.       PGCMIN = MININT
  8364.       PGCLAB = LABEL
  8365. C
  8366. C Use PGCONX with external function PGCL.
  8367. C
  8368.       CL(1) = C
  8369.       CALL PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, CL, 1, PGCL)
  8370. C
  8371.       END
  8372. C*PGCONS -- contour map of a 2D data array (fast algorithm)
  8373. C%void cpgcons(const float *a, int idim, int jdim, int i1, int i2, \
  8374. C% int j1, int j2, const float *c, int nc, const float *tr);
  8375. C+
  8376.       SUBROUTINE PGCONS (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR)
  8377.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  8378.       REAL    A(IDIM,JDIM), C(*), TR(6)
  8379. C
  8380. C Draw a contour map of an array. The map is truncated if
  8381. C necessary at the boundaries of the viewport.  Each contour line is
  8382. C drawn with the current line attributes (color index, style, and
  8383. C width).  This routine, unlike PGCONT, does not draw each contour as a
  8384. C continuous line, but draws the straight line segments composing each
  8385. C contour in a random order.  It is thus not suitable for use on pen
  8386. C plotters, and it usually gives unsatisfactory results with dashed or
  8387. C dotted lines.  It is, however, faster than PGCONT, especially if
  8388. C several contour levels are drawn with one call of PGCONS.
  8389. C
  8390. C Arguments:
  8391. C  A      (input)  : data array.
  8392. C  IDIM   (input)  : first dimension of A.
  8393. C  JDIM   (input)  : second dimension of A.
  8394. C  I1,I2  (input)  : range of first index to be contoured (inclusive).
  8395. C  J1,J2  (input)  : range of second index to be contoured (inclusive).
  8396. C  C      (input)  : array of contour levels (in the same units as the
  8397. C                    data in array A); dimension at least NC.
  8398. C  NC     (input)  : number of contour levels (less than or equal to
  8399. C                    dimension of C). The absolute value of this
  8400. C                    argument is used (for compatibility with PGCONT,
  8401. C                    where the sign of NC is significant).
  8402. C  TR     (input)  : array defining a transformation between the I,J
  8403. C                    grid of the array and the world coordinates. The
  8404. C                    world coordinates of the array point A(I,J) are
  8405. C                    given by:
  8406. C                      X = TR(1) + TR(2)*I + TR(3)*J
  8407. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  8408. C                    Usually TR(3) and TR(5) are zero - unless the
  8409. C                    coordinate transformation involves a rotation
  8410. C                    or shear.
  8411. C--
  8412. C 27-Aug-1984 - [TJP].
  8413. C 21-Sep-1989 - Better treatment of the 'ambiguous' case [A. Tennant];
  8414. C               compute world coordinates internally and eliminate
  8415. C               dependence on common block [TJP].
  8416. C-----------------------------------------------------------------------
  8417.       INTEGER  I, IC, ICORN, IDELT(6), J, K, NPT
  8418.       INTEGER  IOFF(8), JOFF(8), IENC, ITMP, JTMP, ILO, ITOT
  8419.       LOGICAL  PGNOTO
  8420.       REAL     CTR, DELTA, DVAL(5), XX, YY, X(4), Y(4)
  8421.       INTRINSIC ABS
  8422.       DATA     IDELT/0,-1,-1,0,0,-1/
  8423.       DATA     IOFF/-2,-2,-1,-1, 0, 0, 1, 1/
  8424.       DATA     JOFF/ 0,-1,-2, 1,-2, 1,-1, 0/
  8425. C
  8426. C Check arguments.
  8427. C
  8428.       IF (PGNOTO('PGCONS')) RETURN
  8429.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  8430.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) RETURN
  8431.       IF (NC.EQ.0) RETURN
  8432.       CALL PGBBUF
  8433. C
  8434.       DO 130 J=J1+1,J2
  8435.       DO 130 I=I1+1,I2
  8436.           DVAL(1) = A(I-1,J)
  8437.           DVAL(2) = A(I-1,J-1)
  8438.           DVAL(3) = A(I,J-1)
  8439.           DVAL(4) = A(I,J)
  8440.           DVAL(5) = DVAL(1)
  8441.       DO 110 IC=1,ABS(NC)
  8442.           CTR = C(IC)
  8443.           NPT = 0
  8444.           DO 120 ICORN=1,4
  8445.           IF( (DVAL(ICORN).LT.CTR .AND. DVAL(ICORN+1).LT.CTR)
  8446.      1    .OR.(DVAL(ICORN).GE.CTR .AND. DVAL(ICORN+1).GE.CTR) ) GOTO 120
  8447.             NPT=NPT+1
  8448.             DELTA = (CTR-DVAL(ICORN))/(DVAL(ICORN+1)-DVAL(ICORN))
  8449.             GOTO (60,70,60,70), ICORN
  8450. C
  8451.    60       XX = I+IDELT(ICORN+1)
  8452.             YY = REAL(J+IDELT(ICORN)) + 
  8453.      1           DELTA*REAL(IDELT(ICORN+1)-IDELT(ICORN))
  8454.             GOTO 80
  8455. C
  8456.    70       XX = REAL(I+IDELT(ICORN+1)) +
  8457.      1           DELTA*REAL(IDELT(ICORN+2)-IDELT(ICORN+1))
  8458.             YY  = J+IDELT(ICORN)
  8459. C
  8460.    80       X(NPT) = TR(1) + TR(2)*XX + TR(3)*YY
  8461.             Y(NPT) = TR(4) + TR(5)*XX + TR(6)*YY
  8462. C
  8463.   120     CONTINUE
  8464.           IF (NPT.EQ.2) THEN
  8465. C             -- Contour crosses two sides of cell. Draw line-segment.
  8466.               CALL PGMOVE(X(1),Y(1))
  8467.               CALL PGDRAW(X(2),Y(2))
  8468.           ELSE IF (NPT.EQ.4) THEN
  8469. C             -- The 'ambiguous' case.  The routine must draw two line
  8470. C             segments here and there are two ways to do so.  The
  8471. C             following 4 lines would implement the original PGPLOT
  8472. C             method:
  8473. C            CALL PGCP(0,X(1),Y(1),CTR)
  8474. C            CALL PGCP(1,X(2),Y(2),CTR)
  8475. C            CALL PGCP(0,X(3),Y(3),CTR)
  8476. C            CALL PGCP(1,X(4),Y(4),CTR)
  8477. C            -- Choose between \\ and // based on the 8 points just
  8478. C            outside the current box.  If half or more of these points
  8479. C            lie below the contour level, then draw the lines such that
  8480. C            the high corners lie between the lines, otherwise, draw
  8481. C            the lines such that the low corners are enclosed.  Care is
  8482. C            taken to avoid going off the edge.
  8483.             ITOT=0
  8484.             ILO=0
  8485.             DO 140 K=1,8
  8486.                ITMP=I+IOFF(K)
  8487.                JTMP=J+JOFF(K)
  8488.                IF(ITMP.LT.I1 .OR. ITMP.GT.I2) GOTO 140
  8489.                IF(JTMP.LT.J1 .OR. JTMP.GT.J2) GOTO 140
  8490.                ITOT=ITOT+1
  8491.                IF(A(ITMP,JTMP).LT.CTR) ILO=ILO+1
  8492.   140       CONTINUE
  8493.             IENC=+1
  8494.             IF(ILO.LT.ITOT/2) IENC=-1
  8495.             IF(IENC.LT.0 .AND. DVAL(1).LT.CTR .OR.
  8496.      :         IENC.GT.0 .AND. DVAL(1).GE.CTR) THEN
  8497.                CALL PGMOVE(X(1),Y(1))
  8498.                CALL PGDRAW(X(2),Y(2))
  8499.                CALL PGMOVE(X(3),Y(3))
  8500.                CALL PGDRAW(X(4),Y(4))
  8501.             ELSE
  8502.                CALL PGMOVE(X(1),Y(1))
  8503.                CALL PGDRAW(X(4),Y(4))
  8504.                CALL PGMOVE(X(3),Y(3))
  8505.                CALL PGDRAW(X(2),Y(2))
  8506.             END IF
  8507.           END IF
  8508.   110     CONTINUE
  8509.   130 CONTINUE
  8510. C
  8511.       CALL PGEBUF
  8512.       END
  8513. C*PGCONT -- contour map of a 2D data array (contour-following)
  8514. C%void cpgcont(const float *a, int idim, int jdim, int i1, int i2, \
  8515. C% int j1, int j2, const float *c, int nc, const float *tr);
  8516. C+
  8517.       SUBROUTINE PGCONT (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR)
  8518.       INTEGER IDIM, JDIM, I1, J1, I2, J2, NC
  8519.       REAL A(IDIM,JDIM), C(*), TR(6)
  8520. C
  8521. C Draw a contour map of an array.  The map is truncated if
  8522. C necessary at the boundaries of the viewport.  Each contour line
  8523. C is drawn with the current line attributes (color index, style, and
  8524. C width); except that if argument NC is positive (see below), the line
  8525. C style is set by PGCONT to 1 (solid) for positive contours or 2
  8526. C (dashed) for negative contours.
  8527. C
  8528. C Arguments:
  8529. C  A      (input) : data array.
  8530. C  IDIM   (input) : first dimension of A.
  8531. C  JDIM   (input) : second dimension of A.
  8532. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  8533. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  8534. C  C      (input) : array of NC contour levels; dimension at least NC.
  8535. C  NC     (input) : +/- number of contour levels (less than or equal
  8536. C                   to dimension of C). If NC is positive, it is the
  8537. C                   number of contour levels, and the line-style is
  8538. C                   chosen automatically as described above. If NC is
  8539. C                   negative, it is minus the number of contour
  8540. C                   levels, and the current setting of line-style is
  8541. C                   used for all the contours.
  8542. C  TR     (input) : array defining a transformation between the I,J
  8543. C                   grid of the array and the world coordinates.
  8544. C                   The world coordinates of the array point A(I,J)
  8545. C                   are given by:
  8546. C                     X = TR(1) + TR(2)*I + TR(3)*J
  8547. C                     Y = TR(4) + TR(5)*I + TR(6)*J
  8548. C                   Usually TR(3) and TR(5) are zero - unless the
  8549. C                   coordinate transformation involves a rotation or
  8550. C                   shear.
  8551. C--
  8552. C (7-Feb-1983)
  8553. C (24-Aug-1984) Revised to add the option of not automatically
  8554. C       setting the line-style. Sorry about the ugly way this is
  8555. C       done (negative NC); this is the least incompatible way of doing
  8556. C       it (TJP).
  8557. C (21-Sep-1989) Changed to call PGCONX instead of duplicating the code
  8558. C       [TJP].
  8559. C-----------------------------------------------------------------------
  8560.       INCLUDE  'f77.PGPLOT/IN'
  8561.       INTEGER  I
  8562.       LOGICAL  PGNOTO
  8563.       EXTERNAL PGCP
  8564. C
  8565.       IF (PGNOTO('PGCONT')) RETURN
  8566. C
  8567. C Save TRANS matrix.
  8568. C
  8569.       DO 10 I=1,6
  8570.           TRANS(I) = TR(I)
  8571.    10 CONTINUE
  8572. C
  8573. C Use PGCONX with external function PGCP, which applies the TRANS
  8574. C scaling.
  8575. C
  8576.       CALL PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PGCP)
  8577. C
  8578.       END
  8579. C*PGCONX -- contour map of a 2D data array (non rectangular)
  8580. C+
  8581.       SUBROUTINE PGCONX (A, IDIM, JDIM, I1, I2, J1, J2, C, NC, PLOT)
  8582.       INTEGER  IDIM, JDIM, I1, J1, I2, J2, NC
  8583.       REAL     A(IDIM,JDIM), C(*)
  8584.       EXTERNAL PLOT
  8585. C
  8586. C Draw a contour map of an array using a user-supplied plotting
  8587. C routine.  This routine should be used instead of PGCONT when the
  8588. C data are defined on a non-rectangular grid.  PGCONT permits only
  8589. C a linear transformation between the (I,J) grid of the array
  8590. C and the world coordinate system (x,y), but PGCONX permits any
  8591. C transformation to be used, the transformation being defined by a
  8592. C user-supplied subroutine. The nature of the contouring algorithm,
  8593. C however, dictates that the transformation should maintain the
  8594. C rectangular topology of the grid, although grid-points may be
  8595. C allowed to coalesce.  As an example of a deformed rectangular
  8596. C grid, consider data given on the polar grid theta=0.1n(pi/2),
  8597. C for n=0,1,...,10, and r=0.25m, for m=0,1,..,4. This grid
  8598. C contains 55 points, of which 11 are coincident at the origin.
  8599. C The input array for PGCONX should be dimensioned (11,5), and
  8600. C data values should be provided for all 55 elements.  PGCONX can
  8601. C also be used for special applications in which the height of the
  8602. C contour affects its appearance, e.g., stereoscopic views.
  8603. C
  8604. C The map is truncated if necessary at the boundaries of the viewport.
  8605. C Each contour line is drawn with the current line attributes (color
  8606. C index, style, and width); except that if argument NC is positive
  8607. C (see below), the line style is set by PGCONX to 1 (solid) for
  8608. C positive contours or 2 (dashed) for negative contours. Attributes
  8609. C for the contour lines can also be set in the user-supplied
  8610. C subroutine, if desired.
  8611. C
  8612. C Arguments:
  8613. C  A      (input) : data array.
  8614. C  IDIM   (input) : first dimension of A.
  8615. C  JDIM   (input) : second dimension of A.
  8616. C  I1, I2 (input) : range of first index to be contoured (inclusive).
  8617. C  J1, J2 (input) : range of second index to be contoured (inclusive).
  8618. C  C      (input) : array of NC contour levels; dimension at least NC.
  8619. C  NC     (input) : +/- number of contour levels (less than or equal
  8620. C                   to dimension of C). If NC is positive, it is the
  8621. C                   number of contour levels, and the line-style is
  8622. C                   chosen automatically as described above. If NC is
  8623. C                   negative, it is minus the number of contour
  8624. C                   levels, and the current setting of line-style is
  8625. C                   used for all the contours.
  8626. C  PLOT   (input) : the address (name) of a subroutine supplied by
  8627. C                   the user, which will be called by PGCONX to do
  8628. C                   the actual plotting. This must be declared
  8629. C                   EXTERNAL in the program unit calling PGCONX.
  8630. C
  8631. C The subroutine PLOT will be called with four arguments:
  8632. C      CALL PLOT(VISBLE,X,Y,Z)
  8633. C where X,Y (input) are real variables corresponding to
  8634. C I,J indices of the array A. If  VISBLE (input, integer) is 1,
  8635. C PLOT should draw a visible line from the current pen
  8636. C position to the world coordinate point corresponding to (X,Y);
  8637. C if it is 0, it should move the pen to (X,Y). Z is the value
  8638. C of the current contour level, and may be used by PLOT if desired.
  8639. C Example:
  8640. C       SUBROUTINE PLOT (VISBLE,X,Y,Z)
  8641. C       REAL X, Y, Z, XWORLD, YWORLD
  8642. C       INTEGER VISBLE
  8643. C       XWORLD = X*COS(Y) ! this is the user-defined
  8644. C       YWORLD = X*SIN(Y) ! transformation
  8645. C       IF (VISBLE.EQ.0) THEN
  8646. C           CALL PGMOVE (XWORLD, YWORLD)
  8647. C       ELSE
  8648. C           CALL PGDRAW (XWORLD, YWORLD)
  8649. C       END IF
  8650. C       END
  8651. C--
  8652. C 14-Nov-1985 - new routine [TJP].
  8653. C 12-Sep-1989 - correct documentation error [TJP].
  8654. C 22-Apr-1990 - corrected bug in panelling algorithm [TJP].
  8655. C 13-Dec-1990 - make errors non-fatal [TJP].
  8656. C-----------------------------------------------------------------------
  8657.       INTEGER  MAXEMX,MAXEMY
  8658.       PARAMETER (MAXEMX=100)
  8659.       PARAMETER (MAXEMY=100)
  8660.       INTEGER  I
  8661.       INTEGER  NNX,NNY, KX,KY, KI,KJ, IA,IB, JA,JB, LS, PX, PY
  8662.       LOGICAL  STYLE, PGNOTO
  8663. C
  8664. C Check arguments.
  8665. C
  8666.       IF (PGNOTO('PGCONX')) RETURN
  8667.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  8668.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) THEN
  8669.           CALL GRWARN('PGCONX: invalid range I1:I2, J1:J2')
  8670.           RETURN
  8671.       END IF
  8672.       IF (NC.EQ.0) RETURN
  8673.       STYLE = NC.GT.0
  8674.       CALL PGQLS(LS)
  8675.       CALL PGBBUF
  8676. C
  8677. C Divide arrays into panels not exceeding MAXEMX by MAXEMY for
  8678. C contouring by PGCNSC.
  8679. C
  8680. CD    write (*,*) 'PGCONX window:',i1,i2,j1,j2
  8681.       NNX = I2-I1+1
  8682.       NNY = J2-J1+1
  8683.       KX = MAX(1,(NNX+MAXEMX-2)/(MAXEMX-1))
  8684.       KY = MAX(1,(NNY+MAXEMY-2)/(MAXEMY-1))
  8685.       PX = (NNX+KX-1)/KX
  8686.       PY = (NNY+KY-1)/KY
  8687.       DO 60 KI=1,KX
  8688.           IA = I1 + (KI-1)*PX
  8689.           IB = MIN(I2, IA + PX)
  8690.           DO 50 KJ=1,KY
  8691.               JA = J1 + (KJ-1)*PY
  8692.               JB = MIN(J2, JA + PY)
  8693. C
  8694. C             Draw the contours in one panel.
  8695. C
  8696. CD            write (*,*) 'PGCONX panel:',ia,ib,ja,jb
  8697.               IF (STYLE) CALL PGSLS(1)
  8698.               DO 40 I=1,ABS(NC)
  8699.                   IF (STYLE.AND.(C(I).LT.0.0)) CALL PGSLS(2)
  8700.                   CALL PGCNSC(A,IDIM,JDIM,IA,IB,JA,JB,C(I),PLOT)
  8701.                   IF (STYLE) CALL PGSLS(1)
  8702.    40         CONTINUE
  8703.    50     CONTINUE
  8704.    60 CONTINUE
  8705. C
  8706.       CALL PGSLS(LS)
  8707.       CALL PGEBUF
  8708.       END
  8709. C
  8710.       SUBROUTINE PGCP (K, X, Y, Z)
  8711. C
  8712. C PGPLOT (internal routine): Draw one contour segment (for use by
  8713. C PGCNSC).
  8714. C
  8715. C Arguments:
  8716. C
  8717. C K (input, integer): if K=0, move the pen to (X,Y); if K=1, draw
  8718. C       a line from the current position to (X,Y); otherwise
  8719. C       do nothing.
  8720. C X (input, real): X world-coordinate of end point.
  8721. C Y (input, real): Y world-coordinate of end point.
  8722. C Z (input, real): the value of the contour level, not used by PGCP at
  8723. C       the moment.
  8724. C
  8725. C (7-Feb-1983)
  8726. C-----------------------------------------------------------------------
  8727.       INCLUDE  'f77.PGPLOT/IN'
  8728.       INTEGER  K
  8729.       REAL     X,XX,Y,YY,Z
  8730. C
  8731.       XX = TRANS(1) + TRANS(2)*X + TRANS(3)*Y
  8732.       YY = TRANS(4) + TRANS(5)*X + TRANS(6)*Y
  8733.       IF (K.EQ.1) THEN
  8734.           CALL GRLINA(XX,YY)
  8735.       ELSE IF (K.EQ.0) THEN
  8736.           CALL GRMOVA(XX,YY)
  8737.       END IF
  8738.       END
  8739. C*PGCTAB -- install the color table to be used by PGIMAG
  8740. C%void cpgctab(const float *l, const float *r, const float *g, \
  8741. C% const float *b, int nc, float contra, float bright);
  8742. C+
  8743.       SUBROUTINE PGCTAB(L, R, G, B, NC, CONTRA, BRIGHT)
  8744.       INTEGER NC
  8745.       REAL    L(NC), R(NC), G(NC), B(NC), CONTRA, BRIGHT
  8746. C
  8747. C Use the given color table to change the color representations of
  8748. C all color indexes marked for use by PGIMAG. To change which
  8749. C color indexes are thus marked, call PGSCIR before calling PGCTAB
  8750. C or PGIMAG. On devices that can change the color representations
  8751. C of previously plotted graphics, PGCTAB will also change the colors
  8752. C of existing graphics that were plotted with the marked color
  8753. C indexes. This feature can then be combined with PGBAND to
  8754. C interactively manipulate the displayed colors of data previously
  8755. C plotted with PGIMAG.
  8756. C
  8757. C Limitations:
  8758. C  1. Some devices do not propagate color representation changes
  8759. C     to previously drawn graphics.
  8760. C  2. Some devices ignore requests to change color representations.
  8761. C  3. The appearance of specific color representations on grey-scale
  8762. C     devices is device-dependent.
  8763. C
  8764. C Notes:
  8765. C  To reverse the sense of a color table, change the chosen contrast
  8766. C  and brightness to -CONTRA and 1-BRIGHT.
  8767. C
  8768. C  In the following, the term 'color table' refers to the input
  8769. C  L,R,G,B arrays, whereas 'color ramp' refers to the resulting
  8770. C  ramp of colors that would be seen with PGWEDG.
  8771. C
  8772. C Arguments:
  8773. C  L      (input)  : An array of NC normalized ramp-intensity levels
  8774. C                    corresponding to the RGB primary color intensities
  8775. C                    in R(),G(),B(). Colors on the ramp are linearly
  8776. C                    interpolated from neighbouring levels.
  8777. C                    Levels must be sorted in increasing order.
  8778. C                     0.0 places a color at the beginning of the ramp.
  8779. C                     1.0 places a color at the end of the ramp.
  8780. C                    Colors outside these limits are legal, but will
  8781. C                    not be visible if CONTRA=1.0 and BRIGHT=0.5.
  8782. C  R      (input)  : An array of NC normalized red intensities.
  8783. C  G      (input)  : An array of NC normalized green intensities.
  8784. C  B      (input)  : An array of NC normalized blue intensities.
  8785. C  NC     (input)  : The number of color table entries.
  8786. C  CONTRA (input)  : The contrast of the color ramp (normally 1.0).
  8787. C                    Negative values reverse the direction of the ramp.
  8788. C  BRIGHT (input)  : The brightness of the color ramp. This is normally
  8789. C                    0.5, but can sensibly hold any value between 0.0
  8790. C                    and 1.0. Values at or beyond the latter two
  8791. C                    extremes, saturate the color ramp with the colors
  8792. C                    of the respective end of the color table.
  8793. C--
  8794. C  17-Sep-1994 - New routine [MCS].
  8795. C  14-Apr-1997 - Modified to implement a more conventional
  8796. C                interpretation of contrast and brightness [MCS].
  8797. C-----------------------------------------------------------------------
  8798.       INTEGER MININD, MAXIND, CI
  8799.       INTEGER NTOTAL, NSPAN
  8800.       INTEGER BELOW, ABOVE
  8801.       LOGICAL FORWRD
  8802.       REAL CA, CB, CIFRAC, SPAN
  8803.       REAL LEVEL
  8804.       REAL LDIFF, LFRAC
  8805.       REAL RED, GREEN, BLUE
  8806. C
  8807. C Set the minimum absolute contrast - this prevents a divide by zero.
  8808. C
  8809.       REAL MINCTR
  8810.       PARAMETER (MINCTR = 1.0/256)
  8811. C
  8812. C No colormap entries?
  8813. C
  8814.       IF(NC .EQ. 0) RETURN
  8815. C
  8816. C Determine the range of color indexes to be used.
  8817. C
  8818.       CALL PGQCIR(MININD, MAXIND)
  8819. C
  8820. C Count the total number of color indexes to be processed.
  8821. C
  8822.       NTOTAL = MAXIND - MININD + 1
  8823. C
  8824. C No definable colors?
  8825. C
  8826.       IF(NTOTAL .LT. 1 .OR. MININD .LT. 0) RETURN
  8827. C
  8828. C Prevent a divide by zero later by ensuring that CONTRA >= ABS(MINCTR).
  8829. C
  8830.       IF(ABS(CONTRA) .LT. MINCTR) THEN
  8831.         CONTRA = SIGN(MINCTR, CONTRA)
  8832.       END IF
  8833. C
  8834. C Convert contrast to the normalized stretch of the
  8835. C color table across the available color index range.
  8836. C
  8837.       SPAN = 1.0 / ABS(CONTRA)
  8838. C
  8839. C Translate from brightness and contrast to the normalized color index
  8840. C coordinates, CA and CB, at which to place the start and end of the
  8841. C color table.
  8842. C
  8843.       IF(CONTRA .GE. 0.0) THEN
  8844.         CA = 1.0 - BRIGHT * (1.0 + SPAN)
  8845.         CB = CA + SPAN
  8846.       ELSE
  8847.         CA = BRIGHT * (1.0 + SPAN)
  8848.         CB = CA - SPAN
  8849.       END IF
  8850. C
  8851. C Determine the number of color indexes spanned by the color table.
  8852. C
  8853.       NSPAN = INT(SPAN * NTOTAL)
  8854. C
  8855. C Determine the direction in which the color table should be traversed.
  8856. C
  8857.       FORWRD = CA .LE. CB
  8858. C
  8859. C Initialize the indexes at which to start searching the color table.
  8860. C
  8861. C Set the start index for traversing the table from NC to 1.
  8862. C
  8863.       BELOW = NC
  8864. C
  8865. C Set the start index for traversing the table from 1 to NC.
  8866. C
  8867.       ABOVE = 1
  8868. C
  8869. C Buffer PGPLOT commands until the color map has been completely
  8870. C installed.
  8871. C
  8872.       CALL PGBBUF
  8873. C
  8874. C Linearly interpolate the color table RGB values onto each color index.
  8875. C
  8876.       DO 1 CI=MININD, MAXIND
  8877. C
  8878. C Turn the color index into a fraction of the range MININD..MAXIND.
  8879. C
  8880.         CIFRAC = REAL(CI-MININD) / REAL(MAXIND-MININD)
  8881. C
  8882. C Determine the color table position that corresponds to color index,
  8883. C CI.
  8884. C
  8885.         IF(NSPAN .GT. 0) THEN
  8886.           LEVEL = (CIFRAC-CA) / (CB-CA)
  8887.         ELSE
  8888.           IF(CIFRAC .LE. CA) THEN
  8889.             LEVEL = 0.0
  8890.           ELSE
  8891.             LEVEL = 1.0
  8892.           END IF
  8893.         END IF
  8894. C
  8895. C Search for the indexes of the two color table entries that straddle
  8896. C LEVEL. The search algorithm assumes that values in L() are
  8897. C arranged in increasing order. This allows us to search the color table
  8898. C from the point at which the last search left off, rather than having
  8899. C to search the whole color table each time.
  8900. C
  8901.         IF(FORWRD) THEN
  8902.  2        IF(ABOVE.LE.NC .AND. L(ABOVE).LT.LEVEL) THEN
  8903.             ABOVE = ABOVE + 1
  8904.             GOTO 2
  8905.           END IF
  8906.           BELOW = ABOVE - 1
  8907.         ELSE
  8908.  3        IF(BELOW.GE.1 .AND. L(BELOW).GT.LEVEL) THEN
  8909.             BELOW = BELOW - 1
  8910.             GOTO 3
  8911.           END IF
  8912.           ABOVE = BELOW + 1
  8913.         END IF
  8914. C
  8915. C If the indexes lie outside the table, substitute the index of the
  8916. C nearest edge of the table.
  8917. C
  8918.         IF(BELOW .LT. 1) THEN
  8919.           LEVEL = 0.0
  8920.           BELOW = 1
  8921.           ABOVE = 1
  8922.         ELSE IF(ABOVE .GT. NC) THEN
  8923.           LEVEL = 1.0
  8924.           BELOW = NC
  8925.           ABOVE = NC
  8926.         END IF
  8927. C
  8928. C Linearly interpolate the primary color intensities from color table
  8929. C entries, BELOW and ABOVE.
  8930. C
  8931.         LDIFF = L(ABOVE) - L(BELOW)
  8932.         IF(LDIFF .GT. MINCTR) THEN
  8933.           LFRAC = (LEVEL - L(BELOW)) / LDIFF
  8934.         ELSE
  8935.           LFRAC = 0.0
  8936.         END IF
  8937.         RED   = R(BELOW) + (R(ABOVE) - R(BELOW)) * LFRAC
  8938.         GREEN = G(BELOW) + (G(ABOVE) - G(BELOW)) * LFRAC
  8939.         BLUE  = B(BELOW) + (B(ABOVE) - B(BELOW)) * LFRAC
  8940. C
  8941. C Intensities are only defined between 0 and 1.
  8942. C
  8943.         IF(RED   .LT. 0.0)   RED = 0.0
  8944.         IF(RED   .GT. 1.0)   RED = 1.0
  8945.         IF(GREEN .LT. 0.0) GREEN = 0.0
  8946.         IF(GREEN .GT. 1.0) GREEN = 1.0
  8947.         IF(BLUE  .LT. 0.0)  BLUE = 0.0
  8948.         IF(BLUE  .GT. 1.0)  BLUE = 1.0
  8949. C
  8950. C Install the new color representation.
  8951. C
  8952.         CALL PGSCR(CI, RED, GREEN, BLUE)
  8953.  1    CONTINUE
  8954. C
  8955. C Reveal the changed color map.
  8956. C
  8957.       CALL PGEBUF
  8958.       RETURN
  8959.       END
  8960. C*PGCURS -- read cursor position
  8961. C%int cpgcurs(float *x, float *y, char *ch_scalar);
  8962. C+
  8963.       INTEGER FUNCTION PGCURS (X, Y, CH)
  8964.       REAL X, Y
  8965.       CHARACTER*(*) CH
  8966. C
  8967. C Read the cursor position and a character typed by the user.
  8968. C The position is returned in world coordinates.  PGCURS positions
  8969. C the cursor at the position specified, allows the user to move the
  8970. C cursor using the joystick or arrow keys or whatever is available on
  8971. C the device. When he has positioned the cursor, the user types a
  8972. C single character on the keyboard; PGCURS then returns this
  8973. C character and the new cursor position (in world coordinates).
  8974. C
  8975. C Returns:
  8976. C  PGCURS         : 1 if the call was successful; 0 if the device
  8977. C                    has no cursor or some other error occurs.
  8978. C Arguments:
  8979. C  X      (in/out) : the world x-coordinate of the cursor.
  8980. C  Y      (in/out) : the world y-coordinate of the cursor.
  8981. C  CH     (output) : the character typed by the user; if the device has
  8982. C                    no cursor or if some other error occurs, the value
  8983. C                    CHAR(0) [ASCII NUL character] is returned.
  8984. C
  8985. C Note: The cursor coordinates (X,Y) may be changed by PGCURS even if
  8986. C the device has no cursor or if the user does not move the cursor.
  8987. C Under these circumstances, the position returned in (X,Y) is that of
  8988. C the pixel nearest to the requested position.
  8989. C--
  8990. C  7-Sep-1994 - changed to use PGBAND [TJP].
  8991. C-----------------------------------------------------------------------
  8992.       INTEGER PGBAND
  8993.       LOGICAL PGNOTO
  8994. C
  8995.       IF (PGNOTO('PGCURS')) THEN
  8996.          CH = CHAR(0)
  8997.          PGCURS = 0
  8998.       ELSE
  8999.          PGCURS = PGBAND(0, 1, 0.0, 0.0, X, Y, CH)
  9000.       END IF
  9001.       END
  9002. C*PGCURSE -- non-standard alias for PGCURS
  9003. C+
  9004.       INTEGER FUNCTION PGCURSE (X, Y, CH)
  9005.       REAL X, Y
  9006.       CHARACTER*1 CH
  9007. C
  9008. C See description of PGCURS.
  9009. C--
  9010.       INTEGER PGCURS
  9011.       PGCURSE = PGCURS (X, Y, CH)
  9012.       END
  9013. C*PGDRAW -- draw a line from the current pen position to a point
  9014. C%void cpgdraw(float x, float y);
  9015. C+
  9016.       SUBROUTINE PGDRAW (X, Y)
  9017.       REAL X, Y
  9018. C
  9019. C Draw a line from the current pen position to the point
  9020. C with world-coordinates (X,Y). The line is clipped at the edge of the
  9021. C current window. The new pen position is (X,Y) in world coordinates.
  9022. C
  9023. C Arguments:
  9024. C  X      (input)  : world x-coordinate of the end point of the line.
  9025. C  Y      (input)  : world y-coordinate of the end point of the line.
  9026. C--
  9027. C 27-Nov-1986
  9028. C-----------------------------------------------------------------------
  9029.       CALL PGBBUF
  9030.       CALL GRLINA(X,Y)
  9031.       CALL PGEBUF
  9032.       END
  9033. C*PGEBUF -- end batch of output (buffer)
  9034. C%void cpgebuf(void);
  9035. C+
  9036.       SUBROUTINE PGEBUF
  9037. C
  9038. C A call to PGEBUF marks the end of a batch of graphical output begun
  9039. C with the last call of PGBBUF.  PGBBUF and PGEBUF calls should always
  9040. C be paired. Each call to PGBBUF increments a counter, while each call
  9041. C to PGEBUF decrements the counter. When the counter reaches 0, the
  9042. C batch of output is written on the output device.
  9043. C
  9044. C Arguments: none
  9045. C--
  9046. C 21-Nov-1985 - new routine [TJP].
  9047. C-----------------------------------------------------------------------
  9048.       INCLUDE 'f77.PGPLOT/IN'
  9049.       LOGICAL PGNOTO
  9050. C
  9051.       IF (.NOT.PGNOTO('PGEBUF')) THEN
  9052.           PGBLEV(PGID) = MAX(0, PGBLEV(PGID) - 1)
  9053.           IF (PGBLEV(PGID).EQ.0) CALL GRTERM
  9054.       END IF
  9055.       END
  9056. C*PGEND -- close all open graphics devices
  9057. C%void cpgend(void);
  9058. C+
  9059.       SUBROUTINE PGEND
  9060. C
  9061. C Close and release any open graphics devices. All devices must be
  9062. C closed by calling either PGCLOS (for each device) or PGEND before
  9063. C the program terminates. If a device is not closed properly, some
  9064. C or all of the graphical output may be lost.
  9065. C
  9066. C Arguments: none
  9067. C--
  9068. C 22-Dec-1995 [TJP] - revised to call PGCLOS for each open device.
  9069. C 25-Feb-1997 [TJP] - revised description.
  9070. C-----------------------------------------------------------------------
  9071.       INCLUDE 'f77.PGPLOT/IN'
  9072.       INTEGER I
  9073. C
  9074.       DO 10 I=1,PGMAXD
  9075.          IF (PGDEVS(I).EQ.1) THEN
  9076.             CALL PGSLCT(I)
  9077.             CALL PGCLOS
  9078.          END IF
  9079.  10   CONTINUE
  9080.       END
  9081. C*PGENV -- set window and viewport and draw labeled frame
  9082. C%void cpgenv(float xmin, float xmax, float ymin, float ymax, \
  9083. C% int just, int axis);
  9084. C+
  9085.       SUBROUTINE PGENV (XMIN, XMAX, YMIN, YMAX, JUST, AXIS)
  9086.       REAL XMIN, XMAX, YMIN, YMAX
  9087.       INTEGER JUST, AXIS
  9088. C
  9089. C Set PGPLOT "Plotter Environment".  PGENV establishes the scaling
  9090. C for subsequent calls to PGPT, PGLINE, etc.  The plotter is
  9091. C advanced to a new page or panel, clearing the screen if necessary.
  9092. C If the "prompt state" is ON (see PGASK), confirmation
  9093. C is requested from the user before clearing the screen.
  9094. C If requested, a box, axes, labels, etc. are drawn according to
  9095. C the setting of argument AXIS.
  9096. C
  9097. C Arguments:
  9098. C  XMIN   (input)  : the world x-coordinate at the bottom left corner
  9099. C                    of the viewport.
  9100. C  XMAX   (input)  : the world x-coordinate at the top right corner
  9101. C                    of the viewport (note XMAX may be less than XMIN).
  9102. C  YMIN   (input)  : the world y-coordinate at the bottom left corner
  9103. C                    of the viewport.
  9104. C  YMAX   (input)  : the world y-coordinate at the top right corner
  9105. C                    of the viewport (note YMAX may be less than YMIN).
  9106. C  JUST   (input)  : if JUST=1, the scales of the x and y axes (in
  9107. C                    world coordinates per inch) will be equal,
  9108. C                    otherwise they will be scaled independently.
  9109. C  AXIS   (input)  : controls the plotting of axes, tick marks, etc:
  9110. C      AXIS = -2 : draw no box, axes or labels;
  9111. C      AXIS = -1 : draw box only;
  9112. C      AXIS =  0 : draw box and label it with coordinates;
  9113. C      AXIS =  1 : same as AXIS=0, but also draw the
  9114. C                  coordinate axes (X=0, Y=0);
  9115. C      AXIS =  2 : same as AXIS=1, but also draw grid lines
  9116. C                  at major increments of the coordinates;
  9117. C      AXIS = 10 : draw box and label X-axis logarithmically;
  9118. C      AXIS = 20 : draw box and label Y-axis logarithmically;
  9119. C      AXIS = 30 : draw box and label both axes logarithmically.
  9120. C
  9121. C For other axis options, use routine PGBOX. PGENV can be persuaded to
  9122. C call PGBOX with additional axis options by defining an environment
  9123. C parameter PGPLOT_ENVOPT containing the required option codes. 
  9124. C Examples:
  9125. C   PGPLOT_ENVOPT=P      ! draw Projecting tick marks
  9126. C   PGPLOT_ENVOPT=I      ! Invert the tick marks
  9127. C   PGPLOT_ENVOPT=IV     ! Invert tick marks and label y Vertically
  9128. C--
  9129. C  1-May-1983
  9130. C 25-Sep-1985 [TJP] - change to use PGWNAD.
  9131. C 23-Nov-1985 [TJP] - add PGPLOT_ENVOPT option.
  9132. C 31-Dec-1985 [TJP] - remove automatic PGBEG call.
  9133. C 29-Aug-1989 [TJP] - remove common block; no longer needed.
  9134. C-----------------------------------------------------------------------
  9135.       INTEGER      L
  9136.       LOGICAL      PGNOTO
  9137.       CHARACTER*10 XOPTS, YOPTS, ENVOPT, TEMP
  9138. C
  9139.       IF (PGNOTO('PGENV')) RETURN
  9140. C
  9141. C Start a new picture: move to a new panel or page as necessary.
  9142. C
  9143.       CALL PGPAGE
  9144. C
  9145. C Redefine the standard viewport.
  9146. C
  9147.       CALL PGVSTD
  9148. C
  9149. C If invalid arguments are specified, issue warning and leave window
  9150. C unchanged.
  9151. C
  9152.       IF (XMIN.EQ.XMAX) THEN
  9153.           CALL GRWARN('invalid x limits in PGENV: XMIN = XMAX.')
  9154.           RETURN
  9155.       ELSE IF (YMIN.EQ.YMAX) THEN
  9156.           CALL GRWARN('invalid y limits in PGENV: YMIN = YMAX.')
  9157.           RETURN
  9158.       END IF
  9159. C
  9160. C Call PGSWIN to define the window.
  9161. C If equal-scales requested, adjust viewport.
  9162. C
  9163.       IF (JUST.EQ.1) THEN
  9164.           CALL PGWNAD(XMIN,XMAX,YMIN,YMAX)
  9165.       ELSE
  9166.           CALL PGSWIN(XMIN,XMAX,YMIN,YMAX)
  9167.       END IF
  9168. C
  9169. C Call PGBOX to draw and label frame around viewport.
  9170. C
  9171.       YOPTS = '*'
  9172.       IF (AXIS.EQ.-2) THEN
  9173.           XOPTS = ' '
  9174.       ELSE IF (AXIS.EQ.-1) THEN
  9175.           XOPTS = 'BC'
  9176.       ELSE IF (AXIS.EQ.0) THEN
  9177.           XOPTS = 'BCNST'
  9178.       ELSE IF (AXIS.EQ.1) THEN
  9179.           XOPTS = 'ABCNST'
  9180.       ELSE IF (AXIS.EQ.2) THEN
  9181.           XOPTS = 'ABCGNST'
  9182.       ELSE IF (AXIS.EQ.10) THEN
  9183.           XOPTS = 'BCNSTL'
  9184.           YOPTS = 'BCNST'
  9185.       ELSE IF (AXIS.EQ.20) THEN
  9186.           XOPTS = 'BCNST'
  9187.           YOPTS = 'BCNSTL'
  9188.       ELSE IF (AXIS.EQ.30) THEN
  9189.           XOPTS = 'BCNSTL'
  9190.           YOPTS = 'BCNSTL'
  9191.       ELSE
  9192.           CALL GRWARN('PGENV: illegal AXIS argument.')
  9193.           XOPTS = 'BCNST'
  9194.       END IF
  9195.       IF (YOPTS.EQ.'*') YOPTS = XOPTS
  9196. C
  9197. C Additional PGBOX options from PGPLOT_ENVOPT.
  9198. C
  9199.       CALL GRGENV('ENVOPT', ENVOPT, L)
  9200.       IF (L.GT.0 .AND. AXIS.GE.0) THEN
  9201.           TEMP = XOPTS
  9202.           XOPTS = ENVOPT(1:L)//TEMP
  9203.           TEMP = YOPTS
  9204.           YOPTS = ENVOPT(1:L)//TEMP
  9205.       END IF
  9206.       CALL PGBOX(XOPTS, 0.0, 0, YOPTS, 0.0, 0)
  9207. C
  9208.       END
  9209. C*PGERAS -- erase all graphics from current page
  9210. C%void cpgeras(void);
  9211. C+
  9212.       SUBROUTINE PGERAS
  9213. C
  9214. C Erase all graphics from the current page (or current panel, if
  9215. C the view surface has been divided into panels with PGSUBP).
  9216. C
  9217. C Arguments: none
  9218. C--
  9219. C 24-Jun-1994
  9220. C-----------------------------------------------------------------------
  9221.       INTEGER CI, FS
  9222.       REAL XV1, XV2, YV1, YV2, XW1, XW2, YW1, YW2
  9223.       CALL PGBBUF
  9224.       CALL PGQCI(CI)
  9225.       CALL PGQFS(FS)
  9226.       CALL PGSCI(0)
  9227.       CALL PGSFS(1)
  9228.       CALL PGQWIN(XW1, XW2, YW1, YW2)
  9229.       CALL PGQVP(0, XV1, XV2, YV1, YV2)
  9230.       CALL PGSVP(0.0, 1.0, 0.0, 1.0)
  9231.       CALL PGRECT(XW1, XW2, YW1, YW2)
  9232.       CALL PGSVP(XV1, XV2, YV1, YV2)
  9233.       CALL PGSCI(CI)
  9234.       CALL PGSFS(FS)
  9235.       CALL PGEBUF
  9236.       END
  9237. C*PGERR1 -- horizontal or vertical error bar
  9238. C%void cpgerr1(int dir, float x, float y, float e, float t);
  9239. C+
  9240.       SUBROUTINE PGERR1 (DIR, X, Y, E, T)
  9241.       INTEGER DIR
  9242.       REAL X, Y, E
  9243.       REAL T
  9244. C
  9245. C Plot a single error bar in the direction specified by DIR.
  9246. C This routine draws an error bar only; to mark the data point at
  9247. C the start of the error bar, an additional call to PGPT is required.
  9248. C To plot many error bars, use PGERRB.
  9249. C
  9250. C Arguments:
  9251. C  DIR    (input)  : direction to plot the error bar relative to
  9252. C                    the data point. 
  9253. C                    One-sided error bar:
  9254. C                      DIR is 1 for +X (X to X+E);
  9255. C                             2 for +Y (Y to Y+E);
  9256. C                             3 for -X (X to X-E);
  9257. C                             4 for -Y (Y to Y-E).
  9258. C                    Two-sided error bar:
  9259. C                      DIR is 5 for +/-X (X-E to X+E); 
  9260. C                             6 for +/-Y (Y-E to Y+E).
  9261. C  X      (input)  : world x-coordinate of the data.
  9262. C  Y      (input)  : world y-coordinate of the data.
  9263. C  E      (input)  : value of error bar distance to be added to the
  9264. C                    data position in world coordinates.
  9265. C  T      (input)  : length of terminals to be drawn at the ends
  9266. C                    of the error bar, as a multiple of the default
  9267. C                    length; if T = 0.0, no terminals will be drawn.
  9268. C--
  9269. C 31-Mar-1997 - new routine [TJP].
  9270. C-----------------------------------------------------------------------
  9271.       LOGICAL  PGNOTO
  9272.       REAL     XTIK, YTIK, XX, YY
  9273. C
  9274.       IF (PGNOTO('PGERR1')) RETURN
  9275.       IF (DIR.LT.1 .OR. DIR.GT.6) RETURN
  9276.       CALL PGBBUF
  9277. C
  9278. C Determine terminal length.
  9279. C
  9280.       CALL PGTIKL(T, XTIK, YTIK)
  9281. C
  9282. C Draw terminal at starting point if required.
  9283. C
  9284.       IF (DIR.EQ.5) THEN
  9285.          XX = X-E
  9286.          YY = Y
  9287.       ELSE IF (DIR.EQ.6) THEN
  9288.          XX = X
  9289.          YY = Y-E
  9290.       ELSE
  9291.          XX = X
  9292.          YY = Y
  9293.       END IF
  9294.       IF (T.NE.0.0) THEN
  9295.          IF (DIR.EQ.5) THEN
  9296.             CALL GRMOVA(XX,YY-YTIK)
  9297.             CALL GRLINA(XX,YY+YTIK)
  9298.          ELSE IF (DIR.EQ.6) THEN
  9299.             CALL GRMOVA(XX-XTIK,YY)
  9300.             CALL GRLINA(XX+XTIK,YY)
  9301.          END IF
  9302.       END IF
  9303. C
  9304. C Draw the error bar itself.
  9305. C
  9306.       CALL GRMOVA(XX,YY)
  9307.       IF (DIR.EQ.1 .OR. DIR.EQ.5) THEN
  9308.          XX = X+E
  9309.          YY = Y
  9310.       ELSE IF (DIR.EQ.2 .OR. DIR.EQ.6) THEN
  9311.          XX = X
  9312.          YY = Y+E
  9313.       ELSE IF (DIR.EQ.3) THEN
  9314.          XX = X-E
  9315.          YY = Y
  9316.       ELSE IF (DIR.EQ.4) THEN
  9317.          XX = X
  9318.          YY = Y-E
  9319.       END IF
  9320.       CALL GRLINA(XX,YY)
  9321. C
  9322. C Draw terminal at end point.
  9323. C
  9324.       IF (T.NE.0.0) THEN
  9325.          IF (MOD(DIR,2).EQ.1) THEN
  9326.             CALL GRMOVA(XX,YY-YTIK)
  9327.             CALL GRLINA(XX,YY+YTIK)
  9328.          ELSE
  9329.             CALL GRMOVA(XX-XTIK,YY)
  9330.             CALL GRLINA(XX+XTIK,YY)
  9331.          END IF
  9332.       END IF
  9333. C
  9334.       CALL PGEBUF
  9335.       END
  9336. C*PGERRB -- horizontal or vertical error bar
  9337. C%void cpgerrb(int dir, int n, const float *x, const float *y, \
  9338. C% const float *e, float t);
  9339. C+
  9340.       SUBROUTINE PGERRB (DIR, N, X, Y, E, T)
  9341.       INTEGER DIR, N
  9342.       REAL X(*), Y(*), E(*)
  9343.       REAL T
  9344. C
  9345. C Plot error bars in the direction specified by DIR.
  9346. C This routine draws an error bar only; to mark the data point at
  9347. C the start of the error bar, an additional call to PGPT is required.
  9348. C
  9349. C Arguments:
  9350. C  DIR    (input)  : direction to plot the error bar relative to
  9351. C                    the data point. 
  9352. C                    One-sided error bar:
  9353. C                      DIR is 1 for +X (X to X+E);
  9354. C                             2 for +Y (Y to Y+E);
  9355. C                             3 for -X (X to X-E);
  9356. C                             4 for -Y (Y to Y-E).
  9357. C                    Two-sided error bar:
  9358. C                      DIR is 5 for +/-X (X-E to X+E); 
  9359. C                             6 for +/-Y (Y-E to Y+E).
  9360. C  N      (input)  : number of error bars to plot.
  9361. C  X      (input)  : world x-coordinates of the data.
  9362. C  Y      (input)  : world y-coordinates of the data.
  9363. C  E      (input)  : value of error bar distance to be added to the
  9364. C                    data position in world coordinates.
  9365. C  T      (input)  : length of terminals to be drawn at the ends
  9366. C                    of the error bar, as a multiple of the default
  9367. C                    length; if T = 0.0, no terminals will be drawn.
  9368. C
  9369. C Note: the dimension of arrays X, Y, and E must be greater
  9370. C than or equal to N. If N is 1, X, Y, and E may be scalar
  9371. C variables, or expressions.
  9372. C--
  9373. C  1-Mar-1991 - new routine [JM].
  9374. C 20-Apr-1992 - correct bug [ALF, TJP].
  9375. C 28-Mar-1995 - add options DIR = 5 or 6 [TJP].
  9376. C 31-Mar-1997 - use pgtikl [TJP].
  9377. C-----------------------------------------------------------------------
  9378.       INTEGER  I
  9379.       LOGICAL  PGNOTO
  9380.       REAL     XTIK, YTIK, XX, YY
  9381. C
  9382.       IF (PGNOTO('PGERRB')) RETURN
  9383.       IF (N.LT.1) RETURN
  9384.       IF (DIR.LT.1 .OR. DIR.GT.6) RETURN
  9385.       CALL PGBBUF
  9386. C
  9387. C Determine terminal length.
  9388. C
  9389.       CALL PGTIKL(T, XTIK, YTIK)
  9390. C
  9391. C Loop through points.
  9392. C
  9393.       DO 10 I=1,N
  9394. C
  9395. C Draw terminal at starting point if required.
  9396. C
  9397.          IF (DIR.EQ.5) THEN
  9398.             XX = X(I)-E(I)
  9399.             YY = Y(I)
  9400.          ELSE IF (DIR.EQ.6) THEN
  9401.             XX = X(I)
  9402.             YY = Y(I)-E(I)
  9403.          ELSE
  9404.             XX = X(I)
  9405.             YY = Y(I)
  9406.          END IF
  9407.          IF (T.NE.0.0) THEN
  9408.             IF (DIR.EQ.5) THEN
  9409.                CALL GRMOVA(XX,YY-YTIK)
  9410.                CALL GRLINA(XX,YY+YTIK)
  9411.             ELSE IF (DIR.EQ.6) THEN
  9412.                CALL GRMOVA(XX-XTIK,YY)
  9413.                CALL GRLINA(XX+XTIK,YY)
  9414.             END IF
  9415.          END IF
  9416. C
  9417. C Draw the error bar itself.
  9418. C
  9419.          CALL GRMOVA(XX,YY)
  9420.          IF (DIR.EQ.1 .OR. DIR.EQ.5) THEN
  9421.             XX = X(I)+E(I)
  9422.             YY = Y(I)
  9423.          ELSE IF (DIR.EQ.2 .OR. DIR.EQ.6) THEN
  9424.             XX = X(I)
  9425.             YY = Y(I)+E(I)
  9426.          ELSE IF (DIR.EQ.3) THEN
  9427.             XX = X(I)-E(I)
  9428.             YY = Y(I)
  9429.          ELSE IF (DIR.EQ.4) THEN
  9430.             XX = X(I)
  9431.             YY = Y(I)-E(I)
  9432.          END IF
  9433.          CALL GRLINA(XX,YY)
  9434. C
  9435. C Draw terminal at end point.
  9436. C
  9437.          IF (T.NE.0.0) THEN
  9438.             IF (MOD(DIR,2).EQ.1) THEN
  9439.                CALL GRMOVA(XX,YY-YTIK)
  9440.                CALL GRLINA(XX,YY+YTIK)
  9441.             ELSE
  9442.                CALL GRMOVA(XX-XTIK,YY)
  9443.                CALL GRLINA(XX+XTIK,YY)
  9444.             END IF
  9445.          END IF
  9446. C
  9447.  10   CONTINUE
  9448.       CALL PGEBUF
  9449.       END
  9450. C*PGERRX -- horizontal error bar
  9451. C%void cpgerrx(int n, const float *x1, const float *x2, \
  9452. C% const float *y, float t);
  9453. C+
  9454.       SUBROUTINE PGERRX (N, X1, X2, Y, T)
  9455.       INTEGER N
  9456.       REAL X1(*), X2(*), Y(*)
  9457.       REAL T
  9458. C
  9459. C Plot horizontal error bars.
  9460. C This routine draws an error bar only; to mark the data point in
  9461. C the middle of the error bar, an additional call to PGPT or
  9462. C PGERRY is required.
  9463. C
  9464. C Arguments:
  9465. C  N      (input)  : number of error bars to plot.
  9466. C  X1     (input)  : world x-coordinates of lower end of the
  9467. C                    error bars.
  9468. C  X2     (input)  : world x-coordinates of upper end of the
  9469. C                    error bars.
  9470. C  Y      (input)  : world y-coordinates of the data.
  9471. C  T      (input)  : length of terminals to be drawn at the ends
  9472. C                    of the error bar, as a multiple of the default
  9473. C                    length; if T = 0.0, no terminals will be drawn.
  9474. C
  9475. C Note: the dimension of arrays X1, X2, and Y must be greater
  9476. C than or equal to N. If N is 1, X1, X2, and Y may be scalar
  9477. C variables, or expressions, eg:
  9478. C       CALL PGERRX(1,X-SIGMA,X+SIGMA,Y)
  9479. C--
  9480. C (6-Oct-1983)
  9481. C 31-Mar-1997 - use pgtikl [TJP[.
  9482. C-----------------------------------------------------------------------
  9483.       INTEGER  I
  9484.       LOGICAL  PGNOTO
  9485.       REAL     XTIK, YTIK
  9486. C
  9487.       IF (PGNOTO('PGERRX')) RETURN
  9488.       IF (N.LT.1) RETURN
  9489.       CALL PGBBUF
  9490. C
  9491.       CALL PGTIKL(T, XTIK, YTIK)
  9492.       DO 10 I=1,N
  9493.           IF (T.NE.0.0) THEN
  9494.               CALL GRMOVA(X1(I),Y(I)-YTIK)
  9495.               CALL GRLINA(X1(I),Y(I)+YTIK)
  9496.           END IF
  9497.           CALL GRMOVA(X1(I),Y(I))
  9498.           CALL GRLINA(X2(I),Y(I))
  9499.           IF (T.NE.0.0) THEN
  9500.               CALL GRMOVA(X2(I),Y(I)-YTIK)
  9501.               CALL GRLINA(X2(I),Y(I)+YTIK)
  9502.           END IF
  9503.    10 CONTINUE
  9504.       CALL PGEBUF
  9505.       END
  9506. C*PGERRY -- vertical error bar
  9507. C%void cpgerry(int n, const float *x, const float *y1, \
  9508. C% const float *y2, float t);
  9509. C+
  9510.       SUBROUTINE PGERRY (N, X, Y1, Y2, T)
  9511.       INTEGER N
  9512.       REAL X(*), Y1(*), Y2(*)
  9513.       REAL T
  9514. C
  9515. C Plot vertical error bars.
  9516. C This routine draws an error bar only; to mark the data point in
  9517. C the middle of the error bar, an additional call to PGPT or
  9518. C PGERRX is required.
  9519. C
  9520. C Arguments:
  9521. C  N      (input)  : number of error bars to plot.
  9522. C  X      (input)  : world x-coordinates of the data.
  9523. C  Y1     (input)  : world y-coordinates of top end of the
  9524. C                    error bars.
  9525. C  Y2     (input)  : world y-coordinates of bottom end of the
  9526. C                    error bars.
  9527. C  T      (input)  : length of terminals to be drawn at the ends
  9528. C                    of the error bar, as a multiple of the default
  9529. C                    length; if T = 0.0, no terminals will be drawn.
  9530. C
  9531. C Note: the dimension of arrays X, Y1, and Y2 must be greater
  9532. C than or equal to N. If N is 1, X, Y1, and Y2 may be scalar
  9533. C variables or expressions, eg:
  9534. C       CALL PGERRY(1,X,Y+SIGMA,Y-SIGMA)
  9535. C--
  9536. C (6-Oct-1983)
  9537. C 31-Mar-1997 - use pgtikl [TJP].
  9538. C-----------------------------------------------------------------------
  9539.       INTEGER  I
  9540.       LOGICAL  PGNOTO
  9541.       REAL     XTIK, YTIK
  9542. C
  9543.       IF (PGNOTO('PGERRY')) RETURN
  9544.       IF (N.LT.1) RETURN
  9545.       CALL PGBBUF
  9546. C
  9547.       CALL PGTIKL(T, XTIK, YTIK)
  9548.       DO 10 I=1,N
  9549.           IF (T.NE.0.0) THEN
  9550.               CALL GRMOVA(X(I)-XTIK,Y1(I))
  9551.               CALL GRLINA(X(I)+XTIK,Y1(I))
  9552.           END IF
  9553.           CALL GRMOVA(X(I),Y1(I))
  9554.           CALL GRLINA(X(I),Y2(I))
  9555.           IF (T.NE.0.0) THEN
  9556.               CALL GRMOVA(X(I)-XTIK,Y2(I))
  9557.               CALL GRLINA(X(I)+XTIK,Y2(I))
  9558.           END IF
  9559.    10 CONTINUE
  9560.       CALL PGEBUF
  9561.       END
  9562. C*PGETXT -- erase text from graphics display
  9563. C%void cpgetxt(void);
  9564. C+
  9565.       SUBROUTINE PGETXT
  9566. C
  9567. C Some graphics terminals display text (the normal interactive dialog)
  9568. C on the same screen as graphics. This routine erases the text from the
  9569. C view surface without affecting the graphics. It does nothing on
  9570. C devices which do not display text on the graphics screen, and on
  9571. C devices which do not have this capability.
  9572. C
  9573. C Arguments:
  9574. C  None
  9575. C--
  9576. C 18-Feb-1988
  9577. C-----------------------------------------------------------------------
  9578.       CALL GRETXT
  9579.       END
  9580. C*PGFUNT -- function defined by X = F(T), Y = G(T)
  9581. C+
  9582.       SUBROUTINE PGFUNT (FX, FY, N, TMIN, TMAX, PGFLAG)
  9583.       REAL FX, FY
  9584.       EXTERNAL FX, FY
  9585.       INTEGER N
  9586.       REAL TMIN, TMAX
  9587.       INTEGER PGFLAG
  9588. C
  9589. C Draw a curve defined by parametric equations X = FX(T), Y = FY(T).
  9590. C
  9591. C Arguments:
  9592. C  FX     (external real function): supplied by the user, evaluates
  9593. C                    X-coordinate.
  9594. C  FY     (external real function): supplied by the user, evaluates
  9595. C                    Y-coordinate.
  9596. C  N      (input)  : the number of points required to define the
  9597. C                    curve. The functions FX and FY will each be
  9598. C                    called N+1 times.
  9599. C  TMIN   (input)  : the minimum value for the parameter T.
  9600. C  TMAX   (input)  : the maximum value for the parameter T.
  9601. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  9602. C                    current window and viewport; if PGFLAG = 0,
  9603. C                    PGENV is called automatically by PGFUNT to
  9604. C                    start a new plot with automatic scaling.
  9605. C
  9606. C Note: The functions FX and FY must be declared EXTERNAL in the
  9607. C Fortran program unit that calls PGFUNT.
  9608. C--
  9609. C  5-Oct-1983
  9610. C 11-May-1990 - remove unnecessary include [TJP].
  9611. C 13-Dec-1990 - make errors non-fatal [TJP].
  9612. C-----------------------------------------------------------------------
  9613.       INTEGER MAXP
  9614.       PARAMETER (MAXP=1000)
  9615.       INTEGER  I
  9616.       REAL     X(0:MAXP), Y(0:MAXP), DT
  9617.       REAL     XMIN, XMAX, YMIN, YMAX
  9618. C
  9619.       IF (N.LT.1 .OR. N.GT.MAXP) THEN
  9620.           CALL GRWARN('PGFUNT: invalid arguments')
  9621.           RETURN
  9622.       END IF
  9623.       CALL PGBBUF
  9624. C
  9625. C Evaluate function.
  9626. C
  9627.       DT = (TMAX-TMIN)/N
  9628.       X(0) = FX(TMIN)
  9629.       Y(0) = FY(TMIN)
  9630.       XMIN = X(0)
  9631.       XMAX = X(0)
  9632.       YMIN = Y(0)
  9633.       YMAX = Y(0)
  9634.       DO 10 I=1,N
  9635.           X(I) = FX(TMIN+DT*I)
  9636.           Y(I) = FY(TMIN+DT*I)
  9637.           XMIN = MIN(XMIN,X(I))
  9638.           XMAX = MAX(XMAX,X(I))
  9639.           YMIN = MIN(YMIN,Y(I))
  9640.           YMAX = MAX(YMAX,Y(I))
  9641.    10 CONTINUE
  9642.       DT = 0.05*(XMAX-XMIN)
  9643.       IF (DT.EQ.0.0) THEN
  9644.           XMIN = XMIN - 1.0
  9645.           XMAX = XMAX + 1.0
  9646.       ELSE
  9647.           XMIN = XMIN - DT
  9648.           XMAX = XMAX + DT
  9649.       END IF
  9650.       DT = 0.05*(YMAX-YMIN)
  9651.       IF (DT.EQ.0.0) THEN
  9652.           YMIN = YMIN - 1.0
  9653.           YMAX = YMAX + 1.0
  9654.       ELSE
  9655.           YMIN = YMIN - DT
  9656.           YMAX = YMAX + DT
  9657.       END IF
  9658. C
  9659. C Define environment if necessary.
  9660. C
  9661.       IF (PGFLAG.EQ.0) CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  9662. C
  9663. C Draw curve.
  9664. C
  9665.       CALL PGMOVE(X(0),Y(0))
  9666.       DO 20 I=1,N
  9667.           CALL PGDRAW(X(I),Y(I))
  9668.    20 CONTINUE
  9669. C
  9670.       CALL PGEBUF
  9671.       END
  9672. C*PGFUNX -- function defined by Y = F(X)
  9673. C+
  9674.       SUBROUTINE PGFUNX (FY, N, XMIN, XMAX, PGFLAG)
  9675.       REAL FY
  9676.       EXTERNAL FY
  9677.       INTEGER N
  9678.       REAL XMIN, XMAX
  9679.       INTEGER PGFLAG
  9680. C
  9681. C Draw a curve defined by the equation Y = FY(X), where FY is a
  9682. C user-supplied subroutine.
  9683. C
  9684. C Arguments:
  9685. C  FY     (external real function): supplied by the user, evaluates
  9686. C                    Y value at a given X-coordinate.
  9687. C  N      (input)  : the number of points required to define the
  9688. C                    curve. The function FY will be called N+1 times.
  9689. C                    If PGFLAG=0 and N is greater than 1000, 1000
  9690. C                    will be used instead.  If N is less than 1,
  9691. C                    nothing will be drawn.
  9692. C  XMIN   (input)  : the minimum value of X.
  9693. C  XMAX   (input)  : the maximum value of X.
  9694. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  9695. C                    current window and viewport; if PGFLAG = 0,
  9696. C                    PGENV is called automatically by PGFUNX to
  9697. C                    start a new plot with X limits (XMIN, XMAX)
  9698. C                    and automatic scaling in Y.
  9699. C
  9700. C Note: The function FY must be declared EXTERNAL in the Fortran
  9701. C program unit that calls PGFUNX.  It has one argument, the
  9702. C x-coordinate at which the y value is required, e.g.
  9703. C   REAL FUNCTION FY(X)
  9704. C   REAL X
  9705. C   FY = .....
  9706. C   END
  9707. C--
  9708. C  6-Oct-1983 - TJP.
  9709. C  6-May-1985 - fix Y(0) bug - TJP.
  9710. C 11-May-1990 - remove unnecessary include - TJP.
  9711. C-----------------------------------------------------------------------
  9712.       INTEGER MAXP
  9713.       PARAMETER (MAXP=1000)
  9714.       INTEGER  I, NN
  9715.       REAL     Y(0:MAXP), DT, DY
  9716.       REAL     YMIN, YMAX
  9717. C
  9718. C Check N > 1, and find parameter increment.
  9719. C
  9720.       IF (N.LT.1) RETURN
  9721.       DT = (XMAX-XMIN)/N
  9722.       CALL PGBBUF
  9723. C
  9724. C Case 1: we do not have to find limits.
  9725. C
  9726.       IF (PGFLAG.NE.0) THEN
  9727.           CALL PGMOVE(XMIN,FY(XMIN))
  9728.           DO 10 I=1,N
  9729.               CALL PGDRAW(XMIN+I*DT,FY(XMIN+I*DT))
  9730.    10     CONTINUE
  9731. C
  9732. C Case 2: find limits and scale plot; function values must be stored
  9733. C in an array.
  9734. C
  9735.       ELSE
  9736.           NN = MIN(N,MAXP)
  9737.           Y(0) = FY(XMIN)
  9738.           YMIN = Y(0)
  9739.           YMAX = Y(0)
  9740.           DO 20 I=1,NN
  9741.               Y(I) = FY(XMIN+DT*I)
  9742.               YMIN = MIN(YMIN,Y(I))
  9743.               YMAX = MAX(YMAX,Y(I))
  9744.    20     CONTINUE
  9745.           DY = 0.05*(YMAX-YMIN)
  9746.           IF (DY.EQ.0.0) THEN
  9747.               YMIN = YMIN - 1.0
  9748.               YMAX = YMAX + 1.0
  9749.           ELSE
  9750.               YMIN = YMIN - DY
  9751.               YMAX = YMAX + DY
  9752.           END IF
  9753.           CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  9754.           CALL PGMOVE(XMIN,Y(0))
  9755.           DO 30 I=1,NN
  9756.               CALL PGDRAW(XMIN+DT*I,Y(I))
  9757.    30     CONTINUE
  9758.       END IF
  9759. C
  9760.       CALL PGEBUF
  9761.       END
  9762. C*PGFUNY -- function defined by X = F(Y)
  9763. C+
  9764.       SUBROUTINE PGFUNY (FX, N, YMIN, YMAX, PGFLAG)
  9765.       REAL    FX
  9766.       EXTERNAL FX
  9767.       INTEGER N
  9768.       REAL    YMIN, YMAX
  9769.       INTEGER PGFLAG
  9770. C
  9771. C Draw a curve defined by the equation X = FX(Y), where FY is a
  9772. C user-supplied subroutine.
  9773. C
  9774. C Arguments:
  9775. C  FX     (external real function): supplied by the user, evaluates
  9776. C                    X value at a given Y-coordinate.
  9777. C  N      (input)  : the number of points required to define the
  9778. C                    curve. The function FX will be called N+1 times.
  9779. C                    If PGFLAG=0 and N is greater than 1000, 1000
  9780. C                    will be used instead.  If N is less than 1,
  9781. C                    nothing will be drawn.
  9782. C  YMIN   (input)  : the minimum value of Y.
  9783. C  YMAX   (input)  : the maximum value of Y.
  9784. C  PGFLAG (input)  : if PGFLAG = 1, the curve is plotted in the
  9785. C                    current window and viewport; if PGFLAG = 0,
  9786. C                    PGENV is called automatically by PGFUNY to
  9787. C                    start a new plot with Y limits (YMIN, YMAX)
  9788. C                    and automatic scaling in X.
  9789. C
  9790. C Note: The function FX must be declared EXTERNAL in the Fortran
  9791. C program unit that calls PGFUNY.  It has one argument, the
  9792. C y-coordinate at which the x value is required, e.g.
  9793. C   REAL FUNCTION FX(Y)
  9794. C   REAL Y
  9795. C   FX = .....
  9796. C   END
  9797. C--
  9798. C  5-Oct-1983
  9799. C 11-May-1990 - remove unnecessary include [TJP].
  9800. C 13-DEc-1990 - make errors non-fatal [TJP].
  9801. C-----------------------------------------------------------------------
  9802.       INTEGER MAXP
  9803.       PARAMETER (MAXP=1000)
  9804.       INTEGER  I
  9805.       REAL     X(0:MAXP), Y(0:MAXP), DT
  9806.       REAL     XMIN, XMAX
  9807. C
  9808.       IF (N.LT.1 .OR. N.GT.MAXP) THEN
  9809.           CALL GRWARN('PGFUNY: invalid arguments')
  9810.           RETURN
  9811.       END IF
  9812.       CALL PGBBUF
  9813. C
  9814. C Evaluate function.
  9815. C
  9816.       DT = (YMAX-YMIN)/N
  9817.       X(0) = FX(YMIN)
  9818.       Y(0) = YMIN
  9819.       XMIN = X(0)
  9820.       XMAX = X(0)
  9821.       DO 10 I=1,N
  9822.           X(I) = FX(YMIN+DT*I)
  9823.           Y(I) = YMIN + DT*I
  9824.           XMIN = MIN(XMIN,X(I))
  9825.           XMAX = MAX(XMAX,X(I))
  9826.    10 CONTINUE
  9827.       DT = 0.05*(XMAX-XMIN)
  9828.       IF (DT.EQ.0.0) THEN
  9829.           XMIN = XMIN - 1.0
  9830.           XMAX = XMAX + 1.0
  9831.       ELSE
  9832.           XMIN = XMIN - DT
  9833.           XMAX = XMAX + DT
  9834.       END IF
  9835. C
  9836. C Define environment if necessary.
  9837. C
  9838.       IF (PGFLAG.EQ.0) CALL PGENV(XMIN,XMAX,YMIN,YMAX,0,0)
  9839. C
  9840. C Draw curve.
  9841. C
  9842.       CALL PGMOVE(X(0),Y(0))
  9843.       DO 20 I=1,N
  9844.           CALL PGDRAW(X(I),Y(I))
  9845.    20 CONTINUE
  9846. C
  9847.       CALL PGEBUF
  9848.       END
  9849. C*PGGRAY -- gray-scale map of a 2D data array
  9850. C%void cpggray(const float *a, int idim, int jdim, int i1, int i2, \
  9851. C% int j1, int j2, float fg, float bg, const float *tr);
  9852. C+
  9853.       SUBROUTINE PGGRAY (A, IDIM, JDIM, I1, I2, J1, J2,
  9854.      1                   FG, BG, TR)
  9855.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  9856.       REAL    A(IDIM,JDIM), FG, BG, TR(6)
  9857. C
  9858. C Draw gray-scale map of an array in current window. The subsection
  9859. C of the array A defined by indices (I1:I2, J1:J2) is mapped onto
  9860. C the view surface world-coordinate system by the transformation
  9861. C matrix TR. The resulting quadrilateral region is clipped at the edge
  9862. C of the window and shaded with the shade at each point determined
  9863. C by the corresponding array value.  The shade is a number in the
  9864. C range 0 to 1 obtained by linear interpolation between the background
  9865. C level (BG) and the foreground level (FG), i.e.,
  9866. C
  9867. C   shade = [A(i,j) - BG] / [FG - BG]
  9868. C
  9869. C The background level BG can be either less than or greater than the
  9870. C foreground level FG.  Points in the array that are outside the range
  9871. C BG to FG are assigned shade 0 or 1 as appropriate.
  9872. C
  9873. C PGGRAY uses two different algorithms, depending how many color
  9874. C indices are available in the color index range specified for images.
  9875. C (This range is set with routine PGSCIR, and the current or default
  9876. C range can be queried by calling routine PGQCIR).
  9877. C
  9878. C If 16 or more color indices are available, PGGRAY first assigns
  9879. C color representations to these color indices to give a linear ramp
  9880. C between the background color (color index 0) and the foreground color
  9881. C (color index 1), and then calls PGIMAG to draw the image using these
  9882. C color indices. In this mode, the shaded region is "opaque": every
  9883. C pixel is assigned a color.
  9884. C
  9885. C If less than 16 color indices are available, PGGRAY uses only
  9886. C color index 1, and uses  a "dithering" algorithm to fill in pixels,
  9887. C with the shade (computed as above) determining the faction of pixels
  9888. C that are filled. In this mode the shaded region is "transparent" and
  9889. C allows previously-drawn graphics to show through.
  9890. C
  9891. C The transformation matrix TR is used to calculate the world
  9892. C coordinates of the center of the "cell" that represents each
  9893. C array element. The world coordinates of the center of the cell
  9894. C corresponding to array element A(I,J) are given by:
  9895. C
  9896. C          X = TR(1) + TR(2)*I + TR(3)*J
  9897. C          Y = TR(4) + TR(5)*I + TR(6)*J
  9898. C
  9899. C Usually TR(3) and TR(5) are zero -- unless the coordinate
  9900. C transformation involves a rotation or shear.  The corners of the
  9901. C quadrilateral region that is shaded by PGGRAY are given by
  9902. C applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5).
  9903. C
  9904. C Arguments:
  9905. C  A      (input)  : the array to be plotted.
  9906. C  IDIM   (input)  : the first dimension of array A.
  9907. C  JDIM   (input)  : the second dimension of array A.
  9908. C  I1, I2 (input)  : the inclusive range of the first index
  9909. C                    (I) to be plotted.
  9910. C  J1, J2 (input)  : the inclusive range of the second
  9911. C                    index (J) to be plotted.
  9912. C  FG     (input)  : the array value which is to appear with the
  9913. C                    foreground color (corresponding to color index 1).
  9914. C  BG     (input)  : the array value which is to appear with the
  9915. C                    background color (corresponding to color index 0).
  9916. C  TR     (input)  : transformation matrix between array grid and
  9917. C                    world coordinates.
  9918. C--
  9919. C  2-Sep-1987: remove device-dependent code to routine GRGRAY (TJP).
  9920. C  7-Jun-1988: change documentation and argument names (TJP).
  9921. C 31-May-1989: allow 1-pixel wide arrays to be plotted (TJP).
  9922. C 17-Mar-1994: pass PG scaling info to lower routines (TJP).
  9923. C 15-Sep-1994: use PGITF attribute (TJP).
  9924. C  8-Feb-1995: use color ramp based on current foreground and background
  9925. C              colors (TJP).
  9926. C  6-May-1996: allow multiple devives (TJP).
  9927. C-----------------------------------------------------------------------
  9928.       INCLUDE  'f77.PGPLOT/IN'
  9929.       REAL PA(6)
  9930.       LOGICAL PGNOTO
  9931. C
  9932. C Check inputs.
  9933. C
  9934.       IF (PGNOTO('PGGRAY')) RETURN
  9935.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  9936.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  9937.           CALL GRWARN('PGGRAY: invalid range I1:I2, J1:J2')
  9938.       ELSE IF (FG.EQ.BG) THEN
  9939.           CALL GRWARN('PGGRAY: foreground level = background level')
  9940.       ELSE
  9941. C
  9942. C Call lower-level routine to do the work.
  9943. C
  9944.           CALL PGBBUF
  9945.           CALL PGSAVE
  9946.           CALL PGSCI(1)
  9947.           PA(1) = TR(1)*PGXSCL(PGID) + PGXORG(PGID)
  9948.           PA(2) = TR(2)*PGXSCL(PGID)
  9949.           PA(3) = TR(3)*PGXSCL(PGID)
  9950.           PA(4) = TR(4)*PGYSCL(PGID) + PGYORG(PGID)
  9951.           PA(5) = TR(5)*PGYSCL(PGID)
  9952.           PA(6) = TR(6)*PGYSCL(PGID)
  9953.           CALL GRGRAY(A, IDIM, JDIM, I1, I2, J1, J2, FG, BG, PA,
  9954.      :                PGMNCI(PGID), PGMXCI(PGID), PGITF(PGID))
  9955.           CALL PGEBUF
  9956.           CALL PGUNSA
  9957.       END IF
  9958. C-----------------------------------------------------------------------
  9959.       END
  9960.  
  9961. C*PGHI2D -- cross-sections through a 2D data array
  9962. C%void cpghi2d(const float *data, int nxv, int nyv, int ix1, \
  9963. C% int ix2, int iy1, int iy2, const float *x, int ioff, float bias, \
  9964. C% Logical center, float *ylims);
  9965. C+
  9966.       SUBROUTINE PGHI2D (DATA, NXV, NYV, IX1, IX2, IY1, IY2, X, IOFF,
  9967.      1                   BIAS, CENTER, YLIMS)
  9968.       INTEGER NXV, NYV, IX1, IX2, IY1, IY2
  9969.       REAL    DATA(NXV,NYV)
  9970.       REAL    X(IX2-IX1+1), YLIMS(IX2-IX1+1)
  9971.       INTEGER IOFF
  9972.       REAL    BIAS
  9973.       LOGICAL CENTER
  9974. C
  9975. C Plot a series of cross-sections through a 2D data array.
  9976. C Each cross-section is plotted as a hidden line histogram.  The plot
  9977. C can be slanted to give a pseudo-3D effect - if this is done, the
  9978. C call to PGENV may have to be changed to allow for the increased X
  9979. C range that will be needed.
  9980. C
  9981. C Arguments:
  9982. C  DATA   (input)  : the data array to be plotted.
  9983. C  NXV    (input)  : the first dimension of DATA.
  9984. C  NYV    (input)  : the second dimension of DATA.
  9985. C  IX1    (input)
  9986. C  IX2    (input)
  9987. C  IY1    (input)
  9988. C  IY2    (input)  : PGHI2D plots a subset of the input array DATA.
  9989. C                    This subset is delimited in the first (x)
  9990. C                    dimension by IX1 and IX2 and the 2nd (y) by IY1
  9991. C                    and IY2, inclusively. Note: IY2 < IY1 is
  9992. C                    permitted, resulting in a plot with the
  9993. C                    cross-sections plotted in reverse Y order.
  9994. C                    However, IX2 must be => IX1.
  9995. C  X      (input)  : the abscissae of the bins to be plotted. That is,
  9996. C                    X(1) should be the X value for DATA(IX1,IY1), and
  9997. C                    X should have (IX2-IX1+1) elements.  The program
  9998. C                    has to assume that the X value for DATA(x,y) is
  9999. C                    the same for all y.
  10000. C  IOFF   (input)  : an offset in array elements applied to successive
  10001. C                    cross-sections to produce a slanted effect.  A
  10002. C                    plot with IOFF > 0 slants to the right, one with
  10003. C                    IOFF < 0 slants left.
  10004. C  BIAS   (input)  : a bias value applied to each successive cross-
  10005. C                    section in order to raise it above the previous
  10006. C                    cross-section.  This is in the same units as the
  10007. C                    data.
  10008. C  CENTER (input)  : if .true., the X values denote the center of the
  10009. C                    bins; if .false. the X values denote the lower
  10010. C                    edges (in X) of the bins.
  10011. C  YLIMS  (input)  : workspace.  Should be an array of at least
  10012. C                    (IX2-IX1+1) elements.
  10013. C--
  10014. C 21-Feb-1984 - Keith Shortridge.
  10015. C-----------------------------------------------------------------------
  10016.       INCLUDE 'f77.PGPLOT/IN'
  10017.       LOGICAL FIRST,PENDOW,HPLOT,VPLOT
  10018.       INTEGER IY,INC,IX,NELMX,IXPT,NOFF
  10019.       REAL CBIAS,YNWAS,XNWAS,YN,XN,VTO,VFROM,YLIMWS,YLIM
  10020.       REAL PGHIS1
  10021.       LOGICAL PGNOTO
  10022. C
  10023. C Check arguments.
  10024. C
  10025.       IF (IX1.GT.IX2) RETURN
  10026.       IF (PGNOTO('PGHI2D')) RETURN
  10027.       CALL PGBBUF
  10028. C
  10029. C Check Y order.
  10030. C
  10031.       IF (IY1.GT.IY2) THEN
  10032.          INC = -1
  10033.       ELSE
  10034.          INC = 1
  10035.       END IF
  10036. C
  10037. C Clear limits array.
  10038. C
  10039.       NELMX = IX2 - IX1 + 1
  10040.       DO 10 IX=1,NELMX
  10041.          YLIMS(IX) = PGYBLC(PGID)
  10042.  10   CONTINUE
  10043. C
  10044. C Loop through Y values.
  10045. C
  10046.       NOFF = 0
  10047.       CBIAS = 0.
  10048.       DO 200 IY=IY1,IY2,INC
  10049.          YNWAS = CBIAS
  10050.          YLIMWS = YNWAS
  10051.          XNWAS = PGHIS1(X,NELMX,CENTER,1+NOFF)
  10052.          PENDOW = .FALSE.
  10053.          FIRST = .TRUE.
  10054.          IXPT = 1
  10055. C
  10056. C Draw histogram for this Y value.
  10057. C
  10058.          DO 100 IX=IX1,IX2
  10059.             YN = DATA(IX,IY) + CBIAS
  10060.             XN = PGHIS1(X,NELMX,CENTER,IXPT+NOFF+1)
  10061.             YLIM = YLIMS(IXPT)
  10062. C
  10063. C Given X and Y old and new values, and limits, see which parts of the
  10064. C lines are to be drawn.
  10065. C
  10066.             IF (YN.GT.YLIM) THEN
  10067.                YLIMS(IXPT) = YN
  10068.                HPLOT = .TRUE.
  10069.                VPLOT = .TRUE.
  10070.                VTO = YN
  10071.                VFROM = YLIM
  10072.                IF (YNWAS.GT.YLIMWS) VFROM = YNWAS
  10073.             ELSE
  10074.                HPLOT = .FALSE.
  10075.                IF (YNWAS.GT.YLIMWS) THEN
  10076.                   VPLOT = .TRUE.
  10077.                   VFROM = YNWAS
  10078.                   VTO = YLIM
  10079.                ELSE
  10080.                   VPLOT = .FALSE.
  10081.                END IF
  10082.             END IF
  10083. C
  10084. C Plot the bin.
  10085. C
  10086.             IF (VPLOT) THEN
  10087.                IF (.NOT.PENDOW) THEN
  10088.                   IF (FIRST) THEN
  10089.                      CALL GRMOVA(XNWAS,MAX(VTO,CBIAS))
  10090.                      FIRST = .FALSE.
  10091.                   ELSE
  10092.                      CALL GRMOVA(XNWAS,VFROM)
  10093.                   END IF
  10094.                END IF
  10095.                CALL GRLINA(XNWAS,VTO)
  10096.                IF (HPLOT) THEN
  10097.                   CALL GRLINA(XN,YN)
  10098.                END IF
  10099.             END IF
  10100.             PENDOW = HPLOT
  10101.             YLIMWS = YLIM
  10102.             YNWAS = YN
  10103.             XNWAS = XN
  10104.             IXPT = IXPT + 1
  10105.  100     CONTINUE
  10106.          IF (PENDOW) CALL GRLINA(XN,MAX(YLIM,CBIAS))
  10107. C
  10108. C If any offset in operation, shift limits array to compensate for it.
  10109. C
  10110.          IF (IOFF.GT.0) THEN
  10111.             DO 110 IX=1,NELMX-IOFF
  10112.                YLIMS(IX) = YLIMS(IX+IOFF)
  10113.  110        CONTINUE
  10114.             DO 120 IX=NELMX-IOFF+1,NELMX
  10115.                YLIMS(IX) = PGYBLC(PGID)
  10116.  120        CONTINUE
  10117.          ELSE IF (IOFF.LT.0) THEN
  10118.             DO 130 IX=NELMX,1-IOFF,-1
  10119.                YLIMS(IX) = YLIMS(IX+IOFF)
  10120.  130        CONTINUE
  10121.             DO 140 IX=1,-IOFF
  10122.                YLIMS(IX) = PGYBLC(PGID)
  10123.  140        CONTINUE
  10124.          END IF
  10125.          CBIAS = CBIAS + BIAS
  10126.          NOFF = NOFF + IOFF
  10127.  200  CONTINUE
  10128. C
  10129.       CALL PGEBUF
  10130.       END
  10131.       REAL FUNCTION PGHIS1 (X, NELMX, CENTER, IXV)
  10132.       LOGICAL CENTER
  10133.       INTEGER NELMX, IXV
  10134.       REAL X(NELMX)
  10135. C
  10136. C PGPLOT Internal routine used by PGHI2D.  Calculates the X-value for
  10137. C the left hand edge of a given element of the array being plotted.
  10138. C
  10139. C Arguments -
  10140. C
  10141. C X (input, real array): abscissae of bins
  10142. C NELMX (input, integer): number of bins
  10143. C CENTER (Input, logical): if .true., X values denote the center of
  10144. C       the bin; if .false., the X values denote the lower edge (in X)
  10145. C       of the bin.
  10146. C IXV (input, integer): the bin number in question.  Note IXV may be
  10147. C       outside the range 1..NELMX, in which case an interpolated
  10148. C       value is returned.
  10149. C
  10150. C 21-Feb-1984 - Keith Shortridge.
  10151. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  10152. C-----------------------------------------------------------------------
  10153.       REAL XN
  10154.       INTRINSIC REAL
  10155. C
  10156.       IF (CENTER) THEN
  10157.           IF ((IXV.GT.1).AND.(IXV.LE.NELMX)) THEN
  10158.             XN = ( X(IXV-1) + X(IXV) ) * .5
  10159.           ELSE IF (IXV.LE.1) THEN
  10160.             XN = X(1) - .5 * (X(2) - X(1)) * REAL(3 - 2 * IXV)
  10161.           ELSE IF (IXV.GT.NELMX) THEN
  10162.             XN = X(NELMX) +.5*(X(NELMX)-X(NELMX-1))*
  10163.      1           REAL((IXV-NELMX)*2-1)
  10164.           END IF
  10165.       ELSE
  10166.           IF ((IXV.GE.1).AND.(IXV.LE.NELMX)) THEN
  10167.             XN = X(IXV)
  10168.           ELSE IF (IXV.LT.1) THEN
  10169.             XN = X(1) - ( X(2) - X(1) ) * REAL( 1 - IXV )
  10170.           ELSE IF (IXV.GT.NELMX) THEN
  10171.             XN = X(NELMX) + ( X(NELMX) - X(NELMX-1)) *
  10172.      1           REAL(IXV - NELMX)
  10173.           END IF
  10174.       END IF
  10175. C
  10176.       PGHIS1 = XN
  10177.       END
  10178. C*PGHIST -- histogram of unbinned data
  10179. C%void cpghist(int n, const float *data, float datmin, float datmax, \
  10180. C% int nbin, int pgflag);
  10181. C+
  10182.       SUBROUTINE PGHIST(N, DATA, DATMIN, DATMAX, NBIN, PGFLAG)
  10183.       INTEGER N
  10184.       REAL    DATA(*)
  10185.       REAL    DATMIN, DATMAX
  10186.       INTEGER NBIN, PGFLAG
  10187. C
  10188. C Draw a histogram of N values of a variable in array
  10189. C DATA(1...N) in the range DATMIN to DATMAX using NBIN bins.  Note
  10190. C that array elements which fall exactly on the boundary between
  10191. C two bins will be counted in the higher bin rather than the
  10192. C lower one; and array elements whose value is less than DATMIN or
  10193. C greater than or equal to DATMAX will not be counted at all.
  10194. C
  10195. C Arguments:
  10196. C  N      (input)  : the number of data values.
  10197. C  DATA   (input)  : the data values. Note: the dimension of array
  10198. C                    DATA must be greater than or equal to N. The
  10199. C                    first N elements of the array are used.
  10200. C  DATMIN (input)  : the minimum data value for the histogram.
  10201. C  DATMAX (input)  : the maximum data value for the histogram.
  10202. C  NBIN   (input)  : the number of bins to use: the range DATMIN to
  10203. C                    DATMAX is divided into NBIN equal bins and
  10204. C                    the number of DATA values in each bin is
  10205. C                    determined by PGHIST.  NBIN may not exceed 200.
  10206. C  PGFLAG (input)  : if PGFLAG = 1, the histogram is plotted in the
  10207. C                    current window and viewport; if PGFLAG = 0,
  10208. C                    PGENV is called automatically by PGHIST to start
  10209. C                    a new plot (the x-limits of the window will be
  10210. C                    DATMIN and DATMAX; the y-limits will be chosen
  10211. C                    automatically.
  10212. C                    IF PGFLAG = 2,3 the histogram will be in the same
  10213. C                    window and viewport but with a filled area style.
  10214. C                    If pgflag=4,5 as for pgflag = 0,1, but simple
  10215. C                    line drawn as for PGBIN
  10216. C
  10217. C--
  10218. C Side effects:
  10219. C
  10220. C The pen position is changed to (DATMAX,0.0) in world coordinates.
  10221. C--
  10222. C  6-Sep-83:
  10223. C 11-Feb-92: fill options added.
  10224. C-----------------------------------------------------------------------
  10225.       INTEGER  MAXBIN
  10226.       PARAMETER (MAXBIN=200)
  10227.       INTEGER  I, IBIN, NUM(MAXBIN), NUMMAX, JUNK
  10228.       REAL     BINSIZ, PGRND
  10229.       REAL     CUR, PREV, XLO, XHI, YLO, YHI
  10230.       LOGICAL  PGNOTO
  10231. C
  10232.       IF (N.LT.1 .OR. DATMAX.LE.DATMIN .OR. NBIN.LT.1 .OR.
  10233.      1    NBIN.GT.MAXBIN) THEN
  10234.           CALL GRWARN('PGHIST: invalid arguments')
  10235.           RETURN
  10236.       END IF
  10237.       IF (PGNOTO('PGHIST')) RETURN
  10238.       CALL PGBBUF
  10239. C
  10240. C How many values in each bin?
  10241. C
  10242.       DO 10 IBIN=1,NBIN
  10243.           NUM(IBIN) = 0
  10244.    10 CONTINUE
  10245.       DO 20 I=1,N
  10246.           IBIN = (DATA(I)-DATMIN)/(DATMAX-DATMIN)*NBIN+1
  10247.           IF (IBIN.GE.1 .AND. IBIN.LE.NBIN) NUM(IBIN) = NUM(IBIN)+1
  10248.    20 CONTINUE
  10249.       NUMMAX = 0
  10250.       DO 30 IBIN=1,NBIN
  10251.           NUMMAX = MAX(NUMMAX,NUM(IBIN))
  10252.    30 CONTINUE
  10253.       BINSIZ = (DATMAX-DATMIN)/NBIN
  10254. C
  10255. C Boundaries of plot.
  10256. C
  10257.       XLO = DATMIN
  10258.       XHI = DATMAX
  10259.       YLO = 0.0
  10260.       YHI = PGRND(1.01*NUMMAX,JUNK)
  10261. C
  10262. C Define environment if necessary.
  10263. C
  10264.       IF (MOD(PGFLAG,2).EQ.0) THEN
  10265.          CALL PGENV(XLO,XHI,YLO,YHI,0,0)
  10266.       END IF
  10267. C
  10268. C Draw Histogram.
  10269. C
  10270.       IF (PGFLAG/2.EQ.0) THEN
  10271.          PREV = 0.0
  10272.          XHI=DATMIN
  10273.          CALL GRMOVA(DATMIN,0.0)
  10274.          DO 40 IBIN=1,NBIN
  10275.             CUR = NUM(IBIN)
  10276.             XLO=XHI
  10277.             XHI = DATMIN + IBIN*BINSIZ
  10278.             IF (CUR.EQ.0.0) THEN
  10279.                CONTINUE
  10280.             ELSE IF (CUR.LE.PREV) THEN
  10281.                CALL GRMOVA(XLO,CUR)
  10282.                CALL GRLINA(XHI,CUR)
  10283.             ELSE
  10284.                CALL GRMOVA(XLO,PREV)
  10285.                CALL GRLINA(XLO,CUR)
  10286.                CALL GRLINA(XHI,CUR)
  10287.             END IF
  10288.             CALL GRLINA(XHI,0.0)
  10289.             PREV = CUR
  10290.  40      CONTINUE
  10291.       ELSE IF (PGFLAG/2.EQ.1) THEN
  10292.          PREV = 0.0
  10293.          XHI = DATMIN
  10294.          DO 50 IBIN=1,NBIN
  10295.             CUR = NUM(IBIN)
  10296.             XLO=XHI
  10297.             XHI = DATMIN + IBIN*BINSIZ
  10298.             IF (CUR.EQ.0.0) THEN
  10299.                CONTINUE
  10300.             ELSE
  10301.                CALL PGRECT(XLO,XHI,0.0,CUR)
  10302.             END IF
  10303.  50      CONTINUE
  10304.       ELSE IF (PGFLAG/2.EQ.2) THEN
  10305.          PREV = 0.0
  10306.          CALL GRMOVA(DATMIN,0.0)
  10307.          XHI=DATMIN
  10308.          DO 60 IBIN=1,NBIN
  10309.             CUR = NUM(IBIN)
  10310.             XLO = XHI
  10311.             XHI = DATMIN + IBIN*BINSIZ
  10312.             IF (CUR.EQ.0.0 .AND. PREV.EQ.0.0) THEN
  10313.                CALL GRMOVA(XHI,0.0)
  10314.             ELSE 
  10315.                CALL GRLINA(XLO,CUR)
  10316.                IF(CUR.NE.0.0) THEN
  10317.                   CALL GRLINA(XHI,CUR)
  10318.                ELSE
  10319.                   CALL GRMOVA(XHI,CUR)
  10320.                ENDIF
  10321.             END IF
  10322.             PREV = CUR
  10323.  60      CONTINUE
  10324.       END IF
  10325. C     
  10326.       CALL PGEBUF
  10327.       END
  10328. C.PGHTCH -- hatch a polygonal area (internal routine)
  10329. C.
  10330.       SUBROUTINE PGHTCH(N, X, Y, DA)
  10331.       INTEGER N
  10332.       REAL X(*), Y(*), DA
  10333. C
  10334. C Hatch a polygonal area using equi-spaced parallel lines. The lines
  10335. C are drawn using the current line attributes: line style, line width,
  10336. C and color index. Cross-hatching can be achieved by calling this
  10337. C routine twice.
  10338. C
  10339. C Limitations: the hatching will not be done correctly if the
  10340. C polygon is so complex that a hatch line intersects more than
  10341. C 32 of its sides.
  10342. C
  10343. C Arguments:
  10344. C  N      (input)  : the number of vertices of the polygonal.
  10345. C  X,Y    (input)  : the (x,y) world-coordinates of the vertices
  10346. C                    (in order).
  10347. C  DA      (input) : 0.0 for normal hatching, 90.0 for perpendicular
  10348. C                    hatching.
  10349. C--
  10350. C Reference: I.O. Angel and G. Griffith "High-resolution computer
  10351. C graphics using Fortran 77", Halsted Press, 1987.
  10352. C
  10353. C 18-Feb-1995 [TJP].
  10354. C-----------------------------------------------------------------------
  10355. C
  10356. C MAXP is the maximum number of intersections any hatch line may make 
  10357. C with the sides of the polygon.
  10358. C
  10359.       INTEGER MAXP
  10360.       PARAMETER (MAXP=32)
  10361.       INTEGER NP(MAXP), I,J, II,JJ, NMIN,NMAX, NX, NI, NNP
  10362.       REAL ANGLE, SEPN, PHASE
  10363.       REAL RMU(MAXP), DX,DY, C, CMID,CMIN,CMAX, SX,SY, EX,EY, DELTA
  10364.       REAL QX,QY, R, RMU1, RMU2, XI,YI, BX,BY
  10365.       REAL DH, XS1, XS2, YS1, YS2, XL, XR, YT, YB, DINDX, DINDY
  10366. C
  10367. C Check arguments.
  10368. C
  10369.       IF (N.LT.3) RETURN
  10370.       CALL PGQHS(ANGLE, SEPN, PHASE)
  10371.       ANGLE = ANGLE + DA
  10372.       IF (SEPN.EQ.0.0) RETURN
  10373. C
  10374. C The unit spacing is 1 percent of the smaller of the height or
  10375. C width of the view surface. The line-spacing (DH), in inches, is
  10376. C obtained by multiplying this by argument SEPN.
  10377. C
  10378.       CALL PGQVSZ(1, XS1, XS2, YS1, YS2)
  10379.       DH = SEPN*MIN(ABS(XS2-XS1),ABS(YS2-YS1))/100.0
  10380. C
  10381. C DINDX and DINDY are the scales in inches per world-coordinate unit.
  10382. C
  10383.       CALL PGQVP(1, XS1, XS2, YS1, YS2)
  10384.       CALL PGQWIN(XL, XR, YB, YT)
  10385.       IF (XR.NE.XL .AND. YT.NE.YB) THEN
  10386.          DINDX = (XS2 - XS1) / (XR - XL)
  10387.          DINDY = (YS2 - YS1) / (YT - YB)
  10388.       ELSE
  10389.          RETURN
  10390.       END IF
  10391. C
  10392. C Initialize.
  10393. C
  10394.       CALL PGBBUF
  10395. C
  10396. C The vector (SX,SY) is a vector length DH perpendicular to
  10397. C the hatching lines, which have vector (DX,DY).
  10398. C
  10399.       DX = COS(ANGLE/57.29578)
  10400.       DY = SIN(ANGLE/57.29578)
  10401.       SX = (-DH)*DY
  10402.       SY = DH*DX
  10403. C
  10404. C The hatch lines are labelled by a parameter C, the distance from
  10405. C the coordinate origin. Calculate CMID, the C-value of the line
  10406. C that passes through the hatching reference point (BX,BY), and
  10407. C CMIN and CMAX, the range of C-values spanned by lines that intersect
  10408. C the polygon.
  10409. C
  10410.       BX = PHASE*SX
  10411.       BY = PHASE*SY
  10412.       CMID = DX*BY - DY*BX
  10413.       CMIN = DX*Y(1)*DINDY - DY*X(1)*DINDX
  10414.       CMAX = CMIN
  10415.       DO 10 I=2,N
  10416.          C = DX*Y(I)*DINDY - DY*X(I)*DINDX
  10417.          CMIN = MIN(C,CMIN)
  10418.          CMAX = MAX(C,CMAX)
  10419.  10   CONTINUE
  10420. C
  10421. C Compute integer labels for the hatch lines; N=0 is the line
  10422. C which passes through the reference point; NMIN and NMAX define
  10423. C the range of labels for lines that intersect the polygon.
  10424. C [Note that INT truncates towards zero; we need FLOOR and CEIL
  10425. C functions.]
  10426. C
  10427.       CMIN = (CMIN-CMID)/DH
  10428.       CMAX = (CMAX-CMID)/DH
  10429.       NMIN = INT(CMIN)
  10430.       IF (REAL(NMIN).LT.CMIN) NMIN = NMIN+1
  10431.       NMAX = INT(CMAX)
  10432.       IF (REAL(NMAX).GT.CMAX) NMAX = NMAX-1
  10433. C
  10434. C Each iteration of the following loop draws one hatch line.
  10435. C
  10436.       DO 60 J=NMIN,NMAX
  10437. C
  10438. C The parametric representation of this hatch line is
  10439. C (X,Y) = (QX,QY) + RMU*(DX,DY).
  10440. C
  10441.          QX = BX + REAL(J)*SX
  10442.          QY = BY + REAL(J)*SY
  10443. C
  10444. C Find the NX intersections of this line with the edges of the polygon.
  10445. C
  10446.          NX = 0
  10447.          NI = N
  10448.          DO 20 I=1,N
  10449.             EX = (X(I) - X(NI))*DINDX
  10450.             EY = (Y(I) - Y(NI))*DINDY
  10451.             DELTA = EX*DY - EY*DX
  10452.             IF (ABS(DELTA).LT.1E-5) THEN
  10453. C                 -- lines are parallel
  10454.             ELSE
  10455. C                 -- lines intersect in (XI,YI)
  10456.                R = ((QX-X(NI)*DINDX)*DY - (QY-Y(NI)*DINDY)*DX)/DELTA
  10457.                IF (R.GT.0.0 .AND. R.LE.1.0) THEN
  10458.                   IF (NX.LT.MAXP) NX = NX+1
  10459.                   NP(NX) = NX
  10460.                   IF (ABS(DX).GT.0.5) THEN
  10461.                      XI = X(NI)*DINDX + R*EX
  10462.                      RMU(NX) = (XI-QX)/DX
  10463.                   ELSE
  10464.                      YI = Y(NI)*DINDY + R*EY
  10465.                      RMU(NX) = (YI-QY)/DY
  10466.                   END IF
  10467.                END IF
  10468.             END IF
  10469.             NI = I
  10470.  20      CONTINUE
  10471. C     
  10472. C The RMU array now contains the intersections. Sort them into order.
  10473. C
  10474.          DO 40 II=1,NX-1
  10475.             DO 30 JJ=II+1,NX
  10476.                IF (RMU(NP(II)).LT.RMU(NP(JJ))) THEN
  10477.                   NNP = NP(II)
  10478.                   NP(II) = NP(JJ)
  10479.                   NP(JJ) = NNP
  10480.                END IF
  10481.  30         CONTINUE
  10482.  40      CONTINUE
  10483. C
  10484. C Join the intersections in pairs.
  10485. C
  10486.          NI = 1
  10487. C         -- do while NI < NX
  10488.  50      IF (NI .LT. NX) THEN
  10489.             RMU1 = RMU(NP(NI))
  10490.             RMU2 = RMU(NP(NI+1))
  10491.             CALL PGMOVE((QX+RMU1*DX)/DINDX, (QY+RMU1*DY)/DINDY)
  10492.             CALL PGDRAW((QX+RMU2*DX)/DINDX, (QY+RMU2*DY)/DINDY)
  10493.             NI = NI+2
  10494.             GOTO 50
  10495.          END IF
  10496.  60   CONTINUE
  10497. C
  10498. C Tidy up.
  10499. C
  10500.       CALL PGEBUF
  10501. C
  10502.       END
  10503. C*PGIDEN -- write username, date, and time at bottom of plot
  10504. C%void cpgiden(void);
  10505. C+
  10506.       SUBROUTINE PGIDEN
  10507. C
  10508. C Write username, date, and time at bottom of plot.
  10509. C
  10510. C Arguments: none.
  10511. C--
  10512. C  9-Feb-1988
  10513. C 10-Sep-1990 : adjust position of text [TJP]
  10514. C-----------------------------------------------------------------------
  10515.       INCLUDE 'f77.PGPLOT/IN'
  10516.       INTEGER L, M, CF, CI, LW
  10517.       CHARACTER*64 TEXT
  10518.       REAL D, CH
  10519. C
  10520.       CALL PGBBUF
  10521. C
  10522. C Get information for annotation.
  10523. C
  10524.       CALL GRUSER(TEXT, L)
  10525.       TEXT(L+1:) = ' '
  10526.       CALL GRDATE(TEXT(L+2:), M)
  10527.       L = L+1+M
  10528. C
  10529. C Save current attributes.
  10530. C
  10531.       CALL PGQCF(CF)
  10532.       CALL PGQCI(CI)
  10533.       CALL PGQLW(LW)
  10534.       CALL PGQCH(CH)
  10535. C
  10536. C Change attributes and write text.
  10537. C
  10538.       CALL PGSCF(1)
  10539.       CALL PGSCI(1)
  10540.       CALL PGSLW(1)
  10541.       CALL PGSCH(0.6)
  10542.       CALL GRLEN(TEXT(1:L),D)
  10543.       CALL GRTEXT(.FALSE., 0.0, .TRUE., PGXSZ(PGID)-D-2.0,
  10544.      1            2.0+PGYSZ(PGID)/130.0, TEXT(1:L))
  10545. C
  10546. C Restore attributes.
  10547. C
  10548.       CALL PGSCF(CF)
  10549.       CALL PGSCI(CI)
  10550.       CALL PGSLW(LW)
  10551.       CALL PGSCH(CH)
  10552.       CALL PGEBUF
  10553. C
  10554.       END
  10555. C*PGIMAG -- color image from a 2D data array
  10556. C%void cpgimag(const float *a, int idim, int jdim, int i1, int i2, \
  10557. C% int j1, int j2, float a1, float a2, const float *tr);
  10558. C+
  10559.       SUBROUTINE PGIMAG (A, IDIM, JDIM, I1, I2, J1, J2,
  10560.      1                   A1, A2, TR)
  10561.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  10562.       REAL    A(IDIM,JDIM), A1, A2, TR(6)
  10563. C
  10564. C Draw a color image of an array in current window. The subsection
  10565. C of the array A defined by indices (I1:I2, J1:J2) is mapped onto
  10566. C the view surface world-coordinate system by the transformation
  10567. C matrix TR. The resulting quadrilateral region is clipped at the edge
  10568. C of the window. Each element of the array is represented in the image
  10569. C by a small quadrilateral, which is filled with a color specified by
  10570. C the corresponding array value.
  10571. C
  10572. C The subroutine uses color indices in the range C1 to C2, which can
  10573. C be specified by calling PGSCIR before PGIMAG. The default values
  10574. C for C1 and C2 are device-dependent; these values can be determined by
  10575. C calling PGQCIR. Note that color representations should be assigned to
  10576. C color indices C1 to C2 by calling PGSCR before calling PGIMAG. On some
  10577. C devices (but not all), the color representation can be changed after
  10578. C the call to PGIMAG by calling PGSCR again.
  10579. C
  10580. C Array values in the range A1 to A2 are mapped on to the range of
  10581. C color indices C1 to C2, with array values <= A1 being given color
  10582. C index C1 and values >= A2 being given color index C2. The mapping
  10583. C function for intermediate array values can be specified by
  10584. C calling routine PGSITF before PGIMAG; the default is linear.
  10585. C
  10586. C On devices which have no available color indices (C1 > C2),
  10587. C PGIMAG will return without doing anything. On devices with only
  10588. C one color index (C1=C2), all array values map to the same color
  10589. C which is rather uninteresting. An image is always "opaque",
  10590. C i.e., it obscures all graphical elements previously drawn in
  10591. C the region.
  10592. C
  10593. C The transformation matrix TR is used to calculate the world
  10594. C coordinates of the center of the "cell" that represents each
  10595. C array element. The world coordinates of the center of the cell
  10596. C corresponding to array element A(I,J) are given by:
  10597. C
  10598. C          X = TR(1) + TR(2)*I + TR(3)*J
  10599. C          Y = TR(4) + TR(5)*I + TR(6)*J
  10600. C
  10601. C Usually TR(3) and TR(5) are zero -- unless the coordinate
  10602. C transformation involves a rotation or shear.  The corners of the
  10603. C quadrilateral region that is shaded by PGIMAG are given by
  10604. C applying this transformation to (I1-0.5,J1-0.5), (I2+0.5, J2+0.5).
  10605. C
  10606. C Arguments:
  10607. C  A      (input)  : the array to be plotted.
  10608. C  IDIM   (input)  : the first dimension of array A.
  10609. C  JDIM   (input)  : the second dimension of array A.
  10610. C  I1, I2 (input)  : the inclusive range of the first index
  10611. C                    (I) to be plotted.
  10612. C  J1, J2 (input)  : the inclusive range of the second
  10613. C                    index (J) to be plotted.
  10614. C  A1     (input)  : the array value which is to appear with shade C1.
  10615. C  A2     (input)  : the array value which is to appear with shade C2.
  10616. C  TR     (input)  : transformation matrix between array grid and
  10617. C                    world coordinates.
  10618. C--
  10619. C 15-Sep-1994: new routine [TJP].
  10620. C 21-Jun-1995: minor change to header comments [TJP].
  10621. C-----------------------------------------------------------------------
  10622.       INCLUDE  'f77.PGPLOT/IN'
  10623.       REAL PA(6)
  10624.       LOGICAL PGNOTO
  10625. C
  10626. C Check inputs.
  10627. C
  10628.       IF (PGNOTO('PGIMAG')) RETURN
  10629.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  10630.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  10631.           CALL GRWARN('PGIMAG: invalid range I1:I2, J1:J2')
  10632.       ELSE IF (A1.EQ.A2) THEN
  10633.           CALL GRWARN('PGIMAG: foreground level = background level')
  10634.       ELSE IF (PGMNCI(PGID).GT.PGMXCI(PGID)) THEN
  10635.           CALL GRWARN('PGIMAG: not enough colors available')
  10636.       ELSE
  10637. C
  10638. C Call lower-level routine to do the work.
  10639. C
  10640.           CALL PGBBUF
  10641.           PA(1) = TR(1)*PGXSCL(PGID) + PGXORG(PGID)
  10642.           PA(2) = TR(2)*PGXSCL(PGID)
  10643.           PA(3) = TR(3)*PGXSCL(PGID)
  10644.           PA(4) = TR(4)*PGYSCL(PGID) + PGYORG(PGID)
  10645.           PA(5) = TR(5)*PGYSCL(PGID)
  10646.           PA(6) = TR(6)*PGYSCL(PGID)
  10647.           CALL GRIMG0(A, IDIM, JDIM, I1, I2, J1, J2, A1, A2, PA,
  10648.      :                PGMNCI(PGID), PGMXCI(PGID), PGITF(PGID))
  10649.           CALL PGEBUF
  10650.       END IF
  10651. C-----------------------------------------------------------------------
  10652.       END
  10653. C PGINIT -- initialize PGPLOT (internal routine)
  10654. C
  10655.       SUBROUTINE PGINIT
  10656. C
  10657. C Initialize PGPLOT. This routine should be called once during program
  10658. C execution, before any other PGPLOT routines.
  10659. C--
  10660. C Last modified: 1996 Apr 30 [TJP].
  10661. C-----------------------------------------------------------------------
  10662.       INCLUDE 'f77.PGPLOT/IN'
  10663.       INTEGER CALLED, I
  10664.       SAVE CALLED
  10665.       DATA CALLED /0/
  10666. C
  10667.       IF (CALLED.EQ.0) THEN
  10668.          PGID = 0
  10669.          DO 10 I=1,PGMAXD
  10670.             PGDEVS(I) = 0
  10671.  10      CONTINUE
  10672.          CALL GRINIT
  10673.          CALLED = 1
  10674.       END IF
  10675. C
  10676.       RETURN
  10677.       END
  10678. C*PGLAB -- write labels for x-axis, y-axis, and top of plot
  10679. C%void cpglab(const char *xlbl, const char *ylbl, const char *toplbl);
  10680. C+
  10681.       SUBROUTINE PGLAB (XLBL, YLBL, TOPLBL)
  10682.       CHARACTER*(*) XLBL, YLBL, TOPLBL
  10683. C
  10684. C Write labels outside the viewport. This routine is a simple
  10685. C interface to PGMTXT, which should be used if PGLAB is inadequate.
  10686. C
  10687. C Arguments:
  10688. C  XLBL   (input) : a label for the x-axis (centered below the
  10689. C                   viewport).
  10690. C  YLBL   (input) : a label for the y-axis (centered to the left
  10691. C                   of the viewport, drawn vertically).
  10692. C  TOPLBL (input) : a label for the entire plot (centered above the
  10693. C                   viewport).
  10694. C--
  10695. C 11-May-1990 - remove unnecessary include - TJP.
  10696. C-----------------------------------------------------------------------
  10697.       CALL PGBBUF
  10698.       CALL PGMTXT('T', 2.0, 0.5, 0.5, TOPLBL)
  10699.       CALL PGMTXT('B', 3.2, 0.5, 0.5, XLBL)
  10700.       CALL PGMTXT('L', 2.2, 0.5, 0.5, YLBL)
  10701.       CALL PGEBUF
  10702.       END
  10703. C*PGLABEL -- non-standard alias for PGLAB
  10704. C+
  10705.       SUBROUTINE PGLABEL (XLBL, YLBL, TOPLBL)
  10706.       CHARACTER*(*) XLBL, YLBL, TOPLBL
  10707. C
  10708. C See description of PGLAB.
  10709. C--
  10710.       CALL PGLAB (XLBL, YLBL, TOPLBL)
  10711.       END
  10712. C*PGLCUR -- draw a line using the cursor
  10713. C%void cpglcur(int maxpt, int *npt, float *x, float *y);
  10714. C+
  10715.       SUBROUTINE PGLCUR (MAXPT, NPT, X, Y)
  10716.       INTEGER MAXPT, NPT
  10717.       REAL    X(*), Y(*)
  10718. C
  10719. C Interactive routine for user to enter a polyline by use of
  10720. C the cursor.  Routine allows user to Add and Delete vertices;
  10721. C vertices are joined by straight-line segments.
  10722. C
  10723. C Arguments:
  10724. C  MAXPT  (input)  : maximum number of points that may be accepted.
  10725. C  NPT    (in/out) : number of points entered; should be zero on
  10726. C                    first call.
  10727. C  X      (in/out) : array of x-coordinates (dimension at least MAXPT).
  10728. C  Y      (in/out) : array of y-coordinates (dimension at least MAXPT).
  10729. C
  10730. C Notes:
  10731. C
  10732. C (1) On return from the program, cursor points are returned in
  10733. C the order they were entered. Routine may be (re-)called with points
  10734. C already defined in X,Y (# in NPT), and they will be plotted
  10735. C first, before editing.
  10736. C
  10737. C (2) User commands: the user types single-character commands
  10738. C after positioning the cursor: the following are accepted:
  10739. C   A (Add)    - add point at current cursor location.
  10740. C   D (Delete) - delete last-entered point.
  10741. C   X (eXit)   - leave subroutine.
  10742. C--
  10743. C  5-Aug-1984 - new routine [TJP].
  10744. C 16-Jul-1988 - correct error in delete operation [TJP].
  10745. C 13-Dec-1990 - change warnings to messages [TJP].
  10746. C  3-Sep-1992 - fixed erase first point bug under Add option [JM/TJP].
  10747. C  7-Sep-1994 - use PGBAND [TJP].
  10748. C  2-Aug-1995 - remove dependence on common block [TJP].
  10749. C-----------------------------------------------------------------------
  10750.       LOGICAL  PGNOTO
  10751.       CHARACTER*1 LETTER
  10752.       INTEGER  PGBAND, I, SAVCOL, MODE
  10753.       REAL     XP, YP, XREF, YREF
  10754.       REAL     XBLC, XTRC, YBLC, YTRC
  10755. C
  10756. C Check that PGPLOT is in the correct state.
  10757. C
  10758.       IF (PGNOTO('PGLCUR')) RETURN
  10759. C
  10760. C Save current color.
  10761. C
  10762.       CALL GRQCI(SAVCOL)
  10763. C
  10764. C Put current line-segments on screen.
  10765. C
  10766.       IF (NPT.EQ.1) THEN
  10767.           CALL PGPT(1,X(1),Y(1),1)
  10768.       END IF
  10769.       IF (NPT.GT.0) THEN
  10770.           CALL GRMOVA(X(1),Y(1))
  10771.           DO 10 I=2,NPT
  10772.               CALL GRLINA(X(I),Y(I))
  10773.    10     CONTINUE
  10774.       END IF
  10775. C
  10776. C Start with the cursor in the middle of the box,
  10777. C unless lines have already been drawn.
  10778. C
  10779.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  10780.       IF (NPT.GT.0) THEN
  10781.           XP = X(NPT)
  10782.           YP = Y(NPT)
  10783.       ELSE
  10784.           XP = 0.5*(XBLC+XTRC)
  10785.           YP = 0.5*(YBLC+YTRC)
  10786.       END IF
  10787. C
  10788. C Loop over cursor inputs.
  10789. C
  10790.       MODE = 0
  10791.   100 XREF = XP
  10792.       YREF = YP
  10793.       IF (PGBAND(MODE,1,XREF,YREF,XP,YP,LETTER).NE.1) RETURN
  10794.       CALL GRTOUP(LETTER,LETTER)
  10795.       MODE = 1
  10796. C
  10797. C A (ADD) command:
  10798. C
  10799.       IF (LETTER .EQ. 'A') THEN
  10800.           IF (NPT.GE.MAXPT) THEN
  10801.             CALL GRMSG('ADD ignored (too many points).')
  10802.               GOTO 100
  10803.           END IF
  10804.           NPT = NPT+1
  10805.           X(NPT) = XP
  10806.           Y(NPT) = YP
  10807.           IF (NPT.EQ.1) THEN
  10808. C           -- first point: draw a dot
  10809.             CALL GRMOVA(X(NPT),Y(NPT))
  10810.             CALL PGPT(1,X(NPT),Y(NPT),1)
  10811.           ELSE
  10812. C           -- nth point: draw from (n-1) to (n)
  10813.             CALL GRLINA(X(NPT),Y(NPT))
  10814.           END IF
  10815.           CALL GRTERM
  10816. C
  10817. C D (DELETE) command:
  10818. C
  10819.       ELSE IF (LETTER.EQ.'D') THEN
  10820.           IF (NPT.LE.0) THEN
  10821.             CALL GRMSG('DELETE ignored (there are no points left).')
  10822.             GOTO 100
  10823.           END IF
  10824.           IF (NPT.GT.1) THEN
  10825. C           -- delete nth point: erase from (n-1) to (n)
  10826.             CALL GRMOVA(X(NPT-1),Y(NPT-1))
  10827.             CALL GRSCI(0)
  10828.             CALL GRLINA(X(NPT),Y(NPT))
  10829.             CALL GRSCI(SAVCOL)
  10830.             CALL GRMOVA(X(NPT-1),Y(NPT-1))
  10831.             CALL GRTERM
  10832.           ELSE IF (NPT.EQ.1) THEN
  10833. C           -- delete first point: erase dot
  10834.             CALL GRSCI(0)
  10835.             CALL PGPT(1,X(NPT),Y(NPT),1)
  10836.             CALL GRSCI(SAVCOL)
  10837.           END IF
  10838.           NPT = NPT-1
  10839.           IF (NPT.EQ.0) THEN
  10840.             XP = 0.5*(XBLC+XTRC)
  10841.             YP = 0.5*(YBLC+YTRC)
  10842.           ELSE
  10843.             XP = X(NPT)
  10844.             YP = Y(NPT)
  10845.           END IF
  10846.           IF (NPT.EQ.1) THEN
  10847. C           -- delete 2nd point: redraw dot at first point
  10848.             CALL PGPT(1,X(1),Y(1),1)
  10849.           END IF
  10850. C
  10851. C X (EXIT) command:
  10852. C
  10853.       ELSE IF (LETTER.EQ.'X') THEN
  10854.           CALL GRETXT
  10855.           RETURN
  10856. C
  10857. C Illegal command:
  10858. C
  10859.       ELSE
  10860.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  10861.       END IF
  10862. C
  10863.       GOTO 100
  10864.       END
  10865. C*PGLDEV -- list available device types on standard output
  10866. C%void cpgldev(void);
  10867. C+
  10868.       SUBROUTINE PGLDEV
  10869. C
  10870. C Writes (to standard output) a list of all device types available in
  10871. C the current PGPLOT installation.
  10872. C
  10873. C Arguments: none.
  10874. C--
  10875. C 5-Aug-1986 - [AFT].
  10876. C 1-Aug-1988 - add version number [TJP].
  10877. C 24-Apr-1989 - add copyright notice [TJP].
  10878. C 13-Dec-1990 - changed warnings to messages [TJP].
  10879. C 26-Feb-1997 - revised description [TJP].
  10880. C 18-Mar-1997 - revised [TJP].
  10881. C-----------------------------------------------------------------------
  10882.       CHARACTER*16 GVER
  10883.       INTEGER L
  10884.       CHARACTER*10 T
  10885.       CHARACTER*64 D
  10886.       INTEGER I, N, TLEN, DLEN, INTER
  10887. C
  10888. C Initialize PGPLOT if necessary.
  10889. C
  10890.       CALL PGINIT
  10891. C
  10892. C Report version and copyright.
  10893. C
  10894.       CALL PGQINF('VERSION', GVER, L)
  10895.       CALL GRMSG('PGPLOT '//GVER(:L)//
  10896.      1           ' Copyright 1997 California Institute of Technology')
  10897. C
  10898. C Find number of device types.
  10899. C
  10900.       CALL PGQNDT(N)
  10901. C
  10902. C Loop through device-type list (twice).
  10903.  
  10904.       CALL GRMSG('Interactive devices:')
  10905.       DO 10 I=1,N
  10906.          CALL PGQDT(I, T, TLEN, D, DLEN, INTER)
  10907.          IF (TLEN.GT.0 .AND. INTER.EQ.1)
  10908.      :        CALL GRMSG('   '//T//' '//D(1:DLEN))
  10909.  10   CONTINUE
  10910.       CALL GRMSG('Non-interactive file formats:')
  10911.       DO 20 I=1,N
  10912.          CALL PGQDT(I, T, TLEN, D, DLEN, INTER)
  10913.          IF (TLEN.GT.0 .AND. INTER.EQ.0)
  10914.      :        CALL GRMSG('   '//T//' '//D(1:DLEN))
  10915.  20   CONTINUE
  10916. C
  10917.       END
  10918. C*PGLEN -- find length of a string in a variety of units
  10919. C%void cpglen(int units, const char *string, float *xl, float *yl);
  10920. C+
  10921.       SUBROUTINE PGLEN (UNITS, STRING, XL, YL)
  10922.       REAL XL, YL
  10923.       INTEGER UNITS
  10924.       CHARACTER*(*) STRING
  10925. C
  10926. C Work out length of a string in x and y directions 
  10927. C
  10928. C Input
  10929. C  UNITS    :  0 => answer in normalized device coordinates
  10930. C              1 => answer in inches
  10931. C              2 => answer in mm
  10932. C              3 => answer in absolute device coordinates (dots)
  10933. C              4 => answer in world coordinates
  10934. C              5 => answer as a fraction of the current viewport size
  10935. C
  10936. C  STRING   :  String of interest
  10937. C Output
  10938. C  XL       :  Length of string in x direction
  10939. C  YL       :  Length of string in y direction
  10940. C
  10941. C--
  10942. C 15-Sep-1989 - new routine (Neil Killeen)
  10943. C-----------------------------------------------------------------------
  10944.       INCLUDE 'f77.PGPLOT/IN'
  10945.       LOGICAL PGNOTO
  10946.       REAL    D
  10947. C
  10948.       IF (PGNOTO('PGLEN')) RETURN
  10949. C
  10950. C   Work out length of a string in absolute device coordinates (dots)
  10951. C   and then convert
  10952. C
  10953.       CALL GRLEN (STRING, D)
  10954. C
  10955.       IF (UNITS.EQ.0) THEN
  10956.         XL = D / PGXSZ(PGID)
  10957.         YL = D / PGYSZ(PGID)
  10958.       ELSE IF (UNITS.EQ.1) THEN
  10959.         XL = D / PGXPIN(PGID)
  10960.         YL = D / PGYPIN(PGID)
  10961.       ELSE IF (UNITS.EQ.2) THEN
  10962.         XL = 25.4 * D / PGXPIN(PGID)
  10963.         YL = 25.4 * D / PGYPIN(PGID)
  10964.       ELSE IF (UNITS.EQ.3) THEN
  10965.         XL = D
  10966.         YL = D
  10967.       ELSE IF (UNITS.EQ.4) THEN
  10968.         XL = D / ABS(PGXSCL(PGID))
  10969.         YL = D / ABS(PGYSCL(PGID))
  10970.       ELSE IF (UNITS.EQ.5) THEN
  10971.         XL = D / PGXLEN(PGID)
  10972.         YL = D / PGYLEN(PGID)
  10973.       ELSE
  10974.         CALL GRWARN('Illegal value for UNITS in routine PGLEN')
  10975.       END IF
  10976. C
  10977.       RETURN
  10978.       END
  10979. C*PGLINE -- draw a polyline (curve defined by line-segments)
  10980. C%void cpgline(int n, const float *xpts, const float *ypts);
  10981. C+
  10982.       SUBROUTINE PGLINE (N, XPTS, YPTS)
  10983.       INTEGER  N
  10984.       REAL     XPTS(*), YPTS(*)
  10985. C
  10986. C Primitive routine to draw a Polyline. A polyline is one or more
  10987. C connected straight-line segments.  The polyline is drawn using
  10988. C the current setting of attributes color-index, line-style, and
  10989. C line-width. The polyline is clipped at the edge of the window.
  10990. C
  10991. C Arguments:
  10992. C  N      (input)  : number of points defining the line; the line
  10993. C                    consists of (N-1) straight-line segments.
  10994. C                    N should be greater than 1 (if it is 1 or less,
  10995. C                    nothing will be drawn).
  10996. C  XPTS   (input)  : world x-coordinates of the points.
  10997. C  YPTS   (input)  : world y-coordinates of the points.
  10998. C
  10999. C The dimension of arrays X and Y must be greater than or equal to N.
  11000. C The "pen position" is changed to (X(N),Y(N)) in world coordinates
  11001. C (if N > 1).
  11002. C--
  11003. C 27-Nov-1986
  11004. C-----------------------------------------------------------------------
  11005.       INTEGER  I
  11006.       LOGICAL PGNOTO
  11007. C
  11008.       IF (PGNOTO('PGLINE')) RETURN
  11009.       IF (N.LT.2) RETURN
  11010. C
  11011.       CALL PGBBUF
  11012.       CALL GRMOVA(XPTS(1),YPTS(1))
  11013.       DO 10 I=2,N
  11014.          CALL GRLINA(XPTS(I),YPTS(I))
  11015.  10   CONTINUE
  11016.       CALL PGEBUF
  11017.       END
  11018. C*PGMOVE -- move pen (change current pen position)
  11019. C%void cpgmove(float x, float y);
  11020. C+
  11021.       SUBROUTINE PGMOVE (X, Y)
  11022.       REAL X, Y
  11023. C
  11024. C Primitive routine to move the "pen" to the point with world
  11025. C coordinates (X,Y). No line is drawn.
  11026. C
  11027. C Arguments:
  11028. C  X      (input)  : world x-coordinate of the new pen position.
  11029. C  Y      (input)  : world y-coordinate of the new pen position.
  11030. C--
  11031. C (29-Dec-1983)
  11032. C-----------------------------------------------------------------------
  11033.       CALL GRMOVA(X,Y)
  11034.       END
  11035. C*PGMTEXT -- non-standard alias for PGMTXT
  11036. C+
  11037.       SUBROUTINE PGMTEXT (SIDE, DISP, COORD, FJUST, TEXT)
  11038.       CHARACTER*(*) SIDE, TEXT
  11039.       REAL DISP, COORD, FJUST
  11040. C
  11041. C See description of PGMTXT.
  11042. C--
  11043.       CALL PGMTXT (SIDE, DISP, COORD, FJUST, TEXT)
  11044.       END
  11045. C*PGMTXT -- write text at position relative to viewport
  11046. C%void cpgmtxt(const char *side, float disp, float coord, \
  11047. C% float fjust, const char *text);
  11048. C+
  11049.       SUBROUTINE PGMTXT (SIDE, DISP, COORD, FJUST, TEXT)
  11050.       CHARACTER*(*) SIDE, TEXT
  11051.       REAL DISP, COORD, FJUST
  11052. C
  11053. C Write text at a position specified relative to the viewport (outside
  11054. C or inside).  This routine is useful for annotating graphs. It is used
  11055. C by routine PGLAB.  The text is written using the current values of
  11056. C attributes color-index, line-width, character-height, and
  11057. C character-font.
  11058. C
  11059. C Arguments:
  11060. C  SIDE   (input)  : must include one of the characters 'B', 'L', 'T',
  11061. C                    or 'R' signifying the Bottom, Left, Top, or Right
  11062. C                    margin of the viewport. If it includes 'LV' or
  11063. C                    'RV', the string is written perpendicular to the
  11064. C                    frame rather than parallel to it.
  11065. C  DISP   (input)  : the displacement of the character string from the
  11066. C                    specified edge of the viewport, measured outwards
  11067. C                    from the viewport in units of the character
  11068. C                    height. Use a negative value to write inside the
  11069. C                    viewport, a positive value to write outside.
  11070. C  COORD  (input)  : the location of the character string along the
  11071. C                    specified edge of the viewport, as a fraction of
  11072. C                    the length of the edge.
  11073. C  FJUST  (input)  : controls justification of the string parallel to
  11074. C                    the specified edge of the viewport. If
  11075. C                    FJUST = 0.0, the left-hand end of the string will
  11076. C                    be placed at COORD; if JUST = 0.5, the center of
  11077. C                    the string will be placed at COORD; if JUST = 1.0,
  11078. C                    the right-hand end of the string will be placed at
  11079. C                    at COORD. Other values between 0 and 1 give inter-
  11080. C                    mediate placing, but they are not very useful.
  11081. C  TEXT   (input) :  the text string to be plotted. Trailing spaces are
  11082. C                    ignored when justifying the string, but leading
  11083. C                    spaces are significant.
  11084. C
  11085. C--
  11086. C 18-Apr-1983
  11087. C 15-Aug-1987 - fix BBUF/EBUF error.
  11088. C 27-Aug-1987 - fix justification error if XPERIN.ne.YPERIN.
  11089. C 05-Sep-1989 - change so that DISP has some effect for 'RV' and 
  11090. C               'LV' options [nebk]
  11091. C 16-Oct-1993 - erase background of opaque text.
  11092. C-----------------------------------------------------------------------
  11093.       INCLUDE 'f77.PGPLOT/IN'
  11094.       LOGICAL PGNOTO
  11095.       REAL ANGLE, D, X, Y, RATIO, XBOX(4), YBOX(4)
  11096.       INTEGER CI, I, L, GRTRIM
  11097.       CHARACTER*20 TEST
  11098. C
  11099.       IF (PGNOTO('PGMTXT')) RETURN
  11100. C
  11101.       L = GRTRIM(TEXT)
  11102.       IF (L.LT.1) RETURN
  11103.       D = 0.0
  11104.       IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  11105.       D = D*FJUST
  11106.       RATIO = PGYPIN(PGID)/PGXPIN(PGID)
  11107.       CALL GRTOUP(TEST,SIDE)
  11108.       IF (INDEX(TEST,'B').NE.0) THEN
  11109.           ANGLE = 0.0
  11110.           X = PGXOFF(PGID) + COORD*PGXLEN(PGID) - D
  11111.           Y = PGYOFF(PGID) - PGYSP(PGID)*DISP
  11112.       ELSE IF (INDEX(TEST,'LV').NE.0) THEN
  11113.           ANGLE = 0.0
  11114.           X = PGXOFF(PGID) - PGYSP(PGID)*DISP - D
  11115.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - 0.3*PGYSP(PGID)
  11116.       ELSE IF (INDEX(TEST,'L').NE.0) THEN
  11117.           ANGLE = 90.0
  11118.           X = PGXOFF(PGID) - PGYSP(PGID)*DISP
  11119.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - D*RATIO
  11120.       ELSE IF (INDEX(TEST,'T').NE.0) THEN
  11121.           ANGLE = 0.0
  11122.           X = PGXOFF(PGID) + COORD*PGXLEN(PGID) - D
  11123.           Y = PGYOFF(PGID) + PGYLEN(PGID) + PGYSP(PGID)*DISP
  11124.       ELSE IF (INDEX(TEST,'RV').NE.0) THEN
  11125.           ANGLE = 0.0
  11126.           X = PGXOFF(PGID) + PGXLEN(PGID) + PGYSP(PGID)*DISP - D
  11127.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - 0.3*PGYSP(PGID)
  11128.       ELSE IF (INDEX(TEST,'R').NE.0) THEN
  11129.           ANGLE = 90.0
  11130.           X = PGXOFF(PGID) + PGXLEN(PGID) + PGYSP(PGID)*DISP
  11131.           Y = PGYOFF(PGID) + COORD*PGYLEN(PGID) - D*RATIO
  11132.       ELSE
  11133.           CALL GRWARN('Invalid "SIDE" argument in PGMTXT.')
  11134.           RETURN
  11135.       END IF
  11136.       CALL PGBBUF
  11137.       IF (PGTBCI(PGID).GE.0) THEN
  11138.           CALL GRQTXT (ANGLE, X, Y, TEXT(1:L), XBOX, YBOX)
  11139.           DO 25 I=1,4
  11140.               XBOX(I) = (XBOX(I)-PGXORG(PGID))/PGXSCL(PGID)
  11141.               YBOX(I) = (YBOX(I)-PGYORG(PGID))/PGYSCL(PGID)
  11142.    25     CONTINUE
  11143.           CALL PGQCI(CI)
  11144.           CALL PGSCI(PGTBCI(PGID))
  11145.           CALL GRFA(4, XBOX, YBOX)
  11146.           CALL PGSCI(CI)
  11147.       END IF
  11148.       CALL GRTEXT(.FALSE.,ANGLE,.TRUE., X, Y, TEXT(1:L))
  11149.       CALL PGEBUF
  11150.       END
  11151. C*PGNCUR -- mark a set of points using the cursor
  11152. C%void cpgncur(int maxpt, int *npt, float *x, float *y, int symbol);
  11153. C+
  11154.       SUBROUTINE PGNCUR (MAXPT, NPT, X, Y, SYMBOL)
  11155.       INTEGER MAXPT, NPT
  11156.       REAL    X(*), Y(*)
  11157.       INTEGER SYMBOL
  11158. C
  11159. C Interactive routine for user to enter data points by use of
  11160. C the cursor.  Routine allows user to Add and Delete points.  The
  11161. C points are returned in order of increasing x-coordinate, not in the
  11162. C order they were entered.
  11163. C
  11164. C Arguments:
  11165. C  MAXPT  (input)  : maximum number of points that may be accepted.
  11166. C  NPT    (in/out) : number of points entered; should be zero on
  11167. C                    first call.
  11168. C  X      (in/out) : array of x-coordinates.
  11169. C  Y      (in/out) : array of y-coordinates.
  11170. C  SYMBOL (input)  : code number of symbol to use for marking
  11171. C                    entered points (see PGPT).
  11172. C
  11173. C Note (1): The dimension of arrays X and Y must be greater than or
  11174. C equal to MAXPT.
  11175. C
  11176. C Note (2): On return from the program, cursor points are returned in
  11177. C increasing order of X. Routine may be (re-)called with points
  11178. C already defined in X,Y (number in NPT), and they will be plotted
  11179. C first, before editing.
  11180. C
  11181. C Note (3): User commands: the user types single-character commands
  11182. C after positioning the cursor: the following are accepted:
  11183. C A (Add)    - add point at current cursor location.
  11184. C D (Delete) - delete nearest point to cursor.
  11185. C X (eXit)   - leave subroutine.
  11186. C--
  11187. C 27-Nov-1983
  11188. C  9-Jul-1983 - modified to use GRSCI instead of GRSETLI [TJP].
  11189. C 13-Dec-1990 - changed warnings to messages [TJP].
  11190. C  2-Aug-1995 - [TJP].
  11191. C-----------------------------------------------------------------------
  11192.       INCLUDE  'f77.PGPLOT/IN'
  11193.       CHARACTER*1 LETTER
  11194.       LOGICAL  PGNOTO
  11195.       INTEGER  PGCURS, I, J, SAVCOL
  11196.       REAL     DELTA, XP, YP, XPHYS, YPHYS
  11197.       REAL     XMIN, XIP, YIP
  11198.       REAL     XBLC, XTRC, YBLC, YTRC
  11199. C
  11200. C Check that PGPLOT is in the correct state.
  11201. C
  11202.       IF (PGNOTO('PGNCUR')) RETURN
  11203. C
  11204. C Save current color.
  11205. C
  11206.       CALL GRQCI(SAVCOL)
  11207. C
  11208. C Put current points on screen.
  11209. C
  11210.       IF (NPT.NE.0) CALL PGPT(NPT,X,Y,SYMBOL)
  11211. C
  11212. C Start with the cursor in the middle of the viewport.
  11213. C
  11214.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  11215.       XP = 0.5*(XBLC+XTRC)
  11216.       YP = 0.5*(YBLC+YTRC)
  11217. C
  11218. C Loop over cursor inputs.
  11219. C
  11220.   100 IF (PGCURS(XP,YP,LETTER).NE.1) RETURN
  11221.       IF (LETTER.EQ.CHAR(0)) RETURN
  11222.       CALL GRTOUP(LETTER,LETTER)
  11223. C
  11224. C A (ADD) command:
  11225. C
  11226.       IF (LETTER .EQ. 'A') THEN
  11227.           IF (NPT.GE.MAXPT) THEN
  11228.               CALL GRMSG('ADD ignored (too many points).')
  11229.               GOTO 100
  11230.           END IF
  11231. C         ! Find what current points new point is between.
  11232.           DO 120 J=1,NPT
  11233.               IF (XP.LT.X(J)) GOTO 122
  11234.   120     CONTINUE
  11235.           J = NPT + 1
  11236. C         ! New point is beyond last current
  11237.   122     CONTINUE
  11238. C         ! J is vector location where new point should be included.
  11239.           DO 140 I=NPT,J,-1
  11240.               X(I+1) = X(I)
  11241.               Y(I+1) = Y(I)
  11242.   140     CONTINUE
  11243.           NPT = NPT + 1
  11244. C         ! Add new point to point array.
  11245.           X(J) = XP
  11246.           Y(J) = YP
  11247.           CALL PGPT(1,X(J),Y(J),SYMBOL)
  11248.           CALL GRTERM
  11249. C
  11250. C D (DELETE) command:
  11251. C
  11252.       ELSE IF (LETTER.EQ.'D') THEN
  11253.           IF (NPT.LE.0) THEN
  11254.               CALL GRMSG('DELETE ignored (there are no points left).')
  11255.               GOTO 100
  11256.           END IF
  11257.           XMIN = 1.E+08
  11258. C         ! Look for point closest in radius.
  11259. C         ! Convert cursor points to physical.
  11260.           XPHYS = PGXORG(PGID) + XP*PGXSCL(PGID)
  11261.           YPHYS = PGYORG(PGID) + YP*PGYSCL(PGID)
  11262.           DO 220 I=1,NPT
  11263. C             ! Convert array points to physical.
  11264.               XIP = PGXORG(PGID) + X(I)*PGXSCL(PGID)
  11265.               YIP = PGYORG(PGID) + Y(I)*PGYSCL(PGID)
  11266.               DELTA = SQRT( (XIP-XPHYS)**2 + (YIP-YPHYS)**2 )
  11267.               IF (DELTA.LT.XMIN) THEN
  11268.                  XMIN = DELTA
  11269.                  J = I
  11270.               END IF
  11271.   220     CONTINUE
  11272. C         ! Remove point from screen by writing in background color.
  11273.           CALL GRSCI(0)
  11274.           CALL PGPT(1,X(J),Y(J),SYMBOL)
  11275.           CALL GRSCI(SAVCOL)
  11276.           CALL GRTERM
  11277. C         ! Remove point from cursor array.
  11278.           NPT = NPT-1
  11279.           DO 240 I=J,NPT
  11280.               X(I) = X(I+1)
  11281.               Y(I) = Y(I+1)
  11282.   240     CONTINUE
  11283. C
  11284. C X (EXIT) command:
  11285. C
  11286.       ELSE IF (LETTER.EQ.'X') THEN
  11287.           CALL GRETXT
  11288.           RETURN
  11289. C
  11290. C Illegal command:
  11291. C
  11292.       ELSE
  11293.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  11294.       END IF
  11295. C
  11296.       GOTO 100
  11297.       END
  11298. C*PGNCURSE -- non-standard alias for PGNCUR
  11299. C+
  11300.       SUBROUTINE PGNCURSE (MAXPT, NPT, X, Y, SYMBOL)
  11301.       INTEGER MAXPT, NPT
  11302.       REAL    X(*), Y(*)
  11303.       INTEGER SYMBOL
  11304. C
  11305. C See description of PGNCUR.
  11306. C--
  11307.       CALL PGNCUR (MAXPT, NPT, X, Y, SYMBOL)
  11308.       END
  11309. C
  11310.       LOGICAL FUNCTION PGNOTO (RTN)
  11311.       CHARACTER*(*) RTN
  11312. C
  11313. C PGPLOT (internal routine): Test whether a PGPLOT device is open and
  11314. C print a message if not. Usage:
  11315. C     LOGICAL PGNOTO
  11316. C     IF (PGNOTO('routine')) RETURN
  11317. C
  11318. C Arguments:
  11319. C
  11320. C RTN (input, character): routine name to be include in message.
  11321. C
  11322. C Returns:
  11323. C     .TRUE. if PGPLOT is not open.
  11324. C--
  11325. C 11-Nov-1994
  11326. C 21-Dec-1995 - revised for multiple devices.
  11327. C-----------------------------------------------------------------------
  11328.       INCLUDE  'f77.PGPLOT/IN'
  11329.       CHARACTER*80 TEXT
  11330. C
  11331.       CALL PGINIT
  11332.       PGNOTO = .FALSE.
  11333.       IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  11334.          PGNOTO = .TRUE.
  11335.          TEXT = RTN//': no graphics device has been selected'
  11336.          CALL GRWARN(TEXT)
  11337.       ELSE IF (PGDEVS(PGID).NE.1) THEN
  11338.          PGNOTO = .TRUE.
  11339.          TEXT = RTN//': selected graphics device is not open'
  11340.          CALL GRWARN(TEXT)
  11341.       END IF
  11342.       RETURN
  11343.       END
  11344.  
  11345. C
  11346. C.PGNPL -- Work out how many numerals there are in an integer
  11347. C.
  11348.       SUBROUTINE PGNPL (NMAX, N, NPL)
  11349. C
  11350.       INTEGER NMAX, N, NPL
  11351. C
  11352. C     Work out how many numerals there are in an integer for use with 
  11353. C     format statements.   
  11354. C     e.g.  N=280 => NPL=3,   N=-3 => NPL=2
  11355. C
  11356. C     Input:
  11357. C       NMAX   :   If > 0, issue a warning that N is going to
  11358. C                  exceed the format statement field size if NPL 
  11359. C                  exceeds NMAX
  11360. C       N      :   Integer of interest
  11361. C     Output:
  11362. C       NPL    :   Number of numerals
  11363. C
  11364. C-
  11365. C  20-Apr-1991 -- new routine (Neil Killeen)
  11366. C-------------------------------------------------------------------------
  11367.       IF (N.EQ.0) THEN
  11368.         NPL = 1
  11369.       ELSE
  11370.         NPL = INT(LOG10(REAL(ABS(N)))) + 1
  11371.       END IF
  11372.       IF (N.LT.0) NPL = NPL + 1
  11373. C
  11374.       IF (NMAX.GT.0 .AND. NPL.GT.NMAX) 
  11375.      *  CALL GRWARN ('PGNPL: output conversion error likely; '
  11376.      *               //'number too big for format')
  11377. C
  11378.       RETURN
  11379.       END
  11380. C*PGNUMB -- convert a number into a plottable character string
  11381. C%void cpgnumb(int mm, int pp, int form, char *string, \
  11382. C% int *string_length);
  11383. C+
  11384.       SUBROUTINE PGNUMB (MM, PP, FORM, STRING, NC)
  11385.       INTEGER MM, PP, FORM
  11386.       CHARACTER*(*) STRING
  11387.       INTEGER NC
  11388. C
  11389. C This routine converts a number into a decimal character
  11390. C representation. To avoid problems of floating-point roundoff, the
  11391. C number must be provided as an integer (MM) multiplied by a power of 10
  11392. C (10**PP).  The output string retains only significant digits of MM,
  11393. C and will be in either integer format (123), decimal format (0.0123),
  11394. C or exponential format (1.23x10**5). Standard escape sequences \u, \d 
  11395. C raise the exponent and \x is used for the multiplication sign.
  11396. C This routine is used by PGBOX to create numeric labels for a plot.
  11397. C
  11398. C Formatting rules:
  11399. C   (a) Decimal notation (FORM=1):
  11400. C       - Trailing zeros to the right of the decimal sign are
  11401. C         omitted
  11402. C       - The decimal sign is omitted if there are no digits
  11403. C         to the right of it
  11404. C       - When the decimal sign is placed before the first digit
  11405. C         of the number, a zero is placed before the decimal sign
  11406. C       - The decimal sign is a period (.)
  11407. C       - No spaces are placed between digits (ie digits are not
  11408. C         grouped in threes as they should be)
  11409. C       - A leading minus (-) is added if the number is negative
  11410. C   (b) Exponential notation (FORM=2):
  11411. C       - The exponent is adjusted to put just one (non-zero)
  11412. C         digit before the decimal sign
  11413. C       - The mantissa is formatted as in (a), unless its value is
  11414. C         1 in which case it and the multiplication sign are omitted
  11415. C       - If the power of 10 is not zero and the mantissa is not
  11416. C         zero, an exponent of the form \x10\u[-]nnn is appended,
  11417. C         where \x is a multiplication sign (cross), \u is an escape
  11418. C         sequence to raise the exponent, and as many digits nnn
  11419. C         are used as needed
  11420. C   (c) Automatic choice (FORM=0):
  11421. C         Decimal notation is used if the absolute value of the
  11422. C         number is less than 10000 or greater than or equal to
  11423. C         0.01. Otherwise exponential notation is used.
  11424. C
  11425. C Arguments:
  11426. C  MM     (input)
  11427. C  PP     (input)  : the value to be formatted is MM*10**PP.
  11428. C  FORM   (input)  : controls how the number is formatted:
  11429. C                    FORM = 0 -- use either decimal or exponential
  11430. C                    FORM = 1 -- use decimal notation
  11431. C                    FORM = 2 -- use exponential notation
  11432. C  STRING (output) : the formatted character string, left justified.
  11433. C                    If the length of STRING is insufficient, a single
  11434. C                    asterisk is returned, and NC=1.
  11435. C  NC     (output) : the number of characters used in STRING:
  11436. C                    the string to be printed is STRING(1:NC).
  11437. C--
  11438. C 23-Nov-1983
  11439. C  9-Feb-1988 [TJP] - Use temporary variable to avoid illegal character
  11440. C                     assignments; remove non-standard DO loops.
  11441. C 15-Dec-1988 [TJP] - More corrections of the same sort.
  11442. C 27-Nov-1991 [TJP] - Change code for multiplication sign.
  11443. C 23-Jun-1994 [TJP] - Partial implementation of FORM=1 and 2.
  11444. C-----------------------------------------------------------------------
  11445.       CHARACTER*1 BSLASH
  11446.       CHARACTER*2 TIMES, UP, DOWN
  11447.       CHARACTER*20 WORK, WEXP, TEMP
  11448.       INTEGER M, P, ND, I, J, K, NBP
  11449.       LOGICAL MINUS
  11450. C
  11451. C Define backslash (escape) character and escape sequences.
  11452. C
  11453.       BSLASH = CHAR(92)
  11454.       TIMES  = BSLASH//'x'
  11455.       UP     = BSLASH//'u'
  11456.       DOWN   = BSLASH//'d'
  11457. C
  11458. C Zero is always printed as "0".
  11459. C
  11460.       IF (MM.EQ.0) THEN
  11461.           STRING = '0'
  11462.           NC = 1
  11463.           RETURN
  11464.       END IF
  11465. C
  11466. C If negative, make a note of that fact.
  11467. C
  11468.       MINUS = MM.LT.0
  11469.       M = ABS(MM)
  11470.       P = PP
  11471. C
  11472. C Convert M to a left-justified digit string in WORK. As M is a
  11473. C positive integer, it cannot use more than 10 digits (2147483647).
  11474. C
  11475.       J = 10
  11476.    10 IF (M.NE.0) THEN
  11477.           K = MOD(M,10)
  11478.           M = M/10
  11479.           WORK(J:J) = CHAR(ICHAR('0')+K)
  11480.           J = J-1
  11481.        GOTO 10
  11482.       END IF
  11483.       TEMP = WORK(J+1:)
  11484.       WORK = TEMP
  11485.       ND = 10-J
  11486. C
  11487. C Remove right-hand zeros, and increment P for each one removed.
  11488. C ND is the final number of significant digits in WORK, and P the
  11489. C power of 10 to be applied. Number of digits before decimal point
  11490. C is NBP.
  11491. C
  11492.    20 IF (WORK(ND:ND).EQ.'0') THEN
  11493.           ND = ND-1
  11494.           P = P+1
  11495.        GOTO 20
  11496.       END IF
  11497.       NBP = ND+MIN(P,0)
  11498. C
  11499. C Integral numbers of 4 or less digits are formatted as such.
  11500. C
  11501.       IF ((P.GE.0) .AND. ((FORM.EQ.0 .AND. P+ND.LE.4) .OR.
  11502.      :                    (FORM.EQ.1 .AND. P+ND.LE.10))) THEN
  11503.           DO 30 I=1,P
  11504.               ND = ND+1
  11505.               WORK(ND:ND) = '0'
  11506.    30     CONTINUE
  11507.           P = 0
  11508. C
  11509. C If NBP is 4 or less, simply insert a decimal point in the right place.
  11510. C
  11511.       ELSE IF (FORM.NE.2.AND.NBP.GE.1.AND.NBP.LE.4.AND.NBP.LT.ND) THEN
  11512.           TEMP = WORK(NBP+1:ND)
  11513.           WORK(NBP+2:ND+1) = TEMP
  11514.           WORK(NBP+1:NBP+1) = '.'
  11515.           ND = ND+1
  11516.           P = 0
  11517. C
  11518. C Otherwise insert a decimal point after the first digit, and adjust P.
  11519. C
  11520.       ELSE
  11521.           P = P + ND - 1
  11522.           IF (FORM.NE.2 .AND. P.EQ.-1) THEN
  11523.               TEMP = WORK
  11524.               WORK = '0'//TEMP
  11525.               ND = ND+1
  11526.               P = 0
  11527.           ELSE IF (FORM.NE.2 .AND. P.EQ.-2) THEN
  11528.               TEMP = WORK
  11529.               WORK = '00'//TEMP
  11530.               ND = ND+2
  11531.               P = 0
  11532.           END IF
  11533.           IF (ND.GT.1) THEN
  11534.               TEMP = WORK(2:ND)
  11535.               WORK(3:ND+1) = TEMP
  11536.               WORK(2:2) = '.'
  11537.               ND = ND + 1
  11538.           END IF
  11539.       END IF
  11540. C
  11541. C Add exponent if necessary.
  11542. C
  11543.       IF (P.NE.0) THEN
  11544.           WORK(ND+1:ND+6) = TIMES//'10'//UP
  11545.           ND = ND+6
  11546.           IF (P.LT.0) THEN
  11547.               P = -P
  11548.               ND = ND+1
  11549.               WORK(ND:ND) = '-'
  11550.           END IF
  11551.           J = 10
  11552.    40     IF (P.NE.0) THEN
  11553.               K = MOD(P,10)
  11554.               P = P/10
  11555.               WEXP(J:J) = CHAR(ICHAR('0')+K)
  11556.               J = J-1
  11557.            GOTO 40
  11558.           END IF
  11559.           WORK(ND+1:) = WEXP(J+1:10)
  11560.           ND = ND+10-J
  11561.           IF (WORK(1:3).EQ.'1'//TIMES) THEN
  11562.               TEMP = WORK(4:)
  11563.               WORK = TEMP
  11564.               ND = ND-3
  11565.           END IF
  11566.           WORK(ND+1:ND+2) = DOWN
  11567.           ND = ND+2
  11568.       END IF
  11569. C
  11570. C Add minus sign if necessary and move result to output.
  11571. C
  11572.       IF (MINUS) THEN
  11573.          TEMP = WORK(1:ND)
  11574.          STRING = '-'//TEMP
  11575.          NC = ND+1
  11576.       ELSE
  11577.          STRING = WORK(1:ND)
  11578.          NC = ND
  11579.       END IF
  11580. C
  11581. C Check result fits.
  11582. C
  11583.       IF (NC.GT.LEN(STRING)) THEN
  11584.           STRING = '*'
  11585.           NC = 1
  11586.       END IF
  11587.       END
  11588. C*PGOLIN -- mark a set of points using the cursor
  11589. C%void cpgolin(int maxpt, int *npt, float *x, float *y, int symbol);
  11590. C+
  11591.       SUBROUTINE PGOLIN (MAXPT, NPT, X, Y, SYMBOL)
  11592.       INTEGER MAXPT, NPT
  11593.       REAL    X(*), Y(*)
  11594.       INTEGER SYMBOL
  11595. C
  11596. C Interactive routine for user to enter data points by use of
  11597. C the cursor.  Routine allows user to Add and Delete points.  The
  11598. C points are returned in the order that they were entered (unlike
  11599. C PGNCUR).
  11600. C
  11601. C Arguments:
  11602. C  MAXPT  (input)  : maximum number of points that may be accepted.
  11603. C  NPT    (in/out) : number of points entered; should be zero on
  11604. C                    first call.
  11605. C  X      (in/out) : array of x-coordinates.
  11606. C  Y      (in/out) : array of y-coordinates.
  11607. C  SYMBOL (input)  : code number of symbol to use for marking
  11608. C                    entered points (see PGPT).
  11609. C
  11610. C Note (1): The dimension of arrays X and Y must be greater than or
  11611. C equal to MAXPT.
  11612. C
  11613. C Note (2): On return from the program, cursor points are returned in
  11614. C the order they were entered. Routine may be (re-)called with points
  11615. C already defined in X,Y (number in NPT), and they will be plotted
  11616. C first, before editing.
  11617. C
  11618. C Note (3): User commands: the user types single-character commands
  11619. C after positioning the cursor: the following are accepted:
  11620. C A (Add)    - add point at current cursor location.
  11621. C D (Delete) - delete the last point entered.
  11622. C X (eXit)   - leave subroutine.
  11623. C--
  11624. C  4-Nov-1985 - new routine (adapted from PGNCUR) - TJP.
  11625. C 13-Dec-1990 - change warnings to messages [TJP].
  11626. C  7-Sep-1994 - use PGBAND [TJP].
  11627. C  2-Aug-1995 - remove dependence on common block [TJP].
  11628. C-----------------------------------------------------------------------
  11629.       LOGICAL  PGNOTO
  11630.       CHARACTER*1 LETTER
  11631.       INTEGER  PGBAND, SAVCOL
  11632.       REAL     XP, YP, XREF, YREF
  11633.       REAL     XBLC, XTRC, YBLC, YTRC
  11634. C
  11635. C Check that PGPLOT is in the correct state.
  11636. C
  11637.       IF (PGNOTO('PGOLIN')) RETURN
  11638. C
  11639. C Save current color.
  11640. C
  11641.       CALL GRQCI(SAVCOL)
  11642. C
  11643. C Put current points on screen.  Position cursor on last point,
  11644. C or in middle viewport if there are no current points.
  11645. C
  11646.       CALL PGQWIN(XBLC, XTRC, YBLC, YTRC)
  11647.       IF (NPT.NE.0) THEN
  11648.           CALL PGPT(NPT,X,Y,SYMBOL)
  11649.           XP = X(NPT)
  11650.           YP = Y(NPT)
  11651.       ELSE
  11652.           XP = 0.5*(XBLC+XTRC)
  11653.           YP = 0.5*(YBLC+YTRC)
  11654.       END IF
  11655. C
  11656. C Loop over cursor inputs.
  11657. C
  11658.   100 XREF = XP
  11659.       YREF = YP
  11660.       IF (PGBAND(0,1,XREF,YREF,XP,YP,LETTER).NE.1) RETURN
  11661.       IF (LETTER.EQ.CHAR(0)) RETURN
  11662.       CALL GRTOUP(LETTER,LETTER)
  11663. C
  11664. C A (ADD) command:
  11665. C
  11666.       IF (LETTER .EQ. 'A') THEN
  11667.           IF (NPT.GE.MAXPT) THEN
  11668.               CALL GRMSG('ADD ignored (too many points).')
  11669.           ELSE
  11670.               NPT = NPT + 1
  11671.               X(NPT) = XP
  11672.               Y(NPT) = YP
  11673.               CALL PGPT(1,X(NPT),Y(NPT),SYMBOL)
  11674.               CALL GRTERM
  11675.           END IF
  11676. C
  11677. C D (DELETE) command:
  11678. C
  11679.       ELSE IF (LETTER.EQ.'D') THEN
  11680.           IF (NPT.LE.0) THEN
  11681.               CALL GRMSG('DELETE ignored (there are no points left).')
  11682.           ELSE
  11683.               CALL GRSCI(0)
  11684.               CALL PGPT(1,X(NPT),Y(NPT),SYMBOL)
  11685.               XP = X(NPT)
  11686.               YP = Y(NPT)
  11687.               CALL GRSCI(SAVCOL)
  11688.               CALL GRTERM
  11689.               NPT = NPT-1
  11690.           END IF
  11691. C
  11692. C X (EXIT) command:
  11693. C
  11694.       ELSE IF (LETTER.EQ.'X') THEN
  11695.           CALL GRETXT
  11696.           RETURN
  11697. C
  11698. C Illegal command:
  11699. C
  11700.       ELSE
  11701.           CALL GRMSG('Commands are A (add), D (delete), X (exit).')
  11702.       END IF
  11703. C
  11704.       GOTO 100
  11705.       END
  11706. C*PGOPEN -- open a graphics device
  11707. C%int cpgopen(const char *device);
  11708. C+
  11709.       INTEGER FUNCTION PGOPEN (DEVICE)
  11710.       CHARACTER*(*) DEVICE
  11711. C
  11712. C Open a graphics device for PGPLOT output. If the device is
  11713. C opened successfully, it becomes the selected device to which
  11714. C graphics output is directed until another device is selected
  11715. C with PGSLCT or the device is closed with PGCLOS.
  11716. C
  11717. C The value returned by PGOPEN should be tested to ensure that
  11718. C the device was opened successfully, e.g.,
  11719. C
  11720. C       ISTAT = PGOPEN('plot.ps/PS')
  11721. C       IF (ISTAT .LE. 0 ) STOP
  11722. C
  11723. C Note that PGOPEN must be declared INTEGER in the calling program.
  11724. C
  11725. C The DEVICE argument is a character constant or variable; its value
  11726. C should be one of the following:
  11727. C
  11728. C (1) A complete device specification of the form 'device/type' or
  11729. C     'file/type', where 'type' is one of the allowed PGPLOT device
  11730. C     types (installation-dependent) and 'device' or 'file' is the 
  11731. C     name of a graphics device or disk file appropriate for this type.
  11732. C     The 'device' or 'file' may contain '/' characters; the final
  11733. C     '/' delimits the 'type'. If necessary to avoid ambiguity,
  11734. C     the 'device' part of the string may be enclosed in double
  11735. C     quotation marks.
  11736. C (2) A device specification of the form '/type', where 'type' is one
  11737. C     of the allowed PGPLOT device types. PGPLOT supplies a default
  11738. C     file or device name appropriate for this device type.
  11739. C (3) A device specification with '/type' omitted; in this case
  11740. C     the type is taken from the environment variable PGPLOT_TYPE,
  11741. C     if defined (e.g., setenv PGPLOT_TYPE PS). Because of possible
  11742. C     confusion with '/' in file-names, omitting the device type
  11743. C     in this way is not recommended.
  11744. C (4) A blank string (' '); in this case, PGOPEN will use the value
  11745. C     of environment variable PGPLOT_DEV as the device specification,
  11746. C     or '/NULL' if the environment variable is undefined.
  11747. C (5) A single question mark, with optional trailing spaces ('?'); in
  11748. C     this case, PGPLOT will prompt the user to supply the device
  11749. C     specification, with a prompt string of the form
  11750. C         'Graphics device/type (? to see list, default XXX):'
  11751. C     where 'XXX' is the default (value of environment variable
  11752. C     PGPLOT_DEV).
  11753. C (6) A non-blank string in which the first character is a question
  11754. C     mark (e.g., '?Device: '); in this case, PGPLOT will prompt the
  11755. C     user to supply the device specification, using the supplied
  11756. C     string as the prompt (without the leading question mark but
  11757. C     including any trailing spaces).
  11758. C
  11759. C In cases (5) and (6), the device specification is read from the
  11760. C standard input. The user should respond to the prompt with a device
  11761. C specification of the form (1), (2), or (3). If the user types a 
  11762. C question-mark in response to the prompt, a list of available device
  11763. C types is displayed and the prompt is re-issued. If the user supplies
  11764. C an invalid device specification, the prompt is re-issued. If the user
  11765. C responds with an end-of-file character, e.g., ctrl-D in UNIX, program
  11766. C execution is aborted; this  avoids the possibility of an infinite
  11767. C prompting loop.  A programmer should avoid use of PGPLOT-prompting
  11768. C if this behavior is not desirable.
  11769. C
  11770. C The device type is case-insensitive (e.g., '/ps' and '/PS' are 
  11771. C equivalent). The device or file name may be case-sensitive in some
  11772. C operating systems.
  11773. C
  11774. C Examples of valid DEVICE arguments:
  11775. C
  11776. C (1)  'plot.ps/ps', 'dir/plot.ps/ps', '"dir/plot.ps"/ps', 
  11777. C      'user:[tjp.plots]plot.ps/PS'
  11778. C (2)  '/ps'      (PGPLOT interprets this as 'pgplot.ps/ps')
  11779. C (3)  'plot.ps'  (if PGPLOT_TYPE is defined as 'ps', PGPLOT
  11780. C                  interprets this as 'plot.ps/ps')
  11781. C (4)  '   '      (if PGPLOT_DEV is defined)
  11782. C (5)  '?  '
  11783. C (6)  '?Device specification for PGPLOT: '
  11784. C
  11785. C [This routine was added to PGPLOT in Version 5.1.0. Older programs
  11786. C use PGBEG instead.]
  11787. C
  11788. C Returns:
  11789. C  PGOPEN          : returns either a positive value, the
  11790. C                    identifier of the graphics device for use with
  11791. C                    PGSLCT, or a 0 or negative value indicating an
  11792. C                    error. In the event of error a message is
  11793. C                    written on the standard error unit.
  11794. C Arguments:
  11795. C  DEVICE  (input) : the 'device specification' for the plot device
  11796. C                    (see above).
  11797. C--
  11798. C 22-Dec-1995 - new routine [TJP].
  11799. C 14-May-1996 - device '? ' should not give a blank prompt [TJP].
  11800. C-----------------------------------------------------------------------
  11801.       INCLUDE       'f77.PGPLOT/IN'
  11802.       INTEGER       DEFTYP,GRDTYP,GROPEN,L,LR,IC1, LPROMP
  11803.       INTEGER       GRGCOM, IER, LDEFDE, UNIT, ISTAT
  11804.       REAL          DUMMY,DUMMY2,XCSZ, XSZ, YSZ
  11805.       CHARACTER*128 DEFDEV, PROMPT
  11806.       CHARACTER*20  DEFSTR
  11807.       CHARACTER*256 REQ
  11808.       LOGICAL JUNK
  11809. C
  11810. C Initialize PGPLOT if necessary.
  11811. C
  11812.       CALL PGINIT
  11813. C
  11814. C Get the default device/type (environment variable PGPLOT_DEV).
  11815. C
  11816.       CALL GRGENV('DEV', DEFDEV, LDEFDE)
  11817.       IF (LDEFDE.EQ.0) THEN
  11818.          DEFDEV = '/NULL'
  11819.          LDEFDE = 5
  11820.       END IF
  11821. C
  11822. C Open the plot file; default type is given by environment variable
  11823. C PGPLOT_TYPE.
  11824. C
  11825.       CALL GRGENV('TYPE', DEFSTR, L)
  11826.       IF (L.EQ.0) THEN
  11827.           DEFTYP = 0
  11828.       ELSE
  11829.           CALL GRTOUP(DEFSTR, DEFSTR)
  11830.           DEFTYP = GRDTYP(DEFSTR(1:L))
  11831.       END IF
  11832.       IF (DEVICE.EQ.' ') THEN
  11833. C        -- Blank device string: use default device and type.
  11834.          ISTAT = GROPEN(DEFTYP,UNIT,DEFDEV(1:LDEFDE),PGID)
  11835.       ELSE IF (DEVICE(1:1).EQ.'?') THEN
  11836.          IF (DEVICE.EQ.'?') THEN
  11837. C           -- Device string is a ingle question mark: prompt user
  11838. C           -- for device/type
  11839.             PROMPT = 'Graphics device/type (? to see list, default '
  11840.      :           //DEFDEV(1:LDEFDE)//'): '
  11841.             LPROMP = LDEFDE + 48
  11842.          ELSE
  11843. C           -- Device string starts with a question mark: use it
  11844. C           -- as a prompt
  11845.             PROMPT = DEVICE(2:)
  11846.             LPROMP = LEN(DEVICE)-1
  11847.          END IF
  11848.    10    IER = GRGCOM(REQ, PROMPT(1:LPROMP), LR)
  11849.          IF (IER.NE.1) THEN
  11850.             CALL GRWARN('Error reading device specification')
  11851.             PGOPEN = -1
  11852.             RETURN
  11853.          END IF
  11854.          IF (LR.LT.1 .OR. REQ.EQ.' ') THEN
  11855.             REQ = DEFDEV(1:LDEFDE)
  11856.          ELSE IF (REQ(1:1).EQ.'?') THEN
  11857.             CALL PGLDEV
  11858.             GOTO 10
  11859.          END IF
  11860.          ISTAT = GROPEN(DEFTYP,UNIT,REQ,PGID)
  11861.          IF (ISTAT.NE.1) GOTO 10
  11862.       ELSE
  11863.           ISTAT = GROPEN(DEFTYP,UNIT,DEVICE,PGID)
  11864.       END IF
  11865. C
  11866. C Failed to open plot file?
  11867. C
  11868.       IF (ISTAT.NE.1) THEN
  11869.          PGOPEN = - 1
  11870.          RETURN
  11871.       END IF
  11872. C
  11873. C Success: determine device characteristics.
  11874. C
  11875.       IF (PGID.LT.0 .OR. PGID.GT.PGMAXD) CALL
  11876.      1       GRWARN('Something terribly wrong in PGOPEN')
  11877.       PGDEVS(PGID) = 1
  11878.       PGADVS(PGID) = 0
  11879.       PGPFIX(PGID) = .FALSE.
  11880.       CALL GRSIZE(PGID,XSZ,YSZ,DUMMY,DUMMY2,
  11881.      1            PGXPIN(PGID),PGYPIN(PGID))
  11882.       CALL GRCHSZ(PGID,XCSZ,DUMMY,PGXSP(PGID),PGYSP(PGID))
  11883.       PGROWS(PGID)= .TRUE.
  11884.       PGNX(PGID)  = 1
  11885.       PGNY(PGID)  = 1
  11886.       PGXSZ(PGID) = XSZ
  11887.       PGYSZ(PGID) = YSZ
  11888.       PGNXC(PGID) = 1
  11889.       PGNYC(PGID) = 1
  11890.       CALL GRQTYP(DEFSTR,JUNK)
  11891. C
  11892. C Set the prompt state to ON, so that terminal devices pause between
  11893. C pages; this can be changed with PGASK.
  11894. C
  11895.       CALL PGASK(.TRUE.)
  11896. C
  11897. C If environment variable PGPLOT_BUFFER is defined (any value),
  11898. C start buffering output.
  11899. C
  11900.       PGBLEV(PGID) = 0
  11901.       CALL GRGENV('BUFFER', DEFSTR, L)
  11902.       IF (L.GT.0) CALL PGBBUF
  11903. C
  11904. C Set background and foreground colors if requested.
  11905. C
  11906.       CALL GRGENV('BACKGROUND', DEFSTR, L)
  11907.       IF (L.GT.0) CALL PGSCRN(0, DEFSTR(1:L), IER)
  11908.       CALL GRGENV('FOREGROUND', DEFSTR, L)
  11909.       IF (L.GT.0) CALL PGSCRN(1, DEFSTR(1:L), IER)
  11910. C
  11911. C Set default attributes.
  11912. C
  11913.       CALL PGSCI(1)
  11914.       CALL PGSLS(1)
  11915.       CALL PGSLW(1)
  11916.       CALL PGSCH(1.0)
  11917.       CALL PGSCF(1)
  11918.       CALL PGSFS(1)
  11919.       CALL PGSAH(1, 45.0, 0.3)
  11920.       CALL PGSTBG(-1)
  11921.       CALL PGSHS(45.0, 1.0, 0.0)
  11922.       CALL PGSCLP(1)
  11923. C
  11924. C Set the default range of color indices available for images (16 to
  11925. C device maximum, if device maximum >= 16; otherwise not possible).
  11926. C Select linear transfer function.
  11927. C
  11928.       CALL GRQCOL(IC1, PGMXCI(PGID))
  11929.       PGMNCI(PGID) = 16
  11930.       IF (PGMXCI(PGID).LT.16) PGMXCI(PGID) = 0
  11931.       PGITF(PGID) = 0
  11932. C
  11933. C Set the default window (unit square).
  11934. C
  11935.       PGXBLC(PGID) = 0.0
  11936.       PGXTRC(PGID) = 1.0
  11937.       PGYBLC(PGID) = 0.0
  11938.       PGYTRC(PGID) = 1.0
  11939. C
  11940. C Set the default viewport.
  11941. C
  11942.       CALL PGVSTD
  11943. C
  11944.       PGOPEN = PGID
  11945.       RETURN
  11946.       END
  11947. C*PGPAGE -- advance to new page
  11948. C%void cpgpage(void);
  11949. C+
  11950.       SUBROUTINE PGPAGE
  11951. C
  11952. C Advance plotter to a new page or panel, clearing the screen if
  11953. C necessary. If the "prompt state" is ON (see PGASK), confirmation is
  11954. C requested from the user before clearing the screen. If the view
  11955. C surface has been subdivided into panels with PGBEG or PGSUBP, then
  11956. C PGPAGE advances to the next panel, and if the current panel is the
  11957. C last on the page, PGPAGE clears the screen or starts a new sheet of
  11958. C paper.  PGPAGE does not change the PGPLOT window or the viewport
  11959. C (in normalized device coordinates); but note that if the size of the
  11960. C view-surface is changed externally (e.g., by a workstation window
  11961. C manager) the size of the viewport is changed in proportion.
  11962. C
  11963. C Arguments: none
  11964. C--
  11965. C  7-Feb-1983
  11966. C 23-Sep-1984 - correct bug: call GRTERM at end (if flush mode set).
  11967. C 31-Jan-1985 - make closer to Fortran-77.
  11968. C 19-Nov-1987 - explicitly clear the screen if device is interactive;
  11969. C               this restores the behavior obtained with older versions
  11970. C               of GRPCKG.
  11971. C  9-Feb-1988 - move prompting into routine GRPROM.
  11972. C 11-Apr-1989 - change name to PGPAGE.
  11973. C 10-Sep-1990 - add identification labelling.
  11974. C 11-Feb-1992 - check if device size has changed.
  11975. C  3-Sep-1992 - allow column ordering of panels.
  11976. C 17-Nov-1994 - move identification to drivers.
  11977. C 23-Nov-1994 - fix bug: character size not getting reset.
  11978. C 23-Jan-1995 - rescale viewport if size of view surface  has changed.
  11979. C  4-Feb-1997 - bug fix; character size was not correctly indexed by
  11980. C               device ID.
  11981. C-----------------------------------------------------------------------
  11982.       INCLUDE      'f77.PGPLOT/IN'
  11983.       CHARACTER*16 STR
  11984.       LOGICAL      INTER, PGNOTO
  11985.       REAL DUM1, DUM2, XS, YS, XVP1, XVP2, YVP1, YVP2
  11986. C
  11987.       IF (PGNOTO('PGPAGE')) RETURN
  11988. C
  11989.       IF (PGROWS(PGID)) THEN
  11990.         PGNXC(PGID) = PGNXC(PGID) + 1
  11991.         IF (PGNXC(PGID).GT.PGNX(PGID)) THEN
  11992.           PGNXC(PGID) = 1
  11993.           PGNYC(PGID) = PGNYC(PGID) + 1
  11994.           IF (PGNYC(PGID).GT.PGNY(PGID)) PGNYC(PGID) = 1
  11995.         END IF
  11996.       ELSE
  11997.         PGNYC(PGID) = PGNYC(PGID) + 1
  11998.         IF (PGNYC(PGID).GT.PGNY(PGID)) THEN
  11999.           PGNYC(PGID) = 1
  12000.           PGNXC(PGID) = PGNXC(PGID) + 1
  12001.           IF (PGNXC(PGID).GT.PGNX(PGID)) PGNXC(PGID) = 1
  12002.         END IF
  12003.       END IF
  12004.       IF (PGNXC(PGID).EQ.1 .AND. PGNYC(PGID).EQ.1) THEN
  12005.           IF (PGADVS(PGID).EQ.1 .AND. PGPRMP(PGID)) THEN
  12006.               CALL GRTERM
  12007.               CALL GRPROM
  12008.           END IF
  12009.           CALL GRPAGE
  12010.           IF (.NOT.PGPFIX(PGID)) THEN
  12011. C             -- Get current viewport in NDC.
  12012.               CALL PGQVP(0, XVP1, XVP2, YVP1, YVP2)
  12013. C             -- Reset view surface size if it has changed
  12014.               CALL GRSIZE(PGID, XS,YS, DUM1,DUM2,
  12015.      1                    PGXPIN(PGID), PGYPIN(PGID))
  12016.               PGXSZ(PGID) = XS/PGNX(PGID)
  12017.               PGYSZ(PGID) = YS/PGNY(PGID)
  12018. C             -- and character size
  12019.               CALL PGSCH(PGCHSZ(PGID))
  12020. C             -- and viewport
  12021.               CALL PGSVP(XVP1, XVP2, YVP1, YVP2)
  12022.           END IF
  12023. C
  12024. C If the device is interactive, call GRBPIC to clear the page.
  12025. C (If the device is not interactive, GRBPIC will be called
  12026. C automatically before the first output; omitting the call here
  12027. C ensures that a blank page is not output.)
  12028. C
  12029.           CALL GRQTYP(STR,INTER)
  12030.           IF (INTER) CALL GRBPIC
  12031.       END IF
  12032.       PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  12033.       PGYOFF(PGID) = PGYVP(PGID) + 
  12034.      1               (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  12035. C
  12036. C Window the plot in the new viewport.
  12037. C
  12038.       CALL PGVW
  12039.       PGADVS(PGID) = 1
  12040.       CALL GRTERM
  12041.       END
  12042. C*PGPANL -- switch to a different panel on the view surface
  12043. C%void cpgpanl(int nxc, int nyc);
  12044. C+
  12045.       SUBROUTINE PGPANL(IX, IY)
  12046.       INTEGER IX, IY
  12047. C
  12048. C Start plotting in a different panel. If the view surface has been
  12049. C divided into panels by PGBEG or PGSUBP, this routine can be used to
  12050. C move to a different panel. Note that PGPLOT does not remember what
  12051. C viewport and window were in use in each panel; these should be reset
  12052. C if necessary after calling PGPANL. Nor does PGPLOT clear the panel:
  12053. C call PGERAS after calling PGPANL to do this.
  12054. C
  12055. C Arguments:
  12056. C  IX     (input)  : the horizontal index of the panel (in the range
  12057. C                    1 <= IX <= number of panels in horizontal
  12058. C                    direction).
  12059. C  IY     (input)  : the vertical index of the panel (in the range
  12060. C                    1 <= IY <= number of panels in horizontal
  12061. C                    direction).
  12062. C--
  12063. C  1-Dec-1994 - new routine [TJP].
  12064. C-----------------------------------------------------------------------
  12065.       INCLUDE      'f77.PGPLOT/IN'
  12066.       LOGICAL PGNOTO
  12067. C
  12068. C Check that a device is open.
  12069. C
  12070.       IF (PGNOTO('PGPANL')) RETURN
  12071. C
  12072. C Check arguments.
  12073. C
  12074.       IF (IX.LT.1 .OR. IX.GT.PGNX(PGID) .OR.
  12075.      :    IY.LT.1 .OR. IY.GT.PGNY(PGID)) THEN
  12076.          CALL GRWARN('PGPANL: the requested panel does not exist')
  12077. C
  12078. C Adjust the viewport to the new panel and window the plot
  12079. C in the new viewport.
  12080. C
  12081.       ELSE
  12082.          PGNXC(PGID)  = IX
  12083.          PGNYC(PGID)  = IY
  12084.          PGXOFF(PGID) = PGXVP(PGID) + (IX-1)*PGXSZ(PGID)
  12085.          PGYOFF(PGID) = PGYVP(PGID) + (PGNY(PGID)-IY)*PGYSZ(PGID)
  12086.          CALL PGVW
  12087.       END IF
  12088. C
  12089.       END
  12090. C*PGPAP -- change the size of the view surface 
  12091. C%void cpgpap(float width, float aspect);
  12092. C+
  12093.       SUBROUTINE PGPAP (WIDTH, ASPECT)
  12094.       REAL WIDTH, ASPECT
  12095. C
  12096. C This routine changes the size of the view surface ("paper size") to a
  12097. C specified width and aspect ratio (height/width), in so far as this is
  12098. C possible on the specific device. It is always possible to obtain a
  12099. C view surface smaller than the default size; on some devices (e.g.,
  12100. C printers that print on roll or fan-feed paper) it is possible to 
  12101. C obtain a view surface larger than the default.
  12102. C 
  12103. C This routine should be called either immediately after PGBEG or
  12104. C immediately before PGPAGE. The new size applies to all subsequent
  12105. C images until the next call to PGPAP.
  12106. C
  12107. C Arguments:
  12108. C  WIDTH  (input)  : the requested width of the view surface in inches;
  12109. C                    if WIDTH=0.0, PGPAP will obtain the largest view
  12110. C                    surface available consistent with argument ASPECT.
  12111. C                    (1 inch = 25.4 mm.)
  12112. C  ASPECT (input)  : the aspect ratio (height/width) of the view
  12113. C                    surface; e.g., ASPECT=1.0 gives a square view
  12114. C                    surface, ASPECT=0.618 gives a horizontal
  12115. C                    rectangle, ASPECT=1.618 gives a vertical rectangle.
  12116. C--
  12117. C (22-Apr-1983; bug fixed 7-Jun-1988)
  12118. C  6-Oct-1990 Modified to work correctly on interactive devices.
  12119. C 13-Dec-1990 Make errors non-fatal [TJP].
  12120. C 14-Sep-1994 Fix bug to do with drivers changing view surface size.
  12121. C-----------------------------------------------------------------------
  12122.       INCLUDE  'f77.PGPLOT/IN'
  12123.       LOGICAL  PGNOTO
  12124.       REAL     HDEF, HMAX, HREQ, WDEF, WMAX, WREQ
  12125.       REAL     XSMAX, YSMAX, XSZ, YSZ
  12126. C
  12127.       IF (PGNOTO('PGPAP'))  RETURN
  12128.       IF (WIDTH.LT.0.0 .OR. ASPECT.LE.0.0) THEN
  12129.           CALL GRWARN('PGPAP ignored: invalid arguments')
  12130.           RETURN
  12131.       END IF
  12132. C
  12133.       PGPFIX(PGID) = .TRUE.
  12134. C     -- Find default size WDEF, HDEF and maximum size WMAX, HMAX
  12135. C        of view surface (inches)
  12136.       CALL GRSIZE(PGID,XSZ,YSZ,XSMAX,YSMAX,
  12137.      1            PGXPIN(PGID),PGYPIN(PGID))
  12138.       WDEF = XSZ/PGXPIN(PGID)
  12139.       HDEF = YSZ/PGYPIN(PGID)
  12140.       WMAX = XSMAX/PGXPIN(PGID)
  12141.       HMAX = YSMAX/PGYPIN(PGID)
  12142. C     -- Find desired size WREQ, HREQ of view surface (inches)
  12143.       IF (WIDTH.NE.0.0) THEN
  12144.           WREQ = WIDTH
  12145.           HREQ = WIDTH*ASPECT
  12146.       ELSE
  12147.           WREQ = WDEF
  12148.           HREQ = WDEF*ASPECT
  12149.           IF (HREQ.GT.HDEF) THEN
  12150.               WREQ = HDEF/ASPECT
  12151.               HREQ = HDEF
  12152.           END IF
  12153.       END IF
  12154. C     -- Scale the requested view surface to fit the maximum
  12155. C        dimensions
  12156.       IF (WMAX.GT.0.0 .AND. WREQ.GT.WMAX) THEN
  12157.           WREQ = WMAX
  12158.           HREQ = WMAX*ASPECT
  12159.       END IF
  12160.       IF (HMAX.GT.0.0 .AND. HREQ.GT.HMAX) THEN
  12161.           WREQ = HMAX/ASPECT
  12162.           HREQ = HMAX
  12163.       END IF
  12164. C     -- Establish the new view surface dimensions
  12165.       XSZ = WREQ*PGXPIN(PGID)
  12166.       YSZ = HREQ*PGYPIN(PGID)
  12167.       CALL GRSETS(PGID,XSZ,YSZ)
  12168.       PGXSZ(PGID) = XSZ/PGNX(PGID)
  12169.       PGYSZ(PGID) = YSZ/PGNY(PGID)
  12170.       PGNXC(PGID) = PGNX(PGID)
  12171.       PGNYC(PGID) = PGNY(PGID)
  12172.       CALL PGSCH(1.0)
  12173.       CALL PGVSTD
  12174.       END
  12175. C*PGPAPER -- non-standard alias for PGPAP
  12176. C+
  12177.       SUBROUTINE PGPAPER (WIDTH, ASPECT)
  12178.       REAL WIDTH, ASPECT
  12179. C
  12180. C See description of PGPAP.
  12181. C--
  12182.       CALL PGPAP (WIDTH, ASPECT)
  12183.       END
  12184. C*PGPIXL -- draw pixels
  12185. C%void cpgpixl(const int *ia, int idim, int jdim, int i1, int i2, \
  12186. C% int j1, int j2, float x1, float x2, float y1, float y2);
  12187. C+
  12188.       SUBROUTINE PGPIXL (IA, IDIM, JDIM, I1, I2, J1, J2, 
  12189.      1                   X1, X2, Y1, Y2)
  12190.       INTEGER IDIM, JDIM, I1, I2, J1, J2
  12191.       INTEGER IA(IDIM,JDIM)
  12192.       REAL    X1, X2, Y1, Y2
  12193. C
  12194. C Draw lots of solid-filled (tiny) rectangles aligned with the
  12195. C coordinate axes. Best performance is achieved when output is
  12196. C directed to a pixel-oriented device and the rectangles coincide
  12197. C with the pixels on the device. In other cases, pixel output is
  12198. C emulated.
  12199. C
  12200. C The subsection of the array IA defined by indices (I1:I2, J1:J2)
  12201. C is mapped onto world-coordinate rectangle defined by X1, X2, Y1
  12202. C and Y2. This rectangle is divided into (I2 - I1 + 1) * (J2 - J1 + 1)
  12203. C small rectangles. Each of these small rectangles is solid-filled
  12204. C with the color index specified by the corresponding element of 
  12205. C IA.
  12206. C
  12207. C On most devices, the output region is "opaque", i.e., it obscures
  12208. C all graphical elements previously drawn in the region. But on
  12209. C devices that do not have erase capability, the background shade
  12210. C is "transparent" and allows previously-drawn graphics to show
  12211. C through.
  12212. C
  12213. C Arguments:
  12214. C  IA     (input)  : the array to be plotted.
  12215. C  IDIM   (input)  : the first dimension of array A.
  12216. C  JDIM   (input)  : the second dimension of array A.
  12217. C  I1, I2 (input)  : the inclusive range of the first index
  12218. C                    (I) to be plotted.
  12219. C  J1, J2 (input)  : the inclusive range of the second
  12220. C                    index (J) to be plotted.
  12221. C  X1, Y1 (input)  : world coordinates of one corner of the output
  12222. C                    region
  12223. C  X2, Y2 (input)  : world coordinates of the opposite corner of the
  12224. C                    output region
  12225. C--
  12226. C 16-Jan-1991 - [GvG]
  12227. C-----------------------------------------------------------------------
  12228.       LOGICAL PGNOTO
  12229. C
  12230. C Check inputs.
  12231. C
  12232.       IF (PGNOTO('PGPIXL')) RETURN
  12233.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GT.I2 .OR.
  12234.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GT.J2) THEN
  12235.          CALL GRWARN('PGPIXL: invalid range I1:I2, J1:J2')
  12236.       ELSE
  12237. C
  12238. C Call lower-level routine to do the work.
  12239. C
  12240.          CALL PGBBUF
  12241.          CALL GRPIXL(IA, IDIM, JDIM, I1, I2, J1, J2, X1, X2, Y1, Y2)
  12242.          CALL PGEBUF
  12243.       END IF
  12244. C-----------------------------------------------------------------------
  12245.       END
  12246. C*PGPNTS -- draw several graph markers, not all the same
  12247. C%void cpgpnts(int n, const float *x, const float *y, \
  12248. C% const int *symbol, int ns);
  12249. C+
  12250.       SUBROUTINE PGPNTS (N, X, Y, SYMBOL, NS)
  12251.       INTEGER N, NS
  12252.       REAL X(*), Y(*)
  12253.       INTEGER SYMBOL(*)
  12254. C
  12255. C Draw Graph Markers. Unlike PGPT, this routine can draw a different
  12256. C symbol at each point. The markers are drawn using the current values
  12257. C of attributes color-index, line-width, and character-height
  12258. C (character-font applies if the symbol number is >31).  If the point
  12259. C to be marked lies outside the window, no marker is drawn.  The "pen 
  12260. C position" is changed to (XPTS(N),YPTS(N)) in world coordinates
  12261. C (if N > 0).
  12262. C
  12263. C Arguments:
  12264. C  N      (input)  : number of points to mark.
  12265. C  X      (input)  : world x-coordinate of the points.
  12266. C  Y      (input)  : world y-coordinate of the points.
  12267. C  SYMBOL (input)  : code number of the symbol to be plotted at each
  12268. C                    point (see PGPT).
  12269. C  NS     (input)  : number of values in the SYMBOL array.  If NS <= N,
  12270. C                    then the first NS points are drawn using the value
  12271. C                    of SYMBOL(I) at (X(I), Y(I)) and SYMBOL(1) for all
  12272. C                    the values of (X(I), Y(I)) where I > NS.
  12273. C
  12274. C Note: the dimension of arrays X and Y must be greater than or equal
  12275. C to N and the dimension of the array SYMBOL must be greater than or
  12276. C equal to NS.  If N is 1, X and Y may be scalars (constants or
  12277. C variables).  If NS is 1, then SYMBOL may be a scalar.  If N is
  12278. C less than 1, nothing is drawn.
  12279. C--
  12280. C 11-Mar-1991 - new routine [JM].
  12281. C 26-Feb-1997 - revised to use PGPT1 [TJP].
  12282. C-----------------------------------------------------------------------
  12283.       INTEGER I, SYMB
  12284. C
  12285.       IF (N.LT.1) RETURN
  12286.       CALL PGBBUF
  12287.       DO 10 I=1,N
  12288.           IF (I .LE. NS) THEN
  12289.               SYMB = SYMBOL(I)
  12290.           ELSE
  12291.               SYMB = SYMBOL(1)
  12292.           END IF
  12293.           CALL PGPT1(X(I), Y(I), SYMB)
  12294.    10 CONTINUE
  12295.       CALL PGEBUF
  12296.       END
  12297. C*PGPOINT -- non-standard alias for PGPT
  12298. C+
  12299.       SUBROUTINE PGPOINT (N, XPTS, YPTS, SYMBOL)
  12300.       INTEGER N
  12301.       REAL XPTS(*), YPTS(*)
  12302.       INTEGER SYMBOL
  12303. C
  12304. C See description of PGPT.
  12305. C--
  12306.       CALL PGPT (N, XPTS, YPTS, SYMBOL)
  12307.       END
  12308. C*PGPOLY -- draw a polygon, using fill-area attributes
  12309. C%void cpgpoly(int n, const float *xpts, const float *ypts);
  12310. C+
  12311.       SUBROUTINE PGPOLY (N, XPTS, YPTS)
  12312.       INTEGER N
  12313.       REAL XPTS(*), YPTS(*)
  12314. C
  12315. C Fill-area primitive routine: shade the interior of a closed
  12316. C polygon in the current window.  The action of this routine depends
  12317. C on the setting of the Fill-Area Style attribute (see PGSFS).
  12318. C The polygon is clipped at the edge of the
  12319. C window. The pen position is changed to (XPTS(1),YPTS(1)) in world
  12320. C coordinates (if N > 1).  If the polygon is not convex, a point is
  12321. C assumed to lie inside the polygon if a straight line drawn to
  12322. C infinity intersects and odd number of the polygon's edges.
  12323. C
  12324. C Arguments:
  12325. C  N      (input)  : number of points defining the polygon; the
  12326. C                    line consists of N straight-line segments,
  12327. C                    joining points 1 to 2, 2 to 3,... N-1 to N, N to 1.
  12328. C                    N should be greater than 2 (if it is 2 or less,
  12329. C                    nothing will be drawn).
  12330. C  XPTS   (input)  : world x-coordinates of the vertices.
  12331. C  YPTS   (input)  : world y-coordinates of the vertices.
  12332. C                    Note: the dimension of arrays XPTS and YPTS must be
  12333. C                    greater than or equal to N.
  12334. C--
  12335. C 21-Nov-1983 - [TJP].
  12336. C 16-Jul-1984 - revised to shade polygon with GRFA [TJP].
  12337. C 21-Oct-1985 - test PGFAS [TJP].
  12338. C 25-Nov-1994 - implement clipping [TJP].
  12339. C 13-Jan-1994 - fix bug in clipping [TJP].
  12340. C  6-Mar-1995 - add support for fill styles 3 and 4 [TJP].
  12341. C 12-Sep-1995 - fix another bug in clipping [TJP].
  12342. C-----------------------------------------------------------------------
  12343.       INTEGER MAXOUT
  12344.       PARAMETER (MAXOUT=1000)
  12345.       LOGICAL CLIP
  12346.       INTEGER I, N1, N2, N3, N4
  12347.       REAL    QX(MAXOUT), QY(MAXOUT), RX(MAXOUT), RY(MAXOUT)
  12348.       REAL    XL, XH, YL, YH
  12349.       LOGICAL PGNOTO
  12350.       INCLUDE 'f77.PGPLOT/IN'
  12351. C
  12352.       IF (PGNOTO('PGPOLY')) RETURN
  12353.       IF (N.LT.1) RETURN
  12354. C
  12355. C Outline style, or polygon of less than 3 vertices.
  12356. C
  12357.       IF (PGFAS(PGID).EQ.2 .OR. N.LT.3) THEN
  12358.          CALL PGBBUF
  12359.          CALL GRMOVA(XPTS(N),YPTS(N))
  12360.          DO 10 I=1,N
  12361.             CALL GRLINA(XPTS(I),YPTS(I))
  12362.  10      CONTINUE
  12363. C
  12364. C Hatched style.
  12365. C
  12366.       ELSE IF (PGFAS(PGID).EQ.3) THEN
  12367.          CALL PGBBUF
  12368.          CALL PGHTCH(N, XPTS, YPTS, 0.0)
  12369.       ELSE IF (PGFAS(PGID).EQ.4) THEN
  12370.          CALL PGBBUF
  12371.          CALL PGHTCH(N, XPTS, YPTS, 0.0)
  12372.          CALL PGHTCH(N, XPTS, YPTS, 90.0)
  12373.       ELSE
  12374. C     
  12375. C Test whether polygon lies completely in the window.
  12376. C     
  12377.          CLIP = .FALSE.
  12378.          XL = MIN(PGXBLC(PGID),PGXTRC(PGID))
  12379.          XH = MAX(PGXBLC(PGID),PGXTRC(PGID))
  12380.          YL = MIN(PGYBLC(PGID),PGYTRC(PGID))
  12381.          YH = MAX(PGYBLC(PGID),PGYTRC(PGID))
  12382.          DO 20 I=1,N
  12383.             IF (XPTS(I).LT.XL .OR. XPTS(I).GT.XH .OR.
  12384.      :           YPTS(I).LT.YL .OR. YPTS(I).GT.YH) THEN
  12385.                CLIP = .TRUE.
  12386.                GOTO 30
  12387.             END IF
  12388.  20      CONTINUE
  12389.  30      CONTINUE
  12390. C     
  12391. C Filled style, no clipping required.
  12392. C     
  12393.          CALL PGBBUF
  12394.          IF (.NOT.CLIP) THEN
  12395.             CALL GRFA(N,XPTS,YPTS)
  12396. C     
  12397. C Filled style, clipping required: the vertices of the clipped
  12398. C polygon are put in temporary arrays QX,QY, RX, RY.
  12399. C     
  12400.          ELSE
  12401.             CALL GRPOCL(N,  XPTS, YPTS, 1, XL, MAXOUT, N1, QX, QY)
  12402.             IF (N1.GT.MAXOUT) GOTO 40
  12403.             IF (N1.LT.3) GOTO 50
  12404.             CALL GRPOCL(N1, QX,   QY,   2, XH, MAXOUT, N2, RX, RY)
  12405.             IF (N2.GT.MAXOUT) GOTO 40
  12406.             IF (N2.LT.3) GOTO 50
  12407.             CALL GRPOCL(N2, RX,   RY,   3, YL, MAXOUT, N3, QX, QY)
  12408.             IF (N3.GT.MAXOUT) GOTO 40
  12409.             IF (N3.LT.3) GOTO 50
  12410.             CALL GRPOCL(N3, QX,   QY,   4, YH, MAXOUT, N4, RX, RY)
  12411.             IF (N4.GT.MAXOUT) GOTO 40
  12412.             IF (N4.GT.0) CALL GRFA(N4,RX,RY)
  12413.             GOTO 50
  12414.  40         CALL GRWARN('PGPOLY: polygon is too complex')
  12415.  50         CONTINUE
  12416.          END IF
  12417.       END IF
  12418. C
  12419. C Set the current pen position.
  12420. C
  12421.       CALL GRMOVA(XPTS(1),YPTS(1))
  12422.       CALL PGEBUF
  12423. C
  12424.       END
  12425. C*PGPT -- draw several graph markers
  12426. C%void cpgpt(int n, const float *xpts, const float *ypts, int symbol);
  12427. C+
  12428.       SUBROUTINE PGPT (N, XPTS, YPTS, SYMBOL)
  12429.       INTEGER N
  12430.       REAL XPTS(*), YPTS(*)
  12431.       INTEGER SYMBOL
  12432. C
  12433. C Primitive routine to draw Graph Markers (polymarker). The markers
  12434. C are drawn using the current values of attributes color-index,
  12435. C line-width, and character-height (character-font applies if the symbol
  12436. C number is >31).  If the point to be marked lies outside the window,
  12437. C no marker is drawn.  The "pen position" is changed to
  12438. C (XPTS(N),YPTS(N)) in world coordinates (if N > 0).
  12439. C
  12440. C Arguments:
  12441. C  N      (input)  : number of points to mark.
  12442. C  XPTS   (input)  : world x-coordinates of the points.
  12443. C  YPTS   (input)  : world y-coordinates of the points.
  12444. C  SYMBOL (input)  : code number of the symbol to be drawn at each 
  12445. C                    point:
  12446. C                    -1, -2  : a single dot (diameter = current
  12447. C                              line width).
  12448. C                    -3..-31 : a regular polygon with ABS(SYMBOL)
  12449. C                              edges (style set by current fill style).
  12450. C                    0..31   : standard marker symbols.
  12451. C                    32..127 : ASCII characters (in current font).
  12452. C                              e.g. to use letter F as a marker, let
  12453. C                              SYMBOL = ICHAR('F'). 
  12454. C                    > 127  :  a Hershey symbol number.
  12455. C
  12456. C Note: the dimension of arrays X and Y must be greater than or equal
  12457. C to N. If N is 1, X and Y may be scalars (constants or variables). If
  12458. C N is less than 1, nothing is drawn.
  12459. C--
  12460. C 27-Nov-1986
  12461. C 17-Dec-1990 - add polygons [PAH].
  12462. C 14-Mar-1997 - optimization: use GRDOT1 [TJP].
  12463. C-----------------------------------------------------------------------
  12464.       LOGICAL PGNOTO
  12465. C
  12466.       IF (N.LT.1) RETURN
  12467.       IF (PGNOTO('PGPT')) RETURN
  12468. C
  12469.       CALL PGBBUF
  12470.       IF (SYMBOL.GE.0 .OR. SYMBOL.LE.-3) THEN
  12471.           CALL GRMKER(SYMBOL,.FALSE.,N,XPTS,YPTS)
  12472.       ELSE
  12473.           CALL GRDOT1(N,XPTS,YPTS)
  12474.       END IF
  12475.       CALL PGEBUF
  12476.       END
  12477. C*PGPT1 -- draw one graph marker
  12478. C%void cpgpt1(float xpt, float ypt, int symbol);
  12479. C+
  12480.       SUBROUTINE PGPT1 (XPT, YPT, SYMBOL)
  12481.       REAL XPT, YPT
  12482.       INTEGER SYMBOL
  12483. C
  12484. C Primitive routine to draw a single Graph Marker at a specified point.
  12485. C The marker is drawn using the current values of attributes
  12486. C color-index, line-width, and character-height (character-font applies
  12487. C if the symbol number is >31).  If the point to be marked lies outside
  12488. C the window, no marker is drawn.  The "pen position" is changed to
  12489. C (XPT,YPT) in world coordinates.
  12490. C
  12491. C To draw several markers with coordinates specified by X and Y
  12492. C arrays, use routine PGPT.
  12493. C
  12494. C Arguments:
  12495. C  XPT    (input)  : world x-coordinate of the point.
  12496. C  YPT    (input)  : world y-coordinate of the point.
  12497. C  SYMBOL (input)  : code number of the symbol to be drawn:
  12498. C                    -1, -2  : a single dot (diameter = current
  12499. C                              line width).
  12500. C                    -3..-31 : a regular polygon with ABS(SYMBOL)
  12501. C                              edges (style set by current fill style).
  12502. C                    0..31   : standard marker symbols.
  12503. C                    32..127 : ASCII characters (in current font).
  12504. C                              e.g. to use letter F as a marker, let
  12505. C                              SYMBOL = ICHAR('F'). 
  12506. C                    > 127  :  a Hershey symbol number.
  12507. C--
  12508. C  4-Feb-1997 - new routine [TJP].
  12509. C-----------------------------------------------------------------------
  12510.       LOGICAL PGNOTO
  12511.       REAL XPTS(1), YPTS(1)
  12512. C
  12513.       IF (PGNOTO('PGPT1')) RETURN
  12514.       XPTS(1) = XPT
  12515.       YPTS(1) = YPT
  12516.       CALL PGPT(1, XPTS, YPTS, SYMBOL)
  12517.       END
  12518. C*PGPTEXT -- non-standard alias for PGPTXT
  12519. C+
  12520.       SUBROUTINE PGPTEXT (X, Y, ANGLE, FJUST, TEXT)
  12521.       REAL X, Y, ANGLE, FJUST
  12522.       CHARACTER*(*) TEXT
  12523. C
  12524. C See description of PGPTXT.
  12525. C--
  12526.       CALL PGPTXT (X, Y, ANGLE, FJUST, TEXT)
  12527.       END
  12528. C*PGPTXT -- write text at arbitrary position and angle
  12529. C%void cpgptxt(float x, float y, float angle, float fjust, \
  12530. C% const char *text);
  12531. C+
  12532.       SUBROUTINE PGPTXT (X, Y, ANGLE, FJUST, TEXT)
  12533.       REAL X, Y, ANGLE, FJUST
  12534.       CHARACTER*(*) TEXT
  12535. C
  12536. C Primitive routine for drawing text. The text may be drawn at any
  12537. C angle with the horizontal, and may be centered or left- or right-
  12538. C justified at a specified position.  Routine PGTEXT provides a
  12539. C simple interface to PGPTXT for horizontal strings. Text is drawn
  12540. C using the current values of attributes color-index, line-width,
  12541. C character-height, and character-font.  Text is NOT subject to
  12542. C clipping at the edge of the window.
  12543. C
  12544. C Arguments:
  12545. C  X      (input)  : world x-coordinate.
  12546. C  Y      (input)  : world y-coordinate. The string is drawn with the
  12547. C                    baseline of all the characters passing through
  12548. C                    point (X,Y); the positioning of the string along
  12549. C                    this line is controlled by argument FJUST.
  12550. C  ANGLE  (input)  : angle, in degrees, that the baseline is to make
  12551. C                    with the horizontal, increasing counter-clockwise
  12552. C                    (0.0 is horizontal).
  12553. C  FJUST  (input)  : controls horizontal justification of the string.
  12554. C                    If FJUST = 0.0, the string will be left-justified
  12555. C                    at the point (X,Y); if FJUST = 0.5, it will be
  12556. C                    centered, and if FJUST = 1.0, it will be right
  12557. C                    justified. [Other values of FJUST give other
  12558. C                    justifications.]
  12559. C  TEXT   (input)  : the character string to be plotted.
  12560. C--
  12561. C (2-May-1983)
  12562. C 31-Jan-1985 - convert to Fortran-77 standard...
  12563. C 13-Feb-1988 - correct a PGBBUF/PGEBUF mismatch if string is blank.
  12564. C 16-Oct-1993 - erase background of opaque text.
  12565. C-----------------------------------------------------------------------
  12566.       INCLUDE 'f77.PGPLOT/IN'
  12567.       INTEGER CI, I, L, GRTRIM
  12568.       REAL D, XP, YP
  12569.       REAL XBOX(4), YBOX(4)
  12570.       LOGICAL PGNOTO
  12571. C
  12572.       IF (PGNOTO('PGPTXT')) RETURN
  12573.       CALL PGBBUF
  12574. C
  12575.       L = GRTRIM(TEXT)
  12576.       D = 0.0
  12577.       IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  12578.       XP = PGXORG(PGID)+X*PGXSCL(PGID) - D*FJUST*COS(ANGLE/57.29578)
  12579.       YP = PGYORG(PGID)+Y*PGYSCL(PGID) - D*FJUST*SIN(ANGLE/57.29578)
  12580.       IF (PGTBCI(PGID).GE.0) THEN
  12581.           CALL GRQTXT (ANGLE, XP, YP, TEXT(1:L), XBOX, YBOX)
  12582.           DO 25 I=1,4
  12583.               XBOX(I) = (XBOX(I)-PGXORG(PGID))/PGXSCL(PGID)
  12584.               YBOX(I) = (YBOX(I)-PGYORG(PGID))/PGYSCL(PGID)
  12585.    25     CONTINUE
  12586.           CALL PGQCI(CI)
  12587.           CALL PGSCI(PGTBCI(PGID))
  12588.           CALL GRFA(4, XBOX, YBOX)
  12589.           CALL PGSCI(CI)
  12590.       END IF
  12591.       CALL GRTEXT(.TRUE. ,ANGLE, .TRUE., XP, YP, TEXT(1:L))
  12592.    30 CALL PGEBUF
  12593.       END
  12594. C*PGQAH -- inquire arrow-head style
  12595. C%void cpgqah(int *fs, float *angle, float *barb);
  12596. C+
  12597.       SUBROUTINE PGQAH (FS, ANGLE, BARB)
  12598.       INTEGER  FS
  12599.       REAL ANGLE, BARB
  12600. C
  12601. C Query the style to be used for arrowheads drawn with routine PGARRO.
  12602. C
  12603. C Argument:
  12604. C  FS     (output) : FS = 1 => filled; FS = 2 => outline.
  12605. C  ANGLE  (output) : the acute angle of the arrow point, in degrees.
  12606. C  BARB   (output) : the fraction of the triangular arrow-head that
  12607. C                    is cut away from the back. 
  12608. C--
  12609. C 13-Oct-1992 - new routine [TJP].
  12610. C-----------------------------------------------------------------------
  12611.       INCLUDE 'f77.PGPLOT/IN'
  12612. C
  12613.       FS = PGAHS(PGID)
  12614.       ANGLE = PGAHA(PGID)
  12615.       BARB = PGAHV(PGID)
  12616. C
  12617.       END
  12618. C*PGQCF -- inquire character font
  12619. C%void cpgqcf(int *font);
  12620. C+
  12621.       SUBROUTINE PGQCF (FONT)
  12622.       INTEGER  FONT
  12623. C
  12624. C Query the current Character Font (set by routine PGSCF).
  12625. C
  12626. C Argument:
  12627. C  FONT   (output)   : the current font number (in range 1-4).
  12628. C--
  12629. C  5-Nov-1985 - new routine [TJP].
  12630. C 25-OCT-1993 - changed name of argument [TJP].
  12631. C-----------------------------------------------------------------------
  12632.       LOGICAL PGNOTO
  12633. C
  12634.       IF (PGNOTO('PGQCF')) THEN
  12635.          FONT = 1
  12636.       ELSE
  12637.          CALL GRQFNT(FONT)
  12638.       END IF
  12639.       END
  12640. C*PGQCH -- inquire character height
  12641. C%void cpgqch(float *size);
  12642. C+
  12643.       SUBROUTINE PGQCH (SIZE)
  12644.       REAL SIZE
  12645. C
  12646. C Query the Character Size attribute (set by routine PGSCH).
  12647. C
  12648. C Argument:
  12649. C  SIZE   (output) : current character size (dimensionless multiple of
  12650. C                    the default size).
  12651. C--
  12652. C  5-Nov-1985 - new routine [TJP].
  12653. C-----------------------------------------------------------------------
  12654.       INCLUDE  'f77.PGPLOT/IN'
  12655.       LOGICAL  PGNOTO
  12656. C
  12657.       IF (PGNOTO('PGQCH')) THEN
  12658.           SIZE = 1.0
  12659.       ELSE
  12660.           SIZE = PGCHSZ(PGID)
  12661.       END IF
  12662.       END
  12663. C*PGQCI -- inquire color index
  12664. C%void cpgqci(int *ci);
  12665. C+
  12666.       SUBROUTINE PGQCI (CI)
  12667.       INTEGER  CI
  12668. C
  12669. C Query the Color Index attribute (set by routine PGSCI).
  12670. C
  12671. C Argument:
  12672. C  CI     (output) : the current color index (in range 0-max). This is
  12673. C                    the color index actually in use, and may differ
  12674. C                    from the color index last requested by PGSCI if
  12675. C                    that index is not available on the output device.
  12676. C--
  12677. C  5-Nov-1985 - new routine [TJP].
  12678. C-----------------------------------------------------------------------
  12679.       LOGICAL PGNOTO
  12680. C
  12681.       IF (PGNOTO('PGQCI')) THEN
  12682.          CI = 1
  12683.       ELSE
  12684.          CALL GRQCI(CI)
  12685.       END IF
  12686.       END
  12687. C*PGQCIR -- inquire color index range
  12688. C%void cpgqcir(int *icilo, int *icihi);
  12689. C+
  12690.       SUBROUTINE PGQCIR(ICILO, ICIHI)
  12691.       INTEGER   ICILO, ICIHI
  12692. C
  12693. C Query the color index range to be used for producing images with
  12694. C PGGRAY or PGIMAG, as set by routine PGSCIR or by device default.
  12695. C
  12696. C Arguments:
  12697. C  ICILO  (output) : the lowest color index to use for images
  12698. C  ICIHI  (output) : the highest color index to use for images
  12699. C--
  12700. C 1994-Mar-17 : new routine [AFT/TJP].
  12701. C-----------------------------------------------------------------------
  12702.       INCLUDE 'f77.PGPLOT/IN'
  12703. C---
  12704.       ICILO = PGMNCI(PGID)
  12705.       ICIHI = PGMXCI(PGID)
  12706. C
  12707.       END
  12708. C*PGQCLP -- inquire clipping status
  12709. C%void cpgqclp(int *state);
  12710. C+
  12711.       SUBROUTINE PGQCLP(STATE)
  12712.       INTEGER  STATE
  12713. C
  12714. C Query the current clipping status (set by routine PGSCLP).
  12715. C
  12716. C Argument:
  12717. C  STATE  (output) : receives the clipping status (0 => disabled,
  12718. C                    1 => enabled).
  12719. C--
  12720. C 25-Feb-1997 [TJP] - new routine.
  12721. C-----------------------------------------------------------------------
  12722.       INCLUDE 'f77.PGPLOT/IN'
  12723.       LOGICAL PGNOTO
  12724. C
  12725.       IF (PGNOTO('PGQCLP')) THEN
  12726.          STATE = 1
  12727.       ELSE
  12728.          STATE = PGCLP(PGID)
  12729.       END IF
  12730.       END
  12731. C*PGQCOL -- inquire color capability
  12732. C%void cpgqcol(int *ci1, int *ci2);
  12733. C+
  12734.       SUBROUTINE PGQCOL (CI1, CI2)
  12735.       INTEGER  CI1, CI2
  12736. C
  12737. C Query the range of color indices available on the current device.
  12738. C
  12739. C Argument:
  12740. C  CI1    (output) : the minimum available color index. This will be
  12741. C                    either 0 if the device can write in the
  12742. C                    background color, or 1 if not.
  12743. C  CI2    (output) : the maximum available color index. This will be
  12744. C                    1 if the device has no color capability, or a
  12745. C                    larger number (e.g., 3, 7, 15, 255).
  12746. C--
  12747. C 31-May-1989 - new routine [TJP].
  12748. C-----------------------------------------------------------------------
  12749.       CALL GRQCOL(CI1, CI2)
  12750.       END
  12751. C*PGQCR  -- inquire color representation
  12752. C%void cpgqcr(int ci, float *cr, float *cg, float *cb);
  12753. C+
  12754.       SUBROUTINE PGQCR (CI, CR, CG, CB)
  12755.       INTEGER CI
  12756.       REAL    CR, CG, CB
  12757. C
  12758. C Query the RGB colors associated with a color index.
  12759. C
  12760. C Arguments:
  12761. C  CI  (input)  : color index
  12762. C  CR  (output) : red, green and blue intensities
  12763. C  CG  (output)   in the range 0.0 to 1.0
  12764. C  CB  (output)
  12765. C--
  12766. C 7-Apr-1992 - new routine [DLT]
  12767. C-----------------------------------------------------------------------
  12768.       CALL GRQCR(CI, CR, CG, CB)
  12769.       END
  12770. C*PGQCS  -- inquire character height in a variety of units
  12771. C%void cpgqcs(int units, float *xch, float *ych);
  12772. C+
  12773.       SUBROUTINE PGQCS(UNITS, XCH, YCH)
  12774.       INTEGER UNITS
  12775.       REAL XCH, YCH
  12776. C
  12777. C Return the current PGPLOT character height in a variety of units.
  12778. C This routine provides facilities that are not available via PGQCH.
  12779. C Use PGQCS if the character height is required in units other than
  12780. C those used in PGSCH.
  12781. C
  12782. C The PGPLOT "character height" is a dimension that scales with the
  12783. C size of the view surface and with the scale-factor specified with
  12784. C routine PGSCH. The default value is 1/40th of the height or width
  12785. C of the view surface (whichever is less); this value is then
  12786. C multiplied by the scale-factor supplied with PGSCH. Note that it
  12787. C is a nominal height only; the actual character size depends on the
  12788. C font and is usually somewhat smaller.
  12789. C
  12790. C Arguments:
  12791. C  UNITS  (input)  : Used to specify the units of the output value:
  12792. C                    UNITS = 0 : normalized device coordinates
  12793. C                    UNITS = 1 : inches
  12794. C                    UNITS = 2 : millimeters
  12795. C                    UNITS = 3 : pixels
  12796. C                    UNITS = 4 : world coordinates
  12797. C                    Other values give an error message, and are
  12798. C                    treated as 0.
  12799. C  XCH    (output) : The character height for text written with a
  12800. C                    vertical baseline.
  12801. C  YCH    (output) : The character height for text written with
  12802. C                    a horizontal baseline (the usual case).
  12803. C
  12804. C The character height is returned in both XCH and YCH.
  12805. C
  12806. C If UNITS=1 or UNITS=2, XCH and YCH both receive the same value.
  12807. C
  12808. C If UNITS=3, XCH receives the height in horizontal pixel units, and YCH
  12809. C receives the height in vertical pixel units; on devices for which the
  12810. C pixels are not square, XCH and YCH will be different.
  12811. C
  12812. C If UNITS=4, XCH receives the height in horizontal world coordinates
  12813. C (as used for the x-axis), and YCH receives the height in vertical
  12814. C world coordinates (as used for the y-axis). Unless special care has
  12815. C been taken to achive equal world-coordinate scales on both axes, the
  12816. C values of XCH and YCH will be different.
  12817. C
  12818. C If UNITS=0, XCH receives the character height as a fraction of the
  12819. C horizontal dimension of the view surface, and YCH receives the
  12820. C character height as a fraction of the vertical dimension of the view
  12821. C surface.
  12822. C--
  12823. C 15-Oct-1992 - new routine [MCS].
  12824. C  4-Dec-1992 - added more explanation [TJP].
  12825. C  5-Sep-1995 - add UNITS=4; correct error for non-square pixels [TJP].
  12826. C-----------------------------------------------------------------------
  12827.       INCLUDE 'f77.PGPLOT/IN'
  12828.       LOGICAL PGNOTO
  12829.       REAL RATIO
  12830. C                                        Conversion factor inches -> mm
  12831.       REAL INTOMM
  12832.       PARAMETER (INTOMM=25.4)
  12833. C-----------------------------------------------------------------------
  12834.       IF (PGNOTO('PGQCS')) RETURN
  12835.       RATIO = PGYPIN(PGID)/PGXPIN(PGID)
  12836. C
  12837. C Return the character height in the required units.
  12838. C
  12839. C                                        Inches.
  12840.       IF (UNITS.EQ.1) THEN
  12841.         XCH = PGYSP(PGID)/PGXPIN(PGID)
  12842.         YCH = XCH
  12843. C                                        Millimeters.
  12844.       ELSE IF (UNITS.EQ.2) THEN
  12845.         XCH = PGYSP(PGID)/PGXPIN(PGID) * INTOMM
  12846.         YCH = XCH
  12847. C                                        Pixels.
  12848.       ELSE IF (UNITS.EQ.3) THEN
  12849.         XCH = PGYSP(PGID)
  12850.         YCH = PGYSP(PGID)*RATIO
  12851. C                                        World coordinates.
  12852.       ELSE IF (UNITS.EQ.4) THEN
  12853.          XCH = PGYSP(PGID)/PGXSCL(PGID)
  12854.          YCH = PGYSP(PGID)*RATIO/PGYSCL(PGID)
  12855. C                                        Normalized device coords, or
  12856. C                                        unknown.
  12857.       ELSE
  12858.         XCH = PGYSP(PGID)/PGXSZ(PGID)
  12859.         YCH = PGYSP(PGID)*RATIO/PGYSZ(PGID)
  12860.         IF (UNITS.NE.0)
  12861.      :       CALL GRWARN('Invalid "UNITS" argument in PGQCS.')
  12862.       END IF
  12863.       END
  12864. C*PGQDT -- inquire name of nth available device type
  12865. C%void cpgqdt(int n, char *type, int *type_length, char *descr, \
  12866. C% int *descr_length, int *inter);
  12867. C+
  12868.       SUBROUTINE PGQDT(N, TYPE, TLEN, DESCR, DLEN, INTER)
  12869.       INTEGER N
  12870.       CHARACTER*(*) TYPE, DESCR
  12871.       INTEGER TLEN, DLEN, INTER
  12872. C
  12873. C Return the name of the Nth available device type as a character
  12874. C string. The number of available types can be determined by calling
  12875. C PGQNDT. If the value of N supplied is outside the range from 1 to
  12876. C the number of available types, the routine returns DLEN=TLEN=0.
  12877. C
  12878. C Arguments:
  12879. C  N      (input)  : the number of the device type (1..maximum).
  12880. C  TYPE   (output) : receives the character device-type code of the
  12881. C                    Nth device type. The argument supplied should be
  12882. C                    large enough for at least 8 characters. The first
  12883. C                    character in the string is a '/' character.
  12884. C  TLEN   (output) : receives the number of characters in TYPE,
  12885. C                    excluding trailing blanks.
  12886. C  DESCR  (output) : receives a description of the device type. The
  12887. C                    argument supplied should be large enough for at
  12888. C                    least 64 characters.
  12889. C  DLEN   (output) : receives the number of characters in DESCR,
  12890. C                    excluding trailing blanks.
  12891. C  INTER  (output) : receives 1 if the device type is an interactive
  12892. C                    one, 0 otherwise.
  12893. C--
  12894. C 17-Mar-1997 - new routine [TJP].
  12895. C-----------------------------------------------------------------------
  12896.       INTEGER NDEV, NBUF, LCHR, L1, L2
  12897.       REAL RBUF
  12898.       CHARACTER*80 CHR
  12899. C
  12900. C Initialize PGPLOT if necessary.
  12901. C
  12902.       CALL PGINIT
  12903. C
  12904.       TYPE = 'error'
  12905.       TLEN = 0
  12906.       DESCR = ' '
  12907.       DLEN = 0
  12908.       INTER = 1
  12909.       CALL PGQNDT(NDEV)
  12910.       IF (N.GE.1 .AND. N.LE.NDEV) THEN
  12911.          NBUF = 0
  12912.          CALL GREXEC(N, 1, RBUF, NBUF, CHR, LCHR)
  12913.          IF (LCHR.GT.0) THEN
  12914.             L1 = INDEX(CHR(1:LCHR), ' ')
  12915.             IF (L1.GT.1) THEN
  12916.                TYPE(1:1) = '/'
  12917.                IF (LEN(TYPE).GT.1) TYPE(2:) = CHR(1:L1-1)
  12918.                TLEN = MIN(L1,LEN(TYPE))
  12919.             END IF
  12920.             L2 = INDEX(CHR(1:LCHR), '(')
  12921.             IF (L2.GT.0) DESCR = CHR(L2:LCHR)
  12922.             DLEN = MIN(LCHR-L2+1,LEN(DESCR))
  12923.             CALL GREXEC(N, 4, RBUF, NBUF, CHR, LCHR)
  12924.             IF (CHR(1:1).EQ.'H') INTER = 0
  12925.          END IF
  12926.       END IF
  12927. C
  12928.       END
  12929. C*PGQFS -- inquire fill-area style
  12930. C%void cpgqfs(int *fs);
  12931. C+
  12932.       SUBROUTINE PGQFS (FS)
  12933.       INTEGER  FS
  12934. C
  12935. C Query the current Fill-Area Style attribute (set by routine
  12936. C PGSFS).
  12937. C
  12938. C Argument:
  12939. C  FS     (output) : the current fill-area style:
  12940. C                      FS = 1 => solid (default)
  12941. C                      FS = 2 => outline
  12942. C                      FS = 3 => hatched
  12943. C                      FS = 4 => cross-hatched
  12944. C--
  12945. C  5-Nov-1985 - new routine [TJP].
  12946. C  6-Mar-1995 - add styles 3 and 4 [TJP].
  12947. C-----------------------------------------------------------------------
  12948.       INCLUDE 'f77.PGPLOT/IN'
  12949.       LOGICAL PGNOTO
  12950. C
  12951.       IF (PGNOTO('PGQFS')) THEN
  12952.           FS = 1
  12953.       ELSE
  12954.           FS = PGFAS(PGID)
  12955.       END IF
  12956.       END
  12957. C*PGQHS -- inquire hatching style
  12958. C%void cpgqhs(float *angle, float *sepn, float* phase);
  12959. C+
  12960.       SUBROUTINE PGQHS (ANGLE, SEPN, PHASE)
  12961.       REAL ANGLE, SEPN, PHASE
  12962. C
  12963. C Query the style to be used hatching (fill area with fill-style 3).
  12964. C
  12965. C Arguments:
  12966. C  ANGLE  (output) : the angle the hatch lines make with the
  12967. C                    horizontal, in degrees, increasing 
  12968. C                    counterclockwise (this is an angle on the
  12969. C                    view surface, not in world-coordinate space).
  12970. C  SEPN   (output) : the spacing of the hatch lines. The unit spacing
  12971. C                    is 1 percent of the smaller of the height or
  12972. C                    width of the view surface.
  12973. C  PHASE  (output) : a real number between 0 and 1; the hatch lines
  12974. C                    are displaced by this fraction of SEPN from a
  12975. C                    fixed reference.  Adjacent regions hatched with the
  12976. C                    same PHASE have contiguous hatch lines.
  12977. C--
  12978. C 26-Feb-1995 - new routine [TJP].
  12979. C 19-Jun-1995 - correct synopsis [TJP].
  12980. C-----------------------------------------------------------------------
  12981.       INCLUDE 'f77.PGPLOT/IN'
  12982. C
  12983.       ANGLE = PGHSA(PGID)
  12984.       SEPN  = PGHSS(PGID)
  12985.       PHASE = PGHSP(PGID)
  12986. C
  12987.       END
  12988. C*PGQID -- inquire current device identifier
  12989. C%void cpgqid(int *id);
  12990. C+
  12991.       SUBROUTINE PGQID (ID)
  12992.       INTEGER  ID
  12993. C
  12994. C This subroutine returns the identifier of the currently
  12995. C selected device, or 0 if no device is selected.  The identifier is
  12996. C assigned when PGOPEN is called to open the device, and may be used
  12997. C as an argument to PGSLCT.  Each open device has a different
  12998. C identifier.
  12999. C
  13000. C [This routine was added to PGPLOT in Version 5.1.0.]
  13001. C
  13002. C Argument:
  13003. C  ID     (output) : the identifier of the current device, or 0 if
  13004. C                    no device is currently selected.
  13005. C--
  13006. C 22-Dec-1995 - new routine [TJP].
  13007. C-----------------------------------------------------------------------
  13008.       INCLUDE 'f77.PGPLOT/IN'
  13009. C
  13010.       ID = PGID
  13011.       END
  13012. C*PGQINF -- inquire PGPLOT general information
  13013. C%void cpgqinf(const char *item, char *value, int *value_length);
  13014. C+
  13015.       SUBROUTINE PGQINF (ITEM, VALUE, LENGTH)
  13016.       CHARACTER*(*) ITEM, VALUE
  13017.       INTEGER LENGTH
  13018. C
  13019. C This routine can be used to obtain miscellaneous information about
  13020. C the PGPLOT environment. Input is a character string defining the
  13021. C information required, and output is a character string containing the
  13022. C requested information.
  13023. C
  13024. C The following item codes are accepted (note that the strings must
  13025. C match exactly, except for case, but only the first 8 characters are
  13026. C significant). For items marked *, PGPLOT must be in the OPEN state
  13027. C for the inquiry to succeed. If the inquiry is unsuccessful, either
  13028. C because the item code is not recognized or because the information
  13029. C is not available, a question mark ('?') is returned.
  13030. C
  13031. C   'VERSION'     - version of PGPLOT software in use.
  13032. C   'STATE'       - status of PGPLOT ('OPEN' if a graphics device
  13033. C                   is open for output, 'CLOSED' otherwise).
  13034. C   'USER'        - the username associated with the calling program.
  13035. C   'NOW'         - current date and time (e.g., '17-FEB-1986 10:04').
  13036. C   'DEVICE'    * - current PGPLOT device or file.
  13037. C   'FILE'      * - current PGPLOT device or file.
  13038. C   'TYPE'      * - device-type of the current PGPLOT device.
  13039. C   'DEV/TYPE'  * - current PGPLOT device and type, in a form which
  13040. C                   is acceptable as an argument for PGBEG.
  13041. C   'HARDCOPY'  * - is the current device a hardcopy device? ('YES' or
  13042. C                   'NO').
  13043. C   'TERMINAL'  * - is the current device the user's interactive
  13044. C                   terminal? ('YES' or 'NO').
  13045. C   'CURSOR'    * - does the current device have a graphics cursor?
  13046. C                   ('YES' or 'NO').
  13047. C   'SCROLL'    * - does current device have rectangle-scroll
  13048. C                   capability ('YES' or 'NO'); see PGSCRL.
  13049. C
  13050. C Arguments:
  13051. C  ITEM  (input)  : character string defining the information to
  13052. C                   be returned; see above for a list of possible
  13053. C                   values.
  13054. C  VALUE (output) : returns a character-string containing the
  13055. C                   requested information, truncated to the length 
  13056. C                   of the supplied string or padded on the right with 
  13057. C                   spaces if necessary.
  13058. C  LENGTH (output): the number of characters returned in VALUE
  13059. C                   (excluding trailing blanks).
  13060. C--
  13061. C 18-Feb-1988 - [TJP].
  13062. C 30-Aug-1988 - remove pseudo logical use of IER.
  13063. C 12-Mar-1992 - change comments for clarity.
  13064. C 17-Apr-1995 - clean up some zero-length string problems [TJP].
  13065. C  7-Jul-1995 - get cursor information directly from driver [TJP].
  13066. C 24-Feb-1997 - add SCROLL request.
  13067. C-----------------------------------------------------------------------
  13068.       INCLUDE 'f77.PGPLOT/IN'
  13069.       INTEGER IER, L1, GRTRIM
  13070.       LOGICAL INTER, SAME
  13071.       CHARACTER*8 TEST
  13072.       CHARACTER*64 DEV1
  13073. C
  13074. C Initialize PGPLOT if necessary.
  13075. C
  13076.       CALL PGINIT
  13077. C
  13078.       CALL GRTOUP(TEST,ITEM)
  13079.       IF (TEST.EQ.'USER') THEN
  13080.           CALL GRUSER(VALUE, LENGTH)
  13081.           IER = 1
  13082.       ELSE IF (TEST.EQ.'NOW') THEN
  13083.           CALL GRDATE(VALUE, LENGTH)
  13084.           IER = 1
  13085.       ELSE IF (TEST.EQ.'VERSION') THEN
  13086.           VALUE = 'v5.2.0'
  13087.           LENGTH = 6
  13088.           IER = 1
  13089.       ELSE IF (TEST.EQ.'STATE') THEN
  13090.           IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  13091.              VALUE = 'CLOSED'
  13092.              LENGTH = 6
  13093.           ELSE IF (PGDEVS(PGID).EQ.0) THEN
  13094.              VALUE = 'CLOSED'
  13095.              LENGTH = 6
  13096.           ELSE
  13097.              VALUE = 'OPEN'
  13098.              LENGTH = 4
  13099.           END IF
  13100.           IER = 1
  13101.       ELSE IF (PGID.LT.1 .OR. PGID.GT.PGMAXD) THEN
  13102.           IER = 0
  13103.       ELSE IF (PGDEVS(PGID).EQ.0) THEN
  13104.           IER = 0
  13105.       ELSE IF (TEST.EQ.'DEV/TYPE') THEN
  13106.           CALL GRQDT(VALUE)
  13107.           LENGTH = GRTRIM(VALUE)
  13108.           IER = 0
  13109.           IF (LENGTH.GT.0) IER = 1
  13110.       ELSE IF (TEST.EQ.'DEVICE' .OR. TEST.EQ.'FILE') THEN
  13111.           CALL GRQDEV(VALUE, LENGTH)
  13112.           IER = 1
  13113.       ELSE IF (TEST.EQ.'TERMINAL') THEN
  13114.           CALL GRQDEV(DEV1, L1)
  13115.           IF (L1.GE.1) THEN
  13116.              CALL GRTTER(DEV1(1:L1), SAME)
  13117.           ELSE
  13118.              SAME = .FALSE.
  13119.           END IF
  13120.           IF (SAME) THEN
  13121.               VALUE = 'YES'
  13122.               LENGTH = 3
  13123.           ELSE
  13124.               VALUE = 'NO'
  13125.               LENGTH = 2
  13126.           END IF
  13127.           IER = 1
  13128.       ELSE IF (TEST.EQ.'TYPE') THEN
  13129.           CALL GRQTYP(VALUE,INTER)
  13130.           LENGTH = GRTRIM(VALUE)
  13131.           IER = 0
  13132.           IF (LENGTH.GT.0) IER = 1
  13133.       ELSE IF (TEST.EQ.'HARDCOPY') THEN
  13134.           CALL GRQTYP(VALUE,INTER)
  13135.           IF (INTER) THEN
  13136.               VALUE = 'NO'
  13137.               LENGTH = 2
  13138.           ELSE
  13139.               VALUE = 'YES'
  13140.               LENGTH = 3
  13141.           END IF
  13142.           IER = 1
  13143.       ELSE IF (TEST.EQ.'CURSOR') THEN
  13144.           CALL GRQCAP(DEV1)
  13145.           IF (DEV1(2:2).EQ.'N') THEN
  13146.               VALUE = 'NO'
  13147.               LENGTH = 2
  13148.           ELSE
  13149.               VALUE = 'YES'
  13150.               LENGTH = 3
  13151.           END IF
  13152.           IER = 1
  13153.       ELSE IF (TEST.EQ.'SCROLL') THEN
  13154.           CALL GRQCAP(DEV1)
  13155.           IF (DEV1(11:11).NE.'S') THEN
  13156.               VALUE = 'NO'
  13157.               LENGTH = 2
  13158.           ELSE
  13159.               VALUE = 'YES'
  13160.               LENGTH = 3
  13161.           END IF
  13162.           IER = 1
  13163.       ELSE
  13164.           IER = 0
  13165.       END IF
  13166.       IF (IER.NE.1) THEN
  13167.          VALUE = '?'
  13168.          LENGTH = 1
  13169.       ELSE IF (LENGTH.LT.1) THEN
  13170.          LENGTH = 1
  13171.          VALUE = ' '
  13172.       END IF
  13173.       END
  13174. C*PGQITF -- inquire image transfer function
  13175. C%void cpgqitf(int *itf);
  13176. C+
  13177.       SUBROUTINE PGQITF (ITF)
  13178.       INTEGER  ITF
  13179. C
  13180. C Return the Image Transfer Function as set by default or by a previous
  13181. C call to PGSITF. The Image Transfer Function is used by routines
  13182. C PGIMAG, PGGRAY, and PGWEDG.
  13183. C
  13184. C Argument:
  13185. C  ITF    (output) : type of transfer function (see PGSITF)
  13186. C--
  13187. C 15-Sep-1994 - new routine [TJP].
  13188. C-----------------------------------------------------------------------
  13189.       INCLUDE 'f77.PGPLOT/IN'
  13190.       LOGICAL PGNOTO
  13191. C
  13192.       IF (PGNOTO('PGQITF')) THEN
  13193.           ITF = 0
  13194.       ELSE
  13195.           ITF = PGITF(PGID)
  13196.       END IF
  13197.       END
  13198. C*PGQLS -- inquire line style
  13199. C%void cpgqls(int *ls);
  13200. C+
  13201.       SUBROUTINE PGQLS (LS)
  13202.       INTEGER  LS
  13203. C
  13204. C Query the current Line Style attribute (set by routine PGSLS).
  13205. C
  13206. C Argument:
  13207. C  LS     (output) : the current line-style attribute (in range 1-5).
  13208. C--
  13209. C  5-Nov-1985 - new routine [TJP].
  13210. C-----------------------------------------------------------------------
  13211.       LOGICAL PGNOTO
  13212. C
  13213.       IF (PGNOTO('PGQLS')) THEN
  13214.          LS = 1
  13215.       ELSE
  13216.          CALL GRQLS(LS)
  13217.       END IF
  13218.       END
  13219. C*PGQLW -- inquire line width
  13220. C%void cpgqlw(int *lw);
  13221. C+
  13222.       SUBROUTINE PGQLW (LW)
  13223.       INTEGER  LW
  13224. C
  13225. C Query the current Line-Width attribute (set by routine PGSLW).
  13226. C
  13227. C Argument:
  13228. C  LW     (output)  : the line-width (in range 1-201).
  13229. C--
  13230. C  5-Nov-1985 - new routine [TJP].
  13231. C-----------------------------------------------------------------------
  13232.       LOGICAL PGNOTO
  13233. C     
  13234.       IF (PGNOTO('PGQLW')) THEN
  13235.          LW = 1
  13236.       ELSE
  13237.          CALL GRQLW(LW)
  13238.       END IF
  13239.       END
  13240. C*PGQNDT -- inquire number of available device types
  13241. C%void cpgqndt(int *n);
  13242. C+
  13243.       SUBROUTINE PGQNDT(N)
  13244.       INTEGER N
  13245. C
  13246. C Return the number of available device types. This routine is
  13247. C usually used in conjunction with PGQDT to get a list of the
  13248. C available device types.
  13249. C
  13250. C Arguments:
  13251. C  N      (output) : the number of available device types.
  13252. C--
  13253. C 17-Mar-1997 - new routine [TJP].
  13254. C-----------------------------------------------------------------------
  13255.       INTEGER NBUF, LCHR
  13256.       REAL RBUF(2)
  13257.       CHARACTER CHR
  13258. C
  13259. C Initialize PGPLOT if necessary.
  13260. C
  13261.       CALL PGINIT
  13262. C
  13263. C Find number of device types.
  13264. C
  13265.       CALL GREXEC(0, 0, RBUF, NBUF, CHR, LCHR)
  13266.       N = NINT(RBUF(1))
  13267. C
  13268.       END
  13269. C*PGQPOS -- inquire current pen position
  13270. C%void cpgqpos(float *x, float *y);
  13271. C+
  13272.       SUBROUTINE PGQPOS (X, Y)
  13273.       REAL X, Y
  13274. C
  13275. C Query the current "pen" position in world C coordinates (X,Y).
  13276. C
  13277. C Arguments:
  13278. C  X      (output)  : world x-coordinate of the pen position.
  13279. C  Y      (output)  : world y-coordinate of the pen position.
  13280. C--
  13281. C  1-Mar-1991 - new routine [JM].
  13282. C-----------------------------------------------------------------------
  13283.       CALL GRQPOS(X,Y)
  13284.       END
  13285. C*PGQTBG -- inquire text background color index
  13286. C%void cpgqtbg(int *tbci);
  13287. C+
  13288.       SUBROUTINE PGQTBG (TBCI)
  13289.       INTEGER  TBCI
  13290. C
  13291. C Query the current Text Background Color Index (set by routine
  13292. C PGSTBG).
  13293. C
  13294. C Argument:
  13295. C  TBCI   (output) : receives the current text background color index.
  13296. C--
  13297. C 16-Oct-1993 - new routine [TJP].
  13298. C-----------------------------------------------------------------------
  13299.       INCLUDE 'f77.PGPLOT/IN'
  13300.       LOGICAL PGNOTO
  13301. C
  13302.       IF (PGNOTO('PGQTBG')) THEN
  13303.           TBCI = 0
  13304.       ELSE
  13305.           TBCI = PGTBCI(PGID)
  13306.       END IF
  13307.       END
  13308. C*PGQTXT -- find bounding box of text string
  13309. C%void cpgqtxt(float x, float y, float angle, float fjust, \
  13310. C% const char *text, float *xbox, float *ybox);
  13311. C+
  13312.       SUBROUTINE PGQTXT (X, Y, ANGLE, FJUST, TEXT, XBOX, YBOX)
  13313.       REAL X, Y, ANGLE, FJUST
  13314.       CHARACTER*(*) TEXT
  13315.       REAL XBOX(4), YBOX(4)
  13316. C
  13317. C This routine returns a bounding box for a text string. Instead
  13318. C of drawing the string as routine PGPTXT does, it returns in XBOX
  13319. C and YBOX the coordinates of the corners of a rectangle parallel
  13320. C to the string baseline that just encloses the string. The four
  13321. C corners are in the order: lower left, upper left, upper right,
  13322. C lower right (where left and right refer to the first and last
  13323. C characters in the string).
  13324. C
  13325. C If the string is blank or contains no drawable characters, all
  13326. C four elements of XBOX and YBOX are assigned the starting point
  13327. C of the string, (X,Y).
  13328. C
  13329. C Arguments:
  13330. C  X, Y, ANGLE, FJUST, TEXT (input) : these arguments are the same as
  13331. C                    the corrresponding arguments in PGPTXT.
  13332. C  XBOX, YBOX (output) : arrays of dimension 4; on output, they
  13333. C                    contain the world coordinates of the bounding
  13334. C                    box in (XBOX(1), YBOX(1)), ..., (XBOX(4), YBOX(4)).
  13335. C--
  13336. C 12-Sep-1993 - new routine [TJP].
  13337. C  8-Nov-1994 - return something for blank string [TJP].
  13338. C 14-Jan-1997 - additional explanation [TJP].
  13339. C-----------------------------------------------------------------------
  13340.       INCLUDE 'f77.PGPLOT/IN'
  13341.       LOGICAL PGNOTO
  13342.       INTEGER I, L, GRTRIM
  13343.       REAL D, XP, YP, XPBOX(4), YPBOX(4), XOFFS, YOFFS
  13344. C
  13345.       IF (PGNOTO('PGQTXT')) RETURN
  13346. C
  13347.       L = GRTRIM(TEXT)
  13348.       IF (L.LE.0) THEN
  13349.          DO 15 I=1,4
  13350.             XBOX(I) = X
  13351.             YBOX(I) = Y
  13352.  15      CONTINUE
  13353.       ELSE
  13354.          D = 0.0
  13355.          IF (FJUST.NE.0.0) CALL GRLEN(TEXT(1:L),D)
  13356.          XOFFS = PGXORG(PGID) - D*FJUST*COS(ANGLE/57.29578)
  13357.          YOFFS = PGYORG(PGID) - D*FJUST*SIN(ANGLE/57.29578)
  13358.          XP = X*PGXSCL(PGID) + XOFFS
  13359.          YP = Y*PGYSCL(PGID) + YOFFS
  13360.          CALL GRQTXT(ANGLE, XP, YP, TEXT(1:L), XPBOX, YPBOX)
  13361.          DO 25 I=1,4
  13362.             XBOX(I) = (XPBOX(I) - PGXORG(PGID))/PGXSCL(PGID)
  13363.             YBOX(I) = (YPBOX(I) - PGYORG(PGID))/PGYSCL(PGID)
  13364.  25      CONTINUE
  13365.       END IF
  13366.       END
  13367. C*PGQVP -- inquire viewport size and position
  13368. C%void cpgqvp(int units, float *x1, float *x2, float *y1, float *y2);
  13369. C+
  13370.       SUBROUTINE PGQVP (UNITS, X1, X2, Y1, Y2)
  13371.       INTEGER UNITS
  13372.       REAL    X1, X2, Y1, Y2
  13373. C
  13374. C Inquiry routine to determine the current viewport setting.
  13375. C The values returned may be normalized device coordinates, inches, mm,
  13376. C or pixels, depending on the value of the input parameter CFLAG.
  13377. C
  13378. C Arguments:
  13379. C  UNITS  (input)  : used to specify the units of the output parameters:
  13380. C                    UNITS = 0 : normalized device coordinates
  13381. C                    UNITS = 1 : inches
  13382. C                    UNITS = 2 : millimeters
  13383. C                    UNITS = 3 : pixels
  13384. C                    Other values give an error message, and are
  13385. C                    treated as 0.
  13386. C  X1     (output) : the x-coordinate of the bottom left corner of the
  13387. C                    viewport.
  13388. C  X2     (output) : the x-coordinate of the top right corner of the
  13389. C                    viewport.
  13390. C  Y1     (output) : the y-coordinate of the bottom left corner of the
  13391. C                    viewport.
  13392. C  Y2     (output) : the y-coordinate of the top right corner of the
  13393. C                    viewport.
  13394. C--
  13395. C 26-Sep-1985 - new routine (TJP).
  13396. C-----------------------------------------------------------------------
  13397.       INCLUDE 'f77.PGPLOT/IN'
  13398.       REAL SX, SY
  13399. C
  13400.       IF (UNITS.EQ.0) THEN
  13401.           SX = PGXSZ(PGID)
  13402.           SY = PGYSZ(PGID)
  13403.       ELSE IF (UNITS.EQ.1) THEN
  13404.           SX = PGXPIN(PGID)
  13405.           SY = PGYPIN(PGID)
  13406.       ELSE IF (UNITS.EQ.2) THEN
  13407.           SX = (PGXPIN(PGID)/25.4)
  13408.           SY = (PGYPIN(PGID)/25.4)
  13409.       ELSE IF (UNITS.EQ.3) THEN
  13410.           SX = 1.0
  13411.           SY = 1.0
  13412.       ELSE
  13413.           CALL GRWARN(
  13414.      1        'Illegal value for parameter UNITS in routine PGQVP')
  13415.           SX = PGXSZ(PGID)
  13416.           SY = PGYSZ(PGID)
  13417.       END IF
  13418.       X1 = PGXVP(PGID)/SX
  13419.       X2 = (PGXVP(PGID)+PGXLEN(PGID))/SX
  13420.       Y1 = PGYVP(PGID)/SY
  13421.       Y2 = (PGYVP(PGID)+PGYLEN(PGID))/SY
  13422.       END
  13423. C*PGQVSZ -- inquire size of view surface
  13424. C%void cpgqvsz(int units, float *x1, float *x2, float *y1, float *y2);
  13425. C+
  13426.       SUBROUTINE PGQVSZ (UNITS, X1, X2, Y1, Y2)
  13427.       INTEGER UNITS
  13428.       REAL X1, X2, Y1, Y2
  13429. C
  13430. C This routine returns the dimensions of the view surface (the maximum
  13431. C plottable area) of the currently selected graphics device, in 
  13432. C a variety of units. The size of the view surface is device-dependent
  13433. C and is established when the graphics device is opened. On some 
  13434. C devices, it can be changed by calling PGPAP before starting a new
  13435. C page with PGPAGE. On some devices, the size can be changed (e.g.,
  13436. C by a workstation window manager) outside PGPLOT, and PGPLOT detects
  13437. C the change when PGPAGE is used. Call this routine after PGPAGE to 
  13438. C find the current size.
  13439. C
  13440. C Note 1: the width and the height of the view surface in normalized
  13441. C device coordinates are both always equal to 1.0.
  13442. C
  13443. C Note 2: when the device is divided into panels (see PGSUBP), the
  13444. C view surface is a single panel.
  13445. C
  13446. C Arguments:
  13447. C  UNITS  (input)  : 0,1,2,3 for output in normalized device coords, 
  13448. C                    inches, mm, or device units (pixels)
  13449. C  X1     (output) : always returns 0.0
  13450. C  X2     (output) : width of view surface
  13451. C  Y1     (output) : always returns 0.0
  13452. C  Y2     (output) : height of view surface
  13453. C--
  13454. C 28-Aug-1992 - new routine [Neil Killeen].
  13455. C  2-Dec-1992 - changed to avoid resetting the viewport [TJP].
  13456. C 26-Feb-1997 - revised description [TJP].
  13457. C-----------------------------------------------------------------------
  13458.       INCLUDE 'f77.PGPLOT/IN'
  13459.       LOGICAL PGNOTO
  13460.       REAL SX, SY
  13461. C
  13462.       IF (PGNOTO('PGQVSZ')) THEN
  13463.          X1 = 0.0
  13464.          X2 = 0.0
  13465.          Y1 = 0.0
  13466.          Y2 = 0.0
  13467.          RETURN
  13468.       END IF
  13469. C
  13470.       IF (UNITS.EQ.0) THEN
  13471.           SX = PGXSZ(PGID)
  13472.           SY = PGYSZ(PGID)
  13473.       ELSE IF (UNITS.EQ.1) THEN
  13474.           SX = PGXPIN(PGID)
  13475.           SY = PGYPIN(PGID)
  13476.       ELSE IF (UNITS.EQ.2) THEN
  13477.           SX = (PGXPIN(PGID)/25.4)
  13478.           SY = (PGYPIN(PGID)/25.4)
  13479.       ELSE IF (UNITS.EQ.3) THEN
  13480.           SX = 1.0
  13481.           SY = 1.0
  13482.       ELSE
  13483.           CALL GRWARN(
  13484.      1        'Illegal value for parameter UNITS in routine PGQVSZ')
  13485.           SX = PGXSZ(PGID)
  13486.           SY = PGYSZ(PGID)
  13487.       END IF
  13488.       X1 = 0.0
  13489.       X2 = PGXSZ(PGID)/SX
  13490.       Y1 = 0.0
  13491.       Y2 = PGYSZ(PGID)/SY
  13492.       END
  13493. C*PGQWIN -- inquire window boundary coordinates
  13494. C%void cpgqwin(float *x1, float *x2, float *y1, float *y2);
  13495. C+
  13496.       SUBROUTINE PGQWIN (X1, X2, Y1, Y2)
  13497.       REAL X1, X2, Y1, Y2
  13498. C
  13499. C Inquiry routine to determine the current window setting.
  13500. C The values returned are world coordinates.
  13501. C
  13502. C Arguments:
  13503. C  X1     (output) : the x-coordinate of the bottom left corner
  13504. C                    of the window.
  13505. C  X2     (output) : the x-coordinate of the top right corner
  13506. C                    of the window.
  13507. C  Y1     (output) : the y-coordinate of the bottom left corner
  13508. C                    of the window.
  13509. C  Y2     (output) : the y-coordinate of the top right corner
  13510. C                    of the window.
  13511. C--
  13512. C 26-Sep-1985 - new routine (TJP).
  13513. C-----------------------------------------------------------------------
  13514.       INCLUDE 'f77.PGPLOT/IN'
  13515. C
  13516.       X1 = PGXBLC(PGID)
  13517.       X2 = PGXTRC(PGID)
  13518.       Y1 = PGYBLC(PGID)
  13519.       Y2 = PGYTRC(PGID)
  13520.       END
  13521. C*PGRECT -- draw a rectangle, using fill-area attributes
  13522. C%void cpgrect(float x1, float x2, float y1, float y2);
  13523. C+
  13524.       SUBROUTINE PGRECT (X1, X2, Y1, Y2)
  13525.       REAL X1, X2, Y1, Y2
  13526. C
  13527. C This routine can be used instead of PGPOLY for the special case of
  13528. C drawing a rectangle aligned with the coordinate axes; only two
  13529. C vertices need be specified instead of four.  On most devices, it is
  13530. C faster to use PGRECT than PGPOLY for drawing rectangles.  The
  13531. C rectangle has vertices at (X1,Y1), (X1,Y2), (X2,Y2), and (X2,Y1).
  13532. C
  13533. C Arguments:
  13534. C  X1, X2 (input) : the horizontal range of the rectangle.
  13535. C  Y1, Y2 (input) : the vertical range of the rectangle.
  13536. C--
  13537. C 21-Nov-1986 - [TJP].
  13538. C 22-Mar-1988 - use GRRECT for fill [TJP].
  13539. C  6-Mar-1995 - add hatching (by calling PGHTCH) [TJP].
  13540. C-----------------------------------------------------------------------
  13541.       INCLUDE  'f77.PGPLOT/IN'
  13542.       REAL XP(4), YP(4)
  13543. C
  13544.       CALL PGBBUF
  13545. C
  13546. C Outline only.
  13547. C
  13548.       IF (PGFAS(PGID).EQ.2) THEN
  13549.          CALL GRMOVA(X1,Y1)
  13550.          CALL GRLINA(X1,Y2)
  13551.          CALL GRLINA(X2,Y2)
  13552.          CALL GRLINA(X2,Y1)
  13553.          CALL GRLINA(X1,Y1)
  13554. C
  13555. C Hatching.
  13556. C
  13557.       ELSE IF (PGFAS(PGID).EQ.3 .OR. PGFAS(PGID).EQ.4) THEN
  13558.          XP(1) = X1
  13559.          XP(2) = X1
  13560.          XP(3) = X2
  13561.          XP(4) = X2
  13562.          YP(1) = Y1
  13563.          YP(2) = Y2
  13564.          YP(3) = Y2
  13565.          YP(4) = Y1
  13566.          CALL PGHTCH(4, XP, YP, 0.0)
  13567.          IF (PGFAS(PGID).EQ.4) CALL PGHTCH(4, XP, YP, 90.0)
  13568. C
  13569. C Solid fill.
  13570. C
  13571.       ELSE
  13572.           CALL GRRECT(X1,Y1,X2,Y2)
  13573.           CALL GRMOVA(X1,Y1)
  13574.       END IF
  13575.       CALL PGEBUF
  13576.       END
  13577. C*PGRND -- find the smallest `round' number greater than x
  13578. C%float cpgrnd(float x, int *nsub);
  13579. C+
  13580.       REAL FUNCTION PGRND (X, NSUB)
  13581.       REAL X
  13582.       INTEGER NSUB
  13583. C
  13584. C Routine to find the smallest "round" number larger than x, a
  13585. C "round" number being 1, 2 or 5 times a power of 10. If X is negative,
  13586. C PGRND(X) = -PGRND(ABS(X)). eg PGRND(8.7) = 10.0,
  13587. C PGRND(-0.4) = -0.5.  If X is zero, the value returned is zero.
  13588. C This routine is used by PGBOX for choosing  tick intervals.
  13589. C
  13590. C Returns:
  13591. C  PGRND         : the "round" number.
  13592. C Arguments:
  13593. C  X      (input)  : the number to be rounded.
  13594. C  NSUB   (output) : a suitable number of subdivisions for
  13595. C                    subdividing the "nice" number: 2 or 5.
  13596. C--
  13597. C  6-Sep-1989 - Changes for standard Fortran-77 [TJP].
  13598. C  2-Dec-1991 - Fix for bug found on Fujitsu [TJP].
  13599. C-----------------------------------------------------------------------
  13600.       INTEGER  I,ILOG
  13601.       REAL     FRAC,NICE(3),PWR,XLOG,XX
  13602.       INTRINSIC ABS, LOG10, SIGN
  13603.       DATA     NICE/2.0,5.0,10.0/
  13604. C
  13605.       IF (X.EQ.0.0) THEN
  13606.           PGRND = 0.0
  13607.           NSUB = 2
  13608.           RETURN
  13609.       END IF
  13610.       XX   = ABS(X)
  13611.       XLOG = LOG10(XX)
  13612.       ILOG = XLOG
  13613.       IF (XLOG.LT.0) ILOG=ILOG-1
  13614.       PWR  = 10.0**ILOG
  13615.       FRAC = XX/PWR
  13616.       I = 3
  13617.       IF (FRAC.LE.NICE(2)) I = 2
  13618.       IF (FRAC.LE.NICE(1)) I = 1
  13619.       PGRND = SIGN(PWR*NICE(I),X)
  13620.       NSUB = 5
  13621.       IF (I.EQ.1) NSUB = 2
  13622.       END
  13623. C*PGRNGE -- choose axis limits
  13624. C%void cpgrnge(float x1, float x2, float *xlo, float *xhi);
  13625. C+
  13626.       SUBROUTINE PGRNGE (X1, X2, XLO, XHI)
  13627.       REAL X1, X2, XLO, XHI
  13628. C
  13629. C Choose plotting limits XLO and XHI which encompass the data
  13630. C range X1 to X2.
  13631. C
  13632. C Arguments:
  13633. C  X1, X2 (input)  : the data range (X1<X2), ie, the min and max values
  13634. C                    to be plotted.
  13635. C  XLO, XHI (output) : suitable values to use as the extremes of a graph
  13636. C                    axis (XLO <= X1, XHI >= X2).
  13637. C--
  13638. C 10-Nov-1985 - new routine [TJP].
  13639. C-----------------------------------------------------------------------
  13640.       XLO = X1 - 0.1*(X2-X1)
  13641.       XHI = X2 + 0.1*(X2-X1)
  13642.       IF (XLO.LT.0.0 .AND. X1.GE.0.0) XLO = 0.0
  13643.       IF (XHI.GT.0.0 .AND. X2.LE.0.0) XHI = 0.0
  13644.       END
  13645. C*PGSAH -- set arrow-head style
  13646. C%void cpgsah(int fs, float angle, float barb);
  13647. C+
  13648.       SUBROUTINE PGSAH (FS, ANGLE, BARB)
  13649.       INTEGER  FS
  13650.       REAL ANGLE, BARB
  13651. C
  13652. C Set the style to be used for arrowheads drawn with routine PGARRO.
  13653. C
  13654. C Argument:
  13655. C  FS     (input)  : FS = 1 => filled; FS = 2 => outline.
  13656. C                    Other values are treated as 2. Default 1.
  13657. C  ANGLE  (input)  : the acute angle of the arrow point, in degrees;
  13658. C                    angles in the range 20.0 to 90.0 give reasonable
  13659. C                    results. Default 45.0.
  13660. C  BARB   (input)  : the fraction of the triangular arrow-head that
  13661. C                    is cut away from the back. 0.0 gives a triangular
  13662. C                    wedge arrow-head; 1.0 gives an open >. Values 0.3
  13663. C                    to 0.7 give reasonable results. Default 0.3.
  13664. C--
  13665. C 13-Oct-1992 - new routine [TJP].
  13666. C-----------------------------------------------------------------------
  13667.       INCLUDE 'f77.PGPLOT/IN'
  13668. C
  13669.       PGAHS(PGID) = FS
  13670.       IF (PGAHS(PGID).NE.1) PGAHS(PGID) = 2
  13671.       PGAHA(PGID) = ANGLE
  13672.       PGAHV(PGID) = BARB
  13673. C
  13674.       END
  13675. C*PGSAVE -- save PGPLOT attributes
  13676. C%void cpgsave(void);
  13677. C+
  13678.       SUBROUTINE PGSAVE
  13679. C
  13680. C This routine saves the current PGPLOT attributes in a private storage
  13681. C area. They can be restored by calling PGUNSA (unsave). Attributes
  13682. C saved are: character font, character height, color index, fill-area
  13683. C style, line style, line width, pen position, arrow-head style, 
  13684. C hatching style, and clipping state. Color representation is not saved.
  13685. C
  13686. C Calls to PGSAVE and PGUNSA should always be paired. Up to 20 copies
  13687. C of the attributes may be saved. PGUNSA always retrieves the last-saved
  13688. C values (last-in first-out stack).
  13689. C
  13690. C Note that when multiple devices are in use, PGUNSA retrieves the
  13691. C values saved by the last PGSAVE call, even if they were for a
  13692. C different device.
  13693. C
  13694. C Arguments: none
  13695. C--
  13696. C 20-Apr-1992 - new routine [TJP].
  13697. C 27-Nov-1992 - add arrowhead style [TJP].
  13698. C  6-Oct-1993 - add text opacity [TJP].
  13699. C 28-Feb-1994 - correct bug (variable not saved) [TJP].
  13700. C 26-Feb-1995 - add hatching attributes.
  13701. C 19-Jun-1996 - correction in header comments [TJP].
  13702. C 26-Feb-1997 - add clipping state [TJP].
  13703. C-----------------------------------------------------------------------
  13704.       INTEGER MAXS
  13705.       PARAMETER (MAXS=20)
  13706. C
  13707.       INTEGER LEV
  13708.       INTEGER CF(MAXS), CI(MAXS), FS(MAXS), LS(MAXS), LW(MAXS)
  13709.       INTEGER AHFS(MAXS), TBG(MAXS), CLP(MAXS)
  13710.       REAL    CH(MAXS), POS(2,MAXS)
  13711.       REAL    AHANG(MAXS), AHBARB(MAXS), HSA(MAXS), HSS(MAXS), HSP(MAXS)
  13712.       SAVE    LEV, CF, CI, FS, LS, LW, AHFS, TBG, CH, POS
  13713.       SAVE    AHANG, AHBARB, HSA, HSS, HSP, CLP
  13714.       DATA    LEV /0/
  13715. C
  13716.       IF (LEV.GE.MAXS) THEN
  13717.           CALL GRWARN('Too many unmatched calls to PGSAVE')
  13718.       ELSE
  13719.           LEV = LEV+1
  13720.           CALL PGQCF(CF(LEV))
  13721.           CALL PGQCH(CH(LEV))
  13722.           CALL PGQCI(CI(LEV))
  13723.           CALL PGQFS(FS(LEV))
  13724.           CALL PGQLS(LS(LEV))
  13725.           CALL PGQLW(LW(LEV))
  13726. C          CALL PGQVP(0, VP(1,LEV), VP(2,LEV), VP(3,LEV), VP(4,LEV))
  13727. C          CALL PGQWIN(WIN(1,LEV), WIN(2,LEV), WIN(3,LEV), WIN(4,LEV))
  13728.           CALL PGQPOS(POS(1,LEV), POS(2,LEV))
  13729.           CALL PGQAH(AHFS(LEV), AHANG(LEV), AHBARB(LEV))
  13730.           CALL PGQTBG(TBG(LEV))
  13731.           CALL PGQHS(HSA(LEV), HSS(LEV), HSP(LEV))
  13732.           CALL PGQCLP(CLP(LEV))
  13733.       END IF
  13734.       RETURN     
  13735. C
  13736. C*PGUNSA -- restore PGPLOT attributes
  13737. C%void cpgunsa(void);
  13738. C+
  13739.       ENTRY PGUNSA
  13740. C
  13741. C This routine restores the PGPLOT attributes saved in the last call to
  13742. C PGSAVE. Usage: CALL PGUNSA (no arguments). See PGSAVE.
  13743. C
  13744. C Arguments: none
  13745. C-----------------------------------------------------------------------
  13746.       IF (LEV.LE.0) THEN
  13747.           CALL GRWARN('PGUNSA: nothing has been saved')
  13748.       ELSE
  13749.           CALL PGSCF(CF(LEV))
  13750.           CALL PGSCH(CH(LEV))
  13751.           CALL PGSCI(CI(LEV))
  13752.           CALL PGSFS(FS(LEV))
  13753.           CALL PGSLS(LS(LEV))
  13754.           CALL PGSLW(LW(LEV))
  13755. C          CALL PGSVP(VP(1,LEV), VP(2,LEV), VP(3,LEV), VP(4,LEV))
  13756. C          CALL PGSWIN(WIN(1,LEV), WIN(2,LEV), WIN(3,LEV), WIN(4,LEV))
  13757.           CALL PGMOVE(POS(1,LEV), POS(2,LEV))
  13758.           CALL PGSAH(AHFS(LEV), AHANG(LEV), AHBARB(LEV))
  13759.           CALL PGSTBG(TBG(LEV))
  13760.           CALL PGSHS(HSA(LEV), HSS(LEV), HSP(LEV))
  13761.           CALL PGSCLP(CLP(LEV))
  13762.           LEV = LEV-1
  13763.       END IF
  13764.       RETURN     
  13765.       END
  13766. C*PGSCF -- set character font
  13767. C%void cpgscf(int font);
  13768. C+
  13769.       SUBROUTINE PGSCF (FONT)
  13770.       INTEGER  FONT
  13771. C
  13772. C Set the Character Font for subsequent text plotting. Four different
  13773. C fonts are available:
  13774. C   1: (default) a simple single-stroke font ("normal" font)
  13775. C   2: roman font
  13776. C   3: italic font
  13777. C   4: script font
  13778. C This call determines which font is in effect at the beginning of
  13779. C each text string. The font can be changed (temporarily) within a text
  13780. C string by using the escape sequences \fn, \fr, \fi, and \fs for fonts
  13781. C 1, 2, 3, and 4, respectively.
  13782. C
  13783. C Argument:
  13784. C  FONT   (input)  : the font number to be used for subsequent text
  13785. C                    plotting (in range 1-4).
  13786. C--
  13787. C 26-Sep-1985 - new routine [TJP].
  13788. C 25-OCT-1993 - changed name of argument [TJP].
  13789. C-----------------------------------------------------------------------
  13790.       LOGICAL PGNOTO
  13791. C
  13792.       IF (PGNOTO('PGSCF')) RETURN
  13793.       CALL GRSFNT(FONT)
  13794.       END
  13795. C*PGSCH -- set character height
  13796. C%void cpgsch(float size);
  13797. C+
  13798.       SUBROUTINE PGSCH (SIZE)
  13799.       REAL SIZE
  13800. C
  13801. C Set the character size attribute. The size affects all text and graph
  13802. C markers drawn later in the program. The default character size is
  13803. C 1.0, corresponding to a character height about 1/40 the height of
  13804. C the view surface.  Changing the character size also scales the length
  13805. C of tick marks drawn by PGBOX and terminals drawn by PGERRX and PGERRY.
  13806. C
  13807. C Argument:
  13808. C  SIZE   (input)  : new character size (dimensionless multiple of
  13809. C                    the default size).
  13810. C--
  13811. C (1-Mar-1983)
  13812. C-----------------------------------------------------------------------
  13813.       INCLUDE  'f77.PGPLOT/IN'
  13814.       LOGICAL  PGNOTO
  13815.       REAL     XC, XCNEW, YC, XS, YS
  13816. C
  13817.       IF (PGNOTO('PGSCH')) RETURN
  13818. C
  13819.       CALL GRCHSZ(PGID, XC, YC, XS, YS)
  13820.       IF (PGXSZ(PGID)/PGXPIN(PGID) .GT.
  13821.      1    PGYSZ(PGID)/PGYPIN(PGID)) THEN
  13822.           XCNEW = SIZE*XC*PGYSZ(PGID)/YS/40.0
  13823.       ELSE
  13824.           XCNEW = SIZE*XC*(PGXSZ(PGID)*PGYPIN(PGID)/PGXPIN(PGID))
  13825.      1            /YS/40.0
  13826.       END IF
  13827.       CALL GRSETC(PGID,XCNEW)
  13828.       PGXSP(PGID) = XS*XCNEW/XC
  13829.       PGYSP(PGID) = YS*XCNEW/XC
  13830.       PGCHSZ(PGID) = SIZE
  13831.       END
  13832. C*PGSCI -- set color index
  13833. C%void cpgsci(int ci);
  13834. C+
  13835.       SUBROUTINE PGSCI (CI)
  13836.       INTEGER  CI
  13837. C
  13838. C Set the Color Index for subsequent plotting, if the output device
  13839. C permits this. The default color index is 1, usually white on a black
  13840. C background for video displays or black on a white background for
  13841. C printer plots. The color index is an integer in the range 0 to a
  13842. C device-dependent maximum. Color index 0 corresponds to the background
  13843. C color; lines may be "erased" by overwriting them with color index 0
  13844. C (if the device permits this).
  13845. C
  13846. C If the requested color index is not available on the selected device,
  13847. C color index 1 will be substituted.
  13848. C
  13849. C The assignment of colors to color indices can be changed with
  13850. C subroutine PGSCR (set color representation).  Color indices 0-15
  13851. C have predefined color representations (see the PGPLOT manual), but
  13852. C these may be changed with PGSCR.  Color indices above 15  have no
  13853. C predefined representations: if these indices are used, PGSCR must
  13854. C be called to define the representation.
  13855. C
  13856. C Argument:
  13857. C  CI     (input)  : the color index to be used for subsequent plotting
  13858. C                    on the current device (in range 0-max). If the
  13859. C                    index exceeds the device-dependent maximum, the
  13860. C                    default color index (1) is used.
  13861. C--
  13862. C 26-Sep-1985 - new routine [TJP].
  13863. C-----------------------------------------------------------------------
  13864.       LOGICAL PGNOTO
  13865. C
  13866.       IF (PGNOTO('PGSCI')) RETURN
  13867.       CALL GRSCI(CI)
  13868.       END
  13869. C*PGSCIR -- set color index range
  13870. C%void cpgscir(int icilo, int icihi);
  13871. C+
  13872.       SUBROUTINE PGSCIR(ICILO, ICIHI)
  13873.       INTEGER   ICILO, ICIHI
  13874. C
  13875. C Set the color index range to be used for producing images with
  13876. C PGGRAY or PGIMAG. If the range is not all within the range supported
  13877. C by the device, a smaller range will be used. The number of
  13878. C different colors available for images is ICIHI-ICILO+1.
  13879. C
  13880. C Arguments:
  13881. C  ICILO  (input)  : the lowest color index to use for images
  13882. C  ICIHI  (input)  : the highest color index to use for images
  13883. C--
  13884. C 1994-Mar-17 : new routine [AFT/TJP].
  13885. C---
  13886.       INCLUDE 'f77.PGPLOT/IN'
  13887.       INTEGER IC1, IC2
  13888. C---
  13889.       CALL GRQCOL(IC1,IC2)
  13890.       PGMNCI(PGID) = MIN(IC2,MAX(IC1,ICILO))
  13891.       PGMXCI(PGID) = MIN(IC2,MAX(IC1,ICIHI))
  13892. C
  13893.       END
  13894. C*PGSCLP -- enable or disable clipping at edge of viewport
  13895. C%void cpgsclp(int state);
  13896. C+
  13897.       SUBROUTINE PGSCLP(STATE)
  13898.       INTEGER STATE
  13899. C
  13900. C Normally all PGPLOT primitives except text are ``clipped'' at the
  13901. C edge of the viewport: parts of the primitives that lie outside
  13902. C the viewport are not drawn. If clipping is disabled by calling this
  13903. C routine, primitives are visible wherever they lie on the view
  13904. C surface. The default (clipping enabled) is appropriate for almost
  13905. C all applications.
  13906. C
  13907. C Argument:
  13908. C  STATE  (input)  : 0 to disable clipping, or 1 to enable clipping.
  13909. C 
  13910. C 25-Feb-1997 [TJP] - new routine.
  13911. C-----------------------------------------------------------------------
  13912.       INCLUDE  'f77.PGPLOT/IN'
  13913.       LOGICAL PGNOTO
  13914. C
  13915.       IF (PGNOTO('PGSCLP')) RETURN
  13916. C
  13917. C Disable clipping.
  13918. C
  13919.       IF (STATE.EQ.0) THEN
  13920.          CALL GRAREA(PGID,0.,0.,-1.,-1.)
  13921.          PGCLP(PGID) = 0
  13922. C
  13923. C Enable clipping.
  13924. C
  13925.       ELSE
  13926.          CALL GRAREA(PGID,PGXOFF(PGID),PGYOFF(PGID),
  13927.      :               PGXLEN(PGID),PGYLEN(PGID))
  13928.          PGCLP(PGID) = 1
  13929.       END IF
  13930.       END
  13931. C*PGSCR -- set color representation
  13932. C%void cpgscr(int ci, float cr, float cg, float cb);
  13933. C+
  13934.       SUBROUTINE PGSCR (CI, CR, CG, CB)
  13935.       INTEGER CI
  13936.       REAL    CR, CG, CB
  13937. C
  13938. C Set color representation: i.e., define the color to be
  13939. C associated with a color index.  Ignored for devices which do not
  13940. C support variable color or intensity.  Color indices 0-15
  13941. C have predefined color representations (see the PGPLOT manual), but
  13942. C these may be changed with PGSCR.  Color indices 16-maximum have no
  13943. C predefined representations: if these indices are used, PGSCR must
  13944. C be called to define the representation. On monochrome output
  13945. C devices (e.g. VT125 terminals with monochrome monitors), the
  13946. C monochrome intensity is computed from the specified Red, Green, Blue
  13947. C intensities as 0.30*R + 0.59*G + 0.11*B, as in US color television
  13948. C systems, NTSC encoding.  Note that most devices do not have an
  13949. C infinite range of colors or monochrome intensities available;
  13950. C the nearest available color is used.  Examples: for black,
  13951. C set CR=CG=CB=0.0; for white, set CR=CG=CB=1.0; for medium gray,
  13952. C set CR=CG=CB=0.5; for medium yellow, set CR=CG=0.5, CB=0.0.
  13953. C
  13954. C Argument:
  13955. C  CI     (input)  : the color index to be defined, in the range 0-max.
  13956. C                    If the color index greater than the device
  13957. C                    maximum is specified, the call is ignored. Color
  13958. C                    index 0 applies to the background color.
  13959. C  CR     (input)  : red, green, and blue intensities,
  13960. C  CG     (input)    in range 0.0 to 1.0.
  13961. C  CB     (input)
  13962. C--
  13963. C 5-Nov-1985 - new routine [TJP].
  13964. C-----------------------------------------------------------------------
  13965.       LOGICAL PGNOTO
  13966. C
  13967.       IF (PGNOTO('PGSCR')) RETURN
  13968.       CALL GRSCR(CI,CR,CG,CB)
  13969.       END
  13970. C*PGSCRL -- scroll window
  13971. C%void cpgscrl(float dx, float dy);
  13972. C+
  13973.       SUBROUTINE PGSCRL (DX, DY)
  13974.       REAL DX, DY
  13975. C
  13976. C This routine moves the window in world-coordinate space while
  13977. C leaving the viewport unchanged. On devices that have the
  13978. C capability, the pixels within the viewport are scrolled
  13979. C horizontally, vertically or both in such a way that graphics
  13980. C previously drawn in the window are shifted so that their world
  13981. C coordinates are unchanged.
  13982. C
  13983. C If the old window coordinate range was (X1, X2, Y1, Y2), the new
  13984. C coordinate range will be approximately (X1+DX, X2+DX, Y1+DY, Y2+DY).
  13985. C The size and scale of the window are unchanged.
  13986. C
  13987. C Thee window can only be shifted by a whole number of pixels
  13988. C (device coordinates). If DX and DY do not correspond to integral
  13989. C numbers of pixels, the shift will be slightly different from that
  13990. C requested. The new window-coordinate range, and hence the exact
  13991. C amount of the shift, can be determined by calling PGQWIN after this
  13992. C routine.
  13993. C
  13994. C Pixels that are moved out of the viewport by this operation are
  13995. C lost completely; they cannot be recovered by scrolling back.
  13996. C Pixels that are ``scrolled into'' the viewport are filled with
  13997. C the background color (color index 0).
  13998. C
  13999. C If the absolute value of DX is bigger than the width of the window,
  14000. C or the aboslute value of DY is bigger than the height of the window,
  14001. C the effect will be the same as zeroing all the pixels in the
  14002. C viewport.
  14003. C
  14004. C Not all devices have the capability to support this routine.
  14005. C It is only available on some interactive devices that have discrete
  14006. C pixels. To determine whether the current device has scroll capability,
  14007. C call PGQINF.
  14008. C
  14009. C Arguments:
  14010. C  DX     (input)  : distance (in world coordinates) to shift the
  14011. C                    window horizontally (positive shifts window to the
  14012. C                    right and scrolls to the left).
  14013. C  DY     (input)  : distance (in world coordinates) to shift the
  14014. C                    window vertically (positive shifts window up and
  14015. C                    scrolls down).
  14016. C--
  14017. C 25-Feb-97: new routine [TJP].
  14018. C-----------------------------------------------------------------------
  14019.       INCLUDE 'f77.PGPLOT/IN'
  14020.       LOGICAL PGNOTO
  14021.       REAL X1, X2, Y1, Y2, DDX, DDY
  14022.       INTEGER NDX, NDY
  14023. C
  14024.       IF (PGNOTO('PGSCRL')) RETURN
  14025. C
  14026. C Shift must be a whole number of pixels.
  14027. C
  14028.       NDX = NINT(DX*PGXSCL(PGID))
  14029.       NDY = NINT(DY*PGYSCL(PGID))
  14030. C
  14031.       IF (NDX.NE.0 .OR. NDY.NE.0) THEN
  14032.          CALL PGBBUF
  14033.          DDX = NDX/PGXSCL(PGID)
  14034.          DDY = NDY/PGYSCL(PGID)
  14035. C
  14036. C        -- Set new world-ccordinate window.
  14037. C
  14038.          X1 = PGXBLC(PGID)
  14039.          X2 = PGXTRC(PGID)
  14040.          Y1 = PGYBLC(PGID)
  14041.          Y2 = PGYTRC(PGID)
  14042.          PGXBLC(PGID) = X1+DDX
  14043.          PGXTRC(PGID) = X2+DDX
  14044.          PGYBLC(PGID) = Y1+DDY
  14045.          PGYTRC(PGID) = Y2+DDY
  14046.          CALL PGVW
  14047. C
  14048. C        -- Do hardware scroll.
  14049. C
  14050.          CALL GRSCRL(NDX, NDY)
  14051.          CALL PGEBUF
  14052.       END IF
  14053.       END
  14054. C*PGSCRN -- set color representation by name
  14055. C%void cpgscrn(int ci, const char *name, int *ier);
  14056. C+
  14057.       SUBROUTINE PGSCRN(CI, NAME, IER)
  14058.       INTEGER CI
  14059.       CHARACTER*(*) NAME
  14060.       INTEGER IER
  14061. C
  14062. C Set color representation: i.e., define the color to be
  14063. C associated with a color index.  Ignored for devices which do not
  14064. C support variable color or intensity.  This is an alternative to
  14065. C routine PGSCR. The color representation is defined by name instead
  14066. C of (R,G,B) components.
  14067. C
  14068. C Color names are defined in an external file which is read the first
  14069. C time that PGSCRN is called. The name of the external file is
  14070. C found as follows:
  14071. C 1. if environment variable (logical name) PGPLOT_RGB is defined,
  14072. C    its value is used as the file name;
  14073. C 2. otherwise, if environment variable PGPLOT_DIR is defined, a
  14074. C    file "rgb.txt" in the directory named by this environment
  14075. C    variable is used;
  14076. C 3. otherwise, file "rgb.txt" in the current directory is used.
  14077. C If all of these fail to find a file, an error is reported and
  14078. C the routine does nothing.
  14079. C
  14080. C Each line of the file
  14081. C defines one color, with four blank- or tab-separated fields per
  14082. C line. The first three fields are the R, G, B components, which
  14083. C are integers in the range 0 (zero intensity) to 255 (maximum
  14084. C intensity). The fourth field is the color name. The color name
  14085. C may include embedded blanks. Example:
  14086. C
  14087. C 255   0   0 red
  14088. C 255 105 180 hot pink
  14089. C 255 255 255 white
  14090. C   0   0   0 black
  14091. C
  14092. C Arguments:
  14093. C  CI     (input)  : the color index to be defined, in the range 0-max.
  14094. C                    If the color index greater than the device
  14095. C                    maximum is specified, the call is ignored. Color
  14096. C                    index 0 applies to the background color.
  14097. C  NAME   (input)  : the name of the color to be associated with
  14098. C                    this color index. This name must be in the
  14099. C                    external file. The names are not case-sensitive.
  14100. C                    If the color is not listed in the file, the
  14101. C                    color representation is not changed.
  14102. C  IER    (output) : returns 0 if the routine was successful, 1
  14103. C                    if an error occurred (either the external file
  14104. C                    could not be read, or the requested color was
  14105. C                    not defined in the file).
  14106. C--
  14107. C 12-Oct-1992 [TJP]
  14108. C 31-May-1993 [TJP] use GROPTX to open file.
  14109. C  7-Nov-1994 [TJP] better error messages.
  14110. C-----------------------------------------------------------------------
  14111.       INTEGER MAXCOL
  14112.       PARAMETER (MAXCOL=1000)
  14113.       INTEGER I, IR, IG, IB, J, L, NCOL, UNIT, IOS
  14114.       INTEGER GRCTOI, GROPTX, GRTRIM
  14115.       REAL RR(MAXCOL), RG(MAXCOL), RB(MAXCOL)
  14116.       CHARACTER*20 CREQ, CNAME(MAXCOL)
  14117.       CHARACTER*255 TEXT
  14118.       SAVE NCOL, CNAME, RR, RG, RB
  14119.       DATA NCOL/0/
  14120. C
  14121. C On first call, read the database.
  14122. C
  14123.       IF (NCOL.EQ.0) THEN
  14124.           CALL GRGFIL('RGB', TEXT)
  14125.           L = GRTRIM(TEXT)
  14126.           IF (L.LT.1) L = 1
  14127.           CALL GRGLUN(UNIT)
  14128.           IOS = GROPTX(UNIT, TEXT(1:L), 'rgb.txt', 0)
  14129.           IF (IOS.NE.0) GOTO 40
  14130.           DO 10 I=1,MAXCOL
  14131.               READ (UNIT, '(A)', ERR=15, END=15) TEXT
  14132.               J = 1
  14133.               CALL GRSKPB(TEXT, J)
  14134.               IR = GRCTOI(TEXT, J)
  14135.               CALL GRSKPB(TEXT, J)
  14136.               IG = GRCTOI(TEXT, J)
  14137.               CALL GRSKPB(TEXT, J)
  14138.               IB = GRCTOI(TEXT, J)
  14139.               CALL GRSKPB(TEXT, J)
  14140.               NCOL = NCOL+1
  14141.               CALL GRTOUP(CNAME(NCOL), TEXT(J:))
  14142.               RR(NCOL) = IR/255.0
  14143.               RG(NCOL) = IG/255.0
  14144.               RB(NCOL) = IB/255.0
  14145.    10     CONTINUE
  14146.    15     CLOSE (UNIT)
  14147.           CALL GRFLUN(UNIT)
  14148.       END IF
  14149. C
  14150. C Look up requested color and set color representation if found.
  14151. C
  14152.       CALL GRTOUP(CREQ, NAME)
  14153.       DO 20 I=1,NCOL
  14154.           IF (CREQ.EQ.CNAME(I)) THEN
  14155.               CALL PGSCR(CI, RR(I), RG(I), RB(I))
  14156.               IER = 0
  14157.               RETURN
  14158.           END IF
  14159.    20 CONTINUE
  14160. C
  14161. C Color not found.
  14162. C
  14163.       IER = 1
  14164.       TEXT = 'Color not found: '//NAME
  14165.       CALL GRWARN(TEXT)
  14166.       RETURN
  14167. C
  14168. C Database not found.
  14169. C
  14170.    40 IER = 1
  14171.       NCOL = -1
  14172.       CALL GRFLUN(UNIT)
  14173.       CALL GRWARN('Unable to read color file: '//TEXT(1:L))
  14174.       CALL GRWARN('Use environment variable PGPLOT_RGB to specify '//
  14175.      :            'the location of the PGPLOT rgb.txt file.')
  14176.       RETURN
  14177.       END
  14178. C
  14179.       SUBROUTINE PGSETC (SIZE)
  14180.       REAL SIZE
  14181.       CALL PGSCH(SIZE)
  14182.       END
  14183. C*PGSFS -- set fill-area style
  14184. C%void cpgsfs(int fs);
  14185. C+
  14186.       SUBROUTINE PGSFS (FS)
  14187.       INTEGER  FS
  14188. C
  14189. C Set the Fill-Area Style attribute for subsequent area-fill by
  14190. C PGPOLY, PGRECT, or PGCIRC.  Four different styles are available: 
  14191. C solid (fill polygon with solid color of the current color-index), 
  14192. C outline (draw outline of polygon only, using current line attributes),
  14193. C hatched (shade interior of polygon with parallel lines, using
  14194. C current line attributes), or cross-hatched. The orientation and
  14195. C spacing of hatch lines can be specified with routine PGSHS (set
  14196. C hatch style).
  14197. C
  14198. C Argument:
  14199. C  FS     (input)  : the fill-area style to be used for subsequent
  14200. C                    plotting:
  14201. C                      FS = 1 => solid (default)
  14202. C                      FS = 2 => outline
  14203. C                      FS = 3 => hatched
  14204. C                      FS = 4 => cross-hatched
  14205. C                    Other values give an error message and are
  14206. C                    treated as 2.
  14207. C--
  14208. C 21-Oct-1985 - new routine [TJP].
  14209. C 17-Dec-1990 - pass to GR level [TJP].
  14210. C  6-Mar-1995 - add styles 3 and 4 [TJP].
  14211. C-----------------------------------------------------------------------
  14212.       INCLUDE 'f77.PGPLOT/IN'
  14213.       LOGICAL PGNOTO
  14214. C
  14215.       IF (PGNOTO('PGSFS')) RETURN
  14216.       IF (FS.LT.1 .OR. FS.GT.4) THEN
  14217.           CALL GRWARN('illegal fill-area style requested')
  14218.           PGFAS(PGID) = 2
  14219.       ELSE
  14220.           PGFAS(PGID) = FS
  14221.       END IF
  14222.       END
  14223. C*PGSHLS -- set color representation using HLS system
  14224. C%void cpgshls(int ci, float ch, float cl, float cs);
  14225. C+
  14226.       SUBROUTINE PGSHLS (CI, CH, CL, CS)
  14227.       INTEGER CI
  14228.       REAL    CH, CL, CS
  14229. C
  14230. C Set color representation: i.e., define the color to be
  14231. C associated with a color index.  This routine is equivalent to
  14232. C PGSCR, but the color is defined in the Hue-Lightness-Saturation
  14233. C model instead of the Red-Green-Blue model. Hue is represented
  14234. C by an angle in degrees, with red at 120, green at 240,
  14235. C and blue at 0 (or 360). Lightness ranges from 0.0 to 1.0, with black
  14236. C at lightness 0.0 and white at lightness 1.0. Saturation ranges from
  14237. C 0.0 (gray) to 1.0 (pure color). Hue is irrelevant when saturation
  14238. C is 0.0.
  14239. C
  14240. C Examples:           H     L     S        R     G     B
  14241. C     black          any   0.0   0.0      0.0   0.0   0.0
  14242. C     white          any   1.0   0.0      1.0   1.0   1.0
  14243. C     medium gray    any   0.5   0.0      0.5   0.5   0.5
  14244. C     red            120   0.5   1.0      1.0   0.0   0.0
  14245. C     yellow         180   0.5   1.0      1.0   1.0   0.0
  14246. C     pink           120   0.7   0.8      0.94  0.46  0.46
  14247. C
  14248. C Reference: SIGGRAPH Status Report of the Graphic Standards Planning
  14249. C Committee, Computer Graphics, Vol.13, No.3, Association for
  14250. C Computing Machinery, New York, NY, 1979. See also: J. D. Foley et al,
  14251. C ``Computer Graphics: Principles and Practice'', second edition,
  14252. C Addison-Wesley, 1990, section 13.3.5.
  14253. C
  14254. C Argument:
  14255. C  CI     (input)  : the color index to be defined, in the range 0-max.
  14256. C                    If the color index greater than the device
  14257. C                    maximum is specified, the call is ignored. Color
  14258. C                    index 0 applies to the background color.
  14259. C  CH     (input)  : hue, in range 0.0 to 360.0.
  14260. C  CL     (input)  : lightness, in range 0.0 to 1.0.
  14261. C  CS     (input)  : saturation, in range 0.0 to 1.0.
  14262. C--
  14263. C 9-May-1988 - new routine [TJP].
  14264. C-----------------------------------------------------------------------
  14265.       REAL CR, CG, CB
  14266.       CALL GRXRGB (CH,CL,CS,CR,CG,CB)
  14267.       CALL GRSCR(CI,CR,CG,CB)
  14268.       END
  14269. C*PGSHS -- set hatching style
  14270. C%void cpgshs(float angle, float sepn, float phase);
  14271. C+
  14272.       SUBROUTINE PGSHS (ANGLE, SEPN, PHASE)
  14273.       REAL ANGLE, SEPN, PHASE
  14274. C
  14275. C Set the style to be used for hatching (fill area with fill-style 3).
  14276. C The default style is ANGLE=45.0, SEPN=1.0, PHASE=0.0.
  14277. C
  14278. C Arguments:
  14279. C  ANGLE  (input)  : the angle the hatch lines make with the
  14280. C                    horizontal, in degrees, increasing 
  14281. C                    counterclockwise (this is an angle on the
  14282. C                    view surface, not in world-coordinate space).
  14283. C  SEPN   (input)  : the spacing of the hatch lines. The unit spacing
  14284. C                    is 1 percent of the smaller of the height or
  14285. C                    width of the view surface. This should not be
  14286. C                    zero.
  14287. C  PHASE  (input)  : a real number between 0 and 1; the hatch lines
  14288. C                    are displaced by this fraction of SEPN from a
  14289. C                    fixed reference.  Adjacent regions hatched with the
  14290. C                    same PHASE have contiguous hatch lines. To hatch
  14291. C                    a region with alternating lines of two colors,
  14292. C                    fill the area twice, with PHASE=0.0 for one color
  14293. C                    and PHASE=0.5 for the other color.
  14294. C--
  14295. C 26-Feb-1995 - new routine [TJP].
  14296. C 12-Feb-1996 - check for zero spacing [TJP].
  14297. C-----------------------------------------------------------------------
  14298.       INCLUDE 'f77.PGPLOT/IN'
  14299.       LOGICAL PGNOTO
  14300. C
  14301.       IF (PGNOTO('PGSHS')) RETURN
  14302.       PGHSA(PGID) = ANGLE
  14303.       IF (SEPN.EQ.0.0) THEN
  14304.          CALL GRWARN('PGSHS: zero hatch line spacing requested')
  14305.          PGHSS(PGID) = 1.0
  14306.       ELSE
  14307.          PGHSS(PGID) = SEPN
  14308.       END IF
  14309.       IF (PHASE.LT.0.0 .OR. PHASE.GT.1.0) THEN
  14310.          CALL GRWARN('PGSHS: hatching phase must be in (0.0,1.0)')
  14311.       END IF
  14312.       PGHSP(PGID) = PHASE
  14313. C
  14314.       END
  14315. C*PGSITF -- set image transfer function
  14316. C%void cpgsitf(int itf);
  14317. C+
  14318.       SUBROUTINE PGSITF (ITF)
  14319.       INTEGER  ITF
  14320. C
  14321. C Set the Image Transfer Function for subsequent images drawn by
  14322. C PGIMAG, PGGRAY, or PGWEDG. The Image Transfer Function is used
  14323. C to map array values into the available range of color indices
  14324. C specified with routine PGSCIR or (for PGGRAY on some devices)
  14325. C into dot density.
  14326. C
  14327. C Argument:
  14328. C  ITF    (input)  : type of transfer function:
  14329. C                      ITF = 0 : linear
  14330. C                      ITF = 1 : logarithmic
  14331. C                      ITF = 2 : square-root
  14332. C--
  14333. C 15-Sep-1994 - new routine [TJP].
  14334. C-----------------------------------------------------------------------
  14335.       INCLUDE 'f77.PGPLOT/IN'
  14336.       LOGICAL PGNOTO
  14337. C
  14338.       IF (PGNOTO('PGSITF')) RETURN
  14339.       IF (ITF.LT.0 .OR. ITF.GT.2) THEN
  14340.           PGITF(PGID) = 0
  14341.           CALL GRWARN('PGSITF: argument must be 0, 1, or 2')
  14342.       ELSE
  14343.           PGITF(PGID) = ITF
  14344.       END IF
  14345.       END
  14346. C
  14347.       SUBROUTINE PGSIZE (WIDTH, HEIGHT, SHIFTX, SHIFTY, DUMMY)
  14348. C
  14349. C PGPLOT (obsolete routine; use PGVSIZ in preference): Change the
  14350. C size and position of the viewport.
  14351. C
  14352. C Arguments:
  14353. C
  14354. C WIDTH (input, real) : width of viewport in inches.
  14355. C HEIGHT (input, real) : height of viewport in inches.
  14356. C SHIFTX (input, real) : horizontal offset of bottom left corner
  14357. C       from blc of page or panel, in inches.
  14358. C SHIFTY (input, real) : vertical offset of bottom left corner
  14359. C       from blc of page or panel, in inches.
  14360. C DUMMY (input, real) : reserved for future use (must be 0.0).
  14361. C--
  14362. C 13-Dec-1990  Make errors non-fatal [TJP].
  14363. C-----------------------------------------------------------------------
  14364.       REAL     WIDTH,HEIGHT,SHIFTX,SHIFTY,DUMMY
  14365. C
  14366.       IF (WIDTH.LE.0.0 .OR. HEIGHT.LE.0.0 .OR. DUMMY.NE.0.0) THEN
  14367.           CALL GRWARN('PGSIZE ignored: invalid arguments')
  14368.           RETURN
  14369.       END IF
  14370. C
  14371.       CALL PGVSIZ(SHIFTX, SHIFTX+WIDTH, SHIFTY, SHIFTY+HEIGHT)
  14372.       END
  14373. C*PGSLCT -- select an open graphics device
  14374. C%void cpgslct(int id);
  14375. C+
  14376.       SUBROUTINE PGSLCT(ID)
  14377.       INTEGER ID
  14378. C
  14379. C Select one of the open graphics devices and direct subsequent
  14380. C plotting to it. The argument is the device identifier returned by
  14381. C PGOPEN when the device was opened. If the supplied argument is not a
  14382. C valid identifier of an open graphics device, a warning message is
  14383. C issued and the current selection is unchanged.
  14384. C
  14385. C [This routine was added to PGPLOT in Version 5.1.0.]
  14386. C
  14387. C Arguments:
  14388. C
  14389. C ID (input, integer): identifier of the device to be selected.
  14390. C--
  14391. C 22-Dec-1995 - new routine [TJP].
  14392. C-----------------------------------------------------------------------
  14393.       INCLUDE 'f77.PGPLOT/IN'
  14394. C
  14395.       IF (ID.LT.1 .OR. ID.GT.PGMAXD) THEN
  14396.          CALL GRWARN('PGSLCT: invalid argument')
  14397.       ELSE IF (PGDEVS(ID).NE.1) THEN
  14398.          CALL GRWARN('PGSLCT: requested device is not open')
  14399.       ELSE
  14400. C        -- Select the new device
  14401.          PGID = ID
  14402.          CALL GRSLCT(PGID)
  14403.       END IF
  14404. C
  14405.       END
  14406. C*PGSLS -- set line style
  14407. C%void cpgsls(int ls);
  14408. C+
  14409.       SUBROUTINE PGSLS (LS)
  14410.       INTEGER  LS
  14411. C
  14412. C Set the line style attribute for subsequent plotting. This
  14413. C attribute affects line primitives only; it does not affect graph
  14414. C markers, text, or area fill.
  14415. C Five different line styles are available, with the following codes:
  14416. C 1 (full line), 2 (dashed), 3 (dot-dash-dot-dash), 4 (dotted),
  14417. C 5 (dash-dot-dot-dot). The default is 1 (normal full line).
  14418. C
  14419. C Argument:
  14420. C  LS     (input)  : the line-style code for subsequent plotting
  14421. C                    (in range 1-5).
  14422. C--
  14423. C  8-Aug-1985 - new routine, equivalent to GRSLS [TJP].
  14424. C  3-Jun-1984 - add GMFILE device [TJP].
  14425. C-----------------------------------------------------------------------
  14426.       LOGICAL PGNOTO
  14427. C
  14428.       IF (PGNOTO('PGSLS')) RETURN
  14429.       CALL GRSLS(LS)
  14430.       END
  14431. C*PGSLW -- set line width
  14432. C%void cpgslw(int lw);
  14433. C+
  14434.       SUBROUTINE PGSLW (LW)
  14435.       INTEGER  LW
  14436. C
  14437. C Set the line-width attribute. This attribute affects lines, graph
  14438. C markers, and text. The line width is specified in units of 1/200 
  14439. C (0.005) inch (about 0.13 mm) and must be an integer in the range
  14440. C 1-201. On some devices, thick lines are generated by tracing each
  14441. C line with multiple strokes offset in the direction perpendicular to
  14442. C the line.
  14443. C
  14444. C Argument:
  14445. C  LW     (input)  : width of line, in units of 0.005 inch (0.13 mm)
  14446. C                    in range 1-201.
  14447. C--
  14448. C  8-Aug-1985 - new routine, equivalent to GRSLW [TJP].
  14449. C  1-Feb-1995 - change comment [TJP].
  14450. C-----------------------------------------------------------------------
  14451.       LOGICAL PGNOTO
  14452. C
  14453.       IF (PGNOTO('PGSLW')) RETURN
  14454.       CALL GRSLW(LW)
  14455.       END
  14456. C*PGSTBG -- set text background color index
  14457. C%void cpgstbg(int tbci);
  14458. C+
  14459.       SUBROUTINE PGSTBG (TBCI)
  14460.       INTEGER  TBCI
  14461. C
  14462. C Set the Text Background Color Index for subsequent text. By default
  14463. C text does not obscure underlying graphics. If the text background
  14464. C color index is positive, however, text is opaque: the bounding box
  14465. C of the text is filled with the color specified by PGSTBG before
  14466. C drawing the text characters in the current color index set by PGSCI.
  14467. C Use color index 0 to erase underlying graphics before drawing text.
  14468. C
  14469. C Argument:
  14470. C  TBCI   (input)  : the color index to be used for the background
  14471. C                    for subsequent text plotting:
  14472. C                      TBCI < 0  => transparent (default)
  14473. C                      TBCI >= 0 => text will be drawn on an opaque
  14474. C                    background with color index TBCI.
  14475. C--
  14476. C 16-Oct-1993 - new routine [TJP].
  14477. C-----------------------------------------------------------------------
  14478.       INCLUDE 'f77.PGPLOT/IN'
  14479.       LOGICAL PGNOTO
  14480. C
  14481.       IF (PGNOTO('PGSTBG')) RETURN
  14482.       IF (TBCI.LT.0) THEN
  14483.           PGTBCI(PGID) = -1
  14484.       ELSE
  14485.           PGTBCI(PGID) = TBCI
  14486.       END IF
  14487.       END
  14488. C*PGSUBP -- subdivide view surface into panels
  14489. C%void cpgsubp(int nxsub, int nysub);
  14490. C+
  14491.       SUBROUTINE PGSUBP (NXSUB, NYSUB)
  14492.       INTEGER NXSUB, NYSUB
  14493. C
  14494. C PGPLOT divides the physical surface of the plotting device (screen,
  14495. C window, or sheet of paper) into NXSUB x NYSUB `panels'. When the 
  14496. C view surface is sub-divided in this way, PGPAGE moves to the next
  14497. C panel, not the next physical page. The initial subdivision of the
  14498. C view surface is set in the call to PGBEG. When PGSUBP is called,
  14499. C it forces the next call to PGPAGE to start a new physical page,
  14500. C subdivided in the manner indicated. No plotting should be done
  14501. C between a call of PGSUBP and a call of PGPAGE (or PGENV, which calls
  14502. C PGPAGE).
  14503. C
  14504. C If NXSUB > 0, PGPLOT uses the panels in row order; if <0, 
  14505. C PGPLOT uses them in column order, e.g.,
  14506. C      
  14507. C  NXSUB=3, NYSUB=2            NXSUB=-3, NYSUB=2   
  14508. C                                                
  14509. C +-----+-----+-----+         +-----+-----+-----+
  14510. C |  1  |  2  |  3  |         |  1  |  3  |  5  |
  14511. C +-----+-----+-----+         +-----+-----+-----+
  14512. C |  4  |  5  |  6  |         |  2  |  4  |  6  |
  14513. C +-----+-----+-----+         +-----+-----+-----+
  14514. C
  14515. C PGPLOT advances from one panels to the next when PGPAGE is called,
  14516. C clearing the screen or starting a new page when the last panel has
  14517. C been used. It is also possible to jump from one panel to another
  14518. C in random order by calling PGPANL.
  14519. C 
  14520. C Arguments:
  14521. C  NXSUB  (input)  : the number of subdivisions of the view surface in
  14522. C                    X (>0 or <0).
  14523. C  NYSUB  (input)  : the number of subdivisions of the view surface in
  14524. C                    Y (>0).
  14525. C--
  14526. C 15-Nov-1993 [TJP] - new routine.
  14527. C 19-Feb-1994 [TJP] - rescale viewport when panel size changes.
  14528. C 23-Sep-1996 [TJP] - correct bug in assignment of PGROWS.
  14529. C-----------------------------------------------------------------------
  14530.       INCLUDE  'f77.PGPLOT/IN'
  14531.       REAL     CH, XFSZ, YFSZ
  14532.       LOGICAL  PGNOTO
  14533.       REAL     XVP1, XVP2, YVP1, YVP2
  14534.  
  14535. C
  14536.       IF (PGNOTO('PGSUBP')) RETURN
  14537. C
  14538. C Find current character size and viewport (NDC).
  14539. C
  14540.       CALL PGQCH(CH)
  14541.       CALL PGQVP(0, XVP1, XVP2, YVP1, YVP2)
  14542. C
  14543. C Set the subdivisions.
  14544. C
  14545.       XFSZ = PGNX(PGID)*PGXSZ(PGID)
  14546.       YFSZ = PGNY(PGID)*PGYSZ(PGID)
  14547.       PGROWS(PGID) = (NXSUB.GE.0)
  14548.       PGNX(PGID) = MAX(ABS(NXSUB),1)
  14549.       PGNY(PGID) = MAX(ABS(NYSUB),1)
  14550.       PGXSZ(PGID) = XFSZ/PGNX(PGID)
  14551.       PGYSZ(PGID) = YFSZ/PGNY(PGID)
  14552. C
  14553. C The current panel is the last on the physical page, to force
  14554. C a new physical page at next PGPAGE.
  14555. C
  14556.       PGNXC(PGID) = PGNX(PGID)
  14557.       PGNYC(PGID) = PGNY(PGID)
  14558. C
  14559. C Rescale the character size and viewport to the new panel size.
  14560. C
  14561.       CALL PGSCH(CH)
  14562.       CALL PGSVP(XVP1, XVP2, YVP1, YVP2)
  14563. C
  14564.       END
  14565. C*PGSVP -- set viewport (normalized device coordinates)
  14566. C%void cpgsvp(float xleft, float xright, float ybot, float ytop);
  14567. C+
  14568.       SUBROUTINE PGSVP (XLEFT, XRIGHT, YBOT, YTOP)
  14569.       REAL XLEFT, XRIGHT, YBOT, YTOP
  14570. C
  14571. C Change the size and position of the viewport, specifying
  14572. C the viewport in normalized device coordinates.  Normalized
  14573. C device coordinates run from 0 to 1 in each dimension. The
  14574. C viewport is the rectangle on the view surface "through"
  14575. C which one views the graph.  All the PG routines which plot lines
  14576. C etc. plot them within the viewport, and lines are truncated at
  14577. C the edge of the viewport (except for axes, labels etc drawn with
  14578. C PGBOX or PGLAB).  The region of world space (the coordinate
  14579. C space of the graph) which is visible through the viewport is
  14580. C specified by a call to PGSWIN.  It is legal to request a
  14581. C viewport larger than the view surface; only the part which
  14582. C appears on the view surface will be plotted.
  14583. C
  14584. C Arguments:
  14585. C  XLEFT  (input)  : x-coordinate of left hand edge of viewport, in NDC.
  14586. C  XRIGHT (input)  : x-coordinate of right hand edge of viewport,
  14587. C                    in NDC.
  14588. C  YBOT   (input)  : y-coordinate of bottom edge of viewport, in NDC.
  14589. C  YTOP   (input)  : y-coordinate of top  edge of viewport, in NDC.
  14590. C--
  14591. C 13-Dec-1990  Make errors non-fatal [TJP].
  14592. C-----------------------------------------------------------------------
  14593.       INCLUDE  'f77.PGPLOT/IN'
  14594.       LOGICAL  PGNOTO
  14595.       REAL     XS, YS
  14596. C
  14597.       IF (PGNOTO('PGSVP'))  RETURN
  14598.       IF (XLEFT.GE.XRIGHT .OR. YBOT.GE.YTOP) THEN
  14599.           CALL GRWARN('PGSVP ignored: invalid arguments')
  14600.           RETURN
  14601.       END IF
  14602. C
  14603.       XS = PGXSZ(PGID)/PGXPIN(PGID)
  14604.       YS = PGYSZ(PGID)/PGYPIN(PGID)
  14605.       CALL PGVSIZ(XLEFT*XS, XRIGHT*XS, YBOT*YS, YTOP*YS)
  14606.       END
  14607. C*PGSWIN -- set window
  14608. C%void cpgswin(float x1, float x2, float y1, float y2);
  14609. C+
  14610.       SUBROUTINE PGSWIN (X1, X2, Y1, Y2)
  14611.       REAL X1, X2, Y1, Y2
  14612. C
  14613. C Change the window in world coordinate space that is to be mapped on
  14614. C to the viewport.  Usually PGSWIN is called automatically by PGENV,
  14615. C but it may be called directly by the user.
  14616. C
  14617. C Arguments:
  14618. C  X1     (input)  : the x-coordinate of the bottom left corner
  14619. C                    of the viewport.
  14620. C  X2     (input)  : the x-coordinate of the top right corner
  14621. C                    of the viewport (note X2 may be less than X1).
  14622. C  Y1     (input)  : the y-coordinate of the bottom left corner
  14623. C                    of the viewport.
  14624. C  Y2     (input)  : the y-coordinate of the top right corner
  14625. C                    of the viewport (note Y2 may be less than Y1).
  14626. C--
  14627. C 15-Nov-95: check arguments to prevent divide-by-zero [TJP].
  14628. C-----------------------------------------------------------------------
  14629.       INCLUDE 'f77.PGPLOT/IN'
  14630.       LOGICAL PGNOTO
  14631. C
  14632.       IF (PGNOTO('PGSWIN')) RETURN
  14633. C
  14634. C If invalid arguments are specified, issue warning and leave window
  14635. C unchanged.
  14636. C
  14637.       IF (X1.EQ.X2) THEN
  14638.          CALL GRWARN('invalid x limits in PGSWIN: X1 = X2.')
  14639.       ELSE IF (Y1.EQ.Y2) THEN
  14640.          CALL GRWARN('invalid y limits in PGSWIN: Y1 = Y2.')
  14641.       ELSE
  14642.          PGXBLC(PGID) = X1
  14643.          PGXTRC(PGID) = X2
  14644.          PGYBLC(PGID) = Y1
  14645.          PGYTRC(PGID) = Y2
  14646.          CALL PGVW
  14647.       END IF
  14648.       END
  14649. C*PGTBOX -- draw frame and write (DD) HH MM SS.S labelling
  14650. C%void cpgtbox(const char *xopt, float xtick, int nxsub, \
  14651. C% const char *yopt, float ytick, int nysub);
  14652. C+
  14653.       SUBROUTINE PGTBOX (XOPT, XTICK, NXSUB, YOPT, YTICK, NYSUB)
  14654. C
  14655.       REAL XTICK, YTICK
  14656.       INTEGER NXSUB, NYSUB
  14657.       CHARACTER XOPT*(*), YOPT*(*)
  14658. C
  14659. C Draw a box and optionally label one or both axes with (DD) HH MM SS 
  14660. C style numeric labels (useful for time or RA - DEC plots).   If this 
  14661. C style of labelling is desired, then PGSWIN should have been called
  14662. C previously with the extrema in SECONDS of time.
  14663. C
  14664. C In the seconds field, you can have at most 3 places after the decimal
  14665. C point, so that 1 ms is the smallest time interval you can time label.
  14666. C
  14667. C Large numbers are coped with by fields of 6 characters long.  Thus 
  14668. C you could have times with days or hours as big as 999999.  However, 
  14669. C in practice, you might have trouble with labels overwriting  themselves
  14670. C with such large numbers unless you a) use a small time INTERVAL, 
  14671. C b) use a small character size or c) choose your own sparse ticks in 
  14672. C the call to PGTBOX.  
  14673. C
  14674. C PGTBOX will attempt, when choosing its own ticks, not to overwrite
  14675. C the labels, but this algorithm is not very bright and may fail.
  14676. C
  14677. C Note that small intervals but large absolute times such as
  14678. C TMIN = 200000.0 s and TMAX=200000.1 s will cause the algorithm
  14679. C to fail.  This is inherent in PGPLOT's use of single precision
  14680. C and cannot be avoided.  In such cases, you should use relative
  14681. C times if possible.
  14682. C
  14683. C PGTBOX's labelling philosophy is that the left-most or bottom tick of
  14684. C the axis contains a full label.  Thereafter, only changing fields are
  14685. C labelled.  Negative fields are given a '-' label, positive fields
  14686. C have none.   Axes that have the DD (or HH if the day field is not
  14687. C used) field on each major tick carry the sign on each field.  If the
  14688. C axis crosses zero, the zero tick will carry a full label and sign.
  14689. C
  14690. C This labelling style can cause a little confusion with some special
  14691. C cases, but as long as you know its philosophy, the truth can be divined.
  14692. C Consider an axis with TMIN=20s, TMAX=-20s.   The labels will look like
  14693. C
  14694. C        +----------+----------+----------+----------+
  14695. C     0h0m20s      10s      -0h0m0s      10s        20s
  14696. C
  14697. C Knowing that the left field always has a full label and that
  14698. C positive fields are unsigned, informs that time is decreasing
  14699. C from left to right, not vice versa.   This can become very 
  14700. C unclear if you have used the 'F' option, but that is your problem !
  14701. C
  14702. C Exceptions to this labelling philosophy are when the finest time
  14703. C increment being displayed is hours (with option 'Y') or days.  
  14704. C Then all fields carry a label.  For example,
  14705. C
  14706. C        +----------+----------+----------+----------+
  14707. C      -10h        -8h        -6h        -4h        -2h
  14708. C
  14709. C
  14710. C PGTBOX can be used in place of PGBOX; it calls PGBOX and only invokes 
  14711. C time labelling if requested. Other options are passed intact to PGBOX.
  14712. C
  14713. C Inputs:
  14714. C  XOPT   :  X-options for PGTBOX.  Same as for PGBOX plus 
  14715. C
  14716. C             'Z' for (DD) HH MM SS.S time labelling
  14717. C             'Y' means don't include the day field so that labels
  14718. C                 are HH MM SS.S rather than DD HH MM SS.S   The hours
  14719. C                 will accumulate beyond 24 if necessary in this case.
  14720. C             'X' label the HH field as modulo 24.  Thus, a label
  14721. C                 such as 25h 10m would come out as 1h 10m
  14722. C             'H' means superscript numbers with d, h, m, & s  symbols
  14723. C             'D' means superscript numbers with    o, ', & '' symbols 
  14724. C             'F' causes the first label (left- or bottom-most) to
  14725. C                 be omitted. Useful for sub-panels that abut each other.
  14726. C                 Care is needed because first label carries sign as well.
  14727. C             'O' means omit leading zeros in numbers < 10
  14728. C                 E.g.  3h 3m 1.2s rather than 03h 03m 01.2s  Useful
  14729. C                 to help save space on X-axes. The day field does not 
  14730. C                 use this facility.
  14731. C
  14732. C  YOPT   :  Y-options for PGTBOX.  See above.
  14733. C  XTICK  :  X-axis major tick increment.  0.0 for default. 
  14734. C  YTICK  :  Y-axis major tick increment.  0.0 for default. 
  14735. C            If the 'Z' option is used then XTICK and/or YTICK must
  14736. C            be in seconds.
  14737. C  NXSUB  :  Number of intervals for minor ticks on X-axis. 0 for default
  14738. C  NYSUB  :  Number of intervals for minor ticks on Y-axis. 0 for default
  14739. C
  14740. C  The regular XOPT and YOPT axis options for PGBOX are
  14741. C
  14742. C  A : draw Axis (X axis is horizontal line Y=0, Y axis is vertical
  14743. C      line X=0).
  14744. C  B : draw bottom (X) or left (Y) edge of frame.
  14745. C  C : draw top (X) or right (Y) edge of frame.
  14746. C  G : draw Grid of vertical (X) or horizontal (Y) lines.
  14747. C  I : Invert the tick marks; ie draw them outside the viewport
  14748. C      instead of inside.
  14749. C  L : label axis Logarithmically (see below).
  14750. C  N : write Numeric labels in the conventional location below the
  14751. C      viewport (X) or to the left of the viewport (Y).
  14752. C  P : extend ("Project") major tick marks outside the box (ignored if
  14753. C      option I is specified).
  14754. C  M : write numeric labels in the unconventional location above the
  14755. C      viewport (X) or to the right of the viewport (Y).
  14756. C  T : draw major Tick marks at the major coordinate interval.
  14757. C  S : draw minor tick marks (Subticks).
  14758. C  V : orient numeric labels Vertically. This is only applicable to Y.
  14759. C      The default is to write Y-labels parallel to the axis.
  14760. C  1 : force decimal labelling, instead of automatic choice (see PGNUMB).
  14761. C  2 : force exponential labelling, instead of automatic.
  14762. C
  14763. C      The default is to write Y-labels parallel to the axis
  14764. C  
  14765. C
  14766. C        ******************        EXCEPTIONS       *******************
  14767. C
  14768. C        Note that 
  14769. C          1) PGBOX option 'L' (log labels) is ignored with option 'Z'
  14770. C          2) The 'O' option will be ignored for the 'V' option as it 
  14771. C             makes it impossible to align the labels nicely
  14772. C          3) Option 'Y' is forced with option 'D'
  14773. C
  14774. C        ***************************************************************
  14775. C
  14776. C
  14777. C--
  14778. C 05-Sep-1988 - new routine (Neil Killeen)
  14779. C 20-Apr-1991 - add support for new DD (day) field and implement
  14780. C               labelling on any axis (bottom,top,left,right) [nebk]
  14781. C 10-Jun-1993 - add option 'O' for leading zeros, correctly deal with 
  14782. C               user ticks, fully support 'V' and 'NM' options, modify
  14783. C               slightly meaning of 'F' option [nebk]
  14784. C 16-Jan-1995 - add option 'X' [nebk]
  14785. C 16-Aug-1996 - Bring axis labelling displacements more in line with 
  14786. C               those of pgbox.f [nebk]
  14787. C-----------------------------------------------------------------------
  14788.       REAL XTICKD, YTICKD, XMIN, XMAX, YMIN, YMAX
  14789.       INTEGER IPT, TSCALX, TSCALY, NXSUBD, NYSUBD
  14790.       CHARACTER XXOPT*15, YYOPT*15, SUPTYP*4
  14791.       LOGICAL XTIME, YTIME, FIRST, DODAYX, DODAYY, DO2, DOPARA, MOD24
  14792. C------------------------------------------------------------------------
  14793. C
  14794. C  Copy inputs
  14795. C
  14796.       XTICKD = XTICK
  14797.       YTICKD = YTICK
  14798.       NXSUBD = NXSUB
  14799.       NYSUBD = NYSUB
  14800. C
  14801. C  Get window in world coordinates
  14802. C 
  14803.       CALL PGQWIN (XMIN, XMAX, YMIN, YMAX)
  14804. C
  14805. C  X-axis first
  14806. C
  14807.       CALL GRTOUP (XXOPT, XOPT)
  14808.       XTIME = .FALSE.
  14809.       IF (INDEX(XXOPT,'Z').NE.0) THEN
  14810. C
  14811. C  Work out units for labelling and find the tick increments.
  14812. C
  14813.         IF (ABS(XMAX-XMIN).LT.0.001) THEN
  14814.           CALL GRWARN ('PGTBOX: X-axis time interval too small '//
  14815.      *                 '(< 1 ms) for time labels')
  14816.         ELSE
  14817.           XTIME = .TRUE.
  14818.           DODAYX = .TRUE.
  14819.           IF (INDEX(XXOPT,'Y').NE.0 .OR. INDEX(XXOPT,'D').NE.0) 
  14820.      *        DODAYX = .FALSE.
  14821. C
  14822.           DOPARA = .TRUE.
  14823.           CALL PGTBX1 ('X', DODAYX, DOPARA, XMIN, XMAX, XTICKD, 
  14824.      *                 NXSUBD, TSCALX)
  14825.         END IF
  14826.       END IF
  14827. C
  14828. C  Same again for Y-axis
  14829. C
  14830.       CALL GRTOUP (YYOPT, YOPT)
  14831.       YTIME = .FALSE.
  14832.       IF (INDEX(YYOPT,'Z').NE.0) THEN
  14833.         IF (ABS(YMAX-YMIN).LT.0.001) THEN
  14834.           CALL GRWARN ('PGTBOX: Y-axis time interval too small '//
  14835.      *                 '(< 1ms) for time labels')
  14836.         ELSE
  14837.           YTIME = .TRUE.
  14838.           DODAYY = .TRUE.
  14839.           IF (INDEX(YYOPT,'Y').NE.0 .OR. INDEX(YYOPT,'D').NE.0)
  14840.      *        DODAYY = .FALSE.
  14841. C
  14842.           DOPARA = .TRUE.
  14843.           IF (INDEX(YYOPT,'V').NE.0) DOPARA = .FALSE.
  14844. C
  14845.           CALL PGTBX1 ('Y', DODAYY, DOPARA, YMIN, YMAX, YTICKD, 
  14846.      *                 NYSUBD, TSCALY)
  14847.         END IF
  14848.       END IF
  14849. C
  14850. C  Parse options list.  For call to PGBOX when doing time labelling, we 
  14851. C  don't want L (log), N or M (write numeric labels). 
  14852. C
  14853.       IF (XTIME) THEN
  14854.         IPT = INDEX(XXOPT,'L')
  14855.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  14856.         IPT = INDEX(XXOPT,'N')
  14857.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  14858.         IPT = INDEX(XXOPT,'M')
  14859.         IF (IPT.NE.0) XXOPT(IPT:IPT) = ' '
  14860.       END IF
  14861. C
  14862.       IF (YTIME) THEN
  14863.         IPT = INDEX(YYOPT,'L')
  14864.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  14865.         IPT = INDEX(YYOPT,'N')
  14866.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  14867.         IPT = INDEX(YYOPT,'M')
  14868.         IF (IPT.NE.0) YYOPT(IPT:IPT) = ' '
  14869.       END IF
  14870. C
  14871. C  Draw box and ticks
  14872. C
  14873.       CALL PGBOX (XXOPT, XTICKD, NXSUBD, YYOPT, YTICKD, NYSUBD)
  14874. C
  14875. C  Add (DD) HH MM SS labels if desired.  Go back to the original user
  14876. C  specified options list.
  14877. C
  14878.       XXOPT = ' '
  14879.       CALL GRTOUP (XXOPT, XOPT)
  14880.       IF (XTIME .AND. (INDEX(XXOPT,'N').NE.0 .OR.
  14881.      *                 INDEX(XXOPT,'M').NE.0)) THEN
  14882.         FIRST = .TRUE.
  14883.         IF (INDEX(XXOPT,'F').NE.0) FIRST = .FALSE.
  14884. C
  14885.         SUPTYP = 'NONE'
  14886.         IF (INDEX(XXOPT,'D').NE.0) SUPTYP = ' DMS'
  14887.         IF (INDEX(XXOPT,'H').NE.0) SUPTYP = 'DHMS'
  14888. C
  14889.         DO2 = .TRUE.
  14890.         IF (INDEX(XXOPT,'O').NE.0) DO2 = .FALSE.
  14891. C
  14892.         DOPARA = .TRUE.
  14893. C
  14894.         MOD24 = .FALSE.
  14895.         IF (INDEX(XXOPT,'X').NE.0) MOD24 = .TRUE.
  14896. C
  14897.         IF (INDEX(XXOPT,'N').NE.0)
  14898.      *    CALL PGTBX4 (DODAYX, SUPTYP, 'X', .TRUE., FIRST, 
  14899.      *      XMIN, XMAX, TSCALX, XTICKD, DO2, DOPARA, MOD24)
  14900. C
  14901.         IF (INDEX(XXOPT,'M').NE.0)
  14902.      *    CALL PGTBX4 (DODAYX, SUPTYP, 'X', .FALSE., FIRST, 
  14903.      *       XMIN, XMAX, TSCALX, XTICKD, DO2, DOPARA, MOD24)
  14904.       END IF
  14905. C
  14906.       YYOPT = ' '
  14907.       CALL GRTOUP (YYOPT, YOPT)
  14908.       IF (YTIME .AND. (INDEX(YYOPT,'N').NE.0 .OR.
  14909.      *                 INDEX(YYOPT,'M').NE.0)) THEN
  14910.         FIRST = .TRUE.
  14911.         IF (INDEX(YYOPT,'F').NE.0) FIRST = .FALSE.
  14912. C
  14913.         SUPTYP = 'NONE'
  14914.         IF (INDEX(YYOPT,'D').NE.0) SUPTYP = ' DMS'
  14915.         IF (INDEX(YYOPT,'H').NE.0) SUPTYP = 'DHMS'
  14916. C
  14917.         DOPARA = .TRUE.
  14918.         IF (INDEX(YYOPT,'V').NE.0) DOPARA = .FALSE.
  14919. C
  14920.         DO2 = .TRUE.
  14921.         IF (DOPARA .AND. INDEX(YYOPT,'O').NE.0) DO2 = .FALSE.
  14922. C
  14923.         MOD24 = .FALSE.
  14924.         IF (INDEX(YYOPT,'X').NE.0) MOD24 = .TRUE.
  14925. C
  14926.         IF (INDEX(YYOPT,'N').NE.0)
  14927.      *    CALL PGTBX4 (DODAYY, SUPTYP, 'Y', .TRUE., FIRST, 
  14928.      *       YMIN, YMAX, TSCALY, YTICKD, DO2, DOPARA, MOD24)
  14929. C
  14930.         IF (INDEX(YYOPT,'M').NE.0)
  14931.      *    CALL PGTBX4 (DODAYY, SUPTYP, 'Y', .FALSE., FIRST, 
  14932.      *       YMIN, YMAX, TSCALY, YTICKD, DO2, DOPARA, MOD24)
  14933. C
  14934.       END IF
  14935. C
  14936.       RETURN
  14937.       END
  14938. C PGTBX1 -- support routine for PGTBOX
  14939. C
  14940.       SUBROUTINE PGTBX1 (AXIS, DODAY, DOPARA, TMIN, TMAX, TICK, 
  14941.      *                   NSUB, TSCALE)
  14942. C
  14943.       REAL TMIN, TMAX, TICK
  14944.       INTEGER NSUB, TSCALE
  14945.       LOGICAL DODAY, DOPARA
  14946.       CHARACTER AXIS*1
  14947. C
  14948. C Work out what the finest units the time labels will be in and
  14949. C return the tick increments if the user does not set them.
  14950. C
  14951. C This is a support routine for PGTBOX and should not 
  14952. C be called by the user.
  14953. C
  14954. C Input:
  14955. C  AXIS   :  'X' or 'Y' for use in determining if labels overwrite
  14956. C  TMIN   :  Start time in seconds 
  14957. C  TMAX   :  End   time in seconds
  14958. C  DOPARA :  True if label to be parallel to axis, else perpendicular
  14959. C Input/output:
  14960. C  DODAY  :  Write labels as DD HH MM SS.S else HH MM SS.S with
  14961. C            hours ranging above 24.  Useful for declination labels
  14962. C  TICK   :  Major tick interval in seconds.  If 0.0 on input, will 
  14963. C            be set here.
  14964. C  NSUB   :  Number of minor ticks between major ticks. If 0 on input
  14965. C            will be set here.
  14966. C Outputs:
  14967. C  TSCALE :  Determines finest unit of labelling 
  14968. C            (1 => ss, 60 => mm, 3600 => hh, 3600*24 => dd)
  14969. C
  14970. C 05-Sep-1988 - new routine (Neil Killeen)
  14971. C 08-Apr-1991 - correctly work out HH MM SS when the time > 60 h [nebk]
  14972. C 20-Apr-1991 - revise to add support for new DD (day) field and
  14973. C               do lots of work on tick algorithm [nebk]
  14974. C 10-Jun-1993 - deal with user given ticks & rename from PGTIME [nebk/jm]
  14975. C-----------------------------------------------------------------------
  14976.       INTEGER NLIST1, NLIST2, NLIST3, NLIST4, NTICMX
  14977.       PARAMETER (NLIST1 = 19, NLIST2 = 10, NLIST3 = 6, NLIST4 = 8,
  14978.      *           NTICMX = 8)
  14979. C
  14980.       REAL TICKS1(NLIST1), TICKS2(NLIST2), TICKS3(NLIST3), 
  14981.      *TICKS4(NLIST4), TOCK, TOCK2, TINT, TINTS, TMINS, TMAXS
  14982.       INTEGER NSUBS1(NLIST1), NSUBS2(NLIST2), NSUBS3(NLIST3), 
  14983.      *NSUBS4(NLIST4), NPL, NTICK, ITICK, STRLEN
  14984.       CHARACTER STR*15
  14985. C
  14986.       SAVE TICKS1, TICKS2, TICKS3, TICKS4
  14987.       SAVE NSUBS1, NSUBS2, NSUBS3, NSUBS4
  14988. C
  14989.       DATA TICKS1 /0.001,  0.002,                 0.005,
  14990.      *             0.01,   0.02,                  0.05,  
  14991.      *             0.1,    0.2,                   0.5,  
  14992.      *             1.0,    2.0,   3.0,    4.0,    5.0,
  14993.      *             6.0,   10.0,  15.0,   20.0,   30.0/
  14994.       DATA NSUBS1 / 4,      4,                     2,    
  14995.      *              4,      4,                     2,    
  14996.      *              4,      4,                     2,    
  14997.      *              4,      4,     3,      4,      5,
  14998.      *              3,      2,     3,      2,      3/
  14999. C
  15000.       DATA TICKS2 /1.0,    2.0,   3.0,    4.0,    5.0,
  15001.      *             6.0,   10.0,  15.0,   20.0,   30.0/
  15002.       DATA NSUBS2 / 4,      4,     3,      4,      5,
  15003.      *              3,      2,     3,      2,      3/
  15004. C
  15005.       DATA TICKS3 /1.0,    2.0,   3.0,    4.0,    6.0,   12.0/
  15006.       DATA NSUBS3 / 4,      4,     3,      4,      3,      2/
  15007. C
  15008.       DATA TICKS4 /1.0, 2.0, 3.0, 4.0, 5.0, 6.0, 8.0, 9.0/
  15009.       DATA NSUBS4 / 4,   4,   3,   4,   5,   3,   4,   3 /
  15010. C----------------------------------------------------------------------
  15011. C
  15012. C  Turn off DD (day) field if it has been unnecessarily asked for
  15013. C
  15014.       IF ((ABS(TMIN).LT.24.0*3600.0) .AND. (ABS(TMAX).LT.24.0*3600.0))
  15015.      *   DODAY = .FALSE.
  15016. C
  15017. C  If a tick size is provided, use it to determine TSCALE
  15018. C
  15019.       TINT = ABS(TMAX - TMIN)
  15020.       TICK = ABS(TICK)
  15021.       IF (TICK.NE.0.0) THEN
  15022.         IF (TICK.GE.TINT) THEN
  15023.           CALL GRWARN ('PGTBX1: user given tick bigger than time '
  15024.      *                 //'interval; will auto-tick')
  15025.           TICK = 0.0
  15026.         ELSE IF (TICK.LT.0.001) THEN
  15027.           CALL GRWARN ('PGTBX1: user given tick too small (< 1 ms); '
  15028.      *                 //'will auto-tick')
  15029.           TICK = 0.0
  15030.         ELSE 
  15031.           IF (MOD(TICK, 60.0) .NE. 0.0) THEN
  15032.             TSCALE = 1
  15033.           ELSE IF (MOD(TICK, 3600.0).NE.0.0) THEN
  15034.             TSCALE = 60
  15035.           ELSE IF (.NOT.DODAY) THEN
  15036.             TSCALE = 3600
  15037.           ELSE IF (MOD(TICK,(24.0*3600.0)).NE.0.0) THEN
  15038.             TSCALE = 3600
  15039.           ELSE
  15040.             TSCALE = 24 * 3600
  15041.           ENDIF
  15042. C
  15043. C  Make a simple default for the number of minor ticks and bug out
  15044. C
  15045.           IF (NSUB.EQ.0) NSUB = 2
  15046.           RETURN
  15047.         END IF
  15048.       END IF
  15049. C
  15050. C  Work out label units depending on time interval if user 
  15051. C  wants auto-ticking
  15052. C
  15053.       IF (TINT.LE.5*60) THEN
  15054.         TSCALE = 1
  15055.       ELSE IF (TINT.LE.5*3600) THEN
  15056.         TSCALE = 60
  15057.       ELSE 
  15058.         IF (.NOT.DODAY) THEN
  15059.           TSCALE = 3600
  15060.         ELSE
  15061.           IF (TINT.LE.5*24*3600) THEN
  15062.             TSCALE = 3600
  15063.           ELSE
  15064.             TSCALE = 3600*24
  15065.           END IF
  15066.         END IF
  15067.       END IF
  15068. C
  15069. CCCCC
  15070. C  Divide interval into NTICK major ticks and NSUB minor intervals
  15071. C  The tick choosing algorithm is not very robust, so watch out
  15072. C  if you fiddle anything. 
  15073. CCCCC
  15074. C
  15075.       TINTS = TINT / TSCALE
  15076.       IF (TSCALE.EQ.1) THEN
  15077. C
  15078. C  Time in seconds.  If the time interval is very small, may need to 
  15079. C  label with up to 3 decimal places.  Have less ticks to help prevent
  15080. C  label overwrite. STR is a dummy tick label to assess label 
  15081. C  overwrite potential
  15082. C
  15083.         IF (DOPARA) THEN
  15084.           IF (TINTS.LE.0.01) THEN
  15085.             NTICK = 4
  15086.             STR = '60.423'
  15087.             STRLEN = 6
  15088.           ELSE IF (TINTS.LE.0.1) THEN
  15089.             NTICK = 5
  15090.             STR = '60.42'
  15091.             STRLEN = 5
  15092.           ELSE IF (TINTS.LE.1.0) THEN
  15093.             NTICK = 6
  15094.             STR = '60.4'
  15095.             STRLEN = 4
  15096.           ELSE
  15097.             NTICK = 6
  15098.             STR = '60s'
  15099.             STRLEN = 3
  15100.           END IF
  15101.         ELSE
  15102.           NTICK = 6
  15103.           STR = ' '
  15104.           STRLEN = 1
  15105.         END IF
  15106.         TOCK = TINTS / NTICK
  15107. C
  15108. C  Select nearest tick to TOCK from list.
  15109. C
  15110.         CALL PGTBX2 (TOCK, NLIST1, TICKS1, NSUBS1, TICK, NSUB, ITICK)
  15111. C
  15112. C  Check label overwrite and/or too many ticks.
  15113. C
  15114.         CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST1, TICKS1,
  15115.      *               NSUBS1, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  15116.      *               TICK, NSUB)
  15117.       ELSE IF (TSCALE.EQ.60) THEN
  15118. C
  15119. C  Time in minutes 
  15120. C
  15121.         NTICK = 6
  15122.         TOCK = TINTS / NTICK
  15123. C
  15124. C  Select nearest tick from list
  15125. C
  15126.         CALL PGTBX2 (TOCK, NLIST2, TICKS2, NSUBS2, TICK, NSUB, ITICK)
  15127. C
  15128. C  Check label overwrite and/or too many ticks.
  15129. C
  15130.         IF (DOPARA) THEN
  15131.           STR = '42m'
  15132.           STRLEN = 3
  15133.         ELSE
  15134.           STR = ' '
  15135.           STRLEN = 1
  15136.         END IF
  15137.         CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST2, TICKS2,
  15138.      *               NSUBS2, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  15139.      *               TICK, NSUB)
  15140.       ELSE 
  15141.         IF (TSCALE.EQ.3600 .AND. DODAY) THEN
  15142. C
  15143. C  Time in hours with the day field 
  15144. C
  15145.           NTICK = 6
  15146.           TOCK = TINTS / NTICK
  15147. C
  15148. C  Select nearest tick from list
  15149. C
  15150.           CALL PGTBX2 (TOCK, NLIST3, TICKS3, NSUBS3, TICK, NSUB, ITICK)
  15151. C
  15152. C   Check label overwrite and/or too many ticks.
  15153. C
  15154.           IF (DOPARA) THEN
  15155.             STR = '42h'
  15156.             STRLEN = 3
  15157.           ELSE
  15158.             STR = ' '
  15159.             STRLEN = 1
  15160.           END IF
  15161.           CALL PGTBX3 (DODAY, 0, TSCALE, TINTS, NTICMX, NLIST3, TICKS3,
  15162.      *                 NSUBS3, ITICK, AXIS, DOPARA, STR(1:STRLEN),
  15163.      *                 TICK, NSUB)
  15164.         ELSE
  15165. C
  15166. C  Time in hours with no day field or time in days. Have less
  15167. C  ticks for big numbers or the parallel labels will overwrite.
  15168.  
  15169.           IF (DOPARA) THEN
  15170.             TMINS = ABS(TMIN) / TSCALE
  15171.             TMAXS = ABS(TMAX) / TSCALE            
  15172.             CALL PGNPL (-1, NINT(MAX(TINTS,TMINS,TMAXS)), NPL)
  15173.             IF (NPL.LE.3) THEN
  15174.               NTICK = 6
  15175.             ELSE IF (NPL.EQ.4) THEN
  15176.               NTICK = 5
  15177.             ELSE
  15178.               NTICK = 4
  15179.             END IF
  15180.             STR = '345678912'
  15181.             STR(NPL+1:) = 'd'
  15182.             STRLEN = NPL + 1
  15183.           ELSE
  15184.             STR = ' '
  15185.             STRLEN = 1
  15186.             NTICK = 6
  15187.           END IF
  15188.           TOCK = TINTS / NTICK
  15189. C
  15190. C   Select nearest tick from list; 1 choose nearest nice integer 
  15191. C   scaled by the appropriate power of 10
  15192. C
  15193.           CALL PGNPL (-1, NINT(TOCK), NPL)
  15194.           TOCK2 = TOCK / 10**(NPL-1)
  15195. C
  15196.           CALL PGTBX2 (TOCK2, NLIST4, TICKS4, NSUBS4, TICK, NSUB, ITICK)
  15197.           TICK = TICK * 10**(NPL-1)
  15198. C
  15199. C  Check label overwrite and/or too many ticks.
  15200. C
  15201.           CALL PGTBX3 (DODAY, NPL, TSCALE, TINTS, NTICMX, NLIST4, 
  15202.      *                 TICKS4, NSUBS4, ITICK, AXIS, DOPARA,
  15203.      *                 STR(1:STRLEN), TICK, NSUB)
  15204.         END IF
  15205.       END IF
  15206. C
  15207. C  Convert tick to seconds
  15208. C
  15209.       TICK = TICK * TSCALE
  15210. C
  15211.       RETURN
  15212.       END
  15213. C PGTBX2 -- support routine for PGTBOX
  15214. C
  15215.       SUBROUTINE PGTBX2 (TOCK, NTICKS, TICKS, NSUBS, TICK, NSUB, ITICK)
  15216. C
  15217.       INTEGER NTICKS, NSUBS(NTICKS), NSUB, ITICK
  15218.       REAL TOCK, TICKS(NTICKS), TICK
  15219. C
  15220. C Find the nearest tick in a list to a given value.
  15221. C
  15222. C This is a support routine for PGTBOX and should not be called
  15223. C by the user.
  15224. C
  15225. C Input:
  15226. C  TOCK   :  Try to find the nearest tick in the list to TOCK
  15227. C  NTICKS :  Number of ticks in list
  15228. C  TICKS  :  List of ticks
  15229. C  NSUBS  :  List of number of minor ticks between ticks to go with TICKS
  15230. C Output:
  15231. C  TICK   :  The selected tick
  15232. C  ITICK  :  The index of the selected tick from the list TICKS
  15233. C Input/output
  15234. C  NSUB   :  Number of minor ticks between major ticks. If 0 on input
  15235. C            will be set here.
  15236. C
  15237. C 10-Jun-1993 - new routine [nebk]
  15238. C-----------------------------------------------------------------------
  15239.       INTEGER I, NSUBD
  15240.       REAL DMIN, DIFF
  15241. C----------------------------------------------------------------------
  15242.       NSUBD = NSUB
  15243.       DMIN = 1.0E30
  15244.       DO 100 I = 1, NTICKS
  15245.         DIFF = ABS(TOCK - TICKS(I))
  15246.         IF (DIFF.LT.DMIN) THEN
  15247.           TICK = TICKS(I)
  15248.           IF (NSUBD.EQ.0) NSUB = NSUBS(I)
  15249.           ITICK = I
  15250. C
  15251.           DMIN = DIFF
  15252.         END IF
  15253.  100  CONTINUE
  15254. C
  15255.       RETURN
  15256.       END
  15257. C PGTBX3 -- support routine for PGTBOX
  15258. C
  15259.       SUBROUTINE PGTBX3 (DODAY, NPL, TSCALE, TINTS, NTICMX, NTICKS,
  15260.      *                   TICKS, NSUBS, ITICK, AXIS, DOPARA, STR,
  15261.      *                   TICK, NSUB)
  15262. C
  15263.       INTEGER TSCALE, NTICMX, NTICKS, ITICK, NSUB, NSUBS(NTICKS), NPL
  15264.       REAL TINTS, TICKS(NTICKS), TICK
  15265.       CHARACTER AXIS*1, STR*(*)
  15266.       LOGICAL DODAY, DOPARA
  15267. C
  15268. C Try to see if label overwrite is going to occur with this tick 
  15269. C selection, or if there are going to be more than a reasonable
  15270. C number of ticks in the displayed time range.  If so, choose, 
  15271. C if available, the next tick (bigger separation) up in the list.
  15272. C If the overwrite requires that we would need to go up to the bext
  15273. C TSCALE, give up.  They will need to choose a smaller character size
  15274. C
  15275. C This is a support routine for PGTBOX and should not 
  15276. C be called by the user.
  15277. C
  15278. C Input:
  15279. C  DODAY  :  True if day field being used
  15280. C  NPL    :  Number of characters needed to format TICK on input
  15281. C  TSCALE :  Dictates what the finest units of the labelling are.
  15282. C            1 = sec, 60 = min, 3600 = hr, 24*3600 = days
  15283. C  TINTS  :  Absolute time interval in units of TSCALE
  15284. C  NTICMX :  Max. reasonable number of ticks to allow in the time range
  15285. C  NTICKS :  Number of ticks in list of ticks to choose from
  15286. C  TICKS  :  List of ticks from which the current tick was chosen
  15287. C  NSUBS  :  List of number of minor ticks/major tick to choose NSUB from
  15288. C  ITICK  :  Index of chosen tick in list TICKS
  15289. C  AXIS   :  'X' or 'Y' axis
  15290. C  DOPARA :  Labels parallel or perpendicualr to axis
  15291. C  STR    :  A typical formatted string used for checking overwrite
  15292. C Input/output:
  15293. C  TICK   :  Current major tick interval in units of TSCALE. May be 
  15294. C            made larger if possible if overwrite likely.
  15295. C  NSUB   :  Number of minor ticks between major ticks. 
  15296. C
  15297. C 10-Jun-1993 - new routine [nebk]
  15298. C-----------------------------------------------------------------------
  15299.       INTEGER NTICK
  15300.       REAL LENS, LENX, LENY
  15301. C----------------------------------------------------------------------
  15302.       CALL PGLEN (4, STR, LENX, LENY)
  15303.       LENS = LENX
  15304.       IF ( (DOPARA .AND. AXIS.EQ.'Y') .OR.
  15305.      *     (.NOT.DOPARA .AND. AXIS.EQ.'X') ) LENS = LENY
  15306. C
  15307.       IF (TSCALE.EQ.1 .OR. TSCALE.EQ.60 .OR.
  15308.      *    (TSCALE.EQ.3600 .AND. DODAY)) THEN
  15309. C
  15310. C  Time in seconds or minutes, or in hours with a day field
  15311. C
  15312.         NTICK = INT(TINTS / TICK)
  15313.         IF ( (ITICK.LT.NTICKS)  .AND. 
  15314.      *       ((DOPARA .AND. (LENS/TSCALE).GT.0.9*TICK) .OR. 
  15315.      *       (NTICK.GT.NTICMX)) ) THEN
  15316.           IF (TICKS(ITICK+1).LT.TINTS) THEN
  15317.             NSUB = NSUBS(ITICK+1)
  15318.             TICK = TICKS(ITICK+1)
  15319.           END IF
  15320.         END IF
  15321.       ELSE
  15322. C
  15323. C  Time in hours and no day field or time in days
  15324. C
  15325.         NTICK = INT(TINTS / TICK)
  15326.         IF ( (DOPARA .AND. (LENS/TSCALE).GT.0.9*TICK) .OR. 
  15327.      *       (NTICK.GT.NTICMX) ) THEN
  15328.           IF (ITICK.LT.NTICKS) THEN
  15329.             IF (TICKS(ITICK+1)*10**(NPL-1).LT.TINTS) THEN
  15330.               NSUB = NSUBS(ITICK+1)
  15331.               TICK = TICKS(ITICK+1) * 10**(NPL-1)
  15332.             END IF
  15333.           ELSE
  15334.             IF (TICKS(1)*10**NPL.LT.TINTS) THEN
  15335.               NSUB = NSUBS(1)
  15336.               TICK = TICKS(1) * 10**NPL
  15337.             END IF
  15338.           END IF
  15339.         END IF
  15340.       END IF
  15341. C
  15342.       RETURN
  15343.       END
  15344. C PGTBX4 -- support routine for PGTBOX
  15345. C
  15346.       SUBROUTINE PGTBX4 (DODAY, SUPTYP, AXIS, CONVTL, FIRST, TMIN,
  15347.      *                   TMAX, TSCALE, TICK, DO2, DOPARA, MOD24)
  15348. C
  15349.       REAL TMIN, TMAX, TICK
  15350.       INTEGER TSCALE
  15351.       CHARACTER AXIS*(*), SUPTYP*(*)
  15352.       LOGICAL FIRST, DODAY, CONVTL, DO2, DOPARA, MOD24
  15353. C
  15354. C Label an axis in (DD) HH MM SS.S style.    This is the main 
  15355. C workhorse of the PGTBOX routines.
  15356. C
  15357. C This is a support subroutine for PGTBOX and should not be 
  15358. C called by the user. 
  15359. C
  15360. C Inputs:
  15361. C  DODAY  :  Write labels as DD HH MM SS.S else HH MM SS.S with
  15362. C            hours ranging above 24.  Useful for declination labels
  15363. C  SUPTYP :  If 'DHMS' then superscript the fields with d, h, m, & s
  15364. C            If ' DMS' then superscript the fields with    o, '  & '' 
  15365. C              Good for declination plots.  You should obviously not 
  15366. C              ask for the day field for this to do anything sensible. 
  15367. C            If '    ' then no superscripting is done.
  15368. C  AXIS   :  'X' for x-axis, 'Y' for y-axis
  15369. C  CONVTL :  If .true., write the labels in the conventional axis 
  15370. C            locations (bottom and left for 'X' and 'Y').  Otherwise
  15371. C            write them on the top and right axes ('X' and 'Y')
  15372. C  FIRST  :  If .false. then omit the first label.
  15373. C  TMIN   :  Start time (seconds)
  15374. C  TMAX   :  End time (seconds)
  15375. C  TSCALE :  Determines finest units of axis
  15376. C              1 => ss, 60 => mm, 3600 => hh, 3600*24 => dd
  15377. C  TICK   :  Major tick interval in seconds
  15378. C  DO2    :  If .true., write labels less than 10 with a leading zero.
  15379. C  DOPARA :  Y axis label parallel to axis, else perpendicular
  15380. C  MOD24  :  HH field labelled as modulo 24
  15381. C
  15382. C 05-Sep-1988 - new routine (Neil Killeen)
  15383. C 20-Apr-1991 - add support for new DD (day) field [nebk]
  15384. C 10-Jun-1993 - complete rewrite & rename from PGTLAB. Fixes user given 
  15385. C               ticks bug too [nebk]
  15386. C 15-Jan-1995 - Add argument MOD24
  15387. C-----------------------------------------------------------------------
  15388.       INTEGER MAXTIK
  15389.       LOGICAL T, F
  15390.       PARAMETER (MAXTIK = 1000, T = .TRUE., F = .FALSE.)
  15391. C
  15392.       REAL SS(MAXTIK), TFRAC(MAXTIK)
  15393.       INTEGER DD(MAXTIK), HH(MAXTIK), MM(MAXTIK)
  15394.       CHARACTER*1 ASIGN(MAXTIK), ASIGNL
  15395. C
  15396.       REAL TIME, XLEN, YLEN, COORD, FJUST, RVAL, SSL, DISP,
  15397.      *XLEN2, YLEN2
  15398.       INTEGER IS, SD, NT, IZERO, IPOS, INEG, IT, I, J, K, SPREC,
  15399.      *JST(2), JEND(2), TLEN, LAST, IVAL(3), IVALO(3), IVALZ(3),
  15400.      *IVALF(3), IVALL(3), NPASS, INC, DDL, HHL, MML
  15401.       CHARACTER SIGNF*1, TEXT*80, AXLOC*2
  15402.       LOGICAL WRIT(4)
  15403. C-----------------------------------------------------------------------
  15404.       CALL PGBBUF
  15405. C
  15406. C  Direction signs
  15407. C
  15408.       SD = 1
  15409.       IF (TMAX.LT.TMIN) SD = -1
  15410.       IS = 1
  15411.       IF (TMIN.LT.0.0) IS = -1
  15412. C
  15413. C  Find first tick.  Return if none.
  15414. C
  15415.       NT = TMIN / TICK
  15416.       IF (IS*SD.EQ.1 .AND. ABS(TMIN).GT.ABS(NT)*TICK) NT = NT + SD
  15417.       TIME = NT * TICK
  15418.       IF ( (SD.EQ. 1.AND.(TIME.LT.TMIN.OR.TIME.GT.TMAX)) .OR.
  15419.      *     (SD.EQ.-1.AND.(TIME.GT.TMIN.OR.TIME.LT.TMAX)) ) RETURN
  15420. C
  15421. C  Now step through time range in TICK increments and convert
  15422. C  times in seconds at each tick to  +/- (DD) HH MM SS.S
  15423. C
  15424.       IZERO = 0
  15425.       IT = 1
  15426.  100  IF ( (SD.EQ.1  .AND. TIME.GT.(TMAX+1.0E-5)) .OR.
  15427.      *     (SD.EQ.-1 .AND. TIME.LT.(TMAX-1.0E-5)) ) GOTO 200
  15428.         IF (IT.GT.MAXTIK) THEN
  15429.           CALL GRWARN ('PGTBX4: storage exhausted -- you have'
  15430.      *                 //'asked for far too many ticks')
  15431.           GOTO 200
  15432.         END IF
  15433. C
  15434. C  Convert to (DD) HH MM SS.S and find fraction of window that this
  15435. C  tick falls at
  15436. C
  15437.         CALL PGTBX5 (DODAY, TIME, ASIGN(IT), DD(IT), HH(IT),
  15438.      *               MM(IT), SS(IT))
  15439.         TFRAC(IT) = (TIME - TMIN) / (TMAX - TMIN)
  15440. C
  15441. C  Note zero tick
  15442. C
  15443.         IF (NT.EQ.0) IZERO = IT
  15444. C
  15445. C  Increment time
  15446. C
  15447.         NT = NT + SD
  15448.         TIME = NT * TICK
  15449.         IT = IT + 1
  15450. C
  15451.         GOTO 100
  15452.  200  CONTINUE
  15453.       IT = IT - 1
  15454. C
  15455. C   Work out the precision with which to write fractional seconds 
  15456. C   labels into the SS.S field.   All other fields have integer labels.
  15457. C
  15458.       SPREC = 0
  15459.       IF (TSCALE.EQ.1) THEN
  15460.         IF (TICK.LT.0.01) THEN
  15461.           SPREC = 3
  15462.         ELSE IF (TICK.LT.0.1) THEN
  15463.           SPREC = 2
  15464.         ELSE IF (TICK.LT.1.0) THEN
  15465.           SPREC = 1
  15466.         END IF
  15467.       END IF
  15468. C
  15469. C  Label special case of first tick.  Prepare fields and label
  15470. C
  15471.       CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(1), HH(1), MM(1), 
  15472.      *             SS(1), IVALF, RVAL, WRIT)
  15473.       SIGNF = 'H'
  15474.       IF (DODAY) SIGNF = 'D'
  15475.       CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(1), IVALF, RVAL, WRIT,
  15476.      *             SPREC, DO2, TEXT, TLEN, LAST)
  15477. C
  15478. C   Set label displacements from axes.  This is messy for labels oriented
  15479. C   perpendicularly on the right hand axis as we need to know how long
  15480. C   the longest string we are going to write is before we write any 
  15481. C   labels as they are right justified.
  15482. C
  15483.       IF (AXIS.EQ.'X') THEN
  15484.         IF (CONVTL) THEN
  15485.           AXLOC = 'B'
  15486.           IF (SUPTYP.NE.'NONE') THEN
  15487.             DISP = 1.4
  15488.           ELSE
  15489.             DISP = 1.2
  15490.           END IF
  15491.         ELSE
  15492.           AXLOC = 'T'
  15493.           DISP = 0.7
  15494.         END IF
  15495.       ELSE IF (AXIS.EQ.'Y') THEN
  15496.         IF (CONVTL) THEN
  15497.           AXLOC = 'LV'
  15498.           IF (DOPARA) AXLOC = 'L'
  15499.           DISP = 0.7
  15500.         ELSE
  15501.           IF (DOPARA) THEN
  15502.             AXLOC = 'R'
  15503.             IF (SUPTYP.NE.'NONE') THEN
  15504.               DISP = 1.7
  15505.             ELSE
  15506.               DISP = 1.9
  15507.             END IF
  15508.           ELSE
  15509. C
  15510. C  Work out number of characters in first label
  15511. C
  15512.             AXLOC = 'RV'
  15513.             IF (ASIGN(1).NE.'-' .AND. TMIN*TMAX.LT.0.0) THEN
  15514.               CALL PGLEN (2, ' -'//TEXT(1:TLEN), XLEN, YLEN)
  15515.             ELSE
  15516.               CALL PGLEN (2, ' '//TEXT(1:TLEN), XLEN, YLEN)
  15517.             END IF
  15518.             CALL PGQCS (2, XLEN2, YLEN2)
  15519.             DISP = (XLEN/XLEN2)
  15520.           END IF
  15521.         END IF
  15522.       END IF
  15523. C
  15524. C  Now write the label to the plot.  The X-axis label for the first tick is
  15525. C  centred such that the last field of the label is centred on the tick
  15526. C
  15527.       IF (FIRST) THEN
  15528.         CALL PGLEN (5, TEXT(LAST:TLEN), XLEN, YLEN)
  15529. C
  15530.         IF (AXIS.EQ.'X') THEN
  15531.           COORD = TFRAC(1) + XLEN / 2.0
  15532.           FJUST = 1.0
  15533.         ELSE IF (AXIS.EQ.'Y') THEN
  15534.           IF (DOPARA) THEN
  15535.             COORD = TFRAC(1) + YLEN / 2.0
  15536.             FJUST = 1.0
  15537.           ELSE
  15538.             FJUST = 1.0
  15539.             COORD = TFRAC(1)
  15540.           END IF
  15541.         END IF
  15542.         CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  15543.       END IF
  15544.       IF (IT.EQ.1) RETURN
  15545. C
  15546. C   Designate which field out of DD or HH will carry the sign, depending
  15547. C   on whether you want the day field or not for the rest of the ticks
  15548. C
  15549.       SIGNF = 'H'
  15550.       IF (DODAY) SIGNF = 'D'
  15551. C
  15552. C  Set up labelling justifications for the rest of the labels
  15553. C
  15554.       IF (AXIS.EQ.'X') THEN
  15555.         FJUST = 0.5
  15556.       ELSE IF (AXIS.EQ.'Y') THEN
  15557.         IF (DOPARA) THEN
  15558.           FJUST = 0.5
  15559.         ELSE
  15560.           FJUST = 1.0
  15561.         END IF
  15562.       END IF
  15563. C
  15564. C  Note zero crossings; IPOS is the first positive tick and
  15565. C  INEG is the first negative tick on either side of 0
  15566. C
  15567.       IPOS = 0
  15568.       INEG = 0
  15569. C
  15570.       IF (IZERO.NE.0) THEN
  15571.         J = IZERO - 1
  15572.         IF (J.GE.1) THEN
  15573.           IF (ASIGN(J).EQ.'-') THEN
  15574.             INEG = J
  15575.           ELSE IF (ASIGN(J).EQ.' ') THEN
  15576.             IPOS = J
  15577.           END IF
  15578.         END IF
  15579.         J = IZERO + 1
  15580.         IF (J.LE.IT) THEN
  15581.           IF (ASIGN(J).EQ.'-') THEN
  15582.             INEG = J
  15583.           ELSE IF (ASIGN(J).EQ.' ') THEN
  15584.             IPOS = J
  15585.           END IF
  15586.         END IF
  15587.       END IF
  15588. C
  15589. C  Now label special case of zero tick. It carries the sign change
  15590. C  when going from positive to negative time, left to right.
  15591. C
  15592.       IF (IZERO.NE.0 .AND. IZERO.NE.1) THEN
  15593.         CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(IZERO), HH(IZERO), 
  15594.      *               MM(IZERO), SS(IZERO), IVALZ, RVAL, WRIT)
  15595. C
  15596.         IF (ASIGN(IZERO-1).EQ.' ') ASIGN(IZERO) = '-'
  15597.         CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(IZERO), IVALZ, RVAL, WRIT,
  15598.      *               SPREC, DO2, TEXT, TLEN, LAST)
  15599. C
  15600.         COORD = TFRAC(IZERO)
  15601.         CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  15602.       END IF
  15603. C
  15604. C   We may need an extra "virtual" tick if there is no zero crossing
  15605. C   and SD=-1 & IS=1 or SD=1 & IS=-1.  It is used to work out which
  15606. C   fields to label on the right most tick which is labelled first.
  15607. C
  15608.       IF (IZERO.EQ.0) THEN
  15609.         IF (SD*IS.EQ.-1) THEN 
  15610.           IF ( (SD.EQ.-1 .AND. TIME.LE.0.0) .OR.
  15611.      *         (SD.EQ. 1 .AND. TIME.GE.0.0) ) TIME = 0.0
  15612.           CALL PGTBX5 (DODAY, TIME, ASIGNL, DDL, HHL, MML, SSL)
  15613.           CALL PGTBX6 (DODAY, MOD24, TSCALE, DDL, HHL, MML, SSL,
  15614.      *                 IVALL, RVAL, WRIT)
  15615.         END IF
  15616.       END IF
  15617. C
  15618. C  We want to label in the direction(s) away from zero, so we may  need
  15619. C  two passes. Determine the start and end ticks for each required pass.
  15620. C
  15621.       JST(2) = 0
  15622.       JEND(2) = 0
  15623.       NPASS = 1
  15624.       IF (IZERO.EQ.0) THEN
  15625.         IF (IS*SD.EQ.1) THEN
  15626.           JST(1) = 1
  15627.           JEND(1) = IT
  15628.         ELSE
  15629.           JST(1) = IT
  15630.           JEND(1) = 1
  15631.         END IF
  15632.       ELSE
  15633.         IF (INEG.EQ.0 .OR. IPOS.EQ.0) THEN
  15634.           JST(1) = IZERO
  15635.           JEND(1) = IT
  15636.           IF (IZERO.EQ.IT) JEND(1) = 1
  15637.         ELSE
  15638.           NPASS = 2
  15639.           JST(1) = IZERO
  15640.           JEND(1) = 1
  15641.           JST(2) = IZERO
  15642.           JEND(2) = IT
  15643.         END IF
  15644.       END IF
  15645. C
  15646. C  Now label the rest of the ticks.  Always label away from 0
  15647. C
  15648.       DO 400 I = 1, NPASS
  15649. C
  15650. C  Initialize previous tick values.  Use virtual tick if labelling
  15651. C  left to right without a zero (one pass)
  15652. C
  15653.         DO 250 K = 1, 3
  15654.           IVALO(K) = IVALZ(K)
  15655.           IF (IZERO.EQ.0) THEN
  15656.             IVALO(K) = IVALL(K)
  15657.             IF (JST(I).EQ.1) IVALO(K) = IVALF(K)
  15658.           END IF
  15659.   250   CONTINUE
  15660. C
  15661.         INC = 1
  15662.         IF (JEND(I).LT.JST(I)) INC = -1
  15663.         DO 300 J = JST(I), JEND(I), INC
  15664. C
  15665. C  First and zero tick already labelled
  15666. C
  15667.           IF (J.NE.1 .AND. J.NE.IZERO) THEN
  15668. C
  15669. C  Prepare fields
  15670. C
  15671.             CALL PGTBX6 (DODAY, MOD24, TSCALE, DD(J), HH(J), MM(J),
  15672.      *                   SS(J), IVAL, RVAL, WRIT)
  15673. C
  15674. C  Don't write unchanging fields
  15675. C
  15676.             DO 275 K = 1, 3
  15677.               IF (IVAL(K).EQ.IVALO(K)) WRIT(K) = F
  15678.  275        CONTINUE
  15679. C
  15680. C  Prepare label
  15681. C
  15682.             CALL PGTBX7 (SUPTYP, SIGNF, ASIGN(J), IVAL, RVAL, WRIT,
  15683.      *                   SPREC, DO2, TEXT, TLEN, LAST)
  15684. C
  15685. C  Write label
  15686. C
  15687.             COORD = TFRAC(J)
  15688.             CALL PGMTXT (AXLOC, DISP, COORD, FJUST, TEXT(1:TLEN))
  15689. C
  15690. C  Update old values
  15691. C
  15692.             DO 280 K = 1, 3
  15693.               IVALO(K) = IVAL(K)
  15694.   280       CONTINUE
  15695.           END IF
  15696.  300    CONTINUE
  15697.  400  CONTINUE
  15698.       CALL PGEBUF
  15699. C 
  15700.       RETURN
  15701.       END
  15702. C PGTBX5 -- support routine for PGTBOX
  15703. C
  15704.       SUBROUTINE PGTBX5 (DODAY, TSEC, ASIGN, D, H, M, S)
  15705. C      
  15706.       REAL S, TSEC
  15707.       INTEGER  D, H, M
  15708.       LOGICAL DODAY
  15709.       CHARACTER*1 ASIGN
  15710. C
  15711. C  Convert time in seconds to (DD) HH MM SS.S
  15712. C
  15713. C Input
  15714. C  DODAY  :  Use day field if true, else hours accumulates beyond 24
  15715. C  TSEC   :  Time in seconds (signed)
  15716. C Output
  15717. C  ASIGN  :  Sign, ' ' or '-'
  15718. C  D,H,M  :  DD, HH, MM (unsigned)
  15719. C  S      :  SS.S       (unsigned)
  15720. C
  15721. C 10-Jun-1993 - new routine [nebk]
  15722. C-----------------------------------------------------------------------
  15723.       INTEGER IT
  15724. C----------------------------------------------------------------------
  15725.       ASIGN = ' '
  15726.       IF (TSEC.LT.0.0) ASIGN = '-'
  15727. C
  15728.       S = MOD(ABS(TSEC),60.0)
  15729. C
  15730.       IT = NINT(ABS(TSEC)-S) / 60
  15731.       M = MOD(IT,60)
  15732. C
  15733.       IT = (IT - M) / 60
  15734.       IF (DODAY) THEN
  15735.         H = MOD(IT,24)
  15736.         D = (IT-H) / 24
  15737.       ELSE
  15738.         H = IT
  15739.         D = 0
  15740.       END IF
  15741. C
  15742.       RETURN
  15743.       END
  15744. C PGTBX6 -- support routine for PGTBOX
  15745. C
  15746.       SUBROUTINE PGTBX6 (DODAY, MOD24, TSCALE, DD, HH, MM, SS, IVAL, 
  15747.      *                   RVAL, WRIT)
  15748. C
  15749.       INTEGER TSCALE, IVAL(3), DD, HH, MM
  15750.       REAL SS, RVAL
  15751.       LOGICAL WRIT(4), DODAY, MOD24
  15752. C
  15753. C   Find out which of the DD HH MM SS.S fields we want to write
  15754. C   into the label according to TSCALE and make a round off
  15755. C   error check.
  15756. C
  15757. C  Input:
  15758. C    DODAY  :  Use day field if true else hours accrue beyond 24
  15759. C    MOD24  :  HH field labelled as modulo 24
  15760. C    TSCALE :  Dictates which fields appear in labels
  15761. C    DD     :  Day of time  (will be 0 if DODAY=F and HH will compensate)
  15762. C    HH     :  Hour of time
  15763. C    MM     :  Minute of time
  15764. C    SS     :  Second of time
  15765. C  Output:
  15766. C    IVAL(3):  DD HH MM to write into label
  15767. C    RVAL   :  SS.S to write into label
  15768. C    WRIT(4):  T or F if DD,HH,MM,SS are to be written into the label
  15769. C              or not.  IVAL and RVAL fields are set explicitly to
  15770. C              zero if the corresponding WRIT field is false.
  15771. C              This really is overkill.
  15772. C
  15773. C  10-Jun-1993 - New routine [nebk]
  15774. C  16-Jan-1995 - Add argument MOD24
  15775. C-----------------------------------------------------------------------
  15776.       LOGICAL T, F
  15777.       PARAMETER (T = .TRUE., F = .FALSE.)
  15778.       INTEGER WM
  15779. C-----------------------------------------------------------------------
  15780.       IVAL(1) = DD
  15781.       IVAL(2) = HH
  15782.       IVAL(3) = MM
  15783.       RVAL    = SS
  15784. C
  15785. C  SS should be 0.0; round off may get us 59.999 or the like but
  15786. C  not 60.001 (see PGTBX5)
  15787. C
  15788.       IF (TSCALE.GT.1) THEN
  15789.         WM = NINT(SS/60.0)
  15790.         IVAL(3) = IVAL(3) + WM
  15791.         IF (IVAL(3).EQ.60) THEN
  15792.           IVAL(3) = 0
  15793.           IVAL(2) = IVAL(2) + 1
  15794.           IF (DODAY .AND. IVAL(2).EQ.24) THEN
  15795.             IVAL(2) = 0
  15796.             IVAL(1) = IVAL(1) + 1
  15797.           END IF
  15798.         END IF
  15799.       END IF
  15800. C
  15801. C Make HH field modulo 24 if desired
  15802. C
  15803.       IF (MOD24) IVAL(2) = MOD(IVAL(2),24)
  15804. C
  15805.       IF (TSCALE.EQ.1) THEN
  15806. C
  15807. C  Label contains (DD) HH MM SS.S
  15808. C
  15809.         WRIT(1) = DODAY
  15810.         WRIT(2) = T
  15811.         WRIT(3) = T
  15812.         WRIT(4) = T
  15813.       ELSE IF (TSCALE.EQ.60) THEN
  15814. C
  15815. C  Label contains (DD) HH MM
  15816. C
  15817.         WRIT(1) = DODAY
  15818.         WRIT(2) = T
  15819.         WRIT(3) = T
  15820. C        
  15821.         RVAL    = 0.0
  15822.         WRIT(4) = F
  15823.       ELSE IF (TSCALE.EQ.3600) THEN
  15824. C
  15825. C  Label contains (DD) HH
  15826. C
  15827.         WRIT(1) = DODAY
  15828.         WRIT(2) = T
  15829. C
  15830.         IVAL(3) = 0
  15831.         WRIT(3) = F
  15832. C  
  15833.         RVAL    = 0.0
  15834.         WRIT(4) = F
  15835.       ELSE IF (TSCALE.EQ.3600*24) THEN
  15836. C
  15837. C  Label contains DD
  15838. C
  15839.         WRIT(1) = T
  15840. C
  15841.         IVAL(2) = 0
  15842.         WRIT(2) = F
  15843. C
  15844.         IVAL(3) = 0
  15845.         WRIT(3) = F
  15846. C
  15847.         RVAL    = 0.0
  15848.         WRIT(4) = F
  15849.       END IF
  15850. C
  15851.       RETURN
  15852.       END
  15853.       SUBROUTINE PGTBX7 (SUPTYP, SIGNF, ASIGN, IVAL, RVAL, WRIT,
  15854.      *                   SPREC, DO2, TEXT, TLEN, LAST)
  15855. C
  15856.       REAL RVAL
  15857.       INTEGER IVAL(3), TLEN, SPREC, LAST
  15858.       CHARACTER ASIGN*1, TEXT*(*), SIGNF*1, SUPTYP*4
  15859.       LOGICAL WRIT(4), DO2
  15860. C
  15861. C Write (DD) HH MM SS.S time labels into a string
  15862. C
  15863. C This is a support routine for PGTBOX and should not be
  15864. C called by the user
  15865. C
  15866. C Inputs
  15867. C  SUPTYP :  '    ', 'DHMS', or ' DMS' for no superscript labelling,
  15868. C            d,h,m,s   or   o,','' superscripting
  15869. C  SIGNF  :  Tells which field the sign is associated with.  
  15870. C            One of 'D', 'H', 'M', or 'S'    
  15871. C  ASIGN  :  ' ' or '-' for positive or negative times
  15872. C  IVAL(3):  Day, hour, minutes of time
  15873. C  RVAL   :  Seconds of time
  15874. C  WRIT(4):  If .true. then write DD, HH, MM, SS  into label
  15875. C  SPREC  :  Number of places after the decimal to write seconds 
  15876. C            string to.  Must be in the range 0-3
  15877. C  DO2    :  If true, add a leading zero to numbers < 10
  15878. C Outputs
  15879. C  TEXT   :  Label
  15880. C  TLEN   :  Length of label
  15881. C  LAST   :  Is the location of the start character of the last 
  15882. C            field written into TEXT
  15883. C
  15884. C  05-Sep-1989 -- New routine (Neil Killeen)
  15885. C  20-Apr-1991 -- Complete rewrite; support for new DD (day) field and 
  15886. C                 superscripted labels [nebk]
  15887. C  14-May-1991 -- Removed BSL as a parameter (Char(92)) and made it
  15888. C                 a variable to appease Cray compiler [mjs/nebk]
  15889. C  10-Jun-1993 -- Rename from PGTLB1, add code to label superscript 
  15890. C                 seconds above the '.' and add DO2 option [nebk/jm]
  15891. C-----------------------------------------------------------------------
  15892.       INTEGER FLEN, FST, FMAX, TRLEN(3), SUPPNT, TMPNT, TLEN2, 
  15893.      *IR1, IR2, IP
  15894.       CHARACTER FIELD*30, FRMAT2(3)*2, SUPER(4,3)*11, TMP*100, 
  15895.      *BSL*1, FRMAT*30
  15896. C
  15897.       SAVE FRMAT2
  15898.       SAVE TRLEN
  15899. C
  15900.       DATA FRMAT2 /'I1', 'I2', 'I3'/
  15901.       DATA TRLEN /5, 11, 5/
  15902. C-----------------------------------------------------------------------
  15903. C
  15904. C   Initialize
  15905. C
  15906.       BSL = CHAR(92)
  15907.       TLEN = 0
  15908.       TEXT = ' '
  15909. C
  15910. C   Assign superscripting strings.  Use CHAR(92) for backslash as the
  15911. C   latter must be escaped on SUNs thus requiring preprocessing.  The
  15912. C   concatenator operator precludes the use of a data statement
  15913. C
  15914.       SUPER(1,1) = BSL//'ud'//BSL//'d'
  15915.       SUPER(2,1) = BSL//'uh'//BSL//'d'
  15916.       SUPER(3,1) = BSL//'um'//BSL//'d'
  15917.       SUPER(4,1) = BSL//'us'//BSL//'d'
  15918. C
  15919.       SUPER(1,2) = BSL//'u'//BSL//'(2199)'//BSL//'d'
  15920.       SUPER(2,2) = BSL//'u'//BSL//'(2729)'//BSL//'d'
  15921.       SUPER(3,2) = BSL//'u'//BSL//'(2727)'//BSL//'d'
  15922.       SUPER(4,2) = BSL//'u'//BSL//'(2728)'//BSL//'d'
  15923. C      
  15924.       SUPER(1,3) = BSL//'u'//' '//BSL//'d'
  15925.       SUPER(2,3) = BSL//'u'//' '//BSL//'d'
  15926.       SUPER(3,3) = BSL//'u'//' '//BSL//'d'
  15927.       SUPER(4,3) = BSL//'u'//' '//BSL//'d'
  15928. C
  15929. C   Point at correct superscript strings
  15930. C
  15931.       IF (SUPTYP.EQ.'DHMS') THEN
  15932.         SUPPNT = 1
  15933.       ELSE IF (SUPTYP.EQ.' DMS') THEN
  15934.         SUPPNT = 2
  15935.       ELSE
  15936.         SUPPNT = 3
  15937.       END IF
  15938. C
  15939. CCCC
  15940. C   Days field
  15941. CCCC
  15942. C
  15943.       IF (WRIT(1)) THEN
  15944.         LAST = TLEN + 1
  15945. C
  15946. C   Write into temporary field
  15947. C
  15948.         FIELD = ' '
  15949.         CALL PGNPL (0, IVAL(1), FLEN)
  15950.         WRITE (FIELD, '(I6)') IVAL(1)
  15951.         FMAX = 6
  15952.         FST = FMAX - FLEN + 1
  15953. C
  15954. C   Write output text string with desired superscripting
  15955. C
  15956.         TMPNT = 2
  15957.         IF (SIGNF.EQ.'D' .AND. ASIGN.NE.' ') TMPNT = 1
  15958. C
  15959.         TMP = ASIGN//FIELD(FST:FMAX)//SUPER(1,SUPPNT)
  15960.         TLEN2 = (2 - TMPNT) + FLEN + TRLEN(SUPPNT)
  15961. C
  15962.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  15963.         TLEN = TLEN + TLEN2
  15964.       END IF
  15965. C
  15966. CCCC 
  15967. C   Hours field
  15968. CCCC
  15969. C
  15970.       IF (WRIT(2)) THEN
  15971.         LAST = TLEN + 1
  15972. C
  15973. C   Write into temporary field
  15974. C
  15975.         FIELD = ' '
  15976.         CALL PGNPL (0, IVAL(2), FLEN)
  15977.         WRITE (FIELD, '(I6)') IVAL(2)
  15978.         FMAX = 6
  15979.         FST = FMAX - FLEN + 1
  15980. C
  15981.         IF (DO2 .AND. FLEN.EQ.1) THEN
  15982.           FLEN = FLEN + 1
  15983.           FST = FST - 1
  15984.           FIELD(FST:FST) = '0'
  15985.         END IF
  15986. C
  15987. C   Write output text string with desired superscripting
  15988. C
  15989.         TMPNT = 2
  15990.         IF (SIGNF.EQ.'H' .AND. ASIGN.NE.' ') TMPNT = 1
  15991. C
  15992.         TMP = ASIGN//FIELD(FST:FMAX)//SUPER(2,SUPPNT)
  15993.         TLEN2 = (2 - TMPNT) + FLEN + TRLEN(SUPPNT)
  15994. C
  15995.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  15996.         TLEN = TLEN + TLEN2
  15997.       END IF
  15998. C
  15999. CCCC
  16000. C   Minutes field
  16001. CCCC
  16002. C
  16003.       IF (WRIT(3)) THEN
  16004.         LAST = TLEN + 1
  16005. C
  16006. C   Write into temporary field with desired superscripting
  16007. C
  16008.         FIELD = ' '
  16009.         WRITE (FIELD, '(I2, A)') IVAL(3), 
  16010.      *                           SUPER(3,SUPPNT)(1:TRLEN(SUPPNT))
  16011.         FMAX = 2 + TRLEN(SUPPNT)
  16012. C
  16013.         FST = 1
  16014.         IF (FIELD(FST:FST).EQ.' ') THEN
  16015.           IF (DO2) THEN
  16016.             FIELD(FST:FST) = '0'
  16017.           ELSE
  16018.             FST = FST + 1
  16019.           END IF
  16020.         END IF
  16021.         FLEN = FMAX - FST + 1
  16022. C
  16023. C   Write output text string
  16024. C
  16025.         TMPNT = 2
  16026.         IF (SIGNF.EQ.'M' .AND. ASIGN.NE.' ') TMPNT = 1
  16027. C
  16028.         TMP = ASIGN//FIELD(FST:FMAX)
  16029.         TLEN2 = (2 - TMPNT) + FLEN
  16030. C
  16031.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  16032.         TLEN = TLEN + TLEN2
  16033.       END IF
  16034. C
  16035. CCCC
  16036. C   Seconds field
  16037. CCCC
  16038. C
  16039.       IF (WRIT(4)) THEN
  16040.         LAST = TLEN + 1
  16041. C
  16042. C   Write into temporary field
  16043. C 
  16044.         FIELD = ' '
  16045.         FST = 1
  16046.         IF (SPREC.GE.1) THEN
  16047. C
  16048. C   Fractional label.  Upto 3 places after the decimal point allowed
  16049. C   Muck around to get the superscript on top of the decimal point
  16050. C
  16051.           IR1 = INT(RVAL)
  16052.           IR2 = NINT((RVAL - IR1) * 10**SPREC)
  16053.           FRMAT = '(I2, A1, A, '//FRMAT2(SPREC)//')'
  16054.           WRITE (FIELD, FRMAT(1:15)) 
  16055.      *                       IR1, '.',
  16056.      *                       BSL//'b'//SUPER(4,SUPPNT)(1:TRLEN(SUPPNT)),
  16057.      *                       IR2
  16058.           IP = 5 + TRLEN(SUPPNT) + 1
  16059.           IF (FIELD(IP:IP).EQ.' ') FIELD(IP:IP) = '0'
  16060.           IF (FIELD(IP+1:IP+1).EQ.' ') FIELD(IP+1:IP+1) = '0'
  16061.           FMAX = 1 + 2 + SPREC
  16062.         ELSE
  16063. C
  16064. C   Integer label.  
  16065. C
  16066.           WRITE (FIELD, '(I2,A)') NINT(RVAL), 
  16067.      *                            SUPER(4,SUPPNT)(1:TRLEN(SUPPNT))
  16068.           FMAX = 0
  16069.         END IF
  16070.         FMAX = FMAX + 2 + TRLEN(SUPPNT)
  16071. C
  16072.         IF (FIELD(FST:FST).EQ.' ') THEN
  16073.           IF (DO2) THEN
  16074.             FIELD(FST:FST) = '0'
  16075.           ELSE
  16076.             FST = FST + 1
  16077.           END IF
  16078.         END IF
  16079.         FLEN = FMAX - FST + 1
  16080. C
  16081. C   Write output text string
  16082. C
  16083.         TMPNT = 2
  16084.         IF (SIGNF.EQ.'S' .AND. ASIGN.NE.' ') TMPNT = 1
  16085.         TMP = ASIGN//FIELD(FST:FMAX)
  16086.         TLEN2 = (3 - TMPNT) + FLEN
  16087. C
  16088.         TEXT(TLEN+1:) = TMP(TMPNT:TMPNT+TLEN2-1)
  16089.         TLEN = TLEN + TLEN2
  16090.       END IF
  16091. C  
  16092. C   A trailing blank will occur if no superscripting wanted
  16093. C
  16094.       IF (TLEN.GE.5 .AND. TEXT(TLEN-4:TLEN).EQ.BSL//'u'//' '//BSL//'d')
  16095.      *   TLEN = TLEN - 5
  16096. C      
  16097.       RETURN
  16098.       END
  16099. C*PGTEXT -- write text (horizontal, left-justified)
  16100. C%void cpgtext(float x, float y, const char *text);
  16101. C+
  16102.       SUBROUTINE PGTEXT (X, Y, TEXT)
  16103.       REAL X, Y
  16104.       CHARACTER*(*) TEXT
  16105. C
  16106. C Write text. The bottom left corner of the first character is placed
  16107. C at the specified position, and the text is written horizontally.
  16108. C This is a simplified interface to the primitive routine PGPTXT.
  16109. C For non-horizontal text, use PGPTXT.
  16110. C
  16111. C Arguments:
  16112. C  X      (input)  : world x-coordinate of start of string.
  16113. C  Y      (input)  : world y-coordinate of start of string.
  16114. C  TEXT   (input)  : the character string to be plotted.
  16115. C--
  16116. C (2-May-1983)
  16117. C-----------------------------------------------------------------------
  16118.       CALL PGPTXT(X, Y, 0.0, 0.0, TEXT)
  16119.       END
  16120. C*PGTICK -- draw a single tick mark on an axis
  16121. C%void cpgtick(float x1, float y1, float x2, float y2, float v, \
  16122. C% float tikl, float tikr, float disp, float orient, const char *str);
  16123. C+
  16124.       SUBROUTINE PGTICK (X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, 
  16125.      :                   ORIENT, STR)
  16126.       REAL X1, Y1, X2, Y2, V, TIKL, TIKR, DISP, ORIENT
  16127.       CHARACTER*(*) STR
  16128. C
  16129. C Draw and label single tick mark on a graph axis. The tick mark is
  16130. C a short line perpendicular to the direction of the axis (which is not
  16131. C drawn by this routine). The optional text label is drawn with its
  16132. C baseline parallel to the axis and reading in the same direction as
  16133. C the axis (from point 1 to point 2). Current line and text attributes
  16134. C are used.
  16135. C
  16136. C Arguments:
  16137. C  X1, Y1 (input)  : world coordinates of one endpoint of the axis.
  16138. C  X2, Y2 (input)  : world coordinates of the other endpoint of the axis.
  16139. C  V      (input)  : draw the tick mark at fraction V (0<=V<=1) along
  16140. C                    the line from (X1,Y1) to (X2,Y2).
  16141. C  TIKL   (input)  : length of tick mark drawn to left of axis
  16142. C                    (as seen looking from first endpoint to second), in
  16143. C                    units of the character height.
  16144. C  TIKR   (input)  : length of major tick marks drawn to right of axis,
  16145. C                    in units of the character height.
  16146. C  DISP   (input)  : displacement of label text to
  16147. C                    right of axis, in units of the character height.
  16148. C  ORIENT (input)  : orientation of label text, in degrees; angle between
  16149. C                    baseline of text and direction of axis (0-360°).
  16150. C  STR    (input)  : text of label (may be blank).
  16151. C--
  16152. C 25-Mar-1997 - new routine [TJP].
  16153. C-----------------------------------------------------------------------
  16154.       REAL X, Y, XV1, XV2, YV1, YV2, XW1, XW2, YW1, YW2
  16155.       REAL XPMM, YPMM, LENMM, ANGLE, XCH, YCH
  16156.       REAL TIKX, TIKY, FJUST, D, OR
  16157. C
  16158. C Check arguments.
  16159. C
  16160.       IF (X1.EQ.X2 .AND. Y1.EQ.Y2) RETURN
  16161. C
  16162. C Get current character height (mm) [note: XCH = YCH].
  16163. C
  16164.       CALL PGQCS(2, XCH, YCH)
  16165. C
  16166. C Get x and y scales (units per mm).
  16167. C
  16168.       CALL PGQVP(2, XV1, XV2, YV1, YV2)
  16169.       CALL PGQWIN(XW1, XW2, YW1, YW2)
  16170.       XPMM  = (XW2-XW1)/(XV2-XV1)
  16171.       YPMM  = (YW2-YW1)/(YV2-YV1)
  16172. C
  16173. C Length of axis in mm.
  16174. C
  16175.       LENMM = SQRT(((X2-X1)/XPMM)**2 + ((Y2-Y1)/YPMM)**2)
  16176. C
  16177. C Angle of axis to horizontal (device coordinates).
  16178. C
  16179.       ANGLE = ATAN2((Y2-Y1)/YPMM, (X2-X1)/XPMM)*57.29577951
  16180. C
  16181. C (x,y) displacement for 1 character height perpendicular to axis.
  16182. C
  16183.       TIKX = (Y1-Y2)*XCH*XPMM/(LENMM*YPMM)
  16184.       TIKY = (X2-X1)*XCH*YPMM/(LENMM*XPMM)
  16185. C
  16186. C Draw the tick mark at point (X,Y) on the axis.
  16187. C
  16188.       X = X1 + V*(X2-X1)
  16189.       Y = Y1 + V*(Y2-Y1)
  16190.       CALL PGMOVE(X - TIKR*TIKX, Y - TIKR*TIKY)
  16191.       CALL PGDRAW(X + TIKL*TIKX, Y + TIKL*TIKY)
  16192. C
  16193. C Label the tick mark.
  16194. C
  16195.       D = DISP
  16196.       IF (STR.EQ.' ') RETURN
  16197.       OR = MOD(ORIENT, 360.0)
  16198.       IF (OR.LT.0.0) OR=OR+360.0
  16199.       IF (OR.GT.45.0 .AND. OR.LE.135.0) THEN
  16200.          FJUST = 0.0
  16201.          IF (D.LT.0.0) FJUST = 1.0
  16202.       ELSE IF (OR.GT.135.0 .AND. OR.LE.225.0) THEN
  16203.          FJUST = 0.5
  16204.          IF (D.LT.0.0) D = D-1.0
  16205.       ELSE IF (OR.GT.225.0 .AND. OR.LE.315.0) THEN
  16206.          ANGLE = ANGLE+90.0
  16207.          FJUST = 1.0
  16208.          IF (D.LT.0.0) FJUST = 0.0
  16209.       ELSE
  16210.          FJUST = 0.5
  16211.          IF (D.GT.0.0) D = D+1.0
  16212.       END IF            
  16213.       CALL PGPTXT(X-D*TIKX, Y-D*TIKY, ANGLE-OR, FJUST, STR)
  16214.       END
  16215. C.PGTIKL -- length of error bar terminal
  16216. C
  16217.       SUBROUTINE PGTIKL (T, XL, YL)
  16218.       REAL T, XL, YL
  16219. C
  16220. C Return the length of the terminal of an error bar, in world
  16221. C coordinates.
  16222. C
  16223. C Arguments:
  16224. C  T      (input)  : terminal multiplier
  16225. C  XL     (output) : terminal lnegth in world x-coordinates
  16226. C  YL     (output) : terminal lnegth in world y-coordinates
  16227. C--
  16228. C 31-Mar-1997 - new routine [TJP].
  16229. C-----------------------------------------------------------------------
  16230.       INCLUDE  'f77.PGPLOT/IN'
  16231. C
  16232.       XL = T*PGXSP(PGID)*0.15/PGXSCL(PGID)
  16233.       YL = T*PGXSP(PGID)*0.15/PGYSCL(PGID)
  16234. C
  16235.       END
  16236. C*PGUPDT -- update display
  16237. C%void cpgupdt(void);
  16238. C+
  16239.       SUBROUTINE PGUPDT
  16240. C
  16241. C Update the graphics display: flush any pending commands to the
  16242. C output device. This routine empties the buffer created by PGBBUF,
  16243. C but it does not alter the PGBBUF/PGEBUF counter. The routine should
  16244. C be called when it is essential that the display be completely up to
  16245. C date (before interaction with the user, for example) but it is not
  16246. C known if output is being buffered.
  16247. C
  16248. C Arguments: none
  16249. C--
  16250. C 27-Nov-1986
  16251. C-----------------------------------------------------------------------
  16252.       LOGICAL PGNOTO
  16253. C
  16254.       IF (PGNOTO('PGUPDT')) RETURN
  16255.       CALL GRTERM
  16256.       END
  16257. C*PGVECT -- vector map of a 2D data array, with blanking
  16258. C%void cpgvect(const float *a, const float *b, int idim, int jdim, \
  16259. C% int i1, int i2, int j1, int j2, float c, int nc, \
  16260. C% const float *tr, float blank);
  16261. C+
  16262.       SUBROUTINE PGVECT (A, B, IDIM, JDIM, I1, I2, J1, J2, C, NC, TR,
  16263.      1                   BLANK)
  16264.       INTEGER IDIM, JDIM, I1, I2, J1, J2, NC
  16265.       REAL    A(IDIM,JDIM), B(IDIM, JDIM), TR(6), BLANK, C
  16266. C
  16267. C Draw a vector map of two arrays.  This routine is similar to
  16268. C PGCONB in that array elements that have the "magic value" defined by
  16269. C the argument BLANK are ignored, making gaps in the vector map.  The
  16270. C routine may be useful for data measured on most but not all of the
  16271. C points of a grid. Vectors are displayed as arrows; the style of the
  16272. C arrowhead can be set with routine PGSAH, and the the size of the
  16273. C arrowhead is determined by the current character size, set by PGSCH.
  16274. C
  16275. C Arguments:
  16276. C  A      (input)  : horizontal component data array.
  16277. C  B      (input)  : vertical component data array.
  16278. C  IDIM   (input)  : first dimension of A and B.
  16279. C  JDIM   (input)  : second dimension of A and B.
  16280. C  I1,I2  (input)  : range of first index to be mapped (inclusive).
  16281. C  J1,J2  (input)  : range of second index to be mapped (inclusive).
  16282. C  C      (input)  : scale factor for vector lengths, if 0.0, C will be
  16283. C                    set so that the longest vector is equal to the
  16284. C                    smaller of TR(2)+TR(3) and TR(5)+TR(6).
  16285. C  NC     (input)  : vector positioning code.
  16286. C                    <0 vector head positioned on coordinates
  16287. C                    >0 vector base positioned on coordinates
  16288. C                    =0 vector centered on the coordinates
  16289. C  TR     (input)  : array defining a transformation between the I,J
  16290. C                    grid of the array and the world coordinates. The
  16291. C                    world coordinates of the array point A(I,J) are
  16292. C                    given by:
  16293. C                      X = TR(1) + TR(2)*I + TR(3)*J
  16294. C                      Y = TR(4) + TR(5)*I + TR(6)*J
  16295. C                    Usually TR(3) and TR(5) are zero - unless the
  16296. C                    coordinate transformation involves a rotation
  16297. C                    or shear.
  16298. C  BLANK   (input) : elements of arrays A or B that are exactly equal to
  16299. C                    this value are ignored (blanked).
  16300. C--
  16301. C  4-Sep-1992: derived from PGCONB [J. Crane].
  16302. C 26-Nov-1992: revised to use PGARRO [TJP].
  16303. C 25-Mar-1994: correct error for NC not =0 [G. Gonczi].
  16304. C  5-Oct-1996: correct error in computing max vector length [TJP;
  16305. C              thanks to David Singleton].
  16306. C-----------------------------------------------------------------------
  16307.       INTEGER  I, J
  16308.       REAL X, Y, X1, Y1, X2, Y2
  16309.       REAL CC
  16310.       INTRINSIC SQRT, MAX, MIN
  16311. C
  16312. C Define grid to world transformation
  16313. C
  16314.       X(I,J) = TR(1) + TR(2)*I + TR(3)*J
  16315.       Y(I,J) = TR(4) + TR(5)*I + TR(6)*J
  16316. C
  16317. C Check arguments.
  16318. C
  16319.       IF (I1.LT.1 .OR. I2.GT.IDIM .OR. I1.GE.I2 .OR.
  16320.      1    J1.LT.1 .OR. J2.GT.JDIM .OR. J1.GE.J2) THEN
  16321. C        CALL GRWARN('PGVECT: invalid range I1:I2, J1:J2')
  16322.          RETURN
  16323.       END IF
  16324. C
  16325. C Check for scale factor C.
  16326. C
  16327.       CC = C
  16328.       IF (CC.EQ.0.0) THEN
  16329.          DO 20 J=J1,J2
  16330.             DO 10 I=I1,I2
  16331.                IF (A(I,J).NE.BLANK .AND. B(I,J).NE.BLANK)
  16332.      1              CC = MAX(CC,SQRT(A(I,J)**2+B(I,J)**2))
  16333.  10         CONTINUE
  16334.  20      CONTINUE
  16335.          IF (CC.EQ.0.0) RETURN
  16336.          CC = SQRT(MIN(TR(2)**2+TR(3)**2,TR(5)**2+TR(6)**2))/CC
  16337.       END IF
  16338. C
  16339.       CALL PGBBUF
  16340. C
  16341.       DO 40 J=J1,J2
  16342.          DO 30 I=I1,I2
  16343. C
  16344. C Ignore vector if element of A and B are both equal to BLANK
  16345. C
  16346.             IF (.NOT.(A(I,J).EQ.BLANK .AND. B(I,J).EQ.BLANK)) THEN
  16347.  
  16348. C
  16349. C Define the vector starting and end points according to NC.
  16350. C
  16351.                IF (NC.LT.0) THEN
  16352.                   X2 = X(I,J)
  16353.                   Y2 = Y(I,J)
  16354.                   X1 = X2 - A(I,J)*CC
  16355.                   Y1 = Y2 - B(I,J)*CC
  16356.                ELSE IF (NC.EQ.0) THEN
  16357.                   X2 = X(I,J) + 0.5*A(I,J)*CC
  16358.                   Y2 = Y(I,J) + 0.5*B(I,J)*CC
  16359.                   X1 = X2 - A(I,J)*CC
  16360.                   Y1 = Y2 - B(I,J)*CC
  16361.                ELSE
  16362.                   X1 = X(I,J)
  16363.                   Y1 = Y(I,J)
  16364.                   X2 = X1 + A(I,J)*CC
  16365.                   Y2 = Y1 + B(I,J)*CC
  16366.                END IF
  16367. C     
  16368. C Draw vector.
  16369. C
  16370.                CALL PGARRO(X1, Y1, X2, Y2)
  16371.             END IF
  16372.  30      CONTINUE
  16373.  40   CONTINUE
  16374. C
  16375.       CALL PGEBUF
  16376.       END
  16377. C*PGVPORT -- non-standard alias for PGSVP
  16378. C+
  16379.       SUBROUTINE PGVPORT (XLEFT, XRIGHT, YBOT, YTOP)
  16380.       REAL XLEFT, XRIGHT, YBOT, YTOP
  16381. C
  16382. C See description of PGSVP.
  16383. C--
  16384.       CALL PGSVP (XLEFT, XRIGHT, YBOT, YTOP)
  16385.       END
  16386. C*PGVSIZ -- set viewport (inches)
  16387. C%void cpgvsiz(float xleft, float xright, float ybot, float ytop);
  16388. C+
  16389.       SUBROUTINE PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP)
  16390.       REAL XLEFT, XRIGHT, YBOT, YTOP
  16391. C
  16392. C Change the size and position of the viewport, specifying
  16393. C the viewport in physical device coordinates (inches).  The
  16394. C viewport is the rectangle on the view surface "through"
  16395. C which one views the graph.  All the PG routines which plot lines
  16396. C etc. plot them within the viewport, and lines are truncated at
  16397. C the edge of the viewport (except for axes, labels etc drawn with
  16398. C PGBOX or PGLAB).  The region of world space (the coordinate
  16399. C space of the graph) which is visible through the viewport is
  16400. C specified by a call to PGSWIN.  It is legal to request a
  16401. C viewport larger than the view surface; only the part which
  16402. C appears on the view surface will be plotted.
  16403. C
  16404. C Arguments:
  16405. C  XLEFT  (input)  : x-coordinate of left hand edge of viewport, in
  16406. C                    inches from left edge of view surface.
  16407. C  XRIGHT (input)  : x-coordinate of right hand edge of viewport, in
  16408. C                    inches from left edge of view surface.
  16409. C  YBOT   (input)  : y-coordinate of bottom edge of viewport, in
  16410. C                    inches from bottom of view surface.
  16411. C  YTOP   (input)  : y-coordinate of top  edge of viewport, in inches
  16412. C                    from bottom of view surface.
  16413. C--
  16414. C 13-Dec-1990  Make errors non-fatal [TJP].
  16415. C-----------------------------------------------------------------------
  16416.       INCLUDE  'f77.PGPLOT/IN'
  16417.       LOGICAL  PGNOTO
  16418. C
  16419.       IF (PGNOTO('PGVSIZ'))  RETURN
  16420.       IF (XLEFT.GE.XRIGHT .OR. YBOT.GE.YTOP) THEN
  16421.           CALL GRWARN('PGVSIZ ignored: invalid arguments')
  16422.           RETURN
  16423.       END IF
  16424. C
  16425.       PGXLEN(PGID) = (XRIGHT-XLEFT)*PGXPIN(PGID)
  16426.       PGYLEN(PGID) = (YTOP-YBOT)*PGYPIN(PGID)
  16427.       PGXVP(PGID)  = XLEFT*PGXPIN(PGID)
  16428.       PGYVP(PGID)  = YBOT*PGYPIN(PGID)
  16429.       PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  16430.       PGYOFF(PGID) = PGYVP(PGID) + 
  16431.      1                (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  16432.       CALL PGVW
  16433.       END
  16434. C*PGVSIZE -- non-standard alias for PGVSIZ
  16435. C+
  16436.       SUBROUTINE PGVSIZE (XLEFT, XRIGHT, YBOT, YTOP)
  16437.       REAL XLEFT, XRIGHT, YBOT, YTOP
  16438. C
  16439. C See description of PGVSIZ.
  16440. C--
  16441.       CALL PGVSIZ (XLEFT, XRIGHT, YBOT, YTOP)
  16442.       END
  16443. C*PGVSTAND -- non-standard alias for PGVSTD
  16444. C+
  16445.       SUBROUTINE PGVSTAND
  16446. C
  16447. C See description of PGVSTD.
  16448. C--
  16449.       CALL PGVSTD
  16450.       END
  16451. C*PGVSTD -- set standard (default) viewport
  16452. C%void cpgvstd(void);
  16453. C+
  16454.       SUBROUTINE PGVSTD
  16455. C
  16456. C Define the viewport to be the standard viewport.  The standard
  16457. C viewport is the full area of the view surface (or panel),
  16458. C less a margin of 4 character heights all round for labelling.
  16459. C It thus depends on the current character size, set by PGSCH.
  16460. C
  16461. C Arguments: none.
  16462. C--
  16463. C 22-Apr-1983: [TJP].
  16464. C  2-Aug-1995: [TJP].
  16465. C-----------------------------------------------------------------------
  16466.       INCLUDE  'f77.PGPLOT/IN'
  16467.       LOGICAL  PGNOTO
  16468.       REAL     XLEFT, XRIGHT, YBOT, YTOP, R
  16469. C
  16470.       IF (PGNOTO('PGVSIZ')) RETURN
  16471. C
  16472.       R = 4.0*PGYSP(PGID)
  16473.       XLEFT  = R/PGXPIN(PGID)
  16474.       XRIGHT = XLEFT + (PGXSZ(PGID)-2.0*R)/PGXPIN(PGID)
  16475.       YBOT   = R/PGYPIN(PGID)
  16476.       YTOP   = YBOT + (PGYSZ(PGID)-2.0*R)/PGYPIN(PGID)
  16477.       CALL PGVSIZ(XLEFT, XRIGHT, YBOT, YTOP)
  16478.       END
  16479. C
  16480.       SUBROUTINE PGVW
  16481. C
  16482. C PGPLOT (internal routine): set the GRPCKG scaling transformation
  16483. C and window appropriate for the current window and viewport. This
  16484. C routine is called whenever the viewport or window is changed.
  16485. C
  16486. C Arguments: none
  16487. C
  16488. C (11-Feb-1983)
  16489. C-----------------------------------------------------------------------
  16490.       INCLUDE 'f77.PGPLOT/IN'
  16491. C
  16492. C Scale plotter in world coordinates.
  16493. C
  16494.       PGXSCL(PGID) = PGXLEN(PGID)/ABS(PGXTRC(PGID)-PGXBLC(PGID))
  16495.       PGYSCL(PGID) = PGYLEN(PGID)/ABS(PGYTRC(PGID)-PGYBLC(PGID))
  16496.       IF (PGXBLC(PGID).GT.PGXTRC(PGID)) THEN
  16497.           PGXSCL(PGID) = -PGXSCL(PGID)
  16498.       END IF
  16499.       IF (PGYBLC(PGID).GT.PGYTRC(PGID)) THEN
  16500.           PGYSCL(PGID) = -PGYSCL(PGID)
  16501.       END IF
  16502.       PGXORG(PGID) = PGXOFF(PGID)-PGXBLC(PGID)*PGXSCL(PGID)
  16503.       PGYORG(PGID) = PGYOFF(PGID)-PGYBLC(PGID)*PGYSCL(PGID)
  16504.       CALL GRTRN0(PGXORG(PGID),PGYORG(PGID),
  16505.      1            PGXSCL(PGID),PGYSCL(PGID))
  16506. C
  16507. C Window plotter in viewport.
  16508. C
  16509.       CALL GRAREA(PGID,PGXOFF(PGID),PGYOFF(PGID),
  16510.      1            PGXLEN(PGID),PGYLEN(PGID))
  16511.       END
  16512. C*PGWEDG -- annotate an image plot with a wedge
  16513. C%void cpgwedg(const char *side, float disp, float width, \
  16514. C% float fg, float bg, const char *label);
  16515. C+
  16516.       SUBROUTINE PGWEDG(SIDE, DISP, WIDTH, FG, BG, LABEL)
  16517.       CHARACTER *(*) SIDE,LABEL
  16518.       REAL DISP, WIDTH, FG, BG
  16519. C
  16520. C Plot an annotated grey-scale or color wedge parallel to a given axis
  16521. C of the the current viewport. This routine is designed to provide a
  16522. C brightness/color scale for an image drawn with PGIMAG or PGGRAY.
  16523. C The wedge will be drawn with the transfer function set by PGSITF
  16524. C and using the color index range set by PGSCIR.
  16525. C
  16526. C Arguments:
  16527. C  SIDE   (input)  : The first character must be one of the characters
  16528. C                    'B', 'L', 'T', or 'R' signifying the Bottom, Left,
  16529. C                    Top, or Right edge of the viewport.
  16530. C                    The second character should be 'I' to use PGIMAG
  16531. C                    to draw the wedge, or 'G' to use PGGRAY.
  16532. C  DISP   (input)  : the displacement of the wedge from the specified
  16533. C                    edge of the viewport, measured outwards from the
  16534. C                    viewport in units of the character height. Use a
  16535. C                    negative value to write inside the viewport, a
  16536. C                    positive value to write outside.
  16537. C  WIDTH  (input)  : The total width of the wedge including annotation,
  16538. C                    in units of the character height.
  16539. C  FG     (input)  : The value which is to appear with shade
  16540. C                    1 ("foreground"). Use the values of FG and BG
  16541. C                    that were supplied to PGGRAY or PGIMAG.
  16542. C  BG     (input)  : the value which is to appear with shade
  16543. C                    0 ("background").
  16544. C  LABEL  (input)  : Optional units label. If no label is required
  16545. C                    use ' '.
  16546. C--
  16547. C  15-Oct-1992: New routine (MCS)
  16548. C   2-Aug-1995: no longer needs common (TJP).
  16549. C-----------------------------------------------------------------------
  16550.       LOGICAL PGNOTO
  16551. C                                        Temporary window coord storage.
  16552.       REAL WXA,WXB,WYA,WYB, XA,XB,YA,YB
  16553. C                                        Viewport coords of wedge.
  16554.       REAL VXA,VXB,VYA,VYB
  16555. C                          Original and anotation character heights.
  16556.       REAL OLDCH, NEWCH
  16557. C                          Size of unit character height (NDC units).
  16558.       REAL NDCSIZ
  16559. C                          True if wedge plotted horizontally.
  16560.       LOGICAL HORIZ
  16561. C                          Use PGIMAG (T) or PGGRAY (F).
  16562.       LOGICAL IMAGE
  16563. C                          Symbolic version of SIDE.
  16564.       INTEGER NSIDE,BOT,TOP,LFT,RGT
  16565.       PARAMETER (BOT=1,TOP=2,LFT=3,RGT=4)
  16566.       INTEGER I
  16567.       REAL WEDWID, WDGINC, VWIDTH, VDISP, XCH, YCH, LABWID, FG1, BG1
  16568. C                          Set the fraction of WIDTH used for anotation.
  16569.       REAL TXTFRC
  16570.       PARAMETER (TXTFRC=0.6)
  16571. C                          Char separation between numbers and LABEL.
  16572.       REAL TXTSEP
  16573.       PARAMETER (TXTSEP=2.2)
  16574. C                          Array to draw wedge in.
  16575.       INTEGER WDGPIX
  16576.       PARAMETER (WDGPIX=100)
  16577.       REAL WDGARR(WDGPIX)
  16578. C                          Define the coordinate-mapping function.
  16579.       REAL TR(6)
  16580.       SAVE TR
  16581.       DATA TR /0.0,1.0,0.0,0.0,0.0,1.0/
  16582. C-----------------------------------------------------------------------
  16583.       IF(PGNOTO('PGWEDG')) RETURN
  16584. C
  16585. C Get a numeric version of SIDE.
  16586. C
  16587.       IF(SIDE(1:1).EQ.'B' .OR. SIDE(1:1).EQ.'b') THEN
  16588.         NSIDE = BOT
  16589.         HORIZ = .TRUE.
  16590.       ELSE IF(SIDE(1:1).EQ.'T' .OR. SIDE(1:1).EQ.'t') THEN
  16591.         NSIDE = TOP
  16592.         HORIZ = .TRUE.
  16593.       ELSE IF(SIDE(1:1).EQ.'L' .OR. SIDE(1:1).EQ.'l') THEN
  16594.         NSIDE = LFT
  16595.         HORIZ = .FALSE.
  16596.       ELSE IF(SIDE(1:1).EQ.'R' .OR. SIDE(1:1).EQ.'r') THEN
  16597.         NSIDE = RGT
  16598.         HORIZ = .FALSE.
  16599.       ELSE
  16600.         CALL GRWARN('Invalid "SIDE" argument in PGWEDG.')
  16601.         RETURN
  16602.       END IF
  16603. C
  16604. C Determine which routine to use.
  16605. C
  16606.       IF (LEN(SIDE).LT.2) THEN
  16607.          IMAGE = .FALSE.
  16608.       ELSE IF(SIDE(2:2).EQ.'I' .OR. SIDE(2:2).EQ.'i') THEN
  16609.          IMAGE = .TRUE.
  16610.       ELSE IF(SIDE(2:2).EQ.'G' .OR. SIDE(2:2).EQ.'g') THEN
  16611.          IMAGE = .FALSE.
  16612.       ELSE
  16613.          CALL GRWARN('Invalid "SIDE" argument in PGWEDG.')
  16614.       END IF
  16615. C
  16616.       CALL PGBBUF
  16617. C
  16618. C Store the current world and viewport coords and the character height.
  16619. C
  16620.       CALL PGQWIN(WXA, WXB, WYA, WYB)
  16621.       CALL PGQVP(0, XA, XB, YA, YB)
  16622.       CALL PGQCH(OLDCH)
  16623. C
  16624. C Determine the unit character height in NDC coords.
  16625. C
  16626.       CALL PGSCH(1.0)
  16627.       CALL PGQCS(0, XCH, YCH)
  16628.       IF(HORIZ) THEN
  16629.         NDCSIZ = YCH
  16630.       ELSE
  16631.         NDCSIZ = XCH
  16632.       END IF
  16633. C
  16634. C Convert 'WIDTH' and 'DISP' into viewport units.
  16635. C
  16636.       VWIDTH = WIDTH * NDCSIZ * OLDCH
  16637.       VDISP  = DISP * NDCSIZ * OLDCH
  16638. C
  16639. C Determine the number of character heights required under the wedge.
  16640. C
  16641.       LABWID = TXTSEP
  16642.       IF(LABEL.NE.' ') LABWID = LABWID + 1.0
  16643. C
  16644. C Determine and set the character height required to fit the wedge
  16645. C anotation text within the area allowed for it.
  16646. C
  16647.       NEWCH = TXTFRC*VWIDTH / (LABWID*NDCSIZ)
  16648.       CALL PGSCH(NEWCH)
  16649. C
  16650. C Determine the width of the wedge part of the plot minus the anotation.
  16651. C (NDC units).
  16652. C
  16653.       WEDWID = VWIDTH * (1.0-TXTFRC)
  16654. C
  16655. C Use these to determine viewport coordinates for the wedge + annotation.
  16656. C
  16657.       VXA = XA
  16658.       VXB = XB
  16659.       VYA = YA
  16660.       VYB = YB
  16661.       IF(NSIDE.EQ.BOT) THEN
  16662.         VYB = YA - VDISP
  16663.         VYA = VYB - WEDWID
  16664.       ELSE IF(NSIDE.EQ.TOP) THEN
  16665.         VYA = YB + VDISP
  16666.         VYB = VYA + WEDWID
  16667.       ELSE IF(NSIDE.EQ.LFT) THEN
  16668.         VXB = XA - VDISP
  16669.         VXA = VXB - WEDWID
  16670.       ELSE IF(NSIDE.EQ.RGT) THEN
  16671.         VXA = XB + VDISP
  16672.         VXB = VXA + WEDWID
  16673.       END IF
  16674. C
  16675. C Set the viewport for the wedge.
  16676. C
  16677.       CALL PGSVP(VXA, VXB, VYA, VYB)
  16678. C
  16679. C Swap FG/BG if necessary to get axis direction right.
  16680. C
  16681.       FG1 = MAX(FG,BG)
  16682.       BG1 = MIN(FG,BG)
  16683. C
  16684. C Create a dummy wedge array to be plotted.
  16685. C
  16686.       WDGINC = (FG1-BG1)/(WDGPIX-1)
  16687.       DO 1 I=1,WDGPIX
  16688.         WDGARR(I) = BG1 + (I-1) * WDGINC
  16689.  1    CONTINUE
  16690. C
  16691. C Draw the wedge then change the world coordinates for labelling.
  16692. C
  16693.       IF (HORIZ) THEN
  16694.         CALL PGSWIN(1.0, REAL(WDGPIX), 0.9, 1.1)
  16695.         IF (IMAGE) THEN
  16696.            CALL PGIMAG(WDGARR, WDGPIX,1, 1,WDGPIX, 1,1, FG,BG, TR)
  16697.         ELSE
  16698.            CALL PGGRAY(WDGARR, WDGPIX,1, 1,WDGPIX, 1,1, FG,BG, TR)
  16699.         END IF
  16700.         CALL PGSWIN(BG1,FG1,0.0,1.0)
  16701.       ELSE
  16702.         CALL PGSWIN(0.9, 1.1, 1.0, REAL(WDGPIX))
  16703.         IF (IMAGE) THEN
  16704.            CALL PGIMAG(WDGARR, 1,WDGPIX, 1,1, 1,WDGPIX, FG,BG, TR)
  16705.         ELSE
  16706.            CALL PGGRAY(WDGARR, 1,WDGPIX, 1,1, 1,WDGPIX, FG,BG, TR)
  16707.         END IF
  16708.         CALL PGSWIN(0.0, 1.0, BG1, FG1)
  16709.       ENDIF
  16710. C
  16711. C Draw a labelled frame around the wedge.
  16712. C
  16713.       IF(NSIDE.EQ.BOT) THEN
  16714.         CALL PGBOX('BCNST',0.0,0,'BC',0.0,0)
  16715.       ELSE IF(NSIDE.EQ.TOP) THEN
  16716.         CALL PGBOX('BCMST',0.0,0,'BC',0.0,0)
  16717.       ELSE IF(NSIDE.EQ.LFT) THEN
  16718.         CALL PGBOX('BC',0.0,0,'BCNST',0.0,0)
  16719.       ELSE IF(NSIDE.EQ.RGT) THEN
  16720.         CALL PGBOX('BC',0.0,0,'BCMST',0.0,0)
  16721.       ENDIF
  16722. C
  16723. C Write the units label.
  16724. C
  16725.       IF(LABEL.NE.' ') THEN
  16726.         CALL PGMTXT(SIDE,TXTSEP,1.0,1.0,LABEL)
  16727.       END IF
  16728. C
  16729. C Reset the original viewport and world coordinates.
  16730. C
  16731.       CALL PGSVP(XA,XB,YA,YB)
  16732.       CALL PGSWIN(WXA,WXB,WYA,WYB)
  16733.       CALL PGSCH(OLDCH)
  16734.       CALL PGEBUF
  16735.       RETURN
  16736.       END
  16737. C*PGWINDOW -- non-standard alias for PGSWIN
  16738. C+
  16739.       SUBROUTINE PGWINDOW (X1, X2, Y1, Y2)
  16740.       REAL X1, X2, Y1, Y2
  16741. C
  16742. C See description of PGSWIN.
  16743. C--
  16744.       CALL PGSWIN (X1, X2, Y1, Y2)
  16745.       END
  16746. C*PGWNAD -- set window and adjust viewport to same aspect ratio
  16747. C%void cpgwnad(float x1, float x2, float y1, float y2);
  16748. C+
  16749.       SUBROUTINE PGWNAD (X1, X2, Y1, Y2)
  16750.       REAL X1, X2, Y1, Y2
  16751. C
  16752. C Change the window in world coordinate space that is to be mapped on
  16753. C to the viewport, and simultaneously adjust the viewport so that the
  16754. C world-coordinate scales are equal in x and y. The new viewport is
  16755. C the largest one that can fit within the previously set viewport
  16756. C while retaining the required aspect ratio.
  16757. C
  16758. C Arguments:
  16759. C  X1     (input)  : the x-coordinate of the bottom left corner
  16760. C                    of the viewport.
  16761. C  X2     (input)  : the x-coordinate of the top right corner
  16762. C                    of the viewport (note X2 may be less than X1).
  16763. C  Y1     (input)  : the y-coordinate of the bottom left corner
  16764. C                    of the viewport.
  16765. C  Y2     (input)  : the y-coordinate of the top right corner of the
  16766. C                    viewport (note Y2 may be less than Y1).
  16767. C--
  16768. C 25-Sep-1985 - new routine (TJP).
  16769. C 31-May-1989 - correct error: XVP and YVP not set (TJP).
  16770. C-----------------------------------------------------------------------
  16771.       INCLUDE 'f77.PGPLOT/IN'
  16772.       LOGICAL PGNOTO
  16773.       REAL SCALE,OXLEN,OYLEN
  16774. C
  16775.       IF (PGNOTO('PGWNAD')) RETURN
  16776. C
  16777. C If invalid arguments are specified, issue warning and leave window
  16778. C unchanged.
  16779. C
  16780.       IF (X1.EQ.X2) THEN
  16781.          CALL GRWARN('invalid x limits in PGWNAD: X1 = X2.')
  16782.       ELSE IF (Y1.EQ.Y2) THEN
  16783.          CALL GRWARN('invalid y limits in PGWNAD: Y1 = Y2.')
  16784.       ELSE
  16785.          SCALE = MIN(PGXLEN(PGID)/ABS(X2-X1)/PGXPIN(PGID), 
  16786.      1               PGYLEN(PGID)/ABS(Y2-Y1)/PGYPIN(PGID))
  16787.          PGXSCL(PGID) = SCALE*PGXPIN(PGID)
  16788.          PGYSCL(PGID) = SCALE*PGYPIN(PGID)
  16789.          OXLEN = PGXLEN(PGID)
  16790.          OYLEN = PGYLEN(PGID)
  16791.          PGXLEN(PGID) = PGXSCL(PGID)*ABS(X2-X1)
  16792.          PGYLEN(PGID) = PGYSCL(PGID)*ABS(Y2-Y1)
  16793.          PGXVP(PGID)  = PGXVP(PGID) + 0.5*(OXLEN-PGXLEN(PGID))
  16794.          PGYVP(PGID)  = PGYVP(PGID) + 0.5*(OYLEN-PGYLEN(PGID))
  16795.          PGXOFF(PGID) = PGXVP(PGID) + (PGNXC(PGID)-1)*PGXSZ(PGID)
  16796.          PGYOFF(PGID) = PGYVP(PGID) +
  16797.      1                   (PGNY(PGID)-PGNYC(PGID))*PGYSZ(PGID)
  16798.          CALL PGSWIN(X1, X2, Y1, Y2)
  16799.       END IF
  16800.       END
  16801. C
  16802.       INCLUDE 'SYS_ARC.f77.ArcInclude'
  16803.