Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd08v.for
There is 1 other file named bmd08v.for in the archive. Click here to see a list.
CID                     BMD08V
C             ANALYSIS OF VARIANCE                   MARCH  1, 1966
C        THIS IS A SIFTED VERSION OF BMD08V ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
C
C	*** NOTE - APRIL 1976 ***
C	THIS CHANGE CONTAINS SERVERAL UPDATES OBTAINED FROM UCLA
C	UPDATE-MAILING .
C	JULY 1969	ADDITION OF 28 LINES BETWEEN 2170 AND 2180
C			NEW LINE NO. 2171-2188  OLD LINE 2180 IS NOW
C			2188.
C
C	JAN 1970	ADDITION OF LINE 8195.
C
C	MAY 4 1970	MODIFICATION OF SUBROUTINE TAIL
C			ADDITION OF 2 PARAMETERS IN CALLING SEQUENCE
C			PARAMETERS ARE "A , G".
C			ADDITION OF 15 LINES (7936-7942, 7944-7952)
C
C	FEB 19 1970	TO CORRECT AN NON-INTEGER SUBSCRIPT COMPILE
C			ERROR.
C			TO SOLVE PROBLEM - ADD MORE CODES (WHAT ELSE)
C
C	REASON FOR ABOUT UPDATES -- NOT AVAILABLE.
C
C	*** END OF NOTE -- BOB HUNG. ***
C
C
      COMMON/ANARG/FF(180),NI,NCM,KM,MT,NV,ILL
      COMMON /MNTOER/P1,P2,A,B,ID,G,S
      DIMENSION LD(100),LQ(100)
      DIMENSION FIN(11),FOP(11),IN(11),ROF(11),AA(11),P(100),PL(11),A(99
     1),B(98),C(100),D(100),E(100),G(100),P1(100),P2(100),MN(100),IL(100
     2),ID(100),S(15000),J1(10),Z2(10)
      DIMENSION Z3(10)
      DATA Z3,ZZ/'0','1','2','3','4','5','6','7','8','9','0'/
        REAL*8 P1,P2
      REAL*8 P3,P4
       REAL*8 PROB,FINI,PF,PC,Q003HL, Q004HL,Q005HL,Q006HL,
     X Q007HL,Q009HL,Q010HL,AP,PA            ,Q008HL
      INTEGER AA,A,B,C,D,E,U,UNION,H,Q012CT,Q013CT,Q014CT
      LOGICAL INCL
      DATA ON/4HNO  /
      DIMENSION EE(10)
      DATA PROB,FINI/6HPROBLM,6HFINISH/
      DATA Q003HL/6HINDEX /
      DATA Q004HL/6HINF   /
      DATA Q005HL/6HDESIGN/
      DATA Q006HL/6H,     /
      DATA Q007HL/6H      /
      DATA Q008HL/6H(     /
      DATA Q009HL/6H)     /
      DATA Q010HL/6HMEAN  /
