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