C
C	WESTERN   MICHIGAN  UNIVERSITY
C
C	SEPTEMBER, 1972
C
C
C	THIS IS THE SECOND OF THE 3 PROGRAMS COMPRISING THE
C	ANALYSIS OF VARIANCE (ILANO).
C
C	SUBROUTINES CONTAINED IN ANO1.ANO ARE:
C
C		INPUTD
C		LEGALS
C		AUXIL
C		EMS
C		NEWS
C		FINDEN
C		PRTEMS
C		SORTAN
C		SDEN1
C		SDEN2
C
C***********************************************************************
C
C
      SUBROUTINE INPUTD
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
      DATA FCP016/1HF/,FCP018/4HUNWE/,FCP017/4HREPL/
      QFFF=FCP016
      QRCHK=FCP017
      QPCHK=FCP018
      IR=0
      DO 80 IF=1,NF
      READ (NIN,10)QFNAME(IF),(QNEST(IF,IN),IN=1,19),QFR(IF),NLEV(IF),(
     1QP1(I),I=1,13)
10    FORMAT (A1,19A1,A1,I9,12A4,A2)
      WRITE (NOUT,50)QFNAME(IF),(QNEST(IF,IN),IN=1,19),QFR(IF),NLEV(IF),
     1(QP1(I),I=1,13)
50    FORMAT (1X,A1,19A1,A1,I9,12A4,A2)
      IF (QP1(1).NE.QRCHK)GO TO 80
81    IF (IR)83,83,82
83    IR=IF
      IF (QP1(7).NE.QPCHK)GO TO 40
C     OVERRIDE PROPORTIONALITY OF CELL N AND USE UNWEIGHTED MEANS ANALY-
C     SIS
85    IR=-IR
      GO TO 40
82    WRITE (NOUT,84)
84    FORMAT ('0ERROR - TWO REPLICATION FACTORS')
      CALL BOOBOO(2)
C     CHECK WHETHER THIS FACTOR NAME HAS ALREADY APPEARED
40    IF1=IF-1
      IF (IF1)32,32,33
33    DO 31 IF2=1,IF1
      IF (QFNAME(IF).NE.QFNAME(IF1)) GO TO 31
34    WRITE (NOUT,35)QFNAME(IF)
35    FORMAT ('0ERROR - TWO FACTORS HAVE THE SAME NAME',1X,A1)
      CALL BOOBOO(2)
31    CONTINUE
C     CHECK WHETHER FACTOR TYPE O. K.
32    IF (QFR(IF).EQ.QRRR)GO TO 80
36    IF (QFR(IF).EQ.QFFF)GO TO 80
38    WRITE (NOUT,39)QFNAME(IF)
39    FORMAT ('0ERROR - FACTOR ',A1,' IS OF ILLEGAL TYPE - NOT F  OR R')
      CALL BOOBOO(2)
80    CONTINUE
C     SET ISUBSC(IF,IS) FOR IS = 1,NF
      DO 21 IS=1,NF
      DO 21 IF=1,NF
21    ISUBSC(IF,IS)=0
      DO 22 IS=1,NF
      DO 23 IN=1,19
      IF (QNEST(IS,IN).EQ.QBLANK)GO TO 23
C     A NESTING FACTOR HAS BEEN FOUND FOR FACTOR IS - LOCATE THE
C     FACTOR NUMBER OF THE NESTING FACTOR
24    DO 25 IF=1,NF
      IF (QNEST(IS,IN).NE.QFNAME(IF))GO TO 25
26    ISUBSC(IF,IS)=1
      GO TO 23
25    CONTINUE
C     NO FACTOR NUMBER FOUND
      IN1=IN+1
      WRITE (NOUT,27)IN1,IS,QNEST(IS,IN)
27    FORMAT('0ERROR ON FACTOR SPEC. CARD - COLUMN',I3,' FOR FACTOR ',
     1 I3,' IS ',A1/' WHICH IS NOT THE LETTER FOR ANY FACTOR')
      CALL BOOBOO(2)
23    CONTINUE
22    CONTINUE
C     INDICATE LIVE SUBSCRIPT FOR EACH FACTOR IN ISUBSC
      DO 28 IF=1,NF
      IF (ISUBSC(IF,IF))30,30,29
