1  ! PROGRAM FQRT, VERSION 1A (31-AUG-73)
   !
2  ! PROGRAM FQRT IS A PROGRAM IN THE FACTOR ANALYSIS CHAIN.
   ! IT IS ONE OF THE SEVERAL PROGRAMS AND FILES WHICH COMPOSE COSAP,
   ! LAWRENCE UNIVERSITY'S CONVERSATIONALLY ORIENTED STATISTICAL
3  ! ANALYSIS PACKAGE.  COSAP IS DISTRIBUTED FOR EDUCATIONAL USE, ON
   ! THE CONDITION THAT IT NOT BE SOLD, RENTED OR LEASED FOR PROFIT.
   !
4  ! IF YOU DESIRE FURTHER INFORMATION ABOUT COSAP, PLEASE CONTACT THE
   ! LAWRENCE UNIVERSITY COMPUTER CENTER, APPLETON, WISCONSIN, 54911
   !
10 DIM N%(30)  ! FUNCTION TO CREATE FILE EXT. BASED ON JOB#
25 DEF FNZ$ : IF N%(0)=30% THEN 40 
    ELSE CHANGE SYS(CHR$(6)+CHR$(9)+CHR$(0)) TO N% : 
   Z8$=".J"+RIGHT(NUM$(N%(1)/2%),2%)
40 FNZ$=Z8$! EXTENSION IS".J"+JOB #
55 FNEND
70 !****FQRT
85 OPEN "DAT1"+FNZ$ AS FILE 1
100 OPEN "DISC2"+FNZ$ AS FILE 2
115 OPEN "DISC1"+FNZ$ AS FILE 3
130 OPEN "TMP"+FNZ$ AS FILE 4
145 DIM#1,X(200,50),H$(30)=2,C(50,50),M4(0),M5(0),M9(0),N(0),J9(0),
        I4(0),I7(0),N6(0),X2(50),L1$(8)=32%
160 DIM#2,N2(50),M2(50),T9(0),L6(0),G9(0),L1(0)
175 DIM#3,A(50,50),X3(50,50),F9(50),S(50)
190 DIM#4,R(50,50),B(50,50),R1(50,50)
195 L6=L6(0)
235 FOR I=1 TO L6:FOR J=1 TO L6:R1(I,J)=0:NEXT J:R1(I,I)=1
250 NEXT I:A9=0:M=L6-1:FOR I=1 TO M:L=I+1:FOR J=L TO L6
265 A9=A9+A(I,J)*A(I,J):NEXT J:NEXT I:IF A9<=0 THEN 760 
280 A9=1.414*SQR(A9):A4=A9*1.0E-6/L6:I9=0:LET T8=A9
295 T8=T8/L6
310 L=1
325 M=L+1
340 IF ABS(A(L,M))<T8 THEN 655 
355 I9=1:U=.5*(A(L,L)-A(M,M))
370 Y=-A(L,M)/SQR(A(L,M)*A(L,M)+U*U):IF U>=0 THEN 400 
385 Y=-Y
400 X6=Y/SQR(2*(1+(SQR(1-Y*Y)))):X7=X6^2:C6=SQR(1-X7)
415 C7=C6^2:X8=C6*X6:FOR I=1 TO L6:IF I=L THEN 550 
430 IF I>L THEN 475 ELSE IF I>=M THEN 550 
445 U=A(I,L)*C6-A(I,M)*X6:A(I,M)=A(I,L)*X6+A(I,M)*C6
460 A(I,L)=U:GOTO 550 
475 IF I=M THEN 550 ELSE IF I>M THEN 520 
490 U=A(L,I)*C6-A(I,M)*X6:A(I,M)=A(L,I)*X6+A(I,M)*C6
505 GOTO 535 
520 U=A(L,I)*C6-A(M,I)*X6:A(M,I)=A(L,I)*X6+A(M,I)*C6
535 A(L,I)=U
550 U=R1(I,L)*C6-R1(I,M)*X6:R1(I,M)=R1(I,L)*X6+R1(I,M)*C6
565 R1(I,L)=U
580 NEXT I
595 U=2*A(L,M)*X8:Y=A(L,L)*C7+A(M,M)*X7-U
610 U=A(L,L)*X7+A(M,M)*C7+U
625 A(L,M)=(A(L,L)-A(M,M))*X8+A(L,M)*(C7-X7)
640 A(L,L)=Y:A(M,M)=U
655 IF M=L6 THEN 685 
670 M=M+1 :GOTO 340 
685 IF L=L6-1 THEN 715 
700 L=L+1:GOTO 325 
715 IF I9<>1 THEN 745 
730 I9=0:GOTO 310 
745 IF T8>A4 THEN 295 
760 FOR I=1 TO L6:F9(I)=A(I,I):NEXT I
775 FOR I=1 TO L6:FOR J=I TO L6:IF F9(I)>=F9(J) THEN 820 
790 U=F9(I):F9(I)=F9(J):F9(J)=U:FOR L=1 TO L6
805 U=R1(L,I):R1(L,I)=R1(L,J):R1(L,J)=U:NEXT L
820 NEXT J
835 NEXT I
850 FOR I=1 TOL6:FOR J=1 TO L6:A(I,J)=R1(I,J):NEXT J:NEXT I
860 T9(0)=L6
865 K$=SYS(CHR$(7)):N$=LEFT(K$,8):S0=VAL(RIGHT(K$,9))
880 CLOSE 1,2,3,4 : CHAIN N$  S0
895 END