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