29    WRITE (NOUT,41)QFNAME(IF)
41    FORMAT ('0ERROR IN NESTING FOR FACTOR ',A1,', WHICH IS NESTED 
     1 WITHIN ITSELF')
      CALL BOOBOO(2)
30    ISUBSC(IF,IF)=2
28    CONTINUE
C     CHECK NUMBER OF LEVELS
      DO 76 IF=1,NF
      IF (NLEV(IF)-2)77,76,76
77    WRITE (NOUT,78)
78    FORMAT ('0ERROR - SOME NUMBER OF LEVELS IS LESS THAN 2')
      CALL BOOBOO(2)
76    CONTINUE
C     CHECK THAT THE REPLICATION FACTOR, IF ANY, IS NESTED IN SOME
C     OTHER FACTOR AND NO OTHER FACTOR IS NESTED IN IT.
      IF (IR)61,62,61
61    IRP=IABS(IR)
      DO 43 IF=1,NF
      IF (ISUBSC(IF,IRP)-1)43,44,43
43    CONTINUE
      WRITE (NOUT,45)
45    FORMAT ('0ERROR IN FACTOR SPECIFICATION CARDS - THE REPLICATION
     1  FACTOR IS NOT NESTED IN ANY OTHER FACTOR.'/)
      CALL BOOBOO(2)
44    DO 46 IS=1,NF
      IF (ISUBSC(IRP,IS)-1)46,47,46
47    WRITE (NOUT,48)
48    FORMAT ('0ERROR IN FACTOR SPECIFICATION CARDS - SOME FACTOR IS
     1 NESTED IN THE REPLICATION FACTOR WHICH IS ILLEGAL'/)
      CALL BOOBOO(2)
46    CONTINUE
62    RETURN
      END
      SUBROUTINE LEGALS
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     THIS SUBROUTINE FINDS ALL THE LEGAL SOURCES AND INSERTS THEM
C     IN LIST ISUBSC(IF,IS)
C     ISUBSC(IF,IS)=2 IF SUBSCRIPT IF IS LIVE FOR SOURCE IS
C                  =1 IF SUBSCRIPT IF IS DEAD FOR SOURCE IS
C                 =0 IF SUBSCRIPT IF IS ABSENT FOR SOURCE IS
C     THE FIRST NF LEGAL SOURCES ARE THE INPUT FACTORS, ALREADY SET BY
C     INPUTD.  JSUBSC(IF,IS) IS A TEMPORARY LIST OF NEW SOURCES TO BE
C     ADDED TO ISUBSC AFTER EACH CYCLE.
C     COMMON FOR BOTH CORE LOADS 1 AND 2
      DATA FCP016/4HLOOP/,FCP017/4HLEGA/
      NS1=NF
      LOOPF=0
16    CALL NEWS
      IF (NS2)10,10,11
C     NEW SOURCES FOUND IN NEWS
11    DO 12 IS=1,NS2
      DO 12 IF=1,NF
      I1=IS+NS1
12    ISUBSC(IF,I1)=JSUBSC(IF,IS)
      NS1=NS1+NS2
C     CHECK IF NS1 EXCEEDS MAXIMUM ALLOWABLE NUMBER OF LEGAL SOURCES
      IF (NS1-MNS)13,13,14
14    WRITE (NOUT,15)NS1,MNS
15    FORMAT ('0THE NUMBER OF LEGAL SOURCES,NS1, = ',I5,' EXCEEDING
     1 PROGRAM LIMITS (',I5,')')
      CALL BOOBOO(1)
C     CHECK IF LOOPING TOO MANY TIMES AND GO BACK TO START OF LOOP
13    CALL CHLOOP(LOOPF,100,FCP016,FCP017)
      GO TO 16
C     NO NEW SOURCES FOUND - ALL LEGAL SOURCES HAVE BEEN FOUND
10    NS=NS1
      RETURN
      END
      SUBROUTINE AUXIL
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     THIS SUBROUTINE COMPUTES THE AUXILIARY TABLE LAUX(IF,IS) AS
C     ON SCHEFFE, PAGE 285.
      DO 9 IS=1,NS
      DO 10 IF=1,NF
      IF (QFR(IF).NE.QRRR) GO TO 11
C     FACTOR IF IS RANDOM FOR SOURCE IS
12    IF (ISUBSC(IF,IS)-1)13,15,15
C     FACTOR IS IS LIVE OR DEAD (AND RANDOM) FOR SOURCE IS
15    LAUX(IF,IS)=1
      GO TO 10
C     FACTOR IF IS FIXED FOR SOURCE IS
11    IF (ISUBSC(IF,IS)-1)13,17,18
C     FACTOR IF IS LIVE (AND FIXED) FOR SOURCE IS
18    LAUX(IF,IS)=0
      GO TO 10
C     FACTOR IF IS DEAD (AND FIXED) FOR SOURCE IS
17    LAUX(IF,IS)=1
      GO TO 10
C     FACTOR IF IS ABSENT
13    LAUX(IF,IS)=NLEV(IF)
10    CONTINUE
9     CONTINUE
      RETURN
      END
      SUBROUTINE EMS(ISSS,ISUBS,ISI,LEMS,QCOEX)
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      DIMENSION ISUBS(5),LEMS(10),QDUM(5),QCOEX(5,10)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     THIS SUBROUTINE COMPUTES THE EXPECTED VALUE OF THE MEAN SQUARE
C     (E(MS)) OF THE INPUT SOURCE SPECIFIED BY THE VECTOR ISUBS.
C     THE INPUT SOURCE HAS ORDINAL NUMBER ISSS.
C     THE OUTPUT CONSISTS OF
C     ISI= NUMBER OF SIGMA-SQUARED TERMS IN E(MS).
C     (LEMS(ICON),ICON=1,ISI) = LIST OF ORDINAL SOURCE NUMBERS OF
C     THE SIGMA-SQUARED TERMS.  I.E. LEMS(1),...LEMS(ISI) ARE
C     NON-ZERO AND IF E.G. LEMS(4)=7, THIS MEANS THAT SOURCE NUMBER 7
C     CONTRIBUTES A SIGMA-SQUARED TERM TO THE E(MS) OF THE GIVEN SOURCE.
C     ONE OF THESE SOURCE NUMBERS HAS TO BE ISSS, AND THIS IS CHECKED BY
C     THIS SUBROUTINE.  THE LIST IS IN ORDER OF SOURCE NUMBERS
C     EXCEPT THAT ISSS ITSELF IS LAST.
C     QCOEX(IF,ICON)=INDICATION WHETHER THE NUMBER OF LEVELS OF FACTOR
C     IF ENTERS AS A COEFFICIENT OF THE SIGMA-SQUARED TERM
C     FOR SOURCE ICON. (SAME ORDER AS IN LEMS(ICON))
C     =QFNAME(IF) IF SO
C     =1H  IF NOT
      DO 20 IS=1,NS
      DO 21 IF=1,NF
      IF (ISUBS(IF))21,21,22
22    IF (ISUBSC(IF,IS)) 24,24,21
21    CONTINUE
C     SOURCE IS HAS LIVE OR DEAD SUBSCRIPT FOR ALL THOSE FACTORS FOR
C     WHICH INPUT SOURCE ISSS HAS LIVE OR DEAD SUBSCRIPTS.
      LEMST1(IS)=1
      GO TO 20
C     SOURCE IS HAS AN ABSENT SUBSCRIPT FOR AT LEAST ONE FACTOR
C     FOR WHICH INPUT SOURCE ISSS HAS A LIVE OR A DEAD SUBSCRIPT.
24    LEMST1(IS)=0
20    CONTINUE
C     DETERMINE WHICH SIGMA-SQUARED TERMS ACTUALLY APPEAR IN E(MS)
C     (WITH NON-ZERO COEFFICIENTS).  COMPUTE ISIG AND LIST LEMS(ICON),
C     ICON=1,ISIG.  FINALLY DETERMINE THE COEFFICIENTS OF EACH
C     SIGMA-SQUARED TERM, QCOEX(IF,ICON)).  PROCEDURE IS FROM
C     SCHEFFE, PAGE 285, SECOND PARAGRAPH BELOW TABLE 8.2.1.
      DO 40 IF=1,NF
      DO 40 ICON=1,10
40    QCOEX(IF,ICON)=QBLANK
      ICON=1
      DO 30 IS=1,NS
      IF (LEMST1(IS)) 30,30,31
31    DO 32 IF=1,NF
      IF (ISUBS(IF)) 34,33,34
C     ABSENT SUBSCRIPT
33    IF (LAUX(IF,IS)-1) 30,61,62
61    QCOEX(IF,ICON)=QBLANK
      GO TO 32
62    QCOEX(IF,ICON)=QFNAME(IF)
      GO TO 32
C     OTHER SUBSCRIPT
34    QCOEX(IF,ICON)=QBLANK
32    CONTINUE
C     THIS SIGMA-SQUARED ACTUALLY APPEARS
      IF (ICON-MICON) 41,41,42
42    WRITE (NOUT,43) ISSS,ICON
43    FORMAT ('0TOO MANY SIGMA-SQUARED TERMS IN E(MS) FOR SOURCE',I5
     1 ,' ICON =',I5)
      CALL BOOBOO(1)
41    LEMS(ICON)=IS
      ICON=ICON+1
      GO TO 30
C     THIS SIGMA-SQUARED DOES NOT APPEAR, ICON IS NOT INCREMENTED
C     AND HENCE RESULTS FOR THIS ICON WILL BE OVERWRITTEN.
30    CONTINUE
C     CHECK THAT AT LEAST ONE SIGMA-SQUARED WAS INCLUDED
      IF (ICON-1) 37,37,38
37    WRITE (NOUT,39) ISSS
39    FORMAT ('0ERROR IN SUBROUTINE EMS, NO SIGMA-SQUARED TERMS INCLUDED
     1 IN E(MS<) FOR SOURCE  ',I3)
      CALL BOOBOO(3)
C     SET ISI
38    ISI=ICON-1
C     CHECK THAT ONE OF THE SIGMA-SQUAREDS IS FOR SOURCE ISSS ITSELF
      DO 50 ICON=1,ISI
      IF (LEMS(ICON)-ISSS) 50,51,50
50    CONTINUE
      WRITE (NOUT,52) ISSS,(LEMS(ICON),ICON=1,ISI)
52    FORMAT ('0ERROR IN EMS - SOURCE',I5,' DOES NOT CONTAIN A SIGMA-
     1SQUARED FOR ITSELF, ITS SIGMA-SQUARED TERMS ARE '/1X,10I12)
      CALL BOOBOO(3)
C     INSERT ISSS SIGMA-SQUARED TERM LAST IN LIST
51    IF (ICON-ISI) 53,55,55
C     ISSS TERM IS LAST
C     ISSS TERM IS NOT LAST
53    I4=ISI-1
      DO 58 IF=1,NF
58    QDUM(IF)=QCOEX(IF,ICON)
      DO 56 I3=ICON,I4
      LEMS(I3)=LEMS(I3+1)
      DO 56 IF=1,NF
56    QCOEX(IF,I3)=QCOEX(IF,I3+1)
      LEMS(ISI)=ISSS
      DO 57 IF=1,NF
57    QCOEX(IF,ISI)=QDUM(IF)
55    RETURN
      END
      SUBROUTINE NEWS
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     THIS SUBROUTINE CONSIDERS, ONE AT A TIME, ALL PAIRS OF LEGAL
C     SOURCES (IN LIST ISUBSC) FOUND UP TO PRESENT TIME (NS1 OF THEM)
C     IT TESTS WHETHER THE INTERACTION OF THIS PAIR IS A NEW LEGAL
C     SOURCE, NOT IN THE PRESENT LIST.  IF IT IS, IT IS TEMPORARILY
C     STORED IN LIST JSUBSC.  IN SUBROUTINE LEGALS, THIS LIST WILL
C     BE ADDED TO LIST ISUBSC.
C     NS2 IS THE NUMBER OF NEW SOURCES FOUND ON THIS ENTRY TO NEWS.
C     CYCLE ALL POSSIBLE PAIRS OF SOURCES
      NS2=0
      K1=NS1-1
      DO 10 I1=1,K1
      K2=I1+1
      DO 10 I2=K2,NS1
C     SET UP SOURCE (I1,I2) IN ITEMPS(IF)
C     (NOTE - ITEMPS(IF) IS SET = 3 IF SUBSCRIPT IF IS BOTH LIVE
C     AND DEAD - IF THIS SOURCE IS LATER FOUND TO BE UNDUPLICATED
C     IN ISUBSC, AN ERROR CONDITION IS PRINTED,INDICATING EITHER
C     A PROGRAM OR DATA ERROR OR A CONCEPTUAL ERROR)
      DO 11 IF=1,NF
      IF (ISUBSC(IF,I1)-1)12,13,14
12    ITEMPS(IF)=0
      GO TO 15
13    ITEMPS(IF)=1
      GO TO 15
14    ITEMPS(IF)=2
15    IF (ISUBSC(IF,I2)-1)11,17,18
17    IF (ITEMPS(IF)-1)19,19,20
19    ITEMPS(IF)=1
      GO TO 11
20    ITEMPS(IF)=3
      GO TO 11
18    IF (ITEMPS(IF)-1)22,23,22
22    ITEMPS(IF)=2
      GO TO 11
23    ITEMPS(IF)=3
11    CONTINUE
C     IS THE SET OF LIVE AND DEAD SUBSCRIPTS IN THE NEW SOURCE
C     ALREADY IN THE LIST ISUBSC - QUESTION MARK -
C     (NOTE - LIVE SUBSCRIPTS DO NOT HAVE TO MATCH LIVE AND DEAD DEAD
C     ONLY TOTAL SETS OF LIVE AND DEAD HAVE TO MATCH)
      DO 30 IS=1,NS1
      DO 31 IF=1,NF
      IF (ISUBSC(IF,IS))32,32,33
32    IF (ITEMPS(IF))31,31,30
33    IF (ITEMPS(IF))30,30,31
31    CONTINUE
C     ITEMPS MATCHES ISUBSC(IF,IS) - I.E. NOT A NEW SOURCE
      GO TO 10
C     ITEMPS DOES NOT MATCH ISUBSC(IF,IS)IN SET OF LIVE AND DEAD
C     SUBSCRIPTS - CONTINUE SEARCHING FOR MATCH
30    CONTINUE
C     MAKE SAME CHECK WITH SOURCES IN LIST JSUBC
      IF (NS2)65,65,66
66    DO 60 IS=1,NS2
      DO 61 IF=1,NF
      IF (JSUBSC(IF,IS))62,62,63
62    IF (ITEMPS(IF))61,61,60
63    IF (ITEMPS(IF))60,60,61
61    CONTINUE
C     ITEMPS MATCHES JSUBSC(IF,IS) - I.E. NOT A NEW SOURCE
      GO TO 10
C     ITEMPS DOES NOT MATCH JSUBSC(IF,IS) - CONTINUE SEARCHING
60    CONTINUE
C     ITEMPS DOES NOT MATCH ANY ISUBSC OR JSUBSC - I.E.HAVE A NEW SOURCE
C     FIRST, CHECK IF ITEMPS HAS A SUBSCRIPT BOTH LIVE AND DEAD
C     IF SO EXIT
65    DO 35 IF=1,NF
      IF (ITEMPS(IF)-3)35,36,36
35    CONTINUE
      GO TO 51
36    WRITE (NOUT,37)I1,I2,I1,(ISUBSC(IF,I1),IF=1,NF)
37    FORMAT ('0THE INTERACTION OF TWO SOURCES(',I5,' ',I5,') PRODUCES
     1 A NEW SOURCE WHICH HAS A SUBSCRIPT BOTH LIVE AND DEAD'//
     2  'ISUBSC(IF,',I5,')'/1X,20I5)
      WRITE (NOUT,38)I2,(ISUBSC(IF,I2),IF=1,NF)
38    FORMAT ('0ISUBSC(IF,',I5,')'/1X,20I5)
      WRITE (NOUT,39)(ITEMPS(IF),IF=1,NF)
39    FORMAT ('0ITEMPS(IF)'/1X,20I5)
      WRITE (NOUT,40)
40    FORMAT ('0CHECK THIS')
      CALL BOOBOO(3)
C     SECOND,CHECK IF TOO MANY NEW SOURCES
51    NS2=NS2+1
      IF (NS2-10)41,41,42
42    NS2=NS2-1
      GO TO 80
C     THIRD,ADD NEW SOURCE TO TEMPORARY LIST JSUBSC
41    DO 44 IF=1,NF
44    JSUBSC(IF,NS2)=ITEMPS(IF)
C     END OF DO LOOP CYCLING ALL POSSIBLE PAIRS OF SOURCES
10    CONTINUE
80    IF (ILAST.EQ.1) WRITE (NOUT,50)NS2
50    FORMAT (1H0,I5,' NEW SOURCES FOUND ON THIS ENTRY TO NEWS')
71    RETURN
      END
      SUBROUTINE FINDEN(ISSS,ISUBS,LEMS,QCOEX,ISI,LDEN)
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      DIMENSION ISUBS(5),LEMS(10),QCOEX(5,10)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     THIS SUBROUTINE FINDS THE DENOMINATOR SOURCE (IF ANY) FOR
C     THE INPUT SOURCE SPECIFIED BY -
C     ISSS - ORDINAL SOURCE NUMBER
C     ISUBS(IF),IF=1,NF - SOURCE SUBSCRIPTS
C     LEMS(ICON),ICON=1,ISI - SIGMA-SQUARED TERMS IN E(MS)
C     QCOEX(IF,ICON) - COEFFICIENTS OF SIGMA-SQUARED TERMS
C     ISI - NUMBER OF SIGMA-SQUARED TERMS
C     THE OUTPUT IS LDEN = DENOMINATOR SOURCE NUMBER IF THERE IS A DENOM
C                        = 0 OTHERWISE
C     DELETE SIGMA-SQUARED TERM FOR SOURCE ISSS FROM ITS E(MS) -
C     SINCE THIS IS THE LAST TERM OF LIST, JUST REDUCE ISI EFFECTIVELY
C     BY 1.
      ISI2=ISI-1
C     CYCLE THROUGH ALL SOURCES IN SEARCH FOR DENOMINATOR
      LDEN=0
      DO 10 IS=1,NS
C     IS IS THE SOURCE ISSS - IF SO NO GOOD
      IF (IS-ISSS)11,10,11
C     HAS IS THE SAME NUMBER OF SIGMA-SQUARED TERMS AS ISSS - IF NOT,
C     NO GOOD.
11    IF (ISI2-ISIG(IS))10,12,10
C     DO SIGMA-SQUARED LISTS FOR SOURCES IS AND ISSS MATCH
C     (NOTE - LISTS WILL ALREADY BE IN NUMERICAL ORDER) - IF NOT, NO
C     GOOD
12    DO 13 ICON=1,ISI2
      IF (LEMS(ICON)-LEMST3(ICON,IS))10,13,10
13    CONTINUE
C     DO SIGMA-SQUARED COEFFICIENT LISTS MATCH - IF NOT, PRINT AS A
C     POSSIBLE ERROR CONDITION, BUT TREAT ISSS AS NOT HAVING IS AS DENOM
      DO 14 ICON=1,ISI2
      DO 14 IF=1,NF
      IF (QCOEX(IF,ICON).NE.QCOEFX(IF,ICON,IS))GO TO 15
14    CONTINUE
      GO TO 16
15    WRITE (NOUT,17)ISSS,IS
17    FORMAT ('0SOURCE',I5,' WOULD HAVE SOURCE',I5,' AS A DENOMINATOR
     1 EXCEPT THAT SIGMA-SQUARED TERMS HAVE NON-MATCHING COEFFICIENTS'
     2 /' THIS INDICATES POSSIBLE TROUBLE IN YOUR DESIGN BUT I HAVE
     3 CARRIED ON REGARDLESS)')
      CALL BOOBOO(6)
C     HAS ANOTHER DENOMINATOR ALREADY FOUND - IF SO, ERROR.
16    IF (LDEN)18,18,19
19    WRITE (NOUT,20)ISSS,LDEN,IS
20    FORMAT('0ERROR IN FINDING DENOMINATOR OF SOURCE',I5/' TWO
     1 DENOMINATORS HAVE BEEN FOUND,NAMELY,'I5,' AND',I5)
      CALL BOOBOO(3)
C     DENOMINATOR HAS BEEN FOUND
18    LDEN=IS
10    CONTINUE
      RETURN
      END
      SUBROUTINE PRTEMS
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
      DATA FCP016/1H./
C     THIS SUBROUTINE PRINTS OUT THE E(MS) IN A FORM SUCH THAT BY
C     HANDWRITING IN SIGMA-SQUAREDS IN THE APPROPRIATE PLACES
C     THE OUTPUT LOOKS RESPECTABLE.
      QD=FCP016
      WRITE (NOUT,10)
10    FORMAT('0SOURCE AND NESTING',20X,'EXPECTED VALUE OF MEAN SQUARE'/)
      DO 11 IS=1,NS
C     PRESET LINES 1 AND 2 TO BLANKS
      DO 9 I=1,133
      QP1(I)=QB
9     QP2(I)=QB
C     CARRIAGE CONTROL
      QP1(1)=Q0
      I=2
C     SOURCE LETTERS
      CALL PRTSN(QP1,I,ISUBSC(1,IS),2)
C     SKIP 5 COLUMNS
      I=I+5
C     NESTING LETTERS
      CALL PRTSN(QP1,I,ISUBSC(1,IS),1)
      I=28
C     EXPECTED VALUED OF MEAN SQUARES
      I1=ISIG(IS)
      DO 20 ICON=1,I1
      IF (I-100)40,40,41
C     LINE IS TOO LONG - PRINT IT AND PROCEED
41    WRITE (NOUT,28)(QP1(I2),I2=1,133),(QP2(I2),I2=1,133)
28    FORMAT (1H /(133A1))
      DO 42 I2=1,133
      QP1(I2)=QB
42    QP2(I2)=QB
      QP1(1)=Q0
      I=28
C     COEFFICIENTS OF SIGMA-SQUARED
40    DO 21 IF=1,NF
      IF (QCOEFX(IF,ICON,IS).EQ.QB)GO TO 21
22    QP1(I)=QN
      I=I+1
      QP2(I)=QCOEFX(IF,ICON,IS)
      I=I+1
21    CONTINUE
C     SIGMA SQUARED
      QP1(I)=QD
      I=I+1
      I2=LEMST3(ICON,IS)
      DO 23 IF=1,NF
      IF (ISUBSC(IF,I2)-2)23,24,23
24    QP2(I)=QFNAME(IF)
      I=I+1
23    CONTINUE
C     PLUS SIGN
      I=I+1
      QP1(I)=QP
      I=I+2
20    CONTINUE
C     ERASE LAST + SIGN
      I=I-2
      QP1(I)=QB
C     PRINT LINES FOR SOURCE IS
      WRITE (NOUT,28)(QP1(I2),I2=1,133),(QP2(I2),I2=1,133)
11    CONTINUE
      WRITE (NOUT,30)
30    FORMAT(1H0/'0   NOTE 1) IN THE ABOVE TABLE ALL PERIODS (.) SHOULD
     1 BE REPLACED BY SIGMA-SQUARED WITH THE SUBSCRIPT GIVEN'//9X,
     2 '2) N WITH A SUBSCRIPT LETTER IS THE NUMBER OF LEVELS OF THE F
     3ACTOR LABELED BY THAT LETTER')
      RETURN
      END
      SUBROUTINE SORTAN
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
      DATA FCP016/4HLOOP/,FCP018/4HLOOP/,FCP017/4HSORT/,FCP019/4HSORT/
C     THIS SUBROUTINE LISTS SOURCES IN THREE TABLES, AS A CONVENIENCE
C     FOR PRINTING THE SUMMARY TABLE IN A REASONABLE ORDER.
C     FINALLY, THE THREE TABLES ARE ALL PUT IN ONE TABLE (LT1S).
C     TYPE 3 SOURCES - THESE SOURCES EACH HAVE NO DENOMINATOR
C     SUM OF SQUARES (FOR SHORT - NO DENOM) AND ARE THEMSELVES NOT A
C     DENOM.
C     NT3S - NUMBER OF TYPE 3 SOURCES
C     LT3S(IT3S),IT3S=1,NT3S - LIST OF CARDINAL NUMBER OF THE
C     TYPE 3 SOURCES.
C     TYPE 2 SOURCES - THESE SOURCES COME IN SETS.  EACH SET ALL HAVING
C     THE SAME DENOMINATOR.  THE FINAL SOURCE IN EACH SET IS THE
C     DENOMINATOR FOR THAT SET AND IT HAS ITSELF NO DENOMINATOR
C     (UNLIKE TYPE 1 DENOMINATORS)
C     NT2D - NUMBER OF TYPE 2 DENOMS
C     NT2S - NUMBER OF TYPE 2 SOURCES
C     LT2D(IT2D),IT2D=1,NT2D - LIST OF TYPE 2 DENOMS
C     LT2S(IT2S),IT2S=1,NT2S - LIST OF TYPE 2 SOURCES
C     TYPE 1 SOURCES - THESE SOURCES COME IN CHAINS.  EACH CHAIN
C     HAS 2 OR MORE SETS OF SOURCES.  THE SOURCES IN THE FIRST SET
C     HAVE A COMMON DENOMINATOR (SAY X1).  THE FIRST SOURCE IN THE
C     SECOND SET IS X1 WHICH HAS DENOM X2.  THE OTHER SOURCES IN THE
C     SECOND SET ALL HAVE DENOM X2.  SIMILARLY THE FIRST SOURCE
C     IN THE THIRD SET IS X2 WITH DENOM X3 AND ALL SOURCE IN THE THIRD
C     SET HAVE X3 AS DENOM.  SOURCES ARE NOT INCLUDED IN LIST IF
C     THEIR DENOM HAS NOT ITSELF A DENOM - SUCH SOURCES ARE
C     CONSIDERED TO BE TYPE 2 SOURCES
C     NT1D - NUMBER OF TYPE 1 DENOMS
C     NT1S - NUMBER OF TYPE 1 SOURCES
C     LT1D(IT1D),IT1D=1,NT1D - LIST OF TYPE 1 DENOMS.
      ND=0
      DO 10 IS=1,NS
      IF (LDEN1(IS))10,10,11
11    IF (ND)12,12,13
12    ND=1
      LDEN2(1)=LDEN1(IS)
      GO TO 10
C     CHECK IF DENOM ALREADY ON LIST - IF IT IS GO TO 10 (CONTINUE).
13    DO 14 ID=1,ND
      IF (LDEN2(ID)-LDEN1(IS))14,10,14
14    CONTINUE
C     NEW DENOM
      ND=ND+1
      LDEN2(ND)=LDEN1(IS)
10    CONTINUE
      IF (ND)15,15,16
15    WRITE (NOUT,17)ND
17    FORMAT ('0ERROR IN SORT, THE NUMBER OF DENOMINATORS = ',I10/
     1' THIS VIOLATES THE CONDITION THAT THERE BE SOME DENOMINATORS
     2 IN THE SUMMARY TABLE.  THIS ERROR IS MOST LIKELY PRODUCED BY ALL'
     3 /' FACTORS BEING SPECIFIED AS FIXED.  AT LEAST ONE FACTOR MUST
     4 BE RANDOM FOR THERE TO BE A DENOMINATOR TERM.'/)
      CALL BOOBOO(2)
C     LIST TYPE 3 SOURCES (NOT A DENOM AND HAS NO DENOM)
16    NT3S=0
      DO 20 IS=1,NS
      IF (LDEN1(IS))20,21,20
C     HAS NO DENOM
21    DO 22 ID=1,ND
      IF (IS-LDEN2(ID))22,20,22
22    CONTINUE
C     IS NOT A DENOM EITHER
      NT3S=NT3S+1
      LT3S(NT3S)=IS
20    CONTINUE
C     LIST TYPE 1 SOURCES (CHAIN INCLUDES A DENOM WHICH ITSELF
C     HAS A DENOM).
      NT1S=0
      NT1D=0
      DO 24 ID=1,ND
      I1=LDEN2(ID)
      IF (LDEN1(I1))24,24,25
C     DENOM ID HAS A DENOM ITSELF - HENCE TYPE 1.
C     IS ID IN LIST LT1D ALREADY - IF SO GO TO 24 (CONTINUE).
25    IF (NT1D)31,31,32
32    DO 30 IT1D=1,NT1D
      IF (LDEN2(ID)-LT1D(IT1D))30,24,30
30    CONTINUE
C     NO IT IS NOT - TRACE CHAIN BACK TO THE BEGINNING BY TRYING TO FIND
C        A SOURCE WITH THIS DENOM AND THIS SOURCE IS ALSO A DENOM - WHEN
C       THIS CANNOT BE DONE THE TOPE OF THE CHAIN (FIRST SET) HAS BEEN
C     FOUND
31    IIID=LDEN2(ID)
      LOOPG=0
35    CALL CHLOOP(LOOPG,10,FCP016,FCP017)
      CALL SDEN1(IIID,IIIS,IYES)
C     HAS SUCH A SOURCE BEEN FOUND
      IF (IYES-1)33,34,33
C     IYES=1 - SOURCE FOUND - CHECK IF CHAIN CAN BE FOLLOWED
C     FURTHER BACK
34    IIID=IIIS
      GO TO 35
C     IYES = 0, NO NEW SOURCE FOUND - HENCE IIID IS DENOM OF FIRST SET
C     IN CHAIN
33    NOTS=0
C     STORE ALL SOURCES FROM THIS CHAIN IN LT1S AND ALL DENOMS IN LT1D
C     BUT DO NOT STORE SOURCES WHOSE DENOM HAS NOT ITSELF A DENOM.
C     ALSO DO NOT STORE IF ALREADY ON LIST.
      LOOPH=0
36    IF (LDEN1(IIID))24,24,80
80    IF (NT1D)81,81,82
82    DO 83 IT1D=1,NT1D
      IF (IIID-LT1D(IT1D))83,24,83
83    CONTINUE
81    CALL CHLOOP(LOOPH,10,FCP018,FCP019)
      CALL SDEN2(IIID,NT1S,LT1S,NOTS)
      NT1D=NT1D+1
      LT1D(NT1D)=IIID
      IIID=LDEN1(IIID)
      GO TO 36
24    CONTINUE
C     LIST TYPE 2 SOURCES (DENOM IS NOT ITSELF A DENOM AND NOT
C     A TYPE 1 DENOM).
      NT2S=0
      NT2D=0
      DO 70 ID=1,ND
      I1=LDEN2(ID)
      IF (LDEN1(I1))70,71,70
71    DO 27 IS=1,NS
      IF (LDEN1(IS)-I1)27,28,27
28    NT2S=NT2S+1
      LT2S(NT2S)=IS
27    CONTINUE
      NT2S=NT2S+1
      LT2S(NT2S)=I1
      NT2D=NT2D+1
      LT2D(NT2D)=I1
70    CONTINUE
C     COMBINE ALL TABLES IN THE LIST LT1S
      I2=NT1S+NT2S
      NS3=I2+NT3S
      IF (NT2S)50,50,51
51    DO 52 IT2S=1,NT2S
      I5=IT2S+NT1S
52    LT1S(I5)=LT2S(IT2S)
50    IF (NT3S)53,53,54
54    DO 55 IT3S=1,NT3S
      I6=IT3S+I2
55    LT1S(I6)=LT3S(IT3S)
C     CHECK IF RIGHT NUMBER OF SOURCES IN LIST.
53    IF (NS3-NS)56,60,58
C     TOO FEW IN LIST
56    WRITE (NOUT,59)
59    FORMAT ('0NUMBER OF SOURCES IN SUMMARY TABLE IS LESS THAN TOTAL
     1 NUMBER - AN ERROR, BUT TABLE IS PRINTED NEVERTHELESS'//' CHECK
     2 THIS'//)
      CALL BOOBOO(6)
      GO TO 60
C     TOO MANY IN LIST - MAKE SURE LIST IS NOT OVERFLOWED
58    IF (NS3-MNS)61,61,62
61    WRITE (NOUT,63)
63    FORMAT ('0NUMBER OF SOURCES IN SUMMARY TABLE IS GREATER THAN
     1 TOTAL NUMBER - AN ERROR, BUT TABLE IS PRINTED NEVERTHELESS'/
     2 ' CHECK THIS'//)
      CALL BOOBOO(6)
      GO TO 60
62    WRITE (NOUT,64)NS3
64    FORMAT ('0ERROR IN SUBROUTINE SORT, NUMBER OF SOURCES TO GO
     2 IN SUMMARY TABLE IS',I5,' WHICH IS TOO MANY')
      CALL BOOBOO(3)
60    RETURN
      END
      SUBROUTINE SDEN1(INPUTD,NOUTS,IYE)
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100),LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     GIVEN INPUT DENOM (INPUTD) THIS SUBROUTINE FINDS (IF POSSIBLE)
C     A SOURCE WITH THIS DENOM AND THE SOURCE IS ALSO A DENOM.
C     NOUTS = THIS SOURCE, IF IT EXISTS.
C     IYE = 1 - SOURCE FOUND.
C     IYE = 0 - NO SOURCE FOUND.
      DO 10 IS=1,NS
      I1=LDEN1(IS)
      IF (INPUTD-I1) 10,11,10
11    DO 12 ID=1,ND
      IF (IS-LDEN2(ID)) 12,13,12
12    CONTINUE
C     IS IS NOT A DENOM
      GO TO 10
C     IS IS A DENOM
13    NOUTS=IS
      IYE=1
      RETURN
10    CONTINUE
C     NO SOURCE FOUND
      IYE=0
      RETURN
      END
      SUBROUTINE SDEN2(INPUTD,NT,LT,NOT)
      DIMENSION QFNAME(5),QFR(5),ITEMPS(5),NLEV(5),ISIG(100),
     1 LDEN1(100),LDEN2(100),LEMST1(100),LT1D(100),LT1S(100),LT2D(100),
     2 LT2S(100), LT3S(100),QP1(133),QP2(133),TIT(16)
      DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
     1 JSUBSC(5,5),QNEST(5,19)
      DIMENSION QCOEFX(5,10,100)
      DIMENSION LT(100)
      COMMON/BLOCK1/IIID,IIIS,ILAST,IR,IYES,LOOPF,LOOPH,LOOPMX,MICON,
     1 MNS,ND,NF,NF1,NIN,NOTS,NOUT,NS,NSCR1,
     2 NS1,NS2,NS3,NT1D,NT1S,NT2D,NT2S,NT3S,QB,QBLANK,QC,
     3 QN,QP,QREP,QRRR,QX,Q0,QFNAME,QFR,ITEMPS,ISIG,LDEN1,
     4 LDEN2,LEMST1,LT1D,LT1S,LT2D,LT2S,LT3S,ISUBSC,LAUX,
     5 LEMST3,JSUBSC,QP1,QP2,TIT,QNEST,NLEV,NDEP,NINX,ND1OR2
      COMMON/BLOCK3/QCOEFX
C     GIVEN A DENOMINATOR (INPUTD), THIS SUBROUTINE FINDS ALL SOURCES
C     WITH THIS DENOM AND STORES THEM IN LIST LT.  THE SUBSCRIPT FOR
C     THE FIRST SOURCE FOUND IS NT + 1, AND THIS IS SUCCESSIVELY
C     INCREMENTED.  THE OUTPUT VALUE OF NT IS THE HIGHEST SUBSCRIPT
C     USED.
C     THE SOURCE NOT IS NOT TO BE PUT ON THE LIST.
      DO 10 IS=1,NS
      IF (LDEN1(IS)-INPUTD) 10,11,10
11    IF (IS-NOT) 12,10,12
12    NT=NT+1
      LT(NT)=IS
10    CONTINUE
      RETURN
      END