C ASCII '0' PROGRAM DRIVER C C AUTHOR: DON LEDFORD C C DECEMBER 1978 JOHN LUTCH ADDED CLOAKING C DECEMBER 1978 DON LEDFORD ADDED ANTI-MATTER C MARCH 1979 RAY FRENCH ADDED CONTINUOUS DISPLAY C OCTOBER 1979 DON LEDFORD ADDED ROBOT SHIPS C MAY 1980 BILL CAEL AND BILL WOOD RECODED IN RATFOR C MAY 1980 BILL WOOD ADDED ENERGY NETS C JUN 1980 BILL WOOD ADDED RANDOM SHIP SERVICING ORDER C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/ACCUM/ACCUME COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) LOGICAL*1ACCUME BYTE CHAR C CALL MARK(2, 30, 1, IDS) ACCUME = .TRUE. DO 2000 I = 1, 8 SHIPS(I) = I 2000 CONTINUE 2010 CONTINUE THRU = .FALSE. C C * HERE STARTS THE ACTUAL GAME PLAYING C 2020 CONTINUE C C THE PLAYER TASKS NEED SOME CPU TIME TOO ! CALL WAITFR(2, IDS) CALL MARK(2, 30, 1, IDS) C C * FIRE TORPEDOES CALL TORPI C * FIRE PHASERS CALL PHASER C * HANDLE ALL ANTI-MATTER TRANSACTIONS CALL MANTI C * MOVE ACTIVE TORPEDOES CALL MTORPS C * MOVE HOMERS CALL MHOMER C * MOVE SHIPS CALL MSHIPS C * MOVE THE "BLACK HOLE" CALL MHOLE C C THE FOLLOWING CODE (IF UNCOMMENTED) WILL CHECK TO SEE C IF THERE ARE STILL ANY PLAYERS. IF NOT, IT WILL WAIT C 30 SECONDS AND THEN EXIT IF NO NEW PLAYERS HAVE STARTED. C DO 2050 J = 1, 6 DO 2070 I = 1, 8 IF (.NOT.(XSHIP(I))) GOTO 2090 GOTO 10 2090 CONTINUE 2070 CONTINUE 2080 CONTINUE CALL WAIT(5, 2, M) 2050 CONTINUE 2060 CONTINUE THRU = .TRUE. 10 CONTINUE 2030 IF (.NOT.(THRU)) GOTO 2020 2040 CONTINUE CALL EXIT END SUBROUTINE MSHIPS C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8), HSPLOC(2, 6) C BYTE CHAR, SHIP, TRAIL DATA HSPLOC/20, 75, 50, 70, 80, 75, 20, 25, 50, 30, 80, 25/ C CALL PERM(SHIPS, I1, I2) DO 2110 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(XSHIP(I))) GOTO 2130 IF (.NOT.(CLOAK(I))) GOTO 2150 C * CAN'T MOVE IF YOU'RE CLOAKED WARP(I) = 0. ENERGY(I) = ENERGY(I) - CDRAIN 2150 CONTINUE SHIP = I + 48 ENERGY(I) = ENERGY(I) - WARP(I)/2 IF (.NOT.(NET(I))) GOTO 2170 TRAIL = - I ENERGY(I) = ENERGY(I) - NDRAIN*WARP(I)/10. GOTO 2180 2170 CONTINUE TRAIL = EMPTY 2180 CONTINUE IX = XCORD(I) IY = YCORD(I) CALL MOVE(XCORD(I), YCORD(I), X, Y, DIR(I), WARP(I), CHAR, UNI *V, EMPTY) KX = X KY = Y IF (.NOT.(CHAR .LE. '8' .AND. CHAR .GE. '1')) GOTO 2190 C * WE HAVE RAMMED A SHIP K = CHAR - 48 ENERGY(I) = ENERGY(I) - 100. IF (.NOT.(XSHIP(K))) GOTO 2210 ENERGY(K) = ENERGY(K) - 100. CALL SENT(K, 10) 2210 CONTINUE WARP(I) = 0. WARP(K) = 0. CALL SENT(I, 9) C GOTO 2200 2190 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 2230 C * RAMMED (DOCKED) A BASE CALL SENT(I, 1) TORPS(I) = 10 WARP(I) = 0. ENERGY(I) = 10000. SHIELD(I) = 0. IPOD(I) = 0 SCAN(I) = 9 NHOM(I) = 4 DO 2250 II = 1, 4 WHOM(I, II) = 0 C 2250 CONTINUE 2260 CONTINUE GOTO 2240 2230 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 2270 C * HIT A STAR CALL SENT(I, 2) ENERGY(I) = ENERGY(I) - 200. WARP(I) = 0. C GOTO 2280 2270 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 22 *90 C * HIT A TORPEDO CALL SENT(I, 4) IF (.NOT.(CHAR .EQ. '^')) GOTO 2310 V = 300. GOTO 2320 2310 CONTINUE V = 500. 2320 CONTINUE CALL DAMAGE(I, V, 500.) CALL TFIND(K, KX, KY) UNIV(KX, KY) = EMPTY IF (.NOT.(K .NE. 0 .AND. (K .NE. I))) GOTO 2330 CALL SENT(K, 5) SCORE(K) = SCORE(K) + V IF (.NOT.(ENERGY(I) .LE. 0)) GOTO 2350 CALL SENT(K, 22) C$ SCORE(K)=SCORE(K)+2000. 2350 CONTINUE 2330 CONTINUE IF (.NOT.(ENERGY(I) .LE. 0)) GOTO 2370 CALL RESET(I) C 2370 CONTINUE GOTO 2300 2290 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 2390 C * HIT A HYPERSPACE PORT 10 CONTINUE CALL SENT(I, 17) KX = HSPLOC(1, HYPER(I)) KY = HSPLOC(2, HYPER(I)) C C * PUT THE SHIP NEAR THE DESTINATION PORT IF POSSIBLE C DO 2410 II = (KX - 1), (KX + 1) DO 2430 IJ = (KY - 1), (KY + 1) IF (.NOT.(UNIV(II, IJ) .EQ. EMPTY)) GOTO 2450 UNIV(II, IJ) = SHIP UNIV(IX, IY) = TRAIL XCORD(I) = II YCORD(I) = IJ XCORD(I) = XCORD(I) + .5 YCORD(I) = YCORD(I) + .5 GOTO 102 2450 CONTINUE 2430 CONTINUE 2440 CONTINUE C * IF WE ARE HERE WE DIDN'T FIND AN EMPTY SPOT ( VERY UNLIKELY) 2410 CONTINUE 2420 CONTINUE CALL SENT(I, 18) 102 WARP(I) = 0. C GOTO 2400 2390 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 2470 C * RUN INTO THE "BLACK HOLE" ( NICE FLYING) 20 CONTINUE CALL SENT(I, 15) CALL RESET(I) C GOTO 2480 2470 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 2490 C * HIT A RANDOM HYPERSPACE PORT 30 CONTINUE CALL SENT(I, 19) C * FIND A NEW EMPTY LOCATION 2510 CONTINUE KX = RAN(I1, I2)*100. + 1. KY = RAN(I1, I2)*100. + 1. 2520 IF (.NOT.(UNIV(KX, KY) .EQ. EMPTY)) GOTO 2510 2530 CONTINUE XCORD(I) = KX YCORD(I) = KY XCORD(I) = XCORD(I) + .5 YCORD(I) = YCORD(I) + .5 WARP(I) = 0. UNIV(IX, IY) = TRAIL UNIV(KX, KY) = SHIP GOTO 2500 2490 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 2540 C * BUMPED INTO AN ANTI-MATTER POD CALL SENT(I, 27) CALL DAMAGE(I, 250., 500.) GOTO 2550 2540 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 2560 C * BUMPED INTO ENERGY NET ENERGY(I) = ENERGY(I) - 200 IF (.NOT.(CHAR .EQ. -I)) GOTO 2580 2600 CONTINUE X2 = X Y2 = Y CALL MOVE(X2, Y2, X, Y, DIR(I), 8., CHAR *, UNIV, EMPTY) 2610 IF (.NOT.(UNIV(IFIX(X), IFIX(Y)) .NE. -I *)) GOTO 2600 2620 CONTINUE KX = X KY = Y CHAR = UNIV(KX, KY) IF (.NOT.(CHAR .EQ. 'H')) GOTO 2630 GOTO 10 2630 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 2650 GOTO 20 2650 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 2670 GOTO 30 2670 CONTINUE IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 2690 XCORD(I) = X YCORD(I) = Y UNIV(IX, IY) = TRAIL UNIV(KX, KY) = SHIP GOTO 2700 2690 CONTINUE CALL SENT(I, 36) WARP(I) = 0. 2700 CONTINUE GOTO 2590 2580 CONTINUE CALL SENT(I, 33) DIR(I) = DIR(I) - 180. IF (.NOT.(DIR(I) .LT. 0.)) GOTO 2710 DIR(I) = DIR(I) + 360. 2710 CONTINUE 2590 CONTINUE GOTO 2570 2560 CONTINUE XCORD(I) = X YCORD(I) = Y IF (.NOT.(UNIV(IX, IY) .NE. -I)) GOTO 2730 UNIV(IX, IY) = TRAIL 2730 CONTINUE UNIV(KX, KY) = SHIP 2570 CONTINUE 2550 CONTINUE 2500 CONTINUE 2480 CONTINUE 2400 CONTINUE 2300 CONTINUE 2280 CONTINUE 2240 CONTINUE 2200 CONTINUE IF (.NOT.(ENERGY(I) .LE. 0.)) GOTO 2750 CALL SENT(I, 16) CALL RESET(I) 2750 CONTINUE 2130 CONTINUE 2110 CONTINUE 2120 CONTINUE RETURN END SUBROUTINE RESET(K) C C * RE-INCARNATE DESTROYED SHIPS C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/ACCUM/ACCUME LOGICAL*1ACCUME XSHIP(K) = .FALSE. ENERGY(K) = 10000. WARP(K) = 0. TORPS(K) = 10. SHIELD(K) = 0. IPOD(K) = 0 SCAN(K) = 9 NHOM(K) = 4 DO 2770 I = 1, 4 WHOM(K, I) = 0 2770 CONTINUE 2780 CONTINUE CLOAK(K) = .FALSE. NET(K) = .FALSE. IF (.NOT.(ACCUME)) GOTO 2790 SCORE(K) = SCORE(K) - 1000. GOTO 2800 2790 CONTINUE SCORE(K) = 0. 2800 CONTINUE CALL SENT(K, 3) KX = XCORD(K) KY = YCORD(K) UNIV(KX, KY) = EMPTY DO 2810 I = 1, 100 DO 2830 J = 1, 100 IF (.NOT.(UNIV(J, I) .EQ. -K)) GOTO 2850 UNIV(J, I) = EMPTY 2850 CONTINUE 2830 CONTINUE 2840 CONTINUE 2810 CONTINUE 2820 CONTINUE 2870 CONTINUE IX = RAN(I1, I2)*100. + 1. IY = RAN(I1, I2)*100. + 1. 2880 IF (.NOT.(UNIV(IX, IY) .EQ. EMPTY)) GOTO 2870 2890 CONTINUE UNIV(IX, IY) = K + 48 XCORD(K) = IX YCORD(K) = IY XCORD(K) = XCORD(K) + .5 YCORD(K) = YCORD(K) + .5 RETURN END SUBROUTINE THIT(I, IX, IY, CHAR, D, E) C C * HANDLE TORPEDO HITS C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON BYTE CHAR IF (.NOT.((CHAR .EQ. 'H') .OR. (CHAR .EQ. 'R'))) GOTO 2900 C * TORPEDO HIT ON HYPER SPACE PORT CONTINUE C GOTO 2910 2900 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 2920 C * TORPEDO HIT ON SHIP K = CHAR - 48 IF (.NOT.(XSHIP(K))) GOTO 2940 CALL DAMAGE(K, E, D) IF (.NOT.(K .NE. I)) GOTO 2960 SCORE(I) = SCORE(I) + E CALL SENT(I, 5) IF (.NOT.(ENERGY(K) .LE. 0)) GOTO 2980 CALL SENT(I, 22) C$ SCORE(I)=SCORE(I)+2000. 2980 CONTINUE 2960 CONTINUE CALL SENT(K, 4) IF (.NOT.(ENERGY(K) .LE. 0.)) GOTO 3000 CALL RESET(K) 3000 CONTINUE GOTO 2950 2940 CONTINUE CALL SENT(I, 21) 2950 CONTINUE GOTO 2930 2920 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 3020 C * TORPEDO HIT ON BLACK HOLE - THE HOLE PREVAILS! GOTO 3030 3020 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3040 C * TORPEDO HIT ON STAR CALL SENT(I, 13) C GOTO 3050 3040 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 3060 C * TORPEDO HIT ON BASE CALL SENT(I, 12) SCORE(I) = SCORE(I) - 200. C GOTO 3070 3060 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 30 *80 C * TORPEDO HIT ON TORPEDO CALL SENT(I, 20) UNIV(IX, IY) = EMPTY C GOTO 3090 3080 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3100 C * TORPEDO HIT ON ANTI-MATTER POD CALL SENT(I, 26) UNIV(IX, IY) = EMPTY GOTO 3110 3100 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3120 C * TORPEDO HIT ON ENERGY NET CALL SENT(I, 34) UNIV(IX, IY) = EMPTY GOTO 3130 3120 CONTINUE C * ANYTHING ELSE GETS DESTROYED UNIV(IX, IY) = EMPTY 3130 CONTINUE 3110 CONTINUE 3090 CONTINUE 3070 CONTINUE 3050 CONTINUE 3030 CONTINUE 2930 CONTINUE 2910 CONTINUE RETURN END SUBROUTINE PHASER C C * FIRE PHASERS C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) REAL DX(3), DY(3) BYTE CHAR CALL PERM(SHIPS, I1, I2) DO 3140 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(PHA(I) .GE. 0.)) GOTO 3160 C C * FIRE 3 BAND WIDE BEAM (NOTE EACH BAND HAS ITS OWN HIT OR MISS MESSAGE) C DX(2) = XCORD(I) DY(2) = YCORD(I) IF (.NOT.(((PHA(I) .GE. 45.) .AND. (PHA(I) .LT. 135.)) .OR. (( *PHA(I) .GE. 225.) .AND. (PHA(I) .LT. 315.)))) GOTO 3180 DX(1) = DX(2) - 1. DX(3) = DX(2) + 1. DY(1) = DY(2) DY(3) = DY(2) GOTO 3190 3180 CONTINUE DX(1) = DX(2) DX(3) = DX(2) DY(1) = DY(2) - 1. DY(3) = DY(2) + 1. 3190 CONTINUE DO 3200 IZ = 1, 3, 2 IF (.NOT.(DX(IZ) .GE. 101.)) GOTO 3220 DX(IZ) = DX(IZ) - 100. GOTO 3230 3220 CONTINUE IF (.NOT.(DX(IZ) .LT. 1.)) GOTO 3240 DX(IZ) = DX(IZ) + 100. 3240 CONTINUE 3230 CONTINUE IF (.NOT.(DY(IZ) .GE. 101.)) GOTO 3260 DY(IZ) = DY(IZ) - 100. GOTO 3270 3260 CONTINUE IF (.NOT.(DY(IZ) .LT. 1.)) GOTO 3280 DY(IZ) = DY(IZ) + 100. 3280 CONTINUE 3270 CONTINUE 3200 CONTINUE 3210 CONTINUE KX = XCORD(I) KY = YCORD(I) NMISS = 0 DO 3300 IZ = 1, 3 X1 = DX(IZ) Y1 = DY(IZ) DO 3320 IIT = 1, 10 CALL MOVE(X1, Y1, X, Y, PHA(I), 10., CHAR, UNIV, EMPTY) IX = X IY = Y IF (.NOT.((CHAR .NE. EMPTY) .AND. ((KX .NE. IX) .OR. (KY . *NE. IY)))) GOTO 3340 GOTO 3330 3340 CONTINUE X1 = X Y1 = Y 3350 CONTINUE 3320 CONTINUE 3330 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 3360 C * HIT ON SHIP K = CHAR - 48 IF (.NOT.(XSHIP(K))) GOTO 3380 C$ DIST=((XCORD(I)-X)**2+(YCORD(I)-Y)**2)**.5 DIST = DSTNCE(XCORD(I), YCORD(I), X, Y) EN = 900./(4. + DIST) C * MAKE SURE WE DON'T SHOOT OURSELVES IF (.NOT.(K .NE. I)) GOTO 3400 CALL DAMAGE(K, EN, PHA(I)) SCORE(I) = SCORE(I) + EN CALL SENT(I, 6) CALL SENT(K, 14) IF (.NOT.(ENERGY(K) .LE. 0.)) GOTO 3420 C$ SCORE(I)=SCORE(I)+2000. CALL SENT(I, 22) CALL RESET(K) 3420 CONTINUE 3400 CONTINUE GOTO 3390 3380 CONTINUE CALL SENT(I, 21) C 3390 CONTINUE GOTO 3370 3360 CONTINUE IF (.NOT.((CHAR .EQ. '+'))) GOTO 3440 C * PHASER HIT ON TORPEDO CALL SENT(I, 7) C GOTO 3450 3440 CONTINUE IF (.NOT.((CHAR .EQ. '^'))) GOTO 3460 C * PHASER HIT ON SEEKER CALL SENT(I, 7) IF (.NOT.(RAN(I1, I2) .GT. .5)) GOTO 3480 UNIV(IX, IY) = EMPTY C 3480 CONTINUE GOTO 3470 3460 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3500 C * PHASER HIT ON STAR CALL SENT(I, 11) C GOTO 3510 3500 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 3520 C * PHASER HIT ON BASE CALL SENT(I, 12) C GOTO 3530 3520 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3540 C * PHASER HIT ON ANTI-MATTER POD CALL SENT(I, 25) GOTO 3550 3540 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3560 C * PHASER HIT ON ENERGY NET CALL SENT(I, 35) GOTO 3570 3560 CONTINUE C * MISSED C$ CALL SENT(I,8) NMISS = NMISS + 1 3570 CONTINUE 3550 CONTINUE 3530 CONTINUE 3510 CONTINUE 3470 CONTINUE 3450 CONTINUE 3370 CONTINUE 3300 CONTINUE 3310 CONTINUE PHA(I) = - 1. IF (.NOT.(NMISS .EQ. 3)) GOTO 3580 CALL SENT(I, 8) 3580 CONTINUE 3160 CONTINUE 3140 CONTINUE 3150 CONTINUE RETURN END SUBROUTINE TORPI C C * FIRE TORPEDOES C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) BYTE CHAR CALL PERM(SHIPS, I1, I2) DO 3600 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(LAUNCH(I) .GE. 0.)) GOTO 3620 CALL MOVE(XCORD(I), YCORD(I), X1, Y1, LAUNCH(I), 10., CHAR, UN *IV, EMPTY) IX = X1 IY = Y1 KX = XCORD(I) KY = YCORD(I) C * MAKE SURE IT MOVED OUT OF THE FIRER'S SQUARE IF (.NOT.((KX .EQ. IX) .AND. (KY .EQ. IY))) GOTO 3640 CALL MOVE(X1, Y1, X, Y, LAUNCH(I), 10., CHAR, UNIV, EMPTY) GOTO 3650 3640 CONTINUE X = X1 Y = Y1 3650 CONTINUE IX = X IY = Y IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 3660 UNIV(IX, IY) = '+' IF (.NOT.(TDIR(I, IT(I)) .GE. 0.)) GOTO 3680 KX = TLOCS(I, IT(I), 1) KY = TLOCS(I, IT(I), 2) IF (.NOT.(UNIV(KX, KY) .EQ. '+')) GOTO 3700 UNIV(KX, KY) = EMPTY 3700 CONTINUE 3680 CONTINUE TLOCS(I, IT(I), 1) = X TLOCS(I, IT(I), 2) = Y TDIR(I, IT(I)) = LAUNCH(I) IT(I) = IT(I) + 1 IF (.NOT.(IT(I) .GT. 10)) GOTO 3720 IT(I) = 1 3720 CONTINUE GOTO 3670 3660 CONTINUE C * HIT SOMETHING CALL THIT(I, IX, IY, CHAR, LAUNCH(I), 500.) 3670 CONTINUE LAUNCH(I) = - 1. 3620 CONTINUE 3600 CONTINUE 3610 CONTINUE RETURN END SUBROUTINE DAMAGE(K, EN, D) C C * CALCULATE DAMAGE DONE C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON SABS = SHIELD(K)/1000. IF (.NOT.(SABS .GT. 1.)) GOTO 3740 SABS = 1. C C * CALCULATE FACTOR FOR DIRECTIONAL SHIELDING C 3740 CONTINUE IF (.NOT.(D .GT. 360.)) GOTO 3760 DEL = 180. GOTO 3770 3760 CONTINUE DEL = ABS(DIR(K) - D) IF (.NOT.(DEL .GT. 180.)) GOTO 3780 DEL = 360. - DEL 3780 CONTINUE 3770 CONTINUE SABS = SABS*(.5 + DEL/360.) ENERGY(K) = ENERGY(K) - (1.2 - SABS)*EN*6. SHIELD(K) = SHIELD(K) - SABS*EN IF (.NOT.(SHIELD(K) .LT. 0.)) GOTO 3800 SHIELD(K) = 0. 3800 CONTINUE RETURN END SUBROUTINE MOVE(XI, YI, XN, YN, D, W, CHAR, UNIV, EMPTY) C C * MOVE OBJECTS WITH WRAP AROUND C BYTE CHAR, EMPTY BYTE UNIV(100, 100) YN = YI + SIN(D/57.2592)/10.*W XN = XI + COS(D/57.2592)/10.*W IXI = XI IYI = YI IF (.NOT.(XN .GE. 101.)) GOTO 3820 XN = XN - 100. GOTO 3830 3820 CONTINUE IF (.NOT.(XN .LT. 1.)) GOTO 3840 XN = XN + 100. 3840 CONTINUE 3830 CONTINUE IF (.NOT.(YN .GE. 101.)) GOTO 3860 YN = YN - 100. GOTO 3870 3860 CONTINUE IF (.NOT.(YN .LT. 1.)) GOTO 3880 YN = YN + 100. 3880 CONTINUE 3870 CONTINUE IXN = XN IYN = YN IF (.NOT.((IXI .NE. IXN) .OR. (IYI .NE. IYN))) GOTO 3900 CHAR = UNIV(IXN, IYN) GOTO 3910 3900 CONTINUE C C * IF THEY DIDN'T MOVE OUT OF THE SQUARE THEY WERE IN JUST INDICATE C THAT THE PLACE THEY ENDED UP WAS EMPTY C CHAR = EMPTY 3910 CONTINUE RETURN END SUBROUTINE TFIND(I, IX, IY) C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON C C * FIND OUT WHO SHOULD GET THE CREDIT IF SOME ONE RUNS INTO A TORPEDO C DO 3920 I = 1, 8 DO 3940 K = 1, 10 IF (.NOT.(TDIR(I, K) .GE. 0.)) GOTO 3960 KX = TLOCS(I, K, 1) KY = TLOCS(I, K, 2) IF (.NOT.((IX .EQ. KX) .AND. (IY .EQ. KY))) GOTO 3980 GOTO 102 3980 CONTINUE 3960 CONTINUE 3940 CONTINUE 3950 CONTINUE DO 4000 K = 1, 4 IF (.NOT.(WHOM(I, K) .NE. 0)) GOTO 4020 KX = XHOM(I, K) KY = YHOM(I, K) IF (.NOT.((IX .EQ. KX) .AND. (IY .EQ. KY))) GOTO 4040 GOTO 102 4040 CONTINUE 4020 CONTINUE 4000 CONTINUE 4010 CONTINUE 3920 CONTINUE 3930 CONTINUE I = 0 102 RETURN END SUBROUTINE MTORPS C C * MOVE ALL ACTIVE TORPEDOES C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) BYTE CHAR CALL PERM(SHIPS, I1, I2) DO 4060 ISHP = 1, 8 I = SHIPS(ISHP) DO 4080 K = 1, 10 IX = TLOCS(I, K, 1) IY = TLOCS(I, K, 2) C C * MAKE SURE THE TORPEDO IS STILL THERE AND ACTIVE C IF (.NOT.((UNIV(IX, IY) .EQ. '+') .AND. (TDIR(I, K) .GE. 0.))) * GOTO 4100 CALL MOVE(TLOCS(I, K, 1), TLOCS(I, K, 2), X, Y, TDIR(I, K), *10., CHAR, UNIV, EMPTY) KX = X KY = Y IF (.NOT.(CHAR .NE. EMPTY)) GOTO 4120 CALL THIT(I, KX, KY, CHAR, TDIR(I, K), 500.) UNIV(IX, IY) = EMPTY TDIR(I, K) = - 1. GOTO 4130 4120 CONTINUE UNIV(IX, IY) = EMPTY UNIV(KX, KY) = '+' TLOCS(I, K, 1) = X TLOCS(I, K, 2) = Y 4130 CONTINUE GOTO 4110 4100 CONTINUE TDIR(I, K) = - 1. 4110 CONTINUE 4080 CONTINUE 4090 CONTINUE 4060 CONTINUE 4070 CONTINUE RETURN END SUBROUTINE SENT(I, NUM) C C * SEND MESSAGES TO THE PLAYERS C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON DO 4140 K = 1, 10 IF (.NOT.(ISENT(I, K) .EQ. 0)) GOTO 4160 ISENT(I, K) = NUM GOTO 202 4160 CONTINUE C * MESSAGE BUFFER IS FULL SO COPY IT UP TO KEEP MOST RECENT 4140 CONTINUE 4150 CONTINUE DO 4180 K = 1, 9 ISENT(I, K) = ISENT(I, K + 1) 4180 CONTINUE 4190 CONTINUE ISENT(I, 10) = NUM 202 RETURN END SUBROUTINE MHOMER C C MOVE HOMING TORPEDOES C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) BYTE CHAR C CALL PERM(SHIPS, I1, I2) DO 4200 ISHP = 1, 8 I = SHIPS(ISHP) DO 4220 II = 4, 1, - 1 C BACKWARDS SO THEY DON'T PILE UP ON EACH OTHER IF (.NOT.(WHOM(I, II) .EQ. 0)) GOTO 4240 CONTINUE GOTO 4250 4240 CONTINUE IF (.NOT.(WHOM(I, II) .LT. 0)) GOTO 4260 C C * LAUNCH C TWHOM = - WHOM(I, II) XH = XCORD(I) YH = YCORD(I) D = ATAN3((YCORD(TWHOM) - YH), (XCORD(TWHOM) - XH))*180./3 *.14159 CALL MOVE(XH, YH, X, Y, D, 10., CHAR, UNIV, EMPTY) KX = X KY = Y IX = XCORD(I) IY = YCORD(I) IF (.NOT.((IX .EQ. KX) .AND. (IY .EQ. KY))) GOTO 4280 CALL MOVE(X, Y, X1, Y1, D, 10., CHAR, UNIV, EMPTY) X = X1 Y = Y1 4280 CONTINUE KX = X KY = Y IF (.NOT.(CHAR .NE. EMPTY)) GOTO 4300 CALL THIT(I, KX, KY, CHAR, D, 300.) WHOM(I, II) = 0 GOTO 4310 4300 CONTINUE UNIV(KX, KY) = '^' XHOM(I, II) = X YHOM(I, II) = Y WHOM(I, II) = - WHOM(I, II) 4310 CONTINUE 4260 CONTINUE 4250 CONTINUE IF (.NOT.(WHOM(I, II) .GT. 0)) GOTO 4320 C C * CHECK TO SEE IF ACTIVE C IX = XHOM(I, II) IY = YHOM(I, II) IF (.NOT.(UNIV(IX, IY) .EQ. '^')) GOTO 4340 C C * CALCULATE COURSE C D = ATAN3((YCORD(WHOM(I, II)) - YHOM(I, II)), (XCORD(WHOM( *I, II)) - XHOM(I, II)))*180./3.14159 CALL MOVE(XHOM(I, II), YHOM(I, II), X, Y, D, 10., CHAR, UN *IV, EMPTY) KX = X KY = Y IF (.NOT.(CHAR .NE. EMPTY)) GOTO 4360 CALL THIT(I, KX, KY, CHAR, D, 300.) UNIV(IX, IY) = EMPTY WHOM(I, II) = 0 GOTO 4370 4360 CONTINUE UNIV(IX, IY) = EMPTY UNIV(KX, KY) = '^' XHOM(I, II) = X YHOM(I, II) = Y 4370 CONTINUE GOTO 4350 4340 CONTINUE WHOM(I, II) = 0 4350 CONTINUE 4320 CONTINUE 4220 CONTINUE 4230 CONTINUE 4200 CONTINUE 4210 CONTINUE RETURN END SUBROUTINE MHOLE C C * MOVE THE "BLACK HOLE" TOWARD THE NEAREST ACTIVE SHIP C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON BYTE CHAR C C * FIND CLOSEST SHIP C DM = 1.6E37 K = 0 DO 4380 I = 1, 8 IF (.NOT.(XSHIP(I))) GOTO 4400 D = ((HX - XCORD(I))**2 + (HY - YCORD(I))**2)**.5 IF (.NOT.(D .LT. DM)) GOTO 4420 DM = D K = I 4420 CONTINUE 4400 CONTINUE C C *FIND DIRECTION OF CLOSEST SHIP C 4380 CONTINUE 4390 CONTINUE IF (.NOT.(K .NE. 0)) GOTO 4440 D = ATAN3((YCORD(K) - HY), (XCORD(K) - HX))*180./3.14159 C CALL MOVE(HX, HY, X, Y, D, HW, CHAR, UNIV, EMPTY) IF (.NOT.((CHAR .EQ. EMPTY) .OR. (CHAR .EQ. '+') .OR. (CHAR .EQ. * '@') .OR. (CHAR .EQ. '^'))) GOTO 4460 C * JUST MUNCH THIS JUNK DOWN IX = HX IY = HY UNIV(IX, IY) = EMPTY IX = X IY = Y UNIV(IX, IY) = BHOLE HX = X HY = Y GOTO 4470 4460 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 4480 C * CAUGHT A SHIP I = CHAR - 48 IF (.NOT.(XSHIP(I))) GOTO 4500 CALL SENT(I, 15) CALL RESET(I) 4500 CONTINUE GOTO 4490 4480 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 4520 C * CAN'T EAT ENERGY NET! GOTO 4530 4520 CONTINUE C * SWAP PLACES WITH BASES STARS ETC. IX = HX IY = HY UNIV(IX, IY) = CHAR HX = X HY = Y IX = HX IY = HY UNIV(IX, IY) = BHOLE 4530 CONTINUE 4490 CONTINUE 4470 CONTINUE 4440 CONTINUE RETURN END SUBROUTINE MANTI C C * DEAL WITH ANTI-MATTER C C C MOVE ANTI-MATTER PODS C C TEXT COMMON COMMON/TORPE/TLOCS(8, 10, 2), TDIR(8, 10), IT(8) COMMON/LEDFOR/ENERGY(8), SHIELD(8), XCORD(8), YCORD(8), TORPS(8), *HX, HY, HW, CDRAIN, NDRAIN, SCAN(8), PHA(8), I1, I2, HYPER(8), ISE *NT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XHOM(8, 4) *, YHOM(8, 4), WHOM(8, 4), NHOM(8), SCORE(8), CREW(8), DIR(8), WARP *(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), THRU, XSHIP(8), CLOAK *(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS LOGICAL*1THRU, XSHIP, CLOAK, NET C NOTE: BHOLE AND EMPTY ARE THE CHARACTERS FOR THE BLACK HOLE C AND EMPTY SPACE AND ARE SET IN MTREKINI. BYTE UNIV, MESSAG, BHOLE, EMPTY C END COMMON COMMON/DOLOOP/SHIPS INTEGER SHIPS(8) BYTE CHAR INTEGER IPX(21), IPY(21) C C * THE FOLLOWING DATA DESCIBES THE EXPLOSION PATTERN FOR C ANTI-MATTER PODS C DATA IPX/ - 3, - 2, - 2, - 2, - 1, - 1, - 1, 0, 0, 0, 0, 0, *0, 1, 1, 1, 2, 2, 2, 3, 0/ DATA IPY/0, 2, 0, - 2, 1, 0, - 1, 3, 2, 1, - 1, - 2, - 3, 1, *0, - 1, 2, 0, - 2, 0, 0/ CALL PERM(SHIPS, I1, I2) DO 4540 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(IPOD(I) .EQ. 1)) GOTO 4560 C * LAUNCH POD CALL MOVE(XCORD(I), YCORD(I), X1, Y1, DPOD(I), 10., CHAR, UNIV *, EMPTY) IX = X1 IY = Y1 KX = XCORD(I) KY = YCORD(I) C * MAKE SURE IT CLEARS THE SHIP IF (.NOT.((KX .EQ. IX) .AND. (KY .EQ. IY))) GOTO 4580 CALL MOVE(X1, Y1, X, Y, DPOD(I), 10., CHAR, UNIV, EMPTY) GOTO 4590 4580 CONTINUE X = X1 Y = Y1 4590 CONTINUE IX = X IY = Y IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 4600 C * SUCCESSUL LAUNCH UNIV(IX, IY) = '@' XPOD(I) = X YPOD(I) = Y IPOD(I) = 2 WPOD(I) = 5. CALL SENT(I, 28) GOTO 4610 4600 CONTINUE CALL SENT(I, 23) IPOD(I) = 0 4610 CONTINUE 4560 CONTINUE IF (.NOT.(IPOD(I) .EQ. 2)) GOTO 4620 C * POD IS ON THE MOVE IX = XPOD(I) IY = YPOD(I) IF (.NOT.(UNIV(IX, IY) .EQ. '@')) GOTO 4640 CALL MOVE(XPOD(I), YPOD(I), X, Y, DPOD(I), WPOD(I), CHAR, UN *IV, EMPTY) IF (.NOT.((CHAR .EQ. EMPTY) .OR. (CHAR .EQ. '+') .OR. (CHAR *.EQ. '^'))) GOTO 4660 UNIV(IX, IY) = EMPTY IX = X IY = Y UNIV(IX, IY) = '@' XPOD(I) = X YPOD(I) = Y GOTO 4670 4660 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 4680 IF (.NOT.(HYPER(I) .EQ. 1)) GOTO 4700 KX = 20 KY = 75 GOTO 4710 4700 CONTINUE IF (.NOT.(HYPER(I) .EQ. 2)) GOTO 4720 KX = 50 KY = 70 GOTO 4730 4720 CONTINUE IF (.NOT.(HYPER(I) .EQ. 3)) GOTO 4740 KX = 80 KY = 75 GOTO 4750 4740 CONTINUE IF (.NOT.(HYPER(I) .EQ. 4)) GOTO 4760 KX = 20 KY = 25 GOTO 4770 4760 CONTINUE IF (.NOT.(HYPER(I) .EQ. 5)) GOTO 4780 KX = 50 KY = 30 GOTO 4790 4780 CONTINUE IF (.NOT.(HYPER(I) .EQ. 6)) GOTO 4800 KX = 80 KY = 25 GOTO 4810 4800 CONTINUE STOP 52 4810 CONTINUE 4790 CONTINUE 4770 CONTINUE 4750 CONTINUE 4730 CONTINUE 4710 CONTINUE DO 4820 II = (KX - 1), (KX + 1) DO 4840 IJ = (KY - 1), (KY + 1) IF (.NOT.(UNIV(II, IJ) .EQ. EMPTY)) GOTO 4860 UNIV(II, IJ) = '@' UNIV(IX, IY) = EMPTY XPOD(I) = II YPOD(I) = IJ XPOD(I) = XPOD(I) + .5 YPOD(I) = YPOD(I) + .5 IPOD(I) = 3 GOTO 4830 4860 CONTINUE 4840 CONTINUE 4850 CONTINUE 4820 CONTINUE 4830 CONTINUE GOTO 4690 4680 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 4880 4900 CONTINUE KX = RAN(I1, I2)*100. + 1. KY = RAN(I1, I2)*100. + 1. 4910 IF (.NOT.(UNIV(KX, KY) .EQ. EMPTY)) GOTO 4900 4920 CONTINUE XPOD(I) = KX YPOD(I) = KY XPOD(I) = XPOD(I) + .5 YPOD(I) = YPOD(I) + .5 UNIV(IX, IY) = EMPTY UNIV(KX, KY) = '@' IPOD(I) = 3 GOTO 4890 4880 CONTINUE IF (.NOT.(RAN(I1, I2) .GT. .5)) GOTO 4930 DPOD(I) = DPOD(I) + 90. GOTO 4940 4930 CONTINUE DPOD(I) = DPOD(I) - 90. 4940 CONTINUE 4890 CONTINUE 4690 CONTINUE 4670 CONTINUE GOTO 4650 4640 CONTINUE CALL SENT(I, 24) IPOD(I) = 4 4650 CONTINUE 4620 CONTINUE IF (.NOT.(IPOD(I) .EQ. 3)) GOTO 4950 C * DETONATE POD IX = XPOD(I) IY = YPOD(I) IF (.NOT.(UNIV(IX, IY) .EQ. '@')) GOTO 4970 IPOD(I) = 4 CALL SENT(I, 29) DO 4990 L1 = 1, 21 KX = IX + IPX(L1) IF (.NOT.(KX .GE. 101)) GOTO 5010 KX = KX - 100 5010 CONTINUE IF (.NOT.(KX .LT. 1)) GOTO 5030 KX = KX + 100 5030 CONTINUE KY = IY + IPY(L1) IF (.NOT.(KY .GE. 101)) GOTO 5050 KY = KY - 100 5050 CONTINUE IF (.NOT.(KY .LT. 1)) GOTO 5070 KY = KY + 100 5070 CONTINUE CHAR = UNIV(KX, KY) IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 509 *0 CONTINUE C GOTO 5100 5090 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 5110 CONTINUE C GOTO 5120 5110 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 5130 CONTINUE C GOTO 5140 5130 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 5150 CALL SENT(I, 31) C$ SCORE(I)=SCORE(I)+1000. UNIV(KX, KY) = EMPTY 5170 CONTINUE IIX = RAN(I1, I2)*100. + 1. IIY = RAN(I1, I2)*100. + 1. 5180 IF (.NOT.(UNIV(IIX, IIY) .EQ. EMPTY)) GOTO 5170 5190 CONTINUE HX = IIX HY = IIY UNIV(IIX, IIY) = BHOLE GOTO 5160 5150 CONTINUE UNIV(KX, KY) = EMPTY 5160 CONTINUE 5140 CONTINUE 5120 CONTINUE 5100 CONTINUE C C * FIGURE SHIP DAMAGE C 4990 CONTINUE 5000 CONTINUE DO 5200 IZ = 1, 8 C$ D=((XCORD(IZ)-XPOD(I))**2 + (YCORD(IZ)-YPOD(I))**2 ) **.5 D = DSTNCE(XCORD(IZ), YCORD(IZ), XPOD(I), YPOD(I)) IF (.NOT.(D .LE. 4)) GOTO 5220 IS = 7. - D E = 1500. - D*300. IF (.NOT.(XSHIP(IZ))) GOTO 5240 CALL SENT(IZ, 30) CALL DAMAGE(IZ, E, 500.) SCAN(IZ) = SCAN(IZ) - IS IF (.NOT.(SCAN(IZ) .LT. 0)) GOTO 5260 SCAN(IZ) = 0 5260 CONTINUE IF (.NOT.(ENERGY(IZ) .LE. 0.)) GOTO 5280 IF (.NOT.(I .NE. IZ)) GOTO 5300 CALL SENT(I, 22) C$ SCORE(I)=SCORE(I)+2000. 5300 CONTINUE CALL RESET(IZ) 5280 CONTINUE IF (.NOT.(I .NE. IZ)) GOTO 5320 SCORE(I) = SCORE(I) + E CALL SENT(I, 32) 5320 CONTINUE GOTO 5250 5240 CONTINUE CALL SENT(I, 21) 5250 CONTINUE 5220 CONTINUE 5200 CONTINUE 5210 CONTINUE GOTO 4980 4970 CONTINUE CALL SENT(I, 24) IPOD(I) = 4 4980 CONTINUE GOTO 4960 4950 CONTINUE CONTINUE 4960 CONTINUE 4540 CONTINUE 4550 CONTINUE RETURN END REAL FUNCTION DSTNCE(XX, YY, X1, Y1) REAL D1(4) IF (.NOT.(X1 .LT. 51.)) GOTO 5340 X2 = X1 + 100. GOTO 5350 5340 CONTINUE X2 = X1 - 100. 5350 CONTINUE IF (.NOT.(Y1 .LT. 51.)) GOTO 5360 Y2 = Y1 + 100. GOTO 5370 5360 CONTINUE Y2 = Y1 - 100. 5370 CONTINUE D1(1) = SQRT((XX - X1)**2 + (YY - Y1)**2) D1(2) = SQRT((XX - X1)**2 + (YY - Y2)**2) D1(3) = SQRT((XX - X2)**2 + (YY - Y1)**2) D1(4) = SQRT((XX - X2)**2 + (YY - Y2)**2) DSTNCE = D1(1) DO 5380 J = 2, 4 IF (.NOT.(D1(J) .LT. DSTNCE)) GOTO 5400 DSTNCE = D1(J) 5400 CONTINUE 5380 CONTINUE 5390 CONTINUE RETURN END SUBROUTINE PERM(SHIPS, I1, I2) C C PERM - SHUFFLE SHIPS C C DUE TO L. E. MOSES AND R. V. OAKFORD, AND C R. DURSTENFELD C TAKEN FROM KNUTH VOL 2, SEMINUMERICAL ALGORITHMS, P. 125 C INTEGER SHIPS(8), J, K, I1, I2, TMP DO 5420 J = 8, 2, - 1 K = IFIX(FLOAT(J)*RAN(I1, I2)) + 1 TMP = SHIPS(K) SHIPS(K) = SHIPS(J) SHIPS(J) = TMP 5420 CONTINUE 5430 CONTINUE RETURN END