home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / library / pearson / corl.for next >
Text File  |  1986-09-19  |  7KB  |  183 lines
  1.       PROGRAM CORL
  2. C ............................................................
  3. C              Pearson Product Moment Correlation
  4. C                 by Thomas Wm. Madron (1985)
  5. C                       Denton, TX 76205
  6. C PURPOSE:  To calculate a Matrix of  Pearson  Product  Moment
  7. C      Correlation    coefficients,    means,   and   standard
  8. C      deviations.  Data may be entered from a  disk  file  or
  9. C      from  the keyboard (and may be optionally saved if from
  10. C      the keyboard).   Results  may  be  sent  to  the  video
  11. C      display,  the printer, or to a disk file and a standard
  12. C      matrix file may be saved.  
  13. C REMARKS:  CORL requires all data to be present.  As  written
  14. C      it  can handle 100 variables, although if the amount of
  15. C      memory  is  a  problem,  dimension  and   specification
  16. C      statements  may be changed to reflect a smaller number.
  17. C      The program will run faster if compiled to use an  8087
  18. C      coprocessor.  In addition to providing normal output, a
  19. C      primary  purpose  of  the  program  is  to  generate  a
  20. C      standard matrix file for input to other programs.  
  21. C      NOTE:    When  compiling  the  program  and  associated
  22. C      subprograms,  use  the  $STORAGE:  2 and $DO66 compiler
  23. C      options.  The first changes  the  default  for  integer
  24. C      lengths  from 32 bits to 16 bits.  This reduces storage
  25. C      requirements and speeds program execution.  The  second
  26. C      option  changes the default method of handling DO loops
  27. C      from the FORTRAN 77 conventions to FORTRAN 66  (FORTRAN
  28. C      IV)  conventions.  This was probably not necessary, but
  29. C      many of the programs and  subprograms  in  this  series
  30. C      were derived from FORTRAN 66 sources and the precaution
  31. C      was thought the better part of valor.  
  32. C METHOD:  Any introductory statistics textbook describes  the
  33. C      Product Moment Correlation in some detail.  
  34. C SUBPROGRAMS REQUIRED:
  35. C      SUBROUTINES:
  36. C      CENTER (INPUT, OUTPUT, N)
  37. C      CLS
  38. C      CORR (N, NV, R, FMEAN, STD, T, FMT, INPDEV, IOUT, ND)
  39. C      FILES (TITLE, IO, FILENM, STA)
  40. C      HEADER
  41. C      HELP (NCALL) [DUMMY IN THIS PROGRAM]
  42. C      INPMNU (TITLE,IQ)
  43. C      KEYBD (X, NV, NOBS, IOUT, IEND)
  44. C      LOCATE (IROW, ICOL)
  45. C      MOVE (FROM,LOC1,TO,LOC2,LENGTH)
  46. C      OUTMNU (IOD, IDISK3, TITLE3)
  47. C      PCDS (X, N, M, FH, IO, IDIAG, ND)
  48. C      PRTS (X,N,M,NVAR,KH,ND,NSET,IDIAG)
  49. C      SUBS (X, N, IO, ID)
  50. C      VPRTS (TITLE,NVAR,X,NR,NC,FH,IDIAG,ND)
  51. C      WAIT (NCALL)
  52. C      WTMAT (R, FMEAN, STD, NV, DTFILE, FMT, TITLE,
  53. C    1       IDISK4, IDIAG, N, LL, ND)
  54. C      FUNCTIONS REQUIRED:
  55. C      FUNCTION ICLS(IOUT)
  56. C      FUNCTION INSTR (STRING, VALUE, LENVAL)
  57. C      FUNCTION UPPER (CHARX)
  58. C LOGICAL UNIT NUMBERS  FOR  FILES:    Six  (6)  Logical  Unit
  59. C      Numbers (LUNs) are reserved for standard file handling:
  60. C      5 - Video Display Output, opened for 'CON'.
  61. C      6 - Line Printer Output, opened for 'LPT1'.
  62. C      1 - IDISK1:  Raw data input file.
  63. C      2 - IDISK2:  Raw data output file.
  64. C      3 - IDISK3:  Output file for results (print image).
  65. C      4 - IDISK4:  Standard Matrix output file.
  66. C ............................................................
  67. C     SPECIFICATION STATEMENTS
  68.       CHARACTER YM*1, YD*1, YES*1, TITLE*64, TITLE1*28,
  69.      1 TITLE2*28, TITLE3*28, TITLE4*28, UPPER, FST*80, SEC*80,
  70.      2 FILENM*14, DTFILE*14, INPUT*80, OUTPUT*80, FMT*80
  71.       INTEGER*2 NVAR(100), I, J
  72.       REAL*4 R(100,100), FMEAN(100), STD(100)
  73.       COMMON /FILEX/ IDISK1,IDISK2,IDISK3,IDISK4
  74.       COMMON /HEAD/ FST, SEC
  75. C     MAXIMUM DIMENSION OF ROWS IN R:
  76.       ND = 100
  77. C     DISK FILES:
  78.       IDISK1 = 1
  79.       IDISK2 = 2
  80.       IDISK3 = 3
  81.       IDISK4 = 4
  82. C     INITIALIZE VARIABLES
  83.       INPDEV = 0
  84.       IOUT = 0
  85.       YES = 'Y'
  86.       LL = 80
  87.       IDIAG = 0
  88.       ICRT = 5
  89.       IPRT = 6
  90.       NCALL = 0
  91. C     TITLES FOR FILESPEC REQUESTS
  92.       TITLE1 =  'Input Data Filespecs        '
  93.       TITLE2 =  'Output Data Filespecs       '
  94.       TITLE3 =  'Output Results Filespecs    '
  95.       TITLE4 =  'Output Matrix Filespecs     '
  96. C     HEADER TITLES
  97.       FST = 'Pearson Product Moment Correlation Program\'
  98.       SEC = 'by Thomas Wm. Madron (1985)\' 
  99. C     SETUP INPUT PARAMETERS
  100. 40    CALL HEADER
  101.       WRITE (*,'('' Please Enter a Title for this Run:'')')
  102.       READ (*,'(A)') TITLE
  103.       WRITE (*,'('' How many variables will you need? ''\)')
  104.       READ (*,'(I10)') NV
  105.       IF (NV .GT. ND) THEN
  106.            INPUT = '* * * Too Many Variables * * *\'
  107.            CALL CENTER (INPUT, OUTPUT, LL)
  108.            IROW = 10
  109.            ICOL = 1
  110.            CALL LOCATE (IROW, ICOL)
  111.            WRITE (*,'(A)') OUTPUT
  112.            CALL WAIT (NCALL)
  113.            GO TO 40
  114.       ENDIF
  115. C     INITIALIZE NVAR(I)
  116.       DO 50 I = 1,NV
  117.            NVAR(I) = I
  118. 50    CONTINUE
  119.       CALL INPMNU (TITLE, INPD)
  120.       IF (INPD .EQ. 3) GO TO 100
  121.       IF (INPD .EQ. 2) THEN
  122.            CALL FILES (TITLE1, IDISK1, DTFILE, 'OLD')
  123.            WRITE (*,
  124.      1       '('' Please specify your data FORMAT: '')')
  125.            READ (*,'(A)') FMT
  126.       ELSEIF (INPD .EQ. 1) THEN
  127.            WRITE (*,'('' Do You want to save the Data? ''\)')
  128.            READ (*,'(A)') YD
  129.            YD = UPPER(YD)
  130.            IF (YD .EQ. YES) THEN
  131.                 CALL FILES (TITLE2, IDISK2, FILENM, 'NEW')
  132.                 IOUT = 2
  133.            ENDIF
  134.       ENDIF
  135. C     SETUP OUTPUT PARAMETERS
  136.       CALL OUTMNU (IOD, IDISK3, TITLE3)
  137.       CALL HEADER
  138.       WRITE (*,
  139.      1 '('' Do you want to save the Matrix (y/n)? ''\)')
  140.       READ (*,'(A)') YM
  141.       YM = UPPER(YM)
  142.       IF (YM .EQ. YES) THEN
  143.            CALL FILES (TITLE4, IDISK4, FILENM, 'NEW')
  144.       ENDIF
  145. C     DO THE CORRELATIONS
  146.       CALL CORR (N, NV, R, FMEAN, STD, T, FMT, INPD, IDISK1,
  147.      * IOUT, ND)
  148.       IF (IOUT .GE. 1) THEN
  149.            CLOSE (IDISK2, STATUS='KEEP')
  150.       ENDIF
  151.       IF (IOD .EQ. ICRT) THEN
  152. C          PRINT MEANS, STD. DEVS., & CORRELATIONS TO VIDEO
  153.            CALL VPRTS (TITLE,NVAR,FMEAN,NV,1,'MEAN',IDIAG,
  154.      1        NCALL,ND)
  155.            CALL VPRTS (TITLE,NVAR,STD,NV,1,'STD.',IDIAG,
  156.      1        NCALL,ND)
  157.            CALL VPRTS (TITLE,NVAR,R,NV,NV,'CORL',IDIAG,
  158.      1        NCALL,ND)
  159.       ELSE
  160. C     PRINT MEANS, STANDARD DEVIATIONS, AND CORRELATIONS
  161. C          IF IOD =
  162. C               IPRT, THEN OUTPUT IS TO THE PRINTER
  163. C               IDISK3, THEN OUTPUT IS TO DISK
  164.            WRITE (IOD,'('' '',A)') TITLE
  165.            CALL PRTS (FMEAN,NV,1,NVAR,'MEANS   ',ND,IOD,IDIAG)
  166.            CALL PRTS (STD,NV,1,NVAR,'STD.DEV.',ND,IOD,IDIAG)
  167.            II = ICLS (IOD)
  168.            WRITE (IOD,'('' '',A)') TITLE
  169.            CALL PRTS (R,NV,NV,NVAR,'CORRELAT',ND,IOD,IDIAG)
  170.       ENDIF
  171. C     SAVE THE MATRIX IN STANDARD DISK FORMAT, IF OPTED
  172.       IF (YM .EQ. YES) THEN
  173.            CALL WTMAT (R, FMEAN, STD, NV, DTFILE, FMT, TITLE,
  174.      1       IDISK4, IDIAG, N, LL, ND)
  175.       ENDIF
  176. 100   CALL CLS
  177.       STOP 'FINI'
  178.       END
  179.       SUBROUTINE HELP (NCALL)
  180. C     DUMMY SUBROUTINE NOT APPLICABLE TO CORL.FOR
  181.       RETURN
  182.       END
  183.