C==================================================================== C * C TREK7 MODULE G * C * C -- CONVERTED TO PC BY: DAN GAHLINGER -- * C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C * C MISCALLANEOUS ROUTINES * C * C ENTEMP BALOK TALOS ENEMY MOLOCH DONE * C THOLIA KNUTH BLISH FINNEY SAURON MCCOY * C RPAIR * C * C==================================================================== C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C C - ENTEMP - C C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C DG NOV. 15/1999 - CALL_LIB$EOL AND SO FORTH ARE NOT PART OF ORIG PRINTOUT C CALL_LIB$EOL AND SO FORTH HAVE THUS BEEN REMOVED TO REFLECT ORIG SOURCE C SUBROUTINE ENTEMP(MOVE) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCCL(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IF(MOVE.GT.0)GO TO 3331 IF(ITEMP(IT).EQ.4000)GO TO 546 ITEMP(IT)=ITEMP(IT)-600 GO TO 3332 3331 CALL RANDO(I7,75,125) IF(WARP(IT).GT.6.)GO TO 3333 ITEMP(IT)=ITEMP(IT)+(WARP(IT)-6.)*I7 GO TO 3332 3333 ITEMP(IT)=ITEMP(IT)+(WARP(IT)-6.)*FLOAT(I7)*(FLOAT(MA(IT,29))/9.+ *1.)*(FLOAT(MA(IT,30))/9.+1.) 3332 IF(ITEMP(IT).LT.4000)ITEMP(IT)=4000 WRITE(L,3334)ITEMP(IT) 3334 FORMAT(' ENGINE TEMP. = ',I5,' DEGREES') IF(ITEMP(IT).LT.5500)GO TO 546 IF(ITEMP(IT).GT.6200)GO TO 3335 3336 FORMAT(' ENGINES OVERHEATING -TEMPERATURES ARE NEAR CRITICAL') GO TO 546 3335 WRITE(L,3337) 3337 FORMAT(' TEMPERATURES ARE BOYOND CRITICAL POINT') IF(ITEMP(IT).GE.7500)WRITE(L,3338) 3338 FORMAT(' EXPLOSION IMMINENT!!!') CALL RANDO(I7,1,100) IF(I7.GT.(ITEMP(IT)-6200)/100)GO TO 546 I8=MA(IT,29)+MA(IT,30)+1 CALL RANDO(I7,0,I8) J=1 IF(I7.GT.MA(IT,29))J=2 IF(MA(IT,28+J).EQ.9)J=3-J IF(MA(IT,28+J).GT.0)MANUM(IT)=MANUM(IT)-1 MA(IT,28+J)=9 TWARP(IT)=TWARP(IT)-4.5+K(IT,3+J)/2 IF(TWARP(IT).LT.0)TWARP(IT)=0 K(IT,3+J)=9 WRITE(L,3339)J,J 3339 FORMAT(' ENGINEERING HERE SIR - MATTER AND ANTI-MATTER ARE NO WIT *HIN RED-ZONE PROXIMITY'/' AUTOMATIC RELAYS CUTTING IN..... NACELLE *',I2,' JETTISONNED'/' NACELLE',I2,' HAS EXPLODED - DAMAGE REPORT D *UE TO PROXIMITY OF BLAST-') DO 162 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 162 IF(I7.EQ.IT)GO TO 162 I8=I7+4 WRITE(I8,1630)(INAME(IQ0,IT),IQ0=1,3),J 1630 FORMAT(1X,3A4,' NACELLE',I2,' HAS EXPLODED - DAMAGE REPORT-') 162 CONTINUE IVV=10 CALL GRUP1(IVV,IT) 546 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C - BALOK - C SUBROUTINE BALOK COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM I7=IBPSS(I) IF(IJ(I7).EQ.0)I7=0 CALL PIKE(IBASR(I),IBASC(I),I7) IF(MMIN.EQ.0)GO TO 1 IF(DISTP.GT.20.)GO TO 1 DFLCB(I)=DFLCB(I)-5.0 CALL RANDO(IVV,1,100) IF(IVV.LE.DISTP*2.5)GO TO 1 IF(MMIN.GT.14)GO TO 2 IF(MMIN.GT.4)GO TO 3 DO 4 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 4 I8=I7+4 WRITE(I8,5)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(INAME(IQ0,MMIN),IQ0=1,3) 5 FORMAT(/1X,3A4,' STARBASE',I3,' HAS SCORED A HIT ON THE ',3A4,'-DA *MAGE REPORT-') 4 CONTINUE CALL GRUP1(LIRPA(DFLCT(MMIN),50),MMIN) GO TO 1 3 IF(MMIN.GT.6)GO TO 6 MMIN=MMIN-4 DO 7 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 7 I8=I7+4 WRITE(I8,8)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(ISIDE(IQ0,MMIN),IQ0=1,3),IBASE(MMIN) 8 FORMAT(/1X,3A4,' STARBASE',I3,' HIT ',3A4,' STARBASE',I3, *'-DAMAGE REPORT-') 7 CONTINUE CALL GRUP2(LIRPA(DFLCB(MMIN)/3.,50),MMIN) GO TO 1 6 MMIN=MMIN-6 IF(MMIN.NE.7)GO TO 15 CALL RANDO(I7,1,3) IF(I7.EQ.2)GO TO 15 DO 16 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 16 I8=I7+4 WRITE(I8,17)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 17 FORMAT(/1X,3A4,' STARBASE',I3,' PHASERS BOUNCED OFF DOOMSDAY * MACHINE') 16 CONTINUE GO TO 1 15 DO 9 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 9 I8=I7+4 WRITE(I8,18)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(IENM2(IV,MMIN),IV=1,4) 18 FORMAT(/1X,3A4,' STARBASE',I3,' HIT ',4A4,'-DAMAGE REPORT-') 9 CONTINUE CALL GRUP3(LIRPA(DFLCK(MMIN),50),MMIN) GO TO 1 2 MMIN=MMIN-14 DFLCB(I)=DFLCB(I)+4.9 DO 10 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 10 I8=I7+4 WRITE(I8,11)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I),MMIN 11 FORMAT(/1X,3A4,' STARBASE',I3,' DESTROYED EAGLE',I3) 10 CONTINUE CALL BOOM(MMIN) 1 RETURN END C- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHCEK 04/25/2000 BY: D.G. C- TALOS - C SUBROUTINE TALOS COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM DO 13 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 13 I8=I7+4 WRITE(I8,14)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 14 FORMAT(/' ION STORM DAMAGE TO ',3A4,' STARBASE',I3,' AS FOLLOWS-') 13 CONTINUE CALL RANDO(IV,1,20) IVV=ALOG((101.-DFLCB(I)/3.)*IV)/0.700619195-3. CALL GRUP2(IVV,I) RETURN END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHCEK 04/25/2000 BY: D.G. C C EEEEE N N EFEEE M M Y Y C E NN N E MM MM Y Y C EEEE N N N EEEE M M M Y C E N NN E M M Y C EEEEE N N EEEEE M M Y C SUBROUTINE ENEMY LOGICAL BLISH COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /K/IWHO(8),DIST(8),KILLZ,KILLR,KILLD,KILLG,IGOCO(8) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM LOGICAL MOLOCH KOENIG=0 JTK=0 1101 DO 1100 I=1,8 ISTAT=0 IF(I.NE.8)GO TO 11010 CALL DUNE 11010 IF(ICHOS(I).EQ.0)GO TO 1100 107 GO TO (1103,1104,1105,1106,1107,1109,1108,11090),I 1103 CALL RANDO(IV,45,110) GO TO 1109 1104 CALL RANDO(IV,30,100) GO TO 1109 1105 CALL RANDO(IV,60,90) GO TO 1109 1106 CALL RANDO(IV,35,90) GO TO 1109 1107 CALL RANDO(IV,50,100) GO TO 1109 1108 CALL RANDO(IV,100,200) GO TO 1109 11090 IV=50 1109 CALL PIKE(IKLNR(I),IKLNC(I),IBPSB(I)) IF(MMIN.EQ.0)GO TO 232 IF(DIST(I).GE.DISTP)GO TO 3390 IF(MOLOCH(IWHO(I)))GO TO 3390 DISTP=DIST(I) MMIN=IWHO(I) ISTAT=6 3390 IF(I.NE.2)GO TO 378 DO 360 I7=1,4 IF(ICHOE(I7).NE.1)GO TO 380 IF(DI(IENTR(I7),IENTC(I7),IKLNR(2),IKLNC(2)).GT.5.)GO TO 380 INVIS(I7)=1 I8=I7+4 WRITE(I8,381) 381 FORMAT(' THE ROMULAN SHIP IS NOW WITHIN SENSOR RANGE') KILLR=2 380 CONTINUE IF(KILLR.NE.1)GO TO 339 IF(DISTP.GT.10.)GO TO 1100 KILLR=2 GO TO 339 378 IF(I.EQ.3)CALL THOLIA IF(I.NE.7)GO TO 379 IF(KILLD.EQ.1.AND.DISTP.GT.7.)GO TO 1100 KILLD=1 GO TO 339 379 IF(I.NE.6)GO TO 339 IF(DISTP.GT.KILLZ.AND.DFLCK(6).EQ.100.)GO TO 1100 CALL KNUTH 339 IF(MMIN.EQ.0)GO TO 1100 IF(DISTP.GT.25.)GO TO 1100 IF(I.NE.6)GO TO 33900 360 IF(BLISH(JTK))GO TO 1100 33900 CALL RANDO(IVV,1,100) IF(IVV.LE.DISTP*3.)GO TO 232 IF(MMIN.GT.4)GO TO 340 MI=MMIN DO 341 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 341 I8=I7+4 WRITE(I8,342)(IENM2(J,I),J=1,4),(INAME(IQ0,MI),IQ0=1,3) 342 FORMAT(/1X,4A4,' HAS SCORED A HIT ON THE ',3A4,'-DAMAGE REPORT-') 341 CONTINUE CALL GRUP1(LIRPA(DFLCT(MI),IV),MI) GO TO 232 340 IF(MMIN.GT.6)GO TO 343 MI=MMIN-4 DO 344 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 344 I8=I7+4 WRITE(I8,330)(IENM2(J,I),J=1,4),(ISIDE(IQ0,MI),IQ0=1,3),IBASE(MI) 330 FORMAT(/1X,4A4,' HAS HIT ',3A4,' STARBASE',I3,'-DAMAGE REPORT-') 344 CONTINUE CALL GRUP2(LIRPA(DFLCB(MI)/3.,IV),MI) GO TO 232 343 IF(MMIN.GT.14)GO TO 345 MI=MMIN-6 IF(MI.NE.7)GO TO 3460 CALL RANDO(I8,1,3) IF(I8.EQ.2)GO TO 3460 DO 3461 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 3461 I8=I7+4 WRITE(I8,3462)(IENM2(J,I),J=1,4) 3462 FORMAT(/1X,4A4,' FIRE BOUNCED OFF DOOMSDAY MACHINE') 3461 CONTINUE GO TO 232 3460 DO 346 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 346 I8=I7+4 WRITE(I8,347)(IENM2(J,I),J=1,4),(IENM2(J,MI),J=1,4) 347 FORMAT(/1X,4A4,' HAS SCORED A HIT ON ',4A4,'-DAMAGE REPORT-') 346 CONTINUE CALL GRUP3(LIRPA(DFLCK(MI),IV),MI) GO TO 232 345 MI=MMIN-14 DO 348 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 348 I8=I7+4 WRITE(I8,349)(IENM2(J,I),J=1,4),MI 349 FORMAT(/1X,4A4,' DESTROYED EAGLE',I3) 348 CONTINUE 338 CALL BOOM(MI) 232 IF(I.EQ.6)GO TO 360 1100 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - MOLOCH - C LOGICAL FUNCTION MOLOCH(MMIN) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) MOLOCH=.FALSE. IF(MMIN.GT.4)GO TO 1 IF(ICHOE(MMIN).NE.0.AND.ICHOE(MMIN).NE.3)RETURN 10 MOLOCH=.TRUE. RETURN 1 IF(MMIN.GT.6)GO TO 2 IF(ICHOB(MMIN-4).NE.0)RETURN GO TO 10 2 IF(MMIN.GT.14)GO TO 3 IF(ICHOS(MMIN-6).EQ.1)RETURN GO TO 10 3 IF(IGLER(MMIN-14).NE.0)RETURN GO TO 10 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - DUNE - C SUBROUTINE DUNE DIMENSION ISID(3,3) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBABC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /TOM/ITOM DATA ISID/'FEDE','RATI','ON ','KLIN','GON ',' ', *'MOON','BASE',' '/ IF(NUMOUT.EQ.0)KOENIG=3 1110 KOENIG=KOENIG+1 GO TO (315,318,316),KOENIG GO TO 1100 315 CALL RANDO(IS,1,2) 323 IV=NUME(IS) 320 IF(NUME(IS).EQ.0)GO TO 1110 322 DO 319 I7=1,LAUNCH IF(IGLER(I7).NE.0.AND.IBPSE(I7).EQ.IS)GO TO 321 319 CONTINUE 318 IS=3-IS GO TO 323 316 IS=0 IV=NUMOUT-NUME(1)-NUME(2) IF(IV.EQ.0)GO TO 1110 GO TO 322 321 CALL PIKE(IGLER(I7),IGLEC(I7),IBPSE(I7)) IF(MMIN.EQ.0)GO TO 1110 IV=FLOAT(IV)*20.*(1.0-DISTP*0.045) IF(IV.LE.0)GO TO 1110 IF(KOENIG.EQ.3)IS=3 IF(MMIN.GT.4)GO TO 324 MI=MMIN DO 325 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 325 I8=I7+4 WRITE(I8,326)(ISID(IQ0,IS),IQ0=1,3),(INAME(IQ0,MI),IQ0=1,3) 326 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',3A4,'-DAMAGE REPORT-') 325 CONTINUE CALL GRUP1(LIRPA(DFLCT(MI),IV),MI) GO TO 1110 324 IF(MMIN.GT.6)GO TO 328 MI=MMIN-4 DO 329 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 329 I8=I7+4 WRITE(I8,3300)(ISID(IQ0,IS),IQ0=1,3),(ISIDE(IQ0,MI),IQ0=1,3), *IBASE(MI) 3300 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',3A4,' STARBASE',I3,'-DAMAGE *REPORT-') 329 CONTINUE CALL GRUP2(LIRPA(DFLCB(MI)/3.,IV),MI) GO TO 1110 328 IF(MMIN.GT.14)GO TO 332 MI=MMIN-6 IF(MI.EQ.7)IV=IV/3 DO 333 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 333 I8=I7+4 WRITE(I8,334)(ISID(IQ0,IS),IQ0=1,3),(IENM2(J,MI),J=1,4) 334 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',4A4,'-DAMAGE REPORT-') 333 CONTINUE CALL GRUP3(LIRPA(DFLCK(MI),IV),MI) GO TO 1110 332 MI=MMIN-14 DO 336 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 336 I8=I7+4 WRITE(I8,337)(ISID(IQ0,IS),IQ0=1,3),MI 337 FORMAT(/1X,3A4,' BOARDED EAGLES DESTROYED EAGLE ',I2) 336 CONTINUE CALL BOOM(MI) GO TO 1110 1100 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECKED 04/25/2000 BY: D.G. C C - THOLIA - C SUBROUTINE THOLIA DIMENSION IWHE(3,2),IIDIM(2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) DATA IWHE/'THOL','IAN ',' ','KZIN','TI ',' '/,IIDIM(1)/8/ IIDIM(2)=IWEBZ NN=I/3 IF(IWEB(NN).NE.0)GO TO 232 IF(ISTAT.EQ.6)GO TO 232 IF(DISTP.GT.IIDIM(NN))GO TO 232 IF(MMIN.GT.4)GO TO 229 IF(IWEB(3-NN).EQ.MMIN)GO TO 232 DO 228 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 228 I8=I7+4 WRITE(I8,1102)(INAME(IQ0,MMIN),IQ0=1,3),(IWHE(IQ0,NN),IQ0=1,3) 1102 FORMAT(' THE ',3A4,' IS TRAPPED IN A',3A4,'WEB') 228 CONTINUE IWEB(NN)=MMIN GO TO 232 229 IV=MMIN-6 IF(IV.LT.1)GO TO 232 IF(IV.EQ.7)GO TO 232 IF(IV.GT.8)GO TO 232 IF(IWEB(3-NN).EQ.MMIN-2)GO TO 232 DO 227 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 227 I8=I7+4 WRITE(I8,314)(IENM2(J,IV),J=1,4),(IWHE(IQ0,NN),IQ0=1,3) 314 FORMAT(' THE ',4A4,' IS TRAPPED IN A',3A4,'WEB') 227 CONTINUE IWEB(NN)=MMIN-2 232 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - KNUTH - C SUBROUTINE KNUTH COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /K/IWHO(8),DIST(8),KILLZ,KILLR,KILLD,KILLG,IGOCO(8) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) KILLZ=100 IF(IARMZ(5).EQ.0)GO TO 363 DO 382 I7=1,4 INVIZ(I7)=0 IF(ICHOE(I7).NE.1)GO TO 382 IF(DI(IENTR(I7),IENTC(I7),IKLNR(6),IKLNC(6)).GT.ICLOZ)GO TO 382 INVIZ(I7)=1 I8=I7+4 WRITE(I8,383) 383 FORMAT(' THE KZINTI SHIP IS NOW WITHIN SENSOR RANGE') 382 CONTINUE 363 IF(IARMZ(3).EQ.0.OR.IWEB(2).NE.0)GO TO 364 CALL THOLIA 364 IF(IARMZ(6).EQ.0)GO TO 1100 IF(DISTP.GT.IABSZ)GO TO 1100 IF(MMIN.GT.14)GO TO 1100 IF(MMIN.GT.4)GO TO 367 DO 365 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 365 I8=I7+4 WRITE(I8,366)(INAME(IQ0,MMIN),IQ0=1,3) 366 FORMAT(/1X,3A4,' IS WITHIN RANGE OF KZINTI STASIS FIELD') 365 CONTINUE PHASR(MMIN)=PHASR(MMIN)-ISTAZ DFLCT(MMIN)=DFLCT(MMIN)-ISTAZ/100. TWARP(MMIN)=TWARP(MMIN)-ISTAZ/1000. IF(PHASR(MMIN).LT.0)PHASR(MMIN)=0 IF(TWARP(MMIN).LT.0)TWARP(MMIN)=0 GO TO 1100 367 IF(MMIN.GT.6)GO TO 368 MI=MMIN-4 DO 369 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 369 I8=I7+4 WRITE(I8,370)(ISIDE(IQ0,MI),IQ0=1,3),IBASE(MI) 370 FORMAT(/1X,3A4,' STARBASE',I3,' IS WITHIN RANGE OF KZINTI STASIS F *IELD') 369 CONTINUE DFLCB(MI)=DFLCB(MI)-ISTAZ/100. GO TO 1100 368 MI=MMIN-6 IF(MI.EQ.7)GO TO 1100 DO 372 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 372 I8=I7+4 WRITE(I8,373)(IENM2(J,MI),J=1,4) 373 FORMAT(/1X,4A4,' IS WITHIN RANGE OF KZINTI STASIS FIELD') 372 CONTINUE DFLCK(MI)=DFLCK(MI)-ISTAZ/100. 1100 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - BLISH - C DG: NOTE - THIS MODULE IS DEDICATED IN MEMORY OF THE LATE JAMES BLISH C LOGICAL FUNCTION BLISH(JT) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) BLISH=.FALSE. 360 JT=JT+1 GO TO (359,356,1100),JT 359 IF(IARMZ(1).EQ.0)GO TO 360 IV=INDUZ DO 357 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 357 I8=I7+4 WRITE(I8,358) 358 FORMAT(/' KZINTI WARSHIP FIRING INDUCTION BEAM') 357 CONTINUE GO TO 33900 356 IF(IARMZ(2).EQ.0)GO TO 360 IF(.NOT.MOLOCH(MMIN))GO TO 355 CALL PIKE(IKLNR(6),IKLNC(6),IBPSB(6)) IF(MMIN.EQ.0)GO TO 360 355 IV=IXRYZ DO 361 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 361 I8=I7+4 WRITE(I8,362) 362 FORMAT(/' KZINTI WARSHIP FIRING X-RAY LASER CANNON') 361 CONTINUE GO TO 33900 1100 BLISH=.TRUE. 33900 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C C - FINNEY - C SUBROUTINE FINNEY(MI) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM DATA FUDGE/0.700619195/ ION(MI)=0 DO 376 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 376 I8=I7+4 WRITE(I8,377)(INAME(IQ0,MI),IQ0=1,3) 377 FORMAT(/' ION STORM DAMAGE TO ',3A4) 376 CONTINUE CALL RANDO(IV,1,20) IVV=ALOG((101.-DFLCT(MI))*IV)/FUDGE-3. CALL GRUP1(IVV,MI) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - SAURON - C SUBROUTINE SAURON COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /J/KODE(2,8),STATIC(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IDOK=0 DO 131 J=1,4 IF(ICHOE(J).EQ.0)GO TO 131 IF(IBPSC(IT).EQ.J)GO TO 131 I=J+4 WRITE(I,132)(INAME(IQ0,IT),IQ0=1,3) 132 FORMAT(' PLEASE STANDBY WHILE THE ',3A4,' TAKES ITS TURN') 131 CONTINUE DO 1 I=1,2 IF(ICHOB(I).NE.1)GO TO 1 IF(IBPSS(I).NE.IS)GO TO 1 IF(DI(IENTR(IT),IENTC(IT),IBASR(I),IBASC(I)).GE.2)GO TO 1 IDOK=1 CALL MCCOY 1 CONTINUE 2330 IF(TWARP(IT).GE.0.5)GO TO 422 IF(NOMOV(IT).EQ.1)GO TO 423 NOMOV(IT)=1 WRITE(L,421) 421 FORMAT(' WARP ENERGY IS UNDER 0.5 SO THE WARP ENGINES HAVE BEEN SH *UT DOWN'/' TO CONSERVE POWER') ITEMP(IT)=0 GO TO 423 422 IF(NOMOV(IT).EQ.0)GO TO 423 NOMOV(IT)=0 ITEMP(IT)=4000 WRITE(L,424) 424 FORMAT(' ENGINEERING HERE SIR - WE''VE ENGAGED ENGINE RESTART CYCL *E'/' AND SHOULD BE ABLE TO MOVE NOW') 423 IF(IGO(IT).EQ.0)GO TO 23302 IF(NDEAD(IT).LT.100)GO TO 23302 IF(IDOK.EQ.1)GO TO 23302 IF(MANUM(IT).EQ.0)GO TO 23303 CALL RANDO(I7,1,4*IGO(IT)) WRITE(L,425) 425 FORMAT(' DAMAGE CONTROL PARTIES COMMENCING REPAIRS') 429 IF(MANUM(IT).GT.8)GO TO 426 428 DO 427 I=1,33 IF(MA(IT,I).EQ.0)GO TO 427 I7=I7-1 IF(I7.LT.0)GO TO 23303 CALL RPAIR IF(MANUM(IT).EQ.0)GO TO 23303 427 CONTINUE GO TO 23303 426 CALL RANDO(I,1,33) IF(MA(IT,I).EQ.0)GO TO 426 I7=I7-1 IF(I7.LT.0)GO TO 23303 CALL RPAIR IF(MANUM(IT).LT.8)GO TO 426 GO TO 426 23303 IF(IGO(IT).EQ.1)GO TO 23302 IF(PHASR(IT)+DFLCT(IT)*100.+TWARP(IT)*1000.0.GE.26000.)GO TO 23302 IF(PHASR(IT).LT.6000.)PHASR(IT)=PHASR(IT)+500. DFLCT(IT)=DFLCT(IT)+10. TWARP(IT)=TWARP(IT)+1. IF(DFLCT(IT).GT.100.)DFLCT(IT)=100. IF(TWARP(IT).GT.10.)TWARP(IT)=10. 23302 DO 405 I=1,2 HIVEL(IT,I)=10.-MA(IT,I+30) IF(MA(IT,I+30).EQ.0.OR.MA(IT,I+26).EQ.9)GO TO 405 WRITE(L,406)1,HIVEL(IT,I) 406 FORMAT(' ** NOTE **- NACELLE',I2,' MAY RIP OFF IF WARP SPEED EXCEE *DS',F6.2) 405 CONTINUE K(IT,4)=MA(IT,29) K(IT,5)=MA(IT,30) K(IT,6)=MA(IT,28) IF(JS.EQ.2)GO TO 144 K(IT,1)=MA(IT,23) K(IT,2)=MA(IT,14) K(IT,14)=MA(IT,3) NOMAP(IT)=15-MA(IT,33) GO TO 145 144 K(IT,1)=MA(IT,13) K(IT,2)=MA(IT,14) K(IT,14)=MA(IT,29)+MA(IT,30) NOMAP(IT)=15-MA(IT,13) 145 IF(ICOIL(IT).EQ.0)GO TO 234 CALL RANDO(I7,1,7-IGO(IT)) IF(I7.GT.2)GO TO 234 ICOIL(IT)=0 WRITE(L,4020) 4020 FORMAT(' REPAIRS COMPLETE - PHASERS ARE NOW OPERATIVE') 234 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C - MCCOY - C -- NOV./1999 -DG: I WOULD LIKE TO DEDICATE THIS COMMENT IN MEMORY OF THE C LATE DEFOREST KELLEY WHO PASSED AWAY ONLY SOME MONTHS AGO. OUR THOUGHTS C AND OUR HEARTS WILL BE WITH YOU ALWAYS. MR. KELLEY WILL BE SADLY MISSED. C I THINK MR. KELLEY PASSED AWAY AUG/1999 AT THE AGE OF 78 SUBROUTINE MCCOY COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) WRITE(L,2)INAME(1,IT),INAME(2,IT),IBASE(I) 2 FORMAT(' THE ',2A5,' IS DOCKED AT STARBASE ',I2/' REPAIRS COMMENCI *NG-') DO 3 I7=1,33 MA(IT,I7)=MA(IT,I7)-3 IF(MA(IT,I7).GT.0)GO TO 3 IF(MA(IT,I7).EQ.-3)GO TO 4 MANUM(IT)=MANUM(IT)-1 4 MA(IT,I7)=0 3 CONTINUE IF(MA(IT,29).EQ.6)MANUM(IT)=MANUM(IT)+1 IF(MA(IT,30).EQ.6)MANUM(IT)=MANUM(IT)+1 IF(PHASR(IT)+DFLCT(IT)*100.+TWARP(IT)*1000.0.GE.26000.)GOTO 5 DFLCT(IT)=DFLCT(IT)+10. IF(PHASR(IT).LT.6000.)PHASR(IT)=PHASR(IT)+500. TWARP(IT)=TWARP(IT)+1. IF(DFLCT(IT).GT.100.)DFLCT(IT)=100. IF(TWARP(IT).GT.10.)TWARP(IT)=10. 5 IF(ICOIL(IT).EQ.0)GO TO 7 ICOIL(IT)=0 WRITE(L,14) 14 FORMAT(' PHASERS NOW OPERATIVE') 7 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C C - RPAIR - C C THIS WAS HAND-TYPED 21/APR/2000 BY: D.G. SUBROUTINE RPAIR COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) IF(I.EQ.29.AND.MA(IT,29).EQ.9)RETURN IF(I.EQ.30.AND.MA(IT,30).EQ.9)RETURN CALL RANDO(I8,1,5) MA(IT,I)=MA(IT,I)-I8 IF(MA(IT,I).GT.0)RETURN MA(IT,I)=0 MANUM(IT)=MANUM(IT)-1 RETURN END