Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/ilano/ilano2.for
There is 1 other file named ilano2.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 LAST OF THE 3 PROGRAMS COMPRISING THE
C ANALYSIS OF VARIANCE PROGRAM (ILANO).
C
C
C THE SUBROUTINES CONTAINED IN ANO2.ANO ARE:
C
C SEQPGM
C INPUTX
C READX
C CELLN
C SSEQU
C SSPROP
C INEX
C FISHER
C FPRINT
C FLINE
C
C
C FUNCTIONS CONTAINED IN THIS PROGRAM ARE:
C
C LOCX
C ENMEAN
C LOCSSM
C XMEAN
C
C***********************************************************************
C
C
SUBROUTINE SEQPGM
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C MAXIMUM NUMBER OF DEPENDENT VARIABLES
MAXDEP=200
C MAXIMUM NUMBER OF STORAGE LOCATIONS IN X MATRIX
MNX=5000
C CHECK IF PROPORTIONAL DESIGN OVERRIDEN AND RESET IR
IF (IR) 81,82,82
C OVERRIDE
81 IR=-IR
PROVER=1.0
GO TO 83
82 PROVER=0.0
C TYPE OF DESIGN (COMPLETELY CROSSED WITH REPLICATIONS (NTYPE1=1)
C OR OTHER (NTYPE1=2))
83 IF (IR) 24,24,21
21 DO 25 IF=1,NF
DO 25 IS=1,NF
IF (IS-IR) 27,28,27
27 IF (IF-IS) 29,30,29
29 IF (ISUBSC(IF,IS)) 24,25,24
30 IF (ISUBSC(IF,IS)-2) 24,25,24
28 IF (IF-IS) 31,32,31
31 IF (ISUBSC(IF,IS)-1) 24,25,24
32 IF (ISUBSC(IF,IS)-2) 24,25,24
25 CONTINUE
NTYPE1=1
GO TO 33
24 NTYPE1=2
C FOR ALL DESIGNS, SET NALL1(IF)=1, ALL IF, INDICATING THAT ALL
C SUBSCRIPTS IN LIST ARE TO BE USED FOR STORAGE IF CALL IS
C TO LOCX( ,NALL1)
33 DO 103 IF=1,NF
103 NALL1(IF)=1
C SET UP ALPHA - ALL FACTORS IN WHICH REPLICATION FACTOR IS NESTED
C (IF THERE IS A REPLICATION FACTOR)
C NALPHA(IF)=1 IF IF IS IN ALPHA
C ALSO SET UP NALPHR
C NALL1(IF),IF=1,NF ARE ALL = 1, INDICATING THAT ALL SUBSCRIPTS
C IN LIST ARE TO BE USED FOR STORAGE
C NALPHR(IF),IF=1,NF ARE = 1 FOR ALL IF IN ALPHA AND FOR IF = IR
IF (IR) 40,40,41
41 NA=0
DO 42 IF=1,NF
IF (ISUBSC(IF,IR) - 1) 44,43,44
43 NA=NA+1
NALPHA(IF)=1
NALPHR(IF)=1
GO TO 42
44 NALPHA(IF)=0
NALPHR(IF)=0
42 CONTINUE
NA1=NA+1
NALPHR(IR)=1
IF (NTYPE1-1) 40,46,40
46 IF (NF-NA-1) 47,40,47
47 WRITE (NOUT,49) NA
49 FORMAT ('0ERROR, DESIGN IS COMPLETELY CROSSED WITH REPS BUT NA =',
1 I6)
CALL BOOBOO(3)
C RESTRICTION ON STORAGE
C NN= NUMBER OF STORAGE LOCATIONS NEEDED FOR X MATRIX WHICH IS USED
C FOR CELL MEANS (NTYPE1 = 1) OR CELL SCORES (NTYPE1 = 2)
C NN1= NUMBER OF STORAGE LOCATIONS NEEDED FOR NN MATRIX (WHICH
C IS ACTUALLY PART OF X) USED FOR NUMBER OF REPLICATIONS IN EACH
C CELL. THE FIRST STORAGE LOCATION FOR NN IS X(NN+1)
C NN2= NUMBER OF STORAGE LOCATIONS GOT NN1 MATRIX (ACTUALLY PART
C OF X) USED FOR CHANGING EXTERNAL REPLICATIONS NUMBER TO INTERNAL
C NUMBER IN NTYPE1 = 2 WITH REPLICATIONS DESIGN. THE FIRST STORAGE
C LOCATION FOR NN1 MATRIX IS X(NN+NN1+1)
C NOTE THAT NN, NN1, AND NN2 ARE INTEGERS IN FORTRAN BUT ARE ALSO
C LOOSELY USED TO REFER TO MATRICES ACTUALLY STORED IN THE X ARRAY.
40 IF (NTYPE1-1) 51,51,52
C COMPLETELY CROSSED WITH REPS
51 NN=1
DO 53 IF=1,NF
IF (IF.NE.IR) NN=NN*NLEV(IF)
53 CONTINUE
NN1=NN
NN2=0
GO TO 55
C OTHER
52 IF (IR) 58,58,59
C OTHER WITH REPS
59 NN=1
NN1=1
DO 56 IF=1,NF
NN=NN*NLEV(IF)
IF (NALPHA(IF).EQ.1) NN1=NN1*NLEV(IF)
56 CONTINUE
NN2=NN1*NLEV(IR)
GO TO 55
C OTHER WITH NO REPS
58 NN=1
DO 60 IF=1,NF
60 NN=NN*NLEV(IF)
NN1=0
NN2=0
55 NN3=NN+NN1+NN2
WRITE (NOUT,101)
101 FORMAT (1H0,20X,'STORAGE LOCATIONS NEEDED FOR DATA, MEANS AND C
1ELL NUMBERS'/21X,57(1H-))
IF (NN3-MNX) 61,61,62
62 WRITE (NOUT,63) NN3,MNX
63 FORMAT ('0ERROR, NUMBER OF STORAGE LOCATIONS IN X MATRIX NEEDED ='
1,I6,' EXCEEDING LIMITS =',I6)
CALL BOOBOO(1)
61 WRITE (NOUT,64) NN3,MNX
64 FORMAT (1H0,I6,' STORAGE LOCATIONS IN X MATRIX NEEDED (MAXIMUM
1SPACE =',I6,1H))
READ (NIN,71) (FMT(I),I=1,16)
71 FORMAT (16A5)
CALL INPUTX
RETURN
END
SUBROUTINE INPUTX
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HEND /,FCP017/4HDATA/
REWIND NSCR1
END1=FCP016
END2=FCP017
C RESET NINX IF NECESSARY
IF (NINX)66,66,67
66 NINX=NIN
GO TO 68
67 NINX = 13
68 IF (NDEP-MAXDEP)80,80,81
81 WRITE (NOUT,82)NDEP,MAXDEP
82 FORMAT('0ERROR - TOO MANY DEPENDENT VARIABLES (',I6,') EXCEEDING
1 MAXIMUM ALLOWED (',I6,')')
CALL BOOBOO(1)
80 NCDF=IIID
IF (NINX-NIN)94,95,94
94 IF (NCDF)96,96,95
96 WRITE (NOUT,97)NCDF
97 FORMAT ('0ERROR - NCDF =',I6/' THIS NUMBER MUST BE POSITIVE
1 - IT IS THE NUMBER OF CARDS PER SUBJECT - CORRECT THE PARAMETER
2 CARD AND RESUBMIT')
CALL BOOBOO(9)
95 DO 10 IK=1,NDEP
XTOT(IK)=0.0
10 ENTOT(IK)=0.0
NXCDS=0
C READ DATA UNTIL END OF DATA CARD ON TAPE NINX.
C IF NINX = NIN, THERE IS JUST ONE END OF DATA CARD
C IF NINX = ANYTHING ELSE, THE END OF DATA CARD MUST BE FOLLOWED
C BY (NCDF-1) BLANKS WHERE NCDF = NUMBER OF CARDS SPECIFIED BY
C THE FORMAT FMT ( I.E. READ BY ONE READ STATEMENT).
C NOTE THAT THE ARRAYS X, X1, AND SSM ARE USED PURELY AS
C TEMPORARY STORAGE HERE
40 IF (NINX-NIN)71,31,71
C DATA TAPE IS NIN
30 FORMAT (20A4)
C DATA CARD ON TAPE NIN
31 IF (ND1OR2-1)21,22,21
C DEPENDENT VARIABLES(S) LAST ON CARD
21 READ (NINX,FMT)(ISUB(IF),IF=1,NF),(X(IK),IK=1,NDEP)
GO TO 23
C DEPENDENT VARIABLES(S) FIRST ON CARD
22 READ (NINX,FMT)(X(IK),IK=1,NDEP),(ISUB(IF),IF=1,NF)
C RESET NCDF SINCE NCDF IS NOT IN COMMON
23 IF (ISUB(1))77,77,76
C DATA TAPE IS NOT NIN
71 READ (NINX,30)(SSM(I),I=1,20)
IF (SSM(1).NE.END1) GO TO 76
92 IF (SSM(2).EQ.END2) GO TO 77
C IGNORE BLANKS, ACCUMULATE SUMS AND WRITE ON TAPE NSCR1
C ALL CASES OF NINX GET TO HERE
76 DO 12 IK=1,NDEP
15 XTOT(IK)=XTOT(IK)+X(IK)
12 ENTOT(IK)=ENTOT(IK)+1.0
IF ((NF+NDEP).GT.128) GO TO 100
WRITE (NSCR1)(ISUB(IF),IF=1,NF),(X(IK),IK=1,NDEP)
NXCDS=NXCDS+1
GO TO 40
100 WRITE(NSCR1)(ISUB(IF),IF=1,NF),(X(IK),IK=1,128-NF)
WRITE(NSCR1)(X(IKK),IKK=IK+1,NDEP)
NXCDS=NXCDS+1
GO TO 40
C GET MEANS AND QUIT
77 DO 20 IK=1,NDEP
20 XBAR1(IK)=XTOT(IK)/ENTOT(IK)
REWIND NSCR1
RETURN
END
SUBROUTINE READX
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HREAD/
C READ AND STORE DATA FOR DEPENDENT VARIABLE IDEP
C NOTE THAT CALLS TO BOOBOO WITH ARGUMENTS = 8 OR 7 ARE NOT
C ERROR EXISTS BUT ONLY SET A SWITCH IN BOOBOO. WHEN THE LAST
C CALL IS BOOBOO(8), AN ERROR OCCURRING IN LOCX IS A PROGRAM
C ERROR. IF THE LAST CALL IS BOOBOO(7), AN ERROR IN LOCX IS DUE
C TO A DATA CARD HAVING SUBSCRIPTS OUT OF RANGE. ALL ERRORS IN
C LOCX ARE CONSIDERED FATAL.
C CALL BOOBOO(9) IS A FATAL ERROR EXIT.
C IF NTYPE2 IS SET = 4, THEN THIS DEPENDENT VARIABLE CALCULATION IS
C SKIPPED OVER BY THE MAIN PROGRAM.
REWIND NSCR1
CALL RELEAS(NSCR1)
INCOUT = 0
NTYPE2=0
SUMX=0.0
SUMX2=0.0
DO 101 IF=1,NF
101 FNLEV(IF)=NLEV(IF)
DO 10 I=1,NN3
10 X(I)=0.0
CALL BOOBOO(7)
NPOINT=1
IF ((NF+NDEP).GT.128) NPOINT=2
DO 12 ICD=1,NXCDS
GO TO (200,201),NPOINT
200 READ (NSCR1)(ISUB(IF),IF=1,NF),(X1(IK),IK=1,NDEP)
GO TO 13
201 READ(NSCR1)(ISUB(IF),IF=1,NF),(X1(IK),IK=1,128-NF)
READ(NSCR1)(X1(IKK),IKK=IK+1,NDEP)
13 XNEW=X1(NOWDEP)-XBAR1(NOWDEP)
IF (IR) 15,15,60
C REPLICATION FACTOR DESIGN
60 IF (NTYPE1-1) 18,19,18
C COMPLETELY CROSSED DESIGN WITH REPS - I.E. CLASS A DESIGN
19 ISUBX=LOCX(ISUB,NALPHA)
X(ISUBX)=X(ISUBX)+XNEW
SUMX=SUMX+XNEW
SUMX2=SUMX2+XNEW**2
NSTAR=NN+ISUBX
X(NSTAR)=X(NSTAR)+1.0
GO TO 12
C OTHER DESIGNS WITH REPLICATIONS - I.E. CLASS B DESIGNS.
C ISUB(IF),IF=1,NF IS THE INPUT SUBSCRIPT LIST
C ISUB1(IF),IF=1,NF ARE = ISUB(IF) FOR THOSE IF WITH NALPHA(IF) = 1
C AND = RUNNING SUBSCRIPT (II) FOR IF = IR.
C SET UP ISUB1(IF),IF=1,NF WHERE ISUB1(IR) RUNS FROM 1 TO
C NN(ISUB,NALPHA) = NNX AND OTHER ISUB1=ISUB (ACTUALLY ONLY
C IF IN ALPHA USED).
C CHECK WHETHER ISUB(IR) IS ALREADY IN LIST NN2(ISUB1,NALPHR)
18 DO 58 IF=1,NF
58 ISUB1(IF)=ISUB(IF)
NSTAR1=LOCX(ISUB,NALPHA)+NN
NNX=X(NSTAR1)
IF (NNX) 22,22,23
23 DO 24 II=1,NNX
ISUB1(IR)=II
CALL BOOBOO(8)
NSTAR2=LOCX(ISUB1,NALPHR)+NN+NN1
CALL BOOBOO(7)
IF (INT(X(NSTAR2))-ISUB(IR)) 24,25,24
24 CONTINUE
GO TO 22
C YES, ISUB(IR) IS ALREADY ON LIST - CHANGE ISUB(IR) TO INTERNAL
C NUMBER.
25 ISUB(IR)=II
GO TO 15
C NO, ISUB(IR) IS NOT ON LIST - SET ISUB(IR) = NEXT INTERNAL NUMBER
22 NNX=NNX+1
IF (NNX-NLEV(IR)) 80,80,81
81 IF (INCOUT.GE.10) GO TO 12
WRITE (NOUT,82)(QFNAME(IF),ISUB(IF),IF=1,NF)
82 FORMAT('0ERROR - THE MAXIMUM NUMBER OF LEVELS FOR THE REPLICATION
1 FACTOR, GIVEN ON THE FACTOR SPECIFICATION CARD, HAS BEEN EXCEEDED
2.'/' THE FIRST CARD FOUND WHICH PRODUCES THIS EXCESS NUMBER OF
3 REPLICATIONS HAS THE SUBSCRIPT SET GIVEN BELOW.'/' CORRECT THE
4 FACTOR SPECIFICATION CARD OR THE DATA CARD AND RERUN.'/10(1X,A1,
5 1H#,I5,1H,))
CALL BOOBOO(9)
80 X(NSTAR1)=NNX
ISUB1(IR)=NNX
CALL BOOBOO(8)
NSTAR2=LOCX(ISUB1,NALPHR)+NN+NN1
CALL BOOBOO(7)
X(NSTAR2)=ISUB(IR)
ISUB(IR)=NNX
C NO REPLICATIONS - ALSO OTHER DESIGNS WITH REPS HAVE ENDED UP
C HERE - HENCE ALL NTYPE1=2 DESIGNS (OTHER DESIGNS) END UP HERE.
C I.E. CLASS B AND C DESIGNS.
15 NSTAR3=LOCX(ISUB,NALL1)
70 IF (XNEW) 30,31,30
30 X(NSTAR3)=XNEW
GO TO 32
31 X(NSTAR3)=-0.0
32 SUMX=SUMX+XNEW
12 CONTINUE
CALL BOOBOO(8)
REWIND NSCR1
IF (NTYPE2.EQ.4) RETURN
C CHECK CELLS
78 IF (IR) 33,33,34
C REPLICATION DESIGNS - DETERMINE WHETHER EQUAL
C (NTYPE2=1),PROPORTIONAL (=2) OR NONPROPORTIONAL (=3) DESIGN
C OR IF CELL IS EMPTY (ERROR).
34 CALL CELLN
IF (NTYPE1-1) 33,35,33
C NON-REPLICATION DESIGNS - CHECK WHETHER ALL CELLS ARE FILLED
C ALSO NON-COMPLETELY CROSSED REPLICATION DESIGNS - CHECK WHETHER
C ALL CELLS HAVE DATA FOR EACH LEVEL OF FACTORS CROSSED WITH
C ALPHA FACTORS.
C CYCLE ALL FACTORS EXCEPT REPLICATION FACTOR IF ANY - LOOP A.
33 LOOPA=0
INITA=1
36 IF (INITA-NF) 37,37,38
37 DO 39 IF=INITA,NF
IF (IF.NE.IR) ISUB(IF)=1
39 CONTINUE
C CYCLE REPLICATION FACTOR, IF ANY.
38 IF (IR) 42,42,43
43 L5=LOCX(ISUB,NALPHA)+NN
IRLIM5=X(L5)
ISUB(IR)=1
42 CONTINUE
ISUBX=LOCX(ISUB,NALL1)
46 CALL CHLOOP(LOOPA,LOOPMX,FCP016,FCP017)
IF (IR) 91,91,93
93 IF (ISUB(IR)-IRLIM5) 90,91,91
90 ISUB(IR)=ISUB(IR)+1
GO TO 42
C END CYCLING - LOOP A.
91 DO 50 I=1,NF
IF=NF-I+1
IF (IF-IR) 41,50,41
41 IF (ISUB(IF)-NLEV(IF)) 52,50,50
52 ISUB(IF)=ISUB(IF)+1
INITA=IF+1
GO TO 36
50 CONTINUE
35 RETURN
END
FUNCTION LOCX(LSTSUB,INISUB)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
DIMENSION LSTSUB(5),INISUB(5)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C FIND SUBSCRIPT IN X MATRIX FOR SUBSCRIPTS LSTSUB(IF),IF=1,NF
C EXCEPT FOR IF WITH INISUB(IF)=0
C ALSO FIRST CHECK WHETHER ALL SUBSCRIPTS ARE WITHIN RANGE.
DO 40 IF=1,NF
IF (INISUB(IF))40,40,41
41 IF (LSTSUB(IF)-NLEV(IF))50,50,42
50 IF (LSTSUB(IF))42,42,40
42 WRITE (NOUT,43)(LSTSUB(IF1),IF1=1,NF)
43 FORMAT ('0ERROR IN LOCX - SUBSCRIPT SET OUT OF RANGE'/(1X,10I12))
CALL BOOBOO(5)
40 CONTINUE
DO 20 IF=1,NF
IF3=NF-IF+1
IF (INISUB(IF3))20,20,21
21 LOCX=LSTSUB(IF3)
GO TO 23
20 CONTINUE
WRITE (NOUT,24)(INISUB(IF),IF=1,NF)
24 FORMAT ('0ERROR IN LOCX, NO INISUB IS 1'/1X,10I12)
CALL BOOBOO(3)
23 IF1=IF3
IPROD=1
DO 30 IF=1,NF1
IF2=NF-IF
IF (IF2-IF3)31,30,31
31 IF (INISUB(IF2)-1)30,32,30
32 IPROD=IPROD*NLEV(IF1)
LOCX=LOCX+IPROD*(LSTSUB(IF2)-1)
IF1=IF2
30 CONTINUE
RETURN
END
SUBROUTINE CELLN
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HCELL/,FCP018/4HLOOP/,FCP019/4HCELL/
DO 10 IF=1,NF
10 FNLEV(IF)=NLEV(IF)
IF (IR)11,11,12
C NO REPLICATION FACTOR
11 NTYPE2=1
RETURN
C REPLICATION FACTOR - CHECK FOR EQUAL CELL N AND GET CONSTANTS
12 FN=0.0
COUN=0.0
SUMN=0.0
EQUN=0.0
C START CYCLING SUBSCRIPTS IN ALPHA - LOOPE
LOOPE=0
INITE=1
46 IF (INITE-NF)47,47,48
47 DO 49 IF=INITE,NF
IF (NALPHA(IF).EQ.1) ISUB2(IF)=1
49 CONTINUE
48 LISUB2=LOCX(ISUB2,NALPHA)+NN
XXX=X(LISUB2)
IF (XXX)63,63,17
63 IF (NTYPE2.NE.4) WRITE(NOUT,65)
65 FORMAT ('0AS SHOWN IN THE TABLE BELOW, ONE OR MORE CELLS HAVE ZERO
1 REPLICATIONS. THE ANALYSIS CANNOT BE PERFORMED.')
NTYPE2=4
17 IF (EQUN)68,67,66
C FIRST CELL TO BE CHECKED FOR EQUAL N
67 EQUN=XXX
GO TO 68
C CHECK WHETHER NEW CELL HAS SAME N AS FIRST CELL
66 IF (EQUN.NE.XXX) EQUN=-1.0
68 FN=FN+1.0/XXX
SUMN=SUMN+XXX
COUN=COUN+1.0
C FINISH CYCLING SUBSCRIPTS IN ALPHA
CALL CHLOOP(LOOPE,LOOPMX,FCP016,FCP017)
DO 40 I=1,NF
IF=NF-I+1
IF (NALPHA(IF)-1)40,62,40
62 ISUB2(IF)=ISUB2(IF)+1
IF (ISUB2(IF)-NLEV(IF))42,42,40
42 INITE=IF+1
GO TO 46
40 CONTINUE
C SET NTYPE2 AND FNLEV(IR),DF(IR)
IF (EQUN)70,70,71
C UNEQUAL N
C CHECK IF PROPORTIONAL DESIGN
C START CYCLING SUBSCRIPTS IN ALPHA - LOOPK
70 NT=0
LOOPK=0
INITK=1
86 IF (INITK-NF)87,87,88
87 DO 89 IF=INITK,NF
IF (NALPHA(IF).EQ.1) ISUB2(IF)=1
89 CONTINUE
88 ENCHK=1.0
ISUB1(IR)=0
DO 30 IF=1,NF
IF (NALPHA(IF)-1)30,31,30
31 DO 32 IF1=1,NF
IF (IF1-IR)33,32,33
33 IF (IF1-IF)34,32,34
34 ISUB1(IF1)=0
32 CONTINUE
ISUB1(IF)=ISUB2(IF)
ENCHK=ENCHK*ENMEAN(ISUB1)*COUNT/SUMN
IF (ILAST.GT.0) WRITE (NOUT,3)ENCHK,(ISUB1(III),III=1,NF)
3 FORMAT (1X,E20.8,10I6)
30 CONTINUE
ENCHK=ENCHK*SUMN
IF (ILAST.GT.0) WRITE (NOUT,3)ENCHK
4 LISUB2=LOCX(ISUB2,NALPHA)+NN
NPRINT=0
DO 75 JJ=1,NF
IF (NALPHA(JJ)-1)75,76,75
76 NPRINT=NPRINT+1
IFIN(NPRINT)=ISUB2(JJ)
75 CONTINUE
WRITE (NOUT,77)X(LISUB2),(IFIN(IP),IP=1,NPRINT)
77 FORMAT (17X,F10.0,10I5)
IF (AINT(ENCHK+.5).NE.X(LISUB2)) NT=3
C FINISH CYCLING SUBSCRIPTS IN ALPHA
35 CALL CHLOOP(LOOPK,LOOPMX,FCP018,FCP019)
DO 80 I=1,NF
IF=NF-I+1
IF (NALPHA(IF)-1)80,91,80
91 ISUB2(IF)=ISUB2(IF)+1
IF (ISUB2(IF)-NLEV(IF))82,82,80
82 INITK=IF+1
GO TO 86
80 CONTINUE
IF (NTYPE2-4)18,72,18
18 IF (NT)13,13,73
C IT IS A PROPORTIONAL DESIGN BUT FIRST CHECK IF THIS IS OVERRIDDEN
13 IF (PROVER)74,74,73
74 NTYPE2=2
FNLEV(IR)=0.0
DF(IR)=SUMN-FLOAT(NN1)
GO TO 72
C NON-PROPORTIONAL DESIGN
73 NTYPE2=3
FNLEV(IR)=COUN/FN
WRITE (NOUT,20)FNLEV(IR)
20 FORMAT (1H0,20X,'HARMONIC MEAN =',E16.8/)
DF(IR)=SUMN-FLOAT(NN1)
GO TO 72
C EQUAL N
71 NTYPE2=1
FNLEV(IR)=EQUN
DF(IR)=(EQUN-1.0)*FLOAT(NN1)
WRITE (NOUT,92)EQUN
92 FORMAT (17X,F10.0,5X,9HALL CELLS)
IF (EQUN-1.0)101,101,72
101 WRITE (NOUT,103)
103 FORMAT ('0NO CELL HAS MORE THAN ONE REPLICATION - HENCE ANALYSI
1S CANNOT BE PERFORMED - EITHER ADD REPLICATIONS OR DELETE REPLICA
1TION'/' FACTOR FROM DESIGN AND RERUN.')
NTYPE2=4
72 RETURN
END
FUNCTION ENMEAN(LSTSUB)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
DIMENSION LSTSUB(5)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HENME/
C FIND MEAN OF CELL N FOR SUBSCRIPT SET LSTSUB(IF), IF=1,NF
C (USING ONLY SUBSCRIPTS IN ALPHA)
C IF LSTSUB(IR) IS NOT ZERO RETURN WITH ENMEAN = 1.0
C OTHERWISE, AVERAGE OVER EACH SUBSCRIPT IN ALPHA WHICH IS ZERO.
C THE NON-ZERO SUBSCRIPTS IN ALPHA TAKE THEIR INPUT VALUE.
IF (LSTSUB(IR))11,10,11
11 ENMEAN=1.0
RETURN
10 DO 35 IF=1,NF
IF (LSTSUB(IF).GT.0) ISUB(IF)=LSTSUB(IF)
35 CONTINUE
ENSUM=0.0
COUNT=0.0
C CYCLE DOTTED SUBSCRIPTS IN ALPHA - LOOPJ
LOOPJ=0
INITJ=1
46 IF (INITJ-NF)47,47,48
47 DO 49 IF=INITJ,NF
IF (NALPHA(IF)-1)49,61,49
61 IF (LSTSUB(IF).EQ.0) ISUB(IF)=1
49 CONTINUE
48 L1=LOCX(ISUB,NALPHA)+NN
ENSUM=ENSUM+X(L1)
COUNT=COUNT+1.0
C FINISH CYCLING DOTTED SUBSCRIPTS
CALL CHLOOP(LOOPJ,LOOPMX,FCP016,FCP017)
DO 40 I=1,NF
IF=NF-I+1
IF (NALPHA(IF)-1)40,62,40
62 IF (LSTSUB(IF))40,72,40
72 ISUB(IF)=ISUB(IF)+1
IF (ISUB(IF)-NLEV(IF))42,42,40
42 INITJ=IF+1
GO TO 46
40 CONTINUE
ENMEAN=ENSUM/COUNT
RETURN
END
SUBROUTINE SSEQU
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HSSEQ/,FCP018/4HLOOP/,FCP019/4HSSEQ/
C USED FOR NTYPE2=1 OR 3 (EQUAL OR NON-PROPORTIONAL)
IDUM=2**NF
DO 50 I=1,IDUM
50 SSM(I)=0.0
C START CYCLING OF LEGAL SOURCES
DO 10 IS=1,NS
DO 11 IF=1,NF
11 ISUB(IF)=ISUBSC(IF,IS)
SSC=0.0
SSMAX=0.0
C START CYCLING OF VARYING AND DOTTED SUBSCRIPTS
NABS=0
DO 12 IF=1,NF
IF (ISUB(IF)-1) 13,14,15
C ABSENT SUBSCRIPT
13 ISTART(IF)=0
IFIN(IF)=0
NABS=NABS+1
GO TO 12
C DEAD SUBSCRIPT
14 ISTART(IF)=1
IFIN(IF)=1
GO TO 12
C LIVE SUBSCRIPT
15 ISTART(IF)=0
IFIN(IF)=1
12 CONTINUE
LOOPD=0
INITD=1
20 IF (INITD-NF) 21,21,22
21 DO 23 IF=INITD,NF
23 IND2(IF)=ISTART(IF)
C CHECK IF THE FOLLOWING FOUR CONDITIONS ARE ALL SATISFIED
C 1. REPLICATION DESIGN
C 2. NON-PROPORTIONAL DESIGN
C 3. IR IS LIVE FOR THIS SOURCE
C 4. IR IS DOTTED FOR THIS SSM
22 IF (IR) 70,70,71
71 IF (NTYPE2-3) 70,73,70
73 IF (ISUB(IR)-2) 70,72,70
72 IF (IND2(IR)) 70,74,70
C YES THEY ARE - THE SSM WILL BE CALCULATED DIFFERENTLY FROM NORMAL
C AND STORED IN A SPECIAL PLACE SINCE THERE IS ANOTHER SSM WITH THE
C SAME IND2(IF) BUT COMPUTED NORMALLY
74 NSPEC=1
DO 93 IF=1,NF
93 ISUB2(IF)=1-IND2(IF)
LIND2=LOCSSM(ISUB2)
GO TO 94
C N0, THEY ARE NOT - NORMAL COMPUTATION
70 LIND2=LOCSSM(IND2)
C GET NZERO
94 NZERO=0
DO 90 IF=1,NF
IF (IND2(IF).EQ.0)NZERO=NZERO+1
90 CONTINUE
C CHECK IF THIS COMBINATION OF VARYING AND DOTTED SUBSCRIPTS
C HAS BEEN DONE BEFORE (I.E. THIS LIND2) - IF SO GO TO 33
NSPEC=0
C IF SSM(LIND2) IS 0.0 BY CALCULATION THEN THE CALCULATION WILL BE
C REPEATED (CORRECTLY). THIS WILL PRODUCE DUPLICATE PRINTING OF
C SOME MEANS (CORRECTLY). IT WAS NOT CONSIDERED WORTH THE WHILE
C TO DELETE THIS EXTRA PRINTING.
IF (SSM(LIND2)) 33,52,33
C ARE ALL SUBSCRIPTS VARYING AND COMPLETELY CROSSED WITH REPS
C IF SO SSM=SUMX2 AND GO TO 33
52 IF (NTYPE1-1) 30,31,30
31 DO 32 IF=1,NF
IF (IND2(IF)-1) 30,32,30
32 CONTINUE
C YES
SSM(LIND2)=SUMX2
GO TO 33
C NO
C START SUMMING OVER VARYING SUBSCRIPTS, EXCEPT IR IF VARYING
30 LOOPB=0
SSM1=0.0
INITB=1
80 IF (INITB-NF) 81,81,82
81 DO 83 IF=INITB,NF
IF (IND2(IF)) 85,85,84
84 IF (IF.NE.IR) ISUB1(IF)=1
GO TO 83
85 ISUB1(IF)=0
83 CONTINUE
C START SUMMING OVER IR, IF VARYING
82 IF (IR) 4,4,2
2 IF (IND2(IR)) 4,4,5
5 L6=LOCX(ISUB1,NALPHA)+NN
IRLIM6=X(L6)
ISUB1(IR)=1
4 XX=XMEAN(ISUB1)
IF (NSPEC) 95,95,96
95 SSM1=SSM1+XX**2
GO TO 97
96 NSTAR1=LOCX(ISUB1,NALPHA)+NN
SSM1=SSM1+X(NSTAR1)*XX**2
C DELETE PRINTING OF MEAN IF SPECIAL COMPUTATION USED OR
C IF NO SUBSCRIPT IS DOTTED
97 IF (NSPEC) 43,43,44
43 DO 75 IF=1,NF
IF (ISUB1(IF)) 75,76,75
75 CONTINUE
GO TO 44
C PRINT MEAN BUT FIRST CHECK IF UNWEIGHTED MEAN - ONLY SO IF ALL
C FOUR TESTS BELOW ARE PASSED
76 XXADD=XX+XBAR1(NOWDEP)
CALL INEX(ISUB1,ISUB)
IF (IR) 45,45,46
46 IF (NTYPE2-3) 45,47,45
47 IF (ISUB1(IR)) 45,48,45
48 DO 49 IF=1,NF
IF (NALPHA(IF)-1) 49,55,49
55 IF (ISUB1(IF)) 49,16,49
49 CONTINUE
GO TO 45
C UNWEIGHTED MEAN
16 WRITE (NOUT,51) XXADD,(ISUB(IF),IF=1,NF)
51 FORMAT (1X,10HUNWEIGHTED,E16.8,10I5)
GO TO 44
C WEIGHTED MEAN
45 WRITE (NOUT,34) XXADD,(ISUB(IF),IF=1,NF)
34 FORMAT (11X,E16.8,10I5)
C COMPLETE SUMMING OVER IR, IF VARYING
44 CALL CHLOOP(LOOPB,LOOPMX,FCP016,FCP017)
IF (IR) 6,6,7
7 IF (IND2(IR)) 6,6,8
8 IF (ISUB1(IR)-IRLIM6) 9,6,6
9 ISUB1(IR)=ISUB1(IR)+1
GO TO 4
C COMPLETE SUMMING OVER VARYING SUBSCRIPTS, EXCEPT IR
6 DO 40 I=1,NF
IF=NF-I+1
IF (IND2(IF)) 40,40,41
41 IF (IF-IR) 104,40,104
104 ISUB1(IF)=ISUB1(IF)+1
IF (ISUB1(IF)-NLEV(IF))42,42,40
42 INITB=IF+1
GO TO 80
40 CONTINUE
C GET MULTIPLYING FACTOR
PILEV=1.0
DO 86 IF=1,NF
IF (IND2(IF)) 86,87,86
87 IF (NSPEC) 98,98,99
99 IF (IF-IR) 98,86,98
98 PILEV=PILEV*FNLEV(IF)
86 CONTINUE
SSM(LIND2)=SSM1*PILEV
33 SSML=SSM(LIND2)
IF (SSML.GT.SSMAX)SSMAX=SSML
57 SSC=SSC+SSML*(-1.0)**(NZERO-NABS)
IF (ILAST.GT.0) WRITE(NOUT,300) SSM1,SSML,(IND2(IF),IF=1,NF)
300 FORMAT (1X,2E20.8,10I6)
C COMPLETE CYCLING OF VARYING AND DOTTED SUBSCRIPTS
102 CALL CHLOOP(LOOPD,LOOPMX,FCP018,FCP019)
DO 28 I=1,NF
IF=NF-I+1
IND2(IF)=IND2(IF)+1
IF (IND2(IF)-IFIN(IF)) 29,29,28
29 INITD=IF+1
GO TO 20
28 CONTINUE
C STORE SS FOR SOURCE AND COMPLETE CYCLING OF SOURCES
C ALSO GET NUMBER OF SIGNIFICANT DIGITS
SS(IS)=SSC
S11=ABS(SSMAX/SSC)
IF (S11) 62,62,3
3 SIGDIG(IS)=7.0-ALOG10(S11)
IF (SIGDIG(IS)) 59,59,60
59 SIGDIG(IS)=0.0
60 IF (SIGDIG(IS)-7.0) 61,61,62
62 SIGDIG(IS)=7.0
61 CONTINUE
10 CONTINUE
NXX=XXADD
RETURN
END
SUBROUTINE SSPROP
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HSSEQ/,FCP018/4HLOOP/,FCP019/4HSSEQ/
C USED FOR NTYPE2 = 2 (PROPORTIONAL DESIGN)
IDUM=2**NF
DO 50 I=1,IDUM
50 SSM(I)=0.0
C START CYCLING OF LEGAL SOURCES
DO 10 IS=1,NS
DO 11 IF=1,NF
11 ISUB(IF)=ISUBSC(IF,IS)
SSC=0.0
SSMAX=0.0
C START CYCLING OF VARYING AND DOTTED SUBSCRIPTS
NABS=0
DO 12 IF=1,NF
IF (ISUB(IF)-1) 13,14,15
C ABSENT SUBSCRIPT
13 ISTART(IF)=0
IFIN(IF)=0
NABS=NABS+1
GO TO 12
C DEAD SUBSCRIPT
14 ISTART(IF)=1
IFIN(IF)=1
GO TO 12
C LIVE SUBSCRIPT
15 ISTART(IF)=0
IFIN(IF)=1
12 CONTINUE
LOOPD=0
INITD=1
20 IF (INITD-NF) 21,21,22
21 DO 23 IF=INITD,NF
23 IND2(IF)=ISTART(IF)
22 LIND2=LOCSSM(IND2)
C GET NZERO
NZERO=0
DO 90 IF=1,NF
IF (IND2(IF).EQ.0)NZERO=NZERO+1
90 CONTINUE
C CHECK IF THIS COMBINATION OF VARYING AND DOTTED SUBSCRIPTS
C HAS BEEN DONE BEFORE (I.E. THIS LIND2) - IF SO GO TO 33
C IF SSM(LIND2) IS 0.0 BY CALCULATION THEN THE CALCULATION WILL BE
C REPEATED (CORRECTLY). THIS WILL PRODUCE DUPLICATE PRINTING OF
C SOME MEANS (CORRECTLY). IT WAS NOT CONSIDERED WORTH THE WHILE
C TO DELETE THIS EXTRA PRINTING.
IF (SSM(LIND2)) 33,52,33
C ARE ALL SUBSCRIPTS VARYING AND COMPLETELY CROSSED WITH REPS
C IF SO SSM=SUMX2 AND GO TO 33
52 IF (NTYPE1-1)30,31,30
31 DO 32 IF=1,NF
IF (IND2(IF)-1)30,32,30
32 CONTINUE
C YES
SSM(LIND2)=SUMX2
GO TO 33
C NO
C START SUMMING OVER VARYING SUBSCRIPTS, EXCEPT IR IF VARYING
30 LOOPB=0
SSM1=0.0
INITB=1
80 IF (INITB-NF)81,81,82
81 DO 83 IF=INITB,NF
IF (IND2(IF))85,85,84
84 IF (IF.NE.IR) ISUB1(IF)=1
GO TO 83
85 ISUB1(IF)=0
83 CONTINUE
C START SUMMING OVER IR, IF VARYING
82 IF (IR)4,4,2
2 IF (IND2(IR))4,4,5
5 L6=LOCX(ISUB1,NALPHA)+NN
IRLIM6=X(L6)
ISUB1(IR)=1
4 XX=XMEAN(ISUB1)
SSM1=SSM1+ENMEAN(ISUB1)*XX**2
C DELETE PRINTING IF NO SUBSCRIPT IS DOTTED
DO 75 IF=1,NF
IF (ISUB1(IF))75,43,75
75 CONTINUE
GO TO 44
43 XXADD=XX+XBAR1(NOWDEP)
CALL INEX(ISUB1,ISUB)
WRITE (NOUT,51)XXADD,(ISUB(IF),IF=1,NF)
51 FORMAT (11X,E16.8,10I5)
C COMPLETE SUMMING OVER IR, IF VARYING
44 CALL CHLOOP(LOOPB,LOOPMX,FCP016,FCP017)
IF (IR)6,6,7
7 IF (IND2(IR))6,6,8
8 IF (ISUB1(IR)-IRLIM6)9,6,6
9 ISUB1(IR)=ISUB1(IR)+1
GO TO 4
C COMPLETE SUMMING OVER VARYING SUBSCRIPTS, EXCEPT IR
6 DO 40 I=1,NF
IF=NF-I+1
IF (IND2(IF))40,40,41
41 IF (IF-IR)104,40,104
104 ISUB1(IF)=ISUB1(IF)+1
IF (ISUB1(IF)-NLEV(IF))42,42,40
42 INITB=IF+1
GO TO 80
40 CONTINUE
C GET MULTIPLYING FACTOR
PILEV=1.0
DO 86 IF=1,NF
IF (IND2(IF).NE.0)GO TO 86
99 IF (IF.NE.IR)PILEV=PILEV*FNLEV(IF)
86 CONTINUE
SSM(LIND2)=SSM1*PILEV
33 SSML=SSM(LIND2)
IF (SSML.GT.SSMAX)SSMAX=SSML
57 IF (ILAST.GT.0) WRITE (NOUT,300)SSM1,SSML,(IND2(IF),IF=1,NF)
300 FORMAT (1X,2E20.8,10I6)
102 SSC=SSC+SSML*(-1.0)**(NZERO-NABS)
C COMPLETE CYCLING OF VARYING AND DOTTED SUBSCRIPTS
CALL CHLOOP(LOOPD,LOOPMX,FCP018,FCP019)
DO 28 I=1,NF
IF=NF-I+1
IND2(IF)=IND2(IF)+1
IF (IND2(IF)-IFIN(IF))29,29,28
29 INITD=IF+1
GO TO 20
28 CONTINUE
C STORE SS FOR SOURCE AND COMPLETE CYCLING OF SOURCES
C ALSO GET NUMBER OF SIGNIFICANT DIGITS
SS(IS)=SSC
S11=ABS(SSMAX/SSC)
IF (S11.GT.0) GO TO 3
SIGDIG(IS)=7.0
GO TO 10
3 SIGDIG(IS)=7.0-ALOG10(S11)
IF (SIGDIG(IS).LT.0)SIGDIG(IS)=0.0
60 IF (SIGDIG(IS).GT.7.0)SIGDIG(IS)=7.0
10 CONTINUE
RETURN
END
FUNCTION LOCSSM(LSTSUB)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
DIMENSION LSTSUB(5)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
4 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
5 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C SAME AS LOCX EXCEPT THAT DIMENSION OF EACH FACTOR IS 2 INSTEAD
C OF NLEV1(IF)
LOCSSM=LSTSUB(NF)+1
IPROD=1
NF1=NF-1
DO 10 IF=1,NF1
IF2=NF-IF
IPROD=IPROD*2
LOCSSM=LOCSSM+IPROD*LSTSUB(IF2)
10 CONTINUE
RETURN
END
FUNCTION XMEAN(LSTSUB)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200), XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
DIMENSION LSTSUB(5)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/4HLOOP/,FCP017/4HXMEA/
C FIND THE MEAN OF X FOR SUBSCRIPT SET LSTSUB(IF),IF=1,NF
C IF LSTSUB(IF)=0, IF IS DOTTED (SUMMED OVER)
C IF NOT EQUAL TO 0, IF TAKES INPUT VALUE.
C CHECK THAT IF IR IS NOT DOTTED, ALL OTHER SUBSCRIPTS ARE ALSO NOT
C DOTTED.
IF (IR) 10,10,51
51 IF (LSTSUB(IR)) 10,10,11
11 DO 12 IF=1,NF
IF (NALPHA(IF)-1) 12,13,12
13 IF (LSTSUB(IF)) 14,14,12
14 WRITE (NOUT,15) IR,IF,(LSTSUB(I),I=1,NF)
15 FORMAT ('0ERROR IN XMEAN, IR #',I5,' IS NOT DOTTED BUT IF #',I5,
1 ' IS DOTTED'/(1X,10I12))
CALL BOOBOO(3)
12 CONTINUE
C CHECK THAT IF NTYPE1=1, IR IS DOTTED
10 IF (NTYPE1-1) 30,31,30
31 IF (LSTSUB(IR)) 32,30,32
32 WRITE (NOUT,33) NTYPE1,(LSTSUB(IF),IF=1,NF)
33 FORMAT ('0ERROR IN XMEAN, NTYPE1 #',I5,' BUT IR IS NOT DOTTED'
1 /(1X,10I12))
CALL BOOBOO(3)
C SET ISUB(IF)=LSTSUB(IF) FOR ALL UNDOTTED SUBSCRIPTS
30 DO 35 IF=1,NF
IF (LSTSUB(IF).GT.0)ISUB(IF)=LSTSUB(IF)
35 CONTINUE
XSUM=0.0
COUNT=0.0
C CYCLE DOTTED SUBSCRIPTS (EXCEPT IR, IF DOTTED) - LOOPC
C FOR SUMMING
LOOPC=0
INITC=1
46 IF (INITC-NF) 47,47,48
47 DO 49 IF=INITC,NF
IF (LSTSUB(IF)) 49,60,49
60 IF (IF.NE.IR) ISUB(IF)=1
49 CONTINUE
48 IF (NTYPE1-1) 62,63,62
C NTYPE1=1 CASE - IR MUST BE DOTTED
63 LISUBS=LOCX(ISUB,NALPHA)
L1=LISUBS+NN
IF (NTYPE2-3) 76,75,76
76 XSUM=XSUM+X(LISUBS)
COUNT=COUNT+X(L1)
GO TO 64
C UNWEIGHTED MEAN
75 XSUM=XSUM+X(LISUBS)/X(L1)
COUNT=COUNT + 1.0
GO TO 64
C NTYPE1=2 CASE - CYCLE IR IF DOTTED
62 IF (IR) 65,65,69
69 IF (LSTSUB(IR)) 65,66,65
66 L4=LOCX(ISUB,NALPHA)+NN
IRLIM=X(L4)
XS=0.0
CC=0.0
DO 68 I=1,IRLIM
ISUB(IR)=I
LISUBS=LOCX(ISUB,NALL1)
XS=XS+X(LISUBS)
CC=CC+1.0
68 CONTINUE
IF (NTYPE2-3) 78,77,78
78 XSUM=XSUM+XS
COUNT=COUNT+CC
GO TO 64
C UNWEIGHTED MEAN
77 XSUM=XSUM+XS/CC
COUNT=COUNT+1.0
GO TO 64
65 LISUBS=LOCX(ISUB,NALL1)
XSUM=XSUM+X(LISUBS)
COUNT=COUNT+1.0
C FINISH CYCLING DOTTED SUBSCRIPTS
64 CALL CHLOOP(LOOPC,LOOPMX,FCP016,FCP017)
DO 40 I=1,NF
IF=NF-I+1
IF (LSTSUB(IF)) 40,72,40
72 IF (IF-IR) 73,40,73
73 ISUB(IF)=ISUB(IF)+1
IF (ISUB(IF)-NLEV(IF)) 42,42,40
42 INITC=IF+1
GO TO 46
40 CONTINUE
XMEAN=XSUM/COUNT
RETURN
END
SUBROUTINE INEX(LSTIN,LSTEX)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5), NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
DIMENSION LSTIN(5),LSTEX(5)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C THIS SUBROUTINE SETS LSTEX(IF) = LSTIN(IF) EXCEPT FOR
C LSTEX(IR) IF THERE IS A REPLICATION FACTOR AND IT IS NOT DOTTED
C IN WHICH CASE LSTEX(IR) = EXTERNAL NUMBER.
DO 64 IF=1,NF
IF (IF-IR)66,65,66
65 IF (LSTIN(IF))66,66,67
67 NSTAR=LOCX(LSTIN,NALPHR)+NN+NN1
LSTEX(IF)=X(NSTAR)
GO TO 64
66 LSTEX(IF)=LSTIN(IF)
64 CONTINUE
RETURN
END
SUBROUTINE FISH
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C COMPUTE ALL NUMBERS IN SUMMARY TABLE.
C COMPUTE DEGREES OF FREEDOM FOR EACH SOURCE.
C NOTE - IF REPLICATION DESIGN, DF(IR) HAS ALREADY BEEN
C CALCULATED IN CELLN
DO 10 IS=1,NS
IF (IS-IR)30,10,30
30 DF(IS)=1.0
DO 11 IF=1,NF
IF (ISUBSC(IF,IS)-1)11,41,42
C DEAD SUBSCRIPT
41 IF (IR)43,43,44
C REPLICATION DESIGN - IF IF IS IN ALPHA, CONTRIBUTION HANDLED
C BY DF(IR).
44 IF (NALPHA(IF)-1)43,11,43
C NON-REPLICATION DESIGN OR NESTED SUBSCRIPT NOT IN ALPHA
43 DF(IS)=DF(IS)*FNLEV(IF)
GO TO 11
C LIVE SUBSCRIPT
42 IF (IF-IR)45,46,45
C NON-REPLICATION SUBSCRIPT
45 DF(IS)=DF(IS)*(FNLEV(IF)-1.0)
GO TO 11
C REPLICATION SUBSCRIPT
46 DF(IS)=DF(IS)*DF(IR)
11 CONTINUE
10 CONTINUE
C COMPUTE MEAN SQUARE FOR EACH SOURCE
DO 15 IS=1,NS
15 SMS(IS)=SS(IS)/DF(IS)
C COMPUTE F RATIO FOR EACH SOURCE WHICH HAS A DENOM.
C SET FRAT = -100. OTHERWISE
DO 17 IS=1,NS
I1=LDEN1(IS)
IF (I1)18,18,19
C NO DENOM
18 FRAT(IS)=-100.
GO TO 17
C DENOMINATOR IS SOURCE I1.
19 FRAT(IS)=SMS(IS)/SMS(I1)
17 CONTINUE
RETURN
END
SUBROUTINE FPRINT
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
C PRINT SUMMARY TABLE
WRITE(NOUT,10)(TIT(I),I=1,16),NOWDEP
10 FORMAT (1H1,20X,16A5/1H0,30X,'ANALYSIS OF VARIANCE SUMMARY TABLE
1 FOR DEPENDENT VARIABLE',I6/31X,63(1H-)//' SOURCE',13X,'NESTING',
2 12X,'DENOMINATOR',8X,'DEGREES OF FREEDOM',3X,'SUM OF SQUARES',7X,
3 'MEAN SQUARE',10X,'F RATIO'/1H0,61X,'NUM',5X,'DEN',16X,'*SIGNIF
4ICANT* '/92X,'*DIGITS*'/92X,'*IN SS*'/)
IOLD=0
DO 11 IS=1,NS3
INUM=LT1S(IS)
IDEN=LDEN1(INUM)
IF (IOLD.EQ.IDEN) GO TO 13
IF (IDEN.GT.0) WRITE(NOUT,17)
GO TO 16
13 IF (IDEN.LE.0) WRITE(NOUT,17)
17 FORMAT (1H )
16 IOLD=IDEN
CALL FLINE(INUM,IDEN)
11 CONTINUE
IF (IR)19,19,20
19 WRITE (NOUT,30)
30 FORMAT ('0THE DESIGN IS BALANCED AND HAS NO REPLICATION FACTOR -
1 HENCE THE ANALYSIS OF VARIANCE IS EXACT'/' EXCEPT FOR TRUNCA
1TION AND ROUNDING ERRORS')
GO TO 35
20 IF (NTYPE2-2)21,22,23
21 WRITE (NOUT,31)QFNAME(IR),QFNAME(IR)
31 FORMAT ('0FACTOR',1X,A1,' IS THE REPLICATION FACTOR AND',1X,A1,
1 ' HAS AN EQUAL NUMBER OF LEVELS FOR EACH COMBINATION OF LEVELS'/
2 ' OF THE FACTORS IN WHICH IT IS NESTED'/'0HENCE THE DESIGN IS
3 BALANCED. THE ANALYSIS OF VARIANCE IS EXACT EXCEPT FOR TRUNC
4ATION')
GO TO 35
22 WRITE (NOUT,32)QFNAME(IR),QFNAME(IR)
32 FORMAT ('0FACTOR',1X,A1,' IS THE REPLICATION FACTOR AND',1X,A1,
1' HAS AN UNEQUAL NUMBER OF LEVELS FOR EACH COMBINATION OF LEVELS
2 OF THE FACTORS IN'/' WHICH IT IS NESTED')
WRITE (NOUT,34)
34 FORMAT ('0HOWEVER THE NUMBER OF LEVELS ARE PROPORTIONAL AND HENCE
1 THE DESIGN IS BALANCE.'/' THE ANALYSIS OF VARIANCE IS EXACT
2 EXCEPT FOR TRUNCATION AND ROUNDING ERRORS')
GO TO 35
23 WRITE (NOUT,32)QFNAME(IR),QFNAME(IR)
IF (PROVER)41,41,42
42 WRITE (NOUT,43)
43 FORMAT('0HOWEVER, THE NUMBER OF LEVELS ARE PROPORTIONAL AND HENCE
1 THE DESIGN IS BALANCED. NEVERTHERLESS THE APPROPXIMATE METHOD
2 OF UNWEIGHTED'/' MEANS HAS BEEN USED DUE TO AN INPUT OVERRIDE.
3 SEE, FOR EXAMPLE, WINER PAGES 224-227, 241-244 OR SCHEFFE PAGES
4 362-363')
GO TO 35
41 WRITE (NOUT,33)
33 FORMAT ('0THE DESIGN IS NOT BALANCED AND THE ANALYSIS OF VARIANCE
1 IS ONLY APPROXIMATE,'/' (EVEN IF THERE WERE NO TRUNCATION AND
2 ROUNDING ERRORS)'//' THE APPROXIMATE METHOD OF UNWEIGHTED
3 MEANS HAS BEEN USED.',2X, 'SEE, FOR EXAMPLE, WINER PAGES 224-227,
4241-244 OR SCHEFFE PAGES 362-363')
35 RETURN
END
SUBROUTINE FLINE(INUM,IDEN)
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 FNLEV(5),IFIN(5),IND2(5),ISTART(5),ISUB(5),
1 ISUB1(5),ISUB2(5),NALL1(5),NALPHA(5),NALPHR(5),
2 PNAME(5),QFN(5),SSM(32),DF(100),FRAT(100),SIGDIG(100),
3 SMS(100),SS(100),ENTOT(200),XBAR1(200),XTOT(200),X1(200),
4 X(5000),FMT(16)
DIMENSION ISUBSC(5,100),LAUX(5,100),LEMST3(10,100),
1 JSUBSC(5,5),QNEST(5,19)
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/X
COMMON/BLOCK2/COUN,COUNT,EQUN,INITA,INITB,INITC,INITD,INITE,ISUBX,
1 LOOPA,LOOPB,LOOPC,LOOPD,LOOPE,MAXDEP,MNX,NA,NABS,
2 NA1,NN,NNX,NN1,NN2,NN3,NOWDEP,NSTAR,NSTAR1,NSTAR2,
3 NSTAR3,NTYPE1,NTYPE2,NXCDS,NZERO,PILEV,SSC,SSM1,
4 SUMN,SUMX,SUMX2,XNEW,XSUM,FNLEV,IFIN,IND2,ISTART,
5 ISUB,ISUB1,ISUB2,NALL1,NALPHA,NALPHR,SSM,DF,FRAT,
6 SMS,SS,ENTOT,XBAR1,XTOT,X1,FMT,PNAME,PROVER,QFN,
7 SIGDIG
DATA FCP016/1H /
C PRINTS SUMMARY LINE FOR SOURCE INUM HAVING DENOM IDEN.
C IF IDEN=0, NO DENOMINATOR.
DO 10 I=1,58
10 QP1(I)=FCP016
C SETUP SOURCE NAME AND NESTING.
I=2
CALL PRTSN(QP1,I,ISUBSC(1,INUM),2)
I=21
CALL PRTSN(QP1,I,ISUBSC(1,INUM),1)
C TEST IF DENOM EXISTS
IF (IDEN) 12,12,13
C DENOM
13 I=40
CALL PRTSN(QP1,I,ISUBSC(1,IDEN),2)
WRITE (NOUT,14)(QP1(I),I=2,58),DF(INUM),DF(IDEN),SS(INUM),SIGDIG(
1INUM),SMS(INUM),FRAT(INUM)
14 FORMAT (1H ,57A1,2F8.0,E19.8,1X,F3.0,E17.8,E18.8)
GO TO 16
C NO DENOM
12 WRITE (NOUT,15)(QP1(I),I=2,39),DF(INUM),SS(INUM),SIGDIG(INUM),SMS(
1INUM)
15 FORMAT (1H ,38A1,19X,F8.0,8X,E19.8,1X,F3.0,E17.8)
16 RETURN
END