Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
C CROSS TABULATION, INCOMPLETE DATA JUNE 22, 1966
C THIS IS A SIFTED VERSION OF BMD09D ORIGINALLY WRITTEN IN
C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
DOUBLE PRECISION A1,A2,A3,A4,PR,PL,VA,PROBLM,FINISH,MSSVAL,SELECT
DIMENSION Q(27)
DOUBLE PRECISION Q
C
C
DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
2FINTVL(2),SUM(8),JUNK(21),FJUNK(2000),FJAX(2000),MATRIX(21,21),
3VA(28),LC(15),ROW(21),COL(21)
COMMON DATA , JUNK , TD
COMMON FMT , IB , SCALE , CODE , NOC , RANGE
COMMON BIGA, SMAL, FINTVL, K000FX
EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
EXTERNAL SIGN
INTEGER ALTMAX
DATA Q/' ',' ',' ',' ',' ',' ',
1'1H+6X,','5X, ','4H TO','3HTAL ',' ','1H0 ','3HTOT '
2,'2HAL ','2X, ','I3, ','F4.0, ','1H ','F4.1, ','I5, '
3,'I6, ','1H 8X,','I4, ','12X, ','15X, ','F15.5,',
4'13X, '/
DATA ASTRX,RNO,A2,FINISH,A3,A4,PL,PR/1H*,2HNO,6HPROBLM,6HFINISH,
16HMSSVAL,6HSELECT,6H( ,6H) /
916 FORMAT ('1BMD09D - CROSS TABULATION, INCOMPLETE DATA',
* ' - REVISED MAY 10, 1968' /
241H HEALTH SCIENCES COMPUTING FACILITY, UCLA )
MAXNPQ = 6000
ALTMAX = 4000
MTAPE=5
CALL USAGE('BMD09D')
FBIG=10.0**6
FSMAL=10.0**5
25 READ (5,800)A1,PROB,NJ,N,NVG,NV,TESMIS,ITES,K000FX,ICASE,NSEL,RWD,
1NTAPE,MAT
IF(A1.EQ.A2)GO TO 35
26 IF(A1.EQ.FINISH)GO TO 2000
WRITE(6, 5000)A1
GO TO 2000
35 WRITE (6,916)
IF (RWD .EQ. RNO) GO TO 352
351 CALL TPWD (NTAPE,MTAPE)
GO TO 354
352 IF(NTAPE)353,353,354
353 NTAPE=5
354 IF(MAT .GT. 0 .AND.MAT .LE. 10) GO TO 3
WRITE(6, 933)
MAT = 1
3 NJJ=NJ+NV
MAT=MAT*18
WRITE (6,900)PROB
WRITE (6,930)NJJ,N,NSEL
IF(NJ*(NJ-101))30,5001,5001
30 IF(NJJ*(NJJ-101))31,5001,5001
31 IF((2-N)*(2000-N))32,32,5003
32 IF(NSEL*(NSEL-100))33,5005,5005
33 DO40I=1,NJ
40 SCALE(I)=1.0
IF(ICASE)43,43,42
43 NJX=NJ
ASSIGN 113 TO ISKIP
IF(MAXNPQ-(NJ*N))431,44,44
431 WRITE (6,807)
GO TO 2000
42 NJX=NJ+1
ASSIGN 114 TO ISKIP
IF((NJ*N)-ALTMAX) 44,44,431
44 IF(ITES) 61, 61, 63
61 DO 62 I=1,NJ
CODE(I,1)=TESMIS
62 NOC(I)=1
GO TO 55
63 DO 65 I=1,NJ
READ (5,806)A1,NOC(I),(CODE(I,J),J=1,10)
IF(A1 .EQ. A3) GO TO 65
WRITE (6,931)I,A1
GO TO 2000
65 CONTINUE
55 READ (5,802)(FMT(J),J=1,MAT)
WRITE(6, 30000)(FMT(J),J=1,MAT)
30000 FORMAT(' VARIABLE FORMAT CARD(S)'/1X,18A4)
83 DO86 J=1,NJ
IF(NOC(J))79,79,81
79 IB(J)=0
GO TO 86
81 LIM=NOC(J)
DO 80 K=1,LIM
IF(CODE(J,K))84,87,84
87 IF(SIGN(10.0,CODE(J,K)))82,84,84
82 IB(J)=K
GOTO86
84 IB(J)=0
80 CONTINUE
86 CONTINUE
DO110 I=1,N
READ (NTAPE,FMT)(TD(K),K=1,NJX)
J=0
DO110JL=1,NJX
IF(JL-ICASE)100,108,100
100 J=J+1
LIM=NOC(J)
X=TD(JL)
IBLANK=IB(J)
JSAM=1
CALL MISCOD (LIM,J,X,JET,IBLANK)
JSAM=2
GO TO (106,105),JET
105 TD(JL)=TD(JL)*SCALE(J)
106 NN=I+(J*N)-N
DATA(NN)=TD(JL)
GOTO110
108 IDENT(I)=TD(JL)
110 CONTINUE
DO20I=1,100
20 L(I)=I
IF(NVG)120,120,111
111 IF(-NV)112,115,115
112 GO TO ISKIP,(113,114)
113 IF(MAXNPQ-(NJJ*N))431,115,115
114 IF((NJJ*N)-ALTMAX)115,115,431
115 CALL TRANS (NJ,N,IERROR,NVG)
IF(IERROR)116,120,120
116 DO 118 KK=1,NSEL
118 READ (5,803)A1
GO TO 25
120 DO600KK=1,NSEL
READ (5,803)A1,NR,ROWINT,NC,COLINT,LBV,NCT,(LC(I),I=1,15)
IF(A1 .EQ. A4) GO TO 155
WRITE (6,805)KK,A1
GO TO 600
155 NRX=NR+1
NCX=NC+1
IF(LBV-NJJ)160,160,595
160 CALL SELECM(LBV,1,N,ROWINT,NR,MIKE,FJUNK,ROW)
KT=LBV*N-N
250 DO 590 M=1,NCT
LOC=LC(M)
IF(LOC-NJJ)255,255,585
255 CALL SELECM(LOC,2,N,COLINT,NC,MARY,FJAX,COL)
LT=LOC*N-N
DO310I=1,NRX
DO310J=1,NCX
310 MATRIX(I,J)=0
IT=0
DO 311 K=1,5
311 SUM(K) = 0.0
DO330K=1,N
IF(FJUNK(K).EQ.ASTRX)GO TO 320
315 IF(FJAX(K).NE.ASTRX)GO TO 325
320 IT=IT+1
FJAX(IT)=K
GOTO330
325 II=FJUNK(K)
JJ=FJAX(K)
MATRIX(II,JJ)=MATRIX(II,JJ)+1
KX=KT+K
LX=LT+K
SUM(1)=SUM(1)+DATA(KX)
SUM(2)=SUM(2)+DATA(LX)
SUM(3)=SUM(3)+DATA(KX)**2
SUM(4)=SUM(4)+DATA(LX)**2
SUM(5)=SUM(5)+DATA(KX)*DATA(LX)
330 CONTINUE
FN=N-IT
SUM(6)=FN*SUM(5)-SUM(1)*SUM(2)
SUM(7)=(FN*SUM(3)-SUM(1)**2)*(FN*SUM(4)-SUM(2)**2)
SUM(7)=SQRT(SUM(7))
SUM(8)=SUM(6)/SUM(7)
DO340I=1,NR
DO340J=1,NC
340 MATRIX(I,NCX)=MATRIX(I,NCX)+MATRIX(I,J)
DO350J=1,NC
DO350I=1,NR
350 MATRIX(NRX,J)=MATRIX(NRX,J)+MATRIX(I,J)
DO360I=1,NR
360 MATRIX(NRX,NCX)=MATRIX(NRX,NCX)+MATRIX(I,NCX)
WRITE (6,916)
WRITE (6,900)PROB
WRITE (6,901)KK,M
WRITE (6,903)LBV,LOC
IF(FN)365,575,365
365 WRITE (6,904)BIGA(1),BIGA(2)
WRITE (6,905)SMAL(1),SMAL(2)
WRITE (6,906)RANGE(1),RANGE(2)
WRITE (6,907)FINTVL(1),FINTVL(2)
NSAMP=FN
WRITE (6,929)SUM(8),NSAMP
DO380I=1,NR
IF(MATRIX(I,NCX))380,380,370
370 IR=I
380 CONTINUE
DO390J=1,NC
IF(MATRIX(NRX,J))390,390,385
385 IC=J
390 CONTINUE
IRX=IR+1
ICX=IC+1
DO400I=1,IR
400 MATRIX(I,ICX)=MATRIX(I,NCX)
DO410J=1,IC
410 MATRIX(IRX,J)=MATRIX(NRX,J)
MATRIX(IRX,ICX)=MATRIX(NRX,NCX)
GO TO (411,412,413),MARY
411 WRITE (6,909)(L(I),I=1,IC)
GO TO 415
412 WRITE (6,920)(COL(I),I=1,IC)
GO TO 415
413 WRITE (6,921)(COL(I),I=1,IC)
415 CALL WRITVA(IC,VA,PL,Q,PR,MIKE,MATRIX,ICX,IRX,ID,L,ROW,JUNK,I,
* J,K,IC,IR)
GOTO(551,555,555),MIKE
551 WRITE (6,908)
WRITE (6,922)
WRITE (6,923)
DO553 II=1,IR
I=IRX-II
553 WRITE (6,924)L(I),ROW(I)
555 GO TO (557,559,559),MARY
557 WRITE (6,908)
WRITE (6,925)
WRITE (6,923)
DO558 II=1,IC
I=ICX-II
558 WRITE (6,924)L(I),COL(I)
559 WRITE (6,908)
IF(IT)580,580,560
560 WRITE (6,915)
WRITE (6,912)LBV,LOC
VA(1)=PL
VA(2) = Q(22)
VA(3) = Q(23)
C
VA(4) = Q(24)
DO570I=1,IT
IKE=0
II=FJAX(I)
LM=LBV*N-N+II
MM=LOC*N-N+II
IF(DATA(LM))563,561,563
561 IF(SIGN(10.0,DATA(LM)))562,563,563
562 VA(5) = Q(25)
GOTO 564
563 VA(5) = Q(26)
IKE=IKE+1
COL(IKE)=DATA(LM)
564 VA(6) = Q(27)
IF(DATA(MM))567,565,567
565 IF(SIGN(10.0,DATA(MM)))566,567,567
566 VA(7) = Q(25)
GOTO568
567 VA(7) = Q(26)
IKE=IKE+1
COL(IKE)=DATA(MM)
568 VA(8)=PR
IF(IKE)571,571,572
571 WRITE (6,VA)II
GOTO570
572 WRITE (6,VA)II,(COL(J),J=1,IKE)
570 CONTINUE
GOTO590
575 WRITE (6,801)
GO TO 600
580 WRITE (6,914)
GO TO 590
585 WRITE (6,902)LOC
590 CONTINUE
GO TO 600
595 WRITE (6,910)LBV
600 CONTINUE
IF(K000FX) 25, 25, 603
603 ID=0
DO620J=1,NJJ
IF(SCALE(J)-99.0)615,605,615
605 ID=ID+1
FJUNK(ID)=J
GOTO620
615 MM=(J*N)-N
DO 618 I=1,N
LM=MM+I
D=DATA(LM)
LIM=NOC(J)
IBLANK=IB(J)
CALL MISCOD (LIM,J,D,JET,IBLANK)
GO TO (618,616),JET
616 DATA(LM)=DATA(LM)/SCALE(J)
618 CONTINUE
IB(J)=0
611 IF(SCALE(J)-1.11111)617,617,613
617 IF(SCALE(J)-0.999)612,620,620
612 SCALE(J)=SCALE(J)*10.0
IB(J)=IB(J)-1
GO TO 611
613 SCALE(J)=SCALE(J)/10.0
IB(J)=IB(J)+1
GO TO 611
620 CONTINUE
IF(ID)648,648,623
623 DO610IJ=1,ID
J=FJUNK(IJ)
MM=(J*N)-N
FJAX(J)=0
DO610I=1,N
LM=MM+I
IF(DATA(LM)-CODE(J,1))607,610,607
607 TY=ABS(DATA(LM))
IF(FJAX(J)-TY)608,610,610
608 FJAX(J)=TY
610 CONTINUE
DO640IJ=1,ID
J=FJUNK(IJ)
I=0
IF(FJAX(J))638,638,625
625 IF(FJAX(J)-FBIG)628,635,635
628 IF(FJAX(J)-FSMAL)630,638,638
630 FJAX(J)=FJAX(J)*10.0
I=I-1
GOTO625
635 FJAX(J)=FJAX(J)/10.0
I=I+1
GOTO625
638 IB(J)=I
640 CONTINUE
DO645IJ=1,ID
J=FJUNK(IJ)
MM=(J*N)-N
IIB=(-1)*IB(J)
FACT=10.0**IIB
DO645I=1,N
LM=MM+I
IF(DATA(LM)-CODE(J,1))644,645,644
644 DATA(LM)=DATA(LM)*FACT
645 CONTINUE
648 WRITE (6,919)
WRITE (6,917)
MAX=13
IF(ICASE)647,647,646
646 MAX=12
647 NF=1
IF(NJJ-MAX)650,650,660
650 NL=NJJ
CALL PRINT(NF,NL,N,ICASE)
GO TO 675
660 NL=MAX
CALL PRINT (NF,NL,N,ICASE)
NO=NJJ
663 NO=NO-MAX
NF=NF+MAX
WRITE (6,919)
WRITE (6,918)
IF(NO-MAX)670,670,665
665 NL=NL+MAX
CALL PRINT (NF,NL,N,ICASE)
GOTO663
670 NL=NL+NO
CALL PRINT (NF,NL,N,ICASE)
675 WRITE (6,927)
DO 680 J=1,NJJ
LIM=NOC(J)
680 WRITE (6,928)J,(CODE(J,K),K=1,LIM)
GOTO25
800 FORMAT(A6,A2,I3,I4,2I3,F3.0,2I2,I3,I2,33X,A2,I2,I2)
801 FORMAT(1H019X80HSAMPLE SIZE IS ZERO. PROGRAM WILL READ NEXT SELECT
1ION CARD (IF ANY) AND PROCEED.)
802 FORMAT(18A4)
803 FORMAT(A6,I2,F5.0,I2,F5.0,I3,I2,15I3)
804 FORMAT(' ERROR ON PROBLEM CARD')
805 FORMAT(24H0ERROR ON SELECTION CARDI4,' PROGRAM READ IN',A6,' INSTE
1AD OF SELECT')
806 FORMAT(A6,I2,10F6.0)
807 FORMAT(1H0,29X,58HTOO MUCH DATA. SEE LIMITATIONS ON DATA SIZE IN T
1HE MANUAL.)
900 FORMAT(12H0PROBLEM NO.2X,A2)
901 FORMAT(10H SELECTIONI6,1H-I3)
902 FORMAT(16H0VARIABLE NUMBER,I4,80H IS NOT IN THIS PROBLEM. PROGRAM
1PROCEEDS TO NEXT VARABLE TO BE CROSS TABULATED.)
903 FORMAT(9H0VARIABLEI4,3X,5H(ROW)26X,8HVARIABLEI4,3X,8H(COLUMN))
904 FORMAT(8H MAXIMUM9X,F15.5,15X,7HMAXIMUM9X,F15.5)
905 FORMAT(8H MINIMUM9X,F15.5,15X,7HMINIMUM9X,F15.5)
906 FORMAT(6H RANGE11X,F15.5,15X,5HRANGE11X,F15.5)
907 FORMAT(9H INTERVAL8X,F15.5,15X,8HINTERVAL8X,F15.5)
908 FORMAT(1H0//)
909 FORMAT(1H06X,21I5)
910 FORMAT(15H0BASE VARIABLE,,I4,62H, INCORRECT. PROGRAM PROCEEDS TO N
1EXT SELECTION CARD (IF ANY).)
912 FORMAT(1H06X,8HITEM NO.9X,8HVARIABLEI4,1X,5H(ROW)10X,8HVARIABLEI4,
11X,8H(COLUMN))
913 FORMAT(1H08X,I4,12X,F15.5,13X,F15.5)
914 FORMAT(18H0NO MISSING VALUES)
915 FORMAT(15H0MISSING VALUES)
917 FORMAT(1H018X,15HVARIABLE NUMBER)
918 FORMAT(1H018X,25HVARIABLE NUMBER CONTINUED)
919 FORMAT(1H142X,11HDATA MATRIX)
920 FORMAT(1H07X,20(F4.0,1H ))
921 FORMAT(1H07X,20(F4.1,1H ))
922 FORMAT(18H ROW SPECIFICATION)
925 FORMAT(21H COLUMN SPECIFICATION)
923 FORMAT(6H0LABEL5X,8HINTERVAL)
924 FORMAT(1H I3,F16.5,1H-)
927 FORMAT(20H1MISSING VALUE CODES/9H0VARIABLE4X,5HCODES)
928 FORMAT(1H I4,2X,2H* 10F11.5)
929 FORMAT(25H0CORRELATION COEFFICIENT=F9.5,3X,13H(SAMPLE SIZE=I4,1H)/
1///)
930 FORMAT(17H0NO. OF VARIABLES7X,I3/12H SAMPLE SIZE11X,I4/23H NO. OF
1SELECTION CARDSI4)
931 FORMAT(28H0ERROR ON MISSING VALUE CARDI4,' PROGRAM READ IN',1X,A6,
1' INSTEAD OF MSSVAL')
933 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
1IED, ASSUMED TO BE 1.)
5000 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE F
1OLLOWING'/1X,A6)
5002 FORMAT(' NUMBER OF VARIABLES MUST BE LESS THAN 100 BEFORE AND AFTE
1R TRANSGENERATION ')
5004 FORMAT(' THE SAMPLE SIZE IS NOT WITHIN THE LIMITS SPECIFIED IN THE
1 BMD MANUAL')
5006 FORMAT(' THE NUMBER OF SELECTION CARDS IS NOT WITHIN THE LIMITS SP
1ECIFIED IN THE BMD MANUAL')
5001 WRITE(6, 5002)
GO TO 27
5003 WRITE(6, 5004)
GO TO 27
5005 WRITE(6, 5006)
27 WRITE (6,804)
2000 IF(MTAPE-5)2002,2002,2001
2001 REWIND MTAPE
2002 STOP
END
C SUBROUTINE MISCOD FOR BMD09D JUNE 22, 1966
SUBROUTINE MISCOD (N,J,X,JET,IBLANK)
DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
2FINTVL(2),SUM(8),JUNK(21)
COMMON DATA , JUNK , TD
COMMON FMT , IB , SCALE , CODE , NOC , RANGE
COMMON BIGA , SMAL , FINTVL
EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
EXTERNAL SIGN
IF(N)35,35,5
5 DO 30 K=1,N
IF(IBLANK-K)25,15,25
15 IF(X)30,20,30
20 IF(SIGN(10.0,X))40,30,30
25 IF(X-CODE(J,K))30,40,30
30 CONTINUE
35 JET=2
GO TO 50
40 JET=1
50 RETURN
END
C SUBROUTINE PRINT FOR BMD09D JUNE 22, 1966
SUBROUTINE PRINT (NF,NL,N,ICASE)
DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
2FINTVL(2),SUM(8),JUNK(21) ,TY(13)
COMMON DATA , JUNK , TD
COMMON FMT , IB , SCALE , CODE , NOC , RANGE
COMMON BIGA , SMAL , FINTVL
EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
IF(ICASE)15,15,40
15 WRITE (6,918)(L(I),I=NF,NL)
WRITE (6,919)(IB(J),J=NF,NL)
WRITE (6,920)
DO30I=1,N
K=0
DO20J=NF,NL
LL=N*J-N+I
K=K+1
20 TY(K)=DATA(LL)
30 WRITE (6,921)I,(TY(M),M=1,K)
GOTO1000
40 WRITE (6,928)(L(I),I=NF,NL)
WRITE (6,929)(IB(J),J=NF,NL)
WRITE (6,920)
DO60I=1,N
K=0
DO50J=NF,NL
LL=N*J-N+I
K=K+1
50 TY(K)=DATA(LL)
60 WRITE (6,931)I,IDENT(I),(TY(M),M=1,K)
918 FORMAT(5H0ITEM3X,1H*/7H NUMBER1X,1H*,I7,12I8)
919 FORMAT(1H05X,5HSCALEI5,12I8)
920 FORMAT(1H0)
921 FORMAT(1H I4,5X,13F8.0)
928 FORMAT(5H0ITEM3X,8HI.D. * /4H NO.4X,8HNO. * 12I8)
929 FORMAT(1H013X,5HSCALEI5,11I8)
931 FORMAT(1H I4,I7,4X,12F8.0)
1000 RETURN
END
C SUBROUTINE SELECM FOR B M09D JUNE 22, 1966
SUBROUTINE SELECM (LBV,L,N,ROWINT,NR,KING,FJUNK,ROW)
DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
1M(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
2FINTVL(2),SUM(8),JUNK(21),FJUNK(2000),ROW(21)
COMMON DATA , JUNK , TD
COMMON FMT , IB , SCALE , CODE , NOC , RANGE
COMMON BIGA , SMAL , FINTVL
EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,M)
KING=1
DATA ASTRX/1H*/
FCODE=-999.00999
BIGEST=10.0**36
TSMAL=-BIGEST
LM=LBV*N-N
BIGA(L)=TSMAL
SMAL(L)=BIGEST
DO 145 J=1,N
MN=LM+J
D=DATA(MN)
IF(SCALE(LBV)-99.0)105,100,105
100 IF(D-FCODE)125,145,125
105 LIM=NOC(LBV)
IBLANK=IB(LBV)
CALL MISCOD (LIM,LBV,D,JET,IBLANK)
GO TO (145,125),JET
125 IF(BIGA(L)-DATA(MN))130,135,135
130 BIGA(L)=DATA(MN)
135 IF(SMAL(L)-DATA(MN))145,145,140
140 SMAL(L)=DATA(MN)
145 CONTINUE
RANGE(L)=BIGA(L)-SMAL(L)
IF(SCALE(LBV)-99.0)139,137,139
137 CODE(LBV,1)=FCODE
NOC(LBV)=1
IB(LBV)=0
139 IF(ROWINT)170,170,160
160 FINTVL(L)=ROWINT
GO TO 180
170 SUBRAN=RANGE(L)/(FLOAT(NR)-1.0)
IF(SUBRAN-1.0) 174, 172, 174
172 FINTVL(L)=1.0
GO TO 180
174 CALL INTVL(SUBRAN,SINT)
FINTVL(L)=SINT
180 ROW(1)=SMAL(L)
DO 190 I=2,NR
190 ROW(I)=ROW(I-1)+FINTVL(L)
IF(SMAL(L))149,141,141
141 IF(BIGA(L)-1000.0)142,149,149
142 IF(FINTVL(L)-1.0)144,143,143
143 KING=2
GO TO 149
144 IF(BIGA(L)-100.0)146,149,149
146 IF(FINTVL(L)-0.099999)149,147,147
147 KING=3
149 CONTINUE
DO 220 K=1,N
MM=LM+K
IF(SCALE(LBV)-99.0)200,216,200
216 IF(DATA(MM)-FCODE)201,194,201
200 D=DATA(MM)
LIM=NOC(LBV)
IBLANK=IB(LBV)
CALL MISCOD (LIM,LBV,D,JET,IBLANK)
GO TO (194,201),JET
194 FJUNK(K)=ASTRX
GO TO 220
201 DO 215 I=2,NR
IF(DATA(MM)-ROW(I)) 210, 215, 215
210 FJUNK(K)=I-1
GO TO 220
215 CONTINUE
FJUNK(K)=NR
220 CONTINUE
RETURN
END
C SUBROUTINE TRANS FOR BMD09D JUNE 22, 1966
SUBROUTINE TRANS (NJ,N,IERROR,NVG)
DOUBLE PRECISION A1,A2
DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
2FINTVL(2),SUM(8),JUNK(21)
COMMON DATA , JUNK , TD
COMMON FMT , IB , SCALE , CODE , NOC , RANGE
COMMON BIGA, SMAL, FINTVL, K000FX
ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
DATA A2/6HTRNGEN/
INTEGER ALTMAX
ALTMAX = 4000
MAXNPQ = 6000
FCODE=-999.00999
FN=N
WRITE (6,1403)
WRITE (6,1400)
IERROR=0
DO 1000 I=1,NVG
READ (5,1100)A1,NEWA,LCODE,LVA,BNEW
III=I
IF(A1 .NE. A2) GO TO 1001
WRITE (6,1402)I,NEWA,LCODE,LVA,BNEW
MARY=0
MA=N*NEWA-N
MB=N*LVA-N+1
MC=MB+N-1
IF(K000FX)301,322,301
301 IF(MC-ALTMAX)343,343,315
315 WRITE (6,320)MC
STOP
320 FORMAT(35H DATA SIZE N(P+Q) EXCEEDED, SIZE = I6)
322 IF(MC-MAXNPQ)343,343,315
343 K=BNEW
MD=N*K-N
DO 3 J=MB,MC
MA=MA+1
MD=MD+1
D=DATA(J)
IF(SCALE(LVA)-99.0)49,203,49
203 IF(D-FCODE)51,190,51
49 LIM=NOC(LVA)
IBLANK=IB(LVA)
CALL MISCOD (LIM,LVA,D,JET,IBLANK)
GO TO (190,51),JET
51 IF(LCODE*(15-LCODE)) 4001,4001,52
4001 WRITE (6,6002) NVG
6002 FORMAT(' ILLEGAL TRANSGENERATION CODE ENCOUNTERED ON TRNGEN CARD
1 NO.',I4)
STOP
52 IF (LCODE.LT.11) GO TO 54
X = DATA(MD)
IF(SCALE(K)-99.0)202,201,202
201 IF(X-FCODE)54,190,54
202 LIM=NOC(K)
IBLANK=IB(K)
CALL MISCOD(LIM,K,X,JET,IBLANK)
GO TO (190,54),JET
54 CONTINUE
GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140),LCODE
10 IF(D)99,7,8
7 DATA(MA)=0.0
GO TO 3
8 DATA(MA)=SQRT(D)
GO TO 3
20 IF(D)99,11,12
11 DATA(MA)=1.0
GO TO 3
12 DATA(MA)=SQRT(D)+SQRT(D+1.0)
GO TO 3
30 IF(D)99,99,14
14 DATA(MA)=ALOG10(D)
GO TO 3
40 DATA(MA)=EXP(D)
GO TO 3
50 IF(-D)17,7,99
17 IF(D-1.0)18,19,99
18 DATA(MA)=ASN(SQRT(D))
GO TO 3
19 DATA(MA)=3.14159265/2.0
GO TO 3
60 A=D/(FN+1.0)
B=A+1.0/(FN+1.0)
IF(A)99,23,24
23 IF(-B)27,7,99
27 DATA(MA)=ASN(SQRT(B))
GO TO 3
24 IF(B)99,28,29
28 DATA(MA)=ASN(SQRT(A))
GO TO 3
29 DATA(MA)=ASN(SQRT(A))+ASN(SQRT(B))
GO TO 3
70 IF(D)31,99,31
31 DATA(MA)=1.0/D
GO TO 3
80 DATA(MA)=D+BNEW
GO TO 3
90 DATA(MA)=D*BNEW
GO TO 3
100 IF(D)33,7,33
33 DATA(MA)=D**BNEW
GO TO 3
110 DATA(MA)=D+X
GO TO 3
120 DATA(MA)=D-X
GO TO 3
130 DATA(MA)=D*X
GO TO 3
140 IF(X)145,99,145
145 DATA(MA)=D/X
GO TO 3
190 DATA(MA)=FCODE
GO TO 3
99 IF(MARY)43,44,44
44 MARY=-999
IERROR=-999
WRITE (6,1404)I
43 WRITE (6,1405)J
3 CONTINUE
SCALE(NEWA)=99.0
1000 CONTINUE
GO TO 1150
1001 WRITE (6,1406)III,A1
IERROR=-999
IF(III-NVG) 300, 42, 42
300 III=III+1
DO 1005 KK=III,NVG
1005 READ (5,1100)A1
1150 IF(IERROR)42,1111,1111
42 WRITE (6,1401)
1100 FORMAT(A6,I3,I2,I3,F6.0)
1400 FORMAT(46H0CARD NEW TRANS ORIG. ORIG. VAR(B)/45H NO.
1VARIABLE CODE VAR(A) OR CONSTANT)
1401 FORMAT(42H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM.)
1402 FORMAT(2H I2,I8,2I9,4X,F10.5)
1403 FORMAT(1H06X,23HTRANSGENERATION CARD(S))
1404 FORMAT(55H0THE INSTRUCTIONS INDICATED ON TRANSGENERATION CARD NO.I
12,1X,3HRE-/60H SULTED IN THE VIOLATION OF A RESTRICTION FOR THIS T
2RANSFOR-/59H MATION. THE VIOLATION OCCURRED FOR THE ITEMS LISTED B
3ELOW.)
1405 FORMAT(10H ITEM NO. I5)
1406 FORMAT(30H0ERROR ON TRANSGENERATION CARDI4,' PROGRAM READ IN',1X,A
16,' INSTEAD OF TRNGEN')
1111 RETURN
END
C SUBROUTINE INTVL FOR BMD09D JUNE 22, 1966
SUBROUTINE INTVL(X,XINT)
DIMENSION TLIMIT(4),FLIMIT(4)
DATA TLIMIT/1.0,2.0,5.0,10.0/
IF(X-1.0)10,30,30
10 IP=(-1)
DO20II=1,38
I=IP*II
POWER=10.0**I
IF(X-POWER)20,50,50
20 CONTINUE
30 DO45II=1,39
I=II-1
POWER=10.0**I
IF(X-POWER)40,45,45
40 POWER=POWER/10.0
GOTO50
45 CONTINUE
50 DO55I=1,4
55 FLIMIT(I)=TLIMIT(I)*POWER
DO70I=1,4
IF(X-FLIMIT(I))60,70,70
60 XINT=FLIMIT(I)
GOTO80
70 CONTINUE
80 RETURN
END
C SUBROUTINE TPWD FOR BMD09D JUNE 22, 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 18
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
SUBROUTINE WRITVA(IC,VA,PL,Q,PR,MIKE,MATRIX,ICX,IRX,ID,L,ROW,
* JUNK,I,J,K,IC2,IR)
DOUBLE PRECISION PR,PL,VA(28),Q(27)
DIMENSION JUNK(21), MATRIX(21,21), ROW(21),L(100)
VA(1) = PL
VA(2) = Q(7)
DO 420 KX = 1,IC
K = KX+2
420 VA(K) = Q(8)
K = K+1
VA(K) = Q(9)
K = K+1
VA(K) = Q(10)
K = K+1
VA(K) = PR
WRITE (6,VA)
ID = 0
VA(1) = PL
VA(2) = Q(12)
430 ID = ID+1
I = IR-ID+1
GO TO 440
435 VA(3) = Q(13)
VA(4) = Q(14)
GO TO 445
440 GO TO (441,442,443), MIKE
441 VA(3) = Q(15)
VA(4) = Q(16)
GO TO 445
442 VA(3) = Q(17)
VA(4) = Q(18)
GO TO 445
443 VA(3) = Q(19)
VA(4) = Q(18)
445 DO 470 J=1,IC
K=4+J
IF (MATRIX(I,J)) 450,450,460
450 VA(K) = Q(8)
GO TO 470
460 VA(K) = Q(20)
470 CONTINUE
K = K+1
IF (MATRIX(I,ICX)) 480,480,485
480 VA(K) = Q(8)
GO TO 490
485 VA(K) = Q(21)
490 K = K+1
VA(K) = PR
K = 0
DO 510 J=1,ICX
IF (MATRIX(I,J)) 510,510,500
500 K = K+1
JUNK(K) = MATRIX(I,J)
510 CONTINUE
IF (I-IRX) 520,550,550
520 IF (K) 525,525,530
525 GO TO (526,527,527), MIKE
526 WRITE (6,VA) L(I)
GO TO 535
527 WRITE (6,VA) ROW(I)
GO TO 535
530 GO TO (531,532,532), MIKE
531 WRITE (6,VA) L(I), (JUNK(J), J=1,K)
GO TO 535
532 WRITE (6,VA) ROW(I), (JUNK(J),J=1,K)
535 IF (I-1) 540,540,536
536 GO TO 430
540 I = IRX
GO TO 435
550 WRITE (6,VA) (JUNK(J),J=1,K)
RETURN
END