Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd01d.for
There is 1 other file named bmd01d.for in the archive. Click here to see a list.
C        SIMPLE DATA DESCRIPTION                      JUNE  6, 1966
C               HEALTH SCIENCES COMPUTING FACILITY
C                      UCLA MEDICAL SCHOOL
C        THIS IS A SIFTED VERSION OF BMD01D ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
       DIMENSION FMT(180),NX(1000),DATA(1000),SUMX(1000),
     1SUMXX(1000),XMIN(1001),XMAX(1001),BLANK(9)
      DIMENSION TRANS(8,100),KTRANS(4,100)
      DIMENSION DELET(1000)
      COMMON  DATA   , TRANS  , KTRANS , NTR    , NCASE  , METHD
      COMMON  BLANK  , NB     , NVAR   , NOVAR
      COMMON DELET
      DOUBLE PRECISION TODE,PROB,SPEC,A2,    A123,B123,C123
      DATA A123,B123,C123,A2/6HPROBLM,6HFINISH,6HSPCVAL,6HTRNGEN/
C
  404 FORMAT('1BMD01D - SIMPLE DATA DESCRIPTION - REVISED ',
     1'JULY 14, 1969'/
     241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
C
      MIN=5
	CALL USAGEB('BMD01D')
 1000 READ (5,100)TODE,PROB,NCASE,NVAR,NADVAR,METHD,NTR,NB, NTAPE,KVR
      IF(TODE.EQ.B123)GO TO 997
  401 IF(TODE.EQ.A123)GO TO 403
      PRINT 10001, TODE,PROB
  400 WRITE (6,402)
 997  IF(MIN-5)999,999,998
  998 REWIND MIN
  999 STOP
 403  CALL TPWD(NTAPE,MIN)
      IF(NB) 10000,411,2223
 2223 IF(NB-9)2222,10000,10000
 2222 READ (5,102)SPEC,(BLANK(I),I=1,NB)
      IF(C123.NE.SPEC)GO TO 10002
  411 IF(KVR.GT.0.AND.KVR.LE.10)GO TO 203
      KVR=1
      WRITE(6,4000)
  203 IVR=KVR*18
      IF(NVAR) 10003,10003,303
 303  NOVAR=NVAR+NADVAR
      IF(NOVAR-1000) 304,304,10004
  304 IF(NTR-100)204,204,10005
  204 IF(NTR) 10005,205,206
  205 ASSIGN 12 TO NNN
      ASSIGN 112 TO NJ
      GO TO 210
  206 ASSIGN 13 TO NNN
      ASSIGN 113 TO NJ
      DO 8 I=1,NTR
      READ (5,200)TODE,KTRANS(1,I),KTRANS(2,I),KTRANS(3,I),TRANS(8,I),KT
     1RANS(4,I),(TRANS(J,I),J=1,7)
      IF(TODE.NE.A2)GO TO 10007
    8 CONTINUE
  210 WRITE (6,404)
      READ (5,101)(FMT(I),I=1,IVR)
  207 WRITE (6,302)
      WRITE (6,500)PROB,METHD,NCASE,NB,NVAR,NTR,NADVAR,MIN, KVR
       IF (NB.GT.0) WRITE (6,501) (BLANK(I),I=1,NB)
      WRITE (6,108)
      WRITE (6,106)(FMT(I),I=1,IVR)
      GO TO NJ,(112,113)
  113 WRITE (6,1403)
      WRITE (6,1400)
      DO 334 I=1,NTR
      IF(KTRANS(2,I)-40) 331,332,331
  331 WRITE (6,1401)I,KTRANS(1,I),KTRANS(2,I),KTRANS(3,I),TRANS(8,I)
      GO TO 334
  332 J=KTRANS(4,I)
      IF(J*(J-8)) 333,10008,10008
  333 WRITE (6,1402)I,KTRANS(1,I),KTRANS(2,I),KTRANS(3,I),TRANS(8,I),(TR
     1ANS(JJ,I),JJ=1,J)
  334 CONTINUE
  112 DO 4 I=1,NOVAR
      SUMX(I)=0.0
      SUMXX(I)=0.0
      XMIN(I)=10.0**25
      XMAX(I)=-10.0**25
    4 NX(I)=0
      IF(METHD) 6,6,300
    6 ASSIGN 378 TO METD
      GO TO 379
  300 ASSIGN 377 TO METD
  379 DO 50 I=1,NCASE
      READ (MIN,FMT)(DATA(J),J=1,NVAR)
      DO 555 II=1,NVAR
 555  DELET(II)=0.0
      GO TO METD,(377,378)
  377 CALL MISVAL
  378 GO TO NNN,(12,13)
   13 CALL TRNGEN(I)
      IF(-NVAR)12,12,997
   12 DO 18 J=1,NOVAR
      IF (DELET(J) .EQ. 1.) GO TO 18
   66 NX(J)=NX(J)+1
      D=DATA(J)-SUMX(J)
      SUMX(J)=SUMX(J)+D/NX(J)
      SUMXX(J)=SUMXX(J)+D*(DATA(J)-SUMX(J))
      XMAX(J)=AMAX1(XMAX(J),DATA(J))
      XMIN(J)=AMIN1(XMIN(J),DATA(J))
   18 CONTINUE
   50 CONTINUE
      WRITE (6,105)
      DO 110 I=1,NOVAR
      DIV=NX(I)
      IF (DIV.LE.1.0) GO TO 109
      XBAR=SUMX(I)
      SUMXX(I)=SUMXX(I)/(DIV-1.0)
      SUMXX(I)=SQRT(SUMXX(I))
      SUMX(I)=SUMXX(I)/SQRT(DIV)
      GO TO 11
  109 WRITE (6,103)
      GO TO 110
   11 RANGE=XMAX(I  )-XMIN(I  )
      WRITE(6,104)I,XBAR,SUMXX(I),SUMX(I),NX(I),XMAX(I),XMIN(I),RANGE
  110 CONTINUE
      GO TO 1000
10000 PRINT 20000
      GO TO 400
10002 PRINT 2002, SPEC,(BLANK(I), I=1,NB)
      GO TO 400
10003 PRINT 20003
      GO TO 400
10004 PRINT 20004
      GO TO 400
10005 PRINT 20005
      GO TO 400
10007 PRINT 20007, TODE
      GO TO 400
10008 PRINT 20008
      GO TO 400
C
  100 FORMAT(2A6,I5,I3,I4,I1,I3,I1,39X,2I2)
  101 FORMAT(18A4)
  102 FORMAT(A6,8F6.0)
  103 FORMAT(26H NO DATA FOR THIS VARIABLE)
  104 FORMAT(2H  I4,F13.4,2F12.4,I7 ,4X,3F12.4)
  105 FORMAT(7H0VAR NO6X,4HMEAN8X,4HS.D.4X,12HS.E. OF MEAN2X,6HSAMPLE6X,
     130HMAXIMUM     MINIMUM      RANGE//)
  106 FORMAT(1H 18A4)
  107 FORMAT(1H 20F5.2)
  108 FORMAT(24H0VARIABLE FORMAT CARD(S))
  200 FORMAT(A6,I3,I2,I3,F6.0,5X,I1,7(F6.0))
  302 FORMAT(13H0PROBLEM CARD)
  402 FORMAT(45H0CONTROL CARDS INCORRECTLY ORDERED OR PUNCHED)
  500 FORMAT(15H PROBLEM NUMBER9X,A6,5X,13HMETHOD NUMBERI18/
     1  16H NUMBER OF CASESI14,5X,24HNUMBER OF SPECIAL VALUESI7/
     2  20H NUMBER OF VARIABLESI10,5X,26HNUMBER OF TRANSGENERATIONSI5/
     3  26H NUMBER OF VARIABLES ADDEDI4,5X,17HINPUT TAPE NUMBERI14/
     4  10X,31HNUMBER OF VARIABLE FORMAT CARDSI5)
  501 FORMAT(20H0SPECIAL VALUES CARD/1H 8F12.5)
 1400 FORMAT(46H0CARD    NEW     TRANS    ORIG.   ORIG. VAR(B)10X,17HTYP
     1E-40 CONSTANTS/45H  NO. VARIABLE   CODE    VAR(A)   OR CONSTANT)
 1401 FORMAT(2H  I2,I8,2I9,F15.5)
 1402 FORMAT(2H  I2,I8,2I9,F15.5,5X,5F14.5/50X,2F14.5)
 1403 FORMAT(1H06X,24H TRANS GENERATOR CARD(S))
 4000 FORMAT(1H023X71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPECIF
     1IED, ASSUMED TO BE 1.)
10001 FORMAT(' PROGRAM EXPECTED PROBLM OR FINISH CARD INSTEAD READ THE
     1 FOLLOWING'/1X,2A6)
20000 FORMAT(' NUMBER OF SPECIAL VALUES INCORRECTLY SPECIFIED')
 2002 FORMAT(' PROGRAM EXPECTED SPCVAL CARD INSTEAD READ THE FOLLOWING'/
     11X,A6,8F7.0)
20003 FORMAT(' NUMBER OF VARIABLES INCORRECTLY SPECIFIED')
20004 FORMAT(' NUMBER OF VARIABLES + NUMBER OF VARIABLES ADDED BY TRANSG
     1ENERATION CANNOT EXCEED 1000')
20005 FORMAT(' NUMBER OF TRANSGENERATION CARDS INCORRECTLY SPECIFIED')
20007 FORMAT(' PROGRAM EXPECTED TRNGEN CARD INSTEAD READ THE FOLLOWING'/
     11X,A6)
20008 FORMAT(' COLUMN 26 ON TRNGEN CARD MUST CONTAIN A DIGIT IN THE RANG
     1E 1-7 FOR TRANSGENERATION CODE 40')
C
      END
      SUBROUTINE MISVAL
C        SUBROUTINE MISVAL FOR BMD01D                 JUNE  6, 1966
      DIMENSION DATA(1000),TRANS(8,100),KTRANS(4,100),BLANK(9)
      DIMENSION DELET(1000)
      COMMON  DATA   , TRANS  , KTRANS , NTR    , NCASE  , METHD
      COMMON  BLANK  , NB     , NVAR   , NOVAR
      COMMON DELET
      EXTERNAL SIGN
      DO 50 J=1,NVAR
      GO TO (10,20,30),METHD
   10 IF(DATA(J)) 50,12,50
   12 IF(SIGN(1.0,DATA(J))) 55,50,50
   20 IF(DATA(J)) 54,22,54
   22 IF(SIGN(1.0,DATA(J))) 55,54,54
   54 DO 3 I=1,NB
      IF(DATA(J)-BLANK(I)) 3,55,3
    3 CONTINUE
      GO TO 50
   30 DO 4 I=1,NB
      IF(DATA(J)-BLANK(I)) 4,55,4
    4 CONTINUE
      GO TO 50
 55   DELET(J) = 1.0
   50 CONTINUE
      RETURN
      END
      SUBROUTINE TPWD(NT1,NT2)
C        SUBROUTINE TPWD FOR BMD01D                   JUNE  6, 1966
      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 TRNGEN(NINCS)
C        SUBROUTINE TRNGEN FOR BMD01D                 JUNE  6, 1966
C
      DIMENSION DATA(1000),TRANS(8,100),KTRANS(4,100),BLANK(9)
      DIMENSION DELET(1000)
      COMMON  DATA   , TRANS  , KTRANS , NTR    , NCASE  , METHD
      COMMON  BLANK  , NB     , NVAR   , NOVAR
      COMMON DELET
      EXTERNAL SIGN
      ASN(XX)=ATAN(XX/SQRT(1.0-XX**2))
C
C
      FN=NCASE
      IF(NVAR-1000)204,206,206
 204  NVA=NVAR+1
      DO 205 J=NVA,NOVAR
      DELET(J) = 0.
  205 DATA(J)=0.0
  206 DO 110 I=1,NTR
      M=KTRANS(1,I)
      N=KTRANS(3,I)
      NTRANS=KTRANS(2,I)
      D2=DATA(N)
      IF((NTRANS-11)*(NTRANS-12)*(NTRANS-13)*(NTRANS-14)*(NTRANS-16)*
     1(NTRANS-23)) 58,57,58
   57 NEWB=TRANS(8,I)
      IF(DELET(NEWB).EQ.1.0)GO TO 92
   58 IF(DELET(N).EQ.1.0)GO TO 92
   59 IF((KTRANS(2,I)-25)*KTRANS(2,I)) 50,99,60
   60 IF(KTRANS(2,I)-40)99,40,99
   99 WRITE (6,199)I
      NVAR=-NVAR
      RETURN
   50 GOTO(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,99,99,20,21,22,23,
     124),NTRANS
    1 IF(D2)198,107,108
  107 D1=0.0
      GOTO100
  108 D1=SQRT(D2)
      GOTO100
    2 IF(D2)198,111,112
  111 D1=1.0
      GOTO100
  112 D1=SQRT(D2)+SQRT(D2+1.0)
      GOTO100
    3 IF(-D2)114,198,198
  114 D1=ALOG10(D2)
      GOTO100
    4 D1=EXP(D2)
      GOTO100
    5 IF(-D2)117,107,198
  117 IF(D2-1.0)118,119,198
  118 D1=ASN(SQRT(D2))
      GOTO100
  119 D1=PI2
      GOTO100
    6 A=D2/(FN+1.0)
      B=A+1.0/(FN+1.0)
      IF(A) 198,127,124
  127 D1=ASN(SQRT(B))
      GOTO100
  124 IF(B)198,128,129
 128  IF(A-1.0)123,125,198
  123 D1=ASN(SQRT(A))*2.0
      GOTO100
  125 D1=3.14159265
      GO TO 100
  129 A=SQRT(A)
      B=SQRT(B)
      D1=ASN(A)+ASN(B)
      GOTO100
    7 IF(D2)131,198,131
  131 D1=1.0/D2
      GOTO100
    8 D1=D2+TRANS(8,I)
      GOTO100
    9 D1=D2*TRANS(8,I)
      GOTO100
   10 IF(-D2)133,107,198
  133 D1=D2**TRANS(8,I)
      GOTO100
   11 D1=D2+DATA(NEWB)
      GOTO100
   12 D1=D2-DATA(NEWB)
      GOTO100
   13 D1=D2*DATA(NEWB)
      GOTO100
   14 IF(DATA(NEWB))134,198,134
  134 D1=D2/DATA(NEWB)
      GOTO100
   15 IF(D2-TRANS(8,I))107,111,111
   16 IF(D2-DATA(NEWB))107,111,111
   17 IF(-D2)163,198,198
  163 D1=ALOG(D2)
      GO TO 100
   20 D1=SIN(D2)
      GO TO 100
   21 D1=COS(D2)
      GO TO 100
C
C
 22   D1=ATAN(D2)
      GO TO 100
   23 IF(-D2)188,107,198
  188 D1=D2**DATA(NEWB)
      GO TO 100
   24 IF(TRANS(8,I)) 198,107,189
  189 D1=TRANS(8,I)**D2
      GO TO 100
   40 IF((KTRANS(4,I)-8)*KTRANS(4,I))45,99,99
   45 K=KTRANS(4,I)
      DO 41 J=1,K
      IF(D2-TRANS(J,I))41,42,41
   42 C=SIGN(1.0,D2)
      D=SIGN(1.0,TRANS(J,I))
      IF(C+D)43,41,43
   41 CONTINUE
      GO TO 110
   43 D1=TRANS(8,I)
      GOTO100
  198 WRITE (6,201)N,NINCS,KTRANS(2,I),M
 92   DELET(M)=1.
  100 DATA(M)=D1
  110 CONTINUE
  199 FORMAT(21H0TRANSGENERATION CARDI3,26HMISPUNCHED OR OUT OF ORDER)
  201 FORMAT(22H0THE VALUE OF VARIABLEI4,8H IN CASEI5,54H VIOLATED THE R
     1ESTRICTIONS FOR TRANSGENERATION OF TYPEI3,1H./40H THE PROGRAM CONT
     2INUED TREATING VARIABLEI4,20H AS A MISSING VALUE.)
      RETURN
      END