Google
 

Trailing-Edge - PDP-10 Archives - decus_20tap5_198111 - decus/20-0137/ilano/ilano.for
There is 1 other file named ilano.for in the archive. Click here to see a list.
00100	C
00200	C	WESTERN  MICHIGAN  UNIVERSITY
00300	C
00400	C
00500	C	ANALYSIS OF VARIANCE
00600	C
00700	C	ADAPTED BY  BERENICE GAN
00800	C	            COMPUTER CENTER, WMU
00900	C	            SEPTEMBER, 1972
01000	C
01100	C
01200	C	THIS PROGRAM IS ADAPTED FROM THE WAYNE STATE UNIVERSITY
01300	C	VERSION OF ANALYSIS OF VARIANCE (BALANOVA) ORIGINALLY WRITTEN AT
01400	C	UNIVERSITY OF ILLINOIS.  THE WMU COMPUTER CENTER DISCLAIM ANY
01500	C	RESPONSIBILITY IN THE DESIGN, EFFICIENCY AND ACCURACY OF
01600	C	THIS PROGRAM.
01700	C
01800	C
01900	C	ASIDE FROM REDUCING THE DIMENSION STATEMENTS AND COMPACTING
02000	C	THE COMMON STATEMENTS, THIS PROGRAM IS DIVIDED INTO 3 PARTS:
02100	C	ILANO.ANO     THE RESIDENT PROGRAM
02200	C	ILANO1.ANO    THE PROGRAM CALLED BY CHAIN 1
02300	C	ILANO2.ANO    THE PROGRAM CALLED BY CHAIN 2
02400	C
02500	C
02600	C
02700	C	SUBROUTINES CONTAINED IN ANO.ANO:
02800	C
02900	C		BOOBOO
03000	C		CHLOOP
03100	C		PRTSN
03200	C	C***********************************************************************
03300	C
03400	C
03500	      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
03600	     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
03700	     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
03800	      DIMENSION FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
03900	     1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
04000	     2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
04100	     3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
04200	     4 X(5000),FMT(16)
04300	      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
04400	     1 JSUBSC(5,5),QNEST(5,19)
04500	      DIMENSION QCOEFX(5,10,100)
04600	      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
04700	     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
04800	     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
04900	     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
05000	     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
05100	     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
05200	      COMMON/BLOCK3/QCOEFX
05300	      COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
05400	     1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
05500	     2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
05600	     3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
05700	     4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
05800	     5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
05900	     6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
06000	     7 SIGDIG
06100	      EQUIVALENCE (QCOEFX,X)
06200	      DATA FCP016/1H0/,FCP017/1HN/,FCP018/1H /,FCP019/1H /,FCP020/1H&/,
06300	     1 FCP021/1HR/,FCP022/1HX/,B/'FINIS'/
06400	C	CALL USAGE('ILANO')
06500	      NIN=2
06600	      NOUT=20
06700	      NSCR1=21
06800	C     MAXIMUM NUMBER OF FACTORS
06900	      MNF=5
07000	C     MAXIMUM NUMBER OF LEGAL SOURCES
07100	      MNS=100
07200	C     MAXIMUM NUMBER OF SIGMA-SQUARED TERMS IN ONE E(MS)
07300	      MICON=10
07400	C     HOLLERITH LITERAL CONSTANTS
07500	      Q0=FCP016
07600	      QN=FCP017
07700	      QB=FCP018
07800	      QBLANK=FCP019
07900	      QP=FCP020
08000	      QRRR=FCP021
08100	      QX=FCP022
08200	29    READ (NIN,30)(TIT(I),I=1,16)
08300	      IF (TIT(1).EQ.B) CALL EXIT
08400	30    FORMAT(16A5)
08500	      WRITE (NOUT,31)(TIT(I),I=1,16)
08600	31    FORMAT(//'1',54X,'WESTERN MICHIGAN UNIVERSITY'//62X,'VERSION OF'//
08700	     1 56X,'UNIVERSITY OF ILLINOIS'///61X,'BALANOVA 5'/61X,10(1H-)//
08800	     2 53X,'ANALYSIS OF VARIANCE PROGRAM'////20X,'TITLE, PARAMETER AND
08900	     3 FACTOR SPECIFICATION CARDS'/20X,47(1H-)///1X,16A5)
09000	C     READ PARAMETER CARD
09100	C     NF = NUMBER OF FACTORS
09200	C     NDEP = NUMBER OF DEPENDENT VARIABLES
09300	C     NINX = NUMBER OF INPUT TAPE FOR DATA CARDS (IF = NIN MAY BE
09400	C                  BE LEFT BLANK)
09500	C     ND1OR2 = 1, DEPENDENT VARIABLES ARE FIRST ON DATA CARDS, FOL-
09600	C                        LOWED BY SUBSCRIPT SET
09700	C            = 2 OR BLANK, DEPENDENT VARIABLES ARE LAST ON DATA CARDS,
09800	C                            PRECEDED BY SUBSCRIPT SET.
09900	C     NCDF = NUMBER OF DATA CARDS PER FORMAT (I.E. PER READ STATEMENT
10000	C                   OR PER SUBJECT) - NOT NECESSARY TO INCLUDE IF
10100	C                   NINX = BLANK OR 7
10200	C     THE FOLLOWING TWO PARAMETERS ARE NORMALLY BLANK - USED PRINC-
10300	C     IPALLY FOR DEBUGGING.
10400	C     LOOPMX = OPTIONAL SPECIFICATION OF LOOPMX - USED TO CONTROL
10500	C                  MAXIMUM NUMBER OF CYCLES IN CERTAIN NESTED LOOPS
10600	C                  - IF LEFT BLANK, LOOPMX IS SET = 5000 BY PROGRAM
10700	C     ILAST = 0, NO DEBUG PRINTING.
10800	C           = 1, DEBUG PRINTING.
10900	      READ (NIN,9)NF,NDEP,NINX,ND1OR2,NCDF,LOOPMX,ILAST,MISDAT
11000	9     FORMAT (13I6)
11100	      WRITE (NOUT,20)NF,NDEP
11200	20    FORMAT(/1X,'THE NUMBER OF FACTORS IS',I6/1X,'THE NUMBER OF DEPENDE
11300	     1NT VARIABLES IS',I6/)
11400	      IF (NF-MNF)820,820,14
11500	820    IF (NF-1)14,14,840
11600	14    WRITE (NOUT,16)NF
11700	16    FORMAT ('0NUMBER OF FACTORS IS',I10,' WHICH IS ILLEGAL')
11800	      CALL BOOBOO(1)
11900	840   NF1=NF-1
12000	C     RESET LOOPMX IF READ IN AS 0
12100	      IF (LOOPMX.LE.0) LOOPMX=5000
12200	C     INPUT DESIGN AND COMPUTE ALL LEGAL SOURCES
12400	730      CALL INPUTD
12500	      CALL LEGALS
12600	      CALL AUXIL
12700	      DO 600 IS=1,NS
12800	600   CALL EMS(IS,ISUBSC(1,IS),ISIG(IS),LEMST3(1,IS),QCOEFX(1,1,IS))
12900	      WRITE(NOUT,21)
13000	21    FORMAT(1H0,20X,'TABLE OF EXPECTED VALUES (USED TO DETERMINE COR
13100	     1RECT DENOMINATORS)'/21X,67(1H-))
13200	      CALL PRTEMS
13300	      DO 601 IS=1,NS
13400	601   CALL FINDEN(IS,ISUBSC(1,IS),LEMST3(1,IS),QCOEFX(1,1,IS),
13500	     1 ISIG(IS),LDEN1(IS))
13600	      CALL SORTAN
13700	      IIID=NCDF
13900	      CALL SEQPGM
14000	      DO 72 NOWDEP=1,NDEP
14100	       WRITE (NOUT,90) (TIT(I),I=1,16),NOWDEP
14200	90    FORMAT(1H1,16A5,2X,'DEPENDENT VARIABLE NUMBER ',I5)
14300	      IF (IR) 87,87,88
14400	88    NPRINT=0
14500	      DO 84 JJ=1,NF
14600	      IF (NALPHA(JJ)-1) 84,85,84
14700	85    NPRINT=NPRINT+1
14800	      PNAME(NPRINT)=QFNAME(JJ)
14900	84    CONTINUE
15000	      WRITE(NOUT,86)(PNAME(NP),NP=1,NPRINT)
15100	86    FORMAT (1H0,20X,'NUMBER OF REPLICATIONS IN EACH CELL'/21X,36(1H-)
15200	     1 /1H0,20X,'NUMBER',4X,'CELL'/1H0,30X,10A5)
15300	      WRITE(NOUT, 80)
15400	80    FORMAT(1X)
15500	87    CALL READX
15600	      IF (NTYPE2.EQ.4) GO TO 72
15700	      WRITE(NOUT,76) (QFNAME(IF),IF=1,NF)
15800	76    FORMAT(1H0,20X,'CELL AND MARGINAL MEANS OF THE DEPENDENT VARIABLE'
15900	     1 /21X,49(1H-)//' EACH MEAN CORRESPONDS TO THE SUBSCRIPT (LEVEL)
16000	     2 SET PRINTED ON THE RIGHT.'/' A ZERO INDICATES THAT THE SUBSCRIPT
16100	     3 IS DOTTED (SUMMED OVER)'//16X,'MEAN',6X,'SUBSCRIPT SET'/1H0,30X,
16200	     4 10A5)
16300	      IF (NTYPE2-2) 73,74,73
16400	73    CALL SSEQU
16500	      GO TO 75
16600	74    CALL SSPROP
16700	75    IF (NTYPE1-1) 91,92,91
16800	91    IF (IR) 92,92,104
16900	104   WRITE(NOUT,93)
17000	93    FORMAT('0IN SOME LINES IN THE TABLE THE REPLICATION FACTOR MAY
17100	     1 NOT BE DOTTED.  IN ANY LINE IN WHICH THIS IS THE CASE, THE INPUT
17200	     2 REP-'/' LICATION NUMBER WILL APPEAR AS THE SUBSCRIPT.  NOTE
17300	     3 THAT IF THE INPUT REPLICATION SUBSCRIPT NUMBER IS EVER ZERO IT
17400	     4 WILL NOT'/' BE DISTINGUISHED FROM A DOTTED SUBSCRIPT IN THE
17500	     5 TABLE.  INTERNALLY IN BALANOVA, HOWEVER, NO CONFUSION WILL HAVE
17600	     6 ARISEN.'/'0IF THE REPLICATION FACTOR IS ALWAYS DOTTED IN THE
17700	     7 TABLE, IGNORE THIS MESSAGE.')
17800	92    CALL FISH
17900	      CALL FPRINT
18000	72    CONTINUE
18100	      GO TO 29
18200	      END
18300	      SUBROUTINE BOOBOO(KK)
18400		NOUT=20
18500	      IF (KK.NE.1) GO TO 40
18600	      WRITE (NOUT,21)
18700	21    FORMAT ('-THE ABOVE ERROR IS DUE TO ONE OF THE PROGRAM RESTRIC
18800	     1TIONS BEING EXCEEDED.  THIS ERROR IS POSSIBLY DUE TO AN ERROR ON
18900	     2 THE'/' PARAMETER OR FACTOR SPECIFICATION CARDS.  IF THESE CARDS
19000	     3 ARE CORRECT THEN THE ANALYSIS IS TOO LARGE TO BE RUN WITH THE
19100	     4 PRESENT'/' PROGRAM.  THE DIMENSIONS IN THE PROGRAM CAN BE INCREA
19200	     5SED,HOWEVER, BY FOLLOWING THE INSTRUCTIONS IN THE FORTRAN LISTINGS
19300	     6  OF'/' THE TWO MAIN PROGRAMS, ONE FOR EACH CORE LOAD.')
19400	      CALL EXIT
19500	40    IF (KK.NE.2) GO TO 41
19600	      WRITE (NOUT,22)
19700	22    FORMAT ('0THIS ERROR IS DUE TO AN INCONSISTENCY ON ONE OR MORE
19800	     1 FACTOR SPECIFICATION CARDS.  CORRECT THE ERROR AND RERUN.')
19900	      CALL EXIT
20000	41    IF (KK.NE.3) GO TO 42
20100	13    WRITE(NOUT,23)
20200	23    FORMAT(' THIS ERROR CONDITION WAS INSERTED IN THE PROGRAM PRIMARIL
20300	     1Y FOR PROGRAM DEBUGGING.  THIS CONDITION SHOULD NOT HAVE OCCURED'
20400	     2 /' SINCE THE DESIGN HAS ALREADY BEEN CHECKED TO BE A LEGAL DESIGN
20500	     3.  HENCE THE OCCURENCE OF THIS ERROR PROBABLY INDICATES A'/' REM
20600	     4AMINING ERROR IN THE PROGRAM.  IN SOME CASES THIS ERROR IS
20700	     5 CONSIDERED NON-FATAL AND THE PROGRAM HAS CONTINUED'/' HOWEVER THE
20800	     6 RESULTS SHOULD BE INTERPRETED WITH EXTREME CAUTION IN ANY CASE.')
20900	      IF (KK.EQ.6) RETURN
21000	      CALL EXIT
21100	42    IF (KK.NE.4)GO TO 45
21200	      WRITE (NOUT,24)
21300	24    FORMAT ('-BALANOVA, OF COURSE CONTAINS MANY LOOPS WITHIN LOOPS.
21400	     1 THE PRESENT PROGRAM, AS A HEDGE AGAINST INFINITE LOOPING DURING
21500	     2 DEBUGGING,'/' CONTAINS AN UPPER LIMIT OF 10,000 ON THE NUMBER
21600	     3 OF LOOPS IN ANY ONE NEST OF LOOPS.  THIS NUMBER HAS NOW BEEN
21700	     4 EXCEEDED.'/' IF THIS IS NOT DUE TO MACHINE ERROR THIS SUPER LIMIT
21800	     5 (LOOPMX) MAYBE ALTERED IN THE MAIN PROGRAM OF CORE LOAD 1'/)
21900	      CALL EXIT
22000	45    IF (KK.NE.5) GO TO 46
22100	      IF (NSWIT.NE.7) GO TO 13
22200	      WRITE (NOUT,25)
22300	25    FORMAT ('-THIS ERROR IS DUE TO THE SUBSCRIPT SET GIVEN ABOVE A
22400	     1PPEARING ON A DATA CARD.  THE SUBSCRIPT SET FALLS OUTSIDE THE MAX
22500	     2IMUM NUMBER'/' OF LEVELS STATED ON THE FACTOR SPECIFICATION CARDS.
22600	     3  CORRECT EITHER THE FACTOR SPECIFICATION CARDS OR THE DATA CARD
22700	     4 AND RERUN')
22800	      WRITE(NOUT,52)
22900	52    FORMAT(' IF THIS IS A CLASS B DESIGN (REPLICATION FACTOR BUT NOT 
23000	     1COMPLETELY CROSSED), IGNORE THE SUBSCRIPT PRINTED FOR THE REPLICA
23100	     2TION'/' FACTOR SINCE THIS SUBSCRIPT IS AN INTERNAL NUMBER RATHER
23200	     3 THAN THE NUMBER ON THE DATA CARD.  THIS SUBSCRIPT IS NOT THE ONE
23300	     4 IN'/' ERROR ANYWAY.  ONE OF THE OTHERS IS IN ERROR.  FOR CLASS A
23400	     5 OR C DESIGNS, ALL SUBSCRIPTS PRINTED ARE AS THEY APPEARED ON THE
23500	     6 '/' DATA CARD AND ONE OF THEM IS IN ERROR')
23600	      CALL EXIT
23700	46    IF (KK.EQ.6) GO TO 13
23800	      IF (KK-7)49,17,49
23900	17    NSWIT=17
24000	      RETURN
24100	49    IF (KK.NE.8) CALL EXIT
24200	51    NSWIT=8
24300	      RETURN
24400	      END
24500	      SUBROUTINE CHLOOP(LOOP,MAX,LOOPNM,SUBNAM)
24600		NOUT=20
24700	      LOOP=LOOP+1
24800	      IF (LOOP.LE.MAX) RETURN
24900	11    WRITE (NOUT,12) LOOPNM,LOOP,SUBNAM
25000	12    FORMAT (1H0,A6,' =',I10,' EXCEEDING MAX IN SUBROUTINE ',A6)
25100	      CALL BOOBOO(4)
25200	10    RETURN
25300	      END
25400	C
25500	C	THIS IS A COMBINATION OF THE ORIGINAL SUBROUTINES PRTN AND
25600	C	PRTS.  PRTN AND PRTS ONLY DIFFER BY ONE STATEMENT AND HENCE
25700	C	PRTSN HAS AN EXTRA ARGUMENT TO COMPENSATE THE DIFFERENCE.
25800	C
25900	C
26000	C
26100	      SUBROUTINE PRTSN(QQ,I,ISUBS,IDUM)
26200	      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
26300	     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
26400	     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
26500	      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
26600	     1 JSUBSC(5,5),QNEST(5,19)
26700	      DIMENSION ISUBS(5),QQ(133)
26800	      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
26900	     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
27000	     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
27100	     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
27200	     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
27300	     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
27400	      COMMON/BLOCK3/QCOEFX
27500	C     STORE SOURCE IN FORM FOR PRINTING IN QQ(I) ONWARDS.
27600	C     EXIT WITH I = SUBSCRIPT OF FIRST BLANK COLUMN.
27700	C     ONLY LIVE SUBSCRIPTS ARE PRINTED.
27800	C     ISUBS(IF),IF=1,NF IS SOURCE SPECIFICATION
27900	      DO 12 IF=1,NF
28000	      IF (ISUBS(IF)-IDUM)12,13,12
28100	13    QQ(I)=QFNAME(IF)
28200	      I=I+1
28300	      IF (IDUM.EQ.1) QQ(I)=QC
28400	      IF (IDUM.EQ.2) QQ(I)=QX
28500	      I=I+1
28600	12    CONTINUE
28700	      I=I-1
28800	      QQ(I)=QB
28900	      RETURN
29000	      END