Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd09s.for
There is 1 other file named bmd09s.for in the archive. Click here to see a list.
C             TRANSGENERATION - MAIN PROGRAM         MARCH 21, 1966
C        THIS IS A SIFTED VERSION OF BMD09S ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
C        IT WAS THEN CONVERTED TO 360 FORTRAN IV (H-LEVEL)
CPROGRAM FLOW-
C    1. DETERMINE TYPE OF INPUT AND READ IN VARIABLE INPUT FORMAT CARDS
C      A) PUNCHED INPUT- PREPARE BRANCHES AND LISTING
C      B) BINARY TAPE INPUT- PREPARE BRANCHES AND LISTING, CHECK JIN
C      C) BCD TAPE INPUT- PREPARE BRANCHES AND LISTING
C      D) NON-PUNCHED INPUT- PREPARE BRANCHES AND CHECK MIN
C      E) LIST METHOD OF INPUT
C      F) NON-BINARY INPUT- PREPARE BRANCHES, CHECK JIN, LIST FORMAT
C    2. DETERMINE TYPES OF OUTPUT, READ IN VARIABLE OUTPUT FORMATS
C      A) PRINTED OUTPUT- PREPARE BRANCHES AND LISTINGS, CHECK JPRT
C      B) PUNCHED OUTPUT- PREPARE BRANCHES AND LISTINGS, CHECK JPNCH AND
C                                                                 NPUNCH
C      C) BINARY OUTPUT- PREPARE BRANCHES AND LISTINGS, CHECK JTAPE
C      D) BCD OUTPUT- PREPARE BRANCHES AND LISTINGS, CHECK JTAPE
C      E) TAPE OUTPUT- CHECK MIN
C      F) NON-TAPE OUTPUT- PREPARE BRANCH
C      G) LIST METHODS OF OUTPUT
C      H) LIST TYPE AND NUMBER OF OUTPUT TAPE
C      I) READ AND LIST APPROPRIATE FORMAT CARDS
C    3. READ TRANSGENERATION CARDS, CHECK CONSTRAINTS, SAVE LOCATIONS OF
C       ALL TYPE-18 AND -19 TRANSGENERATIONS, STORE TYPE-40 CONSTANTS
C    4. RUN THROUGH DATA FOR MEAN AND STANDARD DEVIATION COMPUTATIONS
C                (IF DATA INPUT WAS FROM CARDS, IT IS WRITTEN ON TAPE 2)
C    5. CHECK THAT NO VARIABLE USED IN TYPE-18 OR -19 TRANSGENERATION IS
C       CHANGED (UNLESS BY ANOTHER TYPE-18) BEFORE THAT TRANSGENERATION
C    6. CALL SUBROUTINE TRANS TO TRANSGENERATE, ONE CASE AT A TIME FROM
C              TAPE, SAVE OLD AND NEW VARIABLES FOR FIRST AND LAST CASES
C    7. AFTER EACH CASE THE REQUESTED OUTPUTS ARE MADE
C    8. PRINT OUT OLD AND NEW VARIABLES FOR FIRST AND LAST CASES
CGUIDE TO FIRST LETTER IN FIXED-POINT VARIABLES-
C    I    TO DETERMINE TRANSFERS AND FOR OUTERMOST DO LOOPS
C    J    NUMBER OF VARIABLE FORMAT CARDS (JIN,JPRT,JPNCH,JTAPE)
C    K    ALPHABETIC CONTROL WORDS AND CHECKS ON SAME
C    M    TAPE NO. (MIN,MIN2,MOUT,MOUT1)
C    N    ALL OTHER VARIABLES (EXCEPT KODE)
CGUIDE TO DIMENSIONED VARIABLES-
C    CONS=   CONSTANTS IN TYPE-40 TRANSGEN. (ONLY 50 40'S PERMITTED)
C    CONST=  2ND VARIABLE NO. OR REGULAR CONSTANT FOR TRANSGENERATIONS
C    DATA=   DATA (TRANSGENERATED ONE CASE AT A TIME FROM TAPE)
C    FMT=    VARIABLE INPUT FORMAT
C    KODE=   TYPE OF TRANSGENERATION
C    NCON40= NUMBER OF TYPE-40 CONSTANTS
C    NOTRAN= OLD VARIABLE TO BE TRANSGENERATED
C    NSUM18= LOCATION OF CARDS HAVING TYPE-18 OR -19 TRANSGENERATIONS
C    NTRAN=  NEW VARIABLE AFTER TRANSGENERATION
C    OUTPUT= USED FOR ALPHABETIC LISTING OF METHODS OF DATA OUTPUT
C    PRINT=  VARIABLE PRINT FORMAT
C    PUNCH=  VARIABLE PUNCH FORMAT
C    SAMPL=  USED TO SAVE OLD AND NEW VARIABLES FOR FIRST AND LAST CASES
C    SUM18=  USED FOR SUM OF SQUARES IN TYPE-19 TRANSGENERATIONS
C    TAPE=   VARIABLE BCD TAPE FORMAT
C    TRAN40= USED FOR TEMPORARY STORAGE OF TYPE-40 CONSTANTS
CGUIDE TO PROBLEM CARD (WITH LIMITS OF PARAMETER VALUES)-
C    PROB =  IDENTIFIES PROBLEM CARD WITH WORD- PROBLM
C    PRBM=   ALPHANUMERIC USER'S PROBLEM NUMBER OR OTHER IDENTIFICATION
C    NCASE=  NUMBER OF CASES (LIMIT OF 130000)
C    NVAR=   NUMBER OF VARIABLES INPUTED (LIMIT OF 99)
C    NADVAR= NUMBER OF VARIABLES ADDED BY TRANSGEN.  (NVAR+NADVAR  99)
C    NPUNCH= NO. OF VARIABLES PUNCHED/ BLANK IF SAME AS NOVAR (LIMIT99)
C    NTRG=   NUMBER OF TRANSGENERATION CARDS(LIMIT 99)
C    AINPUT= CRD FOR PUNCHED INPUT, BCD FROM BCD TAPE, BIN FROM BIN.TAPE
C    MIN=    INPUT TAPE NO./ BLANK IF INPUT ON CARDS (LIMIT 16, NOT 5,6)
C     PRNT=  YES IF PRINT-OUT DESIRED/ OTHERWISE BLANK
C     PNCH=  YES IF PUNCHED CARD OUTPUT DESIRED/ OTHERWISE BLANK
C     OUT=   BCD FOR BCD TAPE OUTPUT, BIN FOR BINARY TAPE, IF NONE BLANK
C    MOUT=   OUTPUT TAPE NO./BLANK IF NONE (LIMIT OF 16, NOT 5 OR 6)
C    JIN=    NO. OF VARIABLE INPUT FORMAT CARDS/ BLANK IF BINARY INPUT
C    JPRT=   NO. OF VARIABLE PRINT FORMAT CARDS/ BLANK IF NO PRINT-OUT
C    JPNCH=  NO. OF VARIABLE PUNCH FORMAT CARDS/ BLANK IF NO PUNCHING
C    JTAPE=  NO. OF VARIABLE BCD FORMAT CARDS/ BLANK IF NO BCD OUTPUT
C                        (ALL VARIABLE FORMATS ARE LIMITED TO 10 CARDS)
CLIST OF VARIABLES NOT APPEARING IN DIMENSION OR PROBLEM CARD LISTS-
C    IFPNCH  WHETHER TO PUNCH OUTPUT
C    IFPRT   WHETHER TO PRINT OUTPUT
C    IMIN2   WHETHER TO SET MIN=2 AFTER INPUT IS WRITTEN ON SCRATCH TAPE
C    INOFMT  WHETHER TO READ IN INPUT FORMAT CARDS
C    INSAVE  WHETHER TO SAVE NEW VARIABLES
C    INTAP   WHETHER BINARY OR BCD TAPE READ DURING MAIN DATA PASS
C    INTAPE  WHETHER BINARY OR BCD TAPE READ DURING PREPASS
C    IPRINT  WHETHER TO READ IN PRINT FORMAT CARDS
C    IPUNCH  WHETHER TO READ IN PUNCH FORMAT CARDS
C    IREWND  WHETHER TO REWIND INPUT TAPE
C    ISAVE   WHETHER TO CONTINUE MAIN LOOP OR BRANCH OUT LAST TIME
C    ISPECL  WHETHER TO SAVE OLD VARIABLES FOR LAST CASE
C    ITAPE   WHETHER BINARY OR BCD OR NO TAPE OUTPUT
C    IWRTAP  WHETHER TO READ IN BCD TAPE FORMAT CARDS
C    IWRIT2  WHETHER TO WRITE PUNCHED INPUT ON SCRATCH TAPE AT PREPASS
C    I1SAVE  WHETHER TO SAVE OLD VARIABLES
C    NCAS    (NO. OF CASES)-1
C    NLOC    USED TO POSITION NAMES OF TYPES OF OUTPUT
C    NLOC18  THE LOCATION OF CARDS WITH TYPE-18 OR 19 TRANSGENERATIONS
C    NOVAR   NUMBER OF VARIABLES AFTER TRANSGENERATION
C    NUM18   COUNTS THE NUMBER OF TYPE-18 AND -19 TRANSGENERATIONS
C    N18     THE VARIABLE USED IN A TYPE-18 OR -19 TRANSGENERATION
C    N40     COUNTS THE NUMBER OF TYPE-40 TRANSGENERATIONS
C    TEMP,TEMP1   NAME OF TYPE OF DATA INPUT
CGUIDE TO STATEMENT NUMBERING-
C    200'S     TRANSFERS FROM IF AND COMPUTED GOTO STATEMENTS
C    300'S     TRANSFERS FROM UNCONDITIONAL GOTO STATEMENTS
C    400'S     END OF DO LOOPS  (ORDERED BY THE ORDER OF BEGINNING NOT
C    500'S     TRANSFERS FROM CHECKS ON PROBLM CARD       (END OF LOOPS)
C    600'S     TRANSFERS FROM ASSIGNED GOTO STATEMENTS
C    900'S     ERROR OUTPUTS
C    950'S     FORMAT STATEMENTS FOR ERROR OUTPUTS
C    1000'S    FORMAT STATEMENTS FOR WRITE OUTPUTS
C    2000'S    FORMAT STATEMENTS FOR READ INPUTS
      DOUBLE PRECISION SAMPL
      DOUBLE PRECISION PROB,PRBM,TRGN,OUTPUT,DATA
      DOUBLE PRECISION A123,B123,C123
      DOUBLE PRECISION TEMP,TEMP1,Q007HL,Q008HL,Q009HL,Q010HL,Q011HL,
     1Q012HL, Q013HL,Q014HL
      DIMENSION CONS(7,50),CONST(99),DATA(1500),FMT(180),KODE(99),NCON
     140(50),NOTRAN(99),NSUM18(99),NTRAN(99),OUTPUT(6),PRINT(180),PUN
     2CH(180),SAMPL(3,99),SUM18(99),TAPE(180),TRAN40(7)
      COMMON DATA,CONS,CONST,KODE,NCASE,NCON40
      COMMON  NOTRAN , NTRAN  , NTRG   , NVAR
      DATA A123,B123,C123,D123,E123,F123,G123/6HPROBLM,6HFINISH,6HTRNGEN
     X,3HYES,3HBCD,3HBIN,3HCRD/
C
 1001 FORMAT(39H1BMD09S - TRANSGENERATION - VERSION OF 
     114HMARCH 21, 1966/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
C
      MIN2=5
      MOUT1=6
	CALL USAGEB('BMD09S')
C
C     READ PROBLEM CARD
C
  888 READ (5,2001) PROB, PRBM,NCASE,NVAR,NADVAR,NPUNCH, NTRG,AINPUT,MIN
     1, PRNT, PNCH, OUT,MOUT,JIN,JPRT,JPNCH,JTAPE
 2001 FORMAT(2A6,I6,I3,I4,2I3,A3,I2,3A3,I2,17X,4I2)
      IF(PROB.EQ.B123)GO TO 999
      IF(PROB.NE.A123)GO TO 903
  501 WRITE (6,1001)
      NOVAR=NVAR+NADVAR
      WRITE (6,1002)PRBM,NCASE,NVAR,NOVAR,NTRG
 1002 FORMAT(1H    18X,12HPROBLEM NO. A6/22H0THIS PROBLEM CONTAINSI6,29H
     1 CASES.  INITIALLY THERE ARE I3,34H VARIABLES, AFTER TRANSGENERATI
     2ON-I3,11H VARIABLES./1H I3,33H TRANSGENERATIONS ARE TO BE MADE.)
      REWIND 2
      ASSIGN 1000 TO IREWND
      ASSIGN 6093 TO KSKIP
      ASSIGN 2475 TO ISKIP
      IF(NCASE) 903,903,502
  502 IF(NVAR) 903,903,503
  503 IF(NOVAR) 903,903,504
  504 IF(NTRG)903,5045,505
 5045 ASSIGN 6096 TO KSKIP
      ASSIGN 280  TO ISKIP
  505 IF(NOVAR-99) 506,506,903
  506 IF(NCASE-130000)507,507,903
C
C
CERROR OUTPUTS
C
  900 WRITE (6,950)
  950 FORMAT(48H0AN IMPROPER INPUT OR OUTPUT TAPE WAS SPECIFIED.)
      GO TO 1000
  901 WRITE (6,951)
  951 FORMAT(49H0NO METHOD OF INPUT OR OUTPUT HAS BEEN SPECIFIED.)
      GO TO 1000
  902 WRITE (6,952)
  952 FORMAT(82H0AN IMPROPER NUMBER OF FORMAT CARDS ARE CALLED FOR SOME 
     1INPUT OR OUTPUT OPERATION.)
      GO TO 1000
  903 WRITE (6,953)
  953 FORMAT(47H0CONTROL CARDS MISPUNCHED OR CARDS OUT OF ORDER)
      GO TO 1000
  904 WRITE (6,954)
  954 FORMAT(16H0A PROGRAM ERROR)
      GO TO 1000
C
CEND OF PROGRAM
C
  999 IF(MOUT1-6)297,299,297
 297  END FILE MOUT1
 296  REWIND MOUT1
  299 GO TO IREWND,(699,1000)
  699 IF(MIN2.LE.5)GO TO 1000
      REWIND MIN2
 1000 STOP
C
CPART 1
C
  507 IF(AINPUT.NE.G123)GO TO 201
      DATA Q007HL/6HPUNCH /
  200 TEMP=(+Q007HL)
      DATA Q008HL/6HCARDS /
      TEMP1=(+Q008HL)
      MIN=5
      ASSIGN 600 TO INOFMT
      ASSIGN 604 TO IWRIT2
      GO TO 206
  201 IF(AINPUT.NE.F123)GO TO 203
      DATA Q009HL/6HBINARY/
  202 TEMP=(+Q009HL)
      DATA Q010HL/6H TAPE /
      TEMP1=(+Q010HL)
      ASSIGN 601 TO INOFMT
      ASSIGN 602 TO INTAPE
      ASSIGN 607 TO INTAP
      IF(JIN)902,205,902
  203 IF(AINPUT.NE.E123)GO TO 901
      DATA Q011HL/6H   BCD/
  204 TEMP=(+Q011HL)
      TEMP1=(+Q010HL)
      ASSIGN 600 TO INOFMT
  205 ASSIGN 605 TO IWRIT2
      ASSIGN 699 TO IREWND
      IF(MIN.EQ.0.OR.MIN.GE.17)GO TO 900
  206 WRITE (6,1003)TEMP,TEMP1,MIN
 1003 FORMAT(17H0INPUT DATA FROM 2A6,9H ON TAPE I2)
      GO TO INOFMT,(600,601)
 600  CALL VFCHCK(JIN)
C208  JIN=JIN*12
 208  JIN=JIN*18
      ASSIGN 603 TO INTAPE
      ASSIGN 606 TO INTAP
C
C     READ INPUT VARIBLE FORMAT
C
      READ (5,2002)(FMT(I),I=1,JIN)
C2002 FORMAT(12A6)
 2002 FORMAT(18A4)
      WRITE (6,1004)(FMT(I),I=1,JIN)
C1004 FORMAT(21H THE INPUT FORMAT IS-/(1H ,12A6))
 1004 FORMAT(21H THE INPUT FORMAT IS-/(1H ,18A4))
C
CPART 2
C
  601 NLOC=2
      IPRINT=0
      IPUNCH=0
      IWRTAP=3
      IF(PRNT.NE.D123)GO TO 211
 209  CALL VFCHCK(JPRT)
      DATA Q012HL/6H PRINT/
  210 OUTPUT(1)=(+Q012HL)
      DATA Q013HL/6H,     /
      OUTPUT(2)=(+Q013HL)
      NLOC=NLOC+2
      IPRINT=1
C     JPRT=JPRT*12
      JPRT=JPRT*18
      ASSIGN 612 TO IFPRT
      GO TO 312
  211 ASSIGN 613 TO IFPRT
  312 IF(PNCH.NE.D123)GO TO 216
 213  CALL VFCHCK(JPNCH)
  214 OUTPUT(NLOC-1)=(+Q007HL)
      DATA Q014HL/6HCARDS,/
      OUTPUT(NLOC)=(+Q014HL)
      NLOC=NLOC+2
      IPUNCH=1
C     JPNCH=JPNCH*12
      JPNCH=JPNCH*18
      ASSIGN 614 TO IFPNCH
      IF(NPUNCH)215,215,217
  215 NPUNCH=NOVAR
      GO TO 217
  216 ASSIGN 615 TO IFPNCH
  217 IF(OUT.NE.F123)GO TO 219
  218 OUTPUT(NLOC-1)=(+Q009HL)
      OUTPUT(NLOC)=(+Q010HL)
      IWRTAP=2
      ASSIGN 617 TO ITAPE
      IF(JTAPE) 902,222,902
  219 IF(OUT.NE.E123)GO TO 224
 220  CALL VFCHCK(JTAPE)
  221 OUTPUT(NLOC-1)=(+Q011HL)
      OUTPUT(NLOC)=(+Q010HL)
      IWRTAP=1
C     JTAPE=JTAPE*12
      JTAPE=JTAPE*18
      ASSIGN 616 TO ITAPE
  222 IF(MOUT.EQ.0.OR.MOUT.EQ.2.OR.MOUT.EQ.5.OR.MOUT.EQ.6.OR.MOUT.GE.17)
     XGO TO 900
      GO TO 225
  224 ASSIGN 618 TO ITAPE
      NLOC=NLOC-2
      IF(IPRINT+IPUNCH) 904,901,227
  225 CALL TPWD2(MOUT,MOUT1)
  227 WRITE (6,1005)(OUTPUT(I),I=1,NLOC)
 1005 FORMAT(17H0DATA OUTPUT IS- 3(2A6,1X))
      CALL TPWD(MIN,MIN2)
      GO TO(231,231,232), IWRTAP
  231 WRITE (6,1006)OUTPUT(NLOC-1),OUTPUT(NLOC),MOUT
 1006 FORMAT(16H OUTPUT TAPE IS 2A6,3HNO.I3)
  232 IF(IPRINT) 904,241,240
  240 WRITE (6,1007)
 1007 FORMAT(21H0THE PRINT FORMAT IS-)
      READ (5,2002)(PRINT(I),I=1,JPRT)
      WRITE (6,1008)(PRINT(I),I=1,JPRT)
C1008 FORMAT(1H ,12A6)
 1008 FORMAT(1H ,18A4)
  241 IF(IPUNCH) 904,244,242
  242 WRITE (6,1009)
 1009 FORMAT(35H0THE PUNCHED CARD OUTPUT FORMAT IS-)
      READ (5,2002)(PUNCH(I),I=1,JPNCH)
      WRITE (6,1008)(PUNCH(I),I=1,JPNCH)
  244 GO TO (245,247,247),IWRTAP
  245 WRITE (6,1010)
 1010 FORMAT(31H0THE BCD OUTPUT TAPE FORMAT IS-)
      READ (5,2002)(TAPE(I),I=1,JTAPE)
      WRITE (6,1008)(TAPE(I),I=1,JTAPE)
C
CPART 3
C
  247 NUM18=0
      N40=0
      GO TO ISKIP,(2475,280)
 2475 WRITE (6,1011)
 1011 FORMAT(1H06X21H TRANSGENERATOR CARDS/5H0CARD4X3HNEW5X5HTRANS4X
     1 20HORIG.   ORIG. VAR(B)10X,17HTYPE 40 CONSTANTS/45H  NO. VARIABLE
     2   CODE    VAR(A)   OR CONSTANT)
      DO 400 I=1,NTRG
      READ (5,2003) TRGN,NTRAN(I),KODE(I),NOTRAN(I),CONST(I), NCONS,(TRA
     1N40(J),J=1,7)
 2003 FORMAT(A6,I3,I2,I3,F6.0,5X,I1,7F6.0)
      IF(TRGN.NE.C123)GO TO 903
  248 IF(KODE(I)*(KODE(I)-27))249,905,251
  249 IF(KODE(I).NE.18.AND.KODE(I).NE.19)GO TO 255
  250 NUM18=NUM18+1
      NSUM18(NUM18)=I
      SUM18(I)=0
      CONST(I)=0
      GO TO 255
 251  IF(KODE(I)-40)905,252,2515
 2515 IF(KODE(I)-42)255,252,254
  252 IF(NCONS.EQ.0.OR.NCONS.GE.8)GO TO 905
  253 N40=N40+1
      DO 401 II=1,NCONS
  401 CONS(II,N40)=TRAN40(II)
      NCON40(N40)=NCONS
      WRITE (6,1012)I,NTRAN(I),KODE(I),NOTRAN(I),CONST(I), (CONS(II,N40)
     1,II=1,NCONS)
 1012 FORMAT(1H ,I3,I8,2I9,F15.5,5X5F14.5/50X,2F14.5)
      GO TO 400
  254 IF(KODE(I).EQ.43)GO TO 255
  905 WRITE (6,955)
  955 FORMAT(112H0THE FOLLOWING TRANSGENERATION CARD HAS ILLEGAL CODE NU
     1MBER OR NUMBER OF TYPE-40 CONSTANTS.  IT WILL BE SKIPPED.)
      WRITE (6,1013)I,NTRAN(I),KODE(I),NOTRAN(I),CONST(I)
 1013 FORMAT(1H ,I3,I8,2I9,F15.5)
      WRITE (6,1020)
 1020 FORMAT(1H0)
      KODE(I)=44
      GO TO 400
  255 WRITE (6,1013)I,NTRAN(I),KODE(I),NOTRAN(I),CONST(I)
  400 CONTINUE
      WRITE (6,1020)
      IF(N40.LE.50)GO TO 260
  906 WRITE (6,956)
  956 FORMAT(65H0MORE THAN 50 TYPE-40 TRANSGENERATIONS.  PROGRAM CANNOT 
     1CONTINUE.)
      GO TO 999
  260 IF(NUM18) 904,280,261
C
CPART 4
C
  261 ASSIGN 624 TO IMIN2
      NCASE1=NCASE
  265 NCASE2=MOD(NCASE1,32767)
      IF(NCASE2.EQ.0)NCASE2=32767
      DO 402 I=1,NCASE2
      GO TO INTAPE,(602,603)
  602 READ (MIN)(DATA(II),II=1,NVAR)
      GO TO 605
  603 READ (MIN,FMT)(DATA(II),II=1,NVAR)
      GO TO IWRIT2,(604,605,622)
  604 ASSIGN 622 TO IWRIT2
      ASSIGN 623 TO IMIN2
  622 WRITE (2)(DATA(II),II=1,NVAR)
  605 DO 402 I18=1,NUM18
      NLOC18=NSUM18(I18)
      N18=NOTRAN(NLOC18)
      IF(KODE(NLOC18)-18) 904,402,275
  275 SUM18(NLOC18)=DATA(N18)*DATA(N18)+SUM18(NLOC18)
  402 CONST(NLOC18)=DATA(N18)+CONST(NLOC18)
      NCASE1=NCASE1-NCASE2
      IF(NCASE1.GT.0)GO TO 265
      GO TO IMIN2,(623,624)
  623 MIN=2
      ASSIGN 607 TO INTAP
      ASSIGN 699 TO IREWND
      END FILE MIN
  624 REWIND MIN
      DO 403 I18=1,NUM18
      NLOC18=NSUM18(I18)
      CASE=NCASE
      IF(KODE(NLOC18)-18) 904,277,278
  277 CONST(NLOC18)=CONST(NLOC18)/CASE
      GO TO 403
  278 CONST(NLOC18)=(SUM18(NLOC18)-((CONST(NLOC18)*CONST(NLOC18))/CASE))
     1/(CASE-1.0)
      CONST(NLOC18)=SQRT(CONST(NLOC18))
  403 CONTINUE
C
CPART 5
C
      DO 404 K=1,NTRG
      DO 404 KK=1,NUM18
      NLOC18=NSUM18(KK)
      IF(NTRAN(K).NE.NOTRAN(NLOC18).OR.K.GE.NLOC18.OR.KODE(K).EQ.18)GO
     XTO 404
  907 WRITE (6,957)K,NTRAN(K),KODE(NLOC18),NSUM18(KK),KODE(NLOC18)
  957 FORMAT(25H0TRANSGENERATION CARD NO.I4,17H CHANGES VARIABLEI4,
     139H BEFORE THAT VARIABLE IS USED IN A TYPEI3/44H TRANSGENERATION O
     2N TRANSGENERATION CARD NO.I4,12H.  THIS TYPEI3,37H TRANSGENERATION
     3 WILL BECOME INVALID.)
  404 CONTINUE
C
CPART 6
C
  280 ASSIGN 405 TO ISAVE
      ASSIGN 608 TO I1SAVE
      ASSIGN 610 TO INSAVE
      ASSIGN 619 TO ISPECL
      NCAS=NCASE-1
       NVA=NVAR+1
      IF(NCAS) 903,281,282
  281 I=1
      ASSIGN 621 TO ISAVE
      GO TO 383
  282 NCASE1=NCAS
  285 NCASE2=MOD(NCASE1,32767)
      IF(NCASE2.EQ.0)NCASE2=32767
      DO 405 I=1,NCASE2
  383 DO 406 J=NVA,NOVAR
      SAMPL(1,J)=0.0
      SAMPL(3,J)=0.0
  406 DATA(J)=0.0
      GO TO INTAP,(606,607)
  606 READ (MIN,FMT)(DATA(II),II=1,NVAR)
      GO TO 384
  607 READ (MIN)(DATA(II), II=1,NVAR)
  384 GO TO ISPECL,(619,620)
  619 GO TO I1SAVE,(608,609)
  608 DO 407 J=1,NVAR
  407 SAMPL(1,J)=DATA(J)
      ASSIGN 609 TO I1SAVE
      GO TO 609
  620 DO 408 J=1,NVAR
  408 SAMPL(3,J)=DATA(J)
  609 GO TO KSKIP,(6093,6096)
 6093 CALL TRANS(I)
 6096 GO TO INSAVE,(610,611)
  610 DO 409 J=1,NOVAR
  409 SAMPL(2,J)=DATA(J)
      ASSIGN 611 TO INSAVE
C
CPART 7
C
  611 GO TO IFPRT,(612,613)
  612 WRITE (6,1014)I
 1014 FORMAT(9H CASE NO.I6)
      WRITE (6,PRINT)(DATA(J),J=1,NOVAR)
  613 GO TO IFPNCH,(614,615)
  614 PUNCH PUNCH,(DATA(J),J=1,NPUNCH)
  615 GO TO ITAPE,(616,617,618)
  616 WRITE (MOUT,TAPE)(DATA(J),J=1,NOVAR)
      GO TO 618
  617 WRITE (MOUT)(DATA(J),J=1,NOVAR)
  618 GO TO ISAVE,(405,621)
  405 CONTINUE
      NCASE1=NCASE1-NCASE2
      IF(NCASE1.GT.0)GO TO 285
      ASSIGN 620 TO ISPECL
      ASSIGN 621 TO ISAVE
      I=NCASE
      GO TO 383
C
CPART 8
C
  621 WRITE (6,1015)NCASE, NCASE
 1015 FORMAT(62H1SAMPLE LISTING OF VARIABLES BEFORE AND AFTER TRANSGENER
     1ATION.//13H VARIABLE NO.7X,17H   CASE  1 BEFORE4X,16H   CASE  1 AF
     2TER 12X,6H  CASEI6,7H BEFORE4X,4HCASEI6,6H AFTER/      23X,15HTRAN
     3SGENERATION5X,15HTRANSGENERATION14X,15HTRANSGENERATION5X,15HTRANSG
     4ENERATION/)
      DO 410 I=1,NOVAR
  410 WRITE (6,1016)I,SAMPL(1,I),SAMPL(2,I),SAMPL(3,I),DATA(I)
 1016 FORMAT(1H I8,F26.6,F20.6,F30.6,F21.6)
      GO TO 888
      END
      SUBROUTINE TPWD(NT1,NT2)
C        SUBROUTINE TPWD FOR BMD09S                  MARCH 21, 1966
C
      IF(NT1)40,10,12
 10   NT1=5
 12   IF(NT1-NT2)14,19,14
   14 IF(NT2.EQ.5)GO TO 19
   15 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 TPWD2(NT1,NT2)
C         SUBROUTINE TPWD2 FOR BMD09S                MARCH 21, 1966
C
      IF(NT1-NT2)14,28,14
   14 IF(NT2.EQ.0.OR.NT2.EQ.6)GO TO 22
 16   END FILE NT2
   15 REWIND NT2
 22   REWIND NT1
 24   NT2=NT1
 28   RETURN
      END
      SUBROUTINE TRANS(NOCASE)
C      SUBROUTINE TRANS FOR BMD09S-DATA RECODE       MARCH 21, 1966
      DIMENSION CONS(7,50),CONST(99),DATA(1500),KODE(99),NCON40(50),
     1NOTRAN(99),NTRAN(99)
      DOUBLE PRECISION DATA
      COMMON DATA,CONS,CONST,KODE,NCASE,NCON40
      COMMON  NOTRAN , NTRAN  , NTRG   , NVAR
      EXTERNAL SIGN
      ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
C
      II=0
      DO 110 I=1,NTRG
      N=NOTRAN(I)
      M=NTRAN(I)
      D2 = DATA(M)
      K=KODE(I)
      D1=DATA(N)
      C=CONST(I)
      NEWB=C
      IF(K.NE.18 .AND. K.NE.19) D3 = DATA(NEWB)
      GO TO(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,
     124, 25, 26,198,198,198,198,198,198,198,198,198,198,198,198,198,
     2 170,175,170,175,100),K
    1 IF(D1)198,107,108
  107 D2=0.0
      GOTO100
  108 D2=SQRT(D1)
      GOTO100
    2 IF(D1)198,111,112
  111 D2=1.0
      GOTO100
  112 D2=SQRT(D1)+SQRT(D1+1.0)
      GOTO100
    3 IF(D1.LE.0.0)GO TO 198
  114 D2=ALOG10(D1)
      GOTO100
    4 D2=EXP(D1)
      GOTO100
    5 IF(D1)198,107,117
  117 IF(D1.GE.1.0)GO TO 119
  118 D2=ASN(SQRT(D1))
      GOTO100
  119 D2=3.14159265/2.0
      GOTO100
    6 FN=NCASE
      A=D1/(FN+1.0)
      B=A+1.0/(FN+1.0)
      IF(A) 198,123,124
  123 IF(B)198,107,127
  127 D2=ASN(SQRT(A))
      GOTO100
  124 IF(B)198,128,129
  128 D2=ASN(SQRT(A))
      GOTO100
  129 D2=ASN(SQRT(A))+ASN(SQRT(B))
      GOTO100
    7 IF(D1.EQ.0.0)GO TO 198
  131 D2=1.0/D1
      GOTO100
    8 D2=D1+C
      GOTO100
    9 D2=D1*C
      GOTO100
   10 IF(D1)198,107,133
  133 D2=D1**C
      GOTO100
   11 D2=D1+D3
      GOTO100
   12 D2=D1-D3
      GOTO100
   13 D2=D1*D3
      GOTO100
   14 IF(D3.EQ.0.0)GO TO 197
      D2=D1/D3
      GOTO100
   15 IF(D1-C)107,111,111
   16 IF(D1-D3)107,111,111
   17 IF(D1.LE.0.0)GO TO 198
      D2=ALOG(D1)
      GO TO 100
   18 D2=D1-C
      GO TO 100
   19 D2=D1/C
      GO TO 100
   20 D2=SIN(D1)
      GO TO 100
   21 D2=COS(D1)
      GO TO 100
   22 IF(D1.GT.1.57079632.OR.D1.LT.-1.57079632)GO TO 198
      D2=ATAN(D1)
      GO TO 100
   23 IF(D1.LE.0.0)GO TO 198
      D2=D1**D3
      GO TO 100
   24 IF(C.LE.0.0)GO TO 196
      D2=C**D1
      GO TO 100
   25 D2=D1
      GO TO 100
   26 D2=C
      GO TO 100
  170 II=II+1
      L=NCON40(II)
      DO 166 J=1,L
      IF(D1.NE.CONS(J,II))GO TO 166
      E=SIGN(1.0,D1)
      D=SIGN(1.0,CONS(J,II))
      IF((E+D).NE.0.0)GO TO 167
  166 CONTINUE
      GO TO 100
  175 IF(D1.NE.0.0)GO TO 110
      E=SIGN(1.0,D1)
      D=1.0
      IF((E+D).NE.0.0)GO TO 110
  167 JUMP=K-39
      GO TO (26,26,43,43),JUMP
   43 D2=D3
      GO TO 100
  196 WRITE(6,4000)
      GO TO 199
  197 N=NEWB
  198 WRITE (6,201)N,NOCASE
  199 WRITE (6,202)K,M
      GO TO 110
  100 DATA(M)=D2
  110 CONTINUE
  201 FORMAT(22H0THE VALUE OF VARIABLEI4,8H IN CASEI5)
 4000 FORMAT(26H0THE VALUE OF THE CONSTANT)
  202 FORMAT(54H VIOLATED THE RESTRICTIONS FOR TRANSGENERATION OF TYPEI3
     X,1H./39H THE PROGRAM CONTINUED LEAVING VARIABLEI4,25H UNCHANGED FO
     XR THIS CASE.)
      RETURN
      END
C          SUBROUTINE TO CHECK FOR PROPER NUMBER OF VARIABLE FORMAT CRDS
      SUBROUTINE VFCHCK(NVF)
C
      IF(NVF.GT.0.AND.NVF.LE.10)GO TO 50
 10   WRITE (6,4000)
      NVF=1
 50   RETURN
C
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
      END