Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd07m.for
There is 1 other file named bmd07m.for in the archive. Click here to see a list.
CBMD07M   STEPWISE DISCRIMINANT ANALYSIS         SEPTEMBER  1, 1965
C
C	TECO IN 81 FOR ALL OCCURANCES OF 81
C
C
C
      DIMENSION DF(81,81),XM(81,81),W(81,81),T(81,81),GZ(91,55),IC(81),L
     1Q(20),MQ(81),FT(288),F(81),V(81),U(81),P(81),X(81),NPG(81),C(255),
     2DODE(162),LIST(81),CHAR(81,2),CLIST(81,2)
      DIMENSION AU(81)
      DIMENSION FFV(4),FFV1(8),FFG(8),FTT(18)
      COMMON/XX12/ ISTEP,STRAT
      LOGICAL STRAT
      COMMON  W
      COMMON  Q000CM (   81)
      COMMON  DF
      COMMON  Q001CM ( 6561)
      COMMON  IC     , LQ     , NV     , NG     , NQ     , F
      COMMON  L      , K      , FADD   , FDEL   , FT     , NG1
      COMMON  U      , P      , X      , NPG    , N      , NST
      COMMON  FL     , NS     , V      , TOL    , MQ     , MORE
      COMMON  C      , YOS    , YES    , IT1    , IT2    , NV1
      COMMON  DODE   , LIST   , CHAR   , CLIST  , NGU
      EQUIVALENCE (W(82),T),(GZ,DF),(DF(6562),XM)
      DIMENSION ALF(81,1)
      EQUIVALENCE (DF(42,41),ALF)
C     EXTERNAL SIGN
  200 FORMAT('1BMD07M - STEPWISE DISCRIMINANT ANALYSIS - REVISED ',
     1'MAY 16, 1969'/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//
     320H0PROBLEM CODE                      A6/
     420H0NUMBER OF VARIABLES               I6/
     520H0NUMBER OF GROUPS                  I6/
     630H0NUMBER OF CASES IN EACH GROUP16I6/(30X,16I6))
      REAL*8 ALPHA, PR, FN, GR, GL, SP, CND, Z, ZZ, PC, COVAR
      DATA ALPHA/'ALPHA  '/
      DATA FFV/'(9H  VARI ABLE )    '
     1 /,FFV1/'(1H0 ,10X ,8HV ARIA BLE/ (1X, 9I14 ))  '
     1 /,FFG/'(1H0 ,11X ,5HG ROUP /(4X ,9(8 X,2A 3))) '/,Q002HL/'NO  '/,
     2Q005HL/'YES '/
      IT1=1
      IT2=2
      DATA PR/'PROBLM  '/,FN/'FINISH  '/,GR/'SAMSIZ  '/,GL/'GPLABL  '/
     1,SP/'SUBPRO  '/,CND/'CONDEL  '/,COVAR/'COVAR '/
	CALL USAGEB('BMD07M')
      ON=(+Q002HL)
      YES=(+Q005HL)
      MT=5
	CALL DEVCHG('DSK',2)
	CALL DEFINE(2,255,NOUSE,'FOR02.DAT',0,0)
	CALL DEFINE(1,255,NOUSE,'FOR01.DAT',0,0)
 20   MTP=MT
      FL=0.0
      REWIND IT1
      REWIND IT2
      READ (5,1)Z,PC,NV,NG,NSP,NF,MT,NGPP,EAN,STD,COV,COR,AUA ,IUA,ONO
     2,NUA,ISTEP,STRA
 1    FORMAT(2A6,6I2,5A3,I1,A2,2I1,A3)
      STRAT=.FALSE.
      IF(STRA.EQ.YES) STRAT=.TRUE.
      DO 85 I=1,81
 85   AU(I)=1.0
      IF(Z.EQ.PR) GO TO 101
  131 IF(Z.EQ.FN) GO TO 132
 530  WRITE (6,531)
 531  FORMAT(10H0PROBLM OR)
      ZZ=FN
  500  WRITE (6,501) ZZ,Z
  501 FORMAT(1H0A6,1X,58HCARD EXPECTED, THE FIRST SIX COLUMNS OF THE CAR
     1D READ WERE,2A6)
      GO TO 110
 132  WRITE (6,133)
 133  FORMAT(40H0FINISH CARD ENCOUNTERED, JOB TERMINATED)
      GO TO 110
  101 IF(NV*(81-NV))100,100,230
 230  IF(NG*(81-NG))165,165,231
 231  IF(NF*(15-NF))163,1017,1017
 1017 IF(AUA.NE.YES) GO TO 82
 83   READ (5,84) Z ,(AU(I),I=1,NG)
   84 FORMAT(A6,11F6.5/(6X,11F6.5))
      ZZ=COVAR
      IF (Z.NE.COVAR) GO TO 500
 82   READ (5,2)Z,(NPG(I),I=1,NG)
    2 FORMAT(A6,11I6/(6X,11I6))
      GO TO 232
  100 WRITE (6,571) NV
  571 FORMAT (1H ,I6,1X,20HVARIABLES IS ILLEGAL  /)
      WRITE (6,572)
  572 FORMAT (1H ,10X,14HJOB TERMINATED   )
      GO TO 110
  165 WRITE (6,573) NG
  573 FORMAT (1H ,I6,1X,17HGROUPS IS ILLEGAL  /)
      WRITE (6,572)
      GO TO 110
  163 WRITE (6,164)
  164 FORMAT (1H 23X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECI
     2FIED,ASSUMED TO BE 1.  )
      NF=1
 232  ZZ=GR
      IF(Z.NE.GR) GO TO 500
  102 NF=MAX0(NF,1)*18
      WRITE (6,200)PC,NV,NG,(NPG(I),I=1,NG)
      READ (5,550) Z,(CHAR(I,1),CHAR(I,2),I=1,NG)
  550 FORMAT(A6,22A3/(6X,22A3))
      ZZ=GL
      IF(Z.NE.GL) GO TO 500
      NG11=NG-1
      DO 559 I=1,NG11
      DO 559 J=1,I
 559  ALF(I,J)=1.
      IF(ISTEP.EQ.2) READ (5,558)Z,((ALF(I,J),J=1,I),I=1,NG11)
 558  FORMAT(A6,18F4.4/(6X,18F4.4))
      ZZ=ALPHA
      IF(ISTEP.EQ.2 .AND. Z.NE.ALPHA) GO TO 500
 551  READ (5,3)(FT(I),I=1,NF)
      IF(IUA)123,123,124
 124  READ (5,3) (FTT(I),I=1,18)
    3 FORMAT(18A5)
 123  DO 5 I=1,81
      DO 4 J=1,81
      W(I,J)=0.0
 4    T(I,J)=0.0
      V(I)=0.0
 5    U(I)=0.0
      L=0
      IF(MT)12,12,13
 12   MT=5
 13   HH=0.0
      NGU=0
      IF((MT-IT1)*(MT-IT2)*(MT-6))104,105,104
 105  WRITE (6,106)MT
 106  FORMAT(5H0TAPEI4,43H MAY NOT BE USED AS AN ALTERNATE INPUT TAPE)
  110 IF(MTP.EQ.5) GO TO 112
      REWIND MTP
  112 STOP
 104  IF(MT-5)114,115,114
 114  IF(ONO-ON) 121,115,121
 121  REWIND MT
 115  IF(MT-MTP)116,119,116
  116 IF(MTP.EQ.5) GO TO 119
      REWIND MTP
 119  KL=0
      WRITE (6,201)(FT(I),I=1,NF)
  201 FORMAT(21H0VARIABLE FORMAT     5X,18A5/(26X,18A5))
      IF (IUA) 208,208,209
  208 IF(MT-5)202,203,202
 203  WRITE (6,204)
 204  FORMAT(22H0DATA INPUT FROM CARDS)
      GO TO 205
  209 WRITE (6,2965) (FTT(I),I=1,18)
 2965 FORMAT (' VARIABLE FORMAT FOR ALTERNATE OUTPUT IS '/(5X,18A5))
      GO TO 208
 202  WRITE (6,207)MT
 2051 FORMAT('0STEPPING CRITERION IS AVERAGE OVER DISTINCT PAIRS OF GROU
     *PS OF 1/(1+D(I,J)**2/4)')
 2053 FORMAT('0STEPPING CRITERION IS AVERAGE OVER DISTINCT PAIRS OF GROU
     *PS OF ALPHA(I,J)/(1+D(I,J)**2/4)')
 207  FORMAT(29H0DATA INPUT FROM LOGICAL TAPEI3)
 205  IF(ISTEP.EQ.1) WRITE (6,2051)
      IF(ISTEP.EQ.2) WRITE (6,2053)
      IF(ISTEP.EQ.2) ISTEP=1
      IF(ISTEP.EQ.3) WRITE (6,2052)
 2052 FORMAT('0STEPPING CRITERION IS MAXIMUM MINIMUM F'/22X,'   VAR.   P
     *AIRS'/22X,'          OF GPS')
      DO 6 I=1,NG
      N=IABS(NPG(I))
      F(I)=(N+NPG(I))/2
      IF(F(I)) 260,260,80
 80   NGU=NGU+1
 260  DO 8 J=1,N
      H=J
      HHH=0.
      IF(H.NE.1.) HHH=H/(H-1.0)
      READ (MT,FT)(X(K),K=1,NV)
      DO 8 K=1,NV
      KL=KL+1
      IF(KL-255) 25,25,24
   24 WRITE (IT2) C
      KL=1
 25   C(KL)=X(K)
      U(K)=U(K)+X(K)
      P(K)=X(K)-U(K)/H
      Q=P(K)*HHH
 251  DO 250 M=1,K
 250  T(M,K)=T(M,K)+P(M)*Q
 8    CONTINUE
      H1=H-1.0
      DO 253 K=1,NV
      DF(K,I)=SQRT(T(K,K)/H1)
      XM(K,I)=U(K)/H
      TEMP=U(K)
      U(K)=0.0
      IF(NPG(I))254,254,252
 252  V(K)=V(K)+TEMP
      DO 9 M=1,K
 9    W(K,M)=W(K,M)+T(M,K)*AU(I)
 254  DO 253 M=1,K
 253  T(M,K)=0.0
 6    HH=HH+F(I)
      WRITE (IT2) C
      NG1=NG+1
      N=HH
      D=HH-FLOAT(NGU)
      QG=N-1
      NV1=NV+1
      DO 850 I=1,NV
      U(I)=V(I)/HH
      XM(I,NG1)=U(I)
      V(I)=W(I,I)
      DO 10 J=1,I
      Q=W(I,J)
      DO 11 K=1,NG
 11   Q=Q+(XM(I,K)-U(I))*(XM(J,K)-U(J))*F(K)
 851  W(I,J)=W(I,J)/D
      C(I)=SQRT(ABS(Q/QG))
 10    T(J,I)=Q/D
 850  X(I)=SQRT(W(I,I))
 880  WRITE (IT2) ((ALF(I,J),I=1,NG11),J=1,I),((W(I,J),J=1,NV1)
     *,(XM(I,J),J=1,NG1),I=1,NV)
 879  ENDFILE IT2
      REWIND IT2
      IF(EAN.NE.YES) GO TO 800
 801  WRITE (6,802)
 802  FORMAT(87H0MEANS  (THE LAST COLUMN CONTAINS THE GRAND MEANS OVER T
     1HE GROUPS USED IN THE ANALYSIS))
      DATA Q009HL/'    '/
      CHAR(NG1,1)=(+Q009HL)
      CHAR(NG1,2)=(+Q009HL)
      CALL PRM(XM,NV,NG1,1,FFV,FFG,CHAR)
  800 IF(STD.NE.YES) GO TO 804
 703  WRITE (6,805)
 805  FORMAT(20H0STANDARD DEVIATIONS)
      CALL PRM(DF,NV,NG,1,FFV,FFG,CHAR)
  804 IF(COV.NE.YES) GO TO 806
 807  WRITE (6,809)
 809  FORMAT(32H0WITHIN GROUPS COVARIANCE MATRIX)
      CALL PRM(W,NV,NV,0,FFV,FFV1,CHAR)
  806 IF(COR.NE.YES) GO TO 812
 813  DO 810 I=1,NV
      DO 810 J=1,I
      IF (X(I)*X(J).EQ.0.0) DF(I,J)=0.0
      IF (X(I)*X(J).EQ.0.0) GO TO 810
      DF(I,J)=W(I,J)/(X(I)*X(J))
  810 CONTINUE
      WRITE (6,811)
 811  FORMAT(33H0WITHIN GROUPS CORRELATION MATRIX)
      CALL PRM(DF,NV,NV,0,FFV,FFV1,CHAR)
 812  DO 18 NN=1,NSP
      READ (5,15)Z,NST,FADD,FDEL,TOL,CD,YOS,(LQ(I),I=1,19)
 15   FORMAT(A6,I4,3F6.6,2A3,19I2)
      L=0
      DO 295 I=1,NG
      IF(NPG(I))295,295,261
 261  L=L+1
      LIST(L)=I
      CLIST(L,1)=CHAR(I,1)
      CLIST(L,2)=CHAR(I,2)
 295  CONTINUE
      NGU=L
      IF (TOL.EQ.0.0) TOL=.0001
      IF (FADD.EQ.0.0) FADD=.01
      IF (FDEL.EQ.0.0) FDEL=.005
      ZZ=SP
      IF(Z.NE.SP) GO TO 500
 130  IF(NST)34,34,35
 34   NST=2*NV
   35 IF(CD.EQ.YES) GO TO 31
 30   DO 32 I=1,NV
 32   IC(I)=1
      GO TO 33
 31   READ (5,14)Z,(IC(I),I=1,NV)
   14 FORMAT(A6,66I1/(6X,66I1))
      ZZ=CND
      IF(Z.NE.CND) GO TO 500
 33   DO 16 I=1,19
      IF(LQ(I))17,17,1675
 1675 LQ(I)=LQ(I)+1
 16   CONTINUE
      I=20
 17   NQ=I-1
 701  DO 23 I=1,NV
      DO 23 J=1,NG1
 23   DF(I,J)=-XM(I,J)
      WRITE (6,210)NN,FADD,FDEL,TOL,(IC(I),I=1,NV)
 210  FORMAT(22H1SUBPROBLEM           I8/22H F-LEVEL FOR INCLUSIONF8.4/
     122H F-LEVEL FOR DELETION F8.4/22H TOLERANCE LEVEL      F8.4/
     222H CONTROL VALUES       92I1///)
      IF(FADD-FDEL)510,220,220
 510  WRITE (6,511)
 511  FORMAT(51H0F FOR INCLUSION MUST BE AS LARGE AS F FOR DELETION)
      GO TO 18
 220  IF(NN-1)838,838,832
 832  READ (IT2) ((ALF(I,J),I=1,NG11),J=1,I),((W(I,J),J=1,NV1)
     *,(XM(I,J),J=1,NG1),I=1,NV)
      REWIND IT2
 838  CALL MASTER
      IF(NGPP*L) 18,18,900
 900  READ (IT2) ((ALF(I,J),I=1,NG11),J=1,I),((W(I,J),J=1,NV1)
     *,(XM(I,J),J=1,NG1),I=1,NV)
      REWIND IT2
      CALL PLT(NGPP,IUA,FTT,NUA)
 18   CONTINUE
   21 GO TO 20
      END
CNV2      SUBROUTINE INV2 FOR BMD07M            SEPTEMBER  1, 1965
      SUBROUTINE INV2(A,B,C,N,T,U,IN)
      DIMENSION U(81),IN(81),A(81,81),B(81,81),C(81,81)
      DIMENSION V(81)
      DO 1 I=1,N
      DO 60 J=1,N
      V(I)=A(I,I)
 60   C(I,J)=0.0
      C(I,I)=1.0
 1    IN(I)=0
      K=1
 2    DO 3 I=K,N
      U(I)=A(I,K)
 3    A(I,K)=0.0
      P=U(K)
      DO 4 I=1,K
      U(I)=A(K,I)
 4    A(K,I)=0.0
      U(K)=-1.0
      IN(K)=1
      H=0.0
      K1=K+1
      DO 5 I=1,N
      Y=U(I)/P
      DO 6 J=1,I
 6    A(I,J)=A(I,J)-U(J)*Y
      IF(IN(I))5,7,5
 7    IF(I-K)30,30,31
 30   Z=B(I,I)-Y*(2.0*B(I,K)-Y*B(K,K))
      DO 32 J=1,N
      IF(J-I)33,32,34
 33   B(J,I)=B(J,I)-Y*B(J,K)
      GO TO 32
 34   IF(J-K)35,36,36
 35   B(I,J)=B(I,J)-Y*B(J,K)
      GO TO 32
 36   B(I,J)=B(I,J)-Y*B(K,J)
 32   CONTINUE
      GO TO 37
 31   Z=B(I,I)-Y*(2.0*B(K,I)-Y*B(K,K))
      DO 42 J=1,N
      IF(J-K)43,43,44
 43   B(J,I)=B(J,I)-Y*B(J,K)
      GO TO 42
 44   IF(J-I)45,42,46
 45   B(J,I)=B(J,I)-Y*B(K,J)
      GO TO 42
 46   B(I,J)=B(I,J)-Y*B(K,J)
 42   CONTINUE
 37   B(I,I)=Z
      DO 50 J=1,N
 50   C(J,I)=C(J,I)-Y*C(J,K)
      IF(A(I,I)/V(I)-H)5,5,9
 9    H=A(I,I)/V(I)
      KK=I
 5    CONTINUE
      Z=B(K,K)/P
      P=SQRT(P)
      DO 14 I=1,K
 14   B(I,K)=B(I,K)/P
      IF(K-N)47,48,48
 47   DO 49 I=K1,N
 49   B(K,I)=B(K,I)/P
 48   B(K,K)=Z
      DO 51 I=1,N
 51   C(I,K)=C(I,K)/P
      K=KK
      IF(H-T)10,10,2
 10   DO 70 I=1,N
      I1=I+1
      IF(IN(I))71,71,76
 71   DO 72 J=1,I
 72   B(J,I)=0.0
      IF(I-N)74,76,76
 74   DO 75 J=I1,N
 75   B(I,J)=0.0
      DO 73 J=1,N
 73   C(J,I)=0.0
 76   DO 77 J=1,I
      A(I,J)=B(J,I)
 77   A(J,I)=B(J,I)
 70   CONTINUE
      RETURN
      END
CJACOBI     SUBROUTINE JACOBI FOR BMD07M         SEPTEMBER  1, 1965
      SUBROUTINE JACOBI(A,B,NV,ACC,NR,IV,LK,Q)
      DIMENSION A(81,81),LK(81),Q(81),B(81,81)
      NR=0
      Q(1)=0.0
      W=0.0
      H=.5*ABS(A(1,1))
      DO 1 I=2,NV
      H=H+ABS(A(I,I))*.5
      Q(I)=0.0
      I1=I-1
      DO 2 J=1,I1
      Z=ABS(A(I,J))
      H=H+Z
      IF(Z-Q(I))2,2,3
 3    Q(I)=Z
      LK(I)=J
 2    CONTINUE
      IF(Q(I)-W)1,1,4
 4    W=Q(I)
      III=I
 1    CONTINUE
      X=NV*NV
      H=2.0*H*ACC/X
 30   II=LK(III)
      JJ=III
      X=A(II,II)
      Y=A(JJ,II)
      Z=A(JJ,JJ)
      W=X-Z
      T=.5*(W+SQRT(W*W+4.0*Y*Y))/Y
      W=SQRT(1.0+T*T)
      S=T/W
      C=1.0/W
      CC=C*C
      SS=S*S
      SC=S*C*2.0
      Q1=0.0
      Q2=0.0
      W=0.0
      NR=NR+1
      DO 27 I=1,NV
      IF(I-II)10,11,12
 10   U=A(II,I)
      V=A(JJ,I)
      E=U*S+V*C
      A(II,I)=E
      IF(ABS(E)-Q1)15,15,14
 14   Q1=ABS(E)
      I1=I
 15   F=V*S-U*C
      A(JJ,I)=F
      IF(I-II) 100,100,110
 110  IF(LK(I)-II) 100,101,100
 101  Q(I)=-1.E20
      I3=I-1
      DO 103 J=1,I3
      IF(ABS(A(I,J))-Q(I)) 103,103,107
 107  LK(I)=J
      Q(I)=ABS(A(I,J))
 103  CONTINUE
 100  IF(ABS(F)-Q2) 9,9,16
 16   Q2=ABS(F)
      I2=I
      GO TO 9
 11   A(II,I)=SS*X+SC*Y+CC*Z
      Q(I)=Q1
      LK(I)=I1
      GO TO 9
 12   IF(I-JJ)17,18,19
 17   U=A(I,II)
      V=A(JJ,I)
      E=S*U+C*V
      A(I,II)=E
      IF(ABS(E)-Q(I))15,15,21
 21   LK(I)=II
      Q(I)=ABS(E)
      GO TO 15
 18   A(JJ,I)=CC*X-SC*Y+SS*Z
      A(I,II)=0.0
      Q(I)=Q2
      LK(I)=I2
      GO TO 9
 19   U=A(I,II)
      V=A(I,JJ)
      E=U*S+V*C
      F=V*S-U*C
      A(I,II)=E
      A(I,JJ)=F
      IF((LK(I)-II)*(LK(I)-JJ)) 109,101,109
 109  G=AMAX1(ABS(E),ABS(F))
      IF(G-Q(I))9,9,13
 13   Q(I)=G
      IF(ABS(E)-ABS(F))23,24,24
 24   LK(I)=II
      GO TO 9
 23   LK(I)=JJ
 9    IF(Q(I)-W)40,25,25
 25   W=Q(I)
      III=I
 40   IF(IV)27,27,33
 33   U=B(I,II)
      V=B(I,JJ)
      B(I,II)=U*S+V*C
      B(I,JJ)=V*S-U*C
 27   CONTINUE
      IF(W-H)31,31,30
 31   RETURN
      END
CMASTER      SUBROUTINE MASTER FOR BMD07M        SEPTEMBER  1, 1965
      SUBROUTINE MASTER
      DIMENSION DF(81,81),XM(81,81),W(81,81),T(81,81),GZ(91,55),IC(81),L
     1Q(20),MQ(81),FT(288),F(81),V(81),U(81),P(81),X(81),NPG(81),C(255),
     2DODE(162),LIST(81),CHAR(81,2),CLIST(81,2)
      DIMENSION NSU(180)
      COMMON/XX12/ ISTEP,STRAT
      COMMON  W
      COMMON  Q000CM (   81)
      COMMON  DF
      COMMON  Q001CM ( 6561)
      COMMON  IC     , LQ     , NV     , NG     , NQ     , F
      COMMON  L      , K      , FADD   , FDEL   , FT     , NG1
      COMMON  U      , P      , X      , NPG    , N      , NST
      COMMON  FL     , NS     , V      , TOL    , MQ     , MORE
      COMMON  C      , YOS    , YES    , IT1    , IT2    , NV1
      COMMON  DODE   , LIST   , CHAR   , CLIST  , NGU
C     EXTERNAL SIGN
      EQUIVALENCE (W(82),T),(GZ,DF),(DF(6562),XM)
      COMMON/TOLER/LISTOL(80),LQQL
      DIMENSION XWX(81,1)
      EQUIVALENCE (XWX,DF(1,41))
      DO 47 I=1,NG
      DO 47 J=1,I
 47   XWX(I,J)=0.
      K=0
      USTAT=1.0
      YAS=YOS
      YOS=0.0
      NS=0
      Q=NGU-1
      L=0
      LQQL=0
      DO 2 I=1,NV
      LISTOL(I)=0
 2    MQ(I)=0
      IJ=0
      DO 5 I=1,NV
      J=IC(I)
      IF(J)5,5,3
 3    MQ(J)=MQ(J)+1
      IF(J-IJ)5,5,4
 4    IJ=J
 5    CONTINUE
      H=1.E20
      G=-1.E20
      A=N-NGU
      DO 30 I=1,NV
      IF(IC(I))30,30,31
 31   F(I)=(T(I,I)-W(I,I))/W(I,I)*A/Q
      IF(ISTEP.GT.0) P(I)=CRIT(I,NG,NPG,ISTEP,1.)
      FI=F(I)
      IF(ISTEP.EQ.1) FI=-P(I)
      IF(ISTEP.EQ.3) FI=P(I)
      IF(G-FI) 32,30,30
 32   G=FI
      KK=I
 30   CONTINUE
      CALL OUT(0)
      IF(F(KK) .GT.FADD .AND. G.NE.-1.E20) GO TO 12
 250  WRITE (6,261)
 261  FORMAT(39H0NO VARIABLE HAS A SUFFICIENTLY LARGE F)
      RETURN
 12   IF(IJ-1)21,21,13
 13   IF(MQ(IJ))14,14,16
 14   IJ=IJ-1
      GO TO 12
 16   MQ(IJ)=MQ(IJ)-1
      G=-1.E20
      LQQL=0
      DO 19 I=1,NV
      IF(IC(I)-IJ)19,17,19
   17 IF(W(I,I)/V(I)-TOL) 9019,175,175
 175  FI=F(I)
      IF(ISTEP.EQ.1) FI=-P(I)
      IF(ISTEP.EQ.3) FI=P(I)
      IF(G-FI) 18,18,19
 18   G=FI
      K=I
      GO TO 19
 9019 LQQL=LQQL+1
      LISTOL(LQQL)=I
 19   CONTINUE
      IF(G+1.E20)14,14,24
 21   IF(H-FDEL)22,22,225
 22   L=L-1
      FL=-1.0
      GO TO 28
 225  IF(F(KK) .GT.FADD .AND. G.NE.-1.E20) GO TO 20
 400  WRITE (6,401)
 401  FORMAT(45H0F LEVEL INSUFFICIENT FOR FURTHER COMPUTATION)
 23   YOS=YAS
      CALL OUT(1)
      WRITE (6,315)
 315  FORMAT(14H1SUMMARY TABLE
     1//      92H0 STEP        VARIABLE         F VALUE TO          NUMB
     2ER OF       U-STATISTIC              /
     3 94H NUMBER   ENTERED  REMOVED   ENTER OR REMOVE   VARIABLES INCLU
     4DED                             //)
      J=0
      DS=DODE(NS)
      DO 300 I=1,NS
      IF(FT(I))310,310,311
 310  J=J-1
      Q=-FT(I)
      WRITE (6,317)I,NSU(I),Q,J,DODE(I)
 317  FORMAT(1X,I4,9X,I9,F16.4,10X,I8,F19.4,F12.4)
      GO TO 300
 311  J=J+1
      WRITE (6,316)I,NSU(I),FT(I),J,DODE(I)
 316  FORMAT(1X,I4,I9,9X,F16.4,10X,I8,F19.4,F12.4)
 300  CONTINUE
      RETURN
 20   K=KK
 24   L=L+1
      FL=1.0
 28   IF(NQ) 27,27,29
 29   DO 25 I=1,NQ
      IF(L-LQ(I))25,26,25
 25   CONTINUE
      GO TO 27
 26   CALL OUT(1)
      REWIND IT2
 27   DO 41 I=1,K
      U(I)=W(K,I)
      P(I)=T(I,K)
      W(K,I)=0.0
 41   T(I,K)=0.0
      PW=U(K)
      IC(K)=-IC(K)
      PT=P(K)
      USTAT=USTAT*PW/PT
      DO 42 I=K,NV
      U(I)=W(I,K)
      P(I)=T(K,I)
      W(I,K)=0.0
 42   T(K,I)=0.0
      DO 44 I=1,NG1
      X(I)=DF(K,I)
 44   DF(K,I)=0.0
C
      DO 46 I=1,NG
      DO 46 J=1,I
 46   XWX(I,J)=XWX(I,J)+X(I)*X(J)/PW
      P(K)=FL
      U(K)=FL
      DO 43 I=1,NV
      YW=U(I)/PW
      YT=P(I)/PT
      DO 45 J=1,NG1
 45   DF(I,J)=DF(I,J)-X(J)*YW
      DO 43 J=1,I
      W(I,J)=W(I,J)-U(J)*YW
 43   T(J,I)=T(J,I)-P(J)*YT
      A=N-L-NGU+1
      FACTU=(A-1.)/(N-NGU)/(L+1)
      G=-1.E20
      H=1.E20
      LQQL=0
      DO 11 I=1,NV
      IF(IC(I))10,11,7
    7 F(I)=0.0
      IF (W(I,I).NE.0.0) F(I)=(T(I,I)-W(I,I))/W(I,I)*(A-1.0)/Q
      IF(ISTEP.GT.0) P(I)=CRIT(I,NG,NPG,ISTEP,FACTU)
      FI=F(I)
      IF(ISTEP.EQ.1) FI=-P(I)
      IF(ISTEP.EQ.3) FI=P(I)
      IF(W(I,I)/V(I)-TOL) 9011,8,8
 8    IF(G-FI) 9,9,11
 9    G=FI
      KK=I
      GO TO 11
 10   F(I)=(W(I,I)-T(I,I))/T(I,I)*A/Q
      IF(IC(I)+1)11,101,11
 101  IF(H-F(I))11,105,105
 105  H=F(I)
      KKK=I
      GO TO 11
 9011 LQQL=LQQL+1
      LISTOL(LQQL)=I
 11   CONTINUE
      NS=NS+1
      FT(NS)=SIGN(F(K),FL)
      NSU(NS)=K
      DODE(NS)=USTAT
      CALL OUT(0)
      K=KKK
      IF(NS-NST) 121,23,23
  121 GO TO 12
      END
COUT   SUBROUTINE OUT FOR BMD07M                 SEPTEMBER  1, 1965
      SUBROUTINE OUT(KKK)
      DIMENSION DF(81,81),XM(81,81),W(81,81),T(81,81),GZ(91,55),IC(81),L
     1Q(20),MQ(81),FT(288),F(81),V(81),U(81),P(81),X(81),NPG(81),C(255),
     2DODE(162),LIST(81),CHAR(81,2),CLIST(81,2)
      DIMENSION XX(90)
      DIMENSION LH(90)
      COMMON/XX12/ ISTEP,STRAT
      LOGICAL STRAT
      COMMON  W
      COMMON  Q000CM (   81)
      COMMON  DF
      COMMON  Q001CM ( 6561)
      COMMON  IC     , LQ     , NV     , NG     , NQ     , F
      COMMON  L      , K      , FADD   , FDEL   , FT     , NG1
      COMMON  U      , P      , X      , NPG    , N      , NST
      COMMON  FL     , NS     , V      , TOL    , MQ     , MORE
      COMMON  C      , YOS    , YES    , IT1    , IT2    , NV1
      COMMON  DODE   , LIST   , CHAR   , CLIST  , NGU
      EQUIVALENCE (W(82),T),(GZ,DF),(DF(6562),XM)
      COMMON/TOLER/LISTOL(80),LQQL
      DO 17 I=1,NG
 17   U(I)=(NPG(I)+IABS(NPG(I)))/2
      MG=NGU-1
      N1=N-NGU
      N3=N1-L
      N2=N3+1
      IF(KKK)23,23,24
 23   WRITE (6,91)
 91   FORMAT(1H0,100(1H*))
      IF(NS)801,801,800
 801  WRITE (6,20)NS
      GO TO 802
 800  IF(FL)19,18,18
 18   WRITE (6,20)NS,K
   20 FORMAT(17H0STEP NUMBER      I4/17H VARIABLE ENTERED   I4)
      GO TO 21
 19   WRITE (6,22)NS,K
 22   FORMAT(17H0STEP NUMBER      I4/17H VARIABLE REMOVED  I4)
 21   WRITE (6,10)MG,N2
 10   FORMAT(56H0VARIABLES INCLUDED AND F TO REMOVE - DEGREES OF FREEDOM
     12I5/)
      J=0
      DO 11 I=1,NV
      IF(IC(I))12,11,11
 12   J=J+1
      LH(J)=I
      X(J)=F(I)
 11   CONTINUE
      M1=(J+6)/7
      DO 100 M=1,M1
 100  WRITE (6,13)(LH(I),X(I),I=M,J,M1)
 13   FORMAT(I4,F9.4,I10,F9.4,I10,F9.4,I10,F9.4,I10,F9.4,I10,F9.4,I10,F9
     1.4)
 802  J=0
      DO 15 I=1,NV
      IF(IC(I))15,15,16
   16 IF (LQQL.LE.0) GO TO 1656
      DO 1655 LQQLL=1,LQQL
      IF (LISTOL(LQQLL).EQ.I)GO TO 15
 1655 CONTINUE
 1656 J=J+1
      LH(J)=I
      P(J)=P(I)
      X(J)=F(I)
 15   CONTINUE
      IF(J)101,101,102
 102  M1=(J+6)/7
      WRITE (6,14)MG,N3
 14   FORMAT(59H0VARIABLES NOT INCLUDED AND F TO ENTER - DEGREES OF FREE
     1DOM2I5/)
      DO 103 M=1,M1
 103  WRITE (6,13)(LH(I),X(I),I=M,J,M1)
      IF(ISTEP.EQ.0) GO TO 101
      WRITE (6,3216)
 3216 FORMAT('0VARIABLES NOT INCLUDED AND ACTUAL ENTRY CRITERIA'/)
      DO 3217 M=1,M1
 3217 WRITE (6,13) (LH(I),P(I),I=M,J,M1)
 101  IF(NS)82,82,804
 804  P7=L
      Q7=MG
      PP=P7*P7
      QQ=Q7*Q7
      IF(PP+QQ-5.0)3175,3176,3175
 3176 S=1.0
      GO TO 3177
 3175 S=SQRT((PP*QQ-4.0)/(PP+QQ-5.0))
 3177 D2=(FLOAT(N)-(P7+Q7+3.0)/2.0)*S-P7*Q7*.5+1.0
      ID1=L*MG
      HL=DODE(NS)**(1.0/S)
      FST=(1.0-HL)/HL*D2/FLOAT(ID1)
      IF(LQQL.GT.0) WRITE(6,9090) (LISTOL(JQQJ),JQQJ=1,LQQL)
 9090 FORMAT(57H0THE FOLLOWING VARIABLES DID NOT PASS THE TOLERANCE TEST
     1    ,20I3)
      IF (LQQL.GT.0) WRITE (6,9091)
 9091 FORMAT ('   THEY WILL NO LONGER BE PRINTED')
      WRITE (6,35)DODE(NS),L,MG,N1,FST,ID1,D2
 35   FORMAT(12H0U-STATISTICF17.5,5X,18HDEGREES OF FREEDOM3I5/
     114H APPROXIMATE F  F15.5,5X,18HDEGREES OF FREEDOMI5,F8.2)
      WRITE (6,1)L,N2
 1    FORMAT(30H0F MATRIX - DEGREES OF FREEDOM2I5)
      E=FLOAT(N2)/(FLOAT(L)*FLOAT(N1))
      L1=0
      NG2=NGU-1
 2    L0=L1+1
      L1=MIN0(L1+10,NG2)
      WRITE (6,3) (CLIST(J,1),CLIST(J,2),J=L0,L1)
    3 FORMAT(1H012X,5HGROUP/5X,10(6X,2A3))
      WRITE (6,4)
 4    FORMAT(6H GROUP)
      LS=L0
      L00=L0+1
      DO 5 I=L00,NGU
      II=LIST(I)
      DO 6 J=L0,LS
      JJ=LIST(J)
      Q=0.0
      DO 7 LL=1,NV
      IF(IC(LL))40,7,7
 40   Q=Q+(DF(LL,II)-DF(LL,JJ))*(XM(LL,II)-XM(LL,JJ))
 7    CONTINUE
      DS=DS+U(JJ)*Q
 6    X(J)=Q*E*U(II)*U(JJ)/(U(II)+U(JJ))
      WRITE (6,8) CLIST(I,1),CLIST(I,2),(X(J),J=L0,LS)
    8 FORMAT(1H ,2A3,10F12.5)
      LS=MIN0(LS+1,L1)
 5    CONTINUE
      IF(L1-NG2)2,82,82
 24   L1=0
 550  L0=L1+1
      L1=MIN0(L1+9,NGU)
      WRITE (6,50) (CLIST(I,1),CLIST(I,2),I=L0,L1)
   50 FORMAT(1H010X,8HFUNCTION/4X,9(8X,2A3))
      WRITE (6,51)
 51   FORMAT(9H VARIABLE)
      DO 52 I=1,NV
      IF(IC(I))86,52,52
 86   DO 270 J=L0,L1
      JJ=LIST(J)
 270  X(J)=DF(I,JJ)
      WRITE (6,55)I,(X(J),J=L0,L1)
   55 FORMAT(I4,9F14.5/(4X,9F14.5))
 52   CONTINUE
      DO 30 J=L0,L1
      JJ=LIST(J)
      P(J)=0.0
      DO 31 I=1,NV
      IF(IC(I))36,31,31
 36   P(J)=P(J)+DF(I,JJ)*XM(I,JJ)
 31   CONTINUE
 30   P(J)=-.5*P(J)
      WRITE (6,32)(P(J),J=L0,L1)
 32   FORMAT(10H0CONSTANT   /(4X,9F14.5))
      IF(L1-NGU)550,560,560
  560 IF(YOS.NE.YES) GO TO 95
 96   WRITE (6,90)
 90   FORMAT(1H05X,10HGROUP WITH10X,37HSQUARE OF DISTANCE FROM AND POSTE
     1RIOR/5X,13HLARGEST PROB.15X,23HPROBABILITY FOR GROUP -)
 95   KL=255
      DO 85 JJ=1,NG
      DO 84 I=1,NG
 84   LH(I)=0
      IF(YOS.NE.YES) GO TO 111
  112 WRITE (6,67) (CLIST(I,1),CLIST(I,2),I=1,NGU)
   67 FORMAT(8H0 GROUP ,6X,7(9X,2A3)/(13X,7(9X,2A3)))
      WRITE (6,190) CHAR(JJ,1),CHAR(JJ,2)
  190 FORMAT(3H   ,2A3/7H   CASE)
 111  NO=IABS(NPG(JJ))
 66   DO 92 J=1,NO
      DO 69 I=1,NV
      KL=KL+1
      IF(KL-255) 69,69,71
   71 READ (IT2) C
      KL=1
 69   X(I)=C(KL)
      XY=0.0
      B=-1.E20
      DO 70 KI=1,NGU
      KJ=LIST(KI)
      U(KI)=P(KI)
      DO 72 I=1,NV
      IF(IC(I))73,72,72
 73   U(KI)=U(KI)+X(I)*DF(I,KJ)
 72   CONTINUE
      IF(B-U(KI))74,74,70
 74   B=U(KI)
      KK=KI
 70   CONTINUE
      LH(KK)=LH(KK)+1
      IF(YOS.NE.YES) GO TO 92
 60   QV=0.0
      DO 780 I=1,NV
      ZZ=0.0
      IF(IC(I))781,780,780
 781  DO 782 MM=1,I
      IF(IC(MM))783,782,782
 783  YY=X(MM)*W(I,MM)
      ZZ=ZZ+YY
 782  CONTINUE
      XY=XY+X(I)*(ZZ-YY*.5)
 780  CONTINUE
      DO 75 I=1,NGU
      XX(I)=U(I)
      U(I)=EXP(U(I)-B)
 75   QV=QV+U(I)
      DO 76 I=1,NGU
      TO=U(I)
      U(I)=-2.0*(XY+XX(I))
 76   XX(I)=TO/QV
      WRITE (6,77) J,CLIST(KK,1),CLIST(KK,2),(U(K),XX(K),K=1,NGU)
 92   CONTINUE
   77 FORMAT(I5,6X,2A3,7(F8.3,F6.3,1H,)/(17X,F8.3,F6.3,1H,F8.6,F6.3,1H,
     1F8.3,F6.3,1H,F8.3,F6.3,1H,F8.3,F6.3,1H,F8.3,F6.3,1H,F8.3,F6.3))
   85 WRITE (IT1) (LH(I),I=1,NGU)
   63 WRITE (6,78) (CLIST(I,1),CLIST(I,2),I=1,NGU)
   78 FORMAT(1H011X,39HNUMBER OF CASES CLASSIFIED INTO GROUP -/(10X,17(1
     1X,2A3)))
	ENDFILE IT1
      REWIND IT1
      WRITE (6,79)
 79   FORMAT(6H GROUP)
      DO 80 I=1,NG
   81 FORMAT(2H  2A3,17I7/(7X,17I7))
      READ (IT1) (LH(J),J=1,NGU)
   80 WRITE (6,81) CHAR(I,1),CHAR(I,2),(LH(J),J=1,NGU)
      REWIND IT1
82    RETURN
      END
CPLT     SUBROUTINE PLT FOR BMD07M               SEPTEMBER  1, 1965
      SUBROUTINE PLT(NGPP,IUA,FTT,NUA)
      DIMENSION PCHAR(81),HHH(41),A3(41),F3(41)
      DIMENSION DF(81,81),XM(81,81),W(81,81),T(81,81),GZ(91,55),IC(81),L
     1Q(20),MQ(81),FT(288),F(81),V(81),U(81),P(81),X(81),NPG(81),C(255),
     2DODE(162),LIST(81),CHAR(81,2),CLIST(81,2)
      DIMENSION TEV(81),FTT(18)
      DIMENSION X1(10),X2(60)
      COMMON/XX12/ ISTEP,STRAT
      LOGICAL STRAT
      COMMON  W
      COMMON  Q000CM (   81)
      COMMON  DF
      COMMON  Q001CM ( 6561)
      COMMON  IC     , LQ     , NV     , NG     , NQ     , F
      COMMON  L      , K      , FADD   , FDEL   , FT     , NG1
      COMMON  U      , P      , X      , NPG    , NQ00N  , NST
      COMMON  FL     , NS     , V      , TOL    , MQ     , MORE
      COMMON  C      , YOS    , YES    , IT1    , IT2    , NV1
      COMMON  DODE   , LIST   , CHAR   , CLIST  , NGU
      EQUIVALENCE (W(82),T),(GZ,DF),(DF(6562),XM)
      DATA DOLAR/'$   '/,ST/'*   '/,BL/'    '/,Q003HL/'0   '/
      L=0
      DO 1 I=1,NV
      TEV(I)=W(I,I)
      IF(IC(I))2,1,1
 2    L=L+1
      U(L)=XM(I,NG1)
      MQ(L)=I
      DO 3 J=1,L
      K=MQ(J)
      T(J,L)=T(K,I)-W(I,K)
 3    W(L,J)=W(I,K)
 1    CONTINUE
      IF(L.EQ.0) RETURN
      IF(L.GT.1) GO TO 1019
      X(1)=W(1,2)/W(1,1)
      V(1)=X(1)
      W(1,1)=1.
      W(1,2)=0.
      TX=1./(1.+X(1))
      LFT=1
      GO TO 1029
 1019 CONTINUE
      CALL INV2(W,W(1,2),DF,L,1.E-5,IC,X)
      CALL JACOBI(W,DF,L,1.E-6,NR,1,IC,X)
      DO 4 I=1,L
      X(I)=W(I,I)
 4    IC(I)=I
      TX=1.0
      RQ=0.0
      LFT=L
      DO 5 I=1,L
      DO 6 J=I,L
      IF(X(J)-X(I))6,6,8
 8    Y=X(J)
      X(J)=X(I)
      X(I)=Y
      II=IC(I)
      IC(I)=IC(J)
      IC(J)=II
 6    CONTINUE
      TX=TX/(1.0+X(I))
      RQ=RQ+X(I)
      V(I)=RQ
      M=IC(I)
      DO 5 J=1,L
 5    W(J,I)=DF(J,M)
 1029 CONTINUE
      WRITE (6,7)(X(I),I=1,LFT)
 7    FORMAT(1H06X,11HEIGENVALUES//(4X,9F14.5))
      DO 859 LO=1,LFT
      V(LO)=V(LO)/RQ
      XDP1=X(LO)/(1.0+X(LO))
      AXDP1=ABS(XDP1)
  859 X(LO)=SQRT(AXDP1)
      WRITE (6,858)(V(LO),LO=1,LFT)
 858  FORMAT(1H06X,41HCUMULATIVE PROPORTION OF TOTAL DISPERSION// (4X,9F
     114.5))
      WRITE (6,857)(X(LO),LO=1,LFT)
 857  FORMAT(1H0,5X,23H CANONICAL CORRELATIONS//(4X,9F14.5))
      L1=0
 10   L0=L1+1
      L1=MIN0(L1+9,LFT)
      WRITE (6,11)(I,I=L0,L1)
 11   FORMAT(39H0COEFFICIENTS FOR CANONICAL VARIABLE - /9H0ORIGINALI6,8I
     114)
      WRITE (6,12)
 12   FORMAT(9H VARIABLE)
      DO 13 I=1,L
 13   WRITE (6,14)MQ(I),(W(I,J),J=L0,L1)
      DO 180 J=L0,L1
      DO 180 I=1,NG
      DF(I,J)=0.0
      DO 180 K=1,L
      M=MQ(K)
 180  DF(I,J)=DF(I,J)+W(K,J)*(XM(M,I)-U(K))
      WRITE (6,182)
 182  FORMAT(6H0GROUP 10X,44HCANONICAL VARIABLES EVALUATED AT GROUP MEAN
     1S)
      DO 181 I=1,NG
 181  WRITE (6,14)I,(DF(I,J),J=L0,L1)
      IF(L1-LFT)10,15,15
 15   DO 25 I=1,L
      A3(I)=W(I,3)
      V(I)=W(I,1)
 25   P(I)=W(I,2)
      WRITE (6,100)TX
 100  FORMAT(27H0CHECK ON FINAL U-STATISTICF15.5)
      A=0.0
      CC=0.
      B=0.0
      DO 37 M=1,L
      CC=CC+U(M)*A3(M)
      A=A+U(M)*V(M)
 37   B=B+U(M)*P(M)
      BX=-1.E20
      BY=-1.E20
      AX=1.E20
      AY=1.E20
      N=0
      DO 27 I=1,NG
      F(I)=-A
      N=N+IABS(NPG(I))
      FT(I)=-B
      F3(I)=-CC
      DO 26 J=1,L
      M=MQ(J)
      Z=XM(M,I)
      F3(I)=F3(I)+Z*A3(J)
      F(I)=F(I)+Z*V(J)
 26   FT(I)=FT(I)+Z*P(J)
      AX=AMIN1(AX,F(I))
      AY=AMIN1(AY,FT(I))
      BX=AMAX1(BX,F(I))
 27   BY=AMAX1(BY,FT(I))
      DO 600 I=1,NG
 600  HHH(I)=F3(I)
      DO 620 I=1,NG
      HHM="377777777777
C     HIGHEST DECIMAL NUMBER
      DO 610 J=I,NG
      HHM=AMIN1(HHM,HHH(J))
 610  IF(HHM.EQ.HHH(J)) K=J
      HHH(K)=HHH(I)
 620  HHH(I)=HHM
      DO 630 I=2,NG
 630  HHH(I)=(HHH(I)+HHH(I-1))/2.
      HHH(1)=-1.E30
      IF(.NOT.STRAT) HHH(2)=1.E30
      HHH(NG+1)=1.E30
      AX=AMIN1(AX,AY)-3.
      BX=AMAX1(BX,BY)+3.0
C
 14   FORMAT(1X,I3,9F14.5)
      AY=AX
      RX=BX-AX
      RY=RX
      D=RX/9.0
      Z=AX
      IF (NUA) 1225,1225,122
 1225 IF(IUA) 121,121,122
 122  KL=255
      REWIND IUA
      DO 124 J=1,N
      DO 143 I=1,NV
      KL=KL+1
      IF(KL-255) 143,143,144
  144 READ (IT2) C
      KL=1
 143  X(I)=C(KL)
      DO 146 I=1,L
      DODE(I)=0.0
      DO 146 K=1,L
      M=MQ(K)
 146  DODE(I)=DODE(I)+W(K,I)*(X(M)-U(K))
      IF (IUA) 1465,1465,124
 124  WRITE (IUA,FTT)(DODE(I),I=1,L)
C
      ENDFILE IUA
      REWIND IUA
 1465 IF (NUA) 121,121,1475
 1475 DO 147 I=1,L
 147  WRITE (NUA,FTT)(W(K,I),K=1,L)
      ENDFILE NUA
      REWIND NUA
 121  DO 71 I=1,10
      X1(I)=Z
 71   Z=Z+D
      NSTRAT=1
      IF(STRAT) NSTRAT=NG
      DO 200 LKKL=1,NSTRAT
      REWIND IT2
      KL=255
      L1=0
 30   L0=L1+1
      IF(STRAT) WRITE (6,201) LKKL
 201  FORMAT('1STRATIFICATION',I3,' ON THIRD CANONICAL VARIABLE')
      LLZ1=1
      IF(STRAT) LLZ1=0
      WRITE (6,120) LLZ1
 120  FORMAT(I1,'POINTS PLOTTED ON THE FOLLWING GRAPH'//5X,29HX = FIRST
     1 CANONICAL VARIABLE /5X,30HY = SECOND CANONICAL VARIABLE /5X,62HCA
     2SE NUMBER FOLLOWED BY * INDICATES THE POINT IS OFF THE GRAPH)
      DO 31 I=1,91
      DO 31 J=1,55
 31   GZ(I,J)=BL
      L1=MIN0(L1+NGPP,NG)
C      FINDING THE FIRST NON-BLANK LETTER OF THE GROUP LABELS
      DO 39 ICH=1,NG
      KC=1
      IF(CHAR(ICH,1).EQ.BL) KC=2
	CALL GETCHR(CHAR(ICH,KC),CCHAR)
   38 PCHAR(ICH)=CCHAR
   39 CONTINUE
C      PCHAR(I) IS THE FIRST LETTER OF GROUP LABEL I
      DO 40 MZ=L0,L1
      LOST=0
      MX=0
      N87=IABS(NPG(MZ))
      N41=MIN0((N87-1)/10,5)
      WRITE (6,154) CHAR(MZ,1),CHAR(MZ,2), F(MZ),FT(MZ),(BL,J=1,N41)
  154 FORMAT(7H0GROUP ,2A3,18H  MEAN COORDINATES2F8.3//
     16(A1,21H  CASE     X       Y ))
      DO 42 J=1,N87
      DO 43 I=1,NV
      KL=KL+1
      IF(KL-255)43,43,44
   44 READ (IT2) C
      KL=1
 43   X(I)=C(KL)
      AA=-A
      CCC=-CC
      BB=-B
      DO 45 I=1,L
      M=MQ(I)
      CCC=CCC+X(M)*A3(I)
      AA=AA+X(M)*V(I)
 45   BB=BB+X(M)*P(I)
      IF(CCC.LE.HHH(LKKL) .OR. CCC.GT.HHH(LKKL+1)) GO TO 42
      MX=MX+1
      IF(MX-61)150,151,151
C
 151  CONTINUE
      WRITE (6,153) ((LIST(I),X2(I),CLIST(I,1),U(I),I=K,60,10),K=1,10)
  153 FORMAT(1H0,I4,A1,2F8.3,5(I5,A1,2F8.3)/6(I5,A1,2F8.3))
C
      MX=1
  150 CLIST(MX,1)=AA
      U(MX)=BB
      LIST(MX)=J
      X2(MX)=BL
      XIX=(AA-AX)/RX*90.0+1.5
      IX=XIX
      XIX=55.5-(BB-AY)/RY*54.0
      IY=XIX
      IF(IX*(92-IX))50,50,48
 48   IF(IY*(56-IY))50,50,49
 49   IF(GZ(IX,IY) .EQ. BL) GO TO 935
  934 IF(GZ(IX,IY) .EQ. PCHAR(MZ)) GO TO 42
 936  GZ(IX,IY)=DOLAR
      GO TO 42
  935 GZ(IX,IY)=PCHAR(MZ)
      GO TO 42
 50   X2(MX)=ST
 42   CONTINUE
C
      IF(MX.EQ.0) GO TO 40
      R=(+Q003HL)
      N41=MIN0(10,MX)
      DO 161 K0=1,N41
      WRITE (6,162) R,(LIST(I),X2(I),CLIST(I,1),U(I),I=K0,MX,10)
 162  FORMAT(A1,I4,A1,2F8.3,5(I5,A1,2F8.3))
  161 R=BL
 40   CONTINUE
      DO 92 MZ=L0,L1
      XIX=(F(MZ)-AX)/RX*90.0+1.5
      IX=XIX
      XIX=55.5-(FT(MZ)-AY)/RY*54.0
      IY=XIX
      IF(F3(MZ).LE.HHH(LKKL) .OR. F3(MZ).GT.HHH(LKKL+1)) GO TO 92
      GZ(IX,IY)=ST
 92   CONTINUE
      D=RY/54.0
      Z=AY+RY
      DO 70 I=1,55
      X2(I)=Z
 70   Z=Z-D
      WRITE (6,95)
 95   FORMAT(45H-OVERLAP IS INDICATED BY $, GROUP MEANS BY *. )
      WRITE (6,80)(X1(I),I=1,9,2),(X1(I),I=2,10,2),(X2(J),(GZ(I,J),I=1,9
     11),X2(J),J=1,55),(X1(I),I=2,10,2),(X1(I),I=1,9,2)
 80   FORMAT(1H15X,5(F10.3,10X)/6X,5(10X,F10.3)/12X,1H+18(5H....+),55(/1
     1X,F9.3,2H .91A1,1H.F9.3)/12X,1H+18(5H....+)/6X,5(10X,F10.3)/6X,5(F
     210.3,10X))
      IF(L1-NG) 30,200,200
 200  CONTINUE
 90   DO 995 I=1,NV
 995  V(I)=TEV(I)
      RETURN
      END
CPRM          SUBROUTINE  PRM   FOR BMD07M       SEPTEMBER  1, 1965
      SUBROUTINE PRM(A,NV,NG,KK,F1,F2,CHAR)
      DIMENSION A(81,81),F1(4),F2(8),CHAR(81,2)
      L1=0
 1    L0=L1+1
      L1=MIN0(L1+9,NG)
      IF(KK)3,3,2
 2    LS=L1
      WRITE (6,12) (CHAR(I,1),CHAR(I,2),I=L0,L1)
   12 FORMAT (1H0,11X,5HGROUP,/4X,9(8X,2A3))
      L00=1
      GO TO 4
 3    LS=L0
      WRITE (6,13) (I,I=L0,L1)
   13 FORMAT (1H0,11X,9HVARIABLES/4X,9(8X,I4,2X))
      L00=L0
    4 WRITE (6,14)
   14 FORMAT (9H VARIABLE)
      DO 5 I=L00,NV
      WRITE (6,7)I,(A(I,J),J=L0,LS)
    7 FORMAT (1X,I3,9F14.5)
 5    LS=MIN0(LS+1,L1)
      IF(L1-NG)1,6,6
 6    RETURN
      END
      SUBROUTINE GETCHR(A,C)
CGETCHR        SUBROUTINE GETCHR FOR BMD07M                 JULY 26,1966
C FINDS FIRST BLANK LETTER OF WORD A AND RETURNS IT IN C
	EQUIVALENCE (CI,IC)
	CI=A
1	IF (IC .EQ. 0) GO TO 20
	ID=IC .AND. "774000000000
	IF (ID .NE. "200000000000) GO TO 21
	ID=IC .AND. "002000000000
	IC=IC .AND. "001777777777
	IC=IC*2**7
	IF (ID .NE. 0) IC=IC .OR. "400000000000
	GO TO 1
20	IC=' '
21	C=CI
      RETURN
      END
      FUNCTION CRIT(K,NG,NPG,ISTEP,C)
      DIMENSION NPG(1),XWX(81,8),Y(40)
      COMMON W(81,81),X(81),DF(81,81)
      EQUIVALENCE (XWX,DF(1,41))
      DIMENSION ALF(81,1)
      EQUIVALENCE (DF(41,41),ALF)
      AL=0.
      F="377777777777
      IF(ISTEP.EQ.1) F=0.
      DO 1 I=1,NG
      IF(NPG(I).LT.0) GO TO 1
      Y(I)=XWX(I,I)+DF(K,I)**2/W(K,K)
      I1=I-1
      IF(I1.EQ.0) GO TO 1
      DO 2 J=1,I1
      IF(NPG(J).LT.0) GO TO 2
      AL=AL+ALF(I,J)
      S=Y(I)+Y(J)-2.*(XWX(I,J)+DF(K,I)*DF(K,J)/W(K,K))
      IF(ISTEP.EQ.1) F=F+4.*ALF(I,J)/(4.+S)
      IF(ISTEP.EQ.3) F=AMIN1(F,S*NPG(I)*NPG(J)/(NPG(I)+NPG(J))*C)
 2    CONTINUE
 1    CONTINUE
      IF(ISTEP.EQ.1) F=F/AL
      CRIT=F
      RETURN
      END