PDP-10 Archive: decus/20-0137/bmd/bmd08d.for from decuslib20-05

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd08d.for
There is 1 other file named bmd08d.for in the archive. Click here to see a list.
C        CROSS TABULATION WITH VARIABLE STACKING     MARCH  1, 1966
C        THIS IS A SIFTED VERSION OF BMD08D ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
      DIMENSION MRANGX(40),MRANGY(100),JOUTX(50),WORD(200),
     1IOUTY( 50),              KPOINT(100,40),MARGY(100),MARGX(40),
     2IDATA( 8000)        ,NEW(100),MMAX(100),MMIN(100),LEVEL(22),
     3ITEM( 50),ASK(120), FMT(180)
      COMMON  ASK    , FMT
      COMMON  MRANGY , JOUTX  , IOUTY  , KPOINT , MARGY  , MARGX
      COMMON  ISTART , IEND   , IDATA  , MMAX   , MMIN   , ITEM
      COMMON  NTOT   , LIMITY , LIMITX , MAXX   , MAXY   , MINX
      COMMON  MINY   , NEWX   , NEWY   , JUNKX  , IOVER  , JUNKXY
      COMMON  JSTART , JEND
      EQUIVALENCE(ASK,NEW),(MRANGX,FMT(51)),(LEVEL,FMT(91))