C
 134  FORMAT('1BMD08V - ANALYSIS OF VARIANCE - ',
     1'REVISED FEBRUARY 19, 1970'/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//14H0PROBLEM CODE A6)
	CALL USAGEB('BMD08V')
      MTP=5
 101  READ (5,100)PF,PC,NV,NI,KM,NF,MT,PCOV
      L=10
      I=1
      DO 500 J=1,10
      AA(L)=I
      I=2*I
  500 L=L-1
      Q012CT=I
      Q013CT=2*I
      Q014CT=4*I
      KLV=-1
      IIIII=1
 100  FORMAT(2A6,5I2,A2)
 7777 IF(PF.EQ.PROB)GO TO 111
  110 IF(PF.EQ.FINI)GO TO 113
 20   IF(KLV)2111,7766,7766
2111  KLV=1
      GO TO (2101,2102,2103,2104),IIIII
 7766 STOP
C
C
  113 IF(MTP.EQ.5)GO TO 117
 116  REWIND MTP
 117  CALL EXIT
 2000 WRITE (6,2001)
 2001 FORMAT(54H0THE NUMBER OF ANALYSIS OF VARIANCE INDICES IS TOO BIG)
 888  KLV=1
      GO TO 7766
 111  IF(KM.LE.100) GO TO 99
      WRITE(6,699)
 699  FORMAT(99H0ERROR ON ASSIGNMENT OF NUMGER OF PIECES OF DATA SPECIFI
     1ED BY THE FORMAT CARD.IT CAN NOT EXCEED 100)
      GO TO 888
 99   IF(NF.LE.9) GO TO 999
      WRITE(6,6999)
 6999 FORMAT(41H0ERROR ON NUMBER OF VARIABLE FORMAT CARDS)
      GO TO 888
 999  NF=18*MAX0(1,NF)
C
      IF((MT-1)*(MT-2)*(MT-6))112,66,112
 66   WRITE(6,666)
 666  FORMAT(25H0ERROR ON TAPE ASSIGNMENT)
      GO TO 888
 3000 WRITE(6,3001)
 3001 FORMAT(62H0NUMBER OF COMPONENTS IN ANALYSIS OF VARIANCE TABLE IS T
     1OO BIG)
      GO TO 888
 4000 WRITE(6,4001)
 4001 FORMAT(74H0VIOLATING THE LIMITATION FOR THE PROBLM,CHECK FOOTNOTE
     1ON PAGE 586 OF BMD      )
      GO TO 888
2101  WRITE(6,2121)
2121  FORMAT(32H0PROBLEM CARD IS OUT OF SEQUENCE)
      GO TO 7766
2102  WRITE(6,2122)
2122  FORMAT(30H0INDEX CARD IS OUT OF SEQUENCE)
      GO TO 7766
2103  WRITE(6,2123)
2123  FORMAT(31H0DESIGN CARD IS OUT OF SEQUENCE)
      GO TO 7766
2104  WRITE(6,2124)
 2124 FORMAT(' WRONG SPECIFICATION ON DESIGN CARD')
      GO TO 7766
 112  KLV=-1
      IF(MT)102,102,103
 102  MT=5
 103  IF(MT-MTP)104,107,104
  104 IF(MTP.EQ.5)GO TO 107
 106  REWIND MTP
 107  MTP=MT
      IF(PCOV.EQ.ON)GO TO 5114
 5013 IF(MT.EQ.5)GO TO 5114
 5116 REWIND MT
 5114 WRITE (6,134)PC
      READ (5,191)AP,(FIN(I),I=1,10),(FOP(I),I=1,10)
      IIIII=2
 191  FORMAT(A6,20F3.0)
      IF(AP-(+Q003HL))20,193,20
 193  N=NI
      IF(NI*(11-NI))2000,2000,2011
 989   FORMAT(36X,10A3)
 2011 DO 135 I=1,NI
      J1(I)=FIN(I)
 991  IN(N)=FIN(I)
      IF(FOP(I))136,136,137
 136  ROF(N)=0.0
 990  Z2(I)=(+Q004HL)
C
      GO TO 135
 137  ROF(N)=FIN(I)/FOP(I)
      Z3(1)=Q007HL
      Z2(I)=Q007HL
      FIP=100.
      DO 710 J=1,3
      NN=AMOD(FOP(I)/FIP,10.)
      CALL PUTCHR(Z2(I),J,Z3(NN+1))
      IF(NN.NE.0) Z3(1)=ZZ
 710  FIP=FIP/10.
 135  N=N-1
      READ (5,179)PA,(P(I),I=1,66)
 179  FORMAT(A6,66A1)
      IIIII=3
      IF(PA-(+Q005HL))20,152,20
 152  L=NI
      IIIII=4
      M=0
      DO 31 I=1,10
      FIN(I)=IN(I)
      K=LWH(P(I))
      GO TO (31,33,20,20,20,20,20,20),K
 33   PL(L)=P(I)
      M=M+1
      EE(M)=P(I)
      L=L-1
 31   CONTINUE
      IF(L)20,32,20
 32   WRITE (6,722) (EE(I),I=1,NI)
      WRITE (6,723)(J1(I),I=1,NI)
      WRITE (6,724)(Z2(I),I=1,NI)
 722  FORMAT(17H0INDEX           10(4X,A1))
 724  FORMAT(17H POPULATION SIZE 10(2X,A3))
 723  FORMAT(17H NUMBER OF LEVELS10I5)
      WRITE (6,93)(P(I),I=1,66)
 93   FORMAT(12H0DESIGN CARD 5X,72A1)
      P(10)=      ','
      CO=1.0
      LB=-1
      RB=-1.0
      N=0
      MO=10
      MI=66
 178  DO 4 I=MO,MI
      K=LWH(P(I))
      GO TO (4,36,37,8,9,10,11,20),K
 37   IF(CO)20,20,12
 12   DO=1.0
      CO=-1.0
      PE=-1.0
      LL=1
      NL=0
      N=N+1
      A(N)=0
      B(N)=0
      GO TO 4
 11   IF(DO)20,20,13
 13   A(N)=Q012CT
      DO=-1.0
      GO TO 4
 9    IF(RB)20,20,14
 14   NL=1
      CO=1.0
      PE=1.0
      RB=-1.0
      GO TO 4
 8    IF(LB)20,20,15
 15   NL=-1
      RB=1.0
      LB=-1
      CO=-1.0
      PE=-1.0
      GO TO 4
 36   IF(LL)20,20,16
 16   DO 17 M=1,NI
      IF(P(I).EQ.PL(M))  GO TO 19
 17   CONTINUE
      GO TO 20
 19   IF(NL)21,22,23
 22   A(N)=A(N)+Q013CT+AA(M)
C
      NL=1
      DO=-1.0
      LB=1
      CO=1.0
      PE=1.0
      GO TO 4
 23   IF(B(N)/Q013CT.EQ.0) B(N)=B(N)+Q013CT
 21   B(N)=B(N)+AA(M)
 4    CONTINUE
      READ (5,130)(P(I),I=1,72)
      MO=1
      MI=72
      WRITE (6,471)(P(I),I=1,72)
 471  FORMAT(18X,72A1)
      GO TO 178
 10   IF(PE)20,20,24
 24   C(1)=Q013CT
      D(1)=0
      MN(1)=1
C	FOLLOWING IS UPDATE JULY 17 1969.
C
	J0 = N									00002171
	DO 9004 K=1,N								00002172
C
C	UPDATE DEC 1975
C	REPLACE LINE 2173 AND  LINE 2185
C
9000	IF (K.GT.J0) GOTO 9005							00002173
C	IF (K.GT. J0) GO TO 9005						00002173
	IF (.NOT. INCL (Q012CT,A(K))) GO TO 9004				00002174
	K1 = K-1								00002175
	KKC = A(K) - Q012CT							00002176
	DO 9001 I=1,K1								00002177
	IF (KKC.EQ.A(1).AND.B(K).EQ.B(I)) GOTO 9002				00002178
9001	CONTINUE								00002179
	GO TO 9004								00002180
9002	J0 = J0-1								00002181
	DO 9003 I=K,J0								00002182
	A(I) = A(I+1)								00002183
9003	B(I) = B(I+1)								00002184
	GO TO 9000								00002185
C	K= K-1									00002185
9004	CONTINUE								00002186
9005	N=J0									00002187
	J=1									00002188
C  	END OF UPDATE JULY 1969
	DO 51 K=1,N
      J0=J
      DO 51 I=1,J0
      IF(.NOT.INCL(B(K),Q014CT-1-C(I))
     X.OR. .NOT.INCL(A(K),Q014CT-1-D(I))) GO TO 51
 52   J=J+1
      IF(J-100)2221,3000,3000
 2221 MN(J)=0
      D(J)=UNION(B(K),D(I))
      C(J)=UNION(A(K),C(I))
      E(J)=MOD(C(J)+D(J),Q012CT)
 51   CONTINUE
      NCM=J
      DO 25 I=1,N
      IF(MOD(A(I)/Q012CT,2).EQ.0) GO TO 25
C
 26   H=MOD(A(I)+B(I),Q012CT)
      DO 27 J=1,NCM
       IF(E(J).EQ.H) GO TO 28
 27   CONTINUE
      GO TO 20
 28   MN(J)=1
 25   CONTINUE
      DO 53 I=1,NCM
      E(1)=0
C
      C(I)=MOD(C(I),Q012CT)
      D(I)=MOD(D(I),Q012CT)
 53   G(I)=1024*(10*NBITS(E(I))+NBITS(C(I)))+C(I)
      DO 86 I=1,NCM
      X=1.E30
      DO 89 K=I,NCM
      IF(X-G(K))89,89,88
 88   J=K
      X=G(K)
 89   CONTINUE
      G(J)=G(I)
      U=C(J)
      C(J)=C(I)
      C(I)=U
      U=D(J)
      D(J)=D(I)
      D(I)=U
      NUU=MN(I)
      MN(I)=MN(J)
      MN(J)=NUU
 86   E(I)=UNION(C(I),D(I))
      DO 122 I=2,NCM
      P1(I)=Q007HL
      P2(I)=Q007HL
      N=0
      L=NI
      DO 123 J=1,NI
      IF(MOD(C(I)/AA(L),2).EQ.0) GO TO 123
 124  N=N+1
      IF(N.LE.6) CALL PUTCHR(P1(I),N,PL(L))
      IF(N.GT.6) CALL PUTCHR(P2(I),N-6,PL(L))
 123  L=L-1
C
      IF(D(I)) 125,122,125
 125  N=N+1
      IF(N.LE.6) CALL PUTCHR(P1(I),N,Q008HL)
      IF(N.GT.6) CALL PUTCHR(P2(I),N-6,Q008HL)
      L=NI
      DO 126 J=1,NI
      IF(MOD(D(I)/AA(L),2).EQ.0) GO TO 126
 127  N=N+1
      IF(N.LE.6) CALL PUTCHR(P1(I),N,PL(L))
      IF(N.GT.6) CALL PUTCHR(P2(I),N-6,PL(L))
 126  L=L-1
      N=N+1
      IF(N.LE.6) CALL PUTCHR(P1(I),N,Q009HL)
      IF(N.GT.6) CALL PUTCHR(P2(I),N-6,Q009HL)
 130  FORMAT(72A1)
 122  CONTINUE
      P1(1)=(+Q010HL)
      P2(1)=(+Q007HL)
 121  FORMAT(12A6)
       DO 602 I=2,NCM
       IF(MN(I))602,602,603
C
C
  603 DO 601 J=1,I
      IF(INCL(E(J) ,E(I))) MN(J)=1
 601   CONTINUE
 602   CONTINUE
       M1=0
  921 FORMAT(20A4)
       READ(5,921)(FF (I),I=1,NF)
      WRITE (6,5432)(FF(I),I=1,NF)
 5432 FORMAT(21H0VARIABLE FORMAT          20A4/(21X,20A4))
      M2P2=M1
       M1P1=M1+1
      CALL SS(NCM,NI,S(M1P1),E,LQ,PL,AA)
      M1P1=M1P1+LQ(NCM+1)+1
      DO 90 I=M1P1,15000
 90   S(I)=0.0
      ILL=15000-M1P1
      CALL ANOVA(AA,MN,E,IN,IL,S(M1P1),ID)
      IF(ILL)4000,4000,2888
 2888 NVV=NV
      NN=NVV*NCM
  874 DO 731 I=1,NV
C
C
      K=M1P1+I-1
  529 WRITE(6,141)I
 141  FORMAT(44H1ANALYSIS OF VARIANCE FOR DEPENDENT VARIABLEI3/11H0    S
     *OURCE,5X,'ERROR TERM',6X,'F    SUM OF SQUARES DEG. OF MEAN SQUARE
     *  EXPECTED MEAN SQUARE'/52X,'FREEDOM'/)
      REWIND 1
      REWIND 2
      A(1)=15001-ILL
      DO 144 J=1,NCM
      SM=S(K)/FLOAT(ID(J))
      L=1
      DO 3 N=1,NCM
      IF(.NOT.INCL(E(J),E(N))) GO TO 3
      FF(L)=1.
      DO 40 M=1,NI
      IF(MOD(UNION(D(N),E(J))/AA(M),2).EQ.1) GO TO 40
      NN=MOD(C(N)/AA(M),2)
      IF(NN.EQ.1) FF(L)=FF(L)*(1.-ROF(M))
      IF(NN.EQ.0) FF(L)=FF(L)*FIN(M)
 40   CONTINUE
      LD(L)=N
      IF(FF(L).NE.0.) L=L+1
 3    CONTINUE
      LL=L-1
      A(J+1)=A(J)+2*LL
      IF(A(J+1)-15001)8000,8000,8002
 8000 DO 8001 N=1,LL
      M=A(J)+2*N-1
      S(M-1)=FF(N)
 8001 S(M)=LD(N)
      B(J)=LD(2)
 8002 WRITE(1     )S(K),SM,( FF(L),LD(L),L=1,LL)
 8003 FORMAT(20A4)
      G(J)=SM
 8004 FORMAT(2A6,2A4)
  144 K=K+NVV
      END FILE 1
      REWIND 1
C
C
      IF(A(NCM+1)-15001)8005,8005,8006
 8005 CALL ERRTRM(I,NI,NV,NCM,M1P1)
      GO TO 8065
 8006 DO 8055 J=1,NCM
 8055 WRITE(2,8004)(Q007HL,LL=1,4)
 8065 END FILE 2
      REWIND 2
      DO 8007 J=1,NCM
      LL=(A(J+1)-A(J))/2
C
      READ(1     )SK,SM,(FF(L),LD(L),L=1,LL)
      READ(2,8004)P3,P4,F1,F2
 8007 WRITE(6,8008)J,P1(J),P2(J),P3,P4,F1,F2,SK,ID(J),SM,(FF(L),LD(L),L=
     *1,LL)
 8008 FORMAT(I3,1X,4A6,   2A4,3X,G12.7,I6,3X,G12.7,5(F8.3,'(',I2,')')/
     *( 72X,5(F8.3,'(',I2,')')/))
C
C	FOLLOWING IS PART OF MAY 1970 UPDATE (DELETE LINE 4027-4030)
C
C      L=IL(1)+ M1P1+I-1
C      WRITE(6,400)S(L)
C 400  FORMAT(5H-MEANF14.5/11H0CELL MEANS)
C
C	SUBROUTINE TAIL WILL NOW HAVE 2 MORE ARGUMENTS
C
	CALL TAIL (A,G,MN,IL,I,M1P1,E,AA,PL,IN,S,LQ,ID,M2P2)			00007920
C
C      CALL TAIL(MN,IL,I,M1P1,E,AA,PL,IN,S,LQ,ID,M2P2)
 731   CONTINUE
      GO TO 101
       END
C             SUBROUTINE ANOVA FOR BMD08V            MARCH  1, 1966
      SUBROUTINE ANOVA(AJ,MN,CW,IN,IL,S,ID)
      COMMON/ANARG/FF(180),NI,NCW,MK,MT,NV,ILL
      DIMENSION AJ(2),MN(2),CW(2),IN(2),IL(2),S(2),ID(2),ST(100),
     1IC(11,100),II(11),IJ(11,100),X(255),FP(100),SF(100),SG(100)
      DIMENSION IW(100)
      LOGICAL INCL
      INTEGER CW,AJ ,QCT
      QCT=2**10
       IF(MT)500,500,501
  500 DO 50 I=1,NCW
   50 IW(I)=CW(I)
      DO 403 I=2,NCW
      AJ(NI1)=QCT
      IW(I)=IW(I)+QCT
       J1=I-1
      DO 404 J=1,I
      FP(J)=-1.
  404 IF(INCL(IW(J),IW(I)))FP(J)=1.
 410  DO 600 J=1,J1
      IF(FP(J).NE.1.) GO TO 600
      M=IL(I)-MT
      L=IL(J)-MT
      S(M)=S(M)-S(L)
 600  CONTINUE
       II(NI1)=-2
       DO 408 K=1,NI1
      KK=K
      IF(MOD(IW(I)/AJ(K),2).EQ.0)GO TO 408
C
 402   II(K)=II(K)+1
       IF(II(K))401,400,400
 400   II(K)=-IN(K)
 408   CONTINUE
 401   DO 407 J=1,I
  407 IF(FP(J).EQ.1.0)IL(J)=IL(J)+IJ(KK,J)
      IF(NI1-KK)410,403,410
 403   CONTINUE
       RETURN
 501   KM=MK
      DO 228 I=1,100
 228  ST(I)=0.0
      NVV=NV
      NN=1
      DO 51 I=1,NI
 51   NN=NN*IN(I)
      NI1=NI+1
      DO 10 J=1,NCW
      ID(J)=1
      IL(J)=1
      IO=1
      DO 12 I=1,NI
      IF(MOD(CW(J)/AJ(I),2).EQ.0) GO TO 13
C
 52   IC(I,J)=1
      ID(J)=ID(J)*IN(I)
      GO TO 12
 13   IO=I
      IC(I,J)=0
 12   CONTINUE
      IF(MN(J))11,11,107
 11   DO 14 K=IO,NI
 14   IC(K,J)=-IC(K,J)
 107  FP(J)=NN/ID(J)
 10   IC(NI1,J)=-1
      IN(NI1)=2
      DO 7 I=1,NI1
      DO 15 J=1,NCW
      IF(IC(I,J)-1)16,17,16
 17   IJ(I,J)=NV
      IL(J)=IL(J)*IN(I)
      GO TO 15
 16   IJ(I,J)=(1-IL(J))*NV
 15   CONTINUE
 7    II(I)=-IN(I)
      N=(NVV*NCW)/NV+1
       DO 118 J=1,NCW
       IF(MN(J))118,118,110
 110   N=N+IL(J)
       IL(J)=(N-IL(J))*NV
 118   CONTINUE
       MK=N+1
       DO 119 J=1,NCW
       IF(MN(J))111,111,119
 111   N=N+IL(J)
       IL(J)=(N-IL(J))*NV
 119   CONTINUE
      KU=KM
      FQ=0.0
      NTNV=N*NV
      IF(N*NV-ILL)19,2000,2000
 2000  ILL=0
       RETURN
 19   DO 23 M=1,NV
      KU=KU+1
      IF(KU-KM)22,22,21
 21   READ (MT,FF)(X(K),K=1,KM)
      KU=1
 22   XK=X(KU)
      ST(M)=ST(M)+XK
      DO 23 J=1,NCW
      N=IL(J)+M
 23   S(N)=S(N)+XK
      FQ=FQ+1.0
      DO 20 I=1,NI1
      II(I)=II(I)+1
      IF(II(I))24,20,20
 20   II(I)=-IN(I)
 24   DO 25 J=2,NCW
      IL(J)=IL(J)+IJ(I,J)
      IF(IC(I,J))26,25,25
 26   N=IL(J)
      DO 222 K=1,NV
 222  SG(K)=0.0
      LL=-IJ(I,J)/NV+1
      K0=(J-1)*NVV
      GR=FP(J)/FQ
      DO 27 L=1,LL
      M=K0
      DO 27 K=1,NV
      N=N+1
      SF(K)=S(N)-GR*ST(K)
      SG(K)=SG(K)+SF(K)
      M=M+1
      S(M)=S(M)+SF(K)*SF(K)
      IF(I-NI1)60,27,60
 60   S(N)=0.0
 27   CONTINUE
      GR=FQ/FP(J)-FLOAT(LL)
      IF(GR)25,25,372
 372  M=K0
      DO 327 K=1,NV
      M=M+1
 327  S(M)=S(M)+SG(K)*SG(K)/GR
 25   CONTINUE
      IF(I-NI1)19,30,19
 30   K1=0
      K=0
      L0=IL(1)+1
      L1=IL(1)+NV
      DO 373 L=L0,L1
      K=K+1
 373  S(K)=S(L)*S(L)
      DO 31 J=1,NCW
      NM=NV-IJ(NI1,J)
      MN(J)=MN(J)*NM
      F=(NN*NV)/NM
      K2=IL(J)+1
      K3=IL(J)+NM
      DO 70 K=K2,K3
 70   S(K)=S(K)/F
      F=NN/ID(J)
      K0=K1+1
      K1=K1+NVV
      DO 31 K=K0,K1
 31   S(K)=S(K)/F
      L1=NVV
      DO 32 J=2,NCW
      J1=J-1
      L0=L1+1
      L1=L1+NVV
      DO 32 K=1,J1
      IF(.NOT.INCL(CW(K),CW(J))) GO TO 32
C
 33   IF(K-1)62,62,61
 61   M=(K-1)*NVV
      DO 34 L=L0,L1
      M=M+1
 34   S(L)=S(L)-S(M)
 62   ID(J)=ID(J)-ID(K)
 32   CONTINUE
      ILL=ILL-NTNV
      RETURN
      END
C   FUNCTION LWH FOR BMD08V   MAY 14,  1968
      FUNCTION LWH(P)
      DIMENSION A(17)
      DATA A/' ',' ',',','(',')','.','$','=','+','-','*','/',1H',
     *'=','+','(',')'/
      DO 1 I=1,17
      IF(P.EQ.A(I)) GO TO 2
 1    CONTINUE
      LWH=2
      RETURN
    2 IF(I.GE.16)I=I-12
      LWH=MIN0(8,I)
      RETURN
      END
C             SUBROUTINE PMEANS FOR BMD08V           MARCH  1, 1966
      SUBROUTINE PMEANS(E,A,PL,IN,S,NI,NV)
      DIMENSION A(2),PL(2),S(2),LL(11),P(11),JO(11),IN(2)
      INTEGER A,E
 40   M=NI+1
      DO 1 I=1,NI
      IF(MOD(E/A(I),2).EQ.0) GO TO 1
C
 2    M=M-1
      P(M)=PL(I)
      JO(M)=IN(I)
 1    CONTINUE
      NJ=NI-2
      N=NI-M+1
      JO1=JO(NI)
      JO2=JO(NI-1)
      L1=1-NV
      IF(N-2)3,88,5
 88   WRITE (6,127)P(NI),(I,I=1,JO1)
      GO TO 89
 5    DO 6 I=M,NI
 6    LL(I)=1
 11   WRITE (6,7)(P(K),LL(K),K=M,NJ)
 7    FORMAT(1H08(4X,A1,2H =I3))
      GO TO 8
 9    I=NJ
      DO 10 J=3,N
      LL(I)=LL(I)+1
      IF(LL(I)-JO(I))11,11,12
 12   LL(I)=1
 10   I=I-1
      RETURN
 8    WRITE (6,27)P(NI),(I,I=1,JO1)
 27   FORMAT(   5X,A1,2H =I7,9I12, /(3X,10I12))
 89   I=1
      L0=L1+NV
      L1=L1+JO1*NV
      WRITE (6,24)P(NI-1),I,(S(L),L=L0,L1,NV)
 24   FORMAT(1X,A1,2H =I3,10F12.5, /(7X,10F12.5))
      DO 29 I=2,JO2
      L0=L1+NV
      L1=L1+JO1*NV
 29   WRITE (6,25)I,(S(L),L=L0,L1,NV)
 25   FORMAT(4X,I3,10F12.5, /(7X,10F12.5))
      IF(N-2)37,37,9
 3    L0=L1+NV
      L1=L1+NV*JO1
      WRITE (6,127)P(NI),(I,I=1,JO1)
 127  FORMAT(1H04X,A1,2H =I7,9I12, /(3X,10I12))
      WRITE (6,35)(S(L),L=L0,L1,NV)
 35   FORMAT(7X,10F12.5)
 37   RETURN
      END
C             SUBROUTINE SS FOR BMD08V               MARCH  1, 1966
      SUBROUTINE SS(NCM,NI,S,E,LQ,P,AA)
      DATA XP,XM,XB,BL,Q001HL/'+ X(','- X(','  X(','    ','.'/
      DATA RP/')'/
      DIMENSION S(2),E(2),LQ(2),P(2),AA(2)
      LOGICAL INCL
      INTEGER AA,E
      L=0
      DO 1 I=1,NCM
      DO 2 J=1,I
      L=L+1
 2    S(L)=0.0
 1    S(L)=1.0
      LL=L
      L0=1
      I1=1
      DO 3 I=2,NCM
      DO 4 J=1,I1
      IF(.NOT.INCL(E(J),E(I))) GO TO 4
C
 6    K0=(J*(J-1))/2+1
      L=L0
      K1=K0+J-1
       DO 7 K=K0,K1
       L=L+1
 7    S(L)=S(L)-S(K)
 4    CONTINUE
       L0=L0+I
 3    I1=I
      L=LL
      LLL=LL+NCM*NI+1
      MM=LLL
      DO 18 I=1,NCM
      N=NI
      LQ(I)=LLL-MM
      DO 8 J=1,NI
      L=L+1
      S(L)=(+Q001HL)
      IF(MOD(E(I)/AA(N),2).EQ.1) S(L)=P(N)
C
 8    N=N-1
      XPB=XB
      K0=L+1
      K=(I*(I+1))/2
      DO 10 J=1,I
C
      K0=K0-NI
      IF(S(K))11,10,13
 13   S(LLL+1)=XPB
      XPB=XP
      GO TO 14
 11   S(LLL+1)=XM
 14   S(LLL+2)=BL
      S(LLL+3)=BL
      S(LLL+4)=BL
      NK=K0
      DO 12 N=1,NI
      CALL PUTCHR(S(LLL+2),N,S(NK))
 12   NK=NK+1
      CALL PUTCHR(S(LLL+2),NI+1,RP)
      LLL=LLL+4
 10   K=K-1
 18   CONTINUE
      L=0
      K0=MM+1
      DO 19 K=K0,LLL
      L=L+1
 19   S(L)=S(K)
      LQ(NCM+1)=LLL-MM
      RETURN
      END
      FUNCTION NBITS(II)
      K=II
      NBITS=0
      DO 1 I=1,10
      IF(MOD(K,2).EQ.1) NBITS=NBITS+1
 1    K=K/2
      RETURN
      END
      INTEGER FUNCTION UNION(II,JJ)
      UNION=0
      L=1
      DO 1 I=1,12
      IF(MOD(II/L,2).NE.0 .OR. MOD(JJ/L,2).NE.0) UNION=UNION+L
 1    L=L*2
      RETURN
      END
      LOGICAL FUNCTION INCL(II,JJ)
      INCL=.FALSE.
      L=1
      DO 1 I=1,12
      IF(MOD(II/L,2).EQ.0) GO TO 1
      IF(MOD(JJ/L,2).EQ.0) RETURN
 1    L=L*2
      INCL=.TRUE.
      RETURN
      END
C
C	MODIFICATION MAY 1970
C
      SUBROUTINE TAIL(A,C,MN,IL,I,M1P1,E,AA,PL,IN,S,LQ,ID,M2P2)			00007920
	DIMENSION A(1), C(1)							00007921
	INTEGER A, E, AA							00007922
C      SUBROUTINE TAIL(MN,IL,I,M1P1,E,AA,PL,IN,S,LQ,ID,M2P2)
      DIMENSION MN(1),IL(1),E(1),AA(1),PL(1),IN(1),S(1),LQ(1),ID(1)
      COMMON /ANARG/FF(180),NI,NCM,KM,MT,NV,ILL
C      INTEGER E,AA
	DO 320 JJ=1,NCN								00007936
	J=NCM+1-JJ								00007937
	K1=A(J)+2								00007938
	K2=A(J+1)-2								00007939
	IF (K1.GT.K2) GO TO 320							00007940
	DO 330 K=K1,K2,2							00007941
C
C	UPDATE FEB 19 1971
C
	ISK1=S(K+1)								00007942
330	C(J)=C(J)-S(K)*C(ISK1)							00007943
C330	C(J)=C(J)-S(K)*C(S(K+1))						00007942
320	C(J)=C(J)/S(K1-2)							00007944
	WRITE(6,360) (J,C(J),J=1,NCM)						00007945
360   FORMAT('0ESTIMATES OF VARIANCE COMPONENTS'//(' (',I2,')',
     1G15.7))									00007946
	L=IL(1)+M1P1+I-1							00007947
	WRITE(6,400) S(L)							00007948
400	FORMAT('-MEAN',F14.5/'0CELL MEANS')					00007949
	DO 401 J=2,NCM								00007950
	IF (MN(J)) 402,401,402							00007952
C      DO 401 J=2,NCM
C      IF(MN(J))402,401,402
C
C	END OF UPDATE MAY 1970
C
  402 L1=IL(J)+I+M1P1-1
      CALL PMEANS(E(J),AA,PL,IN,S(L1),NI,NV)
  401 CONTINUE
      JYP=1
      DO 731 J=2,NCM
      IF(MN(J))732,731,732
  732 L1=IL(J)+I+M1P1-1
      L8=LQ(J)+1+M2P2
      L9=LQ(J+1)+M2P2
      IF(JYP)421,421,420
  420 JYP=0
      MT=-I
      CALL ANOVA(AA,MN,E,IN,IL,S(M1P1),ID)
      WRITE(6,422)
  422 FORMAT(' CELL DEVIATIONS')
  421 WRITE(6,733)(S(L),L=L8,L9)
  733 FORMAT(1H0 3X,24A4/ (4X,24A4))
      CALL PMEANS(E(J),AA,PL,IN,S(L1),NI,NV)
  731 CONTINUE
      RETURN
      END
      SUBROUTINE ERRTRM(II,NI,NV,NCM,M1P1)
      DIMENSION ID(100), G(100),S(15000)
      REAL*8 P1(100),P2(100)
      COMMON /MNTOER/P1,P2,A,B,ID,G,S
      INTEGER A(99),B(98)
      DATA BLNK4/'    '/
      DO 50 I=1,NCM
      IF(A(I+1)-A(I)-2)40,40,10
   10 JST=A(I)+2
      JND=A(I+1)-1
C
C	UPDATE LINE 8125,8130,8155,8160 HAS ALREADY BEEN TAKEN CARE
C	OF BY DECLARING INTEGER B.
C
      JB=A(B(I))-JST
      DO 30 J=JST,JND
      IF(S(J)-S(J+JB))40,30,40
   30 CONTINUE
      IB=B(I)
      LNG=M1P1+NV*( IB -1)+II-1
      FF=G(I)/S(LNG)*FLOAT(ID(IB))
C
C	UPDATE JAN 1970
C
	IF (FF.LT.0.0) FF=0.0							00008195
      WRITE(2,35)P1(IB),P2(IB),FF
   35 FORMAT(2A6,F8.3)
      GO TO 50
   40 WRITE(2,45)(BLNK4,LL=1,4)
   45 FORMAT(2A6,2A4)
   50 CONTINUE
      RETURN
      END