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 DEC 1980 BILL WOOD ADDED TRACTOR BEAMS 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 TRUDIR = DIR(I) TRUWRP = WARP(I) IF (.NOT.(TRBEAM(I) .NE. 0 .AND. XSHIP(TRBEAM(I)))) GOTO 2190 ENERGY(I) = ENERGY(I) - TDRAIN C$ CALL DIRDIS(XCORD(I),YCORD(I), C$ XCORD(TRBEAM(I)),YCORD(TRBEAM(I)),TDIR,TDIS) C$ CALL POLADD(TRUDIR, TRUWRP, TDIR, 4./SQRT(AMAX1(1., TDIS-4.)), C$ TRUDIR, TRUWRP) 2190 CONTINUE DO 2210 ITRAC = 1, 8 IF (.NOT.(XSHIP(ITRAC) .AND. TRBEAM(ITRAC) .EQ. I .AND. ITRA *C .NE. I)) GOTO 2230 CALL DIRDIS(XCORD(I), YCORD(I), XCORD(ITRAC), YCORD(ITRAC) *, TDIR, TDIS) CALL POLADD(TRUDIR, TRUWRP, TDIR, 8./SQRT(AMAX1(1., TDIS - * 6.)), TRUDIR, TRUWRP) 2230 CONTINUE 2210 CONTINUE 2220 CONTINUE IF (.NOT.(TRUWRP .GT. 10.)) GOTO 2250 TRUWRP = 10. 2250 CONTINUE IX = XCORD(I) IY = YCORD(I) CALL MOVE(XCORD(I), YCORD(I), X, Y, TRUDIR, TRUWRP, CHAR, UNIV *, EMPTY) KX = X KY = Y IF (.NOT.(CHAR .LE. '8' .AND. CHAR .GE. '1')) GOTO 2270 C * WE HAVE RAMMED A SHIP K = CHAR - 48 ENERGY(I) = ENERGY(I) - 100. IF (.NOT.(XSHIP(K))) GOTO 2290 ENERGY(K) = ENERGY(K) - 100. CALL SENT(K, 10) 2290 CONTINUE WARP(I) = 0. WARP(K) = 0. CALL SENT(I, 9) C GOTO 2280 2270 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 2310 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 2330 II = 1, 4 WHOM(I, II) = 0 2330 CONTINUE 2340 CONTINUE TRBEAM(I) = 0 C GOTO 2320 2310 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 2350 C * HIT A STAR CALL SENT(I, 2) ENERGY(I) = ENERGY(I) - 200. WARP(I) = 0. C GOTO 2360 2350 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 23 *70 C * HIT A TORPEDO CALL SENT(I, 4) IF (.NOT.(CHAR .EQ. '^')) GOTO 2390 V = 300. GOTO 2400 2390 CONTINUE V = 500. 2400 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 2410 CALL SENT(K, 5) SCORE(K) = SCORE(K) + V IF (.NOT.(ENERGY(I) .LE. 0)) GOTO 2430 CALL SENT(K, 22) C$ SCORE(K)=SCORE(K)+2000. 2430 CONTINUE 2410 CONTINUE IF (.NOT.(ENERGY(I) .LE. 0)) GOTO 2450 CALL RESET(I) C 2450 CONTINUE GOTO 2380 2370 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 2470 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 2490 II = (KX - 1), (KX + 1) DO 2510 IJ = (KY - 1), (KY + 1) IF (.NOT.(UNIV(II, IJ) .EQ. EMPTY)) GOTO 2530 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 2530 CONTINUE 2510 CONTINUE 2520 CONTINUE C * IF WE ARE HERE WE DIDN'T FIND AN EMPTY SPOT ( VERY UNLIKELY) 2490 CONTINUE 2500 CONTINUE CALL SENT(I, 18) 102 WARP(I) = 0. C GOTO 2480 2470 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 2550 C * RUN INTO THE "BLACK HOLE" ( NICE FLYING) 20 CONTINUE CALL SENT(I, 15) CALL RESET(I) C GOTO 2560 2550 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 2570 C * HIT A RANDOM HYPERSPACE PORT 30 CONTINUE CALL SENT(I, 19) C * FIND A NEW EMPTY LOCATION 2590 CONTINUE KX = RAN(I1, I2)*100. + 1. KY = RAN(I1, I2)*100. + 1. 2600 IF (.NOT.(UNIV(KX, KY) .EQ. EMPTY)) GOTO 2590 2610 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 2580 2570 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 2620 C * BUMPED INTO AN ANTI-MATTER POD CALL SENT(I, 27) CALL DAMAGE(I, 250., 500.) GOTO 2630 2620 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 2640 C * BUMPED INTO ENERGY NET ENERGY(I) = ENERGY(I) - 200 IF (.NOT.(CHAR .EQ. -I)) GOTO 2660 2680 CONTINUE X2 = X Y2 = Y CALL MOVE(X2, Y2, X, Y, TRUDIR, 8., CHAR *, UNIV, EMPTY) 2690 IF (.NOT.(UNIV(IFIX(X), IFIX(Y)) .NE. -I *)) GOTO 2680 2700 CONTINUE KX = X KY = Y CHAR = UNIV(KX, KY) IF (.NOT.(CHAR .EQ. 'H')) GOTO 2710 GOTO 10 2710 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 2730 GOTO 20 2730 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 2750 GOTO 30 2750 CONTINUE IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 2770 XCORD(I) = X YCORD(I) = Y UNIV(IX, IY) = TRAIL UNIV(KX, KY) = SHIP GOTO 2780 2770 CONTINUE CALL SENT(I, 36) WARP(I) = 0. 2780 CONTINUE GOTO 2670 2660 CONTINUE CALL SENT(I, 33) DIR(I) = TRUDIR - 180. IF (.NOT.(DIR(I) .LT. 0.)) GOTO 2790 DIR(I) = DIR(I) + 360. 2790 CONTINUE 2670 CONTINUE GOTO 2650 2640 CONTINUE XCORD(I) = X YCORD(I) = Y IF (.NOT.(UNIV(IX, IY) .NE. -I)) GOTO 2810 UNIV(IX, IY) = TRAIL 2810 CONTINUE UNIV(KX, KY) = SHIP 2650 CONTINUE 2630 CONTINUE 2580 CONTINUE 2560 CONTINUE 2480 CONTINUE 2380 CONTINUE 2360 CONTINUE 2320 CONTINUE 2280 CONTINUE IF (.NOT.(ENERGY(I) .LE. 0.)) GOTO 2830 CALL SENT(I, 16) CALL RESET(I) 2830 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 2850 I = 1, 4 WHOM(K, I) = 0 2850 CONTINUE 2860 CONTINUE CLOAK(K) = .FALSE. NET(K) = .FALSE. TRBEAM(K) = 0 DO 2870 I = 1, 8 IF (.NOT.(TRBEAM(I) .EQ. K)) GOTO 2890 TRBEAM(I) = 0 2890 CONTINUE 2870 CONTINUE 2880 CONTINUE IF (.NOT.(ACCUME)) GOTO 2910 SCORE(K) = SCORE(K) - 1000. GOTO 2920 2910 CONTINUE SCORE(K) = 0. 2920 CONTINUE CALL SENT(K, 3) KX = XCORD(K) KY = YCORD(K) UNIV(KX, KY) = EMPTY DO 2930 I = 1, 100 DO 2950 J = 1, 100 IF (.NOT.(UNIV(J, I) .EQ. -K)) GOTO 2970 UNIV(J, I) = EMPTY 2970 CONTINUE 2950 CONTINUE 2960 CONTINUE 2930 CONTINUE 2940 CONTINUE 2990 CONTINUE IX = RAN(I1, I2)*100. + 1. IY = RAN(I1, I2)*100. + 1. 3000 IF (.NOT.(UNIV(IX, IY) .EQ. EMPTY)) GOTO 2990 3010 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 3020 C * TORPEDO HIT ON HYPER SPACE PORT CONTINUE C GOTO 3030 3020 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 3040 C * TORPEDO HIT ON SHIP K = CHAR - 48 IF (.NOT.(XSHIP(K))) GOTO 3060 CALL DAMAGE(K, E, D) IF (.NOT.(K .NE. I)) GOTO 3080 SCORE(I) = SCORE(I) + E CALL SENT(I, 5) IF (.NOT.(ENERGY(K) .LE. 0)) GOTO 3100 CALL SENT(I, 22) C$ SCORE(I)=SCORE(I)+2000. 3100 CONTINUE 3080 CONTINUE CALL SENT(K, 4) IF (.NOT.(ENERGY(K) .LE. 0.)) GOTO 3120 CALL RESET(K) 3120 CONTINUE GOTO 3070 3060 CONTINUE CALL SENT(I, 21) 3070 CONTINUE GOTO 3050 3040 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 3140 C * TORPEDO HIT ON BLACK HOLE - THE HOLE PREVAILS! GOTO 3150 3140 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3160 C * TORPEDO HIT ON STAR CALL SENT(I, 13) C GOTO 3170 3160 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 3180 C * TORPEDO HIT ON BASE CALL SENT(I, 12) SCORE(I) = SCORE(I) - 200. C GOTO 3190 3180 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 32 *00 C * TORPEDO HIT ON TORPEDO CALL SENT(I, 20) UNIV(IX, IY) = EMPTY C GOTO 3210 3200 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3220 C * TORPEDO HIT ON ANTI-MATTER POD CALL SENT(I, 26) UNIV(IX, IY) = EMPTY GOTO 3230 3220 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3240 C * TORPEDO HIT ON ENERGY NET CALL SENT(I, 34) UNIV(IX, IY) = EMPTY GOTO 3250 3240 CONTINUE C * ANYTHING ELSE GETS DESTROYED UNIV(IX, IY) = EMPTY 3250 CONTINUE 3230 CONTINUE 3210 CONTINUE 3190 CONTINUE 3170 CONTINUE 3150 CONTINUE 3050 CONTINUE 3030 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 3260 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(PHA(I) .GE. 0.)) GOTO 3280 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 3300 DX(1) = DX(2) - 1. DX(3) = DX(2) + 1. DY(1) = DY(2) DY(3) = DY(2) GOTO 3310 3300 CONTINUE DX(1) = DX(2) DX(3) = DX(2) DY(1) = DY(2) - 1. DY(3) = DY(2) + 1. 3310 CONTINUE DO 3320 IZ = 1, 3, 2 IF (.NOT.(DX(IZ) .GE. 101.)) GOTO 3340 DX(IZ) = DX(IZ) - 100. GOTO 3350 3340 CONTINUE IF (.NOT.(DX(IZ) .LT. 1.)) GOTO 3360 DX(IZ) = DX(IZ) + 100. 3360 CONTINUE 3350 CONTINUE IF (.NOT.(DY(IZ) .GE. 101.)) GOTO 3380 DY(IZ) = DY(IZ) - 100. GOTO 3390 3380 CONTINUE IF (.NOT.(DY(IZ) .LT. 1.)) GOTO 3400 DY(IZ) = DY(IZ) + 100. 3400 CONTINUE 3390 CONTINUE 3320 CONTINUE 3330 CONTINUE KX = XCORD(I) KY = YCORD(I) NMISS = 0 DO 3420 IZ = 1, 3 X1 = DX(IZ) Y1 = DY(IZ) DO 3440 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 3460 GOTO 3450 3460 CONTINUE X1 = X Y1 = Y 3470 CONTINUE 3440 CONTINUE 3450 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 3480 C * HIT ON SHIP K = CHAR - 48 IF (.NOT.(XSHIP(K))) GOTO 3500 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 3520 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 3540 C$ SCORE(I)=SCORE(I)+2000. CALL SENT(I, 22) CALL RESET(K) 3540 CONTINUE 3520 CONTINUE GOTO 3510 3500 CONTINUE CALL SENT(I, 21) C 3510 CONTINUE GOTO 3490 3480 CONTINUE IF (.NOT.((CHAR .EQ. '+'))) GOTO 3560 C * PHASER HIT ON TORPEDO CALL SENT(I, 7) C GOTO 3570 3560 CONTINUE IF (.NOT.((CHAR .EQ. '^'))) GOTO 3580 C * PHASER HIT ON SEEKER CALL SENT(I, 7) IF (.NOT.(RAN(I1, I2) .GT. .5)) GOTO 3600 UNIV(IX, IY) = EMPTY C 3600 CONTINUE GOTO 3590 3580 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3620 C * PHASER HIT ON STAR CALL SENT(I, 11) C GOTO 3630 3620 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 3640 C * PHASER HIT ON BASE CALL SENT(I, 12) C GOTO 3650 3640 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3660 C * PHASER HIT ON ANTI-MATTER POD CALL SENT(I, 25) GOTO 3670 3660 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3680 C * PHASER HIT ON ENERGY NET CALL SENT(I, 35) GOTO 3690 3680 CONTINUE C * MISSED C$ CALL SENT(I,8) NMISS = NMISS + 1 3690 CONTINUE 3670 CONTINUE 3650 CONTINUE 3630 CONTINUE 3590 CONTINUE 3570 CONTINUE 3490 CONTINUE 3420 CONTINUE 3430 CONTINUE PHA(I) = - 1. IF (.NOT.(NMISS .EQ. 3)) GOTO 3700 CALL SENT(I, 8) 3700 CONTINUE 3280 CONTINUE 3260 CONTINUE 3270 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 3720 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(LAUNCH(I) .GE. 0.)) GOTO 3740 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 3760 CALL MOVE(X1, Y1, X, Y, LAUNCH(I), 10., CHAR, UNIV, EMPTY) GOTO 3770 3760 CONTINUE X = X1 Y = Y1 3770 CONTINUE IX = X IY = Y IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 3780 UNIV(IX, IY) = '+' IF (.NOT.(TDIR(I, IT(I)) .GE. 0.)) GOTO 3800 KX = TLOCS(I, IT(I), 1) KY = TLOCS(I, IT(I), 2) IF (.NOT.(UNIV(KX, KY) .EQ. '+')) GOTO 3820 UNIV(KX, KY) = EMPTY 3820 CONTINUE 3800 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 3840 IT(I) = 1 3840 CONTINUE GOTO 3790 3780 CONTINUE C * HIT SOMETHING CALL THIT(I, IX, IY, CHAR, LAUNCH(I), 500.) 3790 CONTINUE LAUNCH(I) = - 1. 3740 CONTINUE 3720 CONTINUE 3730 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 3860 SABS = 1. C C * CALCULATE FACTOR FOR DIRECTIONAL SHIELDING C 3860 CONTINUE IF (.NOT.(D .GT. 360.)) GOTO 3880 DEL = 180. GOTO 3890 3880 CONTINUE DEL = ABS(DIR(K) - D) IF (.NOT.(DEL .GT. 180.)) GOTO 3900 DEL = 360. - DEL 3900 CONTINUE 3890 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 3920 SHIELD(K) = 0. 3920 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.29577951)/10.*W XN = XI + COS(D/57.29577951)/10.*W IXI = XI IYI = YI IF (.NOT.(XN .GE. 101.)) GOTO 3940 XN = XN - 100. GOTO 3950 3940 CONTINUE IF (.NOT.(XN .LT. 1.)) GOTO 3960 XN = XN + 100. 3960 CONTINUE 3950 CONTINUE IF (.NOT.(YN .GE. 101.)) GOTO 3980 YN = YN - 100. GOTO 3990 3980 CONTINUE IF (.NOT.(YN .LT. 1.)) GOTO 4000 YN = YN + 100. 4000 CONTINUE 3990 CONTINUE IXN = XN IYN = YN IF (.NOT.((IXI .NE. IXN) .OR. (IYI .NE. IYN))) GOTO 4020 CHAR = UNIV(IXN, IYN) GOTO 4030 4020 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 4030 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4040 I = 1, 8 DO 4060 K = 1, 10 IF (.NOT.(TDIR(I, K) .GE. 0.)) GOTO 4080 KX = TLOCS(I, K, 1) KY = TLOCS(I, K, 2) IF (.NOT.((IX .EQ. KX) .AND. (IY .EQ. KY))) GOTO 4100 GOTO 102 4100 CONTINUE 4080 CONTINUE 4060 CONTINUE 4070 CONTINUE DO 4120 K = 1, 4 IF (.NOT.(WHOM(I, K) .NE. 0)) GOTO 4140 KX = XHOM(I, K) KY = YHOM(I, K) IF (.NOT.((IX .EQ. KX) .AND. (IY .EQ. KY))) GOTO 4160 GOTO 102 4160 CONTINUE 4140 CONTINUE 4120 CONTINUE 4130 CONTINUE 4040 CONTINUE 4050 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4180 ISHP = 1, 8 I = SHIPS(ISHP) DO 4200 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 4220 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 4240 CALL THIT(I, KX, KY, CHAR, TDIR(I, K), 500.) UNIV(IX, IY) = EMPTY TDIR(I, K) = - 1. GOTO 4250 4240 CONTINUE UNIV(IX, IY) = EMPTY UNIV(KX, KY) = '+' TLOCS(I, K, 1) = X TLOCS(I, K, 2) = Y 4250 CONTINUE GOTO 4230 4220 CONTINUE TDIR(I, K) = - 1. 4230 CONTINUE 4200 CONTINUE 4210 CONTINUE 4180 CONTINUE 4190 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4260 K = 1, 10 IF (.NOT.(ISENT(I, K) .EQ. 0)) GOTO 4280 ISENT(I, K) = NUM GOTO 202 4280 CONTINUE C * MESSAGE BUFFER IS FULL SO COPY IT UP TO KEEP MOST RECENT 4260 CONTINUE 4270 CONTINUE DO 4300 K = 1, 9 ISENT(I, K) = ISENT(I, K + 1) 4300 CONTINUE 4310 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4320 ISHP = 1, 8 I = SHIPS(ISHP) DO 4340 II = 4, 1, - 1 C BACKWARDS SO THEY DON'T PILE UP ON EACH OTHER IF (.NOT.(WHOM(I, II) .EQ. 0)) GOTO 4360 CONTINUE GOTO 4370 4360 CONTINUE IF (.NOT.(WHOM(I, II) .LT. 0)) GOTO 4380 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 4400 CALL MOVE(X, Y, X1, Y1, D, 10., CHAR, UNIV, EMPTY) X = X1 Y = Y1 4400 CONTINUE KX = X KY = Y IF (.NOT.(CHAR .NE. EMPTY)) GOTO 4420 CALL THIT(I, KX, KY, CHAR, D, 300.) WHOM(I, II) = 0 GOTO 4430 4420 CONTINUE UNIV(KX, KY) = '^' XHOM(I, II) = X YHOM(I, II) = Y WHOM(I, II) = - WHOM(I, II) 4430 CONTINUE 4380 CONTINUE 4370 CONTINUE IF (.NOT.(WHOM(I, II) .GT. 0)) GOTO 4440 C C * CHECK TO SEE IF ACTIVE C IX = XHOM(I, II) IY = YHOM(I, II) IF (.NOT.(UNIV(IX, IY) .EQ. '^')) GOTO 4460 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 4480 CALL THIT(I, KX, KY, CHAR, D, 300.) UNIV(IX, IY) = EMPTY WHOM(I, II) = 0 GOTO 4490 4480 CONTINUE UNIV(IX, IY) = EMPTY UNIV(KX, KY) = '^' XHOM(I, II) = X YHOM(I, II) = Y 4490 CONTINUE GOTO 4470 4460 CONTINUE WHOM(I, II) = 0 4470 CONTINUE 4440 CONTINUE 4340 CONTINUE 4350 CONTINUE 4320 CONTINUE 4330 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4500 I = 1, 8 IF (.NOT.(XSHIP(I))) GOTO 4520 D = ((HX - XCORD(I))**2 + (HY - YCORD(I))**2)**.5 IF (.NOT.(D .LT. DM)) GOTO 4540 DM = D K = I 4540 CONTINUE 4520 CONTINUE C C *FIND DIRECTION OF CLOSEST SHIP C 4500 CONTINUE 4510 CONTINUE IF (.NOT.(K .NE. 0)) GOTO 4560 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 4580 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 4590 4580 CONTINUE IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 4600 C * CAUGHT A SHIP I = CHAR - 48 IF (.NOT.(XSHIP(I))) GOTO 4620 CALL SENT(I, 15) CALL RESET(I) 4620 CONTINUE GOTO 4610 4600 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 4640 C * CAN'T EAT ENERGY NET! GOTO 4650 4640 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 4650 CONTINUE 4610 CONTINUE 4590 CONTINUE 4560 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, TDRAIN, SCAN(8), PHA(8), I1, I2, HYPER *(8), ISENT(8, 10), XPOD(8), YPOD(8), DPOD(8), IPOD(8), WPOD(8), XH *OM(8, 4), YHOM(8, 4), WHOM(8, 4), NHOM(8), TRBEAM(8), SCORE(8), CR *EW(8), DIR(8), WARP(8), LAUNCH(8), UNIV(100, 100), MESSAG(480), TH *RU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM 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 4660 ISHP = 1, 8 I = SHIPS(ISHP) IF (.NOT.(IPOD(I) .EQ. 1)) GOTO 4680 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 4700 CALL MOVE(X1, Y1, X, Y, DPOD(I), 10., CHAR, UNIV, EMPTY) GOTO 4710 4700 CONTINUE X = X1 Y = Y1 4710 CONTINUE IX = X IY = Y IF (.NOT.(CHAR .EQ. EMPTY)) GOTO 4720 C * SUCCESSUL LAUNCH UNIV(IX, IY) = '@' XPOD(I) = X YPOD(I) = Y IPOD(I) = 2 WPOD(I) = 5. CALL SENT(I, 28) GOTO 4730 4720 CONTINUE CALL SENT(I, 23) IPOD(I) = 0 4730 CONTINUE 4680 CONTINUE IF (.NOT.(IPOD(I) .EQ. 2)) GOTO 4740 C * POD IS ON THE MOVE IX = XPOD(I) IY = YPOD(I) IF (.NOT.(UNIV(IX, IY) .EQ. '@')) GOTO 4760 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 4780 UNIV(IX, IY) = EMPTY IX = X IY = Y UNIV(IX, IY) = '@' XPOD(I) = X YPOD(I) = Y GOTO 4790 4780 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 4800 IF (.NOT.(HYPER(I) .EQ. 1)) GOTO 4820 KX = 20 KY = 75 GOTO 4830 4820 CONTINUE IF (.NOT.(HYPER(I) .EQ. 2)) GOTO 4840 KX = 50 KY = 70 GOTO 4850 4840 CONTINUE IF (.NOT.(HYPER(I) .EQ. 3)) GOTO 4860 KX = 80 KY = 75 GOTO 4870 4860 CONTINUE IF (.NOT.(HYPER(I) .EQ. 4)) GOTO 4880 KX = 20 KY = 25 GOTO 4890 4880 CONTINUE IF (.NOT.(HYPER(I) .EQ. 5)) GOTO 4900 KX = 50 KY = 30 GOTO 4910 4900 CONTINUE IF (.NOT.(HYPER(I) .EQ. 6)) GOTO 4920 KX = 80 KY = 25 GOTO 4930 4920 CONTINUE STOP 52 4930 CONTINUE 4910 CONTINUE 4890 CONTINUE 4870 CONTINUE 4850 CONTINUE 4830 CONTINUE DO 4940 II = (KX - 1), (KX + 1) DO 4960 IJ = (KY - 1), (KY + 1) IF (.NOT.(UNIV(II, IJ) .EQ. EMPTY)) GOTO 4980 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 4950 4980 CONTINUE 4960 CONTINUE 4970 CONTINUE 4940 CONTINUE 4950 CONTINUE GOTO 4810 4800 CONTINUE IF (.NOT.(CHAR .EQ. 'R')) GOTO 5000 5020 CONTINUE KX = RAN(I1, I2)*100. + 1. KY = RAN(I1, I2)*100. + 1. 5030 IF (.NOT.(UNIV(KX, KY) .EQ. EMPTY)) GOTO 5020 5040 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 5010 5000 CONTINUE IF (.NOT.(RAN(I1, I2) .GT. .5)) GOTO 5050 DPOD(I) = DPOD(I) + 90. GOTO 5060 5050 CONTINUE DPOD(I) = DPOD(I) - 90. 5060 CONTINUE 5010 CONTINUE 4810 CONTINUE 4790 CONTINUE GOTO 4770 4760 CONTINUE CALL SENT(I, 24) IPOD(I) = 4 4770 CONTINUE 4740 CONTINUE IF (.NOT.(IPOD(I) .EQ. 3)) GOTO 5070 C * DETONATE POD IX = XPOD(I) IY = YPOD(I) IF (.NOT.(UNIV(IX, IY) .EQ. '@')) GOTO 5090 IPOD(I) = 4 CALL SENT(I, 29) DO 5110 L1 = 1, 21 KX = IX + IPX(L1) IF (.NOT.(KX .GE. 101)) GOTO 5130 KX = KX - 100 5130 CONTINUE IF (.NOT.(KX .LT. 1)) GOTO 5150 KX = KX + 100 5150 CONTINUE KY = IY + IPY(L1) IF (.NOT.(KY .GE. 101)) GOTO 5170 KY = KY - 100 5170 CONTINUE IF (.NOT.(KY .LT. 1)) GOTO 5190 KY = KY + 100 5190 CONTINUE CHAR = UNIV(KX, KY) IF (.NOT.((CHAR .GE. '1') .AND. (CHAR .LE. '8'))) GOTO 521 *0 CONTINUE C GOTO 5220 5210 CONTINUE IF (.NOT.(CHAR .EQ. 'H')) GOTO 5230 CONTINUE C GOTO 5240 5230 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 5250 CONTINUE C GOTO 5260 5250 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 5270 CALL SENT(I, 31) C$ SCORE(I)=SCORE(I)+1000. UNIV(KX, KY) = EMPTY 5290 CONTINUE IIX = RAN(I1, I2)*100. + 1. IIY = RAN(I1, I2)*100. + 1. 5300 IF (.NOT.(UNIV(IIX, IIY) .EQ. EMPTY)) GOTO 5290 5310 CONTINUE HX = IIX HY = IIY UNIV(IIX, IIY) = BHOLE GOTO 5280 5270 CONTINUE UNIV(KX, KY) = EMPTY 5280 CONTINUE 5260 CONTINUE 5240 CONTINUE 5220 CONTINUE C C * FIGURE SHIP DAMAGE C 5110 CONTINUE 5120 CONTINUE DO 5320 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 5340 IS = 7. - D E = 1500. - D*300. IF (.NOT.(XSHIP(IZ))) GOTO 5360 CALL SENT(IZ, 30) CALL DAMAGE(IZ, E, 500.) SCAN(IZ) = SCAN(IZ) - IS IF (.NOT.(SCAN(IZ) .LT. 0)) GOTO 5380 SCAN(IZ) = 0 5380 CONTINUE IF (.NOT.(ENERGY(IZ) .LE. 0.)) GOTO 5400 IF (.NOT.(I .NE. IZ)) GOTO 5420 CALL SENT(I, 22) C$ SCORE(I)=SCORE(I)+2000. 5420 CONTINUE CALL RESET(IZ) 5400 CONTINUE IF (.NOT.(I .NE. IZ)) GOTO 5440 SCORE(I) = SCORE(I) + E CALL SENT(I, 32) 5440 CONTINUE GOTO 5370 5360 CONTINUE CALL SENT(I, 21) 5370 CONTINUE 5340 CONTINUE 5320 CONTINUE 5330 CONTINUE GOTO 5100 5090 CONTINUE CALL SENT(I, 24) IPOD(I) = 4 5100 CONTINUE GOTO 5080 5070 CONTINUE CONTINUE 5080 CONTINUE 4660 CONTINUE 4670 CONTINUE RETURN END REAL FUNCTION DSTNCE(XX, YY, X1, Y1) CALL DIRDIS(XX, YY, X1, Y1, DIR, DIS) DSTNCE = DIS 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 5460 J = 8, 2, - 1 K = IFIX(FLOAT(J)*RAN(I1, I2)) + 1 TMP = SHIPS(K) SHIPS(K) = SHIPS(J) SHIPS(J) = TMP 5460 CONTINUE 5470 CONTINUE RETURN END C POLADD - ADD POLAR COORDINATES: D3, R3 = D1, R1 + D2, R2 # WPW 12/7/80 SUBROUTINE POLADD(D1, R1, D2, R2, D3, R3) XT = R1*COS(D1*3.141592654/180.) + R2*COS(D2*3.141592654/180.) YT = R1*SIN(D1*3.141592654/180.) + R2*SIN(D2*3.141592654/180.) D3 = ATAN3(YT, XT)*180./3.141592654 R3 = SQRT(XT*XT + YT*YT) RETURN END C DIRDIS - FIND SHORTEST DIR AND DIS IN UNIV W/ WRAP-AROUND # WPW 12/8/80 SUBROUTINE DIRDIS(XX, YY, X1, Y1, DIR, DIS) REAL D1(4) IF (.NOT.(X1 .LT. 51.)) GOTO 5480 X2 = X1 + 100. GOTO 5490 5480 CONTINUE X2 = X1 - 100. 5490 CONTINUE IF (.NOT.(Y1 .LT. 51.)) GOTO 5500 Y2 = Y1 + 100. GOTO 5510 5500 CONTINUE Y2 = Y1 - 100. 5510 CONTINUE D1(1) = ((XX - X1)**2 + (YY - Y1)**2)**.5 D1(2) = ((XX - X1)**2 + (YY - Y2)**2)**.5 D1(3) = ((XX - X2)**2 + (YY - Y1)**2)**.5 D1(4) = ((XX - X2)**2 + (YY - Y2)**2)**.5 IIT = 1 DO 5520 J = 2, 4 IF (.NOT.(D1(J) .LT. D1(IIT))) GOTO 5540 IIT = J 5540 CONTINUE 5520 CONTINUE 5530 CONTINUE IF (.NOT.(IIT .EQ. 1)) GOTO 5560 YD = Y1 XD = X1 GOTO 5570 5560 CONTINUE IF (.NOT.(IIT .EQ. 2)) GOTO 5580 YD = Y2 XD = X1 GOTO 5590 5580 CONTINUE IF (.NOT.(IIT .EQ. 3)) GOTO 5600 YD = Y1 XD = X2 GOTO 5610 5600 CONTINUE YD = Y2 XD = X2 5610 CONTINUE 5590 CONTINUE 5570 CONTINUE DIR = ATAN3((YD - YY), (XD - XX))*57.29577951 DIS = D1(IIT) RETURN END