Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - 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