SUBROUTINE PHOTONS CALL PHOTNT(1) RETURN END SUBROUTINE KPHOTON CALL PHOTNT(2) RETURN END SUBROUTINE PHOTNT(IZ) C*BEGIN COMMON COMMON SNAP,SNAPSHT(226), + DATE,REMKL,REMCOM,REMBASE,REMRES,REMTIME,STARKL,BASEKL, + KILLK,KILLC,GALAXY(8,8),CX(10),CY(10),BASEQX(5),BASEQY(5), + NEWSTUF(8,8),PLNETS(10,5),ISX,ISY,NSCREM,NROMKL,NROMREM, + NSCKILL,ICRYSTL,NPLANKL, + QUAD(10,10),KX(20),KY(20),KPOWER(20),KDIST(20),KSTUF(20), + INKLING,INBASE,INRESOR,INCOM,INTIME,INSTAR,INENRG,INSHLD, + INTORPS,INLSR,INDATE,ENERGY,SHLD,SHLDUP,CONDIT,TORPS,SHIP, + QUADX,QUADY,SECTX,SECTY,WARPFAC,WFACSQ,LSUPRES,DAMAGE(20), + LENGTH,SKILL,PASSWD,DIST,DIREC,TIME,BASEX,BASEY,DOCKFAC, + KLHERE,COMHERE,CASUAL,NHELP,NKINKS,STARCH(8,8),FUTURE(10), + DEVICE(2,14),IDIDIT,GAMEWON,ALIVE,JUSTIN,RESTING,ALLDONE, + DAMFAC,SHLDCHG,THINGX,THINGY,NDEVICE,PLNETX,PLNETY,INORBIT, + LANDED,IPLANET,IMINE,INPLAN,NENHERE,ISHERE,NEUTZ,IRHERE,ICRAFT, + IENTESC,ISCRAFT,ISATB,ISCATE,CRYPROB,ICITE,IPHWHO,BATX,BATY, + CRACKS(12) INTEGER CF,CI,SHLDUP,CONDIT,QUADX,QUADY,SECTX,SECTY,TORPS, + REMKL,REMBASE,SKILL,REMCOM,GALAXY,STARCH,CX,CY, + SHIP,ALLDONE,BASEQX,BASEQY,BASEX,BASEY,GAMEWON, + ALIVE,STARKL,BASEKL,CASUAL,COMHERE,RESTING,SNAP,SHLDCHG, + THINGX,THINGY,BATX,BATY,PLNETX,PLNETY,PLNETS REAL KDIST,KPOWER,LSUPRES,INTIME,INRESOR,INDATE,INSHLD, + INENRG,INLSR BYTE QUAD REAL*8 DEVICE,PASSWD C*END COMMON LOGICAL*1 IHS,IHR,IHC,IHK,IHE,IHF,IHBLANK,IHDOT,IHP,IHB 1 ,IHSTAR,IHT,IHQUEST,IHNUM,IQUAD,ISHIP COMMON/HOLLER/IHEOL,IHREAL,IHALPHA,IHS,IHR,IHC,IHK,IHGREEN,IHRED, +IHYELLO,IHDOCKD,IHE,IHF,IHBLANK,IHDOT,IHQUEST,IHP,IHSTAR,IHB +,IHT,IHNUM REAL*8 AITEM COMMON/SCANBF/KEY,AITEM EQUIVALENCE (FNUM,AITEM),(SHIP,ISHIP) DIMENSION TARG(3,2), COURSE(3) REAL KP INTEGER BOT,TOP,TOP2 EQUIVALENCE (CRACKS(1),HIT),(CRACKS(4),KSHOT) EQUIVALENCE (KSTUF(1),ITHERE),(KSTUF(2),ITHX),(KSTUF(3),ITHY) DATA IHDOC/'DO'/ C--------CHECK TORPEDO COUNT AND STATUS OF PHOTON TUBES GOTO (1001,1002),IZ 1001 IDIDIT=1 KSHOT=0 IF(DAMAGE(4) .EQ. 0)GO TO 10 CALL PROUT(21HPHOTON TUBES DAMAGED.,21) GO TO 3005 10 IF(TORPS .NE.0)GO TO 15 CALL PROUT(18HNO TORPEDOES LEFT.,18) GO TO 3005 C--------SCAN AND MAKE SENSE OF COMMAND INPUT LINE 15 CALL SCAN TEMP=FNUM N = TEMP + 0.5 IF(KEY .EQ. IHREAL) GO TO 30 16 CALL CRAMI(TORPS,0) CALL CRAMDMP(16H TORPEDOES LEFT.) CALL PROMPT(30HNUMBER OF TORPEDOES TO FIRE: ,30) GO TO 15 30 IF(N .LE. 0) GO TO 3005 IF(N .LE. 3) GO TO 31 CALL PROUT(33HMAXIMUM OF 3 TORPEDOES PER BURST.,33) GO TO 16 3004 CALL BEGPARD 3005 IDIDIT=0 RETURN 31 IF(N .LE. TORPS) GO TO 32 GO TO 16 C--------ALL TORPEDOES FIRED AT SAME SPOT. 3101 DO 3102 I=2,N TARG(I,1)=TARG(1,1) 3102 TARG(I,2)=TARG(1,2) GO TO 36 C--------READ IN TARGET SECTORS 32 DO 33 I=1,N CALL SCAN TARG(I,1)=FNUM IF((I.EQ.1) .AND. (KEY.EQ.IHEOL)) GO TO 34 IF((I .EQ. 2) .AND. (KEY .EQ. IHEOL)) GO TO 3101 IF (KEY .NE. IHREAL) GO TO 3004 CALL SCAN TARG(I,2)=FNUM 33 IF (KEY .NE. IHREAL) GO TO 3004 GO TO 36 34 DO 35 I=1,N CALL CHEW CALL CRAM (33HTARGET SECTOR FOR TORPEDO NUMBER ) CALL CRAMI(I,0) CALL CRAM(3H: ) CALL CRENDNO CALL SCAN TARG(I,1)=FNUM IF (KEY .NE. IHREAL) GO TO 3004 CALL SCAN TARG(I,2)=FNUM 35 IF( KEY .NE. IHREAL) GO TO 3004 C--------CHECK FOR INVALID TARGETS. 36 DO 37 I=1,N DO 37 J=1,2 TEMP = TARG(I,J) IF(TEMP.EQ.-1.) GO TO 3005 37 IF ((TEMP .LT. 0.999) .OR. (TEMP .GT. 10.001)) GO TO 3004 C--------COMPUTE COURSE FOR EACH TORPEDO. DO 40 I=1,N DELTX = 0.1*(TARG(I,2)-SECTY) DELTY=0.1*(SECTX-TARG(I,1)) C--------DO NOT ALLOW ENTERPRISE TO SHOOT A TORPEDO AT ITSELF. IF((DELTX .NE. 0) .OR. (DELTY .NE. 0)) GO TO 40 CALL SKIP(1) CALL PROUT(41HSPOCK: "BRIDGE TO SICKBAY. DR. MC COY, ,41) CALL PROUT(36H I RECOMMEND AN IMMEDIATE REVIEW OF,36) CALL PROUT(41H THE CAPTAIN'S PSYCHOLOGICAL PROFILE." ,41) GO TO 3005 40 COURSE (I) = 1.90985932*ATAN2(DELTX,DELTY) C--------BEGIN OUTER LOOP FOR MOVING TORPEDOES I=0 50 I=I+1 IF(I .GT. N) GO TO 115 IF(CONDIT .NE. IHDOC ) TORPS=TORPS-1 J=I STARTX=SECTX STARTY=SECTY R=(RANF(0)+RANF(0))*0.5 -0.5 IF(ABS(R) .LT. 0.49) GO TO 5709 R=(RANF(0)+1.2)*R C-------- TORPEDO MISFIRES IF(N.GT.1) GO TO 5706 CALL PROUT(21H***TORPEDO MISFIRES. ,21) GO TO 5707 5706 CALL CRAM(18H***TORPEDO NUMBER ) CALL CRAMI(I,0) CALL CRAMDMP(10H MISFIRES.) IF(I . LT. N) CALL PROUT(31H REMAINDER OF BURST ABORTED. ,31) I=N 5707 IF(RANF(0.) .GT. .200000)GO TO 5709 C------- CHECK IF MISFIRE DOES SHIP DAMAGE. IF SO DON'T GIVE TRACK. CALL PROUT(35H***PHOTON TUBES DAMAGED BY MISFIRE.,35) DAMAGE(4)=DAMFAC*(1.0+2.0*RANF(0)) GO TO 115 5709 IF(SHLDUP.NE.0 .OR. CONDIT.EQ.IHDOC ) R=R+0.001*SHLD*R AC=COURSE(I)+0.25*R GO TO 5710 C* C ENTRY KPHOTON C* C----------- SET FLAG FOR KLINGON C--------ENEMY FIRES PHOTON TORPEDO 1002 IX=KX(KSHOT) IY=KY(KSHOT) I=1 N=1 STARTX=IX STARTY=IY DELTX=0.1*(SECTY-STARTY) DELTY=0.1*(STARTX-SECTX) AC=1.90985932*ATAN2(DELTX,DELTY) TEMP=RANF(0)-0.5 R=TEMP*(1.0+0.001*KPOWER(KSHOT))+RANF(0.)*TEMP AC=AC+0.25*R IQUAD=QUAD(IX,IY) CALL CRMSENA(IQUAD,0,IX,IY) CALL CRAMDMP(22H FIRES PHOTON TORPEDO. ) C--------CHECK FOR KLINGON MISFIRE IF(ABS(TEMP) .LT. 0.45) GO TO 5710 C--------ENEMY TORPEDO MISFIRED. DETERMINE DAMAGE. ANGLE=(15.0-AC)*0.5235988 HIT=200.0 + 600.0*RANF(0) LL=KSHOT CALL PROUT(21H***TORPEDO MISFIRES! ,21) GO TO 68 5710 ANGLE=(15.0-AC)*0.5235988 IF(N .EQ. 1)GO TO 58 CALL SKIP(1) CALL CRAM(25HTRACK FOR TORPEDO NUMBER ) CALL CRAMI(J,0) 5720 CALL CRAM(6H: ) GO TO 59 58 CALL SKIP(1) CALL CRAM(15HTORPEDO TRACK: ) 59 DELTAX=-SIN(ANGLE) DELTAY=COS(ANGLE) BIGGER=AMAX1(ABS(DELTAX),ABS(DELTAY)) DELTAX=DELTAX/BIGGER DELTAY=DELTAY/BIGGER X=STARTX Y=STARTY C--------BEGIN INNER LOOP FOR MOVING A SINGLE TORPEDO L=0 5910 L=L+1 X=X+DELTAX IX=X+0.5 IF(IX .LT. 1 .OR. IX .GT. 10)GO TO 105 Y=Y+DELTAY IY=Y+0.5 IF(IY .LT. 1 .OR. IY .GT. 10)GO TO 105 IF(L .EQ. 4 .OR. L .EQ. 9)CALL CREND CALL CRAMF(X,0,1) CALL CRAM(3H - ) CALL CRAMF(Y,0,1) CALL CRAM(3H ) IQUAD=QUAD(IX,IY) IF(IQUAD.EQ.IHDOT) GOTO 5910 C--------BEGIN HIT CHECKS CALL CREND C--------COMPUTE EXACT ANGLE TO SECTOR HIT, DISTANCE TO SECTOR HIT, C NORMAL MISS DISTANCE, AND HIT DIST=SQRT((STARTX-IX)**2 + (STARTY-IY)**2) DELTX=0.1*(IY-STARTY) DELTY=0.1*(STARTX-IX) BULSEYE=1.90985932*ATAN2(DELTX,DELTY) BULSEYE=(15.0-BULSEYE)*0.5235988 SINANG=SIN(ANGLE-BULSEYE) DISTN=ABS(SINANG) * DIST HIT=700.0+100.0*RANF(0)-1000.0*DISTN C--------TEST FOR AND COPE WITH HIT ON KLINGON,ROMULAN, OR COMMANDER. IF(IQUAD .EQ. IHK .OR. IQUAD .EQ. IHR) GO TO 62 IF(IQUAD .NE. IHC .AND. IQUAD .NE. IHS) GO TO 70 IF(RANF(0) .GT. 0.05) GO TO 62 CALL CRMSENA(IQUAD,2,IX,IY) CALL CRAMDMP(25H USES ANTI-PHOTON DEVICE;) CALL PROUT(23H TORPEDO NEUTRALIZED.,3) GO TO 50 62 DO 65 LL=1,NENHERE IF(IX.EQ.KX(LL) .AND. IY.EQ.KY(LL)) GO TO 68 65 CONTINUE 68 KP=KPOWER(LL) KPOWER(LL)=KP-SIGN(AMIN1(ABS(KP),HIT),KP) IF(KPOWER(LL) .NE. 0.0) GO TO 69 CALL DEADKL(IX,IY,IQUAD,IX,IY) GO TO 50 69 CALL CRMSENA(IQUAD,2,IX,IY) C--------IF ENEMY DAMAGED BUT NOT DESTROYED, TRY TO DISPLACE HIM 6901 ANG=ANGLE + 2.5*(RANF(0)-0.5) TEMP=AMAX1(ABS(-SIN(ANG)),ABS(COS(ANG))) XX=-SIN(ANG) / TEMP YY= COS(ANG) / TEMP JX=IX+XX+0.5 JY=IY+YY+0.5 IF(JX.LT.1 .OR. JX.GT.10 .OR. JY.LT.1 .OR. JY.GT.10) GO TO 6905 IF(QUAD(JX,JY) .NE. IHBLANK) GO TO 6903 C--------SOMEONE FALLS INTO A BLACK HOLE CALL CRAMDMP(26H BUFFETED INTO BLACK HOLE.) IF(IQUAD .NE.ISHIP) GO TO 6902 CALL FINISH(21) RETURN 6902 CALL DEADKL(IX,IY,IQUAD,JX,JY) GO TO 50 6903 IF(QUAD(JX,JY) .NE. IHDOT) GO TO 6905 QUAD(JX,JY)=IQUAD QUAD(IX,IY)=IHDOT CALL CRAMDMP(10H DAMAGED--) CALL CRAM(24H DISPLACED BY BLAST TO) CALL CRAMLOC(2,JX,JY) CALL CREND IF(IQUAD .NE.ISHIP) GO TO 6904 C------STARSHIP DISPLACED BY TORPEDO. MOVE IT AND RESET ENEMY DISTANCES SECTX=JX SECTY=JY CALL RESETD GO TO 50 C--------ENEMY DISPLACED BY PHOTON BLAST 6904 KX(LL)=JX KY(LL)=JY KDIST(LL)= SQRT(FLOAT((SECTX-JX)**2 + (SECTY-JY)**2)) GO TO 50 6905 CALL CRAMDMP(27H DAMAGED BUT NOT DESTROYED.) GO TO 50 C--------TEST FOR AND COPE WITH HIT ON A STARBASE 70 IF(IQUAD.NE.IHT) GO TO 7002 CALL CRMSENA(IHT,2,IX,IY) IF(HIT.LT.600) GO TO 7001 CALL CRAM(11H DESTROYED. ) CALL CREND QUAD(IX,IY)=IHDOT ITHERE=0 ITHX=0 ITHY=0 GO TO 50 7001 X=RANF(0) IF(X.GT.0.05) CALL CRAMDMP(25H SURVIVES PHOTON BLAST. ) IF(X.GT.0.05) GO TO 50 CALL CRAM(12H DISAPEARS. ) QUAD(IX,IY)=IHNUM CALL DROPIN(IHBLANK,DUM,MY) ITHERE=0 GO TO 50 7002 IF(IQUAD.NE.IHNUM) GOTO 7005 CALL PROUT(35H***TORPEDO ABSORBED BY THOLIAN WEB. ,35) GOTO 50 7005 IF(IQUAD.NE.IHB) GO TO 75 CALL CRMSENA(IHB,2,IX,IY) IF(HIT .LT. 600.0) GO TO 7510 CALL CRAM(12H DESTROYED ) IF(IPHWHO.NE.1) CALL CRAM(21H.... CONGRATULATIONS ) CALL CREND IF(STARCH(QUADX,QUADY) .LT. 0) STARCH(QUADX,QUADY)=0 DO 71 LLL=1,REMBASE IF(BASEQX(LLL).NE.QUADX .OR. BASEQY(LLL).NE.QUADY) GO TO 71 BASEQX(LLL)=BASEQX(REMBASE) BASEQY(LLL)=BASEQY(REMBASE) 71 CONTINUE QUAD(IX,IY)=IHDOT REMBASE=REMBASE-1 BASEX=0 BASEY=0 GALAXY(QUADX,QUADY)=GALAXY(QUADX,QUADY)-10 IF(IPHWHO.NE.1) BASEKL=BASEKL+1 CALL NEWCOND GO TO 50 C--------TEST FOR AND COPE WITH A HIT ON A PLANET. 75 IF(IQUAD .NE. IHP) GO TO 80 CALL CRMSENA(IHP,2,IX,IY) IF(HIT .GT. 450.0) GO TO 7520 7510 CALL CRAMDMP(23H SURVIVES PHOTON BLAST.) GO TO 50 7520 CALL CRAMDMP(11H DESTROYED. ) NPLANKL=NPLANKL+1 NEWSTUF(QUADX,QUADY)=NEWSTUF(QUADX,QUADY)-1 DO 76 II=1,5 76 PLNETS(IPLANET,II)=0 IPLANET=0 PLNETX=0 PLNETY=0 QUAD(IX,IY)=IHDOT IF(LANDED .NE. 1) GO TO 50 C--------CAPTAIN PERISHES ON PLANET. CALL FINISH(15) RETURN 80 IF(IQUAD .NE. IHSTAR) GO TO 90 C--------STAR HIT - CHECK FOR NOVA RESULTS IF(HIT.GT.270.0) GO TO 85 CALL CRMSENA(IHSTAR,2,IX,IY) CALL CRAMDMP(28H UNAFFECTED BY PHOTON BLAST.) GO TO 50 85 CALL NOVA(IX,IY) IF(GALAXY(QUADX,QUADY) .EQ. 1000) RETURN IF(ALLDONE.NE.0) RETURN GO TO 50 C--------CHECK FOR A BOOMERANG TORPEDO 90 IF(IQUAD .NE.ISHIP) GO TO 93 IF(CONDIT.NE.IHDOC) GO TO 9010 IF(RANF(0).GT.0.77) GO TO 9010 CALL CRAM(27H STAR BASE SHIELDS PROTECT ) CALL CRAMSHP CALL CREND GO TO 50 9010 CALL CRAM3AS CALL CRAMSHP CALL CRAMDMP(27H BLASTED BY PHOTON TORPEDO! ) CALL NEWCOND CALL ZAP IF(ENERGY .GT. 0.0) GO TO 91 IF(KSHOT.NE.0) GO TO 9020 CALL FINISH(22) RETURN 9020 CALL FINISH(5) RETURN 91 CALL CASULTY C--------CHECK TO SEE IF SHIP DISPLACED CALL CRAMSHP GO TO 6901 C--------CHECK FOR HIT ON THING. 93 IF(IQUAD .NE. IHQUEST) GO TO 95 CALL SKIP(1) CALL PROUT( + 55H"AAAAIIIIIEEEEEEEEEAAAAAAAAUUUUUGGGGGHHHHHHHHHHHHHHH!!!,55) CALL PROUT( + 48H HACK! HACK! HACK! *CHOKE!* ",48) CALL SKIP(1) CALL PROUT(26HMR. SPOCK: "FASCINATING!",26) QUAD(IX,IY)=IHDOT GO TO 50 C--------TORPEDO ENTERS VICINITY OF BLACK HOLE. CHECK FOR DEFLECTION 95 CALL CRMSENA(IHBLANK,2,IX,IY) IF(DISTN .LT. 0.1) GO TO 97 C--------BOING. COMPUTE DEFLECTION ANGLE, AND NEW STARTING POINT SPRANG=(0.5-DISTN) * 7.853981634 BETA=1.57079633 + ANGLE - SPRANG STARTX = IX-DISTN*SIN(BETA) STARTY = IY+DISTN*COS(BETA) ANGLE = ANGLE - SIGN(SPRANG,SINANG) CALL CRAMDMP(18H DEFLECTS TORPEDO. ) CALL CRAM(9HNEW TRACK) GO TO 5720 97 CALL CRAMDMP(18H SWALLOWS TORPEDO.) GO TO 50 C--------END INNER LOOP FOR MOVING ONE TORPEDO 105 CALL CREND 106 CALL PROUT(15HTORPEDO MISSED.,15) GO TO 50 115 IF(REMKL .EQ. 0) CALL FINISH(1) IF(KSHOT .EQ. 0) CALL SORTKL RETURN END