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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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, UPRATE, 1, IDS) ACCUME = .TRUE. DO 2000 I = 1, 8 SHIPS(I) = I 2000 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, UPRATE, 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 CALL WAIT(5, 2, M) 2050 CONTINUE THRU = .TRUE. 10 CONTINUE 2030 IF (.NOT.(THRU)) GOTO 2020 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 - * 4.)), TRUDIR, TRUWRP) 2230 CONTINUE 2210 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 TRBEAM(I) = 0 C GOTO 2280 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 2280 2350 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 2370 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 2280 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 C * IF WE ARE HERE WE DIDN'T FIND AN EMPTY SPOT ( VERY UNLIKELY) 2490 CONTINUE CALL SENT(I, 18) 102 WARP(I) = 0. C GOTO 2280 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 2280 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 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 2280 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 2280 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 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 2280 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 2280 CONTINUE IF (.NOT.(ENERGY(I) .LE. 0.)) GOTO 2830 CALL SENT(I, 16) CALL RESET(I) 2830 CONTINUE 2130 CONTINUE 2110 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 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 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 2930 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 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 3030 3040 CONTINUE IF (.NOT.(CHAR .EQ. BHOLE)) GOTO 3140 C * TORPEDO HIT ON BLACK HOLE - THE HOLE PREVAILS! GOTO 3030 3140 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3160 C * TORPEDO HIT ON STAR CALL SENT(I, 13) C GOTO 3030 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 3030 3180 CONTINUE IF (.NOT.((CHAR .EQ. '+') .OR. (CHAR .EQ. '^'))) GOTO 3200 C * TORPEDO HIT ON TORPEDO CALL SENT(I, 20) UNIV(IX, IY) = EMPTY C GOTO 3030 3200 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3220 C * TORPEDO HIT ON ANTI-MATTER POD CALL SENT(I, 26) UNIV(IX, IY) = EMPTY GOTO 3030 3220 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3240 C * TORPEDO HIT ON ENERGY NET CALL SENT(I, 34) UNIV(IX, IY) = EMPTY GOTO 3030 3240 CONTINUE C * ANYTHING ELSE GETS DESTROYED UNIV(IX, IY) = EMPTY 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 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 3490 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 3490 3580 CONTINUE IF (.NOT.(CHAR .EQ. '*')) GOTO 3620 C * PHASER HIT ON STAR CALL SENT(I, 11) C GOTO 3490 3620 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 3640 C * PHASER HIT ON BASE CALL SENT(I, 12) C GOTO 3490 3640 CONTINUE IF (.NOT.(CHAR .EQ. '@')) GOTO 3660 C * PHASER HIT ON ANTI-MATTER POD CALL SENT(I, 25) GOTO 3490 3660 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 3680 C * PHASER HIT ON ENERGY NET CALL SENT(I, 35) GOTO 3490 3680 CONTINUE C * MISSED C$ CALL SENT(I,8) NMISS = NMISS + 1 3490 CONTINUE 3420 CONTINUE PHA(I) = - 1. IF (.NOT.(NMISS .EQ. 3)) GOTO 3700 CALL SENT(I, 8) 3700 CONTINUE 3280 CONTINUE 3260 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 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 4040 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 4180 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 DO 4300 K = 1, 9 ISENT(I, K) = ISENT(I, K + 1) 4300 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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.1 *4159 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 4320 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 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 4590 4600 CONTINUE IF (.NOT.(CHAR .LT. 0)) GOTO 4640 C * CAN'T EAT ENERGY NET! GOTO 4590 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 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), UPRATE, UNIV(100, 100), MESSAG( *480), THRU, XSHIP(8), CLOAK(8), NET(8), BHOLE, EMPTY REAL LAUNCH, NDRAIN INTEGER SCAN, WHOM, CREW, HYPER, TORPS, TRBEAM, UPRATE 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 4830 4840 CONTINUE IF (.NOT.(HYPER(I) .EQ. 3)) GOTO 4860 KX = 80 KY = 75 GOTO 4830 4860 CONTINUE IF (.NOT.(HYPER(I) .EQ. 4)) GOTO 4880 KX = 20 KY = 25 GOTO 4830 4880 CONTINUE IF (.NOT.(HYPER(I) .EQ. 5)) GOTO 4900 KX = 50 KY = 30 GOTO 4830 4900 CONTINUE IF (.NOT.(HYPER(I) .EQ. 6)) GOTO 4920 KX = 80 KY = 25 GOTO 4830 4920 CONTINUE STOP 52 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 4940 CONTINUE 4950 CONTINUE GOTO 4790 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 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 4790 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 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 5220 5230 CONTINUE IF (.NOT.(CHAR .EQ. 'B')) GOTO 5250 CONTINUE C GOTO 5220 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 HX = IIX HY = IIY UNIV(IIX, IIY) = BHOLE GOTO 5220 5270 CONTINUE UNIV(KX, KY) = EMPTY 5220 CONTINUE C C * FIGURE SHIP DAMAGE C 5110 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 GOTO 5100 5090 CONTINUE CALL SENT(I, 24) IPOD(I) = 4 5100 CONTINUE GOTO 5080 5070 CONTINUE CONTINUE 5080 CONTINUE 4660 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 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 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 5570 5580 CONTINUE IF (.NOT.(IIT .EQ. 3)) GOTO 5600 YD = Y1 XD = X2 GOTO 5570 5600 CONTINUE YD = Y2 XD = X2 5570 CONTINUE DIR = ATAN3((YD - YY), (XD - XX))*57.29577951 DIS = D1(IIT) RETURN END