Trailing-Edge
-
PDP-10 Archives
-
decus_20tap5_198111
-
decus/20-0137/bmd/bmd09d.for
There is 1 other file named bmd09d.for in the archive. Click here to see a list.
00100 C CROSS TABULATION, INCOMPLETE DATA JUNE 22, 1966
00200 C THIS IS A SIFTED VERSION OF BMD09D ORIGINALLY WRITTEN IN
00300 C FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
00400 C AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
00500 DOUBLE PRECISION A1,A2,A3,A4,PR,PL,VA,PROBLM,FINISH,MSSVAL,SELECT
00600 DIMENSION Q(27)
00700 DOUBLE PRECISION Q
00800 C
00900 C
01000 DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
01100 1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
01200 2FINTVL(2),SUM(8),JUNK(21),FJUNK(2000),FJAX(2000),MATRIX(21,21),
01300 3VA(28),LC(15),ROW(21),COL(21)
01400 COMMON DATA , JUNK , TD
01500 COMMON FMT , IB , SCALE , CODE , NOC , RANGE
01600 COMMON BIGA, SMAL, FINTVL, K000FX
01700 EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
01800 EXTERNAL SIGN
01900 INTEGER ALTMAX
02000 DATA Q/' ',' ',' ',' ',' ',' ',
02100 1'1H+6X,','5X, ','4H TO','3HTAL ',' ','1H0 ','3HTOT '
02200 2,'2HAL ','2X, ','I3, ','F4.0, ','1H ','F4.1, ','I5, '
02300 3,'I6, ','1H 8X,','I4, ','12X, ','15X, ','F15.5,',
02400 4'13X, '/
02500 DATA ASTRX,RNO,A2,FINISH,A3,A4,PL,PR/1H*,2HNO,6HPROBLM,6HFINISH,
02600 16HMSSVAL,6HSELECT,6H( ,6H) /
02700 916 FORMAT ('1BMD09D - CROSS TABULATION, INCOMPLETE DATA',
02800 * ' - REVISED MAY 10, 1968' /
02900 241H HEALTH SCIENCES COMPUTING FACILITY, UCLA )
03000 MAXNPQ = 6000
03100 ALTMAX = 4000
03200 MTAPE=5
03300 CALL USAGEB('BMD09D')
03400 FBIG=10.0**6
03500 FSMAL=10.0**5
03600 25 READ (5,800)A1,PROB,NJ,N,NVG,NV,TESMIS,ITES,K000FX,ICASE,NSEL,RWD,
03700 1NTAPE,MAT
03800 IF(A1.EQ.A2)GO TO 35
03900 26 IF(A1.EQ.FINISH)GO TO 2000
04000 WRITE(6, 5000)A1
04100 GO TO 2000
04200 35 WRITE (6,916)
04300 IF (RWD .EQ. RNO) GO TO 352
04400 351 CALL TPWD (NTAPE,MTAPE)
04500 GO TO 354
04600 352 IF(NTAPE)353,353,354
04700 353 NTAPE=5
04800 354 IF(MAT .GT. 0 .AND.MAT .LE. 10) GO TO 3
04900 WRITE(6, 933)
05000 MAT = 1
05100 3 NJJ=NJ+NV
05200 MAT=MAT*18
05300 WRITE (6,900)PROB
05400 WRITE (6,930)NJJ,N,NSEL
05500 IF(NJ*(NJ-101))30,5001,5001
05600 30 IF(NJJ*(NJJ-101))31,5001,5001
05700 31 IF((2-N)*(2000-N))32,32,5003
05800 32 IF(NSEL*(NSEL-100))33,5005,5005
05900 33 DO40I=1,NJ
06000 40 SCALE(I)=1.0
06100 IF(ICASE)43,43,42
06200 43 NJX=NJ
06300 ASSIGN 113 TO ISKIP
06400 IF(MAXNPQ-(NJ*N))431,44,44
06500 431 WRITE (6,807)
06600 GO TO 2000
06700 42 NJX=NJ+1
06800 ASSIGN 114 TO ISKIP
06900 IF((NJ*N)-ALTMAX) 44,44,431
07000 44 IF(ITES) 61, 61, 63
07100 61 DO 62 I=1,NJ
07200 CODE(I,1)=TESMIS
07300 62 NOC(I)=1
07400 GO TO 55
07500 63 DO 65 I=1,NJ
07600 READ (5,806)A1,NOC(I),(CODE(I,J),J=1,10)
07700 IF(A1 .EQ. A3) GO TO 65
07800 WRITE (6,931)I,A1
07900 GO TO 2000
08000 65 CONTINUE
08100 55 READ (5,802)(FMT(J),J=1,MAT)
08200 WRITE(6, 30000)(FMT(J),J=1,MAT)
08300 30000 FORMAT(' VARIABLE FORMAT CARD(S)'/1X,18A4)
08400 83 DO86 J=1,NJ
08500 IF(NOC(J))79,79,81
08600 79 IB(J)=0
08700 GO TO 86
08800 81 LIM=NOC(J)
08900 DO 80 K=1,LIM
09000 IF(CODE(J,K))84,87,84
09100 87 IF(SIGN(10.0,CODE(J,K)))82,84,84
09200 82 IB(J)=K
09300 GOTO86
09400 84 IB(J)=0
09500 80 CONTINUE
09600 86 CONTINUE
09700 DO110 I=1,N
09800 READ (NTAPE,FMT)(TD(K),K=1,NJX)
09900 J=0
10000 DO110JL=1,NJX
10100 IF(JL-ICASE)100,108,100
10200 100 J=J+1
10300 LIM=NOC(J)
10400 X=TD(JL)
10500 IBLANK=IB(J)
10600 JSAM=1
10700 CALL MISCOD (LIM,J,X,JET,IBLANK)
10800 JSAM=2
10900 GO TO (106,105),JET
11000 105 TD(JL)=TD(JL)*SCALE(J)
11100 106 NN=I+(J*N)-N
11200 DATA(NN)=TD(JL)
11300 GOTO110
11400 108 IDENT(I)=TD(JL)
11500 110 CONTINUE
11600 DO20I=1,100
11700 20 L(I)=I
11800 IF(NVG)120,120,111
11900 111 IF(-NV)112,115,115
12000 112 GO TO ISKIP,(113,114)
12100 113 IF(MAXNPQ-(NJJ*N))431,115,115
12200 114 IF((NJJ*N)-ALTMAX)115,115,431
12300 115 CALL TRANS (NJ,N,IERROR,NVG)
12400 IF(IERROR)116,120,120
12500 116 DO 118 KK=1,NSEL
12600 118 READ (5,803)A1
12700 GO TO 25
12800 120 DO600KK=1,NSEL
12900 READ (5,803)A1,NR,ROWINT,NC,COLINT,LBV,NCT,(LC(I),I=1,15)
13000 IF(A1 .EQ. A4) GO TO 155
13100 WRITE (6,805)KK,A1
13200 GO TO 600
13300 155 NRX=NR+1
13400 NCX=NC+1
13500 IF(LBV-NJJ)160,160,595
13600 160 CALL SELECM(LBV,1,N,ROWINT,NR,MIKE,FJUNK,ROW)
13700 KT=LBV*N-N
13800 250 DO 590 M=1,NCT
13900 LOC=LC(M)
14000 IF(LOC-NJJ)255,255,585
14100 255 CALL SELECM(LOC,2,N,COLINT,NC,MARY,FJAX,COL)
14200 LT=LOC*N-N
14300 DO310I=1,NRX
14400 DO310J=1,NCX
14500 310 MATRIX(I,J)=0
14600 IT=0
14700 DO 311 K=1,5
14800 311 SUM(K) = 0.0
14900 DO330K=1,N
15000 IF(FJUNK(K).EQ.ASTRX)GO TO 320
15100 315 IF(FJAX(K).NE.ASTRX)GO TO 325
15200 320 IT=IT+1
15300 FJAX(IT)=K
15400 GOTO330
15500 325 II=FJUNK(K)
15600 JJ=FJAX(K)
15700 MATRIX(II,JJ)=MATRIX(II,JJ)+1
15800 KX=KT+K
15900 LX=LT+K
16000 SUM(1)=SUM(1)+DATA(KX)
16100 SUM(2)=SUM(2)+DATA(LX)
16200 SUM(3)=SUM(3)+DATA(KX)**2
16300 SUM(4)=SUM(4)+DATA(LX)**2
16400 SUM(5)=SUM(5)+DATA(KX)*DATA(LX)
16500 330 CONTINUE
16600 FN=N-IT
16700 SUM(6)=FN*SUM(5)-SUM(1)*SUM(2)
16800 SUM(7)=(FN*SUM(3)-SUM(1)**2)*(FN*SUM(4)-SUM(2)**2)
16900 SUM(7)=SQRT(SUM(7))
17000 SUM(8)=SUM(6)/SUM(7)
17100 DO340I=1,NR
17200 DO340J=1,NC
17300 340 MATRIX(I,NCX)=MATRIX(I,NCX)+MATRIX(I,J)
17400 DO350J=1,NC
17500 DO350I=1,NR
17600 350 MATRIX(NRX,J)=MATRIX(NRX,J)+MATRIX(I,J)
17700 DO360I=1,NR
17800 360 MATRIX(NRX,NCX)=MATRIX(NRX,NCX)+MATRIX(I,NCX)
17900 WRITE (6,916)
18000 WRITE (6,900)PROB
18100 WRITE (6,901)KK,M
18200 WRITE (6,903)LBV,LOC
18300 IF(FN)365,575,365
18400 365 WRITE (6,904)BIGA(1),BIGA(2)
18500 WRITE (6,905)SMAL(1),SMAL(2)
18600 WRITE (6,906)RANGE(1),RANGE(2)
18700 WRITE (6,907)FINTVL(1),FINTVL(2)
18800 NSAMP=FN
18900 WRITE (6,929)SUM(8),NSAMP
19000 DO380I=1,NR
19100 IF(MATRIX(I,NCX))380,380,370
19200 370 IR=I
19300 380 CONTINUE
19400 DO390J=1,NC
19500 IF(MATRIX(NRX,J))390,390,385
19600 385 IC=J
19700 390 CONTINUE
19800 IRX=IR+1
19900 ICX=IC+1
20000 DO400I=1,IR
20100 400 MATRIX(I,ICX)=MATRIX(I,NCX)
20200 DO410J=1,IC
20300 410 MATRIX(IRX,J)=MATRIX(NRX,J)
20400 MATRIX(IRX,ICX)=MATRIX(NRX,NCX)
20500 GO TO (411,412,413),MARY
20600 411 WRITE (6,909)(L(I),I=1,IC)
20700 GO TO 415
20800 412 WRITE (6,920)(COL(I),I=1,IC)
20900 GO TO 415
21000 413 WRITE (6,921)(COL(I),I=1,IC)
21100 415 CALL WRITVA(IC,VA,PL,Q,PR,MIKE,MATRIX,ICX,IRX,ID,L,ROW,JUNK,I,
21200 * J,K,IC,IR)
21300 GOTO(551,555,555),MIKE
21400 551 WRITE (6,908)
21500 WRITE (6,922)
21600 WRITE (6,923)
21700 DO553 II=1,IR
21800 I=IRX-II
21900 553 WRITE (6,924)L(I),ROW(I)
22000 555 GO TO (557,559,559),MARY
22100 557 WRITE (6,908)
22200 WRITE (6,925)
22300 WRITE (6,923)
22400 DO558 II=1,IC
22500 I=ICX-II
22600 558 WRITE (6,924)L(I),COL(I)
22700 559 WRITE (6,908)
22800 IF(IT)580,580,560
22900 560 WRITE (6,915)
23000 WRITE (6,912)LBV,LOC
23100 VA(1)=PL
23200 VA(2) = Q(22)
23300 VA(3) = Q(23)
23400 C
23500 VA(4) = Q(24)
23600 DO570I=1,IT
23700 IKE=0
23800 II=FJAX(I)
23900 LM=LBV*N-N+II
24000 MM=LOC*N-N+II
24100 IF(DATA(LM))563,561,563
24200 561 IF(SIGN(10.0,DATA(LM)))562,563,563
24300 562 VA(5) = Q(25)
24400 GOTO 564
24500 563 VA(5) = Q(26)
24600 IKE=IKE+1
24700 COL(IKE)=DATA(LM)
24800 564 VA(6) = Q(27)
24900 IF(DATA(MM))567,565,567
25000 565 IF(SIGN(10.0,DATA(MM)))566,567,567
25100 566 VA(7) = Q(25)
25200 GOTO568
25300 567 VA(7) = Q(26)
25400 IKE=IKE+1
25500 COL(IKE)=DATA(MM)
25600 568 VA(8)=PR
25700 IF(IKE)571,571,572
25800 571 WRITE (6,VA)II
25900 GOTO570
26000 572 WRITE (6,VA)II,(COL(J),J=1,IKE)
26100 570 CONTINUE
26200 GOTO590
26300 575 WRITE (6,801)
26400 GO TO 600
26500 580 WRITE (6,914)
26600 GO TO 590
26700 585 WRITE (6,902)LOC
26800 590 CONTINUE
26900 GO TO 600
27000 595 WRITE (6,910)LBV
27100 600 CONTINUE
27200 IF(K000FX) 25, 25, 603
27300 603 ID=0
27400 DO620J=1,NJJ
27500 IF(SCALE(J)-99.0)615,605,615
27600 605 ID=ID+1
27700 FJUNK(ID)=J
27800 GOTO620
27900 615 MM=(J*N)-N
28000 DO 618 I=1,N
28100 LM=MM+I
28200 D=DATA(LM)
28300 LIM=NOC(J)
28400 IBLANK=IB(J)
28500 CALL MISCOD (LIM,J,D,JET,IBLANK)
28600 GO TO (618,616),JET
28700 616 DATA(LM)=DATA(LM)/SCALE(J)
28800 618 CONTINUE
28900 IB(J)=0
29000 611 IF(SCALE(J)-1.11111)617,617,613
29100 617 IF(SCALE(J)-0.999)612,620,620
29200 612 SCALE(J)=SCALE(J)*10.0
29300 IB(J)=IB(J)-1
29400 GO TO 611
29500 613 SCALE(J)=SCALE(J)/10.0
29600 IB(J)=IB(J)+1
29700 GO TO 611
29800 620 CONTINUE
29900 IF(ID)648,648,623
30000 623 DO610IJ=1,ID
30100 J=FJUNK(IJ)
30200 MM=(J*N)-N
30300 FJAX(J)=0
30400 DO610I=1,N
30500 LM=MM+I
30600 IF(DATA(LM)-CODE(J,1))607,610,607
30700 607 TY=ABS(DATA(LM))
30800 IF(FJAX(J)-TY)608,610,610
30900 608 FJAX(J)=TY
31000 610 CONTINUE
31100 DO640IJ=1,ID
31200 J=FJUNK(IJ)
31300 I=0
31400 IF(FJAX(J))638,638,625
31500 625 IF(FJAX(J)-FBIG)628,635,635
31600 628 IF(FJAX(J)-FSMAL)630,638,638
31700 630 FJAX(J)=FJAX(J)*10.0
31800 I=I-1
31900 GOTO625
32000 635 FJAX(J)=FJAX(J)/10.0
32100 I=I+1
32200 GOTO625
32300 638 IB(J)=I
32400 640 CONTINUE
32500 DO645IJ=1,ID
32600 J=FJUNK(IJ)
32700 MM=(J*N)-N
32800 IIB=(-1)*IB(J)
32900 FACT=10.0**IIB
33000 DO645I=1,N
33100 LM=MM+I
33200 IF(DATA(LM)-CODE(J,1))644,645,644
33300 644 DATA(LM)=DATA(LM)*FACT
33400 645 CONTINUE
33500 648 WRITE (6,919)
33600 WRITE (6,917)
33700 MAX=13
33800 IF(ICASE)647,647,646
33900 646 MAX=12
34000 647 NF=1
34100 IF(NJJ-MAX)650,650,660
34200 650 NL=NJJ
34300 CALL PRINT(NF,NL,N,ICASE)
34400 GO TO 675
34500 660 NL=MAX
34600 CALL PRINT (NF,NL,N,ICASE)
34700 NO=NJJ
34800 663 NO=NO-MAX
34900 NF=NF+MAX
35000 WRITE (6,919)
35100 WRITE (6,918)
35200 IF(NO-MAX)670,670,665
35300 665 NL=NL+MAX
35400 CALL PRINT (NF,NL,N,ICASE)
35500 GOTO663
35600 670 NL=NL+NO
35700 CALL PRINT (NF,NL,N,ICASE)
35800 675 WRITE (6,927)
35900 DO 680 J=1,NJJ
36000 LIM=NOC(J)
36100 680 WRITE (6,928)J,(CODE(J,K),K=1,LIM)
36200 GOTO25
36300 800 FORMAT(A6,A2,I3,I4,2I3,F3.0,2I2,I3,I2,33X,A2,I2,I2)
36400 801 FORMAT(1H019X80HSAMPLE SIZE IS ZERO. PROGRAM WILL READ NEXT SELECT
36500 1ION CARD (IF ANY) AND PROCEED.)
36600 802 FORMAT(18A4)
36700 803 FORMAT(A6,I2,F5.0,I2,F5.0,I3,I2,15I3)
36800 804 FORMAT(' ERROR ON PROBLEM CARD')
36900 805 FORMAT(24H0ERROR ON SELECTION CARDI4,' PROGRAM READ IN',A6,' INSTE
37000 1AD OF SELECT')
37100 806 FORMAT(A6,I2,10F6.0)
37200 807 FORMAT(1H0,29X,58HTOO MUCH DATA. SEE LIMITATIONS ON DATA SIZE IN T
37300 1HE MANUAL.)
37400 900 FORMAT(12H0PROBLEM NO.2X,A2)
37500 901 FORMAT(10H SELECTIONI6,1H-I3)
37600 902 FORMAT(16H0VARIABLE NUMBER,I4,80H IS NOT IN THIS PROBLEM. PROGRAM
37700 1PROCEEDS TO NEXT VARABLE TO BE CROSS TABULATED.)
37800 903 FORMAT(9H0VARIABLEI4,3X,5H(ROW)26X,8HVARIABLEI4,3X,8H(COLUMN))
37900 904 FORMAT(8H MAXIMUM9X,F15.5,15X,7HMAXIMUM9X,F15.5)
38000 905 FORMAT(8H MINIMUM9X,F15.5,15X,7HMINIMUM9X,F15.5)
38100 906 FORMAT(6H RANGE11X,F15.5,15X,5HRANGE11X,F15.5)
38200 907 FORMAT(9H INTERVAL8X,F15.5,15X,8HINTERVAL8X,F15.5)
38300 908 FORMAT(1H0//)
38400 909 FORMAT(1H06X,21I5)
38500 910 FORMAT(15H0BASE VARIABLE,,I4,62H, INCORRECT. PROGRAM PROCEEDS TO N
38600 1EXT SELECTION CARD (IF ANY).)
38700 912 FORMAT(1H06X,8HITEM NO.9X,8HVARIABLEI4,1X,5H(ROW)10X,8HVARIABLEI4,
38800 11X,8H(COLUMN))
38900 913 FORMAT(1H08X,I4,12X,F15.5,13X,F15.5)
39000 914 FORMAT(18H0NO MISSING VALUES)
39100 915 FORMAT(15H0MISSING VALUES)
39200 917 FORMAT(1H018X,15HVARIABLE NUMBER)
39300 918 FORMAT(1H018X,25HVARIABLE NUMBER CONTINUED)
39400 919 FORMAT(1H142X,11HDATA MATRIX)
39500 920 FORMAT(1H07X,20(F4.0,1H ))
39600 921 FORMAT(1H07X,20(F4.1,1H ))
39700 922 FORMAT(18H ROW SPECIFICATION)
39800 925 FORMAT(21H COLUMN SPECIFICATION)
39900 923 FORMAT(6H0LABEL5X,8HINTERVAL)
40000 924 FORMAT(1H I3,F16.5,1H-)
40100 927 FORMAT(20H1MISSING VALUE CODES/9H0VARIABLE4X,5HCODES)
40200 928 FORMAT(1H I4,2X,2H* 10F11.5)
40300 929 FORMAT(25H0CORRELATION COEFFICIENT=F9.5,3X,13H(SAMPLE SIZE=I4,1H)/
40400 1///)
40500 930 FORMAT(17H0NO. OF VARIABLES7X,I3/12H SAMPLE SIZE11X,I4/23H NO. OF
40600 1SELECTION CARDSI4)
40700 931 FORMAT(28H0ERROR ON MISSING VALUE CARDI4,' PROGRAM READ IN',1X,A6,
40800 1' INSTEAD OF MSSVAL')
40900 933 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
41000 1IED, ASSUMED TO BE 1.)
41100 5000 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE F
41200 1OLLOWING'/1X,A6)
41300 5002 FORMAT(' NUMBER OF VARIABLES MUST BE LESS THAN 100 BEFORE AND AFTE
41400 1R TRANSGENERATION ')
41500 5004 FORMAT(' THE SAMPLE SIZE IS NOT WITHIN THE LIMITS SPECIFIED IN THE
41600 1 BMD MANUAL')
41700 5006 FORMAT(' THE NUMBER OF SELECTION CARDS IS NOT WITHIN THE LIMITS SP
41800 1ECIFIED IN THE BMD MANUAL')
41900 5001 WRITE(6, 5002)
42000 GO TO 27
42100 5003 WRITE(6, 5004)
42200 GO TO 27
42300 5005 WRITE(6, 5006)
42400 27 WRITE (6,804)
42500 2000 IF(MTAPE-5)2002,2002,2001
42600 2001 REWIND MTAPE
42700 2002 STOP
42800 END
42900 C SUBROUTINE MISCOD FOR BMD09D JUNE 22, 1966
43000 SUBROUTINE MISCOD (N,J,X,JET,IBLANK)
43100 DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
43200 1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
43300 2FINTVL(2),SUM(8),JUNK(21)
43400 COMMON DATA , JUNK , TD
43500 COMMON FMT , IB , SCALE , CODE , NOC , RANGE
43600 COMMON BIGA , SMAL , FINTVL
43700 EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
43800 EXTERNAL SIGN
43900 IF(N)35,35,5
44000 5 DO 30 K=1,N
44100 IF(IBLANK-K)25,15,25
44200 15 IF(X)30,20,30
44300 20 IF(SIGN(10.0,X))40,30,30
44400 25 IF(X-CODE(J,K))30,40,30
44500 30 CONTINUE
44600 35 JET=2
44700 GO TO 50
44800 40 JET=1
44900 50 RETURN
45000 END
45100 C SUBROUTINE PRINT FOR BMD09D JUNE 22, 1966
45200 SUBROUTINE PRINT (NF,NL,N,ICASE)
45300 DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
45400 1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
45500 2FINTVL(2),SUM(8),JUNK(21) ,TY(13)
45600 COMMON DATA , JUNK , TD
45700 COMMON FMT , IB , SCALE , CODE , NOC , RANGE
45800 COMMON BIGA , SMAL , FINTVL
45900 EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
46000 IF(ICASE)15,15,40
46100 15 WRITE (6,918)(L(I),I=NF,NL)
46200 WRITE (6,919)(IB(J),J=NF,NL)
46300 WRITE (6,920)
46400 DO30I=1,N
46500 K=0
46600 DO20J=NF,NL
46700 LL=N*J-N+I
46800 K=K+1
46900 20 TY(K)=DATA(LL)
47000 30 WRITE (6,921)I,(TY(M),M=1,K)
47100 GOTO1000
47200 40 WRITE (6,928)(L(I),I=NF,NL)
47300 WRITE (6,929)(IB(J),J=NF,NL)
47400 WRITE (6,920)
47500 DO60I=1,N
47600 K=0
47700 DO50J=NF,NL
47800 LL=N*J-N+I
47900 K=K+1
48000 50 TY(K)=DATA(LL)
48100 60 WRITE (6,931)I,IDENT(I),(TY(M),M=1,K)
48200 918 FORMAT(5H0ITEM3X,1H*/7H NUMBER1X,1H*,I7,12I8)
48300 919 FORMAT(1H05X,5HSCALEI5,12I8)
48400 920 FORMAT(1H0)
48500 921 FORMAT(1H I4,5X,13F8.0)
48600 928 FORMAT(5H0ITEM3X,8HI.D. * /4H NO.4X,8HNO. * 12I8)
48700 929 FORMAT(1H013X,5HSCALEI5,11I8)
48800 931 FORMAT(1H I4,I7,4X,12F8.0)
48900 1000 RETURN
49000 END
49100 C SUBROUTINE SELECM FOR B M09D JUNE 22, 1966
49200 SUBROUTINE SELECM (LBV,L,N,ROWINT,NR,KING,FJUNK,ROW)
49300 DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
49400 1M(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
49500 2FINTVL(2),SUM(8),JUNK(21),FJUNK(2000),ROW(21)
49600 COMMON DATA , JUNK , TD
49700 COMMON FMT , IB , SCALE , CODE , NOC , RANGE
49800 COMMON BIGA , SMAL , FINTVL
49900 EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,M)
50000 KING=1
50100 DATA ASTRX/1H*/
50200 FCODE=-999.00999
50300 BIGEST=10.0**36
50400 TSMAL=-BIGEST
50500 LM=LBV*N-N
50600 BIGA(L)=TSMAL
50700 SMAL(L)=BIGEST
50800 DO 145 J=1,N
50900 MN=LM+J
51000 D=DATA(MN)
51100 IF(SCALE(LBV)-99.0)105,100,105
51200 100 IF(D-FCODE)125,145,125
51300 105 LIM=NOC(LBV)
51400 IBLANK=IB(LBV)
51500 CALL MISCOD (LIM,LBV,D,JET,IBLANK)
51600 GO TO (145,125),JET
51700 125 IF(BIGA(L)-DATA(MN))130,135,135
51800 130 BIGA(L)=DATA(MN)
51900 135 IF(SMAL(L)-DATA(MN))145,145,140
52000 140 SMAL(L)=DATA(MN)
52100 145 CONTINUE
52200 RANGE(L)=BIGA(L)-SMAL(L)
52300 IF(SCALE(LBV)-99.0)139,137,139
52400 137 CODE(LBV,1)=FCODE
52500 NOC(LBV)=1
52600 IB(LBV)=0
52700 139 IF(ROWINT)170,170,160
52800 160 FINTVL(L)=ROWINT
52900 GO TO 180
53000 170 SUBRAN=RANGE(L)/(FLOAT(NR)-1.0)
53100 IF(SUBRAN-1.0) 174, 172, 174
53200 172 FINTVL(L)=1.0
53300 GO TO 180
53400 174 CALL INTVL(SUBRAN,SINT)
53500 FINTVL(L)=SINT
53600 180 ROW(1)=SMAL(L)
53700 DO 190 I=2,NR
53800 190 ROW(I)=ROW(I-1)+FINTVL(L)
53900 IF(SMAL(L))149,141,141
54000 141 IF(BIGA(L)-1000.0)142,149,149
54100 142 IF(FINTVL(L)-1.0)144,143,143
54200 143 KING=2
54300 GO TO 149
54400 144 IF(BIGA(L)-100.0)146,149,149
54500 146 IF(FINTVL(L)-0.099999)149,147,147
54600 147 KING=3
54700 149 CONTINUE
54800 DO 220 K=1,N
54900 MM=LM+K
55000 IF(SCALE(LBV)-99.0)200,216,200
55100 216 IF(DATA(MM)-FCODE)201,194,201
55200 200 D=DATA(MM)
55300 LIM=NOC(LBV)
55400 IBLANK=IB(LBV)
55500 CALL MISCOD (LIM,LBV,D,JET,IBLANK)
55600 GO TO (194,201),JET
55700 194 FJUNK(K)=ASTRX
55800 GO TO 220
55900 201 DO 215 I=2,NR
56000 IF(DATA(MM)-ROW(I)) 210, 215, 215
56100 210 FJUNK(K)=I-1
56200 GO TO 220
56300 215 CONTINUE
56400 FJUNK(K)=NR
56500 220 CONTINUE
56600 RETURN
56700 END
56800 C SUBROUTINE TRANS FOR BMD09D JUNE 22, 1966
56900 SUBROUTINE TRANS (NJ,N,IERROR,NVG)
57000 DOUBLE PRECISION A1,A2
57100 DIMENSION DATA(6000),IDENT(2000),FMT(180),IB(100),TD(100),
57200 1L(100),SCALE(100),CODE(100,10),NOC(100),RANGE(2),BIGA(2),SMAL(2),
57300 2FINTVL(2),SUM(8),JUNK(21)
57400 COMMON DATA , JUNK , TD
57500 COMMON FMT , IB , SCALE , CODE , NOC , RANGE
57600 COMMON BIGA, SMAL, FINTVL, K000FX
57700 ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
57800 EQUIVALENCE (DATA(4001),IDENT),(JUNK,SUM),(TD,L)
57900 DATA A2/6HTRNGEN/
58000 INTEGER ALTMAX
58100 ALTMAX = 4000
58200 MAXNPQ = 6000
58300 FCODE=-999.00999
58400 FN=N
58500 WRITE (6,1403)
58600 WRITE (6,1400)
58700 IERROR=0
58800 DO 1000 I=1,NVG
58900 READ (5,1100)A1,NEWA,LCODE,LVA,BNEW
59000 III=I
59100 IF(A1 .NE. A2) GO TO 1001
59200 WRITE (6,1402)I,NEWA,LCODE,LVA,BNEW
59300 MARY=0
59400 MA=N*NEWA-N
59500 MB=N*LVA-N+1
59600 MC=MB+N-1
59700 IF(K000FX)301,322,301
59800 301 IF(MC-ALTMAX)343,343,315
59900 315 WRITE (6,320)MC
60000 STOP
60100 320 FORMAT(35H DATA SIZE N(P+Q) EXCEEDED, SIZE = I6)
60200 322 IF(MC-MAXNPQ)343,343,315
60300 343 K=BNEW
60400 MD=N*K-N
60500 DO 3 J=MB,MC
60600 MA=MA+1
60700 MD=MD+1
60800 D=DATA(J)
60900 IF(SCALE(LVA)-99.0)49,203,49
61000 203 IF(D-FCODE)51,190,51
61100 49 LIM=NOC(LVA)
61200 IBLANK=IB(LVA)
61300 CALL MISCOD (LIM,LVA,D,JET,IBLANK)
61400 GO TO (190,51),JET
61500 51 IF(LCODE*(15-LCODE)) 4001,4001,52
61600 4001 WRITE (6,6002) NVG
61700 6002 FORMAT(' ILLEGAL TRANSGENERATION CODE ENCOUNTERED ON TRNGEN CARD
61800 1 NO.',I4)
61900 STOP
62000 52 IF (LCODE.LT.11) GO TO 54
62100 X = DATA(MD)
62200 IF(SCALE(K)-99.0)202,201,202
62300 201 IF(X-FCODE)54,190,54
62400 202 LIM=NOC(K)
62500 IBLANK=IB(K)
62600 CALL MISCOD(LIM,K,X,JET,IBLANK)
62700 GO TO (190,54),JET
62800 54 CONTINUE
62900 GO TO (10,20,30,40,50,60,70,80,90,100,110,120,130,140),LCODE
63000 10 IF(D)99,7,8
63100 7 DATA(MA)=0.0
63200 GO TO 3
63300 8 DATA(MA)=SQRT(D)
63400 GO TO 3
63500 20 IF(D)99,11,12
63600 11 DATA(MA)=1.0
63700 GO TO 3
63800 12 DATA(MA)=SQRT(D)+SQRT(D+1.0)
63900 GO TO 3
64000 30 IF(D)99,99,14
64100 14 DATA(MA)=ALOG10(D)
64200 GO TO 3
64300 40 DATA(MA)=EXP(D)
64400 GO TO 3
64500 50 IF(-D)17,7,99
64600 17 IF(D-1.0)18,19,99
64700 18 DATA(MA)=ASN(SQRT(D))
64800 GO TO 3
64900 19 DATA(MA)=3.14159265/2.0
65000 GO TO 3
65100 60 A=D/(FN+1.0)
65200 B=A+1.0/(FN+1.0)
65300 IF(A)99,23,24
65400 23 IF(-B)27,7,99
65500 27 DATA(MA)=ASN(SQRT(B))
65600 GO TO 3
65700 24 IF(B)99,28,29
65800 28 DATA(MA)=ASN(SQRT(A))
65900 GO TO 3
66000 29 DATA(MA)=ASN(SQRT(A))+ASN(SQRT(B))
66100 GO TO 3
66200 70 IF(D)31,99,31
66300 31 DATA(MA)=1.0/D
66400 GO TO 3
66500 80 DATA(MA)=D+BNEW
66600 GO TO 3
66700 90 DATA(MA)=D*BNEW
66800 GO TO 3
66900 100 IF(D)33,7,33
67000 33 DATA(MA)=D**BNEW
67100 GO TO 3
67200 110 DATA(MA)=D+X
67300 GO TO 3
67400 120 DATA(MA)=D-X
67500 GO TO 3
67600 130 DATA(MA)=D*X
67700 GO TO 3
67800 140 IF(X)145,99,145
67900 145 DATA(MA)=D/X
68000 GO TO 3
68100 190 DATA(MA)=FCODE
68200 GO TO 3
68300 99 IF(MARY)43,44,44
68400 44 MARY=-999
68500 IERROR=-999
68600 WRITE (6,1404)I
68700 43 WRITE (6,1405)J
68800 3 CONTINUE
68900 SCALE(NEWA)=99.0
69000 1000 CONTINUE
69100 GO TO 1150
69200 1001 WRITE (6,1406)III,A1
69300 IERROR=-999
69400 IF(III-NVG) 300, 42, 42
69500 300 III=III+1
69600 DO 1005 KK=III,NVG
69700 1005 READ (5,1100)A1
69800 1150 IF(IERROR)42,1111,1111
69900 42 WRITE (6,1401)
70000 1100 FORMAT(A6,I3,I2,I3,F6.0)
70100 1400 FORMAT(46H0CARD NEW TRANS ORIG. ORIG. VAR(B)/45H NO.
70200 1VARIABLE CODE VAR(A) OR CONSTANT)
70300 1401 FORMAT(42H0PROGRAM CANNOT CONTINUE FOR THIS PROBLEM.)
70400 1402 FORMAT(2H I2,I8,2I9,4X,F10.5)
70500 1403 FORMAT(1H06X,23HTRANSGENERATION CARD(S))
70600 1404 FORMAT(55H0THE INSTRUCTIONS INDICATED ON TRANSGENERATION CARD NO.I
70700 12,1X,3HRE-/60H SULTED IN THE VIOLATION OF A RESTRICTION FOR THIS T
70800 2RANSFOR-/59H MATION. THE VIOLATION OCCURRED FOR THE ITEMS LISTED B
70900 3ELOW.)
71000 1405 FORMAT(10H ITEM NO. I5)
71100 1406 FORMAT(30H0ERROR ON TRANSGENERATION CARDI4,' PROGRAM READ IN',1X,A
71200 16,' INSTEAD OF TRNGEN')
71300 1111 RETURN
71400 END
71500 C SUBROUTINE INTVL FOR BMD09D JUNE 22, 1966
71600 SUBROUTINE INTVL(X,XINT)
71700 DIMENSION TLIMIT(4),FLIMIT(4)
71800 DATA TLIMIT/1.0,2.0,5.0,10.0/
71900 IF(X-1.0)10,30,30
72000 10 IP=(-1)
72100 DO20II=1,38
72200 I=IP*II
72300 POWER=10.0**I
72400 IF(X-POWER)20,50,50
72500 20 CONTINUE
72600 30 DO45II=1,39
72700 I=II-1
72800 POWER=10.0**I
72900 IF(X-POWER)40,45,45
73000 40 POWER=POWER/10.0
73100 GOTO50
73200 45 CONTINUE
73300 50 DO55I=1,4
73400 55 FLIMIT(I)=TLIMIT(I)*POWER
73500 DO70I=1,4
73600 IF(X-FLIMIT(I))60,70,70
73700 60 XINT=FLIMIT(I)
73800 GOTO80
73900 70 CONTINUE
74000 80 RETURN
74100 END
74200 C SUBROUTINE TPWD FOR BMD09D JUNE 22, 1966
74300 SUBROUTINE TPWD(NT1,NT2)
74400 IF(NT1)40,10,12
74500 10 NT1=5
74600 12 IF(NT1-NT2)14,19,14
74700 14 IF(NT2.EQ.5)GO TO 18
74800 17 REWIND NT2
74900 19 IF(NT1-5)18,24,18
75000 18 IF(NT1-6)22,40,22
75100 22 REWIND NT1
75200 24 NT2=NT1
75300 28 RETURN
75400 40 WRITE (6,49)
75500 STOP
75600 49 FORMAT(25H ERROR ON TAPE ASSIGNMENT)
75700 END
75800 SUBROUTINE WRITVA(IC,VA,PL,Q,PR,MIKE,MATRIX,ICX,IRX,ID,L,ROW,
75900 * JUNK,I,J,K,IC2,IR)
76000 DOUBLE PRECISION PR,PL,VA(28),Q(27)
76100 DIMENSION JUNK(21), MATRIX(21,21), ROW(21),L(100)
76200 VA(1) = PL
76300 VA(2) = Q(7)
76400 DO 420 KX = 1,IC
76500 K = KX+2
76600 420 VA(K) = Q(8)
76700 K = K+1
76800 VA(K) = Q(9)
76900 K = K+1
77000 VA(K) = Q(10)
77100 K = K+1
77200 VA(K) = PR
77300 WRITE (6,VA)
77400 ID = 0
77500 VA(1) = PL
77600 VA(2) = Q(12)
77700 430 ID = ID+1
77800 I = IR-ID+1
77900 GO TO 440
78000 435 VA(3) = Q(13)
78100 VA(4) = Q(14)
78200 GO TO 445
78300 440 GO TO (441,442,443), MIKE
78400 441 VA(3) = Q(15)
78500 VA(4) = Q(16)
78600 GO TO 445
78700 442 VA(3) = Q(17)
78800 VA(4) = Q(18)
78900 GO TO 445
79000 443 VA(3) = Q(19)
79100 VA(4) = Q(18)
79200 445 DO 470 J=1,IC
79300 K=4+J
79400 IF (MATRIX(I,J)) 450,450,460
79500 450 VA(K) = Q(8)
79600 GO TO 470
79700 460 VA(K) = Q(20)
79800 470 CONTINUE
79900 K = K+1
80000 IF (MATRIX(I,ICX)) 480,480,485
80100 480 VA(K) = Q(8)
80200 GO TO 490
80300 485 VA(K) = Q(21)
80400 490 K = K+1
80500 VA(K) = PR
80600 K = 0
80700 DO 510 J=1,ICX
80800 IF (MATRIX(I,J)) 510,510,500
80900 500 K = K+1
81000 JUNK(K) = MATRIX(I,J)
81100 510 CONTINUE
81200 IF (I-IRX) 520,550,550
81300 520 IF (K) 525,525,530
81400 525 GO TO (526,527,527), MIKE
81500 526 WRITE (6,VA) L(I)
81600 GO TO 535
81700 527 WRITE (6,VA) ROW(I)
81800 GO TO 535
81900 530 GO TO (531,532,532), MIKE
82000 531 WRITE (6,VA) L(I), (JUNK(J), J=1,K)
82100 GO TO 535
82200 532 WRITE (6,VA) ROW(I), (JUNK(J),J=1,K)
82300 535 IF (I-1) 540,540,536
82400 536 GO TO 430
82500 540 I = IRX
82600 GO TO 435
82700 550 WRITE (6,VA) (JUNK(J),J=1,K)
82800 RETURN
82900 END
83000
83100
83200
83300
83400
83500
83600
83700
83800
83900
84000
84100