$JOB MORTALITY RATE JOB $EXECUTE IBJOB $IBJOB GO,FIOCS $IBFTC MORTAL NODECK,REF MORT0020 DIMENSION ID(199),EXP(199),PTRSON(199),OARR(199),OASR(199), MORT0030 1OBSURV(199),S2(199),S3(199),DELTA1(199),SARR(199),SASR(199), MORT0040 2SMSURV(199),PROBLI(199),DELT23(199),DELT4(199), MORT0050 3RR(199),SMOTHR(199) MORT0060 CALL SETHOL(IAST,6H* ) MORT0070 CALL SETHOL(ILANK,6H ) MORT0080 C THIS PROGRAM COMPUTES MORTALITY RATES, SURVIVAL RATE FOR EACH C PERIOD, CUMULATIVE SURVIVOR CURVE, AND LIFE EXPECTANCY - GIVING C OBSERVED, SMOOTHED AND DIFFERENCE VALUES. THE SMOOTHING PROCESS C IS TAKEN FROM R. A. FISHER (PP. 152-156, STATISTICAL METHODS FOR C RESEARCH WORKERS) AND IS USED TO PROJECT THE CURVES BEYOND AVAILABLE C DATA, THUS ACCOMMODATING STUB OR INCOMPLETE SURVIVOR CURVES. THE C PROGRAM ALSO PRINTS OUT PERIOD IDENTIFICATION, EXPOSURE AND MORTAL- C ITY FROM THE INPUT DATA CARDS, AS WELL AS INTERNALLY-GENERATED C LINE NUMBERS. NO MORE THAN 199 LINES CAN ACCEPTED PER CASE. C MORE THAN ONE SET OF INPUT DATA MAY BE SUBMITTED, EACH TO BE C FOLLOWED BY ONE OR MORE CONTROL CARDS. ONE SET OF COMPUTATIONS C IS TABULATED FOR EACH CONTROL CARD. C THE INPUT DATA IS TO CONSIST OF ONE CARD FOR EACH PERIOD OF C TIME, SUBMITTED IN CHRONOLOGICAL SEQUENCE AND IN THE FOLLOWING CARD C FORMAT. NO MORE THAN 199 LINES CAN BE ACCEPTED PER CASE. C COL. 2-11 IDENT OR CASE NO. (SAME FOR ALL CARDS OF SET) C 12-21 IDENTIFICATION OF EACH PERIOD (NOT REQUIRED) C 22-31 EXPOSURE C 32-41 MORTALITY C 1 BLANK C CONTROL CARDS ARE USED TO INDICATE WHICH OF THE SUBMITTED CARDS C ARE TO PROVIDE THE BASIS FOR THE SMOOTHING OR CURVE-FITTING. C ASTERISKS ARE PRINTED TO SHOW WHAT RANGE OF LINE NUMBERS ARE USED. C CONTROL CARD FORMAT IS AS FOLLOWS. C COL. 1 ONE. C 2-11 SAME AS PRECEDING DATA CARDS. C 19-21 LINE NUMBER OF FIRST PERIOD TO BE INCLUDED C IN THE SMOOTHING PROCESS. C 29-31 LINE NO., LAST PERIOD IN SMOOTHING. C 41 BLANK IF NO MORE CONTROL CARDS. C ONE IF LAST, OR ONLY, CONTROL CARD. C 42-51 ALL ZEROS. C LIFE EXPECTANCY IS COMPUTED (WOODS AND DE/GARMO, INTRO TO ENGG C ECONOMY) AND THE USER MAY ADD THIS TO THE AGE FOR WHICH IT IS C COMPUTED IN ORDER TO OBTAIN THE PROBABLE LIFE. ALSO NOTE THAT IF C THE COMPUTED SURVIVOR CURVE FAILS TO APPROACH ZERO, THE LIFE C EXPECTANCIES CANNOT BE VALID. AT THE DISCRETION OF THE USER, HE C CAN RESUBMIT USING A DIFFERENT INTERVAL FOR SMOOTHING IF HE SENSES C THE PRESENCE OF OUTLIERS OR ATYPICAL DATA. C PROBABLE LIVES AND ORDINATES OF SURVIVOR CURVES REFER TO AGE C AT THE B E G I N N I N G OF EACH PERIOD. C NORMAN D. PETERSON AND DALE L. HOLMES, U.S.D.I., PORTLAND, ORE. 1 J=1 MORT0090 ICD=0 MORT0100 7701 IDWN=0 MORT0110 III1=0 MORT0120 ISW3=0 MORT0130 ISTEP=0 MORT0140 ISTPDN=0 MORT0150 ISW33=0 MORT0160 DIF1=0.0 MORT0170 DIF2=0.0 MORT0180 ISTOP=0 MORT0190 2 READ(5,900)IFLAG MORT0200 900 FORMAT (I1) MORT0210 IF (IFLAG.EQ.1) GO TO 10 MORT0220 IF (IFLAG.EQ.9) GO TO 99 MORT0230 READ( 5,910)IFLAG,ICASE,IDENT,EXPSUR,RTIRMT,RETRAT MORT0240 910 FORMAT (I1,I10,A10,3F10.0) MORT0250 GO TO 55 MORT0260 10 READ ( 5,920)IFLAG,ICASE,IA,IB,ICDNO,BLANK MORT0270 920 FORMAT (I1,3I10,9X,I1,F10.0) MORT0280 IBSV=IB MORT0290 21 IF(IFLAG.EQ.1) GO TO 23 MORT0300 55 ICD=ICD+1 MORT0310 ID(J)= IDENT MORT0320 EXP(J)=EXPSUR MORT0330 PTRSON(J)=RTIRMT MORT0340 J=J+1 MORT0350 GO TO 2 MORT0360 C**** ENTER DUE TO NEW CONTROL CARD ****** MORT0370 23 IF (J.EQ.199) GO TO 7117 MORT0380 DO 24 K=J,199 MORT0390 ID(K)=BLANK MORT0400 EXP(K)=BLANK MORT0410 PTRSON(K)=BLANK MORT0420 24 OARR(K)=BLANK MORT0430 DO 25 K=1,199 MORT0440 OASR(K)=BLANK MORT0450 OBSURV(K)=BLANK MORT0460 S2(K)=BLANK MORT0470 S3(K)=BLANK MORT0480 DELTA1(K)=BLANK MORT0490 SARR(K)=BLANK MORT0500 SASR(K)=BLANK MORT0510 SMSURV(K)=BLANK MORT0520 DELT23(K)=BLANK MORT0530 DELT4(K)=BLANK MORT0540 RR(K)=BLANK MORT0550 SMOTHR(K)=BLANK MORT0560 25 PROBLI(K)=BLANK MORT0570 7117 S1TOT=BLANK MORT0580 S2TOT=BLANK MORT0590 S3TOT=BLANK MORT0600 SIGS4=BLANK MORT0610 C**** BEGINNING MAIN PORTION - CALCULATION OF ARRAYS ******* MORT0620 J=1 MORT0630 DO 26 K=1,ICD MORT0640 OARR(J)=PTRSON(J)/EXP(J) MORT0650 26 J=J+1 MORT0660 J=1 MORT0670 DO 27 K=1,ICD MORT0680 OASR(J)=1.0-OARR(J) MORT0690 27 J=J+1 MORT0700 J=1 MORT0710 M=ICD-1 MORT0720 OBSURV(1)=1.0 MORT0730 DO 28 K=1,M MORT0740 OBSURV(J+1)=OBSURV(J)*OASR(J) MORT0750 28 J=J+1 MORT0760 CONTINUE MORT0770 IF (IA.EQ.ILANK) GO TO 29 MORT0780 IF (IB.EQ.ILANK) GO TO 29 MORT0790 GO TO 30 MORT0800 29 STOP MORT0810 30 J=IA MORT0820 DO 31 K=J,IB MORT0830 IF(K.EQ.IA) GO TO 161 MORT0840 S2(J)=OARR(J)+S2(J-1) MORT0850 S3(J)=S2(J)+S3(J-1) MORT0860 DELT4(J)=DELT4(J-1)+S3(J) MORT0870 GO TO 31 MORT0880 161 S2(J)=OARR(J) MORT0890 S3(J)=S2(J) MORT0900 DELT4(J)=S3(J) MORT0910 31 J=J+1 MORT0920 J=IA MORT0930 DO 32 K=J,IB MORT0940 S1TOT=S1TOT+OARR(J) MORT0950 S2TOT=S2TOT+S2(J) MORT0960 S3TOT=S3TOT+S3(J) MORT0970 SIGS4=SIGS4+DELT4(J) MORT0980 32 J=J+1 MORT0990 C**** ENTERING STEP 2 - SMOOTHING ***** MORT1000 550 NDPETE=IB+1-IA MORT1010 Q=NDPETE MORT1020 APRIME=S1TOT/Q MORT1030 B=(2.0*S2TOT)/(Q*(Q+1.0)) MORT1040 HOLMES=(6.0*S3TOT)/(Q*(Q+1.0)*(Q+2.0)) MORT1050 DALE=(24.*SIGS4)/(Q*(Q+1.)*(Q+2.)*(Q+3.)) MORT1060 BPRIME=APRIME-B MORT1070 CPRIME=APRIME-(3.0*B)+(2.0*HOLMES) MORT1080 IF (ISW33.EQ.1) GO TO 301 MORT1090 Y=APRIME+(3.0*BPRIME)+(5.0*CPRIME) MORT1100 D1=-6.0*((BPRIME+(5.0*CPRIME)))/(Q-1.0) MORT1110 D2=(60.0*CPRIME)/((Q-1.0)*(Q-2.0)) MORT1120 302 J=IB MORT1130 SARR(J)=Y MORT1140 DELTA1(J)=D1 MORT1150 35 J=J-1 MORT1160 DELTA1(J)=D2+DELTA1(J+1) MORT1170 SARR(J)=SARR(J+1)+DELTA1(J+1) MORT1180 IF (J.EQ.1) GO TO 40 MORT1190 GO TO 35 MORT1200 40 J=IB+1 MORT1210 DO 41 K=J,199 MORT1220 DELTA1(K)=DELTA1(K-1)-D2 MORT1230 SARR(K)=SARR(K-1)-DELTA1(K) MORT1240 41 CONTINUE MORT1250 313 J=1 MORT1260 DO 44 K=J,199 MORT1270 SASR(K)=1.0-SARR(K) MORT1280 IF(SARR(K).GT.1.0) GO TO 100 MORT1290 IF(SARR(K).LT.0.0) GO TO 43 MORT1300 GO TO 42 MORT1310 100 SASR(K)=0.0 MORT1320 GO TO 42 MORT1330 43 SASR(K)=1.0 MORT1340 42 IF (K.EQ.1) SMSURV (K)=1. MORT1350 IF (K.EQ.1) GO TO 44 MORT1360 SMSURV(K)=SMSURV(K-1)*SASR(K-1) MORT1370 44 CONTINUE MORT1380 8987 J=199 MORT1390 PREVSS=BLANK MORT1391 SIGSS=SMSURV(J)/2.0 MORT1400 48 IF(SMSURV(J).EQ.0.0) GO TO 45 MORT1410 GO TO 46 MORT1420 45 PROBLI(J)=BLANK MORT1430 GO TO 47 MORT1440 46 PROBLI(J)=SIGSS/SMSURV(J) MORT1450 47 J=J-1 MORT1460 IF (J.EQ.0) GO TO 70 PREVSS=SMSURV(J+1) MORT1471 SIGSS=((SMSURV(J)+PREVSS )/2.0)+SIGSS MORT1470 GO TO 48 MORT1490 C MORT1500 C****MAIN PRINT SECTION**** MORT1510 C MORT1520 70 J=1 MORT1530 IPAGE=0 MORT1540 IAST2=ILANK MORT1550 IAST3=ILANK MORT1560 ILINE=1 MORT1570 72 IPAGE=IPAGE+1 MORT1580 IF (ISW33.EQ.1) GO TO 8888 MORT1590 WRITE (6,1000)ICASE,IPAGE MORT1600 1000 FORMAT(1H1,35X,17HANALYSIS OF CASE ,I10,30H USING SECOND-DEGREE SMMORT1610 1OOTHING,31X,5HPAGE ,I2// MORT1620 25H LINE,3X,6HPERIOD,5X,8HEXPOSURE,4X,9HMORTALITY,8X,14HMORTALITY RMORT1630 3ATE,12X,13HSURVIVAL RATE,10X,14HSURVIVOR CURVE,14X,4HLIFE/4H NO., MORT1640 438X,89HOBSERVED SMOOTHED DIFFERENCE OBSERVED SMOOTHED OBSERVED SMMORT1650 5OOTHED DIFFERENCE EXPECTANCY/) MORT1660 GO TO 8889 MORT1670 8888 WRITE (6, 8999)ICASE,IPAGE MORT1680 8999 FORMAT(1H1,35X,17HANALYSIS OF CASE ,I10,29H USING THIRD-DEGREE SMOMORT1690 1OTHING,32X,5HPAGE ,I2// MORT1700 25H LINE,3X,6HPERIOD,5X,8HEXPOSURE,4X,9HMORTALITY,8X,14HMORTALITY RMORT1710 3ATE,12X,13HSURVIVAL RATE,10X,14HSURVIVOR CURVE,14X,4HLIFE/4H NO., MORT1720 438X,89HOBSERVED SMOOTHED DIFFERENCE OBSERVED SMOOTHED OBSERVED SMMORT1730 5OOTHED DIFFERENCE EXPECTANCY/) MORT1740 8889 IF(J.LT.IA) GO TO 217 MORT1750 216 DIF1=SARR(J)-OARR(J) MORT1760 DIF2=SMSURV(J)-OBSURV(J) MORT1770 217 L=IA MORT1780 M=IB MORT1790 IF(ILINE.LT.L) GO TO 200 MORT1800 IF(ILINE.GT.M) GO TO 199 MORT1810 IAST3=IAST MORT1820 199 L=ICD MORT1830 IF(ILINE.GT.L) GO TO 198 MORT1840 GO TO 197 MORT1850 198 IF(SARR(J).LT.SARR(J-1)) GO TO 111 MORT1860 GO TO 112 MORT1870 111 IAST2=ILANK MORT1880 112 WRITE (6,1012)ILINE,SARR(J), SASR(J),SMSURV(J),PROBLI(J) MORT1890 1012 FORMAT(1H ,I3,47H - - - - - - - - - - - - , MORT1900 1F8.5,1X,22H - - - - - - ,F7.5,11H - - - ,F9.6,13H MORT1910 2 - - - ,F10.4) MORT1920 GO TO 114 MORT1930 197 JIA=IA+1 MORT1940 IF (J.LT.JIA) GO TO 200 MORT1950 IF(SARR(J)-SARR(J-1)) 201,200,200 MORT1960 201 IAST2=ILANK MORT1970 200 WRITE (6,1010)ILINE,IAST3,ID(J),EXP(J),PTRSON(J),OARR(J),SARR(J), MORT1980 1IAST2,DIF1,OASR(J),SASR(J),OBSURV(J),SMSURV(J),DIF2,PROBLI(J) MORT1990 1010 FORMAT(1H ,I3,A1,A10,2X,F10.0,2X,F10.0,3X,F7.5,2X,F8.5,A1,1X, MORT2000 1F9.6,2X,F7.5,2X,F8.5,2X,F8.6,1X,F9.6,2X,F9.6,2X,F10.4) MORT2010 114 IF (J.EQ.199) GO TO 500 MORT2020 J=J+1 MORT2030 IAST2=ILANK MORT2040 IAST3=ILANK MORT2050 ILINE=ILINE+1 MORT2060 IF(ILINE.EQ.42) GO TO 72 MORT2070 IF(ILINE.EQ.84) GO TO 72 MORT2080 IF(ILINE.EQ.126) GO TO 72 MORT2090 IF(ILINE.EQ.168) GO TO 72 MORT2100 GO TO 216 MORT2110 99 WRITE (6,1950) MORT2120 1950 FORMAT(11H1END OF JOB) MORT2130 STOP MORT2140 500 III1=III1+1 MORT2150 IF (III1.EQ.1) ISW33=1 MORT2160 IF (III1.EQ.2.AND.ICDNO.EQ.0) GO TO 7702 MORT2170 IF (III1.EQ.2.AND.ICDNO.EQ.1) GO TO 1 MORT2180 J=ICD+1 MORT2190 GO TO 23 MORT2200 7702 J=ICD+1 MORT2210 GO TO 7701 MORT2220 C MORT2230 C**** THIS IS THE THIRD LEVEL OF SMOOTHING **** MORT2240 C MORT2250 301 DPRIME=APRIME-(6.*B)+(10.*HOLMES)-(5.*DALE) MORT2260 Y=APRIME+(3.*BPRIME)+(5.*CPRIME)+(7.*DPRIME) MORT2270 D1=-6.*(BPRIME+(5.*CPRIME)+(14.*DPRIME))/(Q-1.) MORT2280 D2=60.*(CPRIME+(7.*DPRIME))/((Q-1.)*(Q-2.)) MORT2290 D3=(-840.*DPRIME)/((Q-1.)*(Q-2.)*(Q-3.)) MORT2300 J=IB MORT2310 SARR(J)=Y MORT2320 DELTA1(J)=D1 MORT2330 DELT23(J)=D2 MORT2340 304 J=J-1 MORT2350 DELT23(J)=D3+DELT23(J+1) MORT2360 DELTA1(J)=DELT23(J+1)+DELTA1(J+1) MORT2370 SARR(J)=SARR(J+1)+DELTA1(J+1) MORT2380 IF (J.EQ.1) GO TO 310 MORT2390 GO TO 304 MORT2400 310 J=IB+1 MORT2410 DO 311 K=J,199 MORT2420 DELT23(K)=DELT23(K-1)-D3 MORT2430 DELTA1(K)=DELTA1(K-1)-DELT23(K) MORT2440 SARR(K)=SARR(K-1)-DELTA1(K) MORT2450 311 CONTINUE MORT2460 J=IA+1 MORT2470 390 IF (SARR(J).LT.SARR(J-1)) GO TO 391 MORT2480 IF (J.EQ.199) GO TO 313 MORT2490 J=J+1 MORT2500 GO TO 390 MORT2510 391 ISW3=1 MORT2520 ISTEP=J-1 MORT2530 GO TO 313 MORT2540 END MORT2550 $IBMAP XETHOL ENTRY SETHOL BOOL0110 SETHOL SAVE 4 BOOL0160 CAL* 4,4 GET ALPHAMERIC INFO BOOL0170 SLW* 3,4 AND STORE IT BOOL0180 RETURN SETHOL BOOL0190 END $ENTRY MORTAL $DATA $BLOCK BCD,0084 56089386 1 100 10 56089386 2 100 20 56089386 3 100 10 56089386 4 100 15 56089386 5 100 75 56089386 6 100 95 56089386 7 100 99 1 56089386 1 4 10000000000 535245022 1/2 12510 40 535245022 1 1/2 12921 83 535245022 2 1/2 13471 57 535245022 3 1/2 14512 70 535245022 4 1/2 14804 54 535245022 5 1/2 15224 77 535245022 6 1/2 16724 165 535245022 7 1/2 17664 72 535245022 8 1/2 18163 102 535245022 9 1/2 18837 161 535245022 10 1/2 18588 198 535245022 11 1/2 18206 289 535245022 12 1/2 17775 289 535245022 13 1/2 17454 288 535245022 14 1/2 17525 425 535245022 15 1/2 17147 478 535245022 16 1/2 16664 512 535245022 17 1/2 17224 561 535245022 18 1/2 16948 690 535245022 19 1/2 16344 603 535245022 20 1/2 15186 676 535245022 21 1/2 14457 697 535245022 22 1/2 12921 554 535245022 23 1/2 10889 499 535245022 24 1/2 9141 468 535245022 25 1/2 7940 469 535245022 26 1/2 6738 338 535245022 27 1/2 6282 355 535245022 28 1/2 5716 336 535245022 29 1/2 5246 299 535245022 30 1/2 4664 287 1 535245022 2 31 10000000000 9 ~ $IBSYS $STOP