Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50145/facto.smp
There are 2 other files named facto.smp in the archive. Click here to see a list.
C                                                                       FCTO  10
C     ................................................................. FCTO  20
C                                                                       FCTO  30
C        SAMPLE MAIN PROGRAM FOR FACTOR ANALYSIS - FACTO                FCTO  40
C                                                                       FCTO  50
C        PURPOSE                                                        FCTO  60
C           (1) READ THE PROBLEM PARAMETER CARD, (2) CALL FIVE SUBROU-  FCTO  70
C           TINES TO PERFORM A PRINCIPAL COMPONENT SOLUTION AND THE     FCTO  80
C           VARIMAX ROTATION OF A FACTOR MATRIX, AND (3) PRINT THE      FCTO  90
C           RESULTS.                                                    FCTO 100
C                                                                       FCTO 110
C        REMARKS                                                        FCTO 120
C           NONE                                                        FCTO 130
C                                                                       FCTO 140
C        SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED                  FCTO 150
C           CORRE  (WHICH, IN TURN, CALLS THE SUBROUTINE NAMED DATA.)   FCTO 160
C           EIGEN                                                       FCTO 170
C           TRACE                                                       FCTO 180
C           LOAD                                                        FCTO 190
C           VARMX                                                       FCTO 200
C                                                                       FCTO 210
C        METHOD                                                         FCTO 220
C           REFER TO 'BMD COMPUTER PROGRAMS MANUAL', EDITED BY W. J.    FCTO 230
C           DIXON, UCLA, 1964.                                          FCTO 240
C                                                                       FCTO 250
C     ..................................................................FCTO 260
C                                                                       FCTO 270
C     THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO THE     FCTO 280
C     NUMBER OF VARIABLES, M..                                          FCTO 290
C                                                                       FCTO 300
         DIMENSION B(35),D(35),S(35),T(35),XBAR(35)                     FCTO 310
C                                                                       FCTO 320
C     THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE      FCTO 330
C     PRODUCT OF M*M..                                                  FCTO 340
C                                                                       FCTO 350
         DIMENSION V(1225)                                              FCTO 360
C                                                                       FCTO 370
C     THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO          FCTO 380
C     (M+1)*M/2..                                                       FCTO 390
C                                                                       FCTO 400
         DIMENSION R(630)                                               FCTO 410
C                                                                       FCTO 420
C     THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 51..     FCTO 430
C                                                                       FCTO 440
         DIMENSION TV(51)                                               FCTO 450
