Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
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