Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/manova/manov2.for
There is 1 other file named manov2.for in the archive. Click here to see a list.
C WMU IMPLEMENTATION OF THE WAYNE STATE VERSION OF
C
C THE MIAMI MULTIVARIATE ANALYSIS OF VARIANCE(MANOVA)
C
C MODIFIED FOR WMU COMPUTER CENTER BY: SAM ANEMA
C
C FILES: MANOVA.F4,MANOV1.F4,MANOV2.F4,MANOV3.F4,MANOV4.F4
C
C ADDITIONAL SUBROUTINES: USAGE - RUSS BARR(IN NGLIB).MAC
C
C LOADING PROCEDURE:
C
C R LOADER
C MANOV=MANOVA,USAGE/<MANOV1/>MANOV2/>MANOV3/>MANOV4/>/G
C
C MANOV2.F4
SUBROUTINE LNKK
DIMENSION DESIGN(40,40), CELLM(100,20),NCDHLD(100,8), FMT(10)
COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
1ESTIM(50,50), NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
4 ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
5 FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
6SPECOR,VLIST,PRINTR,NFACT , READK, PRINTK,CONTR ,TESTR, MFIRST,
7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,AJOBCD,
8AANALY,AFINIS,WITHIN,SPACE(10)
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
EQUIVALENCE (CELLM,ESTIM),(DESIGN,ORTHES), (NCDHLD,SSEAD(76) )
LOGICAL PRINTK,ERROR, READK
DOUBLE PRECISION VARNAM
NERCOD = 0
IF (NERWIT .EQ. 0) NERCOD = 10
CALL SETUP(NERCOD)
IF (ERROR) GO TO 170
READ ( IAUX1 )((NCDHLD(J,K),J = 1,NCELLS),K = 1,NFACT)
IF (.NOT. READK) GO TO 120
DO 100 I = 1,NCELLS
100 READ(INP,110)(DESIGN(I,J),J = 1,NDFTOT)
110 FORMAT (16F5.5)
120 IF (.NOT. PRINTK) GO TO 170
IND=5+(8-NFACT)*3
ENCODE(26,2371,FMT)NFACT,IND
2371 FORMAT('(1H ,',I4,'I3,',I4,'X,10F10.3)')
N2 = 0
IF (NCELLS .GT. 20) WRITE(IOUT,130)
130 FORMAT (1H1,30X,20HREDUCED MODEL MATRIX )
140 N1 = N2 + 1
N2 = N1 + 9
IF (NCELLS .LE. 20) WRITE (IOUT,130)
IF (N2 .GT. NDFTOT) N2 = NDFTOT
WRITE(IOUT,150)(NTABLE(J), J = 1,8), (I, I = N1,N2)
150 FORMAT (1H0/7H0FACTOR 40X,10HPARAMETER /1H 8(2X,A1),2X,10I10)
DO 160 I = 1,NCELLS
160 WRITE(IOUT,FMT)(NCDHLD(I,J), J = 1,NFACT),(DESIGN(I,J),J = N1,N2)
IF (N2 .NE. NDFTOT) GO TO 140
170 RETURN
END
SUBROUTINE PAK(N,IN,IOUT)
DIMENSION IN(21), IOUT(3)
M = (MIN0(18,N)+5)/6
I=1
DO 100 K=1,M
IOUT(K)=0
DO 100 J=1,6
IOUT(K)=32*IOUT(K)
IF (I .GT. N) GO TO 100
IOUT(K)=IOUT(K)+IN(I)
I=I+1
100 CONTINUE
IF (M .EQ. 3) GO TO 120
M=M+1
DO 110 K=M,3
110 IOUT(K)=0
120 RETURN
END
SUBROUTINE KDF1(N,NSUBCC,NEFFC)
C
DIMENSION NSUBC(8), NSUBCC(8), NEFFC(8)
DIMENSION XKONE(14,14,5),DESIGN(40,40)
COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
1ESTIM(50,50), NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
4 ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
5 FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
6SPECOR,VLIST,PRINTR,NFACT , READK, PRINTK,CONTR ,TESTR, MFIRST,
7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,AJOBCD,
8AANALY,AFINIS,WITHIN,SPACE(10)
EQUIVALENCE (XKONE,ESTIM) , (DESIGN,ORTHES)
DOUBLE PRECISION VARNAM
DO 30 J = 1,NCELLS
ISUM1 = NCELL(J)
DO 10 I = 1,NFACT
ISUM = ISUM1
IB = NFACT - I + 1
ISUM1 = ISUM/ LEVEL(IB)
10 NSUBC(IB) = ISUM - ISUM1* LEVEL(IB) + 1
PROD = 1.0
DO 20 I = 1,NFACT
IND1 = NSUBC(I)
IND2 = NSUBCC(I)
NONE = NEFFC(I)
20 PROD = PROD*XKONE(IND1,IND2,NONE)
30 DESIGN(J,N) = PROD
N = N+1
RETURN
END
SUBROUTINE NATORD(NI)
DIMENSION IHOLD(8), KX(8), NSUB1(8), NSUBL(8), NSUBCC(8),NI(8)
COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
1ESTIM(50,50), NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
4 ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
5 FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
6SPECOR,VLIST,PRINTR,NFACT , READK, PRINTK,CONTR ,TESTR, MFIRST,
7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,AJOBCD,
8AANALY,AFINIS,WITHIN,SPACE(10)
LOGICAL END
DOUBLE PRECISION VARNAM
N=2
NCNT = 1
DO 170 NX = 1,NFACT
DO 100 K = 1,NX
100 KX(K) = K
110 DO 120 K = 1,NFACT
NSUB1(K) = 1
NSUBCC(K) = 1
120 NSUBL(K) = 1
NCNT = NCNT + 1
NDFTST(NCNT) = 1
C PRESENT.
DO 130 K = 1,NX
IND = KX(K)
IHOLD(K) = IND
NDFTST(NCNT) = NDFTST(NCNT)*(LEVEL(IND) - 1)
NSUB1(IND) = 2
NSUBCC(IND) = 2
130 NSUBL(IND) = LEVEL(IND)
NDFCUM(NCNT) = NDFCUM(NCNT-1) + NDFTST(NCNT-1)
CALL PAK(NX, IHOLD(1), HEAD(1,NCNT) )
140 CALL KDF1(N,NSUBCC,NI)
CALL GENNUM(NSUBCC,NSUB1,NSUBL,NFACT,END)
IF (.NOT. END) GO TO 140
DO 160 K = 1,NX
NFAC1 = NFACT-K+1
KN = NX-K+1
IF (KX(KN) .EQ. NFAC1) GO TO 160
KX(KN) = KX(KN)+1
DO 150 I = KN,NX
150 KX(I) = KX(KN)+I-KN
GO TO 110
160 CONTINUE
170 CONTINUE
RETURN
END
SUBROUTINE CHARSR(NARG,J1,IND,NTABLE,LENGTH)
DIMENSION NTABLE(23)
DO 100 IND = 1,LENGTH
IF (NARG .EQ. NTABLE(IND))GO TO 110
100 CONTINUE
J1 = 0
GO TO 140
110 IF (IND .GT. 8) GO TO 120
J1= 1
GO TO 140
120 IF (IND .GT. 18) GO TO 130
J1 = 2
GO TO 140
130 J1 = IND-16
140 RETURN
END
SUBROUTINE GENNUM(NSUBC,NSUB1,NSUBL,NFACT,END)
DIMENSION NSUBC(8), NSUB1(8), NSUBL(8)
LOGICAL END
END = .FALSE.
DO 100 I = 1,NFACT
IBAK = NFACT - I + 1
IF (NSUBC(IBAK)-NSUBL(IBAK) ) 110,100,110
100 CONTINUE
END = .TRUE.
GO TO 140
110 NSUBC(IBAK) = NSUBC(IBAK) + 1
IF (IBAK-NFACT) 120,140,120
120 M = IBAK + 1
DO 130 I = M,NFACT
130 NSUBC(I) = NSUB1(I)
140 RETURN
END
SUBROUTINE UNPAK(IOUT,IN,NTABLE)
DIMENSION IN(21), IOUT(3), NTABLE(27)
I=1
DO 100 K=1,3
ITEMP=IOUT(K)
NSCALE=33554432
DO 100 J=1,6
INI=ITEMP/NSCALE
ITEMP=ITEMP-INI*NSCALE
IN(I)=NTABLE(20)
IF (INI .NE. 0) IN(I) = NTABLE(INI)
NSCALE=NSCALE/32
100 I=I+1
RETURN
END
SUBROUTINE SETUP(NERCOD)
DIMENSION NSUB1(8), NSUBL(8),NEFFC(8),NSUBCC(8)
DIMENSION XKONE(14,14,5),DESIGN(40,40), LIST(720)
COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
1ESTIM(50,50), NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
4 ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
5 FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
6SPECOR,VLIST,PRINTR,NFACT , READK, PRINTK,CONTR ,TESTR, MFIRST,
7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,AJOBCD,
8AANALY,AFINIS,WITHIN,SPACE(10)
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
EQUIVALENCE (XKONE,ESTIM), (LIST,SSEAD(876)), (DESIGN,ORTHES)
DOUBLE PRECISION VARNAM
LOGICAL ERROR,TESTR,END,SPECOR,NEST,READK,MFIRST
DATA NW /4HW /
C ERROR IS TRUE IF ANY ERROR OCCURS.
DO 100 I = 1,100
NERRS(I) = NERCOD
100 NDFTST(I) = 0
IF (MFIRST) NERRS(1) = 99
DO 110 I = 1,8
110 NUMERR(I) = 0
N=1
NSUB1(1) = 26
NSUB1(2) = 20
NSUB1(3) = 27
CALL PAK(3,NSUB1(1),HEAD(1,1) )
NDFCUM(1) = 1
NDFTOT = 1
DO 120 K = 1,NFACT
NDFTOT = NDFTOT * LEVEL(K)
NSUBL(K) = K
NEFFC(K) = 0
120 NSUBCC(K) = 1
CALL KDF1(N,NSUBCC,NSUBL)
IF (SPECOR) GO TO 170
WRITE(IOUT,130)
130 FORMAT (1H0/50H0COMPLETE FACTORIAL WITH NO MISSING CELLS )
IF (NDFTOT .EQ. NCELLS) GO TO 150
WRITE(IOUT,140)
140 FORMAT (52H0ERROR IN DATA. TOO FEW CELLS FOR COMPLETE FACTORIAL )
GO TO 580
150 NDFTST(1) = 1
IF (NCELLS .EQ. 1) GO TO 160
CALL NATORD(NSUBL)
NTESTS = 2**NFACT
GO TO 590
160 NTESTS = 1
NERRS(1) = NERCOD
GO TO 590
C IF MFIRST IS FALSE, DO NOT INCLUDE MEAN IN MODEL UNLESS
170 NDFTOT = 0
WRITE(IOUT,180)
180 FORMAT (1H0/26H0SPECIAL ORDER OF EFFECTS )
IF (MFIRST) GO TO 200
WRITE(IOUT,190)
190 FORMAT (54H NO CONSTANT TERM IN THIS MODEL UNLESS SPECIFIED BELOW)
GO TO 210
200 IF(LIST(1) .NE. NW) NDFTOT = 1
210 LSAVE1 = 0
NDF = 1
NDFTST(1) = NDFTOT
NTESTS = NDFTOT + 1
N = NDFTOT + 1
NFACNT = 0
NEST = .FALSE.
J0 = 4
I2 = 0
NCCNT = 0
INDHLD = 0
DO 530 I1 = 1,641,80
I2=I1+79
WRITE(IOUT,220)(LIST(I), I = I1,I2)
220 FORMAT (1H 80A1)
DO 520 NCDCNT = 1,80
NCCNT = NCCNT + 1
CALL CHARSR(LIST(NCCNT),J1,NUMTBL,NTABLE,25)
LIST(NCCNT) = NUMTBL
LSAVE = LSAVE1
IF (J1-1) 540,230,240
230 LSAVE1 = NUMTBL
240 IND = ITABLE(J0,J1)
J0 = J1
NUM = NUMTBL - 8
GO TO (250,260,320,470,540,310,490,480,510,290,460),IND
250 NUM = 1
IF (NEST) GO TO 280
GO TO 270
260 IF (NEST) GO TO 280
IF(NUM.EQ.1 .OR. NUM.GT.9 .OR. LEVSUB(LSAVE,NUM).EQ.0)GO TO 540
270 NEFFC(LSAVE) = NUM
NDF = NDF*LEVSUB(LSAVE,NUM)
IF (LEVSUB(LSAVE,NUM) .NE. 0) GO TO 470
GO TO 555
280 NEFFC(LSAVE) = -NUM
IF (NUM .NE. 1) GO TO 300
NDF = NDF*LEVEL(LSAVE)
GO TO 470
290 IF (.NOT. NEST) GO TO 540
NEFFC(LSAVE) = 10*(NEFFC(LSAVE) + 1) - NUM
300 IF(-NEFFC(LSAVE) - 1 .GT. LEVEL(LSAVE) ) GO TO 540
GO TO 470
310 NDFTST(NTESTS) = NDFTST(NTESTS) + NDF
GO TO 350
320 NDFTST(NTESTS) = NDFTST(NTESTS) + NDF
IF (NTESTS .NE. 1)
1NDFCUM(NTESTS) = NDFCUM(NTESTS-1) + NDFTST(NTESTS-1)
IF (NTESTS .NE. 1 .OR. .NOT. MFIRST)
1CALL PAK(NCCNT-INDHLD-2,LIST(INDHLD+1),HEAD(1,NTESTS) )
INDHLD = NCCNT-1
IF (.NOT. TESTR .OR. J1 .NE. 6) GO TO 340
NDFCUM(NTESTS) = 0
NDFTST(NTESTS) = NCELLS - NDFTOT
WRITE(IOUT,330)
330 FORMAT (37H0LAST EFFECT OBTAINED AS RESIDUAL )
IF (NDFTST(NTESTS) .EQ. 0) GO TO 560
GO TO 450
340 NDFTOT = NDFTOT + NDFTST(NTESTS)
IF (NDFTOT .GT. NCELLS) GO TO 560
NTESTS = NTESTS+1
350 NDF = 1
IF (READK) GO TO 430
DO 410 I = 1,NFACT
IF (NEFFC(I) ) 370,360,390
360 NSUB1(I) = 1
NSUBL(I) = 1
NEFFC(I) = I
GO TO 410
370 IND = -NEFFC(I)
NEFFC(I) = MAXFAC + 1
IF (IND .EQ. 1) GO TO 380
NSUB1(I) = IND-1
NSUBL(I) = IND-1
GO TO 410
380 NSUB1(I) = 1
NSUBL(I) = LEVSUB(I,1) + 1
GO TO 410
390 IND = NEFFC(I)
NEFFC(I) = I
400 NSUB1(I) = LEVCUM(I,IND) + 1
NSUBL(I) = NSUB1(I) + LEVSUB(I,IND) - 1
410 NSUBCC(I) = NSUB1(I)
420 CALL KDF1(N,NSUBCC,NEFFC)
CALL GENNUM(NSUBCC,NSUB1,NSUBL,NFACT, END)
IF (.NOT. END) GO TO 420
430 DO 440 J = 1,NFACT
440 NEFFC(J) = 0
NEST = .FALSE.
IF (J1 .NE. 6) GO TO 520
NTESTS = NTESTS - 1
450 RETURN
460 IF (MFIRST) GO TO 540
470 IF (J1 .NE. 6) GO TO 520
NCCNT = NCCNT + 1
GO TO 320
480 NERRS(NTESTS) = NUM - 1
IF (NUM .EQ. 1) NERRS(NTESTS) = 10
GO TO 520
490 IF (NUM .EQ. 1 .OR. NUM .GT. 9) GO TO 500
NUMERR(NUM-1) = NTESTS
500 NERRS(NTESTS) = 99
GO TO 520
510 NEST = .TRUE.
IF (J1 .EQ. 1) GO TO 520
NERRS(1) = NERCOD
NEST = .FALSE.
GO TO 470
520 CONTINUE
530 CONTINUE
NCDCNT = 80
540 WRITE(IOUT,550) NCDCNT
550 FORMAT (10H ERROR COL I4,6H ABOVE)
GO TO 580
555 NCDCNT = NCDCNT-1
GO TO 540
560 CALL UNPAK(HEAD(1,NTESTS),NDFTST,NTABLE)
WRITE(IOUT,570)(NDFTST(J),J = 1,21)
570 FORMAT (12H0THE EFFECT 18A1, 62H MAKES THE DEGREES OF FREEDOM MOR
1E THAN THE NUMBER OF CELLS )
580 ERROR = .TRUE.
590 RETURN
END