home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / pgplot5.1 / pgplot5 / pgplot5.1.0 / examples-src / pgdemo1.f < prev    next >
Encoding:
Text File  |  1996-05-07  |  30.2 KB  |  1,034 lines
  1.       PROGRAM PGDEM1
  2. C-----------------------------------------------------------------------
  3. C Demonstration program for PGPLOT. The main program opens the output
  4. C device and calls a series of subroutines, one for each sample plot.
  5. C-----------------------------------------------------------------------
  6.       INTEGER PGOPEN
  7. C
  8. C Call PGOPEN to initiate PGPLOT and open the output device; PGOPEN
  9. C will prompt the user to supply the device name and type. Always
  10. C check the return code from PGOPEN.
  11. C
  12.       IF (PGOPEN('?') .LE. 0) STOP
  13. C
  14. C Print information about device.
  15. C
  16.       CALL PGEX0
  17. C
  18. C Call the demonstration subroutines (4,5 are put on one page)
  19. C
  20.       CALL PGEX1
  21.       CALL PGEX2
  22.       CALL PGEX3
  23.       CALL PGSUBP(2,1)
  24.       CALL PGEX4
  25.       CALL PGEX5
  26.       CALL PGSUBP(1,1)
  27.       CALL PGEX6
  28.       CALL PGEX7
  29.       CALL PGEX8
  30.       CALL PGEX9
  31.       CALL PGEX10
  32.       CALL PGEX11
  33.       CALL PGEX12
  34.       CALL PGEX13
  35.       CALL PGEX14
  36.       CALL PGEX15
  37. C
  38. C Finally, call PGCLOS to terminate things properly.
  39. C
  40.       CALL PGCLOS
  41. C-----------------------------------------------------------------------
  42.       END
  43.  
  44.       SUBROUTINE PGEX0
  45. C-----------------------------------------------------------------------
  46. C This subroutine tests PGQINF and displays the information returned on
  47. C the standard output.
  48. C-----------------------------------------------------------------------
  49.       CHARACTER*64 VALUE
  50.       INTEGER LENGTH
  51.       REAL X, Y, X1, X2, Y1, Y2
  52. C
  53. C Information available from PGQINF:
  54. C
  55.       CALL PGQINF('version',  VALUE, LENGTH)
  56.       WRITE (*,*) 'version=', VALUE(:LENGTH)
  57.       CALL PGQINF('state',    VALUE, LENGTH)
  58.       WRITE (*,*) 'state=',   VALUE(:LENGTH)
  59.       CALL PGQINF('user',     VALUE, LENGTH)
  60.       WRITE (*,*) 'user=',    VALUE(:LENGTH)
  61.       CALL PGQINF('now',      VALUE, LENGTH)
  62.       WRITE (*,*) 'now=',     VALUE(:LENGTH)
  63.       CALL PGQINF('device',   VALUE, LENGTH)
  64.       WRITE (*,*) 'device=',  VALUE(:LENGTH)
  65.       CALL PGQINF('file',     VALUE, LENGTH)
  66.       WRITE (*,*) 'file=',    VALUE(:LENGTH)
  67.       CALL PGQINF('type',     VALUE, LENGTH)
  68.       WRITE (*,*) 'type=',    VALUE(:LENGTH)
  69.       CALL PGQINF('dev/type', VALUE, LENGTH)
  70.       WRITE (*,*) 'dev/type=',VALUE(:LENGTH)
  71.       CALL PGQINF('hardcopy', VALUE, LENGTH)
  72.       WRITE (*,*) 'hardcopy=',VALUE(:LENGTH)
  73.       CALL PGQINF('terminal', VALUE, LENGTH)
  74.       WRITE (*,*) 'terminal=',VALUE(:LENGTH)
  75.       CALL PGQINF('cursor',   VALUE, LENGTH)
  76.       WRITE (*,*) 'cursor=',  VALUE(:LENGTH)
  77. C
  78. C Get view surface dimensions:
  79. C
  80.       CALL PGQVSZ(1, X1, X2, Y1, Y2)
  81.       X = X2-X1
  82.       Y = Y2-Y1
  83.       WRITE (*,100) X, Y, X*25.4, Y*25.4
  84.   100 FORMAT (' Plot dimensions (x,y; inches): ',F9.2,', ',F9.2/
  85.      1        '                          (mm): ',F9.2,', ',F9.2)
  86. C-----------------------------------------------------------------------
  87.       END
  88.  
  89.       SUBROUTINE PGEX1
  90. C-----------------------------------------------------------------------
  91. C This example illustrates the use of PGENV, PGLAB, PGPT, PGLINE.
  92. C-----------------------------------------------------------------------
  93.       INTEGER I
  94.       REAL XS(5),YS(5), XR(100), YR(100)
  95.       DATA XS/1.,2.,3.,4.,5./
  96.       DATA YS/1.,4.,9.,16.,25./
  97. C
  98. C Call PGENV to specify the range of the axes and to draw a box, and
  99. C PGLAB to label it. The x-axis runs from 0 to 10, and y from 0 to 20.
  100. C
  101.       CALL PGENV(0.,10.,0.,20.,0,1)
  102.       CALL PGLAB('(x)', '(y)', 'PGPLOT Example 1:  y = x\u2')
  103. C
  104. C Mark five points (coordinates in arrays XS and YS), using symbol
  105. C number 9.
  106. C
  107.       CALL PGPT(5,XS,YS,9)
  108. C
  109. C Compute the function at 60 points, and use PGLINE to draw it.
  110. C
  111.       DO 10 I=1,60
  112.           XR(I) = 0.1*I
  113.           YR(I) = XR(I)**2
  114.    10 CONTINUE
  115.       CALL PGLINE(60,XR,YR)
  116. C-----------------------------------------------------------------------
  117.       END
  118.  
  119.       SUBROUTINE PGEX2
  120. C-----------------------------------------------------------------------
  121. C Repeat the process for another graph. This one is a graph of the
  122. C sinc (sin x over x) function.
  123. C-----------------------------------------------------------------------
  124.       INTEGER I
  125.       REAL XR(100), YR(100)
  126. C
  127.       CALL PGENV(-2.,10.,-0.4,1.2,0,1)
  128.       CALL PGLAB('(x)', 'sin(x)/x', 
  129.      $             'PGPLOT Example 2:  Sinc Function')
  130.       DO 20 I=1,100
  131.           XR(I) = (I-20)/6.
  132.           YR(I) = 1.0
  133.           IF (XR(I).NE.0.0) YR(I) = SIN(XR(I))/XR(I)
  134.    20 CONTINUE
  135.       CALL PGLINE(100,XR,YR)
  136. C-----------------------------------------------------------------------
  137.       END
  138.  
  139.       SUBROUTINE PGEX3
  140. C----------------------------------------------------------------------
  141. C This example illustrates the use of PGBOX and attribute routines to
  142. C mix colors and line-styles.
  143. C----------------------------------------------------------------------
  144.       REAL PI
  145.       PARAMETER (PI=3.14159265)
  146.       INTEGER I
  147.       REAL XR(360), YR(360)
  148.       REAL ARG
  149. C
  150. C Call PGENV to initialize the viewport and window; the
  151. C AXIS argument is -2, so no frame or labels will be drawn.
  152. C
  153.       CALL PGENV(0.,720.,-2.0,2.0,0,-2)
  154.       CALL PGSAVE
  155. C
  156. C Set the color index for the axes and grid (index 5 = cyan).
  157. C Call PGBOX to draw first a grid at low brightness, and then a
  158. C frame and axes at full brightness. Note that as the x-axis is
  159. C to represent an angle in degrees, we request an explicit tick 
  160. C interval of 90 deg with subdivisions at 30 deg, as multiples of
  161. C 3 are a more natural division than the default.
  162. C
  163.       CALL PGSCI(14)
  164.       CALL PGBOX('G',30.0,0,'G',0.2,0)
  165.       CALL PGSCI(5)
  166.       CALL PGBOX('ABCTSN',90.0,3,'ABCTSNV',0.0,0)
  167. C
  168. C Call PGLAB to label the graph in a different color (3=green).
  169. C
  170.       CALL PGSCI(3)
  171.       CALL PGLAB('x (degrees)','f(x)','PGPLOT Example 3')
  172. C
  173. C Compute the function to be plotted: a trig function of an
  174. C angle in degrees, computed every 2 degrees.
  175. C
  176.       DO 20 I=1,360
  177.           XR(I) = 2.0*I
  178.           ARG = XR(I)/180.0*PI
  179.           YR(I) = SIN(ARG) + 0.5*COS(2.0*ARG) + 
  180.      1                0.5*SIN(1.5*ARG+PI/3.0)
  181.    20 CONTINUE
  182. C
  183. C Change the color (6=magenta), line-style (2=dashed), and line
  184. C width and draw the function.
  185. C
  186.       CALL PGSCI(6)
  187.       CALL PGSLS(2)
  188.       CALL PGSLW(3)
  189.       CALL PGLINE(360,XR,YR)
  190. C
  191. C Restore attributes to defaults.
  192. C
  193.       CALL PGUNSA
  194. C-----------------------------------------------------------------------
  195.       END
  196.  
  197.       SUBROUTINE PGEX4
  198. C-----------------------------------------------------------------------
  199. C Demonstration program for PGPLOT: draw histograms.
  200. C-----------------------------------------------------------------------
  201.       INTEGER  I, ISEED
  202.       REAL     DATA(1000), X(620), Y(620)
  203.       REAL     PGRNRM
  204. C
  205. C Call PGRNRM to obtain 1000 samples from a normal distribution.
  206. C
  207.       ISEED = -5678921
  208.       DO 10 I=1,1000
  209.           DATA(I) = PGRNRM(ISEED)
  210.    10 CONTINUE
  211. C
  212. C Draw a histogram of these values.
  213. C
  214.       CALL PGSAVE
  215.       CALL PGHIST(1000,DATA,-3.1,3.1,31,0)
  216. C
  217. C Samples from another normal distribution.
  218. C
  219.       DO 15 I=1,200
  220.           DATA(I) = 1.0+0.5*PGRNRM(ISEED)
  221.    15 CONTINUE
  222. C
  223. C Draw another histogram (filled) on same axes.
  224. C
  225.       CALL PGSCI(15)
  226.       CALL PGHIST(200,DATA,-3.1,3.1,31,3)
  227.       CALL PGSCI(0)
  228.       CALL PGHIST(200,DATA,-3.1,3.1,31,1)
  229.       CALL PGSCI(1)
  230. C
  231. C Redraw the box which may have been clobbered by the histogram.
  232. C
  233.       CALL PGBOX('BST', 0.0, 0, ' ', 0.0, 0)
  234. C
  235. C Label the plot.
  236. C
  237.       CALL PGLAB('Variate', ' ',
  238.      $             'PGPLOT Example 4:  Histograms (Gaussian)')
  239. C
  240. C Superimpose the theoretical distribution.
  241. C
  242.       DO 20 I=1,620
  243.           X(I) = -3.1 + 0.01*(I-1)
  244.           Y(I) = 0.2*1000./SQRT(2.*3.14159265)*EXP(-0.5*X(I)*X(I))
  245.    20 CONTINUE
  246.       CALL PGLINE(620,X,Y)
  247.       CALL PGUNSA
  248. C-----------------------------------------------------------------------
  249.       END
  250.  
  251.       SUBROUTINE PGEX5
  252. C----------------------------------------------------------------------
  253. C Demonstration program for the PGPLOT plotting package.  This example
  254. C illustrates how to draw a log-log plot.
  255. C PGPLOT subroutines demonstrated:
  256. C    PGENV, PGERRY, PGLAB, PGLINE, PGPT, PGSCI.
  257. C----------------------------------------------------------------------
  258.       INTEGER   RED, GREEN, CYAN
  259.       PARAMETER (RED=2)
  260.       PARAMETER (GREEN=3)
  261.       PARAMETER (CYAN=5)
  262.       INTEGER   I
  263.       REAL      X, YLO, YHI
  264.       REAL      FREQ(15), FLUX(15), XP(100), YP(100), ERR(15)
  265.       DATA FREQ / 26., 38., 80., 160., 178., 318.,
  266.      1            365., 408., 750., 1400., 2695., 2700.,
  267.      2            5000., 10695., 14900. /
  268.       DATA FLUX / 38.0, 66.4, 89.0, 69.8, 55.9, 37.4,
  269.      1            46.8, 42.4, 27.0, 15.8, 9.09, 9.17,
  270.      2            5.35, 2.56, 1.73 /
  271.       DATA ERR  / 6.0, 6.0, 13.0, 9.1, 2.9, 1.4,
  272.      1            2.7, 3.0, 0.34, 0.8, 0.2, 0.46,
  273.      2            0.15, 0.08, 0.01 /
  274. C
  275. C Call PGENV to initialize the viewport and window; the AXIS argument 
  276. C is 30 so both axes will be logarithmic. The X-axis (frequency) runs 
  277. C from 0.01 to 100 GHz, the Y-axis (flux density) runs from 0.3 to 300
  278. C Jy. Note that it is necessary to specify the logarithms of these
  279. C quantities in the call to PGENV. We request equal scales in x and y
  280. C so that slopes will be correct.  Use PGLAB to label the graph.
  281. C
  282.       CALL PGSAVE
  283.       CALL PGSCI(CYAN)
  284.       CALL PGENV(-2.0,2.0,-0.5,2.5,1,30)
  285.       CALL PGLAB('Frequency, \gn (GHz)',
  286.      1             'Flux Density, S\d\gn\u (Jy)',
  287.      2             'PGPLOT Example 5:  Log-Log plot')
  288. C
  289. C Draw a fit to the spectrum (don't ask how this was chosen). This 
  290. C curve is drawn before the data points, so that the data will write 
  291. C over the curve, rather than vice versa.
  292. C
  293.       DO 10 I=1,100
  294.           X = 1.3 + I*0.03
  295.           XP(I) = X-3.0
  296.           YP(I) = 5.18 - 1.15*X -7.72*EXP(-X)
  297.    10 CONTINUE
  298.       CALL PGSCI(RED)
  299.       CALL PGLINE(100,XP,YP)
  300. C
  301. C Plot the measured flux densities: here the data are installed with a
  302. C DATA statement; in a more general program, they might be read from a
  303. C file. We first have to take logarithms (the -3.0 converts MHz to GHz).
  304. C
  305.       DO 20 I=1,15
  306.           XP(I) = ALOG10(FREQ(I))-3.0
  307.           YP(I) = ALOG10(FLUX(I))
  308.    20 CONTINUE
  309.       CALL PGSCI(GREEN)
  310.       CALL PGPT(15, XP, YP, 17)
  311. C
  312. C Draw +/- 2 sigma error bars: take logs of both limits.
  313. C
  314.       DO 30 I=1,15
  315.           YHI = ALOG10(FLUX(I)+2.*ERR(I))
  316.           YLO = ALOG10(FLUX(I)-2.*ERR(I))
  317.           CALL PGERRY(1,XP(I),YLO,YHI,1.0)
  318.    30 CONTINUE
  319.       CALL PGUNSA
  320. C-----------------------------------------------------------------------
  321.       END
  322.  
  323.       SUBROUTINE PGEX6
  324. C----------------------------------------------------------------------
  325. C Demonstration program for the PGPLOT plotting package.  This example
  326. C illustrates the use of PGPOLY, PGCIRC, and PGRECT using SOLID, 
  327. C OUTLINE, HATCHED, and CROSS-HATCHED fill-area attributes.
  328. C----------------------------------------------------------------------
  329.       REAL TWOPI
  330.       PARAMETER (TWOPI=2.0*3.14159265)
  331.       INTEGER NPOL
  332.       PARAMETER (NPOL=6)
  333.       INTEGER I, J, N1(NPOL), N2(NPOL), K
  334.       REAL X(10), Y(10), Y0, ANGLE
  335.       CHARACTER*32 LAB(4)
  336.       DATA N1 / 3, 4, 5, 5, 6, 8 /
  337.       DATA N2 / 1, 1, 1, 2, 1, 3 /
  338.       DATA LAB(1) /'Fill style 1 (solid)'/
  339.       DATA LAB(2) /'Fill style 2 (outline)'/
  340.       DATA LAB(3) /'Fill style 3 (hatched)'/
  341.       DATA LAB(4) /'Fill style 4 (cross-hatched)'/
  342. C
  343. C Initialize the viewport and window.
  344. C
  345.       CALL PGBBUF
  346.       CALL PGSAVE
  347.       CALL PGPAGE
  348.       CALL PGSVP(0.0, 1.0, 0.0, 1.0)
  349.       CALL PGWNAD(0.0, 10.0, 0.0, 10.0)
  350. C
  351. C Label the graph.
  352. C
  353.       CALL PGSCI(1)
  354.       CALL PGMTXT('T', -2.0, 0.5, 0.5, 
  355.      :     'PGPLOT fill area: routines PGPOLY, PGCIRC, PGRECT')
  356. C
  357. C Draw assorted polygons.
  358. C
  359.       DO 30 K=1,4
  360.          CALL PGSCI(1)
  361.          Y0 = 10.0 - 2.0*K
  362.          CALL PGTEXT(0.2, Y0+0.6, LAB(K))
  363.          CALL PGSFS(K)
  364.          DO 20 I=1,NPOL
  365.             CALL PGSCI(I)
  366.             DO 10 J=1,N1(I)
  367.                ANGLE = REAL(N2(I))*TWOPI*REAL(J-1)/REAL(N1(I))
  368.                X(J) = I + 0.5*COS(ANGLE)
  369.                Y(J) = Y0 + 0.5*SIN(ANGLE)
  370.  10         CONTINUE
  371.             CALL PGPOLY (N1(I),X,Y)
  372.  20      CONTINUE
  373.          CALL PGSCI(7)
  374.          CALL PGCIRC(7.0, Y0, 0.5)
  375.          CALL PGSCI(8)
  376.          CALL PGRECT(7.8, 9.5, Y0-0.5, Y0+0.5)
  377.  30   CONTINUE
  378. C
  379.       CALL PGUNSA
  380.       CALL PGEBUF
  381. C-----------------------------------------------------------------------
  382.       END
  383.  
  384.       SUBROUTINE PGEX7
  385. C-----------------------------------------------------------------------
  386. C A plot with a large number of symbols; plus test of PGERRB.
  387. C-----------------------------------------------------------------------
  388.       INTEGER I, ISEED
  389.       REAL XS(300),YS(300), XR(101), YR(101), XP, YP, XSIG, YSIG
  390.       REAL PGRAND, PGRNRM
  391. C
  392. C Window and axes.
  393. C
  394.       CALL PGBBUF
  395.       CALL PGSAVE
  396.       CALL PGSCI(1)
  397.       CALL PGENV(0.,5.,-0.3,0.6,0,1)
  398.       CALL PGLAB('\fix', '\fiy', 'PGPLOT Example 7: scatter plot')
  399. C
  400. C Random data points.
  401. C
  402.       ISEED = -45678921
  403.       DO 10 I=1,300
  404.           XS(I) = 5.0*PGRAND(ISEED)
  405.           YS(I) = XS(I)*EXP(-XS(I)) + 0.05*PGRNRM(ISEED)
  406.    10 CONTINUE
  407.       CALL PGSCI(3)
  408.       CALL PGPT(100,XS,YS,3)
  409.       CALL PGPT(100,XS(101),YS(101),17)
  410.       CALL PGPT(100,XS(201),YS(201),21)
  411. C
  412. C Curve defining parent distribution.
  413. C
  414.       DO 20 I=1,101
  415.           XR(I) = 0.05*(I-1)
  416.           YR(I) = XR(I)*EXP(-XR(I))
  417.    20 CONTINUE
  418.       CALL PGSCI(2)
  419.       CALL PGLINE(101,XR,YR)
  420. C
  421. C Test of PGERRB.
  422. C
  423.       XP = XS(101)
  424.       YP = YS(101)
  425.       XSIG = 0.2
  426.       YSIG = 0.1
  427.       CALL PGSCI(5)
  428.       CALL PGSCH(3.0)
  429.       CALL PGERRB(5, 1, XP, YP, XSIG, 1.0)
  430.       CALL PGERRB(6, 1, XP, YP, YSIG, 1.0)
  431.       CALL PGPT(1,XP,YP,21)
  432. C
  433.       CALL PGUNSA
  434.       CALL PGEBUF
  435. C-----------------------------------------------------------------------
  436.       END
  437.  
  438.       SUBROUTINE PGEX8
  439. C-----------------------------------------------------------------------
  440. C Demonstration program for PGPLOT. This program shows some of the
  441. C possibilities for overlapping windows and viewports.
  442. C T. J. Pearson  1986 Nov 28
  443. C-----------------------------------------------------------------------
  444.       INTEGER I
  445.       REAL XR(720), YR(720)
  446. C-----------------------------------------------------------------------
  447. C Color index:
  448.       INTEGER BLACK, WHITE, RED, GREEN, BLUE, CYAN, MAGENT, YELLOW
  449.       PARAMETER (BLACK=0)
  450.       PARAMETER (WHITE=1)
  451.       PARAMETER (RED=2)
  452.       PARAMETER (GREEN=3)
  453.       PARAMETER (BLUE=4)
  454.       PARAMETER (CYAN=5)
  455.       PARAMETER (MAGENT=6)
  456.       PARAMETER (YELLOW=7)
  457. C Line style:
  458.       INTEGER FULL, DASHED, DOTDSH, DOTTED, FANCY
  459.       PARAMETER (FULL=1)
  460.       PARAMETER (DASHED=2)
  461.       PARAMETER (DOTDSH=3)
  462.       PARAMETER (DOTTED=4)
  463.       PARAMETER (FANCY=5)
  464. C Character font:
  465.       INTEGER NORMAL, ROMAN, ITALIC, SCRIPT
  466.       PARAMETER (NORMAL=1)
  467.       PARAMETER (ROMAN=2)
  468.       PARAMETER (ITALIC=3)
  469.       PARAMETER (SCRIPT=4)
  470. C Fill-area style:
  471.       INTEGER SOLID, HOLLOW
  472.       PARAMETER (SOLID=1)
  473.       PARAMETER (HOLLOW=2)
  474. C-----------------------------------------------------------------------
  475. C
  476.       CALL PGPAGE
  477.       CALL PGBBUF
  478.       CALL PGSAVE
  479. C
  480. C Define the Viewport
  481. C
  482.       CALL PGSVP(0.1,0.6,0.1,0.6)
  483. C
  484. C Define the Window
  485. C
  486.       CALL PGSWIN(0.0, 630.0, -2.0, 2.0)
  487. C
  488. C Draw a box
  489. C
  490.       CALL PGSCI(CYAN)
  491.       CALL PGBOX ('ABCTS', 90.0, 3, 'ABCTSV', 0.0, 0)
  492. C
  493. C Draw labels
  494. C
  495.       CALL PGSCI (RED)
  496.       CALL PGBOX ('N',90.0, 3, 'VN', 0.0, 0)
  497. C
  498. C Draw SIN line
  499. C
  500.       DO 10 I=1,360
  501.           XR(I) = 2.0*I
  502.           YR(I) = SIN(XR(I)/57.29577951)
  503.    10 CONTINUE
  504.       CALL PGSCI (MAGENT)
  505.       CALL PGSLS (DASHED)
  506.       CALL PGLINE (360,XR,YR)
  507. C
  508. C Draw COS line by redefining the window
  509. C
  510.       CALL PGSWIN (90.0, 720.0, -2.0, 2.0)
  511.       CALL PGSCI (YELLOW)
  512.       CALL PGSLS (DOTTED)
  513.       CALL PGLINE (360,XR,YR)
  514.       CALL PGSLS (FULL)
  515. C
  516. C Re-Define the Viewport
  517. C
  518.       CALL PGSVP(0.45,0.85,0.45,0.85)
  519. C
  520. C Define the Window, and erase it
  521. C
  522.       CALL PGSWIN(0.0, 180.0, -2.0, 2.0)
  523.       CALL PGSCI(0)
  524.       CALL PGRECT(0.0, 180., -2.0, 2.0)
  525. C
  526. C Draw a box
  527. C
  528.       CALL PGSCI(BLUE)
  529.       CALL PGBOX ('ABCTSM', 60.0, 3, 'VABCTSM', 1.0, 2)
  530. C
  531. C Draw SIN line
  532. C
  533.       CALL PGSCI (WHITE)
  534.       CALL PGSLS (DASHED)
  535.       CALL PGLINE (360,XR,YR)
  536. C
  537.       CALL PGUNSA
  538.       CALL PGEBUF
  539. C-----------------------------------------------------------------------
  540.       END
  541.  
  542.       SUBROUTINE PGEX9
  543. C----------------------------------------------------------------------
  544. C Demonstration program for the PGPLOT plotting package.  This example
  545. C illustrates curve drawing with PGFUNT; the parametric curve drawn is
  546. C a simple Lissajous figure.
  547. C                              T. J. Pearson  1983 Oct 5
  548. C----------------------------------------------------------------------
  549.       REAL     FX, FY
  550.       EXTERNAL FX, FY
  551. C
  552. C Call PGFUNT to draw the function (autoscaling).
  553. C
  554.       CALL PGBBUF
  555.       CALL PGSAVE
  556.       CALL PGSCI(5)
  557.       CALL PGFUNT(FX,FY,360,0.0,2.0*3.14159265,0)
  558. C
  559. C Call PGLAB to label the graph in a different color.
  560. C
  561.       CALL PGSCI(3)
  562.       CALL PGLAB('x','y','PGPLOT Example 9:  routine PGFUNT')
  563.       CALL PGUNSA
  564.       CALL PGEBUF
  565. C
  566.       END
  567.  
  568.       REAL FUNCTION FX(T)
  569.       REAL T
  570.       FX = SIN(T*5.0)
  571.       RETURN
  572.       END
  573.  
  574.       REAL FUNCTION FY(T)
  575.       REAL T
  576.       FY = SIN(T*4.0)
  577.       RETURN
  578.       END
  579.  
  580.       SUBROUTINE PGEX10
  581. C----------------------------------------------------------------------
  582. C Demonstration program for the PGPLOT plotting package.  This example
  583. C illustrates curve drawing with PGFUNX.
  584. C                              T. J. Pearson  1983 Oct 5
  585. C----------------------------------------------------------------------
  586. C The following define mnemonic names for the color indices and
  587. C linestyle codes.
  588.       INTEGER   BLACK, WHITE, RED, GREEN, BLUE, CYAN, MAGENT, YELLOW
  589.       PARAMETER (BLACK=0)
  590.       PARAMETER (WHITE=1)
  591.       PARAMETER (RED=2)
  592.       PARAMETER (GREEN=3)
  593.       PARAMETER (BLUE=4)
  594.       PARAMETER (CYAN=5)
  595.       PARAMETER (MAGENT=6)
  596.       PARAMETER (YELLOW=7)
  597.       INTEGER   FULL, DASH, DOTD
  598.       PARAMETER (FULL=1)
  599.       PARAMETER (DASH=2)
  600.       PARAMETER (DOTD=3)
  601. C
  602. C The Fortran functions to be plotted must be declared EXTERNAL.
  603. C
  604.       REAL     PGBSJ0, PGBSJ1
  605.       EXTERNAL PGBSJ0, PGBSJ1
  606. C
  607. C Call PGFUNX twice to draw two functions (autoscaling the first time).
  608. C
  609.       CALL PGBBUF
  610.       CALL PGSAVE
  611.       CALL PGSCI(YELLOW)
  612.       CALL PGFUNX(PGBSJ0,500,0.0,10.0*3.14159265,0)
  613.       CALL PGSCI(RED)
  614.       CALL PGSLS(DASH)
  615.       CALL PGFUNX(PGBSJ1,500,0.0,10.0*3.14159265,1)
  616. C
  617. C Call PGLAB to label the graph in a different color. Note the
  618. C use of "\f" to change font.  Use PGMTXT to write an additional
  619. C legend inside the viewport.
  620. C
  621.       CALL PGSCI(GREEN)
  622.       CALL PGSLS(FULL)
  623.       CALL PGLAB('\fix', '\fiy',
  624.      2           '\frPGPLOT Example 10: routine PGFUNX')
  625.       CALL PGMTXT('T', -4.0, 0.5, 0.5,
  626.      1     '\frBessel Functions')
  627. C
  628. C Call PGARRO to label the curves.
  629. C
  630.       CALL PGARRO(8.0, 0.7, 1.0, PGBSJ0(1.0))
  631.       CALL PGARRO(12.0, 0.5, 9.0, PGBSJ1(9.0))
  632.       CALL PGSTBG(GREEN)
  633.       CALL PGSCI(0)
  634.       CALL PGPTXT(8.0, 0.7, 0.0, 0.0, ' \fiy = J\d0\u(x)')
  635.       CALL PGPTXT(12.0, 0.5, 0.0, 0.0, ' \fiy = J\d1\u(x)')
  636.       CALL PGUNSA
  637.       CALL PGEBUF
  638. C-----------------------------------------------------------------------
  639.       END
  640.  
  641.       SUBROUTINE PGEX11
  642. C-----------------------------------------------------------------------
  643. C Test routine for PGPLOT: draws a skeletal dodecahedron.
  644. C-----------------------------------------------------------------------
  645.       INTEGER NVERT
  646.       REAL T, T1, T2, T3
  647.       PARAMETER (NVERT=20)
  648.       PARAMETER (T=1.618)
  649.       PARAMETER (T1=1.0+T)
  650.       PARAMETER (T2=-1.0*T)
  651.       PARAMETER (T3=-1.0*T1)
  652.       INTEGER I, J, K
  653.       REAL VERT(3,NVERT), R, ZZ
  654.       REAL X(2),Y(2)
  655. C
  656. C Cartesian coordinates of the 20 vertices.
  657. C
  658.       DATA VERT/ T, T, T,       T, T,T2,
  659.      3           T,T2, T,       T,T2,T2,
  660.      5          T2, T, T,      T2, T,T2,
  661.      7          T2,T2, T,      T2,T2,T2,
  662.      9          T1,1.0,0.0,    T1,-1.0,0.0,
  663.      B          T3,1.0,0.0,    T3,-1.0,0.0,
  664.      D          0.0,T1,1.0,    0.0,T1,-1.0,
  665.      F          0.0,T3,1.0,    0.0,T3,-1.0,
  666.      H          1.0,0.0,T1,    -1.0,0.0,T1,
  667.      J          1.0,0.0,T3,   -1.0,0.0,T3 /
  668. C
  669. C Initialize the plot (no labels).
  670. C
  671.       CALL PGBBUF
  672.       CALL PGSAVE
  673.       CALL PGENV(-4.,4.,-4.,4.,1,-2)
  674.       CALL PGSCI(2)
  675.       CALL PGSLS(1)
  676.       CALL PGSLW(1)
  677. C
  678. C Write a heading.
  679. C
  680.       CALL PGLAB(' ',' ','PGPLOT Example 11:  Dodecahedron')
  681. C
  682. C Mark the vertices.
  683. C
  684.       DO 2 I=1,NVERT
  685.           ZZ = VERT(3,I)
  686.           CALL PGPT(1,VERT(1,I)+0.2*ZZ,VERT(2,I)+0.3*ZZ,9)
  687.     2 CONTINUE
  688. C
  689. C Draw the edges - test all vertex pairs to find the edges of the 
  690. C correct length.
  691. C
  692.       CALL PGSLW(3)
  693.       DO 20 I=2,NVERT
  694.           DO 10 J=1,I-1
  695.               R = 0.
  696.               DO 5 K=1,3
  697.                   R = R + (VERT(K,I)-VERT(K,J))**2
  698.     5         CONTINUE
  699.               R = SQRT(R)
  700.               IF(ABS(R-2.0).GT.0.1) GOTO 10
  701.               ZZ = VERT(3,I)
  702.               X(1) = VERT(1,I)+0.2*ZZ
  703.               Y(1) = VERT(2,I)+0.3*ZZ
  704.               ZZ = VERT(3,J)
  705.               X(2) = VERT(1,J)+0.2*ZZ
  706.               Y(2) = VERT(2,J)+0.3*ZZ
  707.               CALL PGLINE(2,X,Y)
  708.    10     CONTINUE
  709.    20 CONTINUE
  710.       CALL PGUNSA
  711.       CALL PGEBUF
  712. C-----------------------------------------------------------------------
  713.       END
  714.  
  715.       SUBROUTINE PGEX12
  716. C-----------------------------------------------------------------------
  717. C Test routine for PGPLOT: draw arrows with PGARRO.
  718. C-----------------------------------------------------------------------
  719.       INTEGER NV, I, K
  720.       REAL A, D, X, Y, XT, YT
  721. C
  722. C Number of arrows.
  723. C
  724.       NV =16
  725. C
  726. C Select a square viewport.
  727. C
  728.       CALL PGBBUF
  729.       CALL PGSAVE
  730.       CALL PGSCH(0.7)
  731.       CALL PGSCI(2)
  732.       CALL PGENV(-1.05,1.05,-1.05,1.05,1,-1)
  733.       CALL PGLAB(' ', ' ', 'PGPLOT Example 12: PGARRO')
  734.       CALL PGSCI(1)
  735. C
  736. C Draw the arrows
  737. C
  738.       K = 1
  739.       D = 360.0/57.29577951/NV
  740.       A = -D
  741.       DO 20 I=1,NV
  742.           A = A+D
  743.           X = COS(A)
  744.           Y = SIN(A)
  745.           XT = 0.2*COS(A-D)
  746.           YT = 0.2*SIN(A-D)
  747.           CALL PGSAH(K, 80.0-3.0*I, 0.5*REAL(I)/REAL(NV))
  748.           CALL PGSCH(0.25*I)
  749.           CALL PGARRO(XT, YT, X, Y)
  750.           K = K+1
  751.           IF (K.GT.2) K=1
  752.    20 CONTINUE
  753. C
  754.       CALL PGUNSA
  755.       CALL PGEBUF
  756. C-----------------------------------------------------------------------
  757.       END
  758.  
  759.       SUBROUTINE PGEX13
  760. C----------------------------------------------------------------------
  761. C This example illustrates the use of PGTBOX.
  762. C----------------------------------------------------------------------
  763.       INTEGER N
  764.       PARAMETER (N=10)
  765.       INTEGER I
  766.       REAL X1(N), X2(N)
  767.       CHARACTER*20 XOPT(N), BSL*1
  768.       DATA X1 /   4*0.0, -8000.0, 100.3, 205.3, -45000.0, 2*0.0/
  769.       DATA X2 /4*8000.0,  8000.0, 101.3, 201.1, 3*-100000.0/
  770.       DATA XOPT / 'BSTN', 'BSTNZ', 'BSTNZH', 'BSTNZD', 'BSNTZHFO', 
  771.      :      'BSTNZD', 'BSTNZHI', 'BSTNZHP', 'BSTNZDY', 'BSNTZHFOY'/
  772. C
  773.       BSL = CHAR(92)
  774.       CALL PGPAGE
  775.       CALL PGSAVE
  776.       CALL PGBBUF
  777.       CALL PGSCH(0.7)
  778.       DO 100 I=1,N
  779.         CALL PGSVP(0.15, 0.85, (0.7+REAL(N-I))/REAL(N), 
  780.      :                         (0.7+REAL(N-I+1))/REAL(N)) 
  781.         CALL PGSWIN(X1(I), X2(I), 0.0, 1.0)
  782.         CALL PGTBOX(XOPT(I),0.0,0,' ',0.0,0)
  783.         CALL PGLAB('Option = '//XOPT(I), ' ', ' ')
  784.         IF (I.EQ.1) THEN
  785.            CALL PGMTXT('B', -1.0, 0.5, 0.5, 
  786.      :                 BSL//'fiAxes drawn with PGTBOX')
  787.         END IF
  788.   100 CONTINUE
  789.       CALL PGEBUF
  790.       CALL PGUNSA
  791. C-----------------------------------------------------------------------
  792.       END
  793.  
  794.       SUBROUTINE PGEX14
  795. C-----------------------------------------------------------------------
  796. C Test routine for PGPLOT: polygon fill and color representation.
  797. C-----------------------------------------------------------------------
  798.       INTEGER I, J, N, M
  799.       REAL PI, THINC, R, G, B, THETA
  800.       REAL XI(100),YI(100),XO(100),YO(100),XT(3),YT(3)
  801. C
  802.       PI = ACOS(-1.0)
  803.       N = 33
  804.       M = 8
  805.       THINC=2.0*PI/N
  806.       DO 10 I=1,N
  807.         XI(I) = 0.0
  808.         YI(I) = 0.0
  809.    10 CONTINUE
  810.       CALL PGBBUF
  811.       CALL PGSAVE
  812.       CALL PGENV(-1.,1.,-1.,1.,1,-2)
  813.       CALL PGLAB(' ', ' ', 'PGPLOT Example 14: PGPOLY and PGSCR')
  814.       DO 50 J=1,M
  815.         R = 1.0
  816.         G = 1.0 - REAL(J)/REAL(M)
  817.         B = G
  818.         CALL PGSCR(J, R, G, B)
  819.         THETA = -REAL(J)*PI/REAL(N)
  820.         R = REAL(J)/REAL(M)
  821.         DO 20 I=1,N
  822.           THETA = THETA+THINC
  823.           XO(I) = R*COS(THETA)
  824.           YO(I) = R*SIN(THETA)
  825.    20   CONTINUE
  826.         DO 30 I=1,N
  827.           XT(1) = XO(I)
  828.           YT(1) = YO(I)
  829.           XT(2) = XO(MOD(I,N)+1)
  830.           YT(2) = YO(MOD(I,N)+1)
  831.           XT(3) = XI(I)
  832.           YT(3) = YI(I)
  833.           CALL PGSCI(J)
  834.           CALL PGSFS(1)
  835.           CALL PGPOLY(3,XT,YT)
  836.           CALL PGSFS(2)
  837.           CALL PGSCI(1)
  838.           CALL PGPOLY(3,XT,YT)
  839.    30   CONTINUE
  840.         DO 40 I=1,N
  841.           XI(I) = XO(I)
  842.           YI(I) = YO(I)
  843.    40   CONTINUE
  844.    50 CONTINUE
  845.       CALL PGUNSA
  846.       CALL PGEBUF
  847. C-----------------------------------------------------------------------
  848.       END
  849.  
  850.       SUBROUTINE PGEX15
  851. C----------------------------------------------------------------------
  852. C This is a line-drawing test; it draws a regular n-gon joining
  853. C each vertex to every other vertex. It is not optimized for pen
  854. C plotters.
  855. C----------------------------------------------------------------------
  856.       INTEGER I, J, NV
  857.       REAL A, D, X(100), Y(100)
  858. C
  859. C Set the number of vertices, and compute the 
  860. C coordinates for unit circumradius.
  861. C
  862.       NV = 17
  863.       D = 360.0/NV
  864.       A = -D
  865.       DO 20 I=1,NV
  866.           A = A+D
  867.           X(I) = COS(A/57.29577951)
  868.           Y(I) = SIN(A/57.29577951)
  869.    20 CONTINUE
  870. C
  871. C Select a square viewport.
  872. C
  873.       CALL PGBBUF
  874.       CALL PGSAVE
  875.       CALL PGSCH(0.5)
  876.       CALL PGSCI(2)
  877.       CALL PGENV(-1.05,1.05,-1.05,1.05,1,-1)
  878.       CALL PGLAB(' ', ' ', 'PGPLOT Example 15: PGMOVE and PGDRAW')
  879.       CALL PGSCR(0,0.2,0.3,0.3)
  880.       CALL PGSCR(1,1.0,0.5,0.2)
  881.       CALL PGSCR(2,0.2,0.5,1.0)
  882.       CALL PGSCI(1)
  883. C
  884. C Draw the polygon.
  885. C
  886.       DO 40 I=1,NV-1
  887.           DO 30 J=I+1,NV
  888.             CALL PGMOVE(X(I),Y(I))
  889.             CALL PGDRAW(X(J),Y(J))
  890.    30     CONTINUE
  891.    40 CONTINUE
  892. C
  893. C Flush the buffer.
  894. C
  895.       CALL PGUNSA
  896.       CALL PGEBUF
  897. C-----------------------------------------------------------------------
  898.       END
  899.  
  900.       REAL FUNCTION PGBSJ0(XX)
  901.       REAL XX
  902. C-----------------------------------------------------------------------
  903. C Bessel function of order 0 (approximate).
  904. C Reference: Abramowitz and Stegun: Handbook of Mathematical Functions.
  905. C-----------------------------------------------------------------------
  906.       REAL X, XO3, T, F0, THETA0
  907. C     
  908.       X = ABS(XX)
  909.       IF (X .LE. 3.0) THEN
  910.          XO3 = X/3.0
  911.          T   = XO3*XO3
  912.          PGBSJ0 = 1.0 + T*(-2.2499997 +
  913.      1                  T*( 1.2656208 +
  914.      2                  T*(-0.3163866 +
  915.      3                  T*( 0.0444479 +
  916.      4                  T*(-0.0039444 +
  917.      5                  T*( 0.0002100))))))
  918.       ELSE
  919.          T = 3.0/X
  920.          F0 =     0.79788456 +
  921.      1        T*(-0.00000077 + 
  922.      2        T*(-0.00552740 +
  923.      3        T*(-0.00009512 +
  924.      4        T*( 0.00137237 +
  925.      5        T*(-0.00072805 +
  926.      6        T*( 0.00014476))))))
  927.          THETA0 = X - 0.78539816 +
  928.      1            T*(-0.04166397 +
  929.      2            T*(-0.00003954 +
  930.      3            T*( 0.00262573 +
  931.      4            T*(-0.00054125 +
  932.      5            T*(-0.00029333 +
  933.      6            T*( 0.00013558))))))
  934.          PGBSJ0 = F0*COS(THETA0)/SQRT(X)
  935.       END IF
  936. C-----------------------------------------------------------------------
  937.       END
  938.  
  939.       REAL FUNCTION PGBSJ1(XX)
  940.       REAL XX
  941. C-----------------------------------------------------------------------
  942. C Bessel function of order 1 (approximate).
  943. C Reference: Abramowitz and Stegun: Handbook of Mathematical Functions.
  944. C-----------------------------------------------------------------------
  945.       REAL X, XO3, T, F1, THETA1
  946. C
  947.       X = ABS(XX)
  948.       IF (X .LE. 3.0) THEN
  949.          XO3 = X/3.0
  950.          T = XO3*XO3
  951.          PGBSJ1 = 0.5 + T*(-0.56249985 +
  952.      1                  T*( 0.21093573 +
  953.      2                  T*(-0.03954289 +
  954.      3                  T*( 0.00443319 +
  955.      4                  T*(-0.00031761 +
  956.      5                  T*( 0.00001109))))))
  957.          PGBSJ1 = PGBSJ1*XX
  958.       ELSE
  959.          T = 3.0/X
  960.          F1 =    0.79788456 +
  961.      1       T*( 0.00000156 +
  962.      2       T*( 0.01659667 + 
  963.      3       T*( 0.00017105 +
  964.      4       T*(-0.00249511 +
  965.      5       T*( 0.00113653 + 
  966.      6       T*(-0.00020033))))))
  967.          THETA1 = X   -2.35619449 + 
  968.      1             T*( 0.12499612 +
  969.      2             T*( 0.00005650 +
  970.      3             T*(-0.00637879 +
  971.      4             T*( 0.00074348 +
  972.      5             T*( 0.00079824 +
  973.      6             T*(-0.00029166))))))
  974.          PGBSJ1 = F1*COS(THETA1)/SQRT(X)
  975.       END IF
  976.       IF (XX .LT. 0.0) PGBSJ1 = -PGBSJ1
  977. C-----------------------------------------------------------------------
  978.       END
  979.  
  980.       REAL FUNCTION PGRNRM (ISEED)
  981.       INTEGER ISEED
  982. C-----------------------------------------------------------------------
  983. C Returns a normally distributed deviate with zero mean and unit 
  984. C variance. The routine uses the Box-Muller transformation of uniform
  985. C deviates. For a more efficient implementation of this algorithm,
  986. C see Press et al., Numerical Recipes, Sec. 7.2.
  987. C
  988. C Arguments:
  989. C  ISEED  (in/out) : seed used for PGRAND random-number generator.
  990. C
  991. C Subroutines required:
  992. C  PGRAND -- return a uniform random deviate between 0 and 1.
  993. C
  994. C History:
  995. C  1995 Dec 12 - TJP.
  996. C-----------------------------------------------------------------------
  997.       REAL R, X, Y, PGRAND
  998. C
  999.  10   X = 2.0*PGRAND(ISEED) - 1.0
  1000.       Y = 2.0*PGRAND(ISEED) - 1.0
  1001.       R = X**2 + Y**2
  1002.       IF (R.GE.1.0) GOTO 10
  1003.       PGRNRM = X*SQRT(-2.0*LOG(R)/R)
  1004. C-----------------------------------------------------------------------
  1005.       END
  1006.  
  1007.       REAL FUNCTION PGRAND(ISEED)
  1008.       INTEGER ISEED
  1009. C-----------------------------------------------------------------------
  1010. C Returns a uniform random deviate between 0.0 and 1.0.
  1011. C
  1012. C NOTE: this is not a good random-number generator; it is only
  1013. C intended for exercising the PGPLOT routines.
  1014. C
  1015. C Based on: Park and Miller's "Minimal Standard" random number
  1016. C   generator (Comm. ACM, 31, 1192, 1988)
  1017. C
  1018. C Arguments:
  1019. C  ISEED  (in/out) : seed.
  1020. C-----------------------------------------------------------------------
  1021.       INTEGER   IM, IA, IQ, IR
  1022.       PARAMETER (IM=2147483647)
  1023.       PARAMETER (IA=16807, IQ=127773, IR= 2836)
  1024.       REAL      AM
  1025.       PARAMETER (AM=128.0/IM)
  1026.       INTEGER   K
  1027. C-
  1028.       K = ISEED/IQ
  1029.       ISEED = IA*(ISEED-K*IQ) - IR*K
  1030.       IF (ISEED.LT.0) ISEED = ISEED+IM
  1031.       PGRAND = AM*(ISEED/128)
  1032.       RETURN
  1033.       END
  1034.