Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/ilano/ilano1.for
There is 1 other file named ilano1.for in the archive. Click here to see a list.
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