C
  209 FORMAT('1BMD08D - CROSS TABULATION WITH VARIABLE STACKING - REVISE
     1D JUNE 26, 1969'/
     240H HEALTH SCIENCES COMPUTING FACILITY,UCLA/14H PROBLEM CODE 7(2H.
     3 ),A6,/18H NO. OF VARIABLES 6(2H. ),I4,/14H NO. OF CASES 8(2H. ),
     4I4,/24H NO. OF TRNGEN CARD(S)  3(2H. ),I4,/32H NO. OF VARIABLE FOR
     5MAT CARD(S)  ,I2,//)
C
  101 FORMAT(9H0VARIABLEI3,33H IS CROSS TABULATED WITH VARIABLEI3//)
  102 FORMAT(2H0(I2,1H)13X34H(EXTREME RIGHT VALUE IS ROW TOTAL))
  103 FORMAT(6H RANGE)
  137 FORMAT(3H  (I2,1H)I5,17I6)
  138 FORMAT(8H  RANGE  18I6//)
  139 FORMAT(7H0COLUMNI4,17I6)
  140 FORMAT(8H  TOTAL  18I6//)
  141 FORMAT(13H0GRAND TOTAL=I6//)
  142 FORMAT(3X,I5,9X,I6,10X,I6)
  146 FORMAT(19H0VALUES NOT ENTEREDI4)
  147 FORMAT(11H   CASE NO.5X,8HVARIABLEI3,5X,8HVARIABLEI3)
  148 FORMAT(2A6,I3,I4,I3,I3,I2,I3,I2,34X,3I2)
  149 FORMAT(A6,10I6)
  150 FORMAT(18A4)
  151 FORMAT(2I2,4I5)
 154  FORMAT(61H0(THE FOLLOWING COMPUTATIONS ARE BASED ON ALL DATA AS EN
     1TERED/49H EVEN IF SOME ARE EXCLUDED FROM THE ABOVE TABLE).//
     225H CORRELATION COEFFICIENT F7.4,/
     32(6H MEAN(,I3,2H)=,F15.5,3X,3HSD(,I3,2H)=,F15.5,/),//)
  155 FORMAT(10H SELECTIONI4,1H-I2//)
  156 FORMAT(1H0)
  157 FORMAT(A6,I3,I2,20I3)
  158 FORMAT(12I6)
  159 FORMAT(22H0NO ENTRY IN THE TABLE//)
  205 FORMAT(45H0CONTROL CARDS INCORRECTLY ORDERED OR PUNCHED)
  214 FORMAT(23H CHI-SQUARE (OF TABLE) F15.5,/
     14H DF=I5)
  215 FORMAT(26H0CHI-SQUARE NOT COMPUTABLE)
  601 FORMAT(' NUMBER OF VARIABLES INCORRECTLY SPECIFIED')
  603 FORMAT(' TOTAL DATA INPUT CANNOT EXCEED  8000 BEFORE OR AFTER TRAN
     1SGENERATION')
  605 FORMAT(' NUMBER OF SELECTION CARDS INCORRECTLY SPECIFIED')
  607 FORMAT(' NUMBER OF VARIABLES AFTER TRANSGENERATION CANNOT EXCEED 1
     100')
  609 FORMAT(' NUMBER OF CASES INCORRECTLY SPECIFIED')
  611 FORMAT(' NUMBER OF VARIABLES TO BE CROSS TABULATED WITH BASE VARIA
     1BLE ON SELECT CARD',1X,I6,' IS GREATER THAN 20')
  613 FORMAT(' PROGRAM EXPECTED RANGES CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
  615 FORMAT(' NUMBER OF TRANSGENERATION CARDS CANNOT BE NEGATIVE')
  619 FORMAT(' PROGRAM EXPECTED SELECT CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
  621 FORMAT(' CHI-SQUARE IS NEGATIVE')
  622 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE
     1 FOLLOWING'/1X,A6)
  624 FORMAT(' THE MAXIMUM AND MINIMUM FOR VARIABLE',1X,I6,' APPEARS TO
     1 BE REVERSED, PROGRAM CANNOT CONTINUE')
 2000 FORMAT(24H NUMBER OF REPLICATIONS=I5//)
 2001 FORMAT(41H VARIABLE MAXIMUM MINIMUM  (AS SPECIFIED))
 2002 FORMAT(1H I6,2I8)
 4001 FORMAT(7X,112A1)
 4002 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
 5054 FORMAT(10H0VARIABLE I3,4H OR I3,31H HAVE RANGE GREATER THAN LIMITS
     1//)
 5120 FORMAT(10H0ERROR IN A6,6H CARD.)
 7002 FORMAT(1H05X,A6,24H IS CROSS TABULATED WITH6X,A6,3X,3HOR,)
 7007 FORMAT(1H A6)
 7011 FORMAT(1H A6,1X,18I6,//)
C
      DOUBLE PRECISION       A123,B123,C123,E123,CODE,WORD ,COB
C
      DATA P1,P2,A123,B123,C123,E123/4HI3,   ,4H3X,   ,6HFINISH,6HPROBLM
     1,6HRANGES,6HSELECT/
      LOOK=0
      NTAPE=5
	CALL USAGEB('BMD08D')
   10 READ (5,148)CODE,COB,NVAR,NTOT,NSEL,NADD,IZERO, NAMES,MAD,NVG,MTAP
     1E,MFMT
      ASSIGN 2115 TO KHIPRN
      IF(CODE.EQ.A123)GO TO 202
  201 IF(CODE.EQ.B123)GO TO 204
      WRITE(6, 622) CODE
  203 WRITE (6,205)
  202 IF(NTAPE.LE.5)GO TO 2055
 2035 REWIND NTAPE
 2055 STOP
  600 WRITE(6, 601)
      GO TO 203
  602 WRITE(6, 603)
      GO TO 203
  604 WRITE(6, 605)
      GO TO 203
  606 WRITE(6, 607)
      GO TO 203
  608 WRITE(6, 609)
      GO TO 203
  612 WRITE(6, 613) CODE
      GO TO 203
  614 WRITE(6, 615)
      GO TO 203
  618 WRITE(6, 619) CODE
      GO TO 203
  620 WRITE(6, 621)
      GO TO 203
  625 WRITE(6, 624) LOVE
      GO TO 5108
  204 CALL TPWD(MTAPE,NTAPE)
      IF((NVAR-1)*(NVAR-101)) 6002,600,600
 6002 IF(NADD) 6003,6003,6004
 6003 CONTINUE
 6004 IF(NSEL-99) 6005,6005,604
 6005 IJK=NADD+NVAR
      IF(IJK-101)  206,606,606
  206 IF(NTOT*(NTOT-1501))2075,608,608
 2075 IF((IJK*NTOT)- 8000)207,207,602
  207 IF(MFMT.GT.0.AND.MFMT.LE.10)GO TO 208
      WRITE(6,4002)
      MFMT=1
  208 WRITE (6,209)COB,NVAR,NTOT,NVG,MFMT
      DO 1 I=1, 8000
    1 IDATA(I)=0
      I2=0
      I3=(IJK+4)/5
      DO 7400 L=1,I3
      I1=I2+1
      I2=I2+5
      READ (5,149)CODE,(MMAX(I),MMIN(I),I=I1,I2)
      IF(CODE.NE.C123)GO TO 612
 7400 CONTINUE
 7500 CALL RDLBL(NAMES,IJK,WORD)
 7000 MFMT=MFMT*18
      READ (5,150)(FMT(I),I=1,MFMT)
      WRITE(6, 627)
  627 FORMAT(' VARIABLE FORMAT CARD(S)')
      WRITE(6, 9343)(FMT(I),I=1,MFMT)
 9343 FORMAT(1X,18A4)
      DO110J=1,NTOT
      READ (NTAPE,FMT)(NEW(I),I=1,NVAR)
      DO110I=1,NVAR
      LL=NTOT*I-NTOT+J
  110 IDATA(LL)=NEW(I)
      DATA Q006HL/5H*     /
      ASK(1)=(+Q006HL)
      DO 4000 I=2,120
 4000 ASK(I)=ASK(1)
  118 IF(NVG) 614,3002,3003
 3003 CALL TRNGEN(NVG,NVAR)
      IF(NVAR)2090,2090,210
 2090 IF(-NSEL)2091,10,10
 2091 DO 2095 I=1,NSEL
 2095 READ (5,157)KODE
      GO TO 10
  210 IF((IJK-1)*(IJK-101)) 6006,600,600
 6006 NVAR=IJK
 3002 IF(MAD.EQ.1)GO TO 8000
 9002 NNN=1
 9004 IF(NNN.GT.NSEL)GO TO 10
 9003 READ (5,157)CODE,NEXT,NUM,(LEVEL(I),I=1,NUM)
      IF(CODE.NE.E123)GO TO 618
      GO TO 8001
 8000 N123=NVAR-1
       NUM = 0
      NEXT=1
 9005 IF(NEXT-N123) 8001,8001,10
 8001 MAXX=MMAX(NEXT)
      MINX=MMIN(NEXT)
      IF(NUM-20)8011,8011,610
 8011 IEND=NTOT*NEXT
      ISTART=IEND-NTOT+1
      NEWX=NEXT
      IF(MAD-1) 8002,8003,8002
 8002 MUCH=1
 9006 IF(MUCH-NUM) 8004,8004,1010
 8003 N124=NEXT+1
      LOVE=N124
 9007 IF(LOVE-NVAR)9994,9994,8010
 8004 LOVE=LEVEL(MUCH)
 9994 JEND  =NTOT*LOVE
      JSTART=JEND-NTOT+1
      MAXY=MMAX(LOVE)
      MINY=MMIN(LOVE)
      NEWY=LOVE
      JESUS=MAXX-MINX
      IF(JESUS) 623,5110,5110
  623 WRITE(6, 624) NEXT
 5108 CODE=C123
      GO TO 5100
  610 WRITE(6, 611) NNN
 5109 CODE=E123
 5100 WRITE (6,5120)CODE
      GO TO 203
 5110 IF(JESUS-34)5050,5050,5051
 5051 JESUS=MAXY-MINY
      IF(-JESUS)5130,5130,625
 5130 IF(JESUS-34)5052,5052,5053
 5053 WRITE (6,5054)NEWY,NEWX
      GO TO 64
C
 5052 LOOK=-9
      IT=NEWY
      NEWY=NEWX
      NEWX=IT
      IT=MAXX
      MAXX=MAXY
      MAXY=IT
      IT=MINX
      MINX=MINY
      MINY=IT
      IT=ISTART
      ISTART=JSTART
      JSTART=IT
      IT=IEND
      IEND=JEND
      JEND=IT
 5050 CALL CROSS
      IF(-JUNKXY)5500,5500,5053
 5500 IF(-NAMES)7004,7003,7003
 7004 WRITE (6,7002)WORD(NEWY),WORD(NEWX)
 7003 WRITE (6,101)NEWY,NEWX
      WRITE (6,2000)NTOT
      WRITE (6,2001)
      WRITE (6,2002)NEWY,MAXY,MINY
      WRITE (6,2002)NEWX,MAXX,MINX
      WRITE (6,156)
      ITOTAL=0
      DO66I=1,LIMITX
   66 ITOTAL=ITOTAL+MARGX(I)
      IF(ITOTAL) 67, 67, 68
   67 WRITE (6,159)
      GO TO 64
   68 WRITE (6,102)NEWY
      IF(-NAMES)7006,7005,7005
 7006 WRITE (6,7007)WORD(NEWY)
      GO TO 7008
 7005 WRITE (6,103)
 7008 IF(IZERO-1) 5000,6000,5000
 5000 J1=0
      DO 180 I=1,LIMITY
      IF(MARGY(I)) 180, 180, 170
  170 J1=J1+1
      MRANGY(J1)=MRANGY(I)
      DO 175 J=1,LIMITX
  175 KPOINT(J1,J)=KPOINT(I,J)
      MARGY(J1)=MARGY(I)
  180 CONTINUE
      LIMITY=J1
      J1=0
      DO 190 I=1,LIMITX
      IF(MARGX(I)) 190, 190, 181
  181 J1=J1+1
      MRANGX(J1)=MRANGX(I)
      DO 185 J=1,LIMITY
  185 KPOINT(J,J1)=KPOINT(J,I)
      MARGX(J1)=MARGX(I)
  190 CONTINUE
      LIMITX=J1
 6000 J1=LIMITX
      IMAXY=LIMITY+1
        DATA BLUNK/4H     /
      DO 191 I=1,50
  191 FMT(I)=BLUNK
      DATA Q007HL/4H(     /
      FMT(1)=(+Q007HL)
      DATA Q008HL/4H I5,  /
      FMT(2)=(+Q008HL)
      DATA Q009HL/4H2H *  /
      FMT(3)=(+Q009HL)
       DATA EXER/4H1X,      /
        FMT(4)=EXER
      J1=J1+5
      FMT(J1)=(+Q008HL)
      J1=J1+1
      DATA Q011HL/4H)     /
      FMT(J1)=(+Q011HL)
      DIV=ITOTAL
      CHISQ=0.0
      DO 211 I=1,LIMITY
      DO 211 J=1,LIMITX
      SUB=FLOAT(MARGY(I)*MARGX(J))/DIV
      IF(SUB) 620,212,213
  213 FREQ=KPOINT(I,J)
  211 CHISQ=CHISQ+(FREQ-SUB)**2/SUB
 1915 DO99LL=1,LIMITY
      K=IMAXY-LL
      DO 196 J=1,LIMITX
      IF(KPOINT(K,J)-1) 192,195,195
  192 FMT(J+4)=P2
      GO TO 196
  195 FMT(J+4)=P1
  196 CONTINUE
      J1=0
      DO 199 J=1,LIMITX
      IF(KPOINT(K,J)-1) 199,198,198
 198  J1=J1+1
      KPOINT(K,J1)=KPOINT(K,J)
 199  CONTINUE
      IF(J1) 5001,5001,5002
 5001 WRITE (6,FMT)MRANGY(K),MARGY(K)
      GO TO 99
 5002 WRITE (6,FMT)MRANGY(K),(KPOINT(K,J),J=1,J1),MARGY(K)
   99 CONTINUE
      NASK=8+3*LIMITX
      WRITE (6,4001)(ASK(I),I=1,NASK)
      ITEST=LIMITX
      JTEST=2*(LIMITX/2)
      IF(ITEST-JTEST)60,60,61
   60 LLLT=LIMITX/2
      LLLB=LLLT
      GOTO65
 212  ASSIGN 2125 TO KHIPRN
      GO TO 1915
C
   61 LLLT=LIMITX/2+1
      LLLB=LLLT-1
   65 WRITE (6,137)NEWX,(MRANGX(2*I-1),I=1,LLLT)
      IF(-NAMES)7010,7009,7009
 7010 WRITE (6,7011)WORD(NEWX),(MRANGX(2*I),I=1,LLLB)
      GO TO 7012
 7009 WRITE (6,138)(MRANGX(2*I),I=1,LLLB)
 7012 WRITE (6,139)(MARGX (2*I-1),I=1,LLLT)
      WRITE (6,140)(MARGX(2*I),I=1,LLLB)
      WRITE (6,141)ITOTAL
      GO TO KHIPRN,(2115,2125)
 2115 NDF=(LIMITY-1)*(LIMITX-1)
      WRITE (6,214)CHISQ,NDF
      GO TO 64
 2125 WRITE (6,215)
      ASSIGN 2115 TO KHIPRN
   64 SUMX=0.0
      SUMY=0.0
      SUMX2=0.0
      SUMY2=0.0
      SUMXY=0.0
      J=JSTART
      DO 69 I=ISTART,IEND
      X=IDATA(I)
      Y=IDATA(J)
      SUMX=SUMX+X
      SUMY=SUMY+Y
      SUMX2=SUMX2+(X**2)
      SUMXY=SUMXY+(X*Y)
      SUMY2=SUMY2+(Y**2)
   69 J=J+1
      FNTOT=NTOT
      SCUMX=SUMX/FNTOT
      SCUMY=SUMY/FNTOT
      PUSY=SQRT((SUMY2-SUMY**2/FNTOT)/(FNTOT-1.0))
      PUSX=SQRT((SUMX2-SUMX**2/FNTOT)/(FNTOT-1.0))
      TOP=FNTOT*SUMXY-SUMX*SUMY
      BOT=(FNTOT*SUMX2-SUMX**2)*(FNTOT*SUMY2-SUMY**2)
      RXY=0.0
      IF(BOT.LE.0.0)GO TO 75
      BOT=SQRT(BOT)
      RXY=TOP/BOT
   75 IF(JUNKXY) 1000,1000,76
   76 WRITE (6,146)JUNKXY
      IF(JUNKXY-50) 77,77,1000
   77 WRITE (6,147)NEWY, NEWX
      DO 78 I=1,JUNKX
   78 WRITE (6,142)ITEM(I),IOUTY(I),JOUTX(I)
 1000 WRITE (6,154)RXY,NEWX,SCUMX,NEWX,PUSX,NEWY,SCUMY,NEWY,PUSY
      IF(LOOK) 5056,5057,5057
 5056 LOOK=0
      IT=NEWY
      NEWY=NEWX
      NEWX=IT
      IT=MAXX
      MAXX=MAXY
      MAXY=IT
      IT=MINX
      MINX=MINY
      MINY=IT
      IT=ISTART
      ISTART=JSTART
      JSTART=IT
      IT=IEND
      IEND=JEND
      JEND=IT
 5057 IF(MAD-1) 9010,9011,9010
 9010 MUCH=MUCH+1
      GO TO 9006
 1010 NNN=NNN+1
      GO TO 9004
 9011 LOVE=LOVE+1
      GO TO 9007
 8010 NEXT=NEXT+1
      GO TO 9005
      END
C             SUBROUTINE CROSS FOR BMD08D            MARCH  1, 1966
      SUBROUTINE CROSS
      DIMENSION MRANGX(40),MRANGY(100),JOUTX(50),
     1IOUTY( 50),              KPOINT(100,40),MARGY(100),MARGX(40),
     2IDATA( 8000)        ,NEW(100),MMAX(100),MMIN(100),LEVEL(22),
     3ITEM( 50),ASK(120), FMT(180)
      COMMON  ASK    , FMT
      COMMON  MRANGY , JOUTX  , IOUTY  , KPOINT , MARGY  , MARGX
      COMMON  ISTART , IEND   , IDATA  , MMAX   , MMIN   , ITEM
      COMMON  NTOT   , LIMITY , LIMITX , MAXX   , MAXY   , MINX
      COMMON  MINY   , NEWX   , NEWY   , JUNKX  , IOVER  , JUNKXY
      COMMON  JSTART , JEND
      EQUIVALENCE(ASK,NEW),(MRANGX,FMT(51)),(LEVEL,FMT(91))
C
C     GENERATE RANGE
C
      MRANGX(1)=MINX
      MRANGY(1)=MINY
      MINX1=MINX-1
      MINY1=MINY-1
      LIMITX=MAXX-MINX+1
      LIMITY=MAXY-MINY+1
      JUNKXY=0
      JUNKX=0
      IF(LIMITY-100)2,2,10
 2    DO 3 I=2,LIMITX
    3 MRANGX(I)=MRANGX(I-1)+1
      DO 4 I=2, LIMITY
    4 MRANGY(I)=MRANGY(I-1)+1
C
C     INITIALIZATION
C
      DO5JPOINT=1,LIMITX
      DO5IPOINT=1,LIMITY
    5 KPOINT(IPOINT,JPOINT)=0
C
C     COMPUTE FREQUENCY MATRIX AND EXTREME VALUES
C
      J=JSTART
      DO 12 LPOINT=ISTART,IEND
      IF(IDATA(LPOINT)-MAXX)6,8,7
    6 IF(IDATA(LPOINT)-MINX)7,8,8
    7 JUNKXY=JUNKXY+1
      IF(JUNKXY-49) 18,18,12
   18 JUNKX=JUNKX+1
      JOUTX(JUNKX)=IDATA(LPOINT)
      IOUTY(JUNKX)=IDATA(J)
      ITEM(JUNKX)=LPOINT-ISTART+1
      GOTO12
C
 10   JUNKXY=-2
      GO TO 19
C
    8 IF(IDATA(J)-MAXY)9,11,7
    9 IF(MINY-IDATA(J))11,11,7
   11 IIX=IDATA(LPOINT)-MINX1
      IIY=IDATA(J)-MINY1
      KPOINT(IIY,IIX)=KPOINT(IIY,IIX)+1
   12 J=J+1
      DO14JYY=1,LIMITY
      DO14JXX=1,LIMITX
      KPOINT(JYY,JXX)=MIN0(KPOINT(JYY,JXX),999)
   14 CONTINUE
      DO15I=1,LIMITY
   15 MARGY(I)=0
      DO16I=1,LIMITX
   16 MARGX(I)=0
      DO17I=1,LIMITY
      DO17J=1,LIMITX
      MARGY(I)=MARGY(I)+KPOINT(I,J)
      MARGX(J)=MARGX(J)+KPOINT(I,J)
   17 CONTINUE
 19   RETURN
      END
C             SUBROUTINE RDLBL FOR BMD08D            MARCH  1, 1966
C     SUBROUTINE TO READ IN LABELS CARDS, STORE THEM IN ARRAY,
C     AND SUBSTITUTE NUMBERS FOR UNLABELED VARIABLES
C     NVAR IS TOTAL NUMBER OF VARIABLES
C     NLBVAR IS NUMBER OF LABELED VARIABLES EXPECTED
C
      SUBROUTINE RDLBL(NLBVAR,NVAR,ARRAY)
C     EQUIVALENCE INTEGER AND FLOATING NAMES SO THAT INTEGER SUBTRACTION
C     MAY BE USED TO TEST ALPHABETIC EQUALITY
      DIMENSION ARRAY(1),IDUM(7),DUMY(7)
      DATA ALABEL/5HLAB   /
        DOUBLE PRECISION ARRAY ,DUMY
C     NUMBER VARIABLES
      DO 1 I=1,NVAR
1      ENCODE(10,1234,ARRAY(I))I
1234  FORMAT(I6)
C     IF NO LABELS, RETURN
      IF(NLBVAR) 9,9,2
   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) 11,8,10
  10  IF(K-NVAR) 7,7,11
  11  WRITE (6,12)K,DUMY(J)
  12  FORMAT(18H0LABELS CARD INDEX,I7,18H INCORRECT. LABEL ,A6,9H IGNORE
     1D.)
      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
C        SUBROUTINE TPWD FOR BMD08D                  MARCH  1, 1966
      SUBROUTINE TPWD(NT1,NT2)
      IF(NT1)40,10,12
 10   NT1=5
 12   IF(NT1-NT2)14,19,14
   14 IF(NT2.EQ.5) GO TO 19
   17 REWIND NT2
   19 IF(NT1-5)18,24,18
 18   IF(NT1-6)22,40,22
 22   REWIND NT1
 24   NT2=NT1
 28   RETURN
 40   WRITE (6,49)
      STOP
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)
      END
C             SUBROUTINE TRNGEN FOR BMD08D           MARCH  1, 1966
      SUBROUTINE TRNGEN(NVG,NVAR)
      DIMENSION MRANGX(40),MRANGY(100),JOUTX(50),LXX(10),
     1IOUTY( 50),              KPOINT(100,40),MARGY(100),MARGX(40),
     2IDATA( 8000)        ,NEW(100),MMAX(100),MMIN(100),LEVEL(22),
     3ITEM( 50),ASK(120), FMT(180)
      COMMON  ASK    , FMT
      COMMON  MRANGY , JOUTX  , IOUTY  , KPOINT , MARGY  , MARGX
      COMMON  ISTART , IEND   , IDATA  , MMAX   , MMIN   , ITEM
      COMMON  NTOT   , LIMITY , LIMITX , MAXX   , MAXY   , MINX
      COMMON  MINY   , NEWX   , NEWY   , JUNKX  , IOVER  , JUNKXY
      COMMON  JSTART , JEND
      EQUIVALENCE(ASK,NEW),(MRANGX,FMT(51)),(LEVEL,FMT(91))
C
       DOUBLE PRECISION D123,CODE
      DATA  D123 /6HTRNGEN/
      WRITE (6,103)
      DO 1050 LL=1,NVG
      READ (5,101)CODE,NEN,ICODE,NA,NB,NC,ND,NE,(LXX(I),I=3,7)
      IF(CODE.EQ.D123)GO TO 401
  400 NVAR=-NVAR
      GO TO 125
C
 401  WRITE (6,102)LL,NEN,ICODE,NA,NB,NC,ND,NE ,(LXX(I),I=3,7 )
      K=NA
      NV=NTOT*NEN-NTOT
      IE=NTOT*NA
      IS=IE-NTOT+1
      MB=NTOT*NB-NTOT
      IF(82-ICODE)601,601,600
  601 MMIN(NEN)=1
      MMAX(NEN)=(MMAX(NA)-MMIN(NA)+1)*(MMAX(NB)-MMIN(NB)+1)
      IF(83-ICODE)602,602,209
  602 MMAX(NEN)=MMAX(NEN)*(MMAX(NC)-MMIN(NC)+1)
      IF(84-ICODE)603,603,209
  603 MMAX(NEN)=MMAX(NEN)*(MMAX(ND)-MMIN(ND)+1)
      IF(85-ICODE)900,604,209
  604 MMAX(NEN)=MMAX(NEN)*(MMAX(NE)-MMIN(NE)+1)
      GO TO 209
 600  IF(ICODE-16) 69,69,208
   69 ICODE=ICODE-7
      GO TO 6
  208 IF(ICODE-41)210,210,900
  210 ICODE=ICODE-30
      IF(ICODE-10)900,6,6
 209  ICODE=ICODE-70
      IF(12-ICODE)205,205,900
 205  MC=NTOT*NC-NTOT
      MD=NTOT*ND-NTOT
      ME=NTOT*NE-NTOT
    6 DO 1000 J=IS,IE
      NV=NV+1
      IF(ICODE*(ICODE-16))402,900,900
  402 GO TO (10,20,30,40,50,60,900,70,80,81,82,90,100,110,120),ICODE
   10 IDATA(NV)=IDATA(J)+NB
      GO TO 1000
   20 IDATA(NV)=IDATA(J)*NB
      GO TO 1000
   30 IF(IDATA(J)) 31,32,31
   32 IDATA(NV)=0
      GO TO 1000
   31 IDATA(NV)=IDATA(J)**NB
      GO TO 1000
   40 MB=MB+1
      IDATA(NV)=IDATA(J)+IDATA(MB)
      GO TO 1000
   50 MB=MB+1
      IDATA(NV)=IDATA(J)-IDATA(MB)
      GO TO 1000
   60 MB=MB+1
      IDATA(NV)=IDATA(J)*IDATA(MB)
      GO TO 1000
   70 IF(IDATA(J)-NB) 32 ,301,301
  301 IDATA(NV)=1
      GO TO 1000
   80 MB=MB+1
      IF(IDATA(J)-IDATA(MB)) 32,301,301
   81 IF(IDATA(J)-ND) 211,212,211
  211 IF(NC-2) 1000,217,217
  217 IF(IDATA(J)-NE) 213,212,213
  213 IF(NC-3) 1000,218,218
  218 DO 214 LYNN =3,NC
      IF(IDATA(J)-LXX(LYNN)) 214,212,214
  214 CONTINUE
      GO TO 1000
  212 IDATA(NV)=NB
      GO TO 1000
   82 IF(IDATA(J)) 1000,215,1000
  215 IF(ISIGN(9,IDATA(J))) 216,1000,1000
  216 IDATA(NV)=NB
      GO TO 1000
   90 MB=MB+1
      IDATA(NV)=(MMAX(NB)-MMIN(NB)+1)*(IDATA(J)-MMIN(K))+IDATA(MB)-MMIN(
     1NB)+1
      GO TO 1000
  100 MB=MB+1
      MC=MC+1
      IDATA(NV)=(MMAX(NC)-MMIN(NC)+1)*(MMAX(NB)-MMIN(NB)+1)*(IDATA(J)-MM
     1IN(K))+(MMAX(NC)-MMIN(NC)+1)*(IDATA(MB)-MMIN(NB))+IDATA(MC)-MMIN(N
     2C)+1
      GO TO 1000
  110 MB=MB+1
      MC=MC+1
      MD=MD+1
      IDATA(NV)=(MMAX(ND)-MMIN(ND)+1)*(MMAX(NC)-MMIN(NC)+1)*(MMAX(NB)-MM
     1IN(NB)+1)*(IDATA(J)-MMIN(K))+(MMAX(ND)-MMIN(ND)+1)*(MMAX(NC)-MMIN(
     2NC)+1)*(IDATA(MB)-MMIN(NB))+(MMAX(ND)-MMIN(ND)+1)*(IDATA(MC)-MMIN(
     3NC))+IDATA(MD)-MMIN(ND)+1
      GO TO 1000
  120 MB=MB+1
      MC=MC+1
      MD=MD+1
      ME=ME+1
      IDATA(NV)=(MMAX(NE)-MMIN(NE)+1)*(MMAX(ND)-MMIN(ND)+1)*(MMAX(NC)-MM
     1IN(NC)+1)*(MMAX(NB)-MMIN(NB)+1)* (IDATA(J)-MMIN(K))+(MMAX(NE)-MMIN
     2(NE)+1)*(MMAX(ND)-MMIN(ND)+1)*(MMAX(NC)-MMIN(NC)+1)*(IDATA(MB)-MMI
     3N(NB))+(MMAX(NE)-MMIN(NE)+1)*(MMAX(ND)-MMIN(ND)+1)*(IDATA(MC)-MMIN
     4(NC))+(MMAX(NE)-MMIN(NE)+1)*(IDATA(MD)-MMIN(ND))+IDATA(ME)
     5 -MMIN(NE)+1
 1000 CONTINUE
      GO TO 1050
  900 WRITE (6,4000)
      NVAR=-NVAR
 1050 CONTINUE
  101 FORMAT(A6,I3,I2,I3,9I6)
  102 FORMAT(2H  I2,2I8,I10,I13,3I10,I5,7I6)
  103 FORMAT(46H0CARD     K      TRANS    ORIG.   ORIG. VAR(J)/74H  NO.   
     1 VARIABLE   CODE   VAR(I)   OR CONSTANT   VAR(L)    VAR(M)    VAR(
     2N))
 4000 FORMAT(129H0ILLEGAL TRANSGENERATION CODE SPECIFIED ON THE CARD LIS
     1TED ABOVE. PROGRAM WILL PROCEED TO NEXT PROBLEM CARD (IF ANY) OR T
     2ERMINATE)
 125  RETURN
      END