Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd07d.for
There is 1 other file named bmd07d.for in the archive. Click here to see a list.
C        DESCRIPTION OF STRATA WITH HISTOGRAMS         MAY 20, 1966
C
C             UCLA MEDICAL CENTER - HEALTH SCIENCES COMPUTING FACILITY
C        THIS IS A SIFTED VERSION OF BMD07D ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
C
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
      DIMENSION FNG(10)
       DIMENSION OUT(17)
      DOUBLE PRECISION     OCC,FRMT(120),PROBLM,FINISH,SPVALU,GRPDIV,COB,JBCD
       DOUBLE PRECISION TRYME(10), BLANK
       DATA OUT(1),OUT(2),OUT(4),OUT(5),OUT(6),OUT(7),OUT(8),OUT(10),
     * OUT(11),OUT(12),OUT(14),OUT(15),OUT(16),OUT(17) / 4H(16X, 4H,   ,
     * 4H('GR, 4HOUP', 4H,I3,, 4H3X)/, 4H16X,,4H(A8,, 4H3X)/, 4H15X,,
     * 4H('.., 4H...., 4H...., 4H+')) / , YES / 3HYES /
      DATA FNG/'1','2','3','4','5','6','7','8','9','10'/
       DATA BLANK / '        ' /
      DATA PROBLM,FINISH,SPVALU,GRPDIV,SPCVAL/6HPROBLM,6HFINISH,6HSPCVAL
     1,6HGRPDIV,4H-7CV/
       COMMON / LABS / TRYME
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD   , IPNT
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C           CP       GROUP CUT POINTS
C           IPNT     PRINT CORRELATION MATRIX
C           IAO      PRINT ALL OF ORDERED DATA
C           IPA      PRINT ALL OF INPUT DATA
C           IPO      PRINT PART OF ORDERED INPUT
C           IPP      PRINT PART OF INPUT DATA
C           ISV      NO. OF VARIABLE WITH SPECIAL VALUE
C           IVF      NO. OF VARIABLE FORMAT CARDS
C           JBCD     PROBLEM NAME
C           NADD     NO. OF VARIABLES ADDED IN TRANSGENERATION
C           NCAS     NO. OF CASES
C           NCI      NO. OF CLASS INTERVALS
C           NCP      NO. OF GROUP CUT POINTS
C           NNC      NO. OF NAME CARDS OR VARIABLES WITH SPECIFIED NAMES
C           NSVC     NO. OF SPECIAL VALUE CARDS
C           NTR      NO. OF TRANS GENERATOR CARDS
C           NVAB     NO. OF BASE VARIABLE FOR GROUP DIVISION
C           NVAR     NO. OF VARIABLES
C
C
  17  FORMAT ('1BMD07D - DESCRIPTION OF STRATA WITH HISTOGRAMS',
     * ' - REVISED MAY 10, 1968' /
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
      NTAPE=5
	CALL USAGEB('BMD07D')
C
  998 READ (5,10)COB,JBCD,NVAR,NSVC,NNC,NCAS,NG,NCP,NCI,NTR, NADD, PA, P
     1P,AO,PO,PNT,SNGLE,NULABS,MTAPE,IVF
      IF(COB.EQ.FINISH)GO TO 999
      IF(COB.EQ.PROBLM)GO TO 50
      WRITE(6,10012)
10012 FORMAT(49H PROBLEM CARD OUT OF ORDER OR INCORRECTLY PUNCHED)
 999  IF(5-NTAPE)9998,9999,9999
 9998 REWIND NTAPE
 9999 STOP
   50 CALL TPWD(MTAPE,NTAPE)
    3 IF(IVF .GT. 0.AND. IVF .LE. 10) GO TO 1152
      WRITE (6,888)
      IVF=1
 1152 IVF = IVF*12
      READ (5,12)(FRMT(I),I=1,IVF)
 53   L1=1
 1153 IF(NG-10)1155,1155,10000
10000 WRITE(6,10001)
10001 FORMAT(28H NUMBER OF GROUPS EXCEEDS 10)
      GO TO 1151
 1155 IF(NCI-30)1156,1156,10002
10002 WRITE(6,10003)
10003 FORMAT(47H NUMBER OF CLASSES SPECIFIED IS GREATER THAN 30)
      GO TO 1151
 1156 IF(NCI-5)1157,1158,1158
 1157 IF(NCI)10004,1158,10004
10004 WRITE(6,10005)
10005 FORMAT(43H NUMBER OF CLASSES SPECIFIED IS LESS THAN 5)
      GO TO 1151
 1158 L2 = NVAR
      IF(-NADD)2158,2158,1150
 2158 L3=1+NADD
      NVAR=NVAR+NADD
      IF(NCAS*NVAR-4000)1159,1159,11006
11006 WRITE(6,11007)
11007 FORMAT(' DATA MATRIX IS TOO LARGE, CANNOT EXCEED 16,000')
      GO TO 999
10006 WRITE(6,10007)
10007 FORMAT(19H TOO MANY VARIABLES)
      GO TO 999
 1159 IF(NVAR-100)1154,1154,10006
 1154 DO 531 J=1,NCAS
      READ (NTAPE,FRMT)(X(I),I=L1,L2)
      L1=L2+L3
      L2=L2+NVAR
 531  CONTINUE
      DO 533 I=1,NVAR
      OCC(I) =0 .0
      BIGX(I) =0.0
      SMLX(I) =0.0
      NS(I)=0
      DO 532 J=1,5
      SPV(I,J)=0.0
 532  CONTINUE
 533  CONTINUE
      IF (NSVC) 5305, 5305, 54
   54 IF(NSVC-NVAR)541,541,10010
10010 WRITE(6,10011)
10011 FORMAT(' NUMBER OF SPECIAL VALUES INCORRECTLY SPECIFIED')
      GO TO 1151
C
C     READ IN SPECIAL VALUE CARDS
C
 541  DO 55 I=1,NSVC
      READ (5,1300)COB,KM,NVIV,(SPV(KM,K), K=1,NVIV)
      IF(COB.NE.SPVALU)GO TO 10013
  555 IF(NVIV-5)556,556,20014
20014 WRITE(6,10011)
      GO TO 1151
10013 WRITE(6,10014)
10014 FORMAT(55H SPECIAL VALUE CARD OUT OF ORDER OR INCORRECTLY PUNCHED
     1)
      GO TO 999
  556 ISKIP=1
      IF(SNGLE.NE.YES)GO TO 5567
 5563 ISKIP=2
 5567 IF(KM-100)557,557,10016
10016 WRITE(6,10017)
10017 FORMAT(50H INDEX OF VARIABLE WITH SPECIAL VALUES EXCEEDS 100)
      GO TO 1151
  557 NS(KM)=NVIV
      DO 5460 II = 1, NVIV
      DO 5450 J = II, NVIV
      IF(SPV(KM,II).GE.SPV(KM,J))GO TO 5450
 5425 HOLD = SPV(KM,II)
      SPV(KM,II) = SPV(KM,J)
      SPV(KM,J) = HOLD
 5450 CONTINUE
 5460 CONTINUE
 55   CONTINUE
      GO TO (5305,5500),ISKIP
 5500 DO 5501 I=1,NVAR
      NS(I)=NVIV
      DO 5501 J=1,NVIV
 5501 SPV(I,J)=SPV(KM,J)
 5305 IF(NG)10018,5315,5306
10018 WRITE(6,10019)
10019 FORMAT(36H NUMBER OF GROUPS CANNOT BE NEGATIVE)
      GO TO 1151
 5315 IF(-NCP)560,275,10020
10020 WRITE(6,10021)
10021 FORMAT(46H NUMBER OF GROUP CUT POINTS CANNOT BE NEGATIVE)
      GO TO 1151
C
C     READ IN GROUP DIVISION CARD
C
  560 READ (5,14)COB,NVAB,(CP(I),I=1,NCP)
      IF(COB.NE.GRPDIV)GO TO 20020
  565 IF(NVAB-100)570,570,10022
10022 WRITE(6,10023)
10023 FORMAT(41H NO. OF BASE VARIABLE IS GREATER THAN 100)
      GO TO 1151
20020 WRITE(6,20021)
20021 FORMAT(47H GROUP DIVISION CARD OUT OF ORDER OR MISPUNCHED)
      GO TO 999
  570 GO TO (572,571),ISKIP
  571 NS(NVAB)=0
  572 IF(NS(NVAB))5306,5306,270
 5306 WRITE (6,17)
      IF (NG) 101, 100, 101
 101  WRITE (6,19)NCAS
      GO TO 105
C
 100  WRITE (6,18)NVAB, NCAS, NCP
      DO 1001 I=1,NCP
      WRITE (6,45)I, CP(I)
 1001 CONTINUE
 105  WRITE (6,20)
      WRITE (6,21)JBCD,NCAS,NVAR,NG,NCP,NSVC,NCI,NNC, PA,  PP, AO, PO, P
     1NT
      WRITE(6,35000)(FRMT(I),I=1,IVF)
35000 FORMAT(' VARIABLE FORMAT CARD(S)'/10(1X,12A6/))
      IF (NTR) 56,56,5300
 5300 IF(NTR-99)5301,5301,10024
10024 WRITE(6,10025)
10025 FORMAT(48H NO. OF TRANSGENERATION CARDS IS GREATER THAN 99)
      GO TO 999
 5301 CALL TVA
      IF(-NERR)56,56,999
 56   NVNC=NVAR*NCAS
  205 IF(PA.NE.YES)GO TO 225
  210 WRITE (6,41)
      ASSIGN 5302 TO KBRNCH
  214 L4=NCAS
  215 WRITE (6,47)
      L3=1
      L1=1
      L2=NVAR
  220 DO 2110 J=L3,L4
      WRITE (6,40)J,(X(I),I=L1,L2)
      L1=L2+1
      L2=L2+NVAR
 2110 CONTINUE
      GO TO KBRNCH,(5302,240,71,249)
C
C     PRINT FIRST AND LAST TEN ROWS OF INPUT MATRIX AFTER
C     TRANSGENERATION, IF DESIRED
C
  225 IF(PP.NE.YES)GO TO 5302
 230  IF(20-NCAS)236,210,210
  236 WRITE (6,41)
      ASSIGN 240 TO KBRNCH
  238 WRITE (6,43)
      L4=10
      GO TO 215
C
  240 ASSIGN 5302 TO KBRNCH
  242 WRITE (6,42)
      L1=NVNC-(10*NVAR)+1
      L2=L1+NVAR-1
      L3=NCAS-9
      L4=NCAS
      GO TO 220
C
 5302 IF(-NG)60,63,63
 60   NC=NCAS
      NCP=NG-1
      NGG=NG
      DO 61 I=1,NG
      IGR(I)=NC/(NGG)
      NC=NC-IGR(I)
      NGG=NGG-1
 61   CONTINUE
      GO TO 70
C
 63   CALL DIVIDE (NVAB)
C
C     PRINT ORDERED MATRIX, IF DESIRED
C
   70 IF(AO.NE.YES)GO TO 325
  212 WRITE (6,46)
      ASSIGN 71 TO KBRNCH
      GO TO 214
C
C     PRINT FIRST AND LAST TEN ROWS OF ORDERED MATRIX, IF DESIRED
C
  325 IF(PO.NE.YES)GO TO 71
 330  IF(20-NCAS)248,212,212
 248  WRITE (6,46)
      ASSIGN 249 TO KBRNCH
      GO TO 238
C
  249 ASSIGN 71 TO KBRNCH
      GO TO 242
C
 71    DO 3681 IZQ=1,10
 3681  TRYME(IZQ) = BLANK
       CALL RDLBL(NNC,NVAR,OCC)
       IF (NULABS.LE.0) GO TO 74
       READ (5,8912) TRYME
 8912  FORMAT (10A8)
 74   NG=NCP+1
      DO 997 I=1,10
      INTEG(I)=I
 997  CONTINUE
      DO 900 NV=1, NVAR
      NCICP(NV)=0
      CALL MAMIN(NV)
      KCICP=0
      CALL CLINT(NV)
      IF(KCICP)999,106,999
  106 IF(OCC(NV)-0.0)75,76,75
 75   WRITE (6,22)NV, OCC(NV)
      GO TO 78
C
 76   WRITE (6,23)NV
  78  WRITE (6,16)
      L=NG
       OUT(3) = FNG(L)
       OUT(9) = FNG(L)
       OUT(13) = FNG(L)
 79    WRITE (6,OUT) (I,I=1,NG), (TRYME(I), I=1,NG)
 90   JY=NS(NV)
      J=NCICP(NV)
      IF(-JY)91,911,911
C
C            NTR IS USED TO GIVE RITE THE NUMBER OF THE VARIABLE
C
   91 NTR = NV
      WRITE (6,1112)
      NABC = 1
      CALL PLUG (NV,NABC)
      DO 910 JJ = 1, JY
      CALL RITE (JJ,NG,NABC)
  910 CONTINUE
 911  WRITE (6,1111)
      NABC=2
      CALL PLUG(NV,NABC)
      GO TO 93
   92 J=J-1
   93 CALL RITE(J,NG,NABC)
      IF (J-1) 95, 95, 92
 95   R=0.0
      S=0.0
      CAS=NCAS
      CAS1=CAS-1.0
      YMN=0.0
      YSD=0.0
      DO 9100 I=1,NG
      SX(I)=0.0
      DX(I)=0.0
      XL(I)=0.0
 9100 CONTINUE
      J1=1
      SSW=0.0
      DO 9200 I=1,NG
      II=I-1
      IG=IGR(I)
      GI=IGR(I)
      IF(-II)9106,9107,9107
 9106 J1=J1+IGR(II)
 9107 IG1=J1+IG-1
      IF(-IG)9104,9200,9200
 9104 DO 9150 J=J1,IG1
      K=(J -1)*NVAR+NV
      IF(-JY)9110,9125,9125
 9110 IF(X(K).EQ.SPCVAL)GO TO 9119
 9125 SX(I)=SX(I)+X(K)
      GO TO 9150
C
 9119 XL(I)=XL(I)+1.0
 9150 CONTINUE
       IF (GI.EQ.XL(I)) SX(I) = 0.0
       IF (GI.NE.XL(I)) SX(I) = SX(I)/(GI-XL(I))
C
C     MEAN OF GROUP I IN SX(I)---SPECIAL VALUES EXCLUDED
C
      DO 9175 J=J1,IG1
      K=(J -1)*NVAR+NV
      IF (JY) 9170, 9170, 9160
 9160 IF(X(K).EQ.SPCVAL)GO TO 9175
 9170 DX(I)=DX(I)+(X(K)-SX(I))**2
 9175 CONTINUE
      SSW=SSW+DX(I)
       IF (GI.LE.XL(I)+1.0) DX(I) = 0.0
       IF (GI.GT.XL(I)+1.0) DX(I) = SQRT(DX(I)/(GI-XL(I)-1.0))
C
C     STANDARD DEVIATION OF GROUP I IN DX(I)
C
 9200 CONTINUE
      DO 125 J=1,NCAS
      K=(J-1)*NVAR+NV
      IF (JY) 109, 121, 109
  109 IF(X(K).EQ.SPCVAL)GO TO 110
 121  YMN=YMN+X(K)
      GO TO 125
C
 110  R=R+1.0
 125  CONTINUE
      YMN=YMN/(CAS-R)
      XMN(NV)=YMN
      DO 145 J=1,NCAS
      K=(J-1)*NVAR+NV
      IF(-JY)128,141,141
  128 IF(X(K).EQ.SPCVAL)GO TO 130
 141  YSD=YSD+(X(K)-YMN)**2
      GO TO 145
C
 130  S=S+1.0
 145  CONTINUE
      IDFT=CAS1-S
      IDFG=NG-1
      IDFW=IDFT-IDFG
      SST=YSD
      SSG=SST-SSW
      IF(IDFG.NE.0) SGM=SSG/IDFG
      IF(IDFG.EQ.0) SGM=0.0
      IF(IDFW.NE.0) SWM=SSW/IDFW
      IF(IDFW.EQ.0) SWM=0.0
       IF (SWM.EQ.0) FST = 0.0
       IF (SWM.NE.0) FST = SGM/SWM
      IF(CAS1.NE.S) YSD=SQRT(YSD/(CAS1-S))
      IF(CAS1.EQ.S) YSD=0.0
      WRITE (6,36)( SX(I), I=1,NG)
      WRITE (6,37)( DX(I), I=1,NG)
      DO 150 I=1,NG
      LX=XL(I)
      XL(I)=IGR(I)-LX
 150  CONTINUE
      WRITE (6,38)( XL(I), I=1,NG)
      WRITE (6,1010)YMN,SSG,IDFG,SGM,FST,YSD,SSW,IDFW,SWM,BIGX(NV),SST,I
     1DFT,SMLX(NV)
 900  CONTINUE
  250 IF(PNT.NE.YES)GO TO 998
  255 CALL CORR
      GO TO 998
C
 270  WRITE (6,15)NS(NVAB)
      GO TO 999
C
 275  WRITE (6,24)
      GO TO 999
C
 1150 WRITE (6,1501)
 1151 WRITE (6,1500)
      GO TO 999
C
 10    FORMAT(2A6,3I3,I4,I2,I1,3I2,6A3,15X,I1,2I2)
 11   FORMAT (1H1)
  12  FORMAT(12A6)
  14  FORMAT(A6,I3,9F7.0)
 15   FORMAT(1H0,9HTHERE ARE,I4,86H SPECIAL VALUES FOR THE VARIABLE ON W
     1HICH DATA IS STRATIFIED. PROGRAM CANNOT CONTINUE.)
  16  FORMAT(75X32HLOWER LIMITS OF CLASS INTERVALS)//)
  18  FORMAT(1H034HDATA STRATIFIED ON VARIABLE NUMBERI4,1H,I5,6H CASES/I
     16,21H CUT POINTS SPECIFIED//)
  19  FORMAT(1H0,34HDATA STRATIFIED BY ORDER OF ENTRY.I5,6H CASES)
  20  FORMAT(13H0PROBLEM CARD)
  21  FORMAT(1H0,8X,12HPROBLEM NAME25XA6/9X15HNUMBER OF CASES21XI7/9X19H
     1NUMBER OF VARIABLES17XI7/9X26HNUMBER OF GROUPS SPECIFIED10XI7/9X26
     2 HNUMBER OF GROUP CUT POINTS,I17/9X29HNUMBER OF SPECIAL VALUE CARD
     3S7XI7/9X35HNUMBER OF CLASS INTERVALS SPECIFIED3XI5/9X30HNUMBER OF
     4VARIABLES WITH NAMES,6X,I7,//9X25HPRINT ENTIRE INPUT MATRIX15XA3/9
     5X37HPRINT FIRST AND LAST 10 ROWS OF INPUT3XA3/9X27HPRINT ENTIRE OR
     6DERED MATRIX13XA3/9X40HPRINT FIRST AND LAST 10 ROWS OF ORDERED A3/
     79X24HPRINT CORRELATION MATRIX16XA3)
 22   FORMAT(1H1/40X8HVARIABLEI4,2X2H( A6,2H )10X34H(PRINTED INTERVAL DE
     1SIGNATIONS ARE)
 23   FORMAT(1H1/40X8HVARIABLEI4,22X34H(PRINTED INTERVAL DESIGNATIONS AR
     1E)
 24   FORMAT(1H0,11X,94HBOTH THE NUMBER OF GROUPS AND THE NUMBER OF GROU
     1P CUT POINTS ARE ZERO. PROGRAM CANNOT PROCEED.)
  36  FORMAT(1H05X5HMEAN 10F11.3)
  37  FORMAT(6X5HS DEV10F11.3)
  38  FORMAT(7X1HN10F11.0,//)
  40  FORMAT(I5,8F14.5,/(5X,8F14.5))
  41  FORMAT(1H136X37HINPUT MATRIX  (AFTER TRANSGENERATION))
  42  FORMAT(3(3X1H./)/)
  43  FORMAT(41X29H-FIRST AND LAST 10 ROWS ONLY-)
  45  FORMAT(1H I4,1H.F14.4)
  46  FORMAT(1H136X47HINPUT MATRIX  (ORDERED - AFTER TRANSGENERATION))
  47  FORMAT(3X3HROW//)
 1010 FORMAT(46H-ALL GROUPS COMBINED (SPECIAL VALUES EXCLUDED) 20X,46HSU
     1M OF SQUARES    DF    MEAN SQUARE    F RATIO/1H0,13X,7HMEAN   F12.
     24,24X,7HBETWEENF13.4,I9,F14.4,F11.4/13X,8H S DEV  F12.4,24X,7HWITH
     3IN F13.4,I9,F14.4/13X,8H MAXIMUMF12.4,24X,7HTOTAL  F13.4,I9/13X,8H
     4 MINIMUMF12.4)
 1111 FORMAT (1H013X,64HTABULATIONS AND COMPUTATIONS WHICH FOLLOW EXCLUD
     1E SPECIAL VALUES /6X8HINTERVAL//)
 1112 FORMAT(1H 5X7HSPECIAL/7X6HVALUES//)
 1300 FORMAT(A6,I3,I1,5F7.0)
 1500 FORMAT(1H0,12X75HCONTROL CARDS OUT OF ORDER OR NOT PROPERLY PUNCHE
     1D. PROGRAM CANNOT PROCEED.)
 1501 FORMAT(1H036X45HNUMBER OF VARIABLES ADDED CANNOT BE NEGATIVE.)
  888 FORMAT(1H0,23X,71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPEC
     1IFIED, ASSUMED TO BE 1.)
C
      END
C             SUBROUTINE CLINT FOR BMD07D              MAY 20, 1966
      SUBROUTINE CLINT (NV)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
      COMMON  ZZ
      COMMON  X      , NVAR   , NCAS   , NTR    , CP     , IGR
      COMMON  NCP    , NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C
      IF(NCI)10,10,11
 10   FNCA=NCAS
      G=NG
      CIN=10.0*ALOG10(FNCA/G)
      NCI=CIN
   11 IF(NCI-5)12,15,15
 12   NCI=5
   15 FNCI=NCI-1
      IF(30-NCI)16,18,18
 16   NCI=30
      FNCI=29.0
   18 IF(SMLX(NV)-BIGX(NV))185,22,185
  185 CALL SCALE1(SMLX(NV),BIGX(NV),FNCI,XMIN,XIJ)
      ICI=NCI
   19 NCICP(NV)=ICI
      CICP(1)=XMIN
      ICI=ICI+1
      DO 20 J=2,ICI
      CICP(J)=CICP(J-1)+XIJ
   20 CONTINUE
      RETURN
   22 ICI=5
      XIJ=0.5
      XMIN=SMLX(NV)-1.0
C
C     PRINT ALL OF INPUT MATRIX AFTER TRANSGENERATION, IF DESIRED
C
      GO TO 19
      END
      SUBROUTINE SCALE1(YMIN,YMAX,YINT,TYMIN,YIJ)
      DIMENSION C(10)
      DATA C/1.0,1.5,2.0,3.0,4.0,5.0,7.5,10.0,15.0,20.0/
      TEST=1.0/(2.0**20)
   50 YR=YMAX-YMIN
      TT=YR/YINT
      J=ALOG10(TT)+TEST
      E=10.0**J
      TT=TT/E
      I=0
      IF(TT-1.0+TEST)205,201,201
  205 TT=TT*10.0
      E=E/10.0
  201 I=I+1
      IF(10-I)1,2,2
    1 E=E*10.0
      TT=TT/10.0
      I=1
    2 IF(TT-C(I))233,202,201
  233 YIJ=C(I)*E
      GO TO 203
  202 Y=YMIN/C(I)
      J=Y
      T=J
      IF(0.0001-ABS(T-Y))204,233,233
  204 YIJ=C(I+1)*E
  203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001
      K=X
      IF(K)235,234,240
  235 Y=K
      IF(X-Y)236,240,236
  236 K=K-1
  240 TYMIN=K
      TYMIN=YIJ*TYMIN
      TYMAX=TYMIN + YINT*YIJ
      IF(YMAX-TYMAX-TEST)10,10,201
  234 IF(YMIN)235,240,240
   10 RETURN
      END
C             SUBROUTINE CORR  FOR BMD07D              MAY 20, 1966
      SUBROUTINE CORR
C
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
       DOUBLE PRECISION TRYME(10), BLANK
       COMMON / LABS / TRYME
       DATA BLANK / '        ' /
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD   , IPNT
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C     SUBROUTINE CORR COMPUTES CORRELATION COEFFICIENTS FOR EACH
C      GROUP AND PRINTS THEM OUT IN THE FORM OF THE LOWER TRIANGLE
C      INCLUDING THE PRINCIPAL DIAGONAL.  SPECIAL VALUES ARE EXCLUDED
C     FROM THE COMPUTATIONS.
C
      DATA SPCVAL/4H-7CV/
C
  85  IGF = 1
      LAST = (NVAR*(1+NVAR))/2
      WRITE (6,9101)NG
      ASSIGN 100 TO KSKIP
      DO 40 NV=1,NG
      DO 810 I = 1,LAST
      ZZ(I) = 0.0
  810 CONTINUE
 811  IG = IGR(NV)
      KKK = (IGF - 1)*NVAR
      IKK = KKK
      IGF = IG + IGF
 255  IF (IG) 256,256,7
 256   IF (TRYME(NV).EQ.BLANK     ) WRITE(6,1000) NV
       IF (TRYME(NV).NE.BLANK     ) WRITE(6,1001) NV,TRYME(NV)
      ASSIGN 105 TO KSKIP
      GO TO 40
C
 7    KK=(IGF-2)*NVAR
      JKK = KK
 8    M=0
      DO 1 I = 1, NVAR
      SUMX = 0.0
      SUMSQX = 0.0
      XIG=0.0
      KK = KK + 1
      KKK = KKK + 1
      DO 6 K = KKK,KK,NVAR
      IF(X(K).EQ.SPCVAL)GO TO 6
 15   SUMX = X(K) + SUMX
      SUMSQX = X(K)**2 + SUMSQX
  17  XIG=XIG+1.0
    6  CONTINUE
      DO 2 J = 1, I
      SUMX1=SUMX
 60   SUMY1=0.0
      SUMY = 0.0
      SUMSQY = 0.0
      SUMXY = 0.0
      YIG=0.0
      XYIG=0.0
      IK = I + IKK
      JKIG = J + JKK
      KKJ = J + IKK
      DO 5 K = KKJ,JKIG,NVAR
      IF(X(K).EQ.SPCVAL)GO TO 705
 65   SUMY = X(K) + SUMY
      SUMSQY = X(K)**2 + SUMSQY
  68  YIG=YIG+1.0
      IF(X(IK).EQ.SPCVAL)GO TO 715
  71  SUMXY = X(IK)*X(K) + SUMXY
  72  XYIG=XYIG+1.0
      GO TO 75
C
  705 IF(X(IK).EQ.SPCVAL)GO TO 75
 710  SUMX1=SUMX1-X(IK)
      GO TO 75
C
 715  SUMY1=SUMY1+X(K)
  75  IK = IK + NVAR
    5  CONTINUE
      SUMY1=SUMY-SUMY1
 50   M = M + 1
      IF(XIG*YIG*XYIG)51,505,51
 51   A=SQRT((SUMSQX-(SUMX**2)/XIG)*(SUMSQY-(SUMY**2)/YIG))
      IF(A)515,505,515
 515  IF(XYIG-1.0)550,505,550
 550  ZZ(M)=((SUMXY-(SUMX1*SUMY1)/XYIG)* (SQRT((XIG-1.0)*(YIG-1.0))))/(A
     1*(XYIG-1.0))
      GO TO 2
C
 505  ZZ(M)=99.0
    2 CONTINUE
    1 CONTINUE
       NPAGE = 0
      KVAR = (NVAR+7)/8
      ISTART = 1
      LLL = 0
      GO TO KSKIP,(100,105)
 100  ASSIGN 105 TO KSKIP
      GO TO 110
C
 105  WRITE (6,9105)
 110  DO912 II = 1, KVAR
      IF(II-1)90,900,90
 90   WRITE (6,9105)
 900  KOUNT = LLL
      LL = LLL + 9
       NPAGE = NPAGE + 1
       WRITE (6,9103)  TRYME(NV), NV, NPAGE
      KK = II-1
      KK = KK-5*(KK/5)
      IF(-KK)99,913,913
   99 DO 97 III= 1, KK
      WRITE (6,9104)
   97 CONTINUE
  913 I = ISTART
       IBEGN = KOUNT+1
       IFINSH = MIN0(NVAR,IBEGN+7)
       WRITE (6,9136) (MXL, MXL=IBEGN,IFINSH)
 9136  FORMAT (I16,7I14)
      DO91 IJ = 1, 8
      K = IJ + I- 1
       KOUNT = KOUNT+1
       WRITE (6,9102) KOUNT, (ZZ(N),N=I, K)
      I = KOUNT + I
      IF (KOUNT - NVAR) 91,40,40
   91 CONTINUE
      ISTART = K + LL
      GO TO 92
C
  910 DO 93 L = 1, 8
      JK = I + 7
       KOUNT = KOUNT+1
       WRITE (6,9102) KOUNT, (ZZ(N),N=I,JK)
      I = I + KOUNT
      IF ( KOUNT - NVAR ) 93,911,911
   93 CONTINUE
   92 IF (40 - KOUNT) 914,94,910
  914 IF ( KOUNT - 80) 910,94,910
   94 NPAGE = NPAGE + 1
      WRITE (6,9105)
       WRITE (6,9103)  TRYME(NV), NV, NPAGE
       IBEGN = KOUNT+1
       IFINSH = MIN0(NVAR,IBEGN+7)
       WRITE (6,9136)(MXL,MXL=IBEGN,IFINSH)
      GO TO910
C
  911 LLL   = LLL+8
  912 CONTINUE
  40  CONTINUE
      RETURN
C
 1000 FORMAT(1H0,5HGROUPI3,41H IS EMPTY, THEREFORE, THERE IS NO MATRIX.)
 1001  FORMAT(1X,'GROUP',I3,', ',A8,', IS EMPTY, THEREFORE, THERE IS NO
     *MATRIX.')
 9101 FORMAT (1H1 40X, 22HCORRELATION MATRICES ( I3,1H)//10X,102HTHESE A
     1RE SYMMETRIC MATRICES AND THEREFORE ARE PRINTED IN HALF FORM, INCL
     2UDING THE PRINCIPAL DIAGONAL./10X86HA VALUE OF 99.0 INDICATES THE
     3COEFFICIENT IS NOT COMPUTABLE DUE TO A ZERO DENOMINATOR.//)
 9102  FORMAT(I4,8F14.4)
 9103  FORMAT (7X,A8,'  GROUP',I3,6X,'(PAGE',I3,')'//)
 9104 FORMAT (1H ////////)
 9105 FORMAT(1H1/////)
      END
C             SUBROUTINE DESQ  FOR BMD07D              MAY 20, 1966
      SUBROUTINE DESQ (L1, DEVSQ)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
      EXTERNAL SIGN
      CAS=NCAS-1
      CALL YMEAN (L1, YMEA )
      L=NS(L1)
      SUM=0.0
      DO 100 J=1,NCAS
      I=(J-1)*NVAR+L1
      IF (L) 52, 52, 45
 45   DO 50 K=1,L
      IF(X(I)-SPV(L1,K))50,46,50
 46   B=SIGN(1.0,SPV(L1,K))
      C=SIGN(1.0, X(I))
      IF(B+C)55,50,55
 50   CONTINUE
   52 SUM=SUM+(X(I)-YMEA)**2
      GO TO 100
C
 55   CAS=CAS-1.0
 100  CONTINUE
      DEVSQ=SQRT((1.0/CAS)*SUM)
      RETURN
      END
C             SUBROUTINE DIVIDE FOR BMD07D             MAY 20, 1966
      SUBROUTINE DIVIDE (NVAB)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
      COMMON  ZZ
      COMMON  X      , NVAR   , NCAS   , NTR    , CP     , IGR
      COMMON  NCP    , NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
C         MATRIX ORDERING BASED ON ONE VARIABLE - NVAB
C
      NVNC=NVAR*NCAS
      NVN=NVNC-NVAR-NVAR+NVAB
      DO 1000 K=NVAB,NVN,NVAR
      KK=K+NVAR
      L=K-NVAB+1
      M=L
      CHECK=X(K)
 75   IF(X(KK)-CHECK)100,115,115
 100  M=KK-NVAB+1
      CHECK=X(KK)
 115  KK=KK+NVAR
 110  IF(NVNC-KK)200,75,75
 200  IF(M-L)201,1000,201
 201  DO 205 J=1,NVAR
      DUM=X(L)
      X(L)=X(M)
      X(M)=DUM
      L=L+1
      M=M+1
 205  CONTINUE
 1000 CONTINUE
      K=NCP+1
      M=K
      CP(K)=10.0**6
      DO 63 I=1,K
      IGP(I)=0
 63   CONTINUE
      I=NVN+NVAR
 64   DO 66 J=NVAB,I,NVAR
      IF (X(J)-CP(K)) 65, 66, 66
 65   IGP(K)=IGP(K)+1
 66   CONTINUE
      K=K-1
      IF (K) 67, 67, 64
 67   DO 68 K=2,M
      L=K-1
      IGR(K)=IGP(K)-IGP(L)
 68   CONTINUE
      IGR(1)=IGP(1)
      RETURN
      END
C             SUBROUTINE MAMIN  FOR BMD07D             MAY 20, 1966
      SUBROUTINE MAMIN (NV)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10)
      COMMON  ZZ
      COMMON  X      , NVAR   , NCAS   , NTR    , CP     , IGR
      COMMON  NCP    , NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
      EXTERNAL SIGN
      TENSIX=10.0**6
      SMLX(NV)=TENSIX
      BIGX(NV)=-SMLX(NV)
      JJ=NS(NV)
      IF(JJ)10,10,15
 10   ASSIGN 52 TO JTIMES
      GO TO 20
C
 15   ASSIGN 50 TO JTIMES
 20   J=((NCAS-1)*NVAR)+NV
      DO 60 K=NV,J,NVAR
      GO TO JTIMES,(52,50)
 50   DO 51 I=1,JJ
      IF (X(K)-SPV(NV,I)) 51, 501, 51
 501  B=SIGN(1.0, SPV(NV,I))
      C=SIGN(1.0, X(K))
      IF (B+C) 60, 51, 60
 51   CONTINUE
 52   BIGX(NV)=AMAX1(BIGX(NV),X(K))
      SMLX(NV)=AMIN1(SMLX(NV), X(K))
 60   CONTINUE
      IF(SMLX(NV)-TENSIX)100,70,100
 70   IF(BIGX(NV)+TENSIX)100,80,100
 80   SMLX(NV)=0.0
      BIGX(NV)=0.0
 100  RETURN
      END
C          SUBROUTINE PLUG FOR BMD07D                  MAY 20, 1966
      SUBROUTINE PLUG (NV,NABC)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500),SXX)
C
      DATA SPCVAL/4H-7CV/
       EXTERNAL SIGN
C
      ASSIGN 86 TO KSKIP
      JR=NS(NV)
      IF (NABC - 1) 10,10,15
  10  ASSIGN 88 TO KSKIP
      IF(-JR)15,998,998
   15 DO 50 I=1,10
      DO 50 J=1,30
      K000FX(I,J)=0
 50   CONTINUE
      KKP=NCICP(NV)+1
      KOUNT=0
      KOU=0
      DO 200 K=1,NG
      MN=IGR(K)
      IF(-MN)80,200,200
 80   DO 150 J=1,MN
      L=1
      I=NVAR*(KOUNT+J-1)+NV
      IF(-JR)85,100,100
  85  GO TO KSKIP,(86,88)
   86 IF(X(I).EQ.SPCVAL)GO TO 140
 100   IF ((CICP(L)-X(I))-.00001) 101,101,110
 101  L=L+1
      IF (L-KKP) 100, 100, 200
C
  88  DO 90 JS=1,JR
      IF(X(I).NE.SPV(NV,JS))GO TO 90
 89   B=SIGN(1.0, SPV(NV,JS))
      C=SIGN(1.0, X(I))
 897  IF(B+C) 899,90,899
  899 K000FX(K,JS) = K000FX(K,JS) + 1
      X(I)=SPCVAL
 90   CONTINUE
      GO TO 140
C
 110  LL=L-1
      K000FX(K,LL)=K000FX(K,LL)+1
 140  KOU=KOU+1
 150  CONTINUE
      KOUNT=KOU
 200  CONTINUE
 998  RETURN
      END
C             SUBROUTINE RDLBL FOR BMD07D              MAY 20, 1966
C     SUBROUTINE TO READ IN LABELS CARDS, STORE THEM IN ARRAY,
C     AND SUBSTITUTE ZEROS FOR UNLABELED VARIABLES
C     NVAR IS TOTAL NUMBER OF VARIABLES
C     NLBVAR IS NUMBER OF LABELED VARIABLES EXPECTED
C
      SUBROUTINE RDLBL(NLBVAR,NVAR,ARRAY)
      DOUBLE PRECISION DUMY,ARRAY
      DIMENSION ARRAY(1),IDUM(7),DUMY(7)
      DATA ALABEL/'LAB'/
C     CLEAR VARIABLES
      DO 1 I=1,NVAR
   1  ARRAY(I)=0.0
C     IF NO LABELS, RETURN
      IF(-NLBVAR)2,9,9
   2  N=0
C     READ 1 LABELS CARD
  20  READ (5,3) TEST,(IDUM(J),DUMY(J),J=1,7)
   3  FORMAT(A3,3X,7(I4,A6))
C     TEST FOR 'LAB' IN FIRST 3 COLS.
      IF(TEST.EQ.ALABEL)GO TO 6
C     ERROR--PRINT MESSAGE AND QUIT
   4  WRITE (6,5)
   5  FORMAT(36H0LABELS CARD NOT FOUND WHEN EXPECTED)
      STOP
C     EXAMINE 7 FIELDS
   6  DO 8 J=1,7
      K=IDUM(J)
C     TEST INDEX.  IF 0, IGNORE.  IF ILLEGAL, PRINT MESSAGE AND
C     IGNORE EXCEPT TO COUNT
      IF(-K)10,8,11
  10  IF(K-NVAR) 7,7,11
  11  WRITE (6,12)K,DUMY(J)
   12 FORMAT('0LABELS CARD INDEX',I7,' INCORRECT. LABEL ',A8,'IGNORED.')
C
      GO TO 13
C     MOVE LABEL TO ARRAY
   7  ARRAY(K)=DUMY(J)
C     STEP NUMBER OF VARIABLES
  13  N=N+1
C     TEST FOR END. IF END, RETURN. IF NOT, SCAN OTHER FIELDS.
      IF(N-NLBVAR) 8,9,9
   8  CONTINUE
      GO TO 20
   9  RETURN
      END
      SUBROUTINE RITE (L,NG,NABC)
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3 XMN(100), SX(10), DX(10), XL(10), SXX(100,10),OC(10)
      DATA OC/1H ,1H1,1H2,1H3,1H4,1H5,1H6,1H7,1H8,1H9/
       DATA ZERO / '0' /
      COMMON  ZZ
      COMMON  X      , NVAR   , NCAS   , NTR    , CP     , IGR
      COMMON  NCP    , NCI    , KCICP  , NERR   , QZ     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
C
      J=L
      NABC = NABC
      DATA STAR  /1H*/
      DO 700 K=2,113
      VEC(K) = OC(1)
 700  CONTINUE
      DO 799 I=1,NG
      NN=K000FX(I,J)
      IF(-NN)711,799,799
 711  MA=((I-1)*11)+2
      MB=MA+(NN-1)
      MC=MA+8
      MD=MA+9
      ME=MA+10
      MF=MA+7
      MG=MA+6
      IF (NN-10) 712, 712, 714
 712  DO 713 K=MA,MB
      VEC(K)=STAR
 713  CONTINUE
      GO TO 799
C
 714  IF (NN-99) 715, 715, 717
 715  NNN=1
      DO 716 K=MA,MC
      VEC(K)=STAR
 716  CONTINUE
      NN1=NN/10
      NN2=NN-(10*NN1)
      GO TO 750
C
 717  IF (NN-999) 718, 718, 720
 718   NNN=2
      DO 719 K=MA,MF
      VEC(K)=STAR
 719  CONTINUE
      KNN=NN/10
      NN1=NN/100
      NN2=KNN-(10*NN1)
      NN3=NN-(10*KNN)
      GO TO 750
C
 720  IF (NN-9999) 721, 721, 799
 721  NNN=3
      DO 722 K=MA, MG
      VEC(K)=STAR
 722  CONTINUE
      NN1=NN/1000
      INN=NN/100
      JNN=NN/10
      NN2=INN-(10*NN1)
      NN3=JNN-(10*INN)
      NN4=NN-(10*JNN)
 750  IF (NNN-2) 751, 756, 771
 751  MZ=MD
      IJ=2
 7511 IF(-NN1)752,760,760
 752  GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN1
 753  IJ=IJ-1
      IF(-IJ)754,799,799
 754  MZ=ME
 7541 IF(-NN2)755,760,760
 755  GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN2
 756  IJ=2
      MZ=MC
      IF (NN1) 760, 760, 752
C
 757  IJ=IJ-1
      IF(-IJ)758,759,799
 758  MZ=MD
      IF (NN2) 760, 760, 755
C
 759  MZ=ME
 7591 IF(-NN3)770,760,760
 770  GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN3
C
 771  IJ=2
      IJK=2
      MZ=MF
      GO TO 7511
C
 772  IJ=IJ-1
      IF(-IJ)773,774,775
 773  MZ=MC
      GO TO 7541
C
 774  MZ=MD
      GO TO 7591
C
 775  IJK=IJK-1
      IF(-IJK)776,799,799
 776  MZ=ME
      IF(-NN4)777,760,760
 777  GO TO (761, 762, 763, 764, 765, 766, 767, 768, 769), NN4
C
 760   VEC(MZ) = ZERO
      GO TO (753, 757, 772), NNN
C
  761 VEC(MZ) = OC(2)
      GO TO (753, 757, 772), NNN
C
  762 VEC(MZ) = OC(3)
      GO TO (753, 757, 772), NNN
C
  763 VEC(MZ) = OC(4)
      GO TO (753, 757, 772), NNN
C
  764 VEC(MZ) = OC(5)
      GO TO (753, 757, 772), NNN
C
  765 VEC(MZ) = OC(6)
      GO TO (753, 757, 772), NNN
C
  766 VEC(MZ) = OC(7)
      GO TO (753, 757, 772), NNN
C
  767 VEC(MZ) = OC(8)
      GO TO (753, 757, 772), NNN
C
  768 VEC(MZ) = OC(9)
      GO TO (753, 757, 772), NNN
C
  769 VEC(MZ) = OC(10)
      GO TO (753, 757, 772), NNN
C
 799  CONTINUE
      HOLD = CICP(J)
       GO TO (4001,4002), NABC
 4001 CICP(J) =  SPV(NTR,J)
      GO TO 4004
C
 4002 IF(CICP(J))4004,4003,4004
 4003 CICP(J)=0.0
 4004 WRITE (6,4000)CICP(J), (VEC(MM), MM = 2, 113)
      CICP(J) = HOLD
      RETURN
 4000 FORMAT(1H ,F12.3,2H )113A1)
      END
C             SUBROUTINE  TEST  FOR BMD07D             MAY 20, 1966
      SUBROUTINE TEST(N1,N2,N3,C)
C
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
      EXTERNAL SIGN
      IF(N3)600,600,100
 100  DO 500 L=1,N3
      IF(X(N1).EQ.SPV(N2,L))GO TO 1000
 500  CONTINUE
 600  C=1.0
      RETURN
C
 1000 IF(X(N1))1050,1025,1050
 1025 B=SIGN(1.0,SPV(N2,L))
      C=SIGN(1.0,X(N1))
      IF(B+C)1050,500,1050
 1050 C=0.0
 2000 RETURN
      END
C        SUBROUTINE TPWD FOR BMD07D                    MAY 20, 1966
      SUBROUTINE TPWD(NT1,NT2)
      IF(NT1)40,10,12
 10   NT1=5
   12 IF(NT1 .EQ. NT2) GO TO 19
      IF(NT2.EQ.5)GO TO 18
   17 REWIND NT2
   19 IF(NT1 .EQ. 5) GO TO 24
   18 IF(NT1 .EQ. 6) GO TO 40
      REWIND NT1
 24   NT2=NT1
      RETURN
 40   WRITE (6,49)
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)
      STOP
      END
C        SUBROUTINE TVA FOR BMD07D                     MAY 20, 1966
      SUBROUTINE TVA
C
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
      COMMON  ZZ     , X
      COMMON  NVAR   , NCAS   , NTR    , CP     , IGR    , NCP
      COMMON  NCI    , KCICP  , NERR   , NG     , NADD
      ASN(XX) = ATAN(XX/SQRT(1.0-XX**2))
C
      DOUBLE PRECISION TRNGEN,COB
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
      DATA TRNGEN/6HTRNGEN/
C
      ON=NCAS+1
      NORM=0
      WRITE (6,10)
      WRITE (6,11)
      NERR=0
      DO 1000 I=1,NTR
      READ (5,12)COB,NE,NC,NV,CO
      IF(COB.NE.TRNGEN)GO TO 250
 45   WRITE (6,13)I, NE, NC, NV, CO
      IF(NE-NVAR)50,50,290
 50   NSN=NS(NV)
      NTIMES=1
      LL=CO
      IF(NV-NVAR)5005,5005,290
 5005 IF(10-NC)51,59,59
 51   IF(15-NC)52,59,55
 52   IF(16-NC)53,55,59
 53   IF(NC-23)59,55,275
 55   NSM=NS(LL)
      NTIMES=2
      IF(LL-NVAR)59,59,290
 59   IF(-NC)60,1000,275
   60 IF(-NERR)605,605,1000
  605 NVNC=NVAR*(NCAS-1)+NV
      KK=NE-NVAR
      KKK=LL-NVAR
      DO 910 K=NV,NVNC,NVAR
      D1=X(K)
      KK=KK+NVAR
      KKK=KKK+NVAR
      IF (NSN) 61, 61, 64
 61   GO TO (75,62),NTIMES
 62   IF(-NSM)63,75,75
 63   CALL TEST(KKK,LL,NSM,CHECK)
      IF(CHECK)75,70,75
 64   CALL TEST(K,NV,NSN,CHECK)
      IF(CHECK)61,70,61
 70   IF (NS(NE)) 71, 71, 72
 71   NS(NE)=1
      SPV(NE, 1) = -9909.9909
   72 D2=SPV(NE,1)
      GO TO 900
C
 75   GO TO (100, 105, 110, 115, 120, 125, 130, 135, 140, 145, 150, 155,
     1160, 165, 170, 175, 180, 185, 190, 195, 200, 205, 210 ), NC
  100 IF(-D1)102,101,300
  102 D2=SQRT(D1)
      GO TO 900
  101 D2=0.0
      GO TO 900
  105 IF(-D1)107,106,300
  107 D2=SQRT(D1)+SQRT(D1+1.0)
      GO TO 900
  106 D2=1.0
      GO TO 900
  110 IF(-D1)111,300,300
  111 D2=ALOG10(D1)
      GO TO 900
  115 D2=EXP(D1)
      GO TO 900
  120 IF(-D1)121,101,300
  121 IF(D1-1.0)123,122,300
  123 D2=ASN(SQRT(D1))
      GO TO 900
  122 D2=1.57079632
      GO TO 900
  125 A=D1/ON
      B=A+1.0/ON
      IF(-A)128,126,300
 128  IF(-B)1290,129,300
 1290 A=SQRT(A)
      B=SQRT(B)
      D2=ASN(A)+ASN(B)
      GO TO 900
 126  IF(-B)127,101,300
  127 D2=ASN(SQRT(B))
      GO TO 900
  129 D2=ASN(SQRT(A))
      GO TO 900
  130 IF(D1)131,300,131
  131 D2=1.0/D1
      GO TO 900
  135 D2=D1+CO
      GO TO 900
  140 D2=D1*CO
      GO TO 900
 145  DO 146 JJJ=1,15
      AB=ABS(CO*2.0**JJJ)
      IF (AB-.5) 146, 147, 146
 146  CONTINUE
      GO TO 148
  147 IF(-D1)148,101,300
  148 D2=D1**CO
      GO TO 900
  150 D2=D1+X(KKK)
      GO TO 900
  155 D2=D1-X(KKK)
      GO TO 900
  160 D2=D1*X(KKK)
      GO TO 900
  165 IF(X(KKK))166,300,166
  166 D2=D1/X(KKK)
      GO TO 900
  170 IF(D1-CO)101,106,106
  175 IF(D1-X(KKK))101,106,106
  180 IF(-D1)181,300,300
  181 D2=ALOG(D1)
      GO TO 900
 185  GO TO(186,187),LTIMES
 186  LTIMES=2
      CALL YMEAN (NV, YMEA)
  187 D2=D1-YMEA
      GO TO 900
 190  GO TO (191,192),LTIMES
 191  LTIMES=2
      CALL DESQ(NV,DEVSQ)
  192 D2=D1/DEVSQ
      GO TO 900
  195 D2=SIN(D1)
      GO TO 900
  200 D2=COS(D1)
      GO TO 900
  205 D2=ATAN(D1)
      GO TO 900
 210  DO 211 JJJ=1,15
      AC=ABS(X(KKK)*2.0**JJJ)
      IF (AC-.5) 211, 212, 211
 211  CONTINUE
      GO TO 213
  212 IF(-D1)213,101,300
  213 IF(X(KKK))214,214,215
  214 IF(D1)215,300,215
  215 D2=D1**X(KKK)
  900 X(KK)=D2
  910 CONTINUE
      IF (NORM) 2000, 1000, 1000
C
 250  NERR=-999
      WRITE (6,17)
      GO TO 2000
C
  275 WRITE (6,18)I
  280 NERR=-999
      GO TO 1000
  290 WRITE (6,19)
      GO TO 280
C
 300  NORM=-999
      NERR=-999
      WRITE (6,14)I
      WRITE (6,15)K
 1000 CONTINUE
      IF (NERR) 2000, 3000, 3000
 2000 WRITE (6,16)
 3000 RETURN
C
 10   FORMAT (1H06X, 23HTRANS GENERATOR CARD(S))
 11   FORMAT (46H0CARD    NEW     TRANS    ORIG.   ORIG. VAR(B)/45H  NO.
     1 VARIABLE   CODE    VAR(A)   OR CONSTANT  )
  12  FORMAT(A6,I3,I2,I3,F6.0)
 13   FORMAT(I4,I8,2I9,4XF10.5)
 14   FORMAT (55H0THE INSTRUCTIONS INDICATED ON TRANS GENERATOR CARD NO.
     1 I2, 1X, 3HRE-/60H SULTED IN THE VIOLATION OF A RESTRICTION FOR TH
     2IS TRANSFOR-/58H MATION. THE VIOLATION OCCURED FOR THE ITEMS LISTE
     3D BELOW.)
 15   FORMAT (10H0ITEM NO. I5)
 16   FORMAT (41H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM )
 17   FORMAT(33H0TRANSGENERATOR CARD OUT OF ORDER)
 18   FORMAT(1H039X19HTRANSGENERATOR CARDI3,18H HAS ILLEGAL CODE.)
   19 FORMAT(1H0,26X,65HVARIABLE INDEX ON ABOVE TRANSGENERATION CARD IS   
     1GREATER THAN P+Q.)
      END
C             SUBROUTINE YMEAN FOR BMD07D              MAY 20, 1966
      SUBROUTINE YMEAN (M1,YMEA)
C
      DIMENSION X(4000),NS(100),SPV(100,5),CP(10),
     1 OCC(100), INTEG(10), ZZ(5050), IGR(10), BIGX(100), SMLX(100),
     2 CICP(31), K000FX(10,30), NCICP(100), VEC(113),IGP(10),NCN(100),
     3XMN(100),SX(10),DX(10),XL(10),SXX(100,10)
      COMMON  ZZ
      COMMON  X      , NVAR   , NCAS   , NTR    , CP     , IGR
      COMMON  NCP    , NCI    , KCICP  , NERR   , NG     , NADD
      EQUIVALENCE (ZZ(101),BIGX),   (ZZ(202),SMLX),               (ZZ(30
     13), NCICP), (ZZ(520), VEC), (ZZ(634), INTEG), (ZZ(755), K000
     2FX), (ZZ(2551), XMN), (ZZ(2751), SPV), (ZZ(2651), NS), (ZZ(1056),
     3NCN), (ZZ(1289), CICP), (ZZ(1320), SX), (ZZ(1331),DX), (ZZ(1342),
     4XL), (ZZ(1353), IGP), (ZZ(3500), SXX)
       EXTERNAL SIGN
C
      L=NS(M1)
      CAS=NCAS
      XNN=0
      DO 100 J=1,NCAS
      I=(J-1)*NVAR+M1
      IF (L) 51, 51, 45
 45   DO 50 K=1,L
      IF(X(I)-SPV(M1,K))50,55,50
 55    IF (SIGN(1.0,X(I))-SIGN(1.0,SPV(M1,K))) 50,57,50
 50   CONTINUE
   51 XNN=XNN+X(I)
      GO TO 100
 57    CAS = CAS-1.0
 100  CONTINUE
      YMEA=XNN/CAS
      RETURN
      END