C                                                                       FCTO 460
C     ..................................................................FCTO 470
C                                                                       FCTO 480
C        IF A DOUBLE PRECISION VERSION OF THIS ROUTINE IS DESIRED, THE  FCTO 490
C        C IN COLUMN 1 SHOULD BE REMOVED FROM THE DOUBLE PRECISION      FCTO 500
C        STATEMENT WHICH FOLLOWS.                                       FCTO 510
C                                                                       FCTO 520
C     DOUBLE PRECISION XBAR,S,V,R,D,B,T,TV                              FCTO 530
C                                                                       FCTO 540
C        THE C MUST ALSO BE REMOVED FROM DOUBLE PRECISION STATEMENTS    FCTO 550
C        APPEARING IN OTHER ROUTINES USED IN CONJUNCTION WITH THIS      FCTO 560
C        ROUTINE.                                                       FCTO 570
C                                                                       FCTO 580
C        ...............................................................FCTO 590
C                                                                       FCTO 600
    1 FORMAT(21H1FACTOR ANALYSIS.....A4,A2//3X,12HNO. OF CASES,4X,I6/3X,FCTO 610
     116HNO. OF VARIABLES,I6/)                                          FCTO 620
    2 FORMAT(6H0MEANS/(8F15.5))                                         FCTO 630
    3 FORMAT(20H0STANDARD DEVIATIONS/(8F15.5))                          FCTO 640
    4 FORMAT(25H0CORRELATION COEFFICIENTS)                              FCTO 650
    5 FORMAT(4H0ROWI3/(10F12.5))                                        FCTO 660
    6 FORMAT(1H0/12H EIGENVALUES/(10F12.5))                             FCTO 670
    7 FORMAT(37H0CUMULATIVE PERCENTAGE OF EIGENVALUES/(10F12.5))        FCTO 680
    8 FORMAT(1H0/13H EIGENVECTORS)                                      FCTO 690
    9 FORMAT(7H0VECTORI3/(10F12.5))                                     FCTO 700
   10 FORMAT(1H0/16H FACTOR MATRIX (,I3,9H FACTORS))                    FCTO 710
   11 FORMAT(9H0VARIABLEI3/(10F12.5))                                   FCTO 720
   12 FORMAT(1H0/10H ITERATION,7X,9HVARIANCES/8H   CYCLE)               FCTO 730
   13 FORMAT(I6,F20.6)                                                  FCTO 740
   14 FORMAT(1H0/24H ROTATED FACTOR MATRIX (I3,9H FACTORS))             FCTO 750
   15 FORMAT(9H0VARIABLEI3/(10F12.5))                                   FCTO 760
   16 FORMAT(1H0/23H CHECK ON COMMUNALITIES//9H VARIABLE,7X,8HORIGINAL, FCTO 770
     112X,5HFINAL,10X,10HDIFFERENCE)                                    FCTO 780
   17 FORMAT(I6,3F18.5)                                                 FCTO 790
   18 FORMAT(A4,A2,I5,I2,F6.0)                                          FCTO 800
   19 FORMAT(5H0ONLY,I2,30H FACTOR RETAINED.  NO ROTATION)              FCTO 810
C                                                                       FCTO 820
C     ..................................................................FCTO 830
C                                                                       FCTO 840
C     READ PROBLEM PARAMETER CARD                                       FCTO 850
C                                                                       FCTO 860
  100 READ (5,18,END=999) PR,PR1,N,M,CON                                FCTO 870
C        PR.........PROBLEM NUMBER (MAY BE ALPHAMERIC)                  FCTO 880
C        PR1........PROBLEM NUMBER (CONTINUED)                          FCTO 890
C        N..........NUMBER OF CASES                                     FCTO 900
C        M..........NUMBER OF VARIABLES                                 FCTO 910
C        CON........CONSTANT USED TO DECIDE HOW MANY EIGENVALUES        FCTO 920
C                     TO RETAIN                                         FCTO 930
C                                                                       FCTO 940
      WRITE (6,1) PR,PR1,N,M                                            FCTO 950
C                                                                       FCTO 960
      IO=0                                                              FCTO 970
      X=0.0                                                             FCTO 980
C                                                                       FCTO 990
      CALL CORRE (N,M,IO,X,XBAR,S,V,R,D,B,T)                            FCTO1000
C                                                                       FCTO1010
C     PRINT MEANS                                                       FCTO1020
C                                                                       FCTO1030
      WRITE (6,2) (XBAR(J),J=1,M)                                       FCTO1040
C                                                                       FCTO1050
C     PRINT STANDARD DEVIATIONS                                         FCTO1060
C                                                                       FCTO1070
      WRITE (6,3) (S(J),J=1,M)                                          FCTO1080
C                                                                       FCTO1090
C     PRINT CORRELATION COEFFICIENTS                                    FCTO1100
C                                                                       FCTO1110
      WRITE (6,4)                                                       FCTO1120
      DO 120 I=1,M                                                      FCTO1130
      DO 110 J=1,M                                                      FCTO1140
      IF(I-J) 102, 104, 104                                             FCTO1150
  102 L=I+(J*J-J)/2                                                     FCTO1160
      GO TO 110                                                         FCTO1170
  104 L=J+(I*I-I)/2                                                     FCTO1180
  110 D(J)=R(L)                                                         FCTO1190
  120 WRITE (6,5) I,(D(J),J=1,M)                                        FCTO1200
C                                                                       FCTO1210
      MV=0                                                              FCTO1220
      CALL EIGEN (R,V,M,MV)                                             FCTO1230
C                                                                       FCTO1240
      CALL TRACE (M,R,CON,K,D)                                          FCTO1250
C                                                                       FCTO1260
C     PRINT EIGENVALUES                                                 FCTO1270
C                                                                       FCTO1280
      DO 130 I=1,K                                                      FCTO1290
      L=I+(I*I-I)/2                                                     FCTO1300
  130 S(I)=R(L)                                                         FCTO1310
      WRITE (6,6) (S(J),J=1,K)                                          FCTO1320
C                                                                       FCTO1330
C     PRINT CUMULATIVE PERCENTAGE OF EIGENVALUES                        FCTO1340
C                                                                       FCTO1350
      WRITE (6,7) (D(J),J=1,K)                                          FCTO1360
C                                                                       FCTO1370
C     PRINT EIGENVECTORS                                                FCTO1380
C                                                                       FCTO1390
      WRITE (6,8)                                                       FCTO1400
      L=0                                                               FCTO1410
      DO 150 J=1,K                                                      FCTO1420
      DO 140 I=1,M                                                      FCTO1430
      L=L+1                                                             FCTO1440
  140 D(I)=V(L)                                                         FCTO1450
  150 WRITE (6,9) J,(D(I),I=1,M)                                        FCTO1460
C                                                                       FCTO1470
      CALL LOAD (M,K,R,V)                                               FCTO1480
C                                                                       FCTO1490
C     PRINT FACTOR MATRIX                                               FCTO1500
C                                                                       FCTO1510
      WRITE (6,10) K                                                    FCTO1520
      DO 180 I=1,M                                                      FCTO1530
      DO 170 J=1,K                                                      FCTO1540
      L=M*(J-1)+I                                                       FCTO1550
  170 D(J)=V(L)                                                         FCTO1560
  180 WRITE (6,11) I,(D(J),J=1,K)                                       FCTO1570
C                                                                       FCTO1580
      IF(K-1) 185, 185, 188                                             FCTO1590
  185 WRITE (6,19) K                                                    FCTO1600
      GO TO 100                                                         FCTO1610
C                                                                       FCTO1620
  188 CALL VARMX (M,K,V,NC,TV,B,T,D,IER)                                FCTO1630
	IF (IER .EQ. 1) WRITE (6,998)
998	FORMAT(/' **** WARNING ****'/
	1	' CONVERGENCE NOT REACHED AFTER 50 ITERATIONS'/)
C                                                                       FCTO1640
C     PRINT VARIANCES                                                   FCTO1650
C                                                                       FCTO1660
      NV=NC+1                                                           FCTO1670
      WRITE (6,12)                                                      FCTO1680
      DO 190 I=1,NV                                                     FCTO1690
      NC=I-1                                                            FCTO1700
  190 WRITE (6,13) NC,TV(I)                                             FCTO1710
C                                                                       FCTO1720
C     PRINT ROTATED FACTOR MATRIX                                       FCTO1730
C                                                                       FCTO1740
      WRITE (6,14) K                                                    FCTO1750
      DO 220 I=1,M                                                      FCTO1760
      DO 210 J=1,K                                                      FCTO1770
      L=M*(J-1)+I                                                       FCTO1780
  210 S(J)=V(L)                                                         FCTO1790
  220 WRITE (6,15) I,(S(J),J=1,K)                                       FCTO1800
C                                                                       FCTO1810
C     PRINT COMMUNALITIES                                               FCTO1820
C                                                                       FCTO1830
      WRITE (6,16)                                                      FCTO1840
      DO 230 I=1,M                                                      FCTO1850
  230 WRITE (6,17) I,B(I),T(I),D(I)                                     FCTO1860
      GO TO 100                                                         FCTO1870
999	STOP
      END                                                               FCTO1880