Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/manova/manov1.for
There is 1 other file named manov1.for in the archive. Click here to see a list.
00100	C	WMU IMPLEMENTATION OF THE WAYNE STATE VERSION OF
00200	C
00300	C	THE MIAMI MULTIVARIATE ANALYSIS OF VARIANCE(MANOVA)
00400	C
00500	C	MODIFIED FOR WMU COMPUTER CENTER BY:	SAM ANEMA
00600	C
00700	C	FILES: MANOVA.F4,MANOV1.F4,MANOV2.F4,MANOV3.F4,MANOV4.F4
00800	C
00900	C	ADDITIONAL SUBROUTINES: USAGE - RUSS BARR(IN NGLIB).MAC
01000	C
01100	C	LOADING PROCEDURE:
01200	C
01300	C	R LOADER
01400	C	MANOV=MANOVA,USAGE/<MANOV1/>MANOV2/>MANOV3/>MANOV4/>/G
01500	C	SAV MANOVA
01600	C
01700	C	MANOV1.F4
01800	      SUBROUTINE RDCONT
01900	      DIMENSION XKONE(14,14,5), NCDHLD(100,8),VECHLD(100),
02000	     1LIST(720),     OPTION(75), INLET(75), RECODE(8,20),SSRES(25,26)
02100	      DIMENSION XNUM(50)
02200	      COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
02300	     1ESTIM(50,50),        NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
02400	     2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
02500	     3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
02600	     4      ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
02700	     5           FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
02800	     6SPECOR,VLIST,PRINTR,NFACT , READK,  PRINTK,CONTR ,TESTR, MFIRST,
02900	     7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,APROB,
03000	     8AANALY,AFINIS,WITHIN,SPACE(10)
03100	      EQUIVALENCE (ESTIM,XKONE), (RECODE,DUMMY),(TAGP,SPACE(3)),
03200	     1(SSEAD,OPTION,INLET),   (LIST,SSEAD(876) ),(SSRES,SSHYP),
03300	     2(TAG,SPACE(1) ), (NCDHLD,SSEAD(76) ), (EONLY,SPACE(2) )
03400	     3,(PRTSSH,SPACE(5)),(NPCT,SPACE(6)),(NSIG,SPACE(7))
03500	      DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
03600	      DATA IAUX4/24/
03700	      LOGICAL TRUTH, FIRST, ERROR,       RDNAM, TESTR, TRANS, PRINTK,
03800	     1PRINTR, SPECOR, CONTR, VLIST, RVARC ,IN4,  FIRSTT,READK ,MFIRST,
03900	     2PRINTM, EONLY,PRTSSH
04000	      DOUBLE PRECISION ABLANK,VARNAM,VECHLD
04100	      INTEGER RECODE,TRANCD,                  TWO24,OPTION,BLANK
04200	      DATA XNUM/' 1  ',' 2  ',' 3  ',' 4  ',' 5  ',' 6  ',' 7  ',' 8  ',
04300	     C   ' 9  ','10  ','11  ','12  ','13  ','14  ','15  ','16  ','17  ',
04400	     C   '18  ','19  ','20  ','21  ','22  ','23  ','24  ','25  ','26  ',
04500	     C   '27  ','28  ','29  ','30  ','31  ','32  ','33  ','34  ','35  ',
04600	     C   '36  ','37  ','38  ','39  ','40  ','41  ','42  ','43  ','44  ',
04700	     C   '45  ','46  ','47  ','48  ','49  ','50  '/
04800	      DATA  LR/4HR   /, ABLANK/8H         /
04900	      FIRSTT = .TRUE.
05000	      IF (FIRST) GO TO 100
05100	      IF (ERROR) GO TO 120
05200	      IF (.NOT. TRUTH) GO TO 150
05300	      GO TO 310
05400	  100 CALL ALPHAN(19,NTABLE(9),76H0   1   2   3   4   5   6   7   8   9
05500	     1   ,       +   .   =   -   W   G   M        )
05600	      CALL ALPHAN(4,ATITLE,16HTITLPROBANALFINI  )
05700	      CALL ALPHAN(1,BLANK,4H         )
05800	      DO 105 J=1,50
05900	  105 HNUM(J)=XNUM(J)
06000	  110 ITABLE(1,1) = 1
06100	      ITABLE(1,2) = 2
06200	      ITABLE(1,3) = 1
06300	      ITABLE(1,4) = 5
06400	      ITABLE(1,5) = 1
06500	      ITABLE(1,6) = 1
06600	      ITABLE(1,7) = 1
06700	      ITABLE(1,8) = 1
06800	      ITABLE(1,9) = 1
06900	      ITABLE(2,1) = 4
07000	      ITABLE(2,2) = 10
07100	      ITABLE(2,3) = 4
07200	      ITABLE(2,4) = 5
07300	      ITABLE(2,5) = 4
07400	      ITABLE(2,6) = 4
07500	      ITABLE(2,7) = 4
07600	      ITABLE(2,8) = 4
07700	      ITABLE(2,9) = 4
07800	      ITABLE(3,1) = 3
07900	      ITABLE(3,2) = 5
08000	      ITABLE(3,3) = 5
08100	      ITABLE(3,4) = 3
08200	      ITABLE(3,5) = 5
08300	      ITABLE(3,6) = 5
08400	      ITABLE(3,7) = 5
08500	      ITABLE(3,8) = 5
08600	      ITABLE(3,9) = 3
08700	      ITABLE(4,1) = 4
08800	      ITABLE(4,2) = 5
08900	      ITABLE(4,3) = 5
09000	      ITABLE(4,4) = 4
09100	      ITABLE(4,5) = 5
09200	      ITABLE(4,6) = 5
09300	      ITABLE(4,7) = 11
09400	      ITABLE(4,8) = 11
09500	      ITABLE(4,9) = 4
09600	      ITABLE(5,1) = 6
09700	      ITABLE(5,2) = 5
09800	      ITABLE(5,3) = 5
09900	      ITABLE(5,4) = 5
10000	      ITABLE(5,5) = 5
10100	      ITABLE(5,6) = 5
10200	      ITABLE(5,7) = 5
10300	      ITABLE(5,8) = 5
10400	      ITABLE(5,9) = 5
10500	      ITABLE(7,1) = 5
10600	      ITABLE(7,2) = 7
10700	      ITABLE(7,3) = 5
10800	      ITABLE(7,4) = 5
10900	      ITABLE(7,5) = 5
11000	      ITABLE(7,6) = 5
11100	      ITABLE(7,7) = 5
11200	      ITABLE(7,8) = 5
11300	      ITABLE(7,9) = 5
11400	      ITABLE(8,1) = 5
11500	      ITABLE(8,2) = 8
11600	      ITABLE(8,3) = 5
11700	      ITABLE(8,4) = 5
11800	      ITABLE(8,5) = 5
11900	      ITABLE(8,6) = 5
12000	      ITABLE(8,7) = 5
12100	      ITABLE(8,8) = 5
12200	      ITABLE(8,9) = 5
12300	      ITABLE(9,1) = 9
12400	      ITABLE(9,2) = 5
12500	      ITABLE(9,3) = 9
12600	      ITABLE(9,4) = 5
12700	      ITABLE(9,5) = 5
12800	      ITABLE(9,6) = 9
12900	      ITABLE(9,7) = 5
13000	      ITABLE(9,8) = 9
13100	      ITABLE(9,9) = 5
13200	      NPCT = 0
13300	  120 FIRSTT = .TRUE.
13400	      IF (.NOT. ERROR) WRITE         (IOUT,125)
13500	  125 FORMAT(1H1//' WESTERN MICHIGAN UNIVERSITY'//,
13600	     1	 ' MULTI-VARIATE ANALYSIS OF VARIANCE'/)
13700	  130 READ(INP,140)TAG,TAGP,OPTION
13800	  140 FORMAT (A4,76A1)
13900	  150 IF (TAG .NE. ATITLE .AND. TAG .NE. APROB) GO TO 560
14000	      IF       (ERROR) WRITE         (IOUT,125)
14100	      FIRST = .TRUE.
14200	      EONLY = .FALSE.
14300	      NSIG = 1
14400	  170 IF (TAG .EQ. APROB) GO TO 190
14500	      IF (TAG .NE. ATITLE) GO TO 560
14600	      WRITE(IOUT,180)OPTION
14700	  180 FORMAT (1H 80A1)
14800	      READ(INP,140) TAG,TAGP,OPTION
14900	      GO TO 170
15000	  190 ERROR = .FALSE.
15100	      DO 200 I = 1,8
15200	  200 NTABLE(I) = BLANK + 1
15300	      TWO24 = 16777216
15400	      DO 210 J = 1,4
15500	      IF (OPTION(J) .NE. BLANK) GO TO 205
15600	      OPTION(J)=0
15700	      GO TO 210
15800	  205 OPTION(J)=(OPTION(J)/"4000000000)-"60
15900	  206 FORMAT(I1)
16000	  210 CONTINUE
16100	      NVART = OPTION(1)*10 + OPTION(2)
16200	      NFACT = OPTION(3)
16300	      NFMT = OPTION(4)
16400	      RDNAM  = OPTION( 5) .NE. BLANK
16500	      VLIST  = OPTION( 6) .NE. BLANK
16600	      SPECOR = OPTION( 7) .NE. BLANK
16700	      TESTR  = OPTION( 8) .NE. BLANK
16800	      RVARC  = OPTION( 9) .NE. BLANK
16900	C     READ DATA FROM TAPE 4
17000	      IN4    = OPTION(10) .NE. BLANK
17100	      IF (OPTION(10) .EQ. LR) REWIND IAUX4
17200	      PRINTM = OPTION(11) .EQ. BLANK
17300	      TRANS  = OPTION(12) .NE. BLANK
17400	      PRINTK = OPTION(13) .NE. BLANK
17500	      PRINTR = OPTION(14) .NE. BLANK
17600	      READK  = OPTION(15) .NE. BLANK
17700	      MFIRST = OPTION(16) .EQ. BLANK
17800	      PRTSSH = OPTION(17) .NE. BLANK
17900	      IF (OPTION(18) .EQ. BLANK) GO TO 215
18000	      REWIND IAUX4
18100	  212 READ(INP,140)TAG,TAGP,OPTION
18200	      WRITE(IAUX4,140) TAG,TAGP,OPTION
18300	      IF (TAG .NE. AFINIS) GO TO 212
18400	      REWIND IAUX4
18500	  215 NPCT = (NPCT/1000)+1
18600	      WRITE(IOUT,220)  NPCT,NVART,NFACT
18700	  220 FORMAT (8H0PROBLEM I4,I4, 10H VARIABLES I3, 8H FACTORS /)
18800	      NPCT  = NPCT*1000
18900	      IF (NVART .GT. MAXVAR .OR. NFACT .GT. MAXFAC) GO TO 540
19000	      DO 230 I = 1,NVART
19100	      IORD(I) = I
19200	      IPOSV(I) = I
19300	  230 IVPOS(I) = I
19400	      IF (RDNAM) GO TO 250
19500	      DO 240 J = 1,NVART
19600	      VARNAM(1,J) = ABLANK
19700	  240 VARNAM(2,J) = HNUM(J)
19800	      GO TO 270
19900	  250 READ(INP,260)((VARNAM(J,I),J = 1,2),I = 1,NVART)
20000	  260 FORMAT (8(A6,A4))
20100	  270 NVAR = NVART
20200	      IF(RDNAM)WRITE(IOUT,300)(VARNAM(1,J), VARNAM(2,J),J = 1,NVART)
20300	      NCOVAR = 0
20400	      IF (VLIST)READ(INP,280)NVAR,NCOVAR,(IORD(J),J = 1,38)
20500	  280 FORMAT (40I2)
20600	      NVCVAR = NVAR+NCOVAR
20700	      IF(VLIST.AND.NVCVAR.GT. 38) READ(INP,280)(IORD(J), J = 39,NVCVAR)
20800	      IF (NCOVAR .EQ. 0) NCOVAR = 0
20900	      WRITE(IOUT,290)NVAR,NCOVAR
21000	  290 FORMAT (1H0I2,9H CRITERIA I4, 43H COVARIATES  WITH THE FOLLOWING V
21100	     1ARIABLES      )
21200	      IF (NVCVAR .GT. NVART) GO TO 540
21300	      N2 = 2*NVCVAR
21400	      DO 295 J = 1,NVCVAR
21500	      J1 = IORD(J)
21600	      VECHLD(2*J-1) = VARNAM(1,J1)
21700	  295 VECHLD(2*J) = VARNAM(2,J1)
21800	      WRITE(IOUT,300)(VECHLD(J), J = 1,N2)
21900	  300 FORMAT (10(3X A6,A4) )
22000	  310 NVARTP = NVART+1
22100	      REWIND IAUX1
22200	      IF (FIRST) GO TO 330
22300	      DO 320 I = 1,NVART
22400	      IPOSV(I) = I
22500	  320 IVPOS(I) = I
22600	      IF (.NOT. CONTR) GO TO 430
22700	      READ(IAUX1)(((XKONE(I,J,K),I = 1,MAXLEV),J = 1,MAXLEV),K= 1,NFACT)
22800	      READ(IAUX1)   ((NCDHLD(J,K),J = 1,NCELLS),K = 1,NFACT)
22900	      READ(IAUX1)((ORTHES(J,K),J = 1,NCELLS), K = 1,NVART),((SSRES(J,K),
23000	     1J = 1,NVART),K = 1,NVARTP), ((VARNAM(J,K),J = 1,2),K = 1,NVART)
23100	      REWIND IAUX1
23200	  330 DO 420 I = 1,NFACT
23300	      READ(INP,340) NTABLE(I), ICONT,    M, (LEVSUB(I,J),J = 2,9),
23400	     1(RECODE(I,J), J = 1,20    ), (INLET(J),J = 1,5)
23500	  340 FORMAT (A1,I1,29I2,5A4)
23600	      NOREC=' '
23700	      IF (NOREC .NE. BLANK )  GO TO 360
23800	      DO 350 J = 1,M
23900	  350 RECODE(I,J) = J
24000	  360 LEVEL(I) = M
24100	      WRITE(IOUT,370)NTABLE(I),LEVEL(I), (INLET(J),J = 1,5)
24200	  370 FORMAT(8H0FACTOR A1,I5,7H LEVELS  10X,5A4)
24300	      IF (LEVEL(I) .EQ. 0 .OR. LEVEL(I) .GT. MAXLEV) GO TO 540
24400	      LEVSUB(I,1)    = LEVEL(I) - 1
24500	      LEVCUM(I,1)    = 1
24600	      IF (LEVSUB(I,2) .EQ. 0) GO TO 410
24700	      LEVCUM(I,2) = 1
24800	      DO 390 J = 2,9
24900	      IF (LEVSUB(I,J) .EQ. 0) GO TO 400
25000	      J1 = J-1
25100	      WRITE(IOUT,380)NTABLE(I),J1,LEVSUB(I,J )
25200	  380  FORMAT (1H 9X, A1,I1,4H HAS I3,3H DF)
25300	  390 LEVCUM(I,J+1 ) = LEVCUM(I,J)  + LEVSUB(I,J)
25400	      J = 10
25500	  400 IF (LEVEL(I) .NE. LEVCUM(I,J))GO TO 520
25600	  410 CALL GETK1(ICONT,I,LEVEL(I),XKONE,LEVSUB,NTABLE,ERROR)
25700	      IF (ERROR) GO TO 120
25800	  420 CONTINUE
25900	      WRITE(IAUX1)(((XKONE(I,J,K),I=1,MAXLEV),J= 1,MAXLEV), K = 1,NFACT)
26000	  430 IF (.NOT. SPECOR) GO TO 460
26100	      DO 450 N1 = 1,641,80
26200	      N2 = N1 + 79
26300	      READ(INP,440) (LIST(J),J = N1,N2)
26400	  440 FORMAT (80A1)
26500	      DO 450 J = N1,N2
26600	      IF (LIST(J) .EQ.'.' ) GO TO 460
26700	  450 CONTINUE
26800	      GO TO 510
26900	  460 IF (.NOT. FIRST .AND. .NOT. CONTR) GO TO 480
27000	      IF (.NOT. FIRST) GO TO 470
27100	      CALL RDDAT(NOBST,NFMT,TRANS,IN4,PRINTM)
27200	      NERWIT = NOBST-NCELLS
27300	      IF (ERROR) GO TO 120
27400	  470 WRITE(IAUX1)  ((NCDHLD(J,K),J = 1,NCELLS),K = 1,NFACT)
27500	      WRITE(IAUX1)((ORTHES(J,K),J = 1,NCELLS),K = 1,NVART),((SSRES(J,K),
27600	     1J = 1,NVART),K = 1,NVARTP), ((VARNAM(J,K),J = 1,2),K = 1,NVART)
27700	      REWIND IAUX1
27800	  480 DO 500 J = 1,MAXLEV
27900	      DO 490 K = 1,MAXLEV
28000	  490 XKONE(J,K,MAXFAC+1) = 0.0
28100	  500 XKONE(J,J,MAXFAC+1) = 1.0
28200	      READ(IAUX1)(((XKONE(I,J,K),I=1,MAXLEV),J = 1,MAXLEV), K = 1,NFACT)
28300	510   RETURN
28400	  520 WRITE(IOUT,530)
28500	  530 FORMAT (25H SUBEFFECTS ABOVE WRONG    )
28600	      GO TO 120
28700	  540 WRITE(IOUT,550)
28800	  550 FORMAT (13H ERROR ABOVE   )
28900	      GO TO 120
29000	  560 IF (TAG .EQ. AFINIS) GO TO 580
29100	      IF (.NOT. FIRSTT)GO TO 130
29200	      WRITE(IOUT,570)TAG,OPTION
29300	  570 FORMAT (1H A4,76A1/40H ABOVE NOT VALID HERE, SKIPPING PROBLEM   )
29400	      FIRSTT = .FALSE.
29500	      GO TO 130
29600	  580 WRITE(IOUT,590)
29700	  590 FORMAT  (12H1END OF DATA  )
29800	      STOP
29900	      END
30000	      SUBROUTINE GETK1(ICONT,N1,NLEV,XKONE,LEVSUB,NTABLE,ERROR)
30100	      LOGICAL ERROR
30200	      DIMENSION  XKONE(14,14,5), LEVSUB(8,10), NTABLE(27)
30300	      DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
30400	      DATA IAUX4/24/
30500	      M = ICONT+1
30600	      NBLANK = NTABLE(20)
30700	      NSUM = 2
30800	      K=0
30900	      IF (M .GT. 4) GO TO 350
31000	      GO TO (100,150,220,280),M
31100	  100 IF (NLEV .EQ. 1) GO TO 140
31200	      WRITE (IOUT,110)
31300	  110 FORMAT (23H   DEVIATION CONTRASTS   )
31400	      DO 130 I = 2,NLEV
31500	      XKONE(I-1,1,N1) = 1.0
31600	      XKONE(NLEV,I,N1) = -1.0
31700	      DO 130 J = 2,NLEV
31800	      IF (I .NE. J) GO TO 120
31900	      XKONE(I-1,J,N1) = 1.0
32000	      GO TO 130
32100	  120 XKONE(I-1,J,N1) = 0.0
32200	  130 CONTINUE
32300	  140 XKONE(NLEV,1,N1) = 1.0
32400	      GO TO 340
32500	  150 SUM = 0.0
32600	      WRITE (IOUT,160)
32700	  160 FORMAT (20H   SPECIAL CONTRASTS )
32800	      I = 0
32900	  165 I = I+1
33000	      READ (INP,170)(XKONE(I,J,N1),J=1,NLEV)
33100	  170 FORMAT (16F5.0)
33200	      GO TO 330
33300	  180 WRITE (IOUT,190)LETTER,NUMB,(XKONE(I,J,N1),J=1,NLEV)
33400	  190 FORMAT (3X,2A1,10F12.5/(5X,10F12.5) )
33500	  200 SUM = SUM + XKONE(1,I,N1)
33600	      IF (I .LT. NLEV) GO TO 165
33700	      DO 210 I = 1,NLEV
33800	  210 XKONE(1,I,N1) = XKONE(1,I,N1)/SUM
33900	      CALL INVERT(NLEV,XKONE(1,1,N1),E    ,10HCONTRAST    )
34000	      GO TO 340
34100	C
34200	  220 READ (INP,170)(XKONE(I,2,N1),I=1,NLEV)
34300	      WRITE (IOUT,230)(XKONE(I,2,N1),I=1,NLEV)
34400	  230 FORMAT (45H   ORTHOGONAL POLYNOMIAL CONTRASTS WITH SCALE /
34500	     1(5X 10F12.5) )
34600	      WRITE (IOUT,190)
34700	      A = .5*(XKONE(NLEV,2,N1) + XKONE(1,2,N1) )
34800	      B = 2./(XKONE(NLEV,2,N1) - XKONE(1,2,N1) )
34900	      DO 240 I = 1,NLEV
35000	      XKONE(I,2,N1) = B*(XKONE(I,2,N1)-A)
35100	  240 XKONE(I,1,N1) = 1.0
35200	      DO 250 I = 3,NLEV
35300	      DO 250 J = 1,NLEV
35400	  250 XKONE(J,I,N1) = 2.0*XKONE(J,I-1,N1)*XKONE(J,2,N1)- XKONE(J,I-2,N1)
35500	      CALL GRAM(XKONE(1,1,N1),NLEV,NLEV)
35600	      DO 260 I = 1,NLEV
35700	  260 XKONE(I,1,N1) = 1.0
35800	      I = 0
35900	  265 I = I+1
36000	      GO TO 330
36100	  270 WRITE (IOUT,190)LETTER,NUMB,(XKONE(J,I,N1),J=1,NLEV)
36200	      IF (I .LT. NLEV) GO TO 265
36300	      GO TO 340
36400	  280 XKONE(1,1,N1) = 1.0
36500	      WRITE (IOUT,290)
36600	  290 FORMAT (25H   DIFFERENCE CONTRASTS   )
36700	      DO 320 K = 2,NLEV
36800	      RK = -1.0/FLOAT(K)
36900	      XKONE(K,1,N1) = 1.0
37000	      DO 300 J = K,NLEV
37100	  300 XKONE(J,K,N1) = 0.0
37200	      DO 310 J = 1,K
37300	  310 XKONE(J,K,N1) = RK
37400	  320 XKONE(K,K,N1) = 1.0 + RK
37500	      GO TO 340
37600	  330 LETTER = NBLANK
37700	      NUMB = NBLANK
37800	      IF (I .NE. NSUM) GO TO (180,270),ICONT
37900	      LETTER = NTABLE(N1)
38000	      NUMB = NTABLE(K+10)
38100	      K = K+1
38200	      NSUM = NSUM + LEVSUB(N1,K+1)
38300	      GO TO (180,270), ICONT
38400	340   RETURN
38500	  350 ERROR = .TRUE.
38600	      GO TO 340
38700	      END
38800	      SUBROUTINE RDDAT(NOBST,NFMT,TRANS,IN4,PRINTM)
38900	      DIMENSION TRANCD(50), RECODE(8,20),
39000	     1FMT(180) ,X(50),NCODE(8) ,SSWITH(25,25),CELLM(100,20),
39100	     2CLLSS(50,20),NCDHLD(100,8),SSRES(25,26)
39200	      COMMON ORTHES(100,20),DUMMY(26,27),SSHYP(25,26),SSEAD(40,41),
39300	     1ESTIM(50,50),            NUMERR(8),NERRS(100),NDFCUM(100),NDFTST(
39400	     2100),VARNAM(2,50),HEAD(3,100),LEVEL(8),LEVSUB(8,10),LEVCUM(8,10),
39500	     3NCELL(100), NTABLE(27),ITABLE(9,9),OBS(100)
39600	     4      ,NVAR,NCOVAR,NERWIT,NERRES,HNUM(100),ERROR,NTESTS,RVARC,
39700	     5           FIRST,IORD(50),IPOSV(50),IVPOS(50),NCELLS,NVART,NDFTOT,
39800	     6SPECOR,VLIST,PRINTR,NFACT , READK,  PRINTK,CONTR ,TESTR, MFIRST,
39900	     7TRUTH,BLANK,MAXFAC,MAXCEL,MAXPAR,MAXLEV,MAXVAR,ATITLE,AJOBCD,
40000	     8AANALY,AFINIS,WITHIN,SPACE(10)
40100	      EQUIVALENCE (ESTIM,CLLSS), (ORTHES,CELLM,DESIGN),
40200	     1(SSWITH,SSRES(1,2) ),  (RECODE,DUMMY),(NCDHLD,SSEAD(76) ),
40300	     2(TRANCD,SSEAD), (SSRES,SSHYP)
40400	      DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
40500	      DATA IAUX4/24/
40600	      INTEGER RECODE,TRANCD
40700	      DOUBLE PRECISION VARNAM
40800	      LOGICAL ERROR,END,FIRSTC,TRANS,IN4,PRINTM
40900	C
41000	      FIRSTC = .TRUE.
41100	      NCELLS = 0
41200	      KOBS = 0
41300	      DO 100 J = 1,NVART
41400	      DO 100 K = J,NVART
41500	      SSRES(K,J) = 0.0
41600	  100 SSWITH(J,K) = 0.0
41700	      IF (NFMT .NE. 0) GO TO 120
41800	      N = 10-NFACT
41900	      ENCODE(37,601,FMT) NFACT,N
42000	601   FORMAT('(2X,',I4,'I1,',I4,'X,10F6.0/(12X,10F6.0))')
42100	      GO TO 160
42200	  120 NFMT20 = NFMT*20
42300	      WRITE(IOUT,130)
42400	  130 FORMAT   ( 21H0FORMAT OF DATA CARDS )
42500	      READ(INP,140) (FMT(J), J = 1,NFMT20)
42600	  140 FORMAT (20A4)
42700	      WRITE(IOUT,150)(FMT(J), J = 1,NFMT20)
42800	  150 FORMAT (4X 20A4)
42900	  160 IF (.NOT. TRANS) GO TO 280
43000	      READ(INP,170) (TRANCD(I),I = 1,NVART)
43100	  170 FORMAT (80I1)
43200	      WRITE(IOUT,180)
43300	  180 FORMAT (17H0TRANSFORMATIONS    )
43400	      DO 270 I = 1,NVART
43500	      M = TRANCD(I) + 1
43600	      IF (M .GT. 4) GO TO 250
43700	      GO TO (270,190,210,230), M
43800	  190 WRITE(IOUT,200)VARNAM(1,I), VARNAM(2,I)
43900	  200 FORMAT (16H SQRT  TRANS VAR   2X A6,A4)
44000	      GO TO 270
44100	  210 WRITE(IOUT,220) VARNAM(1,I), VARNAM(2,I)
44200	  220 FORMAT (16H LOGE  TRANS VAR   2X,A6,A4)
44300	      GO TO 270
44400	  230 WRITE(IOUT,240) VARNAM(1,I), VARNAM(2,I)
44500	  240 FORMAT (16H ASIN  TRANS VAR   2X A6,A4)
44600	      GO TO 270
44700	  250 WRITE(IOUT,260) TRANCD(  I), VARNAM(1,I), VARNAM(2,I)
44800	  260 FORMAT(5H USER I1,10H TRANS VAR  2X A6,A4)
44900	  270 CONTINUE
45000	  280 I = 0
45100	  290 IF (IN4)   GO TO 300
45200	      READ (INP,FMT)   (NCODE(K),K = 1,NFACT), (X(K), K = 1,NVART)
45300	      GO TO 305
45400	  300 READ (IAUX4,FMT) (NCODE(K),K = 1,NFACT), (X(K), K = 1,NVART)
45500	  305 DO 307 K = 1,NVART
45600	      IF (X(K) .NE. 0.) GO TO 311
45700	  307 CONTINUE
45800	      DO 310 K = 1,NFACT
45900	      IF (NCODE(K) .NE. 0)  GO TO 311
46000	  310 CONTINUE
46100	      GO TO 430
46200	  311 KOBS = KOBS + 1
46300	      ISUM = 0
46400	      DO 320 J = 1,NFACT
46500	      KLEV = LEVEL(J)
46600	      DO 318 K = 1,KLEV
46700	      IF (NCODE(J) .EQ. RECODE(J,K) ) GO TO 321
46800	  318 CONTINUE
46900	  322 WRITE(IOUT,319)KOBS,  (NCODE(NUMFAC), NUMFAC=1,NFACT)
47000	  319 FORMAT  (20X,11HOBSERVATION I10,47H OMITTED FROM ANALYSIS BECAUSE
47100	     1OF BAD CELL CODE        8I3)
47200	      GO TO 290
47300	  321 ISUM0 = ISUM
47400	      ISUM = ISUM*LEVEL(J) + K - 1
47500	      IF (ISUM .LT. ISUM0) GO TO 322
47600	  320 CONTINUE
47700	      IF (FIRSTC) GO TO 325
47800	      DO 323 I = 1,NCELLS
47900	      IF (ISUM .LT. NCELL(I)) GO TO 326
48000	      IF (ISUM .EQ. NCELL(I) ) GO TO 350
48100	  323 CONTINUE
48200	  325 I = NCELLS + 1
48300	      GO TO 329
48400	  326 IF (NCELLS .EQ. MAXCEL) GO TO 380
48500	      DO 328 J1 = I,NCELLS
48600	      J = NCELLS - J1 + I
48700	      JP = J+1
48800	      OBS(JP) = OBS(J)
48900	      NCELL(JP) = NCELL(J)
49000	      DO 327 K = 1,NVART
49100	      CELLM(JP,K) = CELLM(J,K)
49200	  327 CLLSS(JP,K) = CLLSS(J,K)
49300	      DO 328 K = 1,NFACT
49400	  328 NCDHLD(JP,K) = NCDHLD(J,K)
49500	  329 FIRSTC = .FALSE.
49600	      IF (NCELLS .EQ. MAXCEL) GO TO 380
49700	      NCELLS = NCELLS + 1
49800	      NCELL(I) = ISUM
49900	      DO 330 J = 1,NVART
50000	      CLLSS(I,J) = 0.0
50100	  330 CELLM(I,J) = 0.0
50200	      OBS(I) = 0.0
50300	      DO 340 J = 1,NFACT
50400	  340 NCDHLD(I,J) = NCODE(J)
50500	  350 OBS(I) = OBS(I)+1.
50600	      IF (TRANS) CALL TRANSF(NVART,X,TRANCD)
50700	      DO 360 K = 1,NVART
50800	      CELLM(I,K)=CELLM(I,K)+X(K)
50900	      IF (OBS(I) .EQ. 1.0) GO TO 360
51000	      DIFF1 = OBS(I)*X(K)-CELLM(I,K)
51100	      DIFF2 = DIFF1/(OBS(I)*(OBS(I)-1.))
51200	      CLLSS(I,K) = CLLSS(I,K) + DIFF1*DIFF2
51300	      DO 355 L = 1,K
51400	  355 SSWITH(L,K) =SSWITH(L,K) + (OBS(I)*X(L)-CELLM(I,L))*DIFF2
51500	  360 CONTINUE
51600	      GO TO 290
51700	  380 WRITE(IOUT,400) KOBS
51800	  400 FORMAT (46H0ERROR IN DATA OR TOO MANY CELLS  OBSERVATION  I10)
51900	      ERROR = .TRUE.
52000	  430 WRITE(IOUT,432)NCELLS
52100	  432 FORMAT (1H0,I3,6H CELLS  )
52200	      IF (NCELLS .NE. 0) GO TO 434
52300	      ERROR = .TRUE.
52400	      GO TO 530
52500	  434 OBST = 0.0
52600	      DO 450 I = 1,NCELLS
52700	      OBST = OBST + OBS(I)
52800	      DO 450 J = 1,NVART
52900	      IF (OBS(I) .EQ. 1.0) GO TO 450
53000	      CLLSS(I,J) = SQRT(CLLSS(I,J)/(OBS(I)-1.))
53100	  450 CELLM(I,J) = CELLM(I,J)/OBS(I)
53200	      NOBST = OBST
53300	      IF (.NOT. PRINTM) GO TO 530
53400	      ENCODE(23,540,FMT) NFACT
53500	540   FORMAT('(1H ,',I4,'I3,I10,4H OBS)')
53600	      N2 = 0
53700	      IF (NCELLS .LE. 8) WRITE (IOUT,470)
53800	  470 FORMAT (1H1 50X 30HMEANS AND STANDARD DEVIATIONS )
53900	  480 N1 = N2+1
54000	      N2 = N1+7
54100	      IF (N2 .GT. NVART) N2 = NVART
54200	      IF (NCELLS .GT. 8) WRITE (IOUT,470)
54300	      WRITE(IOUT,490) (NTABLE(J), J = 1,MAXFAC),(VARNAM(1,J),
54400	     1VARNAM(2,J),J = N1,N2)
54500	  490 FORMAT(1H0/ 7H/FACTOR 48X 8HVARIABLE/ 1H 4(2X A1), 23X 8(2XA6,A4))
54600	      DO 510 I = 1,NCELLS
54700	      NOBS = OBS(I)
54800	      WRITE(IOUT,FMT)  (NCDHLD(I,J), J = 1,NFACT),NOBS
54900	      WRITE(IOUT,500)          (CELLM(I,J),J = N1,N2)
55000	  500 FORMAT (1H 28X,2H M 5X 8F12.3)
55100	  510 IF (NOBS .GT. 1) WRITE(IOUT,520)(CLLSS(I,J), J = N1,N2)
55200	  520 FORMAT (1H 28X 2HSD 5X 8F12.3)
55300	      IF (N2 .NE. NVART) GO TO 480
55400	530   RETURN
55500	      END
55600	      SUBROUTINE INVERT(N,A,ERROR,HEAD)
55700	      DIMENSION A(14,14), NPERM(19),NSEQ(20),HEAD(3)
55800	      DATA INP,IOUT,IAUX1,IAUX2/5,30,22,23/
55900	      DATA IAUX4/24/
56000	      LOGICAL ERROR
56100	      ERROR = .FALSE.
56200	      DO 100 K=1,N
56300	  100 NSEQ(K)=K
56400	      AMAX=0.
56500	      K1=1
56600	  110 K=K1
56700	      K1=K1+1
56800	      IF(N-K) 210,210,120
56900	  120 TEMP=ABS (A(K,K))
57000	      IPIV=K
57100	      DO 140 I=K1,N
57200	      IF(TEMP-ABS (A(I,K))) 130,140,140
57300	  130 IPIV=I
57400	      TEMP=ABS (A(I,K))
57500	  140 CONTINUE
57600	      IF(IPIV-K) 170,170,150
57700	  150 DO 160 J=1,N
57800	      TEMP=A(IPIV,J)
57900	      A(IPIV,J)=A(K,J)
58000	  160 A(K,J)=TEMP
58100	      ITEMP=NSEQ(IPIV)
58200	      NSEQ(IPIV)=NSEQ(K)
58300	      NSEQ(K)=ITEMP
58400	  170 IF(AMAX-ABS (A(IPIV,IPIV))) 180,190,190
58500	  180 AMAX=ABS (A(IPIV,IPIV))
58600	  190 NPERM(K)=IPIV
58700	      DO 200 I=K1,N
58800	      TEMP=A(I,K)/A(K,K)
58900	      A(I,K)=TEMP
59000	      DO 200 J=K1,N
59100	  200 A(I,J)=A(I,J)-TEMP*A(K,J)
59200	      K=K+1
59300	      GO TO 110
59400	  210 DO 290 K=1,N
59500	      J=0
59600	  220 J=J+1
59700	      IF(K-J) 260,260,230
59800	  230 TEMP=A(K,J)
59900	      I=K
60000	  240 I=I+1
60100	      IF(N-I) 220,250,250
60200	  250 A(I,J)=A(I,J)-TEMP*A(I,K)
60300	      GO TO 240
60400	  260 I=K
60500	  270 I=I+1
60600	      IF(N-I) 290,280,280
60700	  280 A(I,K)=-A(I,K)
60800	      GO TO 270
60900	  290 CONTINUE
61000	      K=N
61100	  300 AKK=A(K,K)
61200	      IF(ABS (AKK/AMAX)-.01) 520,520,310
61300	  310 AKK=1./AKK
61400	      A(K,K)=AKK
61500	      J=K
61600	  320 J=J+1
61700	      IF(N-J) 360,330,330
61800	  330 TEMP=AKK*A(K,J)
61900	      A(K,J)=TEMP
62000	      I=0
62100	  340 I=I+1
62200	      IF(K-I) 320,320,350
62300	  350 A(I,J)=A(I,J)-TEMP*A(I,K)
62400	      GO TO 340
62500	  360 I=0
62600	  370 I=I+1
62700	      IF(K-I) 390,390,380
62800	  380 A(I,K)=-AKK*A(I,K)
62900	      GO TO 370
63000	  390 K=K-1
63100	      IF(K) 400,400,300
63200	  400 K1=1
63300	  410 K=K1
63400	      K1=K1+1
63500	      IF(N-K) 470,470,420
63600	  420 AKK=A(K,K)
63700	      DO 460 J=K1,N
63800	      AKK=AKK+A(K,J)*A(J,K)
63900	      SUMR=A(K,J)
64000	      SUMC=A(J,J)*A(J,K)
64100	      J1=J+1
64200	      IF(N-J1) 450,430,430
64300	  430 DO 440 I=J1,N
64400	      SUMR=SUMR+A(K,I)*A(I,J)
64500	  440 SUMC=SUMC+A(J,I)*A(I,K)
64600	  450 A(K,J)=SUMR
64700	  460 A(J,K)=SUMC
64800	      A(K,K)=AKK
64900	      GO TO 410
65000	  470 J=N
65100	  480 J=J-1
65200	      IF(J) 540,540,490
65300	  490 JPIV=NPERM(J)
65400	      IF(J-JPIV) 500,480,500
65500	  500 DO 510 I=1,N
65600	      TEMP=A(I,J)
65700	      A(I,J)=A(I,JPIV)
65800	  510 A(I,JPIV)=TEMP
65900	      GO TO 480
66000	  520 ERROR = .TRUE.
66100	      WRITE (IOUT,530)HEAD,(NSEQ(L),L=1,K)
66200	  530 FORMAT (14H0IN THE ABOVE 2A4,A2,13H MATRIX, ROW I3, 48H IS PROBABL
66300	     1Y A LINEAR COMBINATION OF ROWS        24I3)
66400	540   RETURN
66500	      END
66600	      SUBROUTINE GRAM(XMAT,NROW,NCOLX)
66700	      DIMENSION XMAT(14,14),CON(20)
66800	      N1=NCOLX-1
66900	      DO 150 K=1,NCOLX
67000	      SUM=0.
67100	      DO 100 I=K,NROW
67200	  100 SUM=SUM+XMAT(I,K)**2
67300	      TEMP=SUM
67400	      SUM=SQRT(SUM)
67500	      AKK=XMAT(K,K)
67600	      IF (AKK .LT. 0.0) SUM = -SUM
67700	  110 XMAT(K,K)=AKK+SUM
67800	      CONS=TEMP+SUM*AKK
67900	      CON(K)=CONS
68000	      IF (N1 .LT. K)  GO TO 150
68100	  120 DO 140 J=K,N1
68200	      SUM=0.
68300	      DO 130 I=K,NROW
68400	  130 SUM=SUM+XMAT(I,K)*XMAT(I,J+1)
68500	      TEMP=SUM/CONS
68600	      DO 140 I=K,NROW
68700	  140 XMAT(I,J+1)=XMAT(I,J+1)-TEMP*XMAT(I,K)
68800	  150 CONTINUE
68900	      DO 210 K=1,NCOLX
69000	      KK=NCOLX-K+1
69100	      TEMP=XMAT(KK,KK)/CON(KK)
69200	      XMAT(KK,KK)=1.-TEMP*XMAT(KK,KK)
69300	      IF (NROW .EQ. KK) GO TO 170
69400	      KK1=KK+1
69500	      DO 160 I=KK1,NROW
69600	  160 XMAT(I,KK)=-TEMP*XMAT(I,KK)
69700	  170 KM=KK-1
69800	      IF (KM .EQ. 0) GO TO 220
69900	      DO 180 I = 1,KM
70000	  180 XMAT(I,KK) = 0.0
70100	      DO 210 L=1,KM
70200	      LL=KK-L
70300	      SUM=0.
70400	      DO 190 I=LL,NROW
70500	  190 SUM=SUM+XMAT(I,LL)*XMAT(I,KK)
70600	      TEMP=SUM/CON(LL)
70700	      DO 200 I=LL,NROW
70800	  200 XMAT(I,KK)=XMAT(I,KK)-TEMP*XMAT(I,LL)
70900	  210 CONTINUE
71000	220   RETURN
71100	      END
71200	      SUBROUTINE TRANSF(NVART,X,TRANCD)
71300	      DIMENSION X(50), TRANCD(50),SAVE(50)
71400	      INTEGER TRANCD
71500	      DO 90 I = 1,NVART
71600	   90 SAVE(I) = X(I)
71700	      DO 140 I = 1,NVART
71800	      IF (TRANCD(I) .GT. 3) GO TO 130
71900	      M = TRANCD(I) + 1
72000	      GO TO (140,100,110,120), M
72100	  100 X(I) = SQRT(X(I))
72200	      GO TO 140
72300	  110 X(I) = ALOG(X(I))
72400	      GO TO 140
72500	  120 X(I) = ASIN(X(I))
72600	      GO TO 140
72700	  130 CALL SPECTR(I,X,TRANCD,SAVE)
72800	  140 CONTINUE
72900	      RETURN
73000	      END
73100	      SUBROUTINE SPECTR(I,X,TRANCD,SAVE)
73200	      DIMENSION X(50),TRANCD(50),SAVE(50)
73300	      INTEGER  TRANCD
73400	C     LIST TO INDICATE ONE OF SEVERAL TRANSFORMATIONS.  THIS AND THE
73500	      XI = SAVE(I)
73600	      IND = TRANCD(I)
73700	      GO TO (1,1,1,4,5,6,7,8,9), IND
73800	    4 X(I) = 1.0/XI
73900	      GO TO 1
74000	    5 X(I) = ALOG(XI  +.5)
74100	      GO TO 1
74200	    6 X(I) = XI  /(1.0-XI   )
74300	      GO TO 1
74400	    7 X(I) = .5*ALOG( (1.0+XI  )/(1.0 - XI  ) )
74500	      GO TO 1
74600	    8 X(I) = ALOG(XI  /(1.0-XI   ) )
74700	      GO TO 1
74800	    9 X(I) = ASIN(SQRT(XI   ) )
74900	  1   RETURN
75000	      END
75100	      FUNCTION MSIGN(N)
75200	      MSIGN=N
75300	      RETURN
75400	      END
75500	      SUBROUTINE ALPHAN(N,NTABLE,IHOLV)
75600	      DIMENSION NTABLE (1),IHOLV(20)
75700	      NO=N*5
75800	      DECODE(NO,3,IHOLV)(NTABLE(I),I=1,N)
75900	3     FORMAT(20A4)
76000	      RETURN
76100	      END