home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d4xx / d499 / diglib.lha / Diglib / diglib.lzh / source / POLAR.for < prev    next >
Encoding:
Text File  |  1991-05-22  |  9.3 KB  |  348 lines
  1.       SUBROUTINE POLAR(RADIAL,RR,THETA,DATA,MODE,NUM,ISYMNO,SYMSIZ,
  2.      1                  NPBSYM,PLTLAB)
  3. C
  4. C  POLAR PLOT SUBROUTINE FOR DIGLIB
  5. C
  6. C  AUTHOR: JIM LOCKER, SOFTECH INC.
  7. C          MAY 1989
  8. C
  9. C  POLAR ACCEPTS DATA IN THE FOLLOWING MODES;
  10. C
  11. C  MODE(1) CONTROLS THE TYPE OF DATA AND WHETHER OR NOT AXES/RANGE
  12. C  RINGS ARE DRAWN
  13. C
  14. C  MODE(1)= 1 IS R-THETA INFORMATION AND THE PLOT IS TYPE REAL
  15. C
  16. C  MODE(1)= 2 IS REAL-IMAGINARY TYPE INFORMATION AND THE PLOT REPRESENTS
  17. C  A COMPLEX PLANE PLOT
  18. C
  19. C  IF MODE(1)= 1, RR IS AN ARRAY OF RADIAL INFORMATION
  20. C  AND THETA IS AN ARRAY OF ANGULAR INFORMATION CORRESPONDING
  21. C  TO THE RADIAL INFORMATION
  22. C
  23. C  IF MODE(1)= 2, RR IS THE REAL DATA
  24. C  AND THETA IS THE IMAGINARY DATA SO THAT THE DATA SET IS OF THE
  25. C  FORM X+IY
  26. C
  27. C  MODE(1) = 3 IS LIKE MODE(1) = 1 EXCEPT NO AXES OR RANGE RINGS ARE DRAWN
  28. C  MODE(1) = 4 IS LIKE MODE(1) = 2 EXCEPT NO AXES OR RANGE RINGS.
  29. C
  30. C  MODE(2) CONTROLS THE SCALE OF THE PLOT
  31. C
  32. C  MODE(2) = 1 INDICATES A LINEAR RADIAL SCALE
  33. C
  34. C  MODE(2) = 2 INDICATES A LOGARITHMIC RADIAL SCALE
  35. C
  36. C  MODE(3) TELLS THE NUMBER OF RANGE RINGS TO DRAW.  IN LINEAR RADIAL
  37. C  MODE, THIS IS THE NUMBER THAT WILL BE DRAWN.  IN LOGARITHMIC MODE,
  38. C  THIS IS THE NUMBER THAT WILL BE DRAWN PER DECADE.
  39. C
  40. C  MODE(4) DICTATES THE STYLE OF THE LINE FOR RANGE RINGS, FOLLOWING
  41. C  DIGLIB CONVENTION.
  42. C
  43. C  MODE(5) TELLS WHETHER OR NOT RADIAL TICK MARKS ARE TO BE USED.  IF
  44. C  MODE(5) = 0, NO RADIAL TICK MARKS.  IF MODE(5) .GT. 0, THEN OUTWARD
  45. C  POINTING TICKS AT DEGREE INCREMENTS SPECIFIED BY THE VALUE IN MODE(5)
  46. C  IF MODE(5) .LT. 0, THEN INWARD POINTING TICKS.
  47. C
  48. C  MODE(6) SPECIFIES THE COLOR OF THE AXES, RANGE RINGS, AND TICK MARKS
  49. C  MODE(7) SPECIFIES THE COLOR OF THE DATA
  50. C  MODE(8) SPECIFIES THE LINE STYLE OF THE DATA, FOLLOWING DIGLIB 
  51. C  CONVENTION
  52. C
  53. C  NUM IS THE NUMBER OF DATA POINTS
  54. C
  55. C  DATA IS A WORKSPACE PASSED FROM THE CALLING ROUTINE
  56. C
  57. C  ISYMNO IS THE CODE FOR THE SYMBOLS TO DRAW
  58. C
  59. C  SYMSIZ IS THE SIZE OF THE SYMBOLS TO DRAW
  60. C
  61. C  NPBSYM IS THE NUMBER OF DATA POINTS TO SKIP BETWEEN SYMBOLS
  62. C
  63. C  PLTLAB IS THE PLOT LABEL
  64. C
  65.       IMPLICIT NONE
  66.       EXTERNAL LEN
  67.       INTEGER LEN
  68.       REAL GOODCS
  69.       INTEGER*4 NUM,ISYMNO,NPBSYM
  70.       INTEGER*2 MODE(8)
  71.       REAL*4 RADIAL,RADIUS,SYMSIZ,MOD
  72.       REAL*4 RR(NUM),THETA(NUM),DATA(NUM,2)
  73.       INCLUDE DIGLIB$KOM:PLTSIZ.PRM
  74.       INCLUDE DIGLIB$KOM:PLTPRM.PRM
  75.       INCLUDE DIGLIB$KOM:GCLTYP.PRM
  76.       INCLUDE DIGLIB$KOM:GCDCHR.PRM
  77.       INCLUDE DIGLIB$KOM:PLTCLP.PRM
  78.  
  79.       INTEGER I,II,JJ,KK,COLR,IERR,LINSYL,IRAD,IOLDLT,KJK
  80.       CHARACTER*1 LAB(14),TAG(27),PLTLAB(2)
  81.       CHARACTER*13 HEADER
  82.       REAL*4 XORG,YORG,XSKAL,YSKAL
  83.       COMMON/POL/XORG,YORG,XSKAL,YSKAL
  84.  
  85.       REAL*4 RINC,RAD,CSIZE,ANG,ANGX,ANGY,XX1,YY1,DELTAX,DELTAY
  86.       REAL*4 SPOSX,SPOSY,FPOSX,FPOSY,CPOSX,CPOSY,R,YTOP,YBOT
  87.       REAL*4 XRIGHT,XLEFT,RLENGTH
  88.       EQUIVALENCE (HEADER,TAG)
  89.       DATA HEADER/'MAX RADIUS = '/
  90. C
  91. C  SAVE THE OLD LINE TYPE
  92. C
  93.       IOLDLT = ILNTYP
  94.       ILNTYP = 1
  95. C
  96. C  DETERMINE THE PLOT ORIGIN IN VIRTUAL COORDINATES
  97. C
  98.       RADIUS = RADIAL
  99.       XORG = XVSTRT + (XVLEN-XVSTRT)/2
  100.       YORG = YVSTRT + (YVLEN-YVSTRT)/2
  101. C
  102. C  LOGARITHMIC?
  103. C
  104.       IF(MODE(2) .EQ. 2) RADIUS = ALOG10(RADIUS)
  105. C
  106. C     SET THE PLOT SCALE
  107. C
  108.       XSKAL = (XVLEN - XORG)/RADIUS
  109.       YSKAL = (YVLEN - YORG)/RADIUS
  110. C
  111. C  DEPENDING UPON MODE, DRAW THE AXES AND RANGE RINGS OR NOT.
  112. C
  113.       COLR = MODE(6)
  114. D    WRITE(9,1234)XSKAL,YSKAL,XVLEN,YVLEN,XORG,YORG,RADIUS
  115. D1234    FORMAT(1X,"POLAR:",7F6.2)
  116.       CALL GSCOLR(COLR,IERR)
  117. D    WRITE(9,4321)COLR
  118. D4321    FORMAT(1X,"COLOR IS ",I4)
  119.       IF (MODE(1) .EQ. 1 .OR. MODE(1) .EQ. 2) THEN
  120.         CALL GSMOVE(XVSTRT,YORG)
  121.         CALL GSDRAW(XVLEN,YORG)
  122.         CALL GSMOVE(XORG,YVSTRT)
  123.         CALL GSDRAW(XORG,YVLEN)
  124.         CALL CIRCLE(RADIUS)
  125.  
  126. C
  127. C  NOW DO RANGE RINGS, IF INDICATED
  128. C
  129.         IF (MODE(3) .GT. 0) THEN
  130.           MOD = FLOAT(MODE(3))
  131.           LINSYL = MODE(4)
  132. D    WRITE(9,3423)LINSYL
  133. D3423    FORMAT("CALLING GSLTYP ",I3)
  134.           CALL GSLTYP(LINSYL)
  135. D    WRITE(9,3424)
  136. D3424    FORMAT("RETURNED FROM GSLTYP")
  137. C
  138. C  TEST FOR LOG OR LIN
  139. C
  140.           IF(MODE(2) .NE. 2) THEN
  141. C
  142. C  LIN
  143. C
  144.             RINC = RADIUS/MOD
  145.             DO 3 II = 1,MODE(3)-1
  146.               RAD = FLOAT(II)*RINC
  147. D    WRITE(9,3425)II,MODE(3),RAD
  148. D3425    FORMAT("CALLING CIRCLE",2(I3,1X),F6.2)
  149.               CALL CIRCLE(RAD)
  150. 3           CONTINUE
  151.           ELSE
  152. C
  153. C LOG
  154. C
  155.             RINC = 10/MOD
  156.             JJ = RADIUS
  157.             DO 103 II = 0,JJ+1
  158.               DO 102 KK = 1,MODE(3)
  159.                 RAD = ALOG10(FLOAT(KK)*RINC*(10**II))
  160.                 IF(RAD .LT. RADIUS) THEN
  161.                   CALL CIRCLE(RAD)
  162.                 ENDIF
  163. 102           CONTINUE
  164. 103         CONTINUE
  165.           ENDIF
  166.         ENDIF
  167.       ENDIF
  168.       CALL GSLTYP(1)
  169. C
  170. C  NOW DETERMINE CHARACTER SIZES FOR LABELS AND TICK MARKS
  171. C
  172.       CSIZE = GOODCS(AMAX1(0.3,AMIN1(YTOP-YBOT,XRIGHT-XLEFT)/80.0))
  173.       CALL GSSETC(CSIZE,0)
  174. C
  175. C  AND DO THE TICK MARKS AND TICK LABELS, IF INDICATED
  176. C
  177.       IF(MODE(5) .NE. 0) THEN
  178.         TICKLN = CSIZE * 0.9
  179.         DO 122 JJ = 0,360,ABS(MODE(5))
  180.           ANG = FLOAT(JJ)*6.283185/360
  181.           ANGX = COS(ANG)
  182.           ANGY = SIN(ANG)
  183.           XX1 = RADIUS*ANGX*XSKAL
  184.           YY1 = RADIUS*ANGY*YSKAL
  185.           DELTAX = TICKLN*ANGX
  186.           DELTAY = TICKLN*ANGY
  187.           SPOSX = XORG + XX1
  188.           SPOSY = YORG + YY1
  189.           IF(MODE(5) .GT. 0) THEN
  190.             FPOSX = SPOSX + DELTAX
  191.             FPOSY = SPOSY + DELTAY
  192.           ELSE
  193.             FPOSX = SPOSX - DELTAX
  194.             FPOSY = SPOSY - DELTAY
  195.           ENDIF
  196.           CALL GSMOVE(SPOSX,SPOSY)
  197.           CALL GSDRAW(FPOSX,FPOSY)
  198. C
  199. C  AND LABEL THE TICKS
  200. C
  201.           CALL LINLAB(JJ,0,LAB,0)
  202.           RLENGTH = LEN(LAB)
  203. D    WRITE(9,4565)RLENGTH
  204. D4565    FORMAT("RLENGTH ",F8.2)
  205. D    WRITE(9,8767)(LAB(KJK),KJK=1,14),JJ
  206. D8767    FORMAT("LAB,jj ",14A1,I4)
  207.           IF(JJ .GT. 90 .AND. JJ .LT.270) THEN
  208.             CPOSX = CSIZE*ANGX*(RLENGTH + 0.75)
  209. D    WRITE(9,9678)CSIZE,ANGX,RLENGTH,CPOSX
  210. D9678    FORMAT(1X,"CSIZE, ANGX, RLENGTH, CPOSX",4(F10.3,1X))
  211.           ELSE
  212.             CPOSX = CSIZE*ANGX*.5
  213.           ENDIF
  214.           IF(JJ .LT. 180) THEN
  215.             CPOSY = .6*ANGY*CSIZE
  216.           ELSE
  217.             CPOSY = ANGY*1.8*CSIZE
  218.           ENDIF
  219.           IF(JJ .GE. 355) CYCLE
  220.           IF(MODE(5) .GT. 0) THEN
  221. D        WRITE(9,4123)FPOSX,CPOSX,FPOSY,CPOSY
  222. D4123        FORMAT("FPOSX, CPOSX, FPOSY, CPOSY",4(F10.3,1X))
  223.             CALL GSMOVE(FPOSX+CPOSX,FPOSY+CPOSY)
  224.           ELSE
  225. D        WRITE(9,4123)SPOSX,CPOSX,SPOSY,CPOSY
  226. D4124        FORMAT("SPOSX, CPOSX, SPOSY, CPOSY",4(F10.3,1X))
  227.             CALL GSMOVE(SPOSX+ 1.1*CPOSX,SPOSY+ 1.5*CPOSY)
  228.           ENDIF
  229.           CALL GSPSTR(LAB)
  230. 122     CONTINUE
  231.       ENDIF
  232. C
  233. C  NOW PROVIDE THE MAXIMUM RADIUS VALUE AS A LABEL
  234. C
  235.       IF(MODE(1) .EQ. 1 .OR. MODE(1) .EQ. 2) THEN
  236.         IRAD = RADIAL
  237.         CALL LINLAB(IRAD,0,LAB,0)
  238.         CALL GSMOVE(XORG + RADIUS*XSKAL*0.8,YORG+RADIUS*YSKAL)
  239.         DO 123 JJ = 1,14
  240. 123     TAG(JJ+13) = LAB(JJ)
  241.         CALL GSPSTR(TAG)
  242.       ENDIF
  243. C
  244. C  AND PLACE THE PLOT LABEL ON THE PLOT
  245. C
  246.       RLENGTH = LEN(PLTLAB)
  247.       CALL GSMOVE(XORG-CSIZE*RLENGTH/2,YORG - RADIUS*YSKAL - 5*CSIZE)
  248.       CALL GSPSTR(PLTLAB)
  249. C
  250. C DEPENDING UPON MODE, CONVERT POLAR DATA TO X-Y FOR PLOT, OR NOT
  251. C
  252.       IF(MODE(1) .EQ. 1 .OR. MODE(1) .EQ. 3) THEN
  253.         DO 150, JJ = 1,NUM
  254. C
  255. C  LOG OR LIN RADIUS
  256. C
  257.           IF(MODE(2) .NE. 2) THEN
  258.             R = RR(JJ)
  259.           ELSE
  260.             R = ALOG10(RR(JJ))
  261.           ENDIF
  262.           DATA(JJ,1)=R * COS(THETA(JJ))
  263.           DATA(JJ,2)=R * SIN(THETA(JJ))
  264. 150     CONTINUE
  265.       ELSE
  266.         DO 155 JJ = 1,NUM
  267.           DATA(JJ,1)=RR(JJ)
  268.           DATA(JJ,2)=THETA(JJ)
  269. 155     CONTINUE
  270.       ENDIF
  271. C
  272. C  LOGARITHMIC AND OF FORM X+IY ?
  273. C
  274.       IF(MODE(2) .EQ. 2 .AND. (MODE(1) .EQ. 2 .OR. MODE(1) .EQ. 4)) THEN
  275.         DO 165 II = 1,NUM
  276.           DO 165 KK = 1,2
  277.             IF(DATA(II,KK) .GT. 0)DATA(II,KK) = ALOG10(DATA(II,KK))
  278. C
  279. C  DON'T PLOT ANYTHING THAT IS A NEGATIVE VALUE ON A LOG POLAR PLOT
  280. C
  281.             IF(DATA(II,KK) .LT. 0)DATA(II,KK) = 0
  282. 165     CONTINUE
  283.       ENDIF
  284. C
  285. C  NOW SCALE THE DATA TO FIT THE PLOT
  286. C
  287.       DO 170 JJ = 1,NUM
  288.         DATA(JJ,1) = DATA(JJ,1)*XSKAL + XORG
  289.         DATA(JJ,2) = DATA(JJ,2)*YSKAL + YORG
  290. 170   CONTINUE
  291.       LINSYL = MODE(8)
  292.       CALL GSLTYP(LINSYL)
  293.       CALL GSMOVE(DATA(1,1),DATA(1,2))
  294.       COLR = MODE(7)
  295.       CALL GSCOLR(COLR,IERR)
  296.       DO 211 JJ = 2,NUM
  297.         CALL GSDRAW(DATA(JJ,1),DATA(JJ,2))
  298. 211   CONTINUE
  299.       CALL GSLTYP(1)
  300. C
  301. C       NOW ADD SYMBOLS IF DESIRED
  302. C
  303.       IF (ISYMNO .LE. 0) GO TO 800
  304. C
  305. C   DO SYMBOLS IN SOLID LINES
  306. C
  307.       DO 400 I=1,NUM,NPBSYM
  308.       CALL GSMOVE(DATA(I,1),DATA(I,2))
  309.       CALL SYMBOL(ISYMNO,SYMSIZ)
  310. 400   CONTINUE
  311. C
  312. C   RESTORE LINE TYPE
  313. C
  314.  
  315.       ILNTYP = IOLDLT
  316. 800   CONTINUE
  317.       RETURN
  318.       END
  319. C
  320. C  THIS SUBROUTINE DRAWS THE CIRCLES FOR THE RANGE RINGS
  321. C
  322.       SUBROUTINE CIRCLE(RADIUS)
  323.       IMPLICIT NONE
  324.       REAL*4 RADIUS
  325.  
  326.       INCLUDE DIGLIB$KOM:PLTSIZ.PRM
  327.       INCLUDE DIGLIB$KOM:PLTPRM.PRM
  328.       INCLUDE DIGLIB$KOM:GCLTYP.PRM
  329.       INCLUDE DIGLIB$KOM:GCDCHR.PRM
  330.       INCLUDE DIGLIB$KOM:PLTCLP.PRM
  331.  
  332.       INTEGER*2 II
  333.       REAL*4 XORG,YORG,XSKAL,YSKAL,DTORAD,XX,X,Y
  334.       COMMON/POL/XORG,YORG,XSKAL,YSKAL
  335.  
  336.       DTORAD = 6.283185/360
  337.       CALL GSMOVE(XORG+XSKAL*RADIUS,YORG)
  338.       DO 10 II = 1,360,2
  339.       XX = FLOAT(II)
  340.       X = XORG+RADIUS*XSKAL*COS(DTORAD*XX)
  341.       Y = YORG+RADIUS*YSKAL*SIN(DTORAD*XX)
  342. D    WRITE(9,876)X,Y
  343. D876    FORMAT("CIRCLE ",2F8.3)
  344.       CALL GSDRAW(X,Y)
  345. 10    CONTINUE
  346.       RETURN
  347.       END
  348.