Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/manova/manov3.for
There is 1 other file named manov3.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 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