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