Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/manov2.f4
There are no other files named manov2.f4 in the archive.
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