Trailing-Edge
-
PDP-10 Archives
-
decuslib10-09
-
43,50466/manov1.f4
There are no other files named manov1.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 MANOV1.F4
SUBROUTINE RDCONT
DIMENSION XKONE(14,14,5), NCDHLD(100,8),VECHLD(100),
1LIST(720), OPTION(75), INLET(75), RECODE(8,20),SSRES(25,26)
DIMENSION XNUM(50)
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,APROB,
8AANALY,AFINIS,WITHIN,SPACE(10)
EQUIVALENCE (ESTIM,XKONE), (RECODE,DUMMY),(TAGP,SPACE(3)),
1(SSEAD,OPTION,INLET), (LIST,SSEAD(876) ),(SSRES,SSHYP),
2(TAG,SPACE(1) ), (NCDHLD,SSEAD(76) ), (EONLY,SPACE(2) )
3,(PRTSSH,SPACE(5)),(NPCT,SPACE(6)),(NSIG,SPACE(7))
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
LOGICAL TRUTH, FIRST, ERROR, RDNAM, TESTR, TRANS, PRINTK,
1PRINTR, SPECOR, CONTR, VLIST, RVARC ,IN4, FIRSTT,READK ,MFIRST,
2PRINTM, EONLY,PRTSSH
DOUBLE PRECISION ABLANK,VARNAM,VECHLD
INTEGER RECODE,TRANCD, TWO24,OPTION,BLANK
DATA XNUM/' 1 ',' 2 ',' 3 ',' 4 ',' 5 ',' 6 ',' 7 ',' 8 ',
C ' 9 ','10 ','11 ','12 ','13 ','14 ','15 ','16 ','17 ',
C '18 ','19 ','20 ','21 ','22 ','23 ','24 ','25 ','26 ',
C '27 ','28 ','29 ','30 ','31 ','32 ','33 ','34 ','35 ',
C '36 ','37 ','38 ','39 ','40 ','41 ','42 ','43 ','44 ',
C '45 ','46 ','47 ','48 ','49 ','50 '/
DATA LR/4HR /, ABLANK/8H /
FIRSTT = .TRUE.
IF (FIRST) GO TO 100
IF (ERROR) GO TO 120
IF (.NOT. TRUTH) GO TO 150
GO TO 310
100 CALL ALPHAN(19,NTABLE(9),76H0 1 2 3 4 5 6 7 8 9
1 , + . = - W G M )
CALL ALPHAN(4,ATITLE,16HTITLPROBANALFINI )
CALL ALPHAN(1,BLANK,4H )
DO 105 J=1,50
105 HNUM(J)=XNUM(J)
110 ITABLE(1,1) = 1
ITABLE(1,2) = 2
ITABLE(1,3) = 1
ITABLE(1,4) = 5
ITABLE(1,5) = 1
ITABLE(1,6) = 1
ITABLE(1,7) = 1
ITABLE(1,8) = 1
ITABLE(1,9) = 1
ITABLE(2,1) = 4
ITABLE(2,2) = 10
ITABLE(2,3) = 4
ITABLE(2,4) = 5
ITABLE(2,5) = 4
ITABLE(2,6) = 4
ITABLE(2,7) = 4
ITABLE(2,8) = 4
ITABLE(2,9) = 4
ITABLE(3,1) = 3
ITABLE(3,2) = 5
ITABLE(3,3) = 5
ITABLE(3,4) = 3
ITABLE(3,5) = 5
ITABLE(3,6) = 5
ITABLE(3,7) = 5
ITABLE(3,8) = 5
ITABLE(3,9) = 3
ITABLE(4,1) = 4
ITABLE(4,2) = 5
ITABLE(4,3) = 5
ITABLE(4,4) = 4
ITABLE(4,5) = 5
ITABLE(4,6) = 5
ITABLE(4,7) = 11
ITABLE(4,8) = 11
ITABLE(4,9) = 4
ITABLE(5,1) = 6
ITABLE(5,2) = 5
ITABLE(5,3) = 5
ITABLE(5,4) = 5
ITABLE(5,5) = 5
ITABLE(5,6) = 5
ITABLE(5,7) = 5
ITABLE(5,8) = 5
ITABLE(5,9) = 5
ITABLE(7,1) = 5
ITABLE(7,2) = 7
ITABLE(7,3) = 5
ITABLE(7,4) = 5
ITABLE(7,5) = 5
ITABLE(7,6) = 5
ITABLE(7,7) = 5
ITABLE(7,8) = 5
ITABLE(7,9) = 5
ITABLE(8,1) = 5
ITABLE(8,2) = 8
ITABLE(8,3) = 5
ITABLE(8,4) = 5
ITABLE(8,5) = 5
ITABLE(8,6) = 5
ITABLE(8,7) = 5
ITABLE(8,8) = 5
ITABLE(8,9) = 5
ITABLE(9,1) = 9
ITABLE(9,2) = 5
ITABLE(9,3) = 9
ITABLE(9,4) = 5
ITABLE(9,5) = 5
ITABLE(9,6) = 9
ITABLE(9,7) = 5
ITABLE(9,8) = 9
ITABLE(9,9) = 5
NPCT = 0
120 FIRSTT = .TRUE.
IF (.NOT. ERROR) WRITE (IOUT,125)
125 FORMAT(1H1//' WESTERN MICHIGAN UNIVERSITY'//,
1 ' MULTI-VARIATE ANALYSIS OF VARIANCE'/)
130 READ(INP,140)TAG,TAGP,OPTION
140 FORMAT (A4,76A1)
150 IF (TAG .NE. ATITLE .AND. TAG .NE. APROB) GO TO 560
IF (ERROR) WRITE (IOUT,125)
FIRST = .TRUE.
EONLY = .FALSE.
NSIG = 1
170 IF (TAG .EQ. APROB) GO TO 190
IF (TAG .NE. ATITLE) GO TO 560
WRITE(IOUT,180)OPTION
180 FORMAT (1H 80A1)
READ(INP,140) TAG,TAGP,OPTION
GO TO 170
190 ERROR = .FALSE.
DO 200 I = 1,8
200 NTABLE(I) = BLANK + 1
TWO24 = 16777216
DO 210 J = 1,4
IF (OPTION(J) .NE. BLANK) GO TO 205
OPTION(J)=0
GO TO 210
205 OPTION(J)=(OPTION(J)/"4000000000)-"60
206 FORMAT(I1)
210 CONTINUE
NVART = OPTION(1)*10 + OPTION(2)
NFACT = OPTION(3)
NFMT = OPTION(4)
RDNAM = OPTION( 5) .NE. BLANK
VLIST = OPTION( 6) .NE. BLANK
SPECOR = OPTION( 7) .NE. BLANK
TESTR = OPTION( 8) .NE. BLANK
RVARC = OPTION( 9) .NE. BLANK
C READ DATA FROM TAPE 4
IN4 = OPTION(10) .NE. BLANK
IF (OPTION(10) .EQ. LR) REWIND IAUX4
PRINTM = OPTION(11) .EQ. BLANK
TRANS = OPTION(12) .NE. BLANK
PRINTK = OPTION(13) .NE. BLANK
PRINTR = OPTION(14) .NE. BLANK
READK = OPTION(15) .NE. BLANK
MFIRST = OPTION(16) .EQ. BLANK
PRTSSH = OPTION(17) .NE. BLANK
IF (OPTION(18) .EQ. BLANK) GO TO 215
REWIND IAUX4
212 READ(INP,140)TAG,TAGP,OPTION
WRITE(IAUX4,140) TAG,TAGP,OPTION
IF (TAG .NE. AFINIS) GO TO 212
REWIND IAUX4
215 NPCT = (NPCT/1000)+1
WRITE(IOUT,220) NPCT,NVART,NFACT
220 FORMAT (8H0PROBLEM I4,I4, 10H VARIABLES I3, 8H FACTORS /)
NPCT = NPCT*1000
IF (NVART .GT. MAXVAR .OR. NFACT .GT. MAXFAC) GO TO 540
DO 230 I = 1,NVART
IORD(I) = I
IPOSV(I) = I
230 IVPOS(I) = I
IF (RDNAM) GO TO 250
DO 240 J = 1,NVART
VARNAM(1,J) = ABLANK
240 VARNAM(2,J) = HNUM(J)
GO TO 270
250 READ(INP,260)((VARNAM(J,I),J = 1,2),I = 1,NVART)
260 FORMAT (8(A6,A4))
270 NVAR = NVART
IF(RDNAM)WRITE(IOUT,300)(VARNAM(1,J), VARNAM(2,J),J = 1,NVART)
NCOVAR = 0
IF (VLIST)READ(INP,280)NVAR,NCOVAR,(IORD(J),J = 1,38)
280 FORMAT (40I2)
NVCVAR = NVAR+NCOVAR
IF(VLIST.AND.NVCVAR.GT. 38) READ(INP,280)(IORD(J), J = 39,NVCVAR)
IF (NCOVAR .EQ. 0) NCOVAR = 0
WRITE(IOUT,290)NVAR,NCOVAR
290 FORMAT (1H0I2,9H CRITERIA I4, 43H COVARIATES WITH THE FOLLOWING V
1ARIABLES )
IF (NVCVAR .GT. NVART) GO TO 540
N2 = 2*NVCVAR
DO 295 J = 1,NVCVAR
J1 = IORD(J)
VECHLD(2*J-1) = VARNAM(1,J1)
295 VECHLD(2*J) = VARNAM(2,J1)
WRITE(IOUT,300)(VECHLD(J), J = 1,N2)
300 FORMAT (10(3X A6,A4) )
310 NVARTP = NVART+1
REWIND IAUX1
IF (FIRST) GO TO 330
DO 320 I = 1,NVART
IPOSV(I) = I
320 IVPOS(I) = I
IF (.NOT. CONTR) GO TO 430
READ(IAUX1)(((XKONE(I,J,K),I = 1,MAXLEV),J = 1,MAXLEV),K= 1,NFACT)
READ(IAUX1) ((NCDHLD(J,K),J = 1,NCELLS),K = 1,NFACT)
READ(IAUX1)((ORTHES(J,K),J = 1,NCELLS), K = 1,NVART),((SSRES(J,K),
1J = 1,NVART),K = 1,NVARTP), ((VARNAM(J,K),J = 1,2),K = 1,NVART)
REWIND IAUX1
330 DO 420 I = 1,NFACT
READ(INP,340) NTABLE(I), ICONT, M, (LEVSUB(I,J),J = 2,9),
1(RECODE(I,J), J = 1,20 ), (INLET(J),J = 1,5)
340 FORMAT (A1,I1,29I2,5A4)
NOREC=' '
IF (NOREC .NE. BLANK ) GO TO 360
DO 350 J = 1,M
350 RECODE(I,J) = J
360 LEVEL(I) = M
WRITE(IOUT,370)NTABLE(I),LEVEL(I), (INLET(J),J = 1,5)
370 FORMAT(8H0FACTOR A1,I5,7H LEVELS 10X,5A4)
IF (LEVEL(I) .EQ. 0 .OR. LEVEL(I) .GT. MAXLEV) GO TO 540
LEVSUB(I,1) = LEVEL(I) - 1
LEVCUM(I,1) = 1
IF (LEVSUB(I,2) .EQ. 0) GO TO 410
LEVCUM(I,2) = 1
DO 390 J = 2,9
IF (LEVSUB(I,J) .EQ. 0) GO TO 400
J1 = J-1
WRITE(IOUT,380)NTABLE(I),J1,LEVSUB(I,J )
380 FORMAT (1H 9X, A1,I1,4H HAS I3,3H DF)
390 LEVCUM(I,J+1 ) = LEVCUM(I,J) + LEVSUB(I,J)
J = 10
400 IF (LEVEL(I) .NE. LEVCUM(I,J))GO TO 520
410 CALL GETK1(ICONT,I,LEVEL(I),XKONE,LEVSUB,NTABLE,ERROR)
IF (ERROR) GO TO 120
420 CONTINUE
WRITE(IAUX1)(((XKONE(I,J,K),I=1,MAXLEV),J= 1,MAXLEV), K = 1,NFACT)
430 IF (.NOT. SPECOR) GO TO 460
DO 450 N1 = 1,641,80
N2 = N1 + 79
READ(INP,440) (LIST(J),J = N1,N2)
440 FORMAT (80A1)
DO 450 J = N1,N2
IF (LIST(J) .EQ.'.' ) GO TO 460
450 CONTINUE
GO TO 510
460 IF (.NOT. FIRST .AND. .NOT. CONTR) GO TO 480
IF (.NOT. FIRST) GO TO 470
CALL RDDAT(NOBST,NFMT,TRANS,IN4,PRINTM)
NERWIT = NOBST-NCELLS
IF (ERROR) GO TO 120
470 WRITE(IAUX1) ((NCDHLD(J,K),J = 1,NCELLS),K = 1,NFACT)
WRITE(IAUX1)((ORTHES(J,K),J = 1,NCELLS),K = 1,NVART),((SSRES(J,K),
1J = 1,NVART),K = 1,NVARTP), ((VARNAM(J,K),J = 1,2),K = 1,NVART)
REWIND IAUX1
480 DO 500 J = 1,MAXLEV
DO 490 K = 1,MAXLEV
490 XKONE(J,K,MAXFAC+1) = 0.0
500 XKONE(J,J,MAXFAC+1) = 1.0
READ(IAUX1)(((XKONE(I,J,K),I=1,MAXLEV),J = 1,MAXLEV), K = 1,NFACT)
510 RETURN
520 WRITE(IOUT,530)
530 FORMAT (25H SUBEFFECTS ABOVE WRONG )
GO TO 120
540 WRITE(IOUT,550)
550 FORMAT (13H ERROR ABOVE )
GO TO 120
560 IF (TAG .EQ. AFINIS) GO TO 580
IF (.NOT. FIRSTT)GO TO 130
WRITE(IOUT,570)TAG,OPTION
570 FORMAT (1H A4,76A1/40H ABOVE NOT VALID HERE, SKIPPING PROBLEM )
FIRSTT = .FALSE.
GO TO 130
580 WRITE(IOUT,590)
590 FORMAT (12H1END OF DATA )
STOP
END
SUBROUTINE GETK1(ICONT,N1,NLEV,XKONE,LEVSUB,NTABLE,ERROR)
LOGICAL ERROR
DIMENSION XKONE(14,14,5), LEVSUB(8,10), NTABLE(27)
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
M = ICONT+1
NBLANK = NTABLE(20)
NSUM = 2
K=0
IF (M .GT. 4) GO TO 350
GO TO (100,150,220,280),M
100 IF (NLEV .EQ. 1) GO TO 140
WRITE (IOUT,110)
110 FORMAT (23H DEVIATION CONTRASTS )
DO 130 I = 2,NLEV
XKONE(I-1,1,N1) = 1.0
XKONE(NLEV,I,N1) = -1.0
DO 130 J = 2,NLEV
IF (I .NE. J) GO TO 120
XKONE(I-1,J,N1) = 1.0
GO TO 130
120 XKONE(I-1,J,N1) = 0.0
130 CONTINUE
140 XKONE(NLEV,1,N1) = 1.0
GO TO 340
150 SUM = 0.0
WRITE (IOUT,160)
160 FORMAT (20H SPECIAL CONTRASTS )
I = 0
165 I = I+1
READ (INP,170)(XKONE(I,J,N1),J=1,NLEV)
170 FORMAT (16F5.0)
GO TO 330
180 WRITE (IOUT,190)LETTER,NUMB,(XKONE(I,J,N1),J=1,NLEV)
190 FORMAT (3X,2A1,10F12.5/(5X,10F12.5) )
200 SUM = SUM + XKONE(1,I,N1)
IF (I .LT. NLEV) GO TO 165
DO 210 I = 1,NLEV
210 XKONE(1,I,N1) = XKONE(1,I,N1)/SUM
CALL INVERT(NLEV,XKONE(1,1,N1),E ,10HCONTRAST )
GO TO 340
C
220 READ (INP,170)(XKONE(I,2,N1),I=1,NLEV)
WRITE (IOUT,230)(XKONE(I,2,N1),I=1,NLEV)
230 FORMAT (45H ORTHOGONAL POLYNOMIAL CONTRASTS WITH SCALE /
1(5X 10F12.5) )
WRITE (IOUT,190)
A = .5*(XKONE(NLEV,2,N1) + XKONE(1,2,N1) )
B = 2./(XKONE(NLEV,2,N1) - XKONE(1,2,N1) )
DO 240 I = 1,NLEV
XKONE(I,2,N1) = B*(XKONE(I,2,N1)-A)
240 XKONE(I,1,N1) = 1.0
DO 250 I = 3,NLEV
DO 250 J = 1,NLEV
250 XKONE(J,I,N1) = 2.0*XKONE(J,I-1,N1)*XKONE(J,2,N1)- XKONE(J,I-2,N1)
CALL GRAM(XKONE(1,1,N1),NLEV,NLEV)
DO 260 I = 1,NLEV
260 XKONE(I,1,N1) = 1.0
I = 0
265 I = I+1
GO TO 330
270 WRITE (IOUT,190)LETTER,NUMB,(XKONE(J,I,N1),J=1,NLEV)
IF (I .LT. NLEV) GO TO 265
GO TO 340
280 XKONE(1,1,N1) = 1.0
WRITE (IOUT,290)
290 FORMAT (25H DIFFERENCE CONTRASTS )
DO 320 K = 2,NLEV
RK = -1.0/FLOAT(K)
XKONE(K,1,N1) = 1.0
DO 300 J = K,NLEV
300 XKONE(J,K,N1) = 0.0
DO 310 J = 1,K
310 XKONE(J,K,N1) = RK
320 XKONE(K,K,N1) = 1.0 + RK
GO TO 340
330 LETTER = NBLANK
NUMB = NBLANK
IF (I .NE. NSUM) GO TO (180,270),ICONT
LETTER = NTABLE(N1)
NUMB = NTABLE(K+10)
K = K+1
NSUM = NSUM + LEVSUB(N1,K+1)
GO TO (180,270), ICONT
340 RETURN
350 ERROR = .TRUE.
GO TO 340
END
SUBROUTINE RDDAT(NOBST,NFMT,TRANS,IN4,PRINTM)
DIMENSION TRANCD(50), RECODE(8,20),
1FMT(180) ,X(50),NCODE(8) ,SSWITH(25,25),CELLM(100,20),
2CLLSS(50,20),NCDHLD(100,8),SSRES(25,26)
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 (ESTIM,CLLSS), (ORTHES,CELLM,DESIGN),
1(SSWITH,SSRES(1,2) ), (RECODE,DUMMY),(NCDHLD,SSEAD(76) ),
2(TRANCD,SSEAD), (SSRES,SSHYP)
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
INTEGER RECODE,TRANCD
DOUBLE PRECISION VARNAM
LOGICAL ERROR,END,FIRSTC,TRANS,IN4,PRINTM
C
FIRSTC = .TRUE.
NCELLS = 0
KOBS = 0
DO 100 J = 1,NVART
DO 100 K = J,NVART
SSRES(K,J) = 0.0
100 SSWITH(J,K) = 0.0
IF (NFMT .NE. 0) GO TO 120
N = 10-NFACT
ENCODE(37,601,FMT),NFACT,N
601 FORMAT('(2X,',I4,'I1,',I4,'X,10F6.0/(12X,10F6.0))')
GO TO 160
120 NFMT20 = NFMT*20
WRITE(IOUT,130)
130 FORMAT ( 21H0FORMAT OF DATA CARDS )
READ(INP,140) (FMT(J), J = 1,NFMT20)
140 FORMAT (20A4)
WRITE(IOUT,150)(FMT(J), J = 1,NFMT20)
150 FORMAT (4X 20A4)
160 IF (.NOT. TRANS) GO TO 280
READ(INP,170) (TRANCD(I),I = 1,NVART)
170 FORMAT (80I1)
WRITE(IOUT,180)
180 FORMAT (17H0TRANSFORMATIONS )
DO 270 I = 1,NVART
M = TRANCD(I) + 1
IF (M .GT. 4) GO TO 250
GO TO (270,190,210,230), M
190 WRITE(IOUT,200)VARNAM(1,I), VARNAM(2,I)
200 FORMAT (16H SQRT TRANS VAR 2X A6,A4)
GO TO 270
210 WRITE(IOUT,220) VARNAM(1,I), VARNAM(2,I)
220 FORMAT (16H LOGE TRANS VAR 2X,A6,A4)
GO TO 270
230 WRITE(IOUT,240) VARNAM(1,I), VARNAM(2,I)
240 FORMAT (16H ASIN TRANS VAR 2X A6,A4)
GO TO 270
250 WRITE(IOUT,260) TRANCD( I), VARNAM(1,I), VARNAM(2,I)
260 FORMAT(5H USER I1,10H TRANS VAR 2X A6,A4)
270 CONTINUE
280 I = 0
290 IF (IN4) GO TO 300
READ (INP,FMT) (NCODE(K),K = 1,NFACT), (X(K), K = 1,NVART)
GO TO 305
300 READ (IAUX4,FMT) (NCODE(K),K = 1,NFACT), (X(K), K = 1,NVART)
305 DO 307 K = 1,NVART
IF (X(K) .NE. 0.) GO TO 311
307 CONTINUE
DO 310 K = 1,NFACT
IF (NCODE(K) .NE. 0) GO TO 311
310 CONTINUE
GO TO 430
311 KOBS = KOBS + 1
ISUM = 0
DO 320 J = 1,NFACT
KLEV = LEVEL(J)
DO 318 K = 1,KLEV
IF (NCODE(J) .EQ. RECODE(J,K) ) GO TO 321
318 CONTINUE
322 WRITE(IOUT,319)KOBS, (NCODE(NUMFAC), NUMFAC=1,NFACT)
319 FORMAT (20X,11HOBSERVATION I10,47H OMITTED FROM ANALYSIS BECAUSE
1OF BAD CELL CODE 8I3)
GO TO 290
321 ISUM0 = ISUM
ISUM = ISUM*LEVEL(J) + K - 1
IF (ISUM .LT. ISUM0) GO TO 322
320 CONTINUE
IF (FIRSTC) GO TO 325
DO 323 I = 1,NCELLS
IF (ISUM .LT. NCELL(I)) GO TO 326
IF (ISUM .EQ. NCELL(I) ) GO TO 350
323 CONTINUE
325 I = NCELLS + 1
GO TO 329
326 IF (NCELLS .EQ. MAXCEL) GO TO 380
DO 328 J1 = I,NCELLS
J = NCELLS - J1 + I
JP = J+1
OBS(JP) = OBS(J)
NCELL(JP) = NCELL(J)
DO 327 K = 1,NVART
CELLM(JP,K) = CELLM(J,K)
327 CLLSS(JP,K) = CLLSS(J,K)
DO 328 K = 1,NFACT
328 NCDHLD(JP,K) = NCDHLD(J,K)
329 FIRSTC = .FALSE.
IF (NCELLS .EQ. MAXCEL) GO TO 380
NCELLS = NCELLS + 1
NCELL(I) = ISUM
DO 330 J = 1,NVART
CLLSS(I,J) = 0.0
330 CELLM(I,J) = 0.0
OBS(I) = 0.0
DO 340 J = 1,NFACT
340 NCDHLD(I,J) = NCODE(J)
350 OBS(I) = OBS(I)+1.
IF (TRANS) CALL TRANSF(NVART,X,TRANCD)
DO 360 K = 1,NVART
CELLM(I,K)=CELLM(I,K)+X(K)
IF (OBS(I) .EQ. 1.0) GO TO 360
DIFF1 = OBS(I)*X(K)-CELLM(I,K)
DIFF2 = DIFF1/(OBS(I)*(OBS(I)-1.))
CLLSS(I,K) = CLLSS(I,K) + DIFF1*DIFF2
DO 355 L = 1,K
355 SSWITH(L,K) =SSWITH(L,K) + (OBS(I)*X(L)-CELLM(I,L))*DIFF2
360 CONTINUE
GO TO 290
380 WRITE(IOUT,400) KOBS
400 FORMAT (46H0ERROR IN DATA OR TOO MANY CELLS OBSERVATION I10)
ERROR = .TRUE.
430 WRITE(IOUT,432)NCELLS
432 FORMAT (1H0,I3,6H CELLS )
IF (NCELLS .NE. 0) GO TO 434
ERROR = .TRUE.
GO TO 530
434 OBST = 0.0
DO 450 I = 1,NCELLS
OBST = OBST + OBS(I)
DO 450 J = 1,NVART
IF (OBS(I) .EQ. 1.0) GO TO 450
CLLSS(I,J) = SQRT(CLLSS(I,J)/(OBS(I)-1.))
450 CELLM(I,J) = CELLM(I,J)/OBS(I)
NOBST = OBST
IF (.NOT. PRINTM) GO TO 530
ENCODE(23,540,FMT),NFACT
540 FORMAT('(1H ,',I4,'I3,I10,4H OBS)')
N2 = 0
IF (NCELLS .LE. 8) WRITE (IOUT,470)
470 FORMAT (1H1 50X 30HMEANS AND STANDARD DEVIATIONS )
480 N1 = N2+1
N2 = N1+7
IF (N2 .GT. NVART) N2 = NVART
IF (NCELLS .GT. 8) WRITE (IOUT,470)
WRITE(IOUT,490) (NTABLE(J), J = 1,MAXFAC),(VARNAM(1,J),
1VARNAM(2,J),J = N1,N2)
490 FORMAT(1H0/ 7H/FACTOR 48X 8HVARIABLE/ 1H 4(2X A1), 23X 8(2XA6,A4))
DO 510 I = 1,NCELLS
NOBS = OBS(I)
WRITE(IOUT,FMT) (NCDHLD(I,J), J = 1,NFACT),NOBS
WRITE(IOUT,500) (CELLM(I,J),J = N1,N2)
500 FORMAT (1H 28X,2H M 5X 8F12.3)
510 IF (NOBS .GT. 1) WRITE(IOUT,520)(CLLSS(I,J), J = N1,N2)
520 FORMAT (1H 28X 2HSD 5X 8F12.3)
IF (N2 .NE. NVART) GO TO 480
530 RETURN
END
SUBROUTINE INVERT(N,A,ERROR,HEAD)
DIMENSION A(14,14), NPERM(19),NSEQ(20),HEAD(3)
DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
DATA IAUX4/24/
LOGICAL ERROR
ERROR = .FALSE.
DO 100 K=1,N
100 NSEQ(K)=K
AMAX=0.
K1=1
110 K=K1
K1=K1+1
IF(N-K) 210,210,120
120 TEMP=ABS (A(K,K))
IPIV=K
DO 140 I=K1,N
IF(TEMP-ABS (A(I,K))) 130,140,140
130 IPIV=I
TEMP=ABS (A(I,K))
140 CONTINUE
IF(IPIV-K) 170,170,150
150 DO 160 J=1,N
TEMP=A(IPIV,J)
A(IPIV,J)=A(K,J)
160 A(K,J)=TEMP
ITEMP=NSEQ(IPIV)
NSEQ(IPIV)=NSEQ(K)
NSEQ(K)=ITEMP
170 IF(AMAX-ABS (A(IPIV,IPIV))) 180,190,190
180 AMAX=ABS (A(IPIV,IPIV))
190 NPERM(K)=IPIV
DO 200 I=K1,N
TEMP=A(I,K)/A(K,K)
A(I,K)=TEMP
DO 200 J=K1,N
200 A(I,J)=A(I,J)-TEMP*A(K,J)
K=K+1
GO TO 110
210 DO 290 K=1,N
J=0
220 J=J+1
IF(K-J) 260,260,230
230 TEMP=A(K,J)
I=K
240 I=I+1
IF(N-I) 220,250,250
250 A(I,J)=A(I,J)-TEMP*A(I,K)
GO TO 240
260 I=K
270 I=I+1
IF(N-I) 290,280,280
280 A(I,K)=-A(I,K)
GO TO 270
290 CONTINUE
K=N
300 AKK=A(K,K)
IF(ABS (AKK/AMAX)-.01) 520,520,310
310 AKK=1./AKK
A(K,K)=AKK
J=K
320 J=J+1
IF(N-J) 360,330,330
330 TEMP=AKK*A(K,J)
A(K,J)=TEMP
I=0
340 I=I+1
IF(K-I) 320,320,350
350 A(I,J)=A(I,J)-TEMP*A(I,K)
GO TO 340
360 I=0
370 I=I+1
IF(K-I) 390,390,380
380 A(I,K)=-AKK*A(I,K)
GO TO 370
390 K=K-1
IF(K) 400,400,300
400 K1=1
410 K=K1
K1=K1+1
IF(N-K) 470,470,420
420 AKK=A(K,K)
DO 460 J=K1,N
AKK=AKK+A(K,J)*A(J,K)
SUMR=A(K,J)
SUMC=A(J,J)*A(J,K)
J1=J+1
IF(N-J1) 450,430,430
430 DO 440 I=J1,N
SUMR=SUMR+A(K,I)*A(I,J)
440 SUMC=SUMC+A(J,I)*A(I,K)
450 A(K,J)=SUMR
460 A(J,K)=SUMC
A(K,K)=AKK
GO TO 410
470 J=N
480 J=J-1
IF(J) 540,540,490
490 JPIV=NPERM(J)
IF(J-JPIV) 500,480,500
500 DO 510 I=1,N
TEMP=A(I,J)
A(I,J)=A(I,JPIV)
510 A(I,JPIV)=TEMP
GO TO 480
520 ERROR = .TRUE.
WRITE (IOUT,530)HEAD,(NSEQ(L),L=1,K)
530 FORMAT (14H0IN THE ABOVE 2A4,A2,13H MATRIX, ROW I3, 48H IS PROBABL
1Y A LINEAR COMBINATION OF ROWS 24I3)
540 RETURN
END
SUBROUTINE GRAM(XMAT,NROW,NCOLX)
DIMENSION XMAT(14,14),CON(20)
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
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 210 K=1,NCOLX
KK=NCOLX-K+1
TEMP=XMAT(KK,KK)/CON(KK)
XMAT(KK,KK)=1.-TEMP*XMAT(KK,KK)
IF (NROW .EQ. KK) GO TO 170
KK1=KK+1
DO 160 I=KK1,NROW
160 XMAT(I,KK)=-TEMP*XMAT(I,KK)
170 KM=KK-1
IF (KM .EQ. 0) GO TO 220
DO 180 I = 1,KM
180 XMAT(I,KK) = 0.0
DO 210 L=1,KM
LL=KK-L
SUM=0.
DO 190 I=LL,NROW
190 SUM=SUM+XMAT(I,LL)*XMAT(I,KK)
TEMP=SUM/CON(LL)
DO 200 I=LL,NROW
200 XMAT(I,KK)=XMAT(I,KK)-TEMP*XMAT(I,LL)
210 CONTINUE
220 RETURN
END
SUBROUTINE TRANSF(NVART,X,TRANCD)
DIMENSION X(50), TRANCD(50),SAVE(50)
INTEGER TRANCD
DO 90 I = 1,NVART
90 SAVE(I) = X(I)
DO 140 I = 1,NVART
IF (TRANCD(I) .GT. 3) GO TO 130
M = TRANCD(I) + 1
GO TO (140,100,110,120), M
100 X(I) = SQRT(X(I))
GO TO 140
110 X(I) = ALOG(X(I))
GO TO 140
120 X(I) = ASIN(X(I))
GO TO 140
130 CALL SPECTR(I,X,TRANCD,SAVE)
140 CONTINUE
RETURN
END
SUBROUTINE SPECTR(I,X,TRANCD,SAVE)
DIMENSION X(50),TRANCD(50),SAVE(50)
INTEGER TRANCD
C LIST TO INDICATE ONE OF SEVERAL TRANSFORMATIONS. THIS AND THE
XI = SAVE(I)
IND = TRANCD(I)
GO TO (1,1,1,4,5,6,7,8,9), IND
4 X(I) = 1.0/XI
GO TO 1
5 X(I) = ALOG(XI +.5)
GO TO 1
6 X(I) = XI /(1.0-XI )
GO TO 1
7 X(I) = .5*ALOG( (1.0+XI )/(1.0 - XI ) )
GO TO 1
8 X(I) = ALOG(XI /(1.0-XI ) )
GO TO 1
9 X(I) = ASIN(SQRT(XI ) )
1 RETURN
END
FUNCTION MSIGN(N)
MSIGN=N
RETURN
END
SUBROUTINE ALPHAN(N,NTABLE,IHOLV)
DIMENSION NTABLE (1),IHOLV(20)
NO=N*5
DECODE(NO,3,IHOLV)(NTABLE(I),I=1,N)
3 FORMAT(20A4)
RETURN
END