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