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

