Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
C LIFE TABLE AND SURVIVAL RATES MAY 20, 1966
C THIS IS A SIFTED VERSION OF BMD01S 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)
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25), C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31),Y(15)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
DATA BLANK/' '/
INTEGER SYM(15)
DOUBLE PRECISION A1,A2,A3,A4
DATA A2/'PROBLM'/,A3/'SUBPRO'/,A4/'FINISH'/
COMMON MTAPE , IFLAG
C SCRATCH TAPE 1 USED IN PTDATA TO CONVERT INTEGER TO ALPHA
REWIND 1
MTAPE=5
CALL USAGEB('BMD01S')
C
902 FORMAT(52H1BMD01S - LIFE TABLE AND SURVIVAL RATE - VERSION OF
118HMAY 20, 1966 ,/
241H HEALTH SCIENCES COMPUTING FACILITY, UCLA//)
C
IDATE( 1)=11
IDATE( 2)=21
IDATE( 3)=31
IDATE( 4)=41
IDATE( 5)=12
IDATE( 6)=22
IDATE( 7)=32
IDATE( 8)=42
IDATE( 9)=13
IDATE(10)=23
IDATE(11)=33
IDATE(12)=43
10 READ (5,910)A1,PRON,NSUB,NPLOT,LTAPE
IF(A1.EQ.A2) GO TO 12
5 IF(A1.EQ.A4)GO TO 40
7 WRITE (6,915) A1
GO TO 40
12 CALL TPWD(LTAPE,MTAPE)
IFLAG=0
IF(NSUB*(NSUB-11))3,90,90
90 WRITE(6,300)NSUB
300 FORMAT('0NO. OF SUBPROBLEM CARDS SPECIFIED WAS'
9 ,I3,'. ILLEGAL.' )
GO TO 40
3 DO 100 LP=1,NSUB
MN=LP
WRITE (6,902)
WRITE (6,903)PRON,MN
READ (5,900)A1,LK,NKI,KCO,FORM,JCO,NTOT,NV,IPD,UNIT, SYM(MN),IPRIN
1T,MAT
IF(A1.EQ.A3) GO TO 11
8 WRITE (6,916) A1
GO TO 40
11 ITABLE=1
IF(LK*(LK-32))110,91,91
110 IF(NKI-LK)111,92,92
91 WRITE(6,301) LK
GO TO 40
92 WRITE(6,302) NKI,LK
GO TO 40
301 FORMAT('0MAXIMUM NO. OF PERIODS AFTER DIAGNOSIS IS',I3,', WHICH IS
9 GREATER THAN 31.')
302 FORMAT( '0MAXIMUM NO. OF PERIODS FOR THE LIFE TABLE COMPUTATIONS W
9AS',I3/ ' WHICH IS NOT LESS THAN THE MAXIMUM NO. OF PERIODS AFTE
9R DIAGNOSIS,',I3)
111 LNG=0
IF(FORM.EQ.BLANK) GO TO 14
13 WRITE (6,918)FORM
IF(MAT.GT.0.AND.MAT.LE.10) GO TO 200
WRITE(6,4000)
MAT=1
200 DO 16 I=1,31
DO 16 J=1,31
DO 16 KK=1,5
16 DATA(I,J,KK)=0.0
CALL READ
IF(NV*(NV-10))41,93,93
93 WRITE(6,303)NV
GO TO 40
303 FORMAT('0NO. OF VARIABLES,',I3,', INCORRECT')
14 WRITE (6,917)
IF(JCO)81,81,80
80 MX=LK
GO TO 82
81 MX=1
82 DO 15 II=1,MX
KK=LK-(II-1)
DO 15 I=1,KK
15 READ (5,901)(DATA(II,I,J),J=1,5)
41 IF(IPRINT)75,75,70
70 WRITE (6,904)ITABLE
ITABLE=ITABLE+1
WRITE (6,905)
WRITE (6,906)
IF(JCO)72,72,71
71 MX=LK
GO TO 73
72 MX=1
73 DO 18 II=1,MX
KK=LK-(II-1)
WRITE (6,907)II
N1=0
N2=1
DO 18 I=1,KK
DO 17 J=2,5
17 N(J)=DATA(II,I,J)
WRITE (6,908)N1,N2,(N(J),J=2,5)
N1=N1+1
18 N2=N2+1
75 CONTINUE
IF(KCO) 30, 30, 31
30 NK=1
KSR(1)=NKI
GO TO 19
31 DO 32 I=1,NKI
KB=NKI-(I-1)
32 KSR(I)=KB
NK=NKI
19 DO 23 L=1,NK
K=KSR(L)
DO 20 I=1,LK
DO 20 J=1,12
20 C(I,J)=0.0
IF(JCO)76,76,77
76 MX=1
GO TO 78
77 MX=LK
78 DO 22 II=1,MX
KK=LK-(II-1)
DO 22 I=1,KK
DO 22 J=2,5
22 C(I,J)=C(I,J)+DATA(II,I,J)
CALL RATE
CALL REPORT
IF(JCO)23,23,42
42 CALL COHORT
23 CONTINUE
100 CONTINUE
IF(NPLOT)46,46,45
45 WRITE (6,911)
XMIN=0.0
XMAX=NKI
DO 60 I=1,NSUB
60 Y(I)= 1.0
X(1)=0.0
CALL PLOTR(X,XMIN,XMAX,Y,SYM,0.0,1.0,NSUB,-1)
XMIN=1.0
DO 55 I=1,NKI
X(1)=I
DO 50 J=1,NSUB
50 Y(J)=-PROB(J,I)
55 CALL PLOTR(X,XMIN,XMAX,Y,SYM,0.0,1.0,NSUB,-1)
CALL PLOTR(X,XMIN,XMAX,Y,SYM,0.0,1.0, -1 ,-1)
46 GO TO 10
40 IF(MTAPE-5)741,742,741
741 REWIND MTAPE
742 STOP
900 FORMAT(A6,3I2,A1,I2,I4,I2,I4,A1,A2,4X,I2,36X,I2)
901 FORMAT(5F4.0)
903 FORMAT(12H PROBLEM NO.6X,A2/16H SUB-PROBLEM NO.I4)
904 FORMAT(1H028X,5HTABLEI2,16H SURVIVAL DATA)
905 FORMAT(85H0PERIODS AFTER ALIVE AT BEGIN- DIED DURING LOST T
1O FOLLOW-UP WITHDRAWN ALIVE)
906 FORMAT(85H DIAGNOSIS NING OF INTERVAL INTERVAL DURIN
1G INTERVAL DURING INTERVAL)
907 FORMAT(6H0GROUPI3,20H PATIENTS DIAGNOSED)
908 FORMAT(I6,2H -I2,I16,I17,I16,I19)
910 FORMAT(A6,A2,2I2,56X,I2)
911 FORMAT(1H146X,19HSURVIVAL PROPORTION//)
915 FORMAT (' PROBLM OR FINISH CARD EXPECTED,BUT READ ',A6)
916 FORMAT (' SUBPRO CARD EXPECTED, BUT READ ',A6)
917 FORMAT(21H0SURVIVAL TABLE INPUT//)
918 FORMAT(7H0FORM A1,7H INPUT//)
4000 FORMAT(1H0,23X,71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPEC
XIFIED, ASSUMED TO BE 1.)
END
SUBROUTINE AFORM(II,DIV,COH)
C SUBROUTINE AFORM FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25), C1(31),C3(31),COH(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
IX=II-1
DATA A/1HA/
IF(FORM.NE.A)GO TO 45
8 IF(X(2))15,15,10
10 KK=2
GO TO 20
15 IF(X( 3))80,80,16
16 KK=3
20 IF(JCO)25,25,30
25 X(KK)=(X(KK)-X(1))/DIV
30 DO 35 I=1,LK
L=I
IF(X(KK)-COH(I))40,40,35
35 CONTINUE
40 KK=KK+1
L=L-IX
GO TO 75
45 IF(X(6))55,55,50
50 KK=6
GO TO 60
55 IF(X(7))80,80,56
56 KK=7
60 DO 65 I=1,LK
L=I
IF(X(KK)-COH(I))70,70,65
65 CONTINUE
70 KK=KK-3
75 DATA(II,L,KK)=DATA(II,L,KK)+1.0
80 RETURN
END
SUBROUTINE BFORM (II,DIV,COH)
C SUBROUTINE BFORM FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25), C1(31),C3(31),COH(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
IX=II-1
DATA B/1HB/
IF(FORM.NE.B)GO TO 15
10 MM=4
IF(JCO)11,11,20
11 X(4)=(X(4)-X(1))/DIV
GO TO 20
15 MM=8
20 DO 25 I=1,LK
JJ=I
IF(X(MM)-COH(I))30,30,25
25 CONTINUE
30 IF(MM-8) 32, 34, 32
32 JJ=JJ-IX
34 DO 40 I=1,10
IF(X(5)-DCODE(I))35,45,35
35 IF(X(5)-FCODE(I))40,50,40
40 CONTINUE
45 DATA(II,JJ,3)=DATA(II,JJ,3)+1.0
GO TO 55
50 DATA(II,JJ,4)=DATA(II,JJ,4)+1.0
55 RETURN
END
SUBROUTINE COHORT
C SUBROUTINE COHORT FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(120),C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
PRED=0.0
PINC=0.0
DO 10 I=1,LK
DO 10 J=1,12
10 C(I,J)=0.0
K1=DATA(1,1,1)
WRITE (6,920)
WRITE (6,921)ITABLE,K
ITABLE=ITABLE+1
WRITE (6,922)K
WRITE (6,923)K
WRITE (6,924)
WRITE (6,926)
DO 21 I=1,LK
KK=LK-(I-1)
DO 15 II=1,KK
DO 15 J=2,5
15 C(II,J)=C(II,J)+DATA(I,II,J)
CALL RATE
IF(PRED)18,19,18
18 PINC=((PRED-STD)/PRED)*100.0
GO TO 20
19 PRED=STD
20 K2=DATA(1,I,1)
NCASE=C(1,2)
21 WRITE (6,925)K1,K2,NCASE,SRATE,STD,PINC
920 FORMAT(1H0)
921 FORMAT(6H0TABLEI3,I5,76H-PERIOD SURVIVAL RATES AND THEIR STANDARD
1ERROR WITH INCREASE IN COHORT SIZE)
922 FORMAT(23H0 NUMBER OFI8, 47H-PERIOD STANDARD ERRO
1R PERCENT RED. IN)
923 FORMAT(47H COHORT CASES SURVIVAL OFI3,27H-PE
1RIOD STD. ERROR OF)
924 FORMAT(77H DIAGNOSED RATE SURVIVAL RAT
1E SURVIVAL RATE)
925 FORMAT(I6,1H-I6, I7,F16.2,F17.2,F20.1)
926 FORMAT(1H )
RETURN
END
C SUBROUTINE PLOTR (IBM 360) AUGUST 13, 1966
C
C 'PLOTR' IS A UTILITY SUBPROGRAM FOR THE BMD... PROGRAMS WHICH
C PLOTS EITHER SINGLE-LINE OR WHOLE-PAGE GRAPHS AND SETS UP
C APPROPRIATE SCALING. THE CALLING PARAMETERS ARE AS FOLLOWS -
C
C X - THE VALUE OF THE INDEPENDENT VARIABLE
C ZMIN - THE MINIMUM VALUE OF X FOR THIS PLOT
C ZMAX - THE MAXIMUM VALUE OF X FOR THIS PLOT
C Y - THE ARRAY CONTAINING THE VALUES OF UP TO 15 DEPENDENT VAR.'S
C SYM - THE ARRAY CONTAINING THE SYMBOLS TO BE PLOTTED
C WMIN - THE MINIMUM VALUE OF ALL Y'S FOR THIS PLOT
C WMAX - THE MAXIMUM VALUE OF ALL Y'S FOR THIS PLOT
C NC - THE NUMBER OF DEPENDENT VARIABLES
C NC=-1 CLOSES A SINGLE-LINE PLOT
C NC= 0 PRINTS AND CLOSES A WHOLE-PAGE PLOT
C NP - THE CONTROL VARIABLE
C NP=-1 PRINTS A SINGLE LINE
C NP=0 OR NP=1 SETS UP A WHOLE-PAGE PLOT
C
C THE PLOTTING ROUTINE MUST BE CALLED ONCE FOR EACH VALUE OF THE
C INDEPENDENT VARIABLE THAT IS TO BE PLOTTED NO MATTER WHETHER IN
C THE SINGLE-LINE OR WHOLE-PAGE MODE
C
SUBROUTINE PLOTR(X,ZMIN,ZMAX,Y,SYM,WMIN,WMAX,NC,NP)
C
DIMENSION Y(15),CLAB(12),GF(10),FMT(12),XY(51,101),SYM(15)
DATA TC,TP/1H.,1H+/
DATA GF/ 4H 1X,,4H 2X,,4H 3X,,4H 4X,,4H 5X,,4H 6X,,
14H 7X,,4H 8X,,4H 9X,,4H 10X/
DATA FMT/'(17X',' ','5(F1','2.3,','8X)/','7X, ',' ','4(F1','2.3,',
1'8X),','F12.','3) '/
INTEGER XY,BLANKS
DATA BLANKS/' '/
C
100 FORMAT(1H 6X5(F12.3,8X),F12.3/17X,5(F12.3,8X))
101 FORMAT(1H F12.3,1X,103A1,F12.3)
102 FORMAT (1H 13X,103A1)
1000 FORMAT(1H 14X,101A1)
1001 FORMAT(15X,20(5H+....),1H+)
C
DATA NCC/2/
C 'NCC' ON THE INITIAL ENTRY TO PLOTR IS NON-ZERO BECAUSE OF THE DATA
C STATEMENT ABOVE.
C
C 'NCC' IS 0 WHILE A PLOT IS BEING MADE. IT IS 1 OR 2 AT OTHER TIMES
C
IF(NCC) 50,48,50
C
C THE VARIABLE 'KL' CONTROLS THE FUNCTIONING OF THE OPENING AND
C CLOSING SECTIONS OF PLOTR. KL=0 INDICATES OPENING OF THE GRAPH,
C KL=1 INDICATES CLOSING.
C
50 KL=0
CALL SCALE(WMIN,WMAX,100.0,JY,YMIN,YMAX,YIJ)
YR=YMAX-YMIN
230 J=JY
IF(J*(J-10))204,201,201
C
C THE FOLLOWING SECTION OPENS OR CLOSES A PLOT IN FIXED FORMAT
C UNDER CONTROL OF KL
C
201 IF(KL)220,220,231
C
231 WRITE (6,1001)
IF(KL)250,250,220
C
220 CLAB(1)= YMIN
DO 222 I=2,11
222 CLAB(I)=CLAB(I-1)+YIJ
WRITE (6,100)(CLAB(I),I=1,11,2),(CLAB(J),J=2,10,2)
IF(KL)231,231,14
C
C THE FOLLOWING SECTION OPENS OR CLOSES A PLOT IN A VARIABLE
C FORMAT UNDER CONTROL OF KL AND JY FROM 'SCALE'
C
204 IF(J-5)205,221,207
207 J=J-5
205 JYT=5-J
221 CONTINUE
226 FMT(2)=GF(JY)
IF (KL) 225,225,227
C
225 FMT(7)=GF(JY)
TT=JY
TT=TT*YIJ/10.0
CLAB(1)= YMIN+TT
DO 223 I=2,10
223 CLAB(I)=CLAB(I-1) +YIJ
WRITE (6,FMT)(CLAB(I),I=2,10,2),(CLAB(I),I=1,9 ,2)
IF(KL)227,227,14
C
227 IF(JY-5)208,209,208
208 WRITE(6,1000)(TC,I=1,J ),(TP,(TC,I=1,4),K=1,19),TP,(TC,I=1,JYT)
IF (KL) 250,250,225
C
209 WRITE (6,1001)
IF (KL) 250,250,225
C
250 CONTINUE
NCC=0
IC=0
IF(NP)80,11,11
C
C THIS SECTION PREPARES FOR A FULL PAGE PLOT BY FILLING IN XY WITH
C BLANKS AND SETTING UP SCALING FOR THE INDEPENDENT VARIABLE 'X'
C
11 DO 1 I=1,51
DO 1 J=1,101
1 XY(I,J)=BLANKS
CALL SCALE (ZMIN,ZMAX,50.0,JX,XMIN,XMAX,XIJ)
XR=XMAX-XMIN
GO TO 48
C
C
C ENTRY TO PLOTS CAN BE USED ONLY AFTER THE CALLING PARAMETERS
C HAVE BEEN TRANSFERRED BY A CALL ON PLOTR. THE CALL ON PLOTS
C IS IDENTICAL WITH ENTRY TO PLOTR BUT IT ALLOWS THE PROGRAMMER TO
C CALL THE PLOTTING ROUTINE WITHOUT HAVING TO INCLUDE THE PARAMETERS
C
C ENTRY PLOTS
48 IF(NC)52,13,49
49 IF(NP)80,10,10
C THE FOLLOWING SECTION SETS UP A FULL PAGE BUT DOES NO PRINTING.
C THIS SECTION IS REACHED BY SPECIFYING NC POSITIVE AND NP POSITIVE.
C
10 DO 9 N=1,NC
SYMB=SYM(N)
XDIFFR=XMAX-X
IF(XDIFFR)105,106,106
105 XDIFFR=0.0
106 YDIFFR=YMAX-Y(N)
IF(YDIFFR)107,108,108
107 YDIFFR=0.0
108 L=51.0-(50.0*XDIFFR)/XR+.5
K=101.0-(100.0*YDIFFR)/YR+.5
CALL FORM2(SYMB,XY(L,K))
9 CONTINUE
GO TO 15
C
C THE FOLLOWING SECTION CONSTRUCTS AND PLOTS ONE LINE OF A MULTILINE
C GRAPH. LOCATION ALONG THE AXIS OF THE PAPER IS PRINTED AT EVERY
C STEP. THIS SECTION IS ACCESSIBLE BY SPECIFYING NC POSITIVE AND
C NP NEGATIVE.
C
80 DO 86 I=1,101
86 XY(1,I)=BLANKS
L=1
DO 95 N=1,NC
SYMB=SYM(N)
YDIFFR=YMAX-Y(N)
IF(YDIFFR)860,865,865
860 YDIFFR=0.0
865 K=101.0-(100.0*YDIFFR)/YR+.5
95 CALL FORM2(SYMB,XY(L,K))
IF(MOD(IC,5))97,96,97
96 W=TP
GO TO 98
97 W=TC
98 WRITE (6,101)X,W,(XY(1,N),N=1,101),W,X
IC=IC+1
GO TO 15
C
C THIS SECTION PLOTS OUT THE PREVIOUSLY PREPARED WHOLE PAGE GRAPH.
C IT PRINTS LOCATION ALONG THE PAPER'S AXIS EVERY FIFTH STEP. THIS
C SECTION IS ACCESSED BY SPECIFYING NC=0.
C
13 M=6-JX
LL=50+M
T=JX
IF(5-JX)131,131,135
131 T=0.0
135 RLAB=XMAX-(T*XIJ)/5.0
W=TC
K=52
DO 31 L=M,LL
K=K-1
I=MOD(L,5)
IF(I-1)2,3,2
3 W=TP
WRITE (6,101)RLAB,W,(XY(K,N),N=1,101),W,RLAB
RLAB=RLAB-XIJ
W=TC
GO TO 31
2 WRITE (6,102)W,(XY(K,N),N=1,101),W
31 CONTINUE
C
52 KL=1
GO TO 230
C
14 NCC=1
15 RETURN
END
C SUBROUTINE SCALE FOR PLOTR JUNE 21, 1966
C
C SUBROUTINE 'SCALE' CALCULATES THE SCALING FOR 'PLOTR'
C
SUBROUTINE SCALE(YMIN,YMAX,YINT,JY,TYMIN,TYMAX,YIJ)
DIMENSION C(10)
DATA C /1.0,1.5,2.0,3.0,4.0,5.0,7.5,10.0,15.0,20.0/
TEST=1.0/(2.0**17)
50 YR=YMAX-YMIN
TT=YR/YINT
J = ALOG10(TT)+TEST
E=10.0**J
TT=TT/E
I=0
IF(TT-1.0+TEST)205,201,201
205 TT=TT*10.0
E=E/10.0
201 I=I+1
IF(9-I)1,2,2
1 E=E*10.0
I=1
2 IF(TT-C(I))233,202,201
233 YIJ=C(I)*E
GO TO 203
202 Y=YMIN/C(I)
J=Y
T=J
IF(0.0001-ABS(T-Y))204,233,233
204 YIJ=C(I+1)*E
203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001
K=X
IF(K)235,240,240
235 Y=K
IF(X-Y)236,240,236
236 K=K-1
240 TYMIN=K
TYMIN=YIJ*TYMIN
TYMAX=TYMIN+YINT*YIJ
IF (YMAX-TYMAX-TEST)11,11,201
11 YIJJ=C(I)*E
XT=((YMAX+YMIN)/YIJJ-YINT)/2.0+.00001
KT=XT
IF (KT) 1235,1240,1240
1235 YT=KT
IF (XT.NE.YT) KT=KT-1
1240 TYMINT=KT
TYMINT=YIJJ*TYMINT
TYMAXT=TYMINT+YINT*YIJJ
IF (YMAX-TYMAXT.GT.TEST) GO TO 10
TYMIN=TYMINT
TYMAX=TYMAXT
YIJ=YIJJ
K=KT
10 TT=YINT/10.0
JY=TT+.000001
YIJ=YINT*(YIJ/10.0)
J=TYMIN/ YIJ
IF (K)242,241,241
242 J=J-1
241 J=J*JY+JY-K
JY=J
RETURN
END
SUBROUTINE FORM2(SYMB,XY)
C SUBROUTINE FORM2 FOR PLOTR (IBM 360) JUNE 21, 1966
INTEGER XY,SYMB,BLANK,TEST(18)
DATA BLANK/' '/,TEST/'2 ','3 ','4 ','5 ','6 ',
1'7 ','8 ','9 ','A ','B ','C ','D ','E ','F ','G ','H ','I ','/ '/
IF(XY.EQ.BLANK)GO TO 50
DO 30 I=1,17
IF(XY.NE.TEST(I))GO TO 30
C PUT IN NEXT SYMBOL OF ARRAY FOR MULTIPLE POINTS
XY=TEST(I+1)
GO TO 100
30 CONTINUE
IF(XY.EQ.TEST(18))GO TO 100
C IF OTHER THAN CHARACTERS IN ARRAY TEST PUT IN CHARACTER 2.
XY=TEST(1)
GO TO 100
C IF BLANK, PUT IN SYMBOL
50 XY=SYMB
100 RETURN
END
SUBROUTINE PTDATA
C SUBROUTINE PTDATA FOR BMD01S MAY 20, 1966
C THE VARIABLE NAMED 'N' WAS CHANGED TO 'M' IN THE DIMENSION AND
C COMMON STATEMENTS SINCE A DIMENSIONED VARIABLE CANNOT BE USED
C AS DO INDEX.
DIMENSION DATA(31,31,5),C(31,12),M(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(120),C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31),IZ(9),AZ(9)
COMMON C , K , SUM , STD , ITABLE , M
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
COMMON MTAPE , IFLAG
DATA AMZ,BLANK,A,B,C2/2H-0,1H ,1HA,1HB,1HC/
EQUIVALENCE(AZ,IZ)
IF(FORM.NE.A)GO TO 39
10 IF(IFLAG)9,8,9
8 WRITE (6,900)
WRITE (6,901)
WRITE (6,907)
IFLAG=1
9 DO 38 N=1,NV
IF(IORD(N)-12)11,12,14
11 IZ(1)=TD(N)
GO TO 38
12 IZ(2)=TD(N)
GO TO 38
13 IZ(3)=TD(N)
GO TO 38
14 IF(IORD(N)-21)13,21,24
21 IZ(4)=TD(N)
GO TO 38
22 IZ(5)=TD(N)
GO TO 38
23 IZ(6)=TD(N)
GO TO 38
24 IF(IORD(N)-23)22,23,34
31 IZ(7)=TD(N)
GO TO 38
32 IZ(8)=TD(N)
GO TO 38
33 IZ(9)=TD(N)
GO TO 38
34 IF(IORD(N)-32)31,32,33
38 CONTINUE
WRITE(1,910) (IZ(N),N=1,NV)
REWIND 1
READ (1,911) (IZ(N),N=1,NV)
REWIND 1
DO 35 N=1,NV
IF(AZ(N).EQ.AMZ) GO TO 135
GO TO 35
135 AZ(N)=BLANK
35 CONTINUE
WRITE (6,908)(IZ(N),N=1,NV)
RETURN
39 IF(FORM.NE.B)GO TO 58
40 IF(IFLAG)37,36,37
36 WRITE (6,902)
WRITE (6,903)
WRITE (6,907)
IFLAG=1
37 DO 57 N=1,NV
IF(IORD(N)-12)45,46,47
41 IZ(4)=TD(N)
GO TO 57
42 IZ(5)=TD(N)
GO TO 57
43 IZ(6)=TD(N)
GO TO 57
44 IZ(3)=TD(N)
GO TO 57
45 IZ(1)=TD(N)
GO TO 57
46 IZ(2)=TD(N)
GO TO 57
47 IF(IORD(N)-41)44,41,48
48 IF(IORD(N)-43)42,43,50
50 IZ(7)=TD(N)
57 CONTINUE
WRITE(1,910) (IZ(N),N=1,NV)
REWIND 1
READ (1,911) (IZ(N),N=1,NV)
REWIND 1
DO 55 N=1,NV
IF(AZ(N).EQ.AMZ) GO TO 155
GO TO 55
155 AZ(N)=BLANK
55 CONTINUE
WRITE (6,908)(IZ(N),N=1,NV)
RETURN
58 IF(FORM.NE.C2)GO TO 75
59 IF(IFLAG)66,67,66
67 WRITE (6,904)
WRITE (6,905)
WRITE (6,907)
IFLAG=1
66 DO 74 N=1,NV
IF(IORD(N)-12)60,61,62
60 IZ(1)=TD(N)
GO TO 74
61 IZ(2)=TD(N)
GO TO 74
62 IF(IORD(N)-60)63,64,65
63 IZ(3)=TD(N)
GO TO 74
64 IZ(4)=TD(N)
GO TO 74
65 IZ(5)=TD(N)
74 CONTINUE
WRITE(1,910) (IZ(N),N=1,NV)
REWIND 1
READ (1,911) (IZ(N),N=1,NV)
REWIND 1
DO 84 N=1,NV
IF(AZ(N).EQ.AMZ) GO TO 184
GO TO 84
184 AZ(N)=BLANK
84 CONTINUE
WRITE (6,908)(IZ(N),N=1,NV)
RETURN
75 IF(IFLAG)83,82,83
82 WRITE (6,906)
WRITE (6,905)
WRITE (6,907)
IFLAG=1
83 DO 95 N=1,NV
IF(IORD(N)-12)76,77,78
76 IZ(1)=TD(N)
GO TO 95
77 IZ(2)=TD(N)
GO TO 95
78 IF(IORD(N)-50)79,80,81
79 IZ(3)=TD(N)
GO TO 95
80 IZ(4)=TD(N)
GO TO 95
81 IZ(5)=TD(N)
95 CONTINUE
WRITE(1,910) (IZ(N),N=1,NV)
REWIND 1
READ (1,911) (IZ(N),N=1,NV)
REWIND 1
DO 96 N=1,NV
IF(AZ(N).EQ.AMZ) GO TO 196
GO TO 96
196 AZ(N)=BLANK
96 CONTINUE
WRITE (6,908)(IZ(N),N=1,NV)
RETURN
900 FORMAT(1H012X17HDATE OF DIAGNOSIS12X13HDATE OF DEATH13X18HDATE LAS
1T OBSERVED)
901 FORMAT(1H03(12X16HMONTH DAY YEAR))
902 FORMAT(1H012X17HDATE OF DIAGNOSIS9X18HDATE LAST OBSERVED18X6HSTATU
1S/40X15H(ALIVE OR DEAD)16X15H(ALIVE OR DEAD))
903 FORMAT(1H02(12X16HMONTH DAY YEAR),19X4HCODE)
904 FORMAT(1H012X17HDATE OF DIAGNOSIS9X19HLENGTH OF TIME FROM11X19HLEN
1GTH OF TIME FROM/39X18HDIAGNOSIS TO DEATH12X17HDIAGNOSIS TO LAST/5
22X33HOBSERVATION FOR THOSE STILL ALIVE)
905 FORMAT(1H012X16HMONTH DAY YEAR2(19X4HCODE))
906 FORMAT(1H012X17HDATE OF DIAGNOSIS16X6HSTATUS17X19HLENGTH OF TIME F
1ROM/40X15H(ALIVE OR DEAD)15X17HDIAGNOSIS TO LAST/56X27HOBSERVATION
2 (ALIVE OR DEAD))
907 FORMAT(1H )
908 FORMAT(3(15XA2,4XA2,3XA2))
910 FORMAT(9I2)
911 FORMAT(9A2)
END
SUBROUTINE RATE
C SUBROUTINE RATE FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(120),C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
DO 23 I=1,K
23 C(I,6)=C(I,2)-0.5*(C(I,4)+C(I,5))
DO 24 I=1,K
C(I,7)=C(I,3)/C(I,6)
24 C(I,8)=1.0-C(I,7)
DO 25 I=1,K
C(I,9)=1.0
DO 25 J=1,I
25 C(I,9)=C(I,9)*C(J,8)
SUM=0.0
DO 26 I=1,K
C(I,10)=C(I,6)-C(I,3)
C(I,11)=C(I,7)/C(I,10)
SUM=SUM+C(I,11)
26 C(I,12)=C(I,9)*SQRT(SUM)
SRATE=C(K,9)
STD=C(K,12)
RETURN
END
SUBROUTINE READ
C SUBROUTINE READ FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(180),C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
COMMON MTAPE
DOUBLE PRECISION A1,A2,A3,A4
DATA A2/'COHORT'/,A3/'ORDER '/,A4/'STATUS'/
DATA B/'B'/,D/'D'/,W/'W'/,XM/'M'/,Y/'Y'/,A/'A'/,C2/'C'/
21 IF(JCO)30,30,25
25 READ (5,911)A1,(C1(I),COH(I),C3(I), I=1,LK)
IF(A1.EQ.A2) GO TO 18
15 WRITE (6,900) A1
STOP
18 DO 26 I=1,LK
C4 =C3(I)*10000.0
C5 =C1(I)*100.0
C6=COH(I)*100.0
C7=C1(I)*10000.0
DATA(1,I,1)=C6+C7+C3(I)
26 COH(I)=C4+C5+COH(I)
30 IF(FORM.EQ.B)GO TO 32
31 IF(FORM.NE.D)GO TO 35
32 READ (5,912)A1,(DCODE(I),I=1,10),(FCODE(I),I=1,10)
IF(A1.EQ.A4) GO TO 35
33 WRITE (6,901) A1
STOP
35 READ (5,913)A1,(IORD(I),I=1,NV)
IF(A1.EQ.A3) GO TO 37
36 WRITE (6,902) A1
STOP
37 MAT=MAT*18
READ (5,914)(FMT(I),I=1,MAT)
WRITE (6,916) (FMT(I),I=1,MAT)
916 FORMAT (' VARIABLE FORMAT IS'/(1X,18A4))
IF(IPD)55,55,41
41 DO 42 I=1,LK
42 PD(I)=IPD*I
43 IF(UNIT.EQ.D)GO TO 50
44 IF(UNIT.EQ.W)GO TO 51
45 IF(UNIT.EQ.XM)GO TO 52
46 IF(UNIT.EQ.Y)GO TO 53
GO TO 55
50 DIV=1.0
GO TO 55
51 DIV=7.0
GO TO 55
52 DIV=30.4
GO TO 55
53 DIV=365.0
55 DO 125 MM=1,NTOT
READ (MTAPE,FMT)(TD(I),I=1,NV)
CALL PTDATA
CALL RESET (MM)
IF(JCO)75,75,60
60 DO 65 I=1,LK
III=I
IF(X(1)-COH(I))70,70,65
65 CONTINUE
70 II=III
GO TO 80
75 II=1
80 DATA(II,1,2)=DATA(II,1,2)+1.0
IF(FORM.EQ.A)GO TO 100
85 IF(FORM.EQ.B)GO TO 115
90 IF(FORM.EQ.C2)GO TO 110
95 CALL BFORM(II,DIV,PD)
GO TO 125
100 IF(JCO)110,110,105
105 CALL AFORM(II,DIV,COH)
GO TO 125
110 CALL AFORM(II,DIV,PD)
GO TO 125
115 IF(JCO)95,95,120
120 CALL BFORM (II,DIV,COH)
125 CONTINUE
WRITE (6,915)
IF(JCO)127,127,126
126 LM=LK
GO TO 121
127 LM=1
121 DO 135 I=1,LM
LL=I-1
KK=LK-LL
DO 135 JJ=2,KK
J=JJ-1
135 DATA(I,JJ,2)=DATA(I,J,2)-DATA(I,J,3)-DATA(I,J,4)
900 FORMAT (' COHORT CARD EXPECTED,BUT READ ',A6)
901 FORMAT (' STATUS CARD EXPECTED,BUT READ ',A6)
902 FORMAT (' ORDER CARD EXOECTED,BUT READ ',A6)
911 FORMAT(A6,33F2.0/6X,(33F2.0))
912 FORMAT(A6,20F3.0)
913 FORMAT(A6,24(1X,I2))
914 FORMAT(18A4)
915 FORMAT(1H1)
RETURN
END
SUBROUTINE REPORT
C SUBROUTINE REPORT FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(120),C1(31),C3(31),COH(31),PD(31),
2X(8),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
WRITE (6,910)ITABLE,K
WRITE (6,911)
ITABLE=ITABLE+1
WRITE (6,912)
WRITE (6,913)
WRITE (6,914)
WRITE (6,919)
IF(K-NKI)22,20,22
20 DO 21 I=1,K
21 PROB(MN,I)=C(I,9)*(-1.0)
22 N1=0
N2=1
DO 30 I=1,K
DO 29 J=2,5
29 N(J)=C(I,J)
WRITE (6,915)N1,N2,N(2),N(3),N(4),N(5),(C(I,M),M=6,9), C(I,11),C(I
1,12)
N1=N1+1
30 N2=N2+1
WRITE (6,919)
WRITE (6,916)K,SRATE
WRITE (6,917)STD
SUM=(SRATE*(1.0-SRATE))/STD**2
KK=SUM
WRITE (6,918)KK
910 FORMAT(15H1 TABLEI3,20H COMPUTATION OF THEI3,44H-PERIOD S
1URVIVAL RATE AND ITS STANDARD ERROR)
911 FORMAT(120H0PERIODS ALIVE AT DIED LOST TO WITHDRAWN
1 EFFECTIVE NO. PROPOR- PROPOR- CUMULATIVE COL.7/ STAND.)
912 FORMAT(120H AFTER BEG. OF DURING FOLLOW- ALIVE DUR-
1 EXPOSED TO TION TION SUR- PROPORTION COL.6- ERROR )
913 FORMAT(111H DIAGNOSIS INTERVAL INTERVAL UP ING INTERVAL
1 RISK OF DYING DYING VIVING SURVIVING COL.3 )
914 FORMAT(119H (1) (2) (3) (4) (5)
1 (6) (7) (8) (9) (10) (11))
915 FORMAT(I3,2H -I2,I12,I11,I10,I11,F15.1,F12.2,F9.2,F11.2,F12.4,F10.
14)
916 FORMAT(1H0I2,24H-PERIOD SURVIVAL RATE...F7.2)
917 FORMAT(27H0STANDARD ERROR............F7.2)
918 FORMAT(27H0EFFECTIVE SAMPLE SIZE.....I4)
919 FORMAT(1H )
RETURN
END
SUBROUTINE RESET (NVAR)
C SUBROUTINE RESET FOR BMD01S MAY 20, 1966
DIMENSION DATA(31,31,5),C(31,12),N(5),KSR(31),IDATE(12),DCODE(10),
1FCODE(10),IORD(25),TD(25),FMT(120),C1(31),C3(31),COH(31),PD(31),
2X(8),VAR(20),PROB(15,31)
COMMON C , K , SUM , STD , ITABLE , N
COMMON SRATE , DATA , KSR , LK , NTOT , NV
COMMON NJ , FORM , JCO , IPD , UNIT , NTAPE
COMMON MAT , C1 , C3 , DCODE , FCODE , IORD
COMMON IDATE , TD , X , PROB , MN , NKI
DO 10 I=1,8
10 X(I)=0.0
IF(JCO)15,15,20
15 DIV1=30.4
DIV2=365.0
GO TO 25
20 DIV1=100.0
DIV2=10000.0
25 II=0
DO 80 I=1,NV
DO 45 J=1,4
IF(IORD(I)-IDATE(J))45,40,45
40 IJ=IDATE(J)/10
X(IJ)=X(IJ)+TD(I)*DIV1
GO TO 80
45 CONTINUE
DO 65 J=5,8
J10=J*10
IF(IORD(I)-J10)55,50,55
50 X(J)=TD(I)
GO TO 80
55 IF(IORD(I)-IDATE(J))65,60,65
60 IJ=IDATE(J)/10
X(IJ)=X(IJ)+TD(I)
GO TO 80
65 CONTINUE
DO 75 J=9,12
IF(IORD(I)-IDATE(J))75,70,75
70 IJ=IDATE(J)/10
X(IJ)=X(IJ)+TD(I)*DIV2
GO TO 80
75 CONTINUE
80 CONTINUE
RETURN
END
SUBROUTINE TPWD(NT1,NT2)
C SUBROUTINE TPWD FOR BMD01S MAY 20, 1966
IF(NT1)40,10,12
10 NT1=5
12 IF(NT1-NT2)14,19,14
14 IF(NT2.EQ.5)GO TO 18
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