Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/manov3.f4
There are no other files named manov3.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	SAV MANOVA
C
C	MANOV3.F4
      SUBROUTINE EST
      DIMENSION  DESIGN(40,40),CELLM(50,20),CON(100), DIAG(100),
     1SSRES(26,27),SSWITH(26,26),SSE(40,40),GM(40),GM1(40),Q(500)
      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 (DESIGN,ORTHES), (CELLM,ESTIM)  ,(SSRES,DUMMY),
     1(SSWITH,SSRES(1,2)), (SSE,SSEAD(1,2)),(Q,DUMMY(203)),(GM,Q(301))
      DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
      DATA IAUX4/24/
      DOUBLE PRECISION  VARNAM
      LOGICAL PRINTR
C     MAXPAR IS THE MAXIMUM NUMBER OF PARAMETERS
      NVARTP = NVART + 1
      READ(IAUX1)((CELLM(J,K),J = 1,NCELLS), K = 1,NVART),((SSEAD(J,K),
     1J = 1,NVART),K = 1,NVARTP), ((VARNAM(J,K),J = 1,2),K = 1,NVART)
      REWIND IAUX1
      XN = 0.0
      DO 110 I=1,NCELLS
      XN = XN + OBS(I)
      X=SQRT(OBS(I))
      DO 100 K = 1,NVART
      IF (I.EQ. 1) GM1(K) = 0.0
      GM1(K) = GM1(K) + OBS(I)*CELLM(I,K)
  100 CELLM(I,K) = CELLM(I,K)*X
      DO 110 J=1,NDFTOT
  110 DESIGN(I,J)=DESIGN(I,J)*X
      CALL ORTHOG(DESIGN,NCELLS,NDFTOT,CELLM,NVART,DIAG)
      IF (NDFTOT .EQ. 1) GO TO 118
      DO 115 K = 2,NDFTOT
      SUM = 0.0
      DO 114 J = 2,K
  114 SUM = SUM + DESIGN(J-1,K)**2
  115 IF (DIAG(K)**2 /(SUM + DIAG(K)**2) .LT. .001) WRITE(IOUT,116) K
  116 FORMAT (7H0COLUMN  I4, 47H OF REDUCED MODEL MATRIX IS PROBABLY RED
     2UNDANT    )
  118 K = MAXPAR
      L = K+1
      DO 130 J = 1,NVART
      J1 = NVART-J+1
      DO 130 I = 1,NCELLS
      I1 = NCELLS - I + 1
      IF (L .GT. K) GO TO 120
      K = K-1
      L = MAXPAR + 1
  120 L = L-1
  130 DESIGN(L,K) = CELLM(I1,J1)
      KSTART = K
      LSTART = L
      DO 180 J=1,NVART
      I=NDFTOT
  140 SUM = CELLM(I,J)
      REC = 0.0
      IF (DIAG(I) .NE. 0.) REC = 1./DIAG(I)
      IF (I .GE. NDFTOT) GO TO 170
  150 IP1 = I+1
      DO 160 K=IP1,NDFTOT
  160 SUM = SUM -DESIGN(I,K)*CELLM(K,J)
  170 SUM = SUM*REC
      CELLM(I,J) = SUM
      I=I-1
      IF (I .NE. 0) GO TO 140
  180 CONTINUE
      IF (.NOT. PRINTR .OR. NDFTOT .EQ. 1) GO TO 310
      DO 190 I = 1,NDFTOT
      XH = DIAG(I)
      DIAG(I) = DESIGN(I,I)
  190 DESIGN(I,I) = XH
      CALL UPRINV(NDFTOT,DESIGN)
      DO 220 I = 1,NDFTOT
      DO 210 J = I,NDFTOT
      SUM = 0.0
      DO 200 K = J,NDFTOT
  200 SUM = SUM + DESIGN(I,K)*DESIGN(J,K)
  210 DESIGN(I,J) = SUM
  220 DESIGN(I,I) = SQRT(DESIGN(I,I) )
      N = NDFTOT-1
      DO 230 I = 1,N
      K = I+1
      DO 230 J = K,NDFTOT
  230 DESIGN(I,J) = DESIGN(I,J)/(DESIGN(I,I)*DESIGN(J,J) )
      WRITE(IOUT,240)
  240 FORMAT('1CORRELATIONS OF CONTRASTS WITH STANDARD DEVIATIONS OF C',
     1'ONTRASTS DIVIDED BY STANDARD DEVIATIONS OF ',
     1	'VARIABLES ON DIAGONAL')
      JEND = 0
  250 JBEG = JEND+1
      IF(NDFTOT .GT. 20 .AND. JBEG .NE. 1) WRITE (IOUT,260)
  260 FORMAT (1H1)
      JEND = MIN0(JBEG+9, NDFTOT)
      WRITE(IOUT,270)    (HNUM(J),J = JBEG,JEND)
  270 FORMAT (1H0/9H0CONTRAST  10A12)
      DO 280 I = JBEG,NDFTOT
      JENDR = MIN0(I,JEND)
  280 WRITE(IOUT,290)HNUM(I), (DESIGN(J,I), J = JBEG,JENDR)
  290 FORMAT  (A7,5X 10F12.3)
      IF (JEND .LT. NDFTOT) GO TO 250
      DO 300 I = 1,NDFTOT
      XH = DESIGN(I,I)
      DESIGN(I,I) = DIAG(I)
  300 DIAG(I) = XH
  310 K = KSTART
      L = LSTART
      DO 320 J = 1,NVART
      DO 320 I = 1,NCELLS
      ORTHES(I,J) = DESIGN(L,K)
      IF (L .LT. MAXPAR) GO TO 320
      L = K
      K = K+1
  320 L = L+1
      DO 340 J = 1,NVART
      GM(J) = GM1(J)/XN
      DO 340 K = J,NVART
      SUM = 0.0
      IF (NDFTOT .EQ. NCELLS) GO TO 335
      NDFT1 = NDFTOT + 1
      DO 330 I = NDFT1,NCELLS
  330 SUM = SUM + ORTHES(I,J)*ORTHES(I,K)
  335 SSWITH(J,K) = SSE(J,K)
  340 SSRES(K,J) = SUM
      NERRES = NCELLS - NDFTOT
      RETURN
      END
      SUBROUTINE ORTHOG(XMAT,NROW,NCOLX,YMAT,NCOLY,DIAG)
      DIMENSION  XMAT(40,40), YMAT(50,20), CON(50), DIAG(50)
      N1=NCOLX-1
      DO 150 K=1,NCOLX
      SUM=0.
      DO 100 I=K,NROW
  100 SUM=SUM+XMAT(I,K)**2
      TEMP=SUM
      SUM=SQRT(SUM)
      AKK=XMAT(K,K)
      IF (AKK .LT. 0.0) SUM = -SUM
  110 XMAT(K,K)=AKK+SUM
      CONS=TEMP+SUM*AKK
      CON(K)=CONS
      DIAG(K)=-SUM
      IF (N1 .LT. K)  GO TO 150
  120 DO 140 J=K,N1
      SUM=0.
      DO 130 I=K,NROW
  130 SUM=SUM+XMAT(I,K)*XMAT(I,J+1)
      TEMP=SUM/CONS
      DO 140 I=K,NROW
  140 XMAT(I,J+1)=XMAT(I,J+1)-TEMP*XMAT(I,K)
  150 CONTINUE
      DO 180 K=1,NCOLY
      DO 180 L=1,NCOLX
      SUM=0.
      DO 160 I=L,NROW
  160 SUM=SUM+XMAT(I,L)* YMAT(I,K)
      TEMP=SUM/CON(L)
      DO 170 I=L,NROW
  170  YMAT(I,K)= YMAT(I,K)-TEMP*XMAT(I,L)
  180 CONTINUE
      RETURN
      END
      SUBROUTINE UPRINV(N,A)
      DIMENSION A(40,40)
      K=N
  100 AKK=A(K,K)
      AKK=1./AKK
      A(K,K)=AKK
      J=K
  110 J=J+1
      IF  (J .GT. N) GO TO 130
      TEMP=AKK*A(K,J)
      A(K,J)=TEMP
      I=0
  120 I=I+1
      IF (K .LE. I) GO TO 110
      A(I,J)=A(I,J)-TEMP*A(I,K)
      GO TO 120
  130 I=0
  140 I=I+1
      IF (K .LE. I) GO TO 150
      A(I,K)=-AKK*A(I,K)
      GO TO 140
  150 K=K-1
      IF (K .NE. 0) GO TO 100
      RETURN
      END