Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/stp/stp7.for
There is 1 other file named stp7.for in the archive. Click here to see a list.
C *** STAT PACK ***
C SUBROUTINE FOR 2 WAY ANALYSIS OF VARIANCE.
C CALLING SEQUENCE: CALL ANOV2(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
C WHERE NV - IS THE NUMBER OF COLUMNS ACTUALLY FILLED (VARIABLES)
C NC - IS THE NUMBER OF ROWS ACTUALLY FILLED (CASES)
C MV - IS THE MAXIMUM NUMBER OF COLUMNS.
C MC - IS THE MAXIMUM NUMBER OF ROWS.
C DATA - DATA MATRIX, DIMENSIONED FOR MAXIMUM.
C VMN - IS A VECTOR CONTAINING THE MEANS.
C STD - IS A VECTOR CONTAINING THE STANDARD DEVIATIONS.
C NAMES - IS A VECTOR CONTAINING VARIABLE NAMES
C
C SUBROUTINE ALLOWS FOR EACH CELL TO BE AN INDIVIDUAL VARIABLE
C OR FOR A BREAKDOWN ON THE VALUE OF ANOTHER VARIABLE TO DETERMINE
C THE CELLS. THIS PARTICULAR ANOV IS USED SINCE IT DOES ALLOW
C EMPTY CELLS OR AN UNBALANCED DESIGN. ORIGINALLY WRITTEN
C AT W. M. U. BY EVA GAINES, UNDER DIRECTION OF MICHEAL STOLINE,
C IT WAS MODIFIED DURING THE SUMMER OF 71 BY SAM ANEMA,
C THE VERSION NOW IN STP IS A FURTHUR MODIFICATION OF THAT
C PROGRAM. ORIGINAL VERSION IS BASED ON BOOK BY BANCROFT
C "INTERMEDIATE STATISTICAL METHODS".
C
SUBROUTINE ANOV2(NV,NC,MV,MC,DATA,VMN,STD,NAMES)
DIMENSION DATA(MC,MV), VMN(1), STD(1), OPT(5), OPTD(5)
COMMON /DEV/ ICC, IDATA, IOUT, IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON/EXTRA/HEDR(70),NSZ
DIMENSION YS(20,20),Y1(20),Y2(20),S1(20),S2(20),B1(20)
DIMENSION T(20,20),C(20),AM(20),YT(20,20),IBK(2),BRNG(2,20,2)
DIMENSION NGRPS(2),IVA(120)
DIMENSION ICELLS(40),NAMES(1)
EQUIVALENCE (NGRPS(1),NGRPA),(NGRPS(2),NGRPB)
EQUIVALENCE (IBK(1),IBK1),(IBK(2),IBK2)
EQUIVALENCE (IVA,ICELLS),(IVA(41),BRNG)
ISQ=7
IF(IOUT.EQ.21) ISQ=15
ALL=0
5 IF(ICC.NE.2) WRITE (IDLG,1)
OPTD(1)=0
OPTD(2)=0
OPTD(3)=0
OPTD(4)=0
OPTD(5)=0
NGRPS(1)=20
NGRPS(2)=20
1 FORMAT ('0LIST OPTIONS SEPARATED BY COMMAS'/)
READ (ICC,3) OPT
2 FORMAT ('0THE 2 WAY ANALYSIS OF VARIANCE ASSUMES
1 CELLS TO '/' BE MADE UP OF INDIVIDUAL VARIABLES
2.'/' IT IS POSSIBLE HOWEVER TO BREAK
3 1 VARIABLE INTO'/' CELLS, BY MEANS OF
4 TWO OTHER VARIABLES.'/' IN THIS CASE, RANGES
5 FOR BREAK-DOWNS ARE ASSUMED'/' TO BE SUPPLIED
6 BY THE USER. WHEN THE PROGRAM'/' CALLS FOR
7 THE RANGES, THE USER MAY SPECIFY ANOTHER'/' OPTION
8 WHICH ALLOWS THE PROGRAM TO AUTOMATICALLY FORM'/' THE
9 BREAKDOWNS BY INDIVIDUAL VALUES OF THE')
632 FORMAT(' BREAKDOWN VARIABLE. IF MORE VALUES'/
2 ' EXIST THAN GROUPS, THE PROGRAM AUTOMATICALLY'/' FORMS
3 THE RANGES FOR BREAKDOWN'/ ' OPTIONS ARE:'/
5 ' "BREAK" - FORM GROUPINGS BASED ON VALUES OF BREAKDOWN
6 VARIABLES.'/' "GROUP" - SPECIFY MAXIMUM NUMBER OF GROUPS
7 (PRESET TO 20) MAXIMUM OF 20.'/' "AUTO" - AUTOMATIC BREAKDOWN
8 (SPECIFY THIS ONLY WHEN ASKED FOR RANGES)'/' "DISCR" - BOTH',
8' GROUPS ARE AUTO (SPECIFY NOW)'/' "HEADR" -',
9' OMIT SIZE, MEANS, AND STD. DEV. REPORT'/' "RANGE" - TYPE OUT',
1' RANGES FOR BREAKDOWNS IF AUTOMATICALLY FORMED'/
2'0IF NO OPTIONS ARE DESIRED TYPE A RETURN')
3 FORMAT (5(A5,1X))
IF(OPT(1).EQ.'!') RETURN
DO 4 I=1,5
IF (OPT(I).EQ.' ') GO TO 10
IF (OPT(I).NE.'HELP') GO TO 6
WRITE (IDLG,2)
WRITE(IDLG,632)
GO TO 5
6 IF (OPT(I).NE.'BREAK') GO TO 7
OPTD(1)=1
GO TO 4
7 IF (OPT(I).NE.'GROUP') GO TO 90
OPTD(2)=1
GO TO 4
90 IF(OPT(I).NE.'HEADR') GO TO 308
OPTD(3)=1
GO TO 4
308 IF(OPT(I).NE.'DISCR') GO TO 508
OPTD(4)=1
GO TO 4
508 IF(OPT(I).NE.'RANGE') GO TO 509
OPTD(5)=1
GO TO 4
509 IF(OPT(I).NE.'AUTO') GO TO 512
510 WRITE(IDLG,511)
511 FORMAT(' "AUTO" ONLY SPECIFIED WHEN RANGES ARE CALLED FOR')
GO TO 5
512 IF(OPT(I).EQ.'AUTO,') GO TO510
8 WRITE (IDLG,9) OPT(I)
9 FORMAT ('0OPTION ',A5,' DOES NOT EXIST TRY AGAIN')
GO TO 5
4 CONTINUE
10 IF (OPTD(1).EQ.1) GO TO 30
C
C CELLS INDIVIDUAL VARIABLES.
C
11 IF(ICC.NE.2) WRITE (IDLG,12)
12 FORMAT ('0HOW MANY CELLS IN FACTOR 1? ',$)
READ (ICC,13) NGRPA
13 FORMAT(I)
IF (NGRPA.LE.20) GO TO 15
WRITE (IDLG,14)
14 FORMAT ('0MAXIMUM OF 20')
GO TO 11
15 IF(ICC.NE.2) WRITE (IDLG,16)
16 FORMAT ('0HOW MANY CELLS IN FACTOR 2? ',$)
READ (ICC,13) NGRPB
IF (NGRPB.LE.20) GO TO 18
WRITE (IDLG,14)
GO TO 15
18 IF(ICC.NE.2) WRITE (IDLG,19)
19 FORMAT ('0TYPE IN EACH VARIABLE AFTER THE'/
1' CORRESPONDING LEVEL, "EMPTY"-INDICATES EMPTY CELL')
XT=NC
L=-1
DO 26 I=1,NGRPA
DO 26 J=1,NGRPB
22 IF(ICC.NE.2) WRITE (IDLG,21)I,J
21 FORMAT ('0CELL('I2,',',I2,')? ',$)
IRET=-99
CALL ALPHA(ICELL,1,K,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IHELP.EQ.1) GO TO 22
IF(IERR.EQ.1) GO TO 22
IF(ICELL.GE.0) GO TO 441
L=L-1
IF(L.GE.-NV) GO TO 28
445 WRITE(IDLG,27)
27 FORMAT(' TOO MANY CELLS FOR THE NUMBER OF VARIABLES')
GO TO 11
28 ICELL=L
GO TO 24
441 K=(I-1)*NGRPB+J-1
IF(K.LT.1) GO TO 24
DO 442 II=1,K
IF(IVA(II).LE.0) GO TO 442
IF(IVA(II).NE.ICELL) GO TO 442
WRITE(IDLG,443)
443 FORMAT(' THIS VARIABLE USED PREVIOUSLY')
GO TO 22
442 CONTINUE
24 K=(I-1)*NGRPB+J
26 IVA(K)=ICELL
NGPALL=NGRPA*NGRPB
K=0
DO 421 I=1,NGPALL
IF(IVA(I).EQ.0) GOTO 421
K=K+1
421 CONTINUE
IF(K.GT.NV) GO TO 445
GOTO 408
400 J=NGPALL
404 IF(IVA(J).GT.0) GO TO 405
IVA(J)=IVA(J)-1
IF(IVA(J).GE.-NV) GO TO 406
405 J=J-1
IF(J.GE.1) GO TO 404
RETURN
406 K=IVA(J)
IF(J.EQ.NGPALL) GO TO 408
DO 407 I=J+1,NGPALL
IF(IVA(I).GT.0) GO TO 407
K=K-1
IF(K.LT.-NV) GO TO 405
IVA(I)=K
407 CONTINUE
408 DO 403 I=1,NGPALL-1
DO 403 J=I+1,NGPALL
IF((IVA(I).EQ.0).OR.(IVA(J).EQ.0)) GO TO 403
IF(IVA(I).LT.0) GO TO 409
IF(IVA(J).GT.0) GOTO 410
GO TO 411
409 IF(IVA(J).LT.0) GO TO 410
411 IF(IVA(J).EQ.-IVA(I)) GO TO 400
GO TO 403
410 IF(IVA(J).EQ.IVA(I)) GO TO 400
403 CONTINUE
DO 88 I=1,20
AM(I)=0
Y1(I)=0
S1(I)=0
C(I)=0
B1(I)=0
S2(I)=0
Y2(I)=0
DO 88 J=1,20
T(I,J)=0
YT(I,J)=0
88 YS(I,J)=0
RAB=0
SST=0
SS=0
G=0
SSC=0
SSAB=0
AN=0
SSBA=0
TW=0
TC=0
DO 20 I=1,NGRPA
DO 25 J=1,NGRPB
K=(I-1)*NGRPB+J
ICELL=IVA(K)
IF(ICELL.EQ.0) GO TO 20
IF(ICELL.LT.0) ICELL=-ICELL
23 TC=TC+1.
TW=TW+XT-1.
YT(I,J)=VMN(ICELL)*XT
T(I,J)=XT
YS(I,J)=((STD(ICELL)**2)*(XT*(XT-1.))+YT(I,J)**2)/XT
Y1(I)=Y1(I)+YT(I,J)
S1(I)=S1(I)+T(I,J)
SSC=SSC+(YT(I,J)*YT(I,J))/T(I,J)
SST=SST+YS(I,J)
25 CONTINUE
IF(S1(I).EQ.0) GO TO 20
SSAB=SSAB+(Y1(I)**2)/S1(I)
SS=SS+S1(I)
20 G=G+Y1(I)
GO TO 70
C
C CELLS ON INDIV. VAR. BY BREAK-DOWN.
C
30 IF (OPTD(2).NE.1) GO TO 36
31 IF(ICC.NE.2) WRITE (IDLG,32)
32 FORMAT ('0MAXIMUM NUMBER OF GROUPS FOR LEVEL 1? ',$)
READ (ICC,13) NGRPA
IF ((NGRPA.GT.1).AND.(NGRPA.LE.20)) GO TO 34
WRITE (IDLG,33)
33 FORMAT ('0NO. OF GROUPS SPECIFIED WAS EITHER LESS THAN 1'/
1' OR GREATTER THAN THE MAXIMUM (20)')
GO TO 31
34 IF(ICC.NE.2) WRITE (IDLG,35)
35 FORMAT ('0MAXIMUM NUMBER OF GROUPS FOR LEVEL 2? ',$)
READ (ICC,13) NGRPB
IF ((NGRPB.GT.1).AND.(NGRPB.LE.20)) GO TO 36
WRITE (IDLG,33)
GO TO 34
36 IF(ICC.NE.2) WRITE (IDLG,38)
38 FORMAT ('0WHICH VARIABLES ARE TO BE ANALYSED? ',$)
CALL ALPHA(ICELLS,40,NZZ,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IHELP.EQ.1) GO TO 36
IF(IERR.EQ.1) GO TO 36
DO 302 I=1,NZZ
IF(ICELLS(I).NE.-1) GO TO 302
ALL=1
NZZ=NV
GO TO 39
302 CONTINUE
39 DO 40 I=1,2
42 IF(ICC.NE.2) WRITE (IDLG,41) I
41 FORMAT ('0WHICH VARIABLE IS BREAKDOWN VARIABLE',I2,'? ',$)
CALL ALPHA(ICELL,1,J,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IHELP.EQ.1) GO TO 42
IF(IERR.EQ.1) GO TO 42
IF(ICELL.GT.0)GO TO 40
WRITE(IDLG,450)
450 FORMAT(' *, ?, ALL MAY NOT BE USED HERE')
GO TO 42
40 IBK(I)=ICELL
DO 45 I=1,2
IF(OPTD(4).EQ.1) GO TO 50
44 IF(ICC.NE.2) WRITE (IDLG,46) NAMES(IBK(I))
46 FORMAT ('0LIST THE RANGES FOR BREAKDOWN VARIABLE: ',A5/)
DO 43 J=1,20
57 READ (ICC,47,END=37,ERR=37) HELP
47 FORMAT (A4,70X)
IF(HELP.EQ.' ') GO TO 37
IF(HELP.EQ.'!') RETURN
IF (HELP.NE.'HELP') GO TO 59
WRITE (IDLG,48)
48 FORMAT ('IF AUTOMATIC BREAK-DOWN BY GROUPS IS DESIRED TYPE "AUTO",
1'/' OTHERWISE ENTER THE RANGE FOR EACH BREAK-DOWN SMALLER FIRST,
2 1 PER LINE.'/'EXAMPLE:'/'17,35.2'/'CONTROL Z (^Z) WILL TERMINATE
3 ENTRY')
GO TO 44
59 IF (HELP.NE.'AUTO') GO TO 55
300 IF (J.EQ.1) GO TO 50
WRITE (IDLG,49)
49 FORMAT ('0AUTO CAN ONLY BE SPECIFIED FIRST TIME'/' CONFUSION
1 START OVER WITH SAME VARIABLE')
GO TO 44
55 REREAD 56, BRNG(I,J,1),BRNG(I,J,2)
56 FORMAT (2F)
IF (BRNG(I,J,1).LE.BRNG(I,J,2)) GO TO 43
WRITE (IDLG,58)
58 FORMAT (' SMALLER FIRST, PLEASE RETYPE'/)
GO TO 57
43 CONTINUE
J=J+1
37 NGRPS(I)=J-1
IF(NGRPS(I).LT.1) RETURN
GO TO 45
50 XMAX=-10.**11
XMIN=10.**11
N=0
L=IBK(I)
DO 51 K=1,NC
IF (XMAX.LT.DATA(K,L))XMAX=DATA(K,L)
IF (XMIN.GT.DATA(K,L))XMIN=DATA(K,L)
IF (N.GT.20) GO TO 51
IF (N.LT.1) GO TO 53
DO 52 M=1,N
IF (DATA(K,L).EQ.BRNG(I,M,1)) GO TO 51
52 CONTINUE
53 N=N+1
IF(N.GT.20) GO TO 51
BRNG (I,N,1)=DATA(K,L)
BRNG (I,N,2)=DATA(K,L)
51 CONTINUE
IF (N.LT.NGRPS(I)) NGRPS(I)=N
IF (N.EQ.NGRPS(I)) GO TO 89
XT=NGRPS(I)
RG=(XMAX-XMIN)/XT
BRNG(I,1,1)=XMIN
BRNG(I,1,2)=XMIN+RG
DO 54 K=2,NGRPS(I)
BRNG(I,K,1)=BRNG(I,K-1,2)
BRNG(I,K,2)=BRNG(I,K,1)+RG
54 CONTINUE
BRNG(I,NGRPS(I),2)=XMAX
89 IF(OPTD(5).NE.1) GO TO 420
IF(OPTD(4).EQ.1) WRITE(IDLG,301) NAMES(IBK(I))
301 FORMAT('0BREAKDOWN RANGES FOR VARIABLE: ',A5/)
C *******************************************************
C SORT BEFORE PUTTING OUT RANGES (BUBBLE SORT BECAUSE OF SIZE)
C
420 J=0
310 J=J+1
IF(J.EQ.NGRPS(I)) GO TO 312
TAB=BRNG(I,J+1,1)
TBA=BRNG(I,J+1,2)
IF(BRNG(I,J,1).LT.TAB) GO TO 310
K=J
311 BRNG(I,K+1,1)=BRNG(I,K,1)
BRNG(I,K+1,2)=BRNG(I,K,2)
K=K-1
IF(K.LT.1) GO TO 313
IF(TAB.LT.BRNG(I,K,1)) GO TO 311
313 BRNG(I,K+1,1)=TAB
BRNG(I,K+1,2)=TBA
GO TO 310
C ***********************************************************
312 IF(OPTD(5).NE.1) GO TO45
DO 71 J=1,NGRPS(I)
71 WRITE(IDLG,72)(BRNG(I,J,K),K=1,2)
72 FORMAT('+',G10.4,',',G10.4/)
GO TO 45
45 CONTINUE
C
C AT THIS POINT RANGES HAVE BEEN DET.
C BREAK DOWN VARIABLES
C
DO 2000 KCELL=1,NZZ
IF(ALL.EQ.1) GO TO 306
ICELL=ICELLS(KCELL)
GO TO 305
306 IF((KCELL.EQ.IBK1).OR.(KCELL.EQ.IBK2)) GO TO 2000
ICELL=KCELL
305 DO 388 I=1,20
AM(I)=0
Y1(I)=0
S1(I)=0
C(I)=0
B1(I)=0
S2(I)=0
Y2(I)=0
DO 388 J=1,20
T(I,J)=0
YT(I,J)=0
388 YS(I,J)=0
RAB=0
SST=0
SS=0
G=0
SSC=0
SSAB=0
AN=0
SSBA=0
TW=0
TC=0
DO 60 I=1,NC
C ----------------------------------------------------
C WHICH RANGE IN BREAKDOWN VARIABLE 1 DOES IT BELONG TO
DO 61 J=1,NGRPA
IF (DATA(I,IBK1).LT.BRNG(1,J,1)) GO TO 61
IF (DATA(I,IBK1).GT.BRNG(1,J,2)) GO TO 61
C -----------------------------------------------------------
C WHICH RANGE IN BREAKDOWN VARIABLE 2 DOES IT BELONG
62 DO 63 K=1,NGRPB
IF (DATA(I,IBK2).LT.BRNG(2,K,1)) GO TO 63
IF (DATA(I,IBK2).GT.BRNG(2,K,2)) GO TO 63
C --------------------------------------------------------
C ADD IT INTO THE CORRECT TOTALS
64 YT(J,K)=YT(J,K)+DATA(I,ICELL)
YS(J,K)=YS(J,K)+DATA(I,ICELL)**2
T(J,K)=T(J,K)+1.
GO TO 60
63 CONTINUE
GO TO 60
61 CONTINUE
60 CONTINUE
92 DO 65 I=1,NGRPA
DO 66 J=1,NGRPB
IF(T(I,J).EQ.0) GO TO 66
TC=TC+1
TW=TW+T(I,J)-1.
Y1(I)=Y1(I)+YT(I,J)
S1(I)=S1(I)+T(I,J)
SSC=SSC+YT(I,J)**2/T(I,J)
SST=SST+YS(I,J)
66 CONTINUE
IF(S1(I).EQ.0) GO TO 65
SSAB=SSAB+(Y1(I)*Y1(I))/S1(I)
SS=SS+S1(I)
65 G=G+Y1(I)
GO TO 70
C
C BEGIN ANALYSIS OF VARIANCE.
C
70 N1=NGRPA
N2=NGRPB
DO 93 J=1,N2
DO 93 I=1,N1
93 S2(J)=S2(J)+T(I,J)
SWTCH=0
DO 73 I=1,N1
IF(S1(I).NE.0) GO TO 73
IF(SWTCH.EQ.1) GO TO 75
WRITE(IDLG,74)
SWTCH=1
74 FORMAT('OTHE FOLLOWING LEVELS ARE EMPTY - WILL BE ELIMIN.')
75 WRITE(IDLG,76) I
76 FORMAT(' FACTOR 1 LEVEL',I3)
73 CONTINUE
DO 77 J=1,N2
IF(S2(J).NE.0) GO TO 77
IF(SWTCH.EQ.1) GO TO 78
WRITE(IDLG,74)
SWTCH=1
78 WRITE(IDLG,79) J
79 FORMAT(' FACTOR 2 LEVEL',I3)
77 CONTINUE
IF(SWTCH.EQ.0) GO TO 80
81 DO 82 I=1,NGRPA
IF(S1(I).NE.0) GO TO 82
NGRPA=NGRPA-1
IF(I.GT.NGRPA) GO TO 84
DO 83 K=I,NGRPA
DO 83 J=1,NGRPB
YT(K,J)=YT(K+1,J)
YS(K,J)=YS(K+1,J)
T(K,J)=T(K+1,J)
S1(K)=S1(K+1)
83 CONTINUE
GO TO 81
82 CONTINUE
84 DO 85 J=1,NGRPB
IF(S2(J).NE.0) GO TO 85
NGRPB=NGRPB-1
IF(J.GT.NGRPB) GO TO 87
DO 86 K=J,NGRPB
DO 86 I=1,NGRPA
YT(I,K)=YT(I,K+1)
YS(I,K)=YS(I,K+1)
T(I,K)=T(I,K+1)
S2(K)=S2(K+1)
86 CONTINUE
GO TO 84
85 CONTINUE
87 DO 91 I=1,20
Y1(I)=0
AM(I)=0
S1(I)=0
C(I)=0
B1(I)=0
S2(I)=0
91 Y2(I)=0
RAB=0
SST=0
SS=0
G=0
SSC=0
SSAB=0
AN=0
SSBA=0
TW=0
TC=0
GO TO 92
80 DO 100 J=1,N2
DO 101 I=1,N1
IF(T(I,J).EQ.0) GO TO 101
102 Y2(J)=Y2(J)+YT(I,J)
YS(I,J)=YS(I,J)-(YT(I,J)*YT(I,J))/T(I,J)
IF(T(I,J).EQ.1.) GO TO 101
106 YS(I,J)=YS(I,J)/(T(I,J)-1.)
IF(YS(I,J).LT.0) YS(I,J)=0.
YS(I,J)=SQRT(YS(I,J))
YT(I,J)=YT(I,J)/T(I,J)
101 CONTINUE
SSBA=SSBA+(Y2(J)*Y2(J))/S2(J)
100 CONTINUE
G1=(G*G)/SS
SST=SST-G1
SSC=SSC-G1
SSAB=SSAB-G1
SSBA=SSBA-G1
SSW=SST-SSC
NP=0
NP=NP+1
IF(TC.EQ.1.) GO TO 149
104 SMC=SSC/(TC-1.)
NP=NP+1
ITYPE=0
IF(TW.EQ.0) ITYPE=1
105 IF(ITYPE.EQ.1) GO TO 505
SMW=SSW/TW
NP=NP+1
IF(SMW.EQ.0) GO TO 149
103 F=SMC/SMW
505 IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,321)
321 FORMAT('0',15X,'*****2-WAY ANOVA*****')
LINES=4
IF(OPTD(1).NE.1) GO TO 323
WRITE(IOUT,320)NAMES(ICELL),NAMES(IBK1),NAMES(IBK2)
320 FORMAT(' ANALYSIS RUN ON VARIABLE: ',A5,' WITH CELLS DETERMINED'/
1' BY BREAKDOWNS ON VARIABLE: ',A5,' AND VARIABLE: ',A5)
LINES=LINES+2
323 IF(OPTD(3).EQ.1) GO TO 155
LINES=LINES+3+(N2+ISQ-1)/ISQ
324 WRITE (IOUT,107)
107 FORMAT('0FACTOR'/2X,'ONE',25X,'FACTOR TWO')
DO 322 K=1,N2,ISQ
NEND=K+ISQ-1
IF(NEND.GT.N2) NEND=N2
322 WRITE(IOUT,108)(I,I=K,NEND)
108 FORMAT(' LEVEL',5X,15(4X,I3,1X))
DO 116 I=1,N1
IF(IOUT.NE.21) GO TO 325
LINES=LINES+3*((N1+ISQ-1)/ISQ)+1
IF(LINES.LE.LINPP) GO TO 325
CALL PRNTHD
WRITE(IOUT,107)
DO 326 K=1,N2,ISQ
NEND=K+ISQ-1
IF(NEND.GT.N2) NEND=N2
326 WRITE(IOUT,108)(IK,IK=K,NEND)
LINES=5+((N2+ISQ-1)/ISQ)*4+1
325 DO 116 K=1,N2,ISQ
NEND=K+ISQ-1
IF(NEND.GT.N2) NEND=N2
IF(K.EQ.1) GO TO 112
WRITE(IOUT,110)(T(I,J),J=K,NEND)
110 FORMAT('0',5X,'N',4X,15F8.2)
GO TO 111
112 WRITE (IOUT,113)I,(T(I,J),J=K,NEND)
113 FORMAT('0',I3,2X,'N',4X,15F8.2)
111 WRITE (IOUT,114)(YT(I,J),J=K,NEND)
114 FORMAT(6X,'MEAN',1X,15F8.2)
115 WRITE (IOUT,154)(YS(I,J),J=K,NEND)
154 FORMAT(6X,'STDV',1X,15F8.2)
116 CONTINUE
IF(ITYPE.EQ.1) GO TO 335
155 IF(IOUT.NE.21) GO TO 327
LINES=LINES+9
IF(LINES.LE.LINPP) GO TO 327
CALL PRNTHD
LINES=11
327 WRITE (IOUT,117)
117 FORMAT(//24X,'PRELIMINARY ANOVA')
WRITE (IOUT,118)
118 FORMAT(6X,'SOURCE',11X,'DF',8X,'SS',8X,'MS',8X,'F',4X,'PROB')
KK=TC-1.
NDG=TW
PROB=FISHER(KK,NDG,F)
WRITE (IOUT,119)KK,SSC,SMC,F,PROB
119 FORMAT(6X'CELLS',9X,I5,3F10.2,2X,F6.4)
KK=N1-1
I=1
J=2
WRITE (IOUT,120)I,J,KK,SSAB
120 FORMAT(4X,I1,' IGNORING',I2,4X,I5,F10.2)
KK=N2-1
WRITE (IOUT,120)J,I,KK,SSBA
KK=TW
WRITE (IOUT,121)KK,SSW,SMW
121 FORMAT(6X,'WITHIN',8X,I5,2F10.2)
KK=SS-1.
WRITE (IOUT,122)KK,SST
122 FORMAT(6X,'TOTAL',9X,I5,F10.2)
335 DO 125 I=1,N2
DO 125 J=1,N2
YT(I,J)=0.
IF(I-J)124,123,124
123 YS(I,J)=1.
GO TO 125
124 YS(I,J)=0.
125 CONTINUE
DO 128 I=1,N2
DO 128 J=1,N2
DO 128 K=1,N1
IF(S1(K))128,126,128
126 TYPE 127,K,S1(K)
127 FORMAT(3HS1(,I3,2H)=,F6.0)
128 YT(I,J)=YT(I,J)+(T(K,I)*T(K,J))/S1(K)
DO 129 I=1,N2
129 YT(I,I)=YT(I,I)-S2(I)
DO 133 J=1,N2
130 DO 132 K=1,N1
IF(S1(K))132,131,132
131 TYPE 127,K,S1(K)
132 C(J)=C(J)+(T(K,J)*Y1(K))/S1(K)
YT(N2,J)=1.
133 C(J)=C(J)-Y2(J)
C(N2)=0.
C
C *************************************************************
C INVERSE BY LINEAR ROW TRANSFORMATION
C
DO 202 I=1,N2
DO 201 J=1,N2
201 YS(I,J)=0
202 YS(I,I)=1.
DO 210 I=1,N2
IF(((YT(I,I)+100.)-100.).NE.0.0) GO TO 220
IF(I.EQ.N2) GO TO 260
DO 211 J=I+1,N2
IF(((YT(J,I)+100.)-100.).NE.0.0) GO TO 212
211 CONTINUE
260 WRITE(IDLG,261)
261 FORMAT('0INVERSE DOES NOT EXIST')
GO TO 1000
212 DO 213 K=1,N2
YT(I,K)=YT(I,K)+YT(J,K)
213 YS(I,K)=YS(I,K)+YS(J,K)
220 GOB=YT(I,I)
DO 221 J=1,N2
YT(I,J)=YT(I,J)/GOB
221 YS(I,J)=YS(I,J)/GOB
DO 230 L=1,N2
IF(L.EQ.I) GO TO 230
GOB=YT(L,I)
DO 231 J=1,N2
YT(L,J)=YT(L,J)-GOB*YT(I,J)
231 YS(L,J)=YS(L,J)-GOB*YS(I,J)
230 CONTINUE
210 CONTINUE
C ***********************************************************
C
270 DO 134 J=1,N2
DO 134 K=1,N2
134 B1(J)=B1(J)+YS(J,K)*C(K)
DO 138 I=1,N1
DO 135 J=1,N2
135 AM(I)=AM(I)+T(I,J)*B1(J)
AM(I)=Y1(I)-AM(I)
IF(S1(I))137,136,137
136 TYPE 127,I,S1(I)
137 AM(I)=AM(I)/S1(I)
138 AN=AN+AM(I)
P1=N1
AN=AN/P1
DO 139 I=1,N1
A=AM(I)-AN
139 RAB=RAB+A*Y1(I)
DO 140 J=1,N2
140 RAB=RAB+B1(J)*Y2(J)
RAB=RAB+AN*G-G1
SI=SSC-RAB
P2=N2
TI=TC-P1-P2+1.
MP=0
MP=MP+1
IF(TI)141,151,141
141 SMI=SI/TI
TAB=RAB-SSBA
MP=MP+1
IF(P1-1.)142,151,142
142 TMAB=TAB/(P1-1.)
TBA=RAB-SSAB
MP=MP+1
IF(P2-1.)143,151,143
143 TMBA=TBA/(P2-1.)
MP=MP+1
NDG=TW
IF(ITYPE.EQ.1) NDG=TI
IF (ITYPE.EQ.1) SMW=SMI
IF(SMW)144,151,144
144 FI=SMI/SMW
FA=TMAB/SMW
FB=TMBA/SMW
IF(IOUT.NE.21) GO TO 328
LINES=LINES+10
IF(LINES.LE.LINPP) GO TO 328
CALL PRNTHD
LINES=10
328 WRITE (IOUT,145)
145 FORMAT(//29X11HFINAL ANOVA)
WRITE (IOUT,118)
KK=TC-1.
WRITE (IOUT,119)KK,SSC
KK=P1-1.
I=1
J=2
PROB=FISHER(KK,NDG,FA)
WRITE (IOUT,146)I,J,KK,TAB,TMAB,FA,PROB
146 FORMAT(3XI1,12H ELIMINATING,I2,2X,I5,3F10.2,2X,F6.4)
KK=P2-1.
PROB=FISHER(KK,NDG,FB)
WRITE (IOUT,147)J,I,KK,TBA,TMBA,FB,PROB
147 FORMAT(3XI1,12H ELIMINATING,I2,2X,I5,3F10.2,2X,F6.4)
KK=TI
IF(ITYPE.EQ.0) PROB=FISHER(KK,NDG,FI)
IF(ITYPE.EQ.0)WRITE (IOUT,148)I,J,KK,SI,SMI,FI,PROB
IF(ITYPE.EQ.1) WRITE(IOUT,148)I,J,KK,SI,SMI
148 FORMAT(6XI1,3H BY,I2,8X,I5,3F10.2,2X,F6.4)
KK=TW
IF(ITYPE.EQ.0)WRITE (IOUT,121)KK,SSW,SMW
KK=SS-1.
WRITE (IOUT,122)KK
GO TO 1000
C VALUES OF NP MAY BE 1,2,3
C 1 IMPLIES TC-1=0,2 IMPLIES TW=0,3 IMPLIES SMW=0
149 TYPE 150,NP
150 FORMAT(3HNP=,I2)
GO TO(104,105,103),NP
C VALUES OF MP MAY BE 1,2,3,4
C 1 IMPLIES TI=0,2 IMPLIES P1-1=0,3 IMPLIES P2-1=0,4 IMPLIES SMW=0
151 TYPE152,MP
152 FORMAT(3HMP=,I2)
GO TO(141,142,143,144),MP
1000 IF(OPTD(1).NE.1) GO TO 400
2000 CONTINUE
RETURN
END
C *** STAT PACK ***
C SUBROUTINE FOR FRIEDMAN TWO-WAY ANALYSES OF VARIANCE
C CALLING SEQUENCE: CALL FRIED(NV,NC,MV,MC,DATA,SUM,RANK,NAMES)
C WHERE: NV - NUMBER OF VARIABLES USED
C NC - NUMBER OF OBSERVATIONS USED
C MV - MAXIMUM NUMBER OF VARIABLES ALLOWED
C MC - MAXIMUM NUMBER OF OBSERVATIONS ALLOWED
C DATA - MATRIX CONTAINING DATA
C SUM - EXTRA VECTOR AT LEAST NV LONG
C RANK - EXTRA VECTOR AT LEAST NV LONG
C NAMES - VECTOR CONTAINING VARIABLE NAMES
C
C ROUTINE SUGGESTED TO BE INCLUDED IN STAT PACK BY LONNIE
C HANNAFORD (SPECIAL EDUCATION) AND ULDIS SMIDCHENS (EDUCATION).
C SOURCE IS NON PARAMETRIC STATISTICS BY SIEGEL PAGES 166-172.
C
SUBROUTINE FRIED(NV,NC,MV,MC,DATA,SUM,RANK,NAMES)
DIMENSION DATA(MC,MV),SUM(1),RANK(1),IV(20),IVB(20),NAMES(1)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON /EXTRA/ HEDR(70),NSZ
1 IF(ICC.NE.2) WRITE(IDLG,2)
2 FORMAT(' WHICH VARIABLES? '$)
CALL ALPHA(IV,20,N,IRET,IHELP,IERR,NAMES,NV)
IF(IRET.EQ.1) RETURN
IF(IERR.EQ.1) GO TO 1
IF(IHELP.NE.1) GO TO 4
WRITE(IDLG,3)
3 FORMAT('0ENTER UP TO 20 VARIABLES FOR THE FRIEDMAN TWO-WAY'/
1' ANALYSIS OF VARIANCE. VARIABLE NAMES OR NUMBERS'/
2' MAY BE USED TO INDICATED THE VARIABLES. RANGES OF'/
3' VARIABLES MAY BE ENTERED BY TYPING THE EXTREMES OF THE RANGE'/
4' SEPARATED BY A MINUS. THE ASTERIK MAY BE USED IN ONE'/
5' OR MORE POSITIONS TO INDICATED ALL POSSIBLE COMBINATIONS.')
GO TO 1
4 IF(N.LT.2) RETURN
DO 5 I=1,N-1
IF(IV(I).LE.0) GO TO 5
DO 6 J=I+1,N
IF(IV(I).NE.IV(J)) GO TO 6
WRITE(IDLG,7) NAMES(IV(J))
7 FORMAT(' SAME VARIABLE (',A5,') LISTED TWICE')
GO TO 1
6 CONTINUE
5 CONTINUE
C
C OK NOW INSERT FOR * AND ALL.
C
K=1
DO 8 I=1,N
IVB(I)=IV(I)
IF(IV(I).GT.0) GO TO 8
IVB(I)=K
K=K+1
8 CONTINUE
GO TO 18
C
C RETURN HERE TO PICK UP NEXT SET OF VARIABLES
C
10 J=N
14 IF(IV(J).GT.0) GO TO 15
IVB(J)=IVB(J)+1
IF(IVB(J).LE.NV) GO TO 16
15 J=J-1
IF(J.GE.1) GO TO 14
RETURN
16 K=IVB(J)
IF(J.EQ.N) GO TO 18
DO 17 I=J+1,N
IF(IV(I).GT.0) GO TO 17
K=K+1
IF(K.GT.NV) GO TO 15
IVB(I)=K
17 CONTINUE
18 DO 13 I=1,N-1
DO 13 K=I+1,N
IF(IVB(I).EQ.IVB(K)) GO TO 14
13 CONTINUE
C
C BEGIN THE FRIEDMAN ANALYSIS OF VARIANCE
C
DO 19 I=1,N
19 SUM(I)=0
DO 20 J=1,NC
DO 21 I=1,N
21 RANK(I)=DATA(J,IVB(I))
C
C RANKING ( ONLY 20 MAX, SO SORT RANK METHOD NOT USED )
C
DO 22 I=1,N
SAME=1.
ALESS=0
DO 23 K=1,N
IF(RANK(K).GT.RANK(I)) GO TO 23
IF(RANK(K).LT.RANK(I)) GO TO 24
SAME=SAME+1
GO TO 23
24 ALESS=ALESS+1.
23 CONTINUE
22 SUM(I)=SUM(I)+ALESS+SAME/2.
20 CONTINUE
C
C RANKING COMPLETE NOW CALCULATE THE CHI SQUARE
C
IF(IOUT.NE.21) WRITE(IOUT,5566) (HEDR(J),J=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,31)
31 FORMAT('0',8X,'**** FRIEDMAN TWO-WAY ANALYSIS OF VARIANCE ****'/
1'0VARIABLE SUM OF RANKS'/' ======== ============')
LINES=7
TOTSQ=0
DO 30 I=1,N
IF(IOUT.NE.21) GO TO 36
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 36
CALL PRNTHD
WRITE(IOUT,31)
LINES=8
36 WRITE(IOUT,32) NAMES(IVB(I)),SUM(I)
32 FORMAT(2X,A5,5X,F10.2)
30 TOTSQ=TOTSQ+SUM(I)**2
FRIED=(12./(NC*N*(N+1.)))*TOTSQ-3.*NC*(N+1.)
IDF=N-1
FD=FRIED/IDF
PROB=FISHER(IDF,1000,FD)
IF(IOUT.NE.21) GO TO 37
LINES=LINES+3
IF(LINES.LE.LINPP) GO TO 37
CALL PRNTHD
37 WRITE(IOUT,35) FRIED,IDF,PROB
35 FORMAT('0CHI SQUARE=',F12.3,', WITH ',I2,' DEGREES OF FREEDOM'/
1' HAVING A PROBABILITY OF ',F5.2)
GO TO 10
END
C *** STAT PACK ***
C SUBROUTINE FOR SIGN TEST.
C CALLING SEQUENCE: CALL SIGNT(NV,NC,MV,MC,DATA,NAMES)
C WHERE: NV - NUMBER OF VARIABLES USED.
C NC - NUMBER OF OBSERVATIONS USED.
C MV - MAXIMUM NUMBER OF VARIABLES ALLOWED
C MC - MAXIMUM NUMBER OF OBSERVATIONS ALLOWED
C DATA - MATRIX FOR DATA
C NAMES - VECTOR CONTAINING VARIABLE NAMES.
C
C ROUTINE SUGGESTED BY LONNIE HANNAFORD (SPECIAL EDUCATION) AND
C ULDIS SMIDCHENS (TEACHER EDUCATION). SOURCE IS NON-
C PARAMETRIC STATISTICS BY SIEGEL PAGES 68-75. THE
C BINOMIAL EXPANSION COULD BE USED FOR N>25, HOWEVER IT IS
C SLOW FOR LARGE N. WORKS BY ATTEMPTING TO NORMALIZE NUMBER
C AS IT IS BEING CALCULATED ABOUT THE VALUE 1.
C
SUBROUTINE SIGNT(NV,NC,MV,MC,DATA,NAMES)
DIMENSION DATA(MC,MV),NAMES(1)
COMMON /DEV/ ICC,IDATA,IOUT,IDLG,IDSK
COMMON /PRNT/ LINPP,ICOPS,RUNPRG
COMMON /EXTRA/ HEDR(70),NSZ
C EQUIVALENCE FOR BINARY EXPANSION USED TO FIND POWER OF 2
EQUIVALENCE (ISUM,SUM)
IF(IOUT.NE.21) WRITE(IOUT,5566)(HEDR(I),I=1,NSZ)
5566 FORMAT('1',70A1)
IF(IOUT.EQ.21) CALL PRNTHD
WRITE(IOUT,1)
1 FORMAT('0',20X,'**** SIGN TEST ****'/'0',35X,'FREQUENCY OF'/
119X,'NUMBER OF',9X,'SIGN WHICH'/19X,'PAIRS WITH',6X,
2'OCCURED LEAST',7X,'Z',10X,'PROB'/' VAR',4X,'VAR',4X,
3'SIGNED DIFFERENCE',7X,'OFTEN',8X,'(N>25)',6X,'(N<=25)')
LINES=9
DO 2 I=1,NV-1
DO 2 J=I+1,NV
N=0
NMIN=0
DO 3 K=1,NC
IF(DATA(K,I)-DATA(K,J)) 4,3,5
4 NMIN=NMIN+1
5 N=N+1
3 CONTINUE
IF(NMIN.GT.(N-NMIN)) NMIN=N-NMIN
IF(N.GT.25) GO TO 20
C
C BINOMIAL EXPANSION (N<=25)
C
XSUM=0
IF(N.LT.127) XSUM=1./2.**N
IF(NMIN.LT.1) GO TO 13
DO 11 L=1,NMIN
SUM=1.
IN=N-L+1
XONE=1.
NTWOS=N
DO 12 K=IN,N
SUM=SUM*K/XONE
IF(NTWOS.LT.1) GO TO 12
IF(SUM.LT.2) GO TO 12
JJ=(ISUM.AND."377777777777)/2**27-129
NDIV=JJ
IF(JJ.GT.NTWOS) NDIV=NTWOS
SUM=SUM/2.**NDIV
NTWOS=NTWOS-NDIV
12 XONE=XONE+1.
IF(NTWOS.GT.127) GO TO 11
IF(NTWOS.GT.0) SUM=SUM/2.**NTWOS
XSUM=XSUM+SUM
11 CONTINUE
13 IF(IOUT.NE.21) GO TO 15
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 15
CALL PRNTHD
WRITE(IOUT,1)
LINES=10
15 WRITE(IOUT,14) NAMES(I),NAMES(J),N,NMIN,XSUM
14 FORMAT(1X,A5,2X,A5,8X,I5,13X,I5,20X,F7.4)
GO TO 2
C
C BINOMIAL DISTRIBUTION GIVE Z VALUE
C
20 A=N
XMN=A/2.
XSTD=SQRT(A)/2.
Z=N-XMN
IF(N.LT.XMN) Z=Z+.5
Z=Z/XSTD
IF(IOUT.NE.21) GO TO 22
LINES=LINES+1
IF(LINES.LE.LINPP) GO TO 22
CALL PRNTHD
WRITE(IOUT,1)
LINES=10
22 WRITE(IOUT,21) NAMES(I),NAMES(J),N,NMIN,Z
21 FORMAT(1X,A5,2X,A5,8X,I5,13X,I5,7X,G12.3)
2 CONTINUE
RETURN
END