$JOB FACTO[30,30]
$FORTRAN FACTO
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
$FORTRAN DATA
C DATA 10
C ..................................................................DATA 20
C DATA 30
C SAMPLE INPUT SUBROUTINE - DATA DATA 40
C DATA 50
C PURPOSE DATA 60
C READ AN OBSERVATION (M DATA VALUES) FROM INPUT DEVICE. DATA 70
C THIS SUBROUTINE IS CALLED BY THE SUBROUTINE CORRE AND MUST DATA 80
C BE PROVIDED BY THE USER. IF SIZE AND LOCATION OF DATA DATA 90
C FIELDS ARE DIFFERENT FROM PROBLEM TO PROBLEM, THIS SUB- DATA 100
C ROUTINE MUST BE RECOMPILED WITH A PROPER FORMAT STATEMENT. DATA 110
C DATA 120
C USAGE DATA 130
C CALL DATA (M,D) DATA 140
C DATA 150
C DESCRIPTION OF PARAMETERS DATA 160
C M - THE NUMBER OF VARIABLES IN AN OBSERVATION. DATA 170
C D - OUTPUT VECTOR OF LENGTH M CONTAINING THE OBSERVATION DATA 180
C DATA. DATA 190
C DATA 200
C REMARKS DATA 210
C THE TYPE OF CONVERSION SPECIFIED IN THE FORMAT MUST BE DATA 220
C EITHER F OR E. DATA 230
C DATA 240
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED DATA 250
C NONE DATA 260
C ..................................................................DATA 270
C DATA 280
SUBROUTINE DATA (M,D) DATA 290
C DATA 300
DIMENSION D(1) DATA 310
C DATA 320
1 FORMAT(12F6.0) DATA 330
C DATA 340
C READ AN OBSERVATION FROM INPUT DEVICE. DATA 350
C DATA 360
READ (5,1) (D(I),I=1,M) DATA 370
C DATA 380
C INPUT DATA ARE WRITTEN ON LOGICAL TAPE 13 FOR THE RESIDUAL ANALY- DATA 390
C SIS PERFORMED IN THE SAMPLE MULTIPLE REGRESSION PROGRAM. DATA 400
C DATA 410
WRITE (13) (D(I),I=1,M) DATA 420
RETURN DATA 430
END DATA 440
$DECK FAC.CDR
SAMPLE00023090001.0 20
7 7 9 7 15 36 60 15 24 30
13 18 25 15 13 35 61 18 30 40
9 18 24 23 12 43 62 14 31 50
7 13 25 36 11 12 63 26 32 60
6 8 20 7 15 46 18 28 15 70
10 12 30 11 10 42 27 12 17 80
7 6 11 7 15 35 60 20 25 90
16 19 25 16 13 30 64 20 30 100
9 22 26 24 13 40 66 15 32 110
8 15 26 30 13 10 66 25 34 120
8 10 20 8 17 40 20 30 18 130
9 12 28 11 8 45 30 15 19 140
11 17 21 30 10 45 60 17 30 150
9 16 26 27 14 31 59 19 17 160
10 15 24 18 12 29 48 18 26 170
11 11 30 19 19 26 57 20 30 180
16 9 16 20 18 31 60 21 17 190
9 8 19 14 16 33 67 9 19 200
7 18 22 9 15 37 62 11 20 210
8 11 23 18 9 36 61 22 24 220
6 6 27 23 7 40 55 24 31 230
10 9 26 26 10 37 57 27 29 240
8 10 26 15 11 42 59 20 28 250
$EOD
.ASSIGN CDR 5
.ASSIGN LPT 6
.ASSIGN DSK 13
.SET CDR FAC
.EXECUTE/REL FACTO,DATA,WES:SSP/LIB
%FIN::
.DELETE FAC.CDR,FOR13.DAT