home *** CD-ROM | disk | FTP | other *** search
/ Between Heaven & Hell 2 / BetweenHeavenHell.cdr / 500 / 473 / multi.arc / FORGET.FOR < prev    next >
Text File  |  1985-12-01  |  13KB  |  465 lines
  1. C        
  2. C                                 FORGET-IT
  3. C                          Tukey's Forget-it Plots
  4. C                                Version 1.0
  5. C                              November 4, 1985
  6. C
  7. C
  8. C                              Gerard E. Dallal
  9. C
  10. C               USDA Human Nutrition Research Center on Aging
  11. C                            at Tufts University
  12. C                           711 Washington Street
  13. C                             Boston, MA  02111
  14. C
  15. C                                    and
  16. C
  17. C                    Tufts University School of Nutrition
  18. C                             132 Curtis Street
  19. C                             Medford, MA 02155
  20. C        
  21. C
  22. C
  23. C                                  NOTICE
  24. C
  25. C       Documentation and original code copyright 1985 by  Gerard  E.  
  26. C       Dallal.  Reproduction of material for non-commercial purposes 
  27. C       is   permitted,   without  charge,   provided  that  suitable 
  28. C       reference is made to FORGET-IT and its author.  
  29. C
  30. C       Neither FORGET-IT nor its documentation should be modified in 
  31. C       any way without permission from the author,  except for those 
  32. C       changes  that are  essential  to move  FORGET-IT  to  another 
  33. C       computer.  
  34. C
  35. C       Please acknowledge  FORGET-IT in any manuscript that uses its 
  36. C       calculations.  
  37. C
  38.       LOGICAL QFILE, QLABEL, QEXT
  39.       CHARACTER*1 QUERY, RNAME(20,5), CNAME(20,5), PLOT(100,100),
  40.      *   BLANK, SLASH, BSLASH, VBAR, XXX, OOO, CDUMMY
  41.       CHARACTER FNAME*50
  42.       DIMENSION DATA(20, 20), RE(20), CE(20),
  43.      *   INDEX(20), FIT(20, 20), IROW(20), ICOL(20)
  44.  
  45.       DATA IOUT /0/, IIN /0/, NPLMAX/100/, NLMAX /20/, NLWMAX /5/
  46.       DATA IFIN /10/, IWOUT /11/, QFILE /.FALSE./, QEXT/.FALSE./
  47.       DATA BLANK /' '/, SLASH /'/'/, BSLASH /'\'/, VBAR /'|'/, 
  48.      *   XXX /'X'/, OOO /'0'/
  49. C
  50.       WRITE(IOUT,9999)
  51.  9999 FORMAT (//35X,'FORGET-IT'/
  52.      *   28X,'Tukey''s Forget-it Plots'/
  53.      *   34X,'Version 1.0'/32X,'November 4, 1985'//
  54.      *   32X,'Gerard E. Dallal'/
  55.      *   17X,'USDA Human Nutrition Research Center on Aging'/
  56.      *   30X,'at Tufts University'/29X,'711 Washington Street'/
  57.      *   31X,'Boston, MA  02111'///36X,'NOTICE'//9X,'Please '
  58.      *   'acknowledge FORGET-IT in any manuscript that uses its',/
  59.      *   33X,'calculations.'/)
  60. C
  61.     1 QLABEL = .FALSE.
  62.       DO 2 KK = 1, NLWMAX
  63.       DO 2 K = 1, NLMAX
  64.       RNAME(K,KK) = BLANK
  65.       CNAME(K,KK) = BLANK
  66.     2 CONTINUE
  67.       IF (QFILE) GOTO 10
  68.       WRITE(IOUT,4)
  69.     4 FORMAT(/' Do you wish to save the results of this session?  ',
  70.      *  '(Y or N):  '$)
  71.       READ (IIN,6) QUERY
  72.     6 FORMAT (A1)
  73.       IF (QUERY.EQ.'Y' .OR. QUERY.EQ.'y') QFILE = .TRUE.
  74.       IF (.NOT. QFILE) GOTO 10
  75.       WRITE (IOUT,8)
  76.     8 FORMAT (' Enter filename:  '$)
  77.       READ (IIN,'(A)') FNAME
  78.       OPEN (IWOUT, FILE = FNAME, STATUS = 'NEW')
  79.  
  80.    10 WRITE (IOUT,15)
  81.       IF (QFILE) WRITE (IWOUT,15)
  82.    15 FORMAT(//' Enter the number of rows:  '$)
  83.       READ (IIN,*) M
  84.       IF (QFILE) WRITE (IWOUT,*) M
  85.       WRITE (IOUT,20)
  86.       IF (QFILE) WRITE (IWOUT,20)
  87.    20 FORMAT(' Enter the number of columns:  '$)
  88.       READ (IIN,*) N
  89.       IF (QFILE) WRITE (IWOUT,*) N
  90.       WRITE (IOUT,21)
  91.    21 FORMAT(/' Are data contained in an external file?  (Y or N):  '$)
  92.       READ (IIN,6) QUERY
  93.       IF (QUERY.NE.'Y' .AND. QUERY.NE.'y') GOTO 30
  94.       QEXT = .TRUE.
  95.       WRITE (IOUT,24)
  96.    24 FORMAT (' Enter filename:  '$)
  97.       READ (IIN,'(A)') FNAME
  98.       OPEN (IFIN, FILE = FNAME, STATUS = 'OLD')
  99.  
  100.       DO 26 I = 1, M
  101.       READ (IFIN,*) (DATA(I,J), J = 1, N)
  102.    26 CONTINUE
  103.       DO 27 I = 1, M
  104.       READ(IFIN,28,END = 51) (RNAME(I,K), K = 1, 5)
  105.    28 FORMAT(5A1)
  106.    27 CONTINUE
  107.       DO 29 J = 1, N
  108.       READ(IFIN,28,END = 51) (CNAME(J,K), K = 1, 5)
  109.    29 CONTINUE
  110.       QLABEL = .TRUE.
  111.  
  112.       GOTO 59
  113.  
  114.    30 DO 50 I = 1, M
  115.       WRITE (IOUT,40) I
  116.    40 FORMAT(' Enter row',I2,':')
  117.       READ (IIN,*) (DATA(I,J), J = 1, N)
  118.    50 CONTINUE
  119.  
  120.    51 WRITE (IOUT,52)
  121.    52 FORMAT(/' Do you wish to specify row and column names?  ',
  122.      *   '(Y or N):  '$)
  123.       READ (IIN,6) QUERY
  124.       IF (QUERY.NE.'Y' .AND. QUERY.NE.'y') GOTO 59
  125.  
  126.       QLABEL = .TRUE.
  127.       DO 54 I = 1, M
  128.       WRITE(IOUT,53) I
  129.    53 FORMAT(' Enter name of row',I2,':  '$)
  130.       READ(IIN,28) (RNAME(I,K), K = 1, 5)
  131.    54 CONTINUE
  132.       DO 56 J = 1, N
  133.       WRITE(IOUT,55) J
  134.    55 FORMAT(' Enter name of column',I2,':  '$)
  135.       READ(IIN,28) (CNAME(J,K), K = 1, 5)
  136.    56 CONTINUE
  137.  
  138.    59 WRITE(IOUT,60) ((CNAME(J,K),K=1,5), J=1,N)
  139.    60 FORMAT(//(11X,5A1,8X,5A1,8X,5A1,8X,5A1,8X,5A1,8X,5A1))
  140.  
  141.    61 DO 63 I = 1, M
  142.       WRITE (IOUT,62) (RNAME(I,K), K = 1, 5), (DATA(I,J), J = 1, N)
  143.    62 FORMAT (/1X,5A1,1X,6G13.5/(7X,6G13.5))
  144.    63 CONTINUE
  145.  
  146.       IF (QEXT) GOTO 76
  147.       WRITE(IOUT,64)
  148.    64 FORMAT(/' Any changes?  (Y or N):  '$)
  149.       READ (IIN,6) QUERY
  150.       IF (QUERY.NE.'Y' .AND. QUERY.NE.'y') GOTO 76
  151.  
  152.    65 WRITE (IOUT,66)
  153.    66 FORMAT(' Enter row:  '$)
  154.       READ (IIN,*) KROW
  155.       IF (KROW.LT.1 .OR. KROW.GT.M) GOTO 65
  156. C
  157.    67 WRITE (IOUT,68)
  158.    68 FORMAT(' Enter column:  '$)
  159.       READ (IIN,*) KCOL
  160.       IF (KCOL.LT.1 .OR. KCOL.GT.N) GOTO 67
  161. C
  162.       WRITE (IOUT,70)
  163.    70 FORMAT(' Enter new data value:  '$)
  164.       READ (IIN,*) DATA(KROW,KCOL)
  165.       GOTO 61
  166.  
  167.    76 IF (.NOT.QFILE) GOTO 78
  168.       WRITE(IWOUT,60) ((CNAME(J,K),K=1,5), J=1,N)
  169.       DO 77 I = 1, M
  170.       WRITE (IWOUT,62) 
  171.      *   (RNAME(I,K), K = 1, 5), (DATA(I,J), J = 1, N)
  172.    77  CONTINUE
  173.  
  174.  
  175.    78 WRITE (IOUT,79)
  176.       IF (QFILE) WRITE (IWOUT,79)
  177.    79 FORMAT (//' Enter the size of the plot:  '$)
  178.       READ (IIN,*) NPLOT
  179.       IF (QFILE) WRITE (IWOUT,*) NPLOT
  180.  
  181. C
  182. C        TUKEY'S FORGETIT PLOTS
  183. C
  184. C
  185.       XNPLOT = NPLOT
  186.       NPLOTW = NPLOT
  187.       DO 80 I = 1, NPLMAX
  188.       DO 80 J = 1, NPLMAX
  189.    80 PLOT(I,J) = BLANK
  190. C
  191. C        FITTED VALUES
  192. C
  193.       XBAR = 0.0
  194.       DO 90 J = 1, N
  195.    90 CE(J)= 0.0
  196. C
  197.       DO 200 I = 1, M
  198.       RE(I) = 0.0
  199.       DO 100 J = 1, N
  200.       RE(I) = RE(I) + DATA(I, J)
  201.       CE(J) = CE(J) + DATA(I, J)
  202.       XBAR = XBAR + DATA(I, J)
  203.   100 CONTINUE
  204.   200 CONTINUE
  205.       XBAR = XBAR / FLOAT(M * N)
  206.       FN = N
  207.       DO 300 I = 1, M
  208.   300 RE(I) = RE(I) / FN - XBAR
  209.       FM = M
  210.       DO 310 J = 1, N
  211.   310 CE(J) = CE(J) / FM - XBAR
  212.  
  213.       WRITE (IOUT, 320) XBAR
  214.       IF (QFILE) WRITE (IWOUT,320) XBAR
  215.   320 FORMAT(/' GRAND MEAN...  ',G12.5//' ROW EFFECTS...  '/)
  216.       DO 328 I = 1, M
  217.       WRITE (IOUT,325) I, RE(I), (RNAME(I,K), K = 1, 5)
  218.       IF (QFILE) WRITE (IWOUT,325) I, RE(I), (RNAME(I,K), K = 1, 5)
  219.   325 FORMAT (17X,I2,':  ',G12.5,3X,5A1)
  220.   328 CONTINUE
  221.  
  222.       WRITE (IOUT, 330) 
  223.       IF (QFILE) WRITE (IWOUT,330) 
  224.   330 FORMAT(//' COLUMN EFFECTS...  '/)
  225.       DO 338 J = 1, N
  226.       WRITE (IOUT,335) J, CE(J), (CNAME(J,K), K = 1, 5)
  227.       IF (QFILE) WRITE (IWOUT,335) J, CE(J), (CNAME(J,K), K = 1, 5)
  228.   335 FORMAT (20X,I2,':  ',G12.5,3X,5A1)
  229.   338 CONTINUE
  230.  
  231. C
  232. C        SORT TABLE IN ORDER OF DECREASING ROW EFFECTS
  233. C
  234.       DO 400 I = 1, M
  235.   400 INDEX(I) = I
  236.       MM1 = M - 1
  237.       DO 600 I = 1, MM1
  238.       IP1 = I + 1
  239.       DO 600 K = IP1, M
  240.       IF (RE(I) .GE. RE(K)) GOTO 600
  241.       IDUM = INDEX(I)
  242.       INDEX(I) = INDEX(K)
  243.       INDEX(K) = IDUM
  244.       DUMMY = RE(I)
  245.       RE(I) = RE(K)
  246.       RE(K) = DUMMY
  247.       DO 500 J = 1, N
  248.       DUMMY = DATA(I,J)
  249.       DATA(I,J) = DATA(K,J)
  250.       DATA(K,J) = DUMMY
  251.   500 CONTINUE
  252.       DO 550 KK = 1, 5
  253.       CDUMMY = RNAME(I,KK)
  254.       RNAME(I,KK) = RNAME(K,KK)
  255.       RNAME(K,KK) = CDUMMY
  256.   550 CONTINUE
  257.   600 CONTINUE
  258.  
  259.       WRITE (IOUT, 720) 
  260.       IF (QFILE) WRITE (IWOUT, 720) 
  261.   720 FORMAT(//' ORDER OF DECREASING ROW EFFECTS:  ')
  262.       DO 728 I = 1, M
  263.       WRITE (IOUT,725) INDEX(I), RE(I), (RNAME(I,K), K = 1, 5)
  264.       IF (QFILE) WRITE (IWOUT,725) INDEX(I), RE(I), 
  265.      *   (RNAME(I,K), K = 1, 5)
  266.   725 FORMAT (35X,I2,':  ',G12.5,3X,5A1)
  267.   728 CONTINUE
  268. C
  269. C        SORT TABLE IN ORDER OF INCREASING COLUMN EFFECTS
  270. C
  271.       DO 800 J = 1, N
  272.   800 INDEX(J) = J
  273.       NM1 = N - 1
  274.       DO 1000 J = 1, NM1
  275.       JP1 = J + 1
  276.       DO 1000 K = JP1, N
  277.       IF (CE(J) .LE. CE(K)) GOTO 1000
  278.       IDUM = INDEX(J)
  279.       INDEX(J) = INDEX(K)
  280.       INDEX(K) = IDUM
  281.       DUMMY = CE(J)
  282.       CE(J) = CE(K)
  283.       CE(K) = DUMMY
  284.       DO 900 I = 1, M
  285.       DUMMY = DATA(I,J)
  286.       DATA(I,J) = DATA(I,K)
  287.       DATA(I,K) = DUMMY
  288.   900 CONTINUE
  289.       DO 950 KK = 1, 5
  290.       CDUMMY = CNAME(J,KK)
  291.       CNAME(J,KK) = CNAME(K,KK)
  292.       CNAME(K,KK) = CDUMMY
  293.   950 CONTINUE
  294.  1000 CONTINUE
  295.  
  296.       WRITE (IOUT, 1130) 
  297.       IF (QFILE) WRITE (IWOUT,1130) 
  298.  1130 FORMAT(//' ORDER OF INCREASING COLUMN EFFECTS:  ')
  299.       DO 1138 J = 1, N
  300.       WRITE (IOUT,1135) J, CE(J), (CNAME(J,K), K = 1, 5)
  301.       IF (QFILE) WRITE (IWOUT,1135) INDEX(J), CE(J), 
  302.      *   (CNAME(J,K), K = 1, 5)
  303.  1135 FORMAT (38X ,I2,':  ',G12.5,3X,5A1)
  304.  1138 CONTINUE
  305.  
  306. C
  307. C        GET MAX AND MIN (AND FITTED VALUES)
  308. C
  309.       XMAX = XBAR + RE(1) + CE(N)
  310.       XMIN = XBAR + RE(M) + CE(1)
  311.       DO 1200 I = 1, M
  312.       DO 1200 J = 1, N
  313.       FIT(I,J) = XBAR + RE(I) + CE(J)
  314.       IF (DATA(I,J) .LT. XMIN) XMIN = DATA(I,J)
  315.       IF (DATA(I,J) .GT. XMAX) XMAX = DATA(I,J)
  316.  1200 CONTINUE
  317. C
  318. C        A SMALL TWIDDLE... MAKE XMAX AND XMIN THE CENTERS OF THEIR
  319. C        RESPECTIVE PLOTTING POSITIONS
  320. C
  321.       RANGE = XMAX - XMIN
  322.       XMAX = XMAX + RANGE / (2.0 * (XNPLOT - 1.0))
  323.       XMIN = XMIN - RANGE / (2.0 * (XNPLOT - 1.0))
  324.       RANGE = XMAX - XMIN
  325. C
  326. C        FIND ROW PLOTTING POSITIONS OF ROWS AND COLUMNS
  327. C
  328.       DO 1300 I = 1, M
  329.  1300 IROW(I) = 1.49999 + (XNPLOT - 1.0) * (FIT(I,1) - XMIN) / RANGE 
  330.       DO 1400 J = 1, N
  331.  1400 ICOL(J) = 1.49999 + (XNPLOT - 1.0) * (FIT(1,J) - XMIN) / RANGE 
  332.         
  333. C
  334. C        CHANGE LOCATIONS TO OFFSETS FROM ANCHOR AT CELL (1,1)
  335. C
  336.       IANCHR = IROW(1)
  337.       DO 1410 I = 1, M
  338.  1410 IROW(I) = IROW(I) - IANCHR
  339.       DO 1420 J = 1, N
  340.  1420 ICOL(J) = ICOL(J) - IANCHR
  341.  
  342. C
  343. C        FILL IN THE LINES, ROWS
  344. C
  345.       LEN = 1 + ICOL(N) 
  346.       DO 1600 I = 1, M
  347.       ISTART = IANCHR + IROW(I)
  348.       JSTART = 1 - IROW(I)
  349.       DO 1500 K = 1, LEN
  350.       I0 = ISTART + K - 1
  351.       J0 = JSTART + K - 1
  352.       PLOT(I0,J0) = SLASH
  353.  1500 CONTINUE
  354.  1600 CONTINUE
  355. C
  356. C        FILL IN THE LINES, COLUMNS
  357. C
  358.       LEN = 1 - IROW(M) 
  359.       DO 1800 J = 1, N
  360.       ISTART = IANCHR + ICOL(J)
  361.       JSTART = 1 + ICOL(J)
  362.       DO 1700 K = 1, LEN
  363.       I0 = ISTART - K + 1
  364.       J0 = JSTART + K - 1
  365.       PLOT(I0,J0) = BSLASH
  366.  1700 CONTINUE
  367.  1800 CONTINUE
  368. C
  369. C        FILL IN FITTED VALUES
  370. C
  371.       DO 2000 I = 1, M
  372.       DO 2000 J = 1, N
  373.       I0 = IANCHR + IROW(I) + ICOL(J)
  374.       J0 = 1 - IROW(I) + ICOL(J)
  375.       PLOT(I0,J0) = OOO
  376.  2000 CONTINUE
  377. C
  378. C        FILL IN VERTICAL LINES
  379. C
  380.       DO 2200 I = 1, M
  381.       DO 2200 J = 1, N
  382.       DIFF = DATA(I,J) - FIT(I,J)
  383.       LEN =  0.49999 + XNPLOT * ABS(DIFF) / RANGE - 1.0
  384.       I0 = IANCHR + IROW(I) + ICOL(J)
  385.       J0 = 1 - IROW(I) + ICOL(J)
  386.       IF (LEN .LE. 0) GOTO 2200
  387.       DO 2100 K = 1, LEN
  388.       IF (DIFF .GT. 0.0) I0 = I0 + 1
  389.       IF (DIFF .LT. 0.0) I0 = I0 - 1
  390.       PLOT(I0,J0) = VBAR
  391.  2100 CONTINUE
  392.  2200 CONTINUE
  393. C
  394. C        FILL IN OBSERVED VALUES
  395. C
  396.       DO 2300 I = 1, M
  397.       DO 2300 J = 1, N
  398.       DIFF = DATA(I,J) - FIT(I,J)
  399.       LEN = 0.49999 + XNPLOT * ABS(DIFF) / RANGE
  400.       I0 = IANCHR + IROW(I) + ICOL(J) 
  401.       IF (DIFF .GT. 0.0) I0 = I0 + LEN
  402.       IF (DIFF .LT. 0.0) I0 = I0 - LEN
  403.       J0 = 1 - IROW(I) + ICOL(J)
  404.       PLOT(I0,J0) = XXX
  405.  2300 CONTINUE
  406. C
  407. C        INSERT LABELS
  408. C
  409.       IF (.NOT.QLABEL) GOTO 2600
  410.       DO 2400 I = 1, M
  411.       I0 = IANCHR + IROW(I) + ICOL(N)
  412.       DO 2310 K = NPLOT, NPLOTW
  413.       J0 = NPLOTW - (K - NPLOT)
  414.       IF (PLOT(I0,J0).NE.BLANK) GO TO 2320
  415.  2310 CONTINUE
  416.  2320 J0 = J0 + 1
  417.       IF (J0 + 5.GT.NPLMAX) GOTO 2400
  418.       DO 2330 K = 1, 5
  419.       J0 = J0 + 1
  420.       PLOT(I0,J0) = RNAME(I,K)
  421.  2330 CONTINUE
  422.       IF (J0.GT.NPLOTW) NPLOTW = J0
  423.  2400 CONTINUE
  424.  
  425.       DO 2500 J = 1, N
  426.       I0 = IANCHR + IROW(M) + ICOL(J)
  427.       DO 2410 K = NPLOT, NPLOTW
  428.       J0 = NPLOTW - (K - NPLOT)
  429.       IF (PLOT(I0,J0).NE.BLANK) GO TO 2420
  430.  2410 CONTINUE
  431.  2420 J0 = J0 + 1
  432.       IF (J0 + 5.GT.NPLMAX) GOTO 2500
  433.       DO 2430 K = 1, 5
  434.       J0 = J0 + 1
  435.       PLOT(I0,J0) = CNAME(J,K)
  436.  2430 CONTINUE
  437.       IF (J0.GT.NPLOTW) NPLOTW = J0
  438.  2500 CONTINUE
  439.  
  440. C
  441. C        PLOT PLOT
  442. C
  443.  2600 WRITE (IOUT,2700)
  444.       IF (QFILE) WRITE (IWOUT,2700)
  445.  2700 FORMAT('1'//)
  446.       XLAB = XMAX + RANGE / (2.0 * XNPLOT)
  447.       I0 = NPLOT + 1
  448.       DO 3000 I = 1, NPLOT
  449.       I0 = I0 - 1
  450.       XLAB = XLAB - RANGE / XNPLOT 
  451.       WRITE (IOUT,2800) XLAB, (PLOT(I0,J), J = 1, NPLOTW)
  452.       IF (QFILE) WRITE (IWOUT,2800) XLAB, (PLOT(I0,J), J = 1, NPLOTW)
  453.  2800 FORMAT(1X,G12.5, ' |   ', 100A1)
  454.  3000 CONTINUE
  455.  
  456.       WRITE (IOUT,3020)
  457.  3020 FORMAT (///' Do you wish to continue?  (Y or N):  '$)
  458.       READ (IIN,6) QUERY
  459.       IF (QUERY.NE.'Y' .AND. QUERY.NE.'y') STOP ' '
  460.       IF (QEXT) CLOSE (UNIT = IFIN)
  461.       IF (QFILE) WRITE (IWOUT, 3030)
  462.  3030 FORMAT(1H1)
  463.       GOTO 1
  464.       END
  465.