SUBROUTINE EBASE C C DO DAMAGE IF NEEDED TO A STARBASE C INCLUDE 'TRKCOMMON.FTN' REAL LAUNCH INTEGER SCAN,WHOM,CREW,HYPER,TORPS LOGICAL*1 THRU,XSHIP,CLOAK,CLON,FBASE,US,DESTRY,ERROR REAL DX(3),DY(3) BYTE MESSAG,INITLS,CHAR,TMPBUF(60) C C DO 10001 I=1,8 IF (.NOT.FBASE(I)) GOTO 10001 IU=IUNIV(I) IOFF=(IU-1)*20 ERROR=.FALSE. C C * FIRE 3 BAND WIDE BEAM (NOTE EACH BAND HAS ITS OWN HIT OR MISS ME C DX(1)=XCORD(I) DY(1)=YCORD(I) IF ((PHA(I).GE.45.AND.PHA(I).LT.135).OR. 1 (PHA(I).GE.225.AND.PHA(I).LT.315)) GO TO 10008 GO TO 10006 10008 DX(2)=DX(1)-1. DX(3)=DX(1)+1. DY(2)=DY(1) DY(3)=DY(1) GO TO 10007 10006 DX(2)=DX(1) DX(3)=DX(1) DY(2)=DY(1)-1. DY(3)=DY(1)+1. 10007 DO 10010 IZ=2,3 IF (DX(IZ).GT.IMAXX.OR.DX(IZ).LT.1) DX(IZ)=DX(1) IF (DY(IZ).GT.IMAXY.OR.DY(IZ).LT.1) DY(IZ)=DY(1) 10010 CONTINUE DO 10019 IZ=1,3 10011 CONTINUE MNUM=0 X1=DX(IZ) Y1=DY(IZ) DO 10022 IT=1,5 C C SEE IF WE HIT SOMETHING C CALL MOVE(X1,Y1,X,Y,PHA(I),10.,CHAR,IMAXX,IMAXY,IU) IF (CHAR.LT.'1'.OR.CHAR.GT.'8') GOTO 10023 DECODE(1,10033,CHAR)K IF (K.EQ.I) CHAR = '.' 10023 IF (CHAR.NE.'.') GO TO 10022 X1=X Y1=Y 10022 CONTINUE IX=X IY=Y IF (CHAR.EQ.'.') GOTO 10030 IF (CHAR.NE.'B') GOTO 10050 C C FIND OUT WHO OWNS IT C DO 20000 II=1,8 DO 20000 III=1,20,2 IF (IX.EQ.IBASE(II,IOFF+III).AND.IY.EQ.IBASE(II,IOFF+(III+1))) 1 GOTO 20001 20000 CONTINUE WRITE (5,350) IX,IY 350 FORMAT (' MTEBASE -- Failed to locate owner for base at ',I3,',',I3) IF (ERROR) GOTO 10030 C CALL VFY(2) ERROR=.TRUE. GOTO 10011 C C IS THERE ENOUGH ENERGY BEING FIRED TO DESTROY THE BASE? C 20001 DESTRY = .FALSE. IF (BASPHA(I).GT.BASEN(II,IOFF/2+((III+1)/2)).AND.XSHIP(II)) 1 DESTRY = .TRUE. IF (.NOT.XSHIP(II)) GOTO 10030 C C SEE IF IT'S US C US = .FALSE. IF (II.EQ.I) US = .TRUE. C C IF THIS ISN'T OUR BASE, SEND A MESSAGE TO THE PLAYER WHO OWNS IT. NOTE C THAT WE DON'T TELL THE PLAYER IF THE BASE HAS BEEN DESTROYED OR NOT, C JUST TO KEEP HIM GUESSING. C IF (US) GOTO 10260 ENCODE (54,10212,TMPBUF) 1 (III+1)/2,IU,IBASE(II,IOFF+III)/10,IBASE(II,IOFF+((III+1)/10)) 10212 FORMAT ('STARBASE ',I2,' SECT ',I1,',',I2,',',I2, 1 ' REPORTS THEY ARE UNDER ATTACK') DO 10250 J=1,54 MESSAG(II*60-59+J)=TMPBUF(J) 10250 CONTINUE MESSAG(II*60-59)='0' C C OH, NO, WE HIT OUR OWN BASE!! C 10260 IF (US) MNUM=12 IF (.NOT.DESTRY) GOTO 30000 IF (US) SCORE(I) = SCORE(I) - 500. IF (.NOT.US) SCORE(I) = SCORE(I) + 650. IBASE(II,IOFF+III)=0 IBASE(II,IOFF+(III+1))=0 MNUM=34 IF (US) MNUM=35 IF (FDBASE(IU,II).NE.(III+1)/2) GOTO 10032 C C C HAVE DESTROYED THE TARGET BASE OF A FREIGHTER. C NOW SELECT A NEW ONE WHICH IS CLOSEST FROM THE CURRENT POSITION C C C LOCATE FRIENDLY STARBASE C EDIS = 9999. DO 20020, III=1,20,2 IF (IBASE(II,IOFF+III).EQ.0) GOTO 20020 EDIS = ((FXCORD(IU,II)-IBASE(II,IOFF+III))**2+ 1 (FYCORD(IU,II)-IBASE(II,IOFF+(III+1)))**2)**.5 IF (EDIS.GE.LASTD) GO TO 20020 LASTD = EDIS 20020 CONTINUE IF (FDBASE(IU,II).LT.0) GOTO 10032 C C NO MORE LIVABLE BASES, STRAND IT AND HAVE IT WAIT FOR IT'S OWNER. C FDBASE (IU,II) = 0 CALL SENT (II,41) GOTO 10032 C C NOT ENOUGH TO DESTROY, JUST ENOUGH TO PISS THE BASE OFF. C RETALIATE BY ASSUMING THE BASE FIRES BACK AT THE SHIP. DO CONSIDERABLE C DAMAGE TO THE SHIP WHO FIRED. C 30000 IF (US) SCORE(I) = SCORE(I) - 200 IF (US) GOTO 10032 EN = BASPHA(I)/10 BASEN(II,IOFF/2+((III+1)/2))=BASEN(II,IOFF/2+((III+1)/2)) - EN IF (BASEN(II,IOFF/2+((III+1)/2)).LE.0) GOTO 20001 XXX=XCORD(I) YYY=YCORD(I) XX=IBASE(II,IOFF+III) YY=IBASE(II,IOFF+(III+1)) CALL COURSE(XX,YY,XXX,YYY,EDIR,EDIS) EN = BASPHA(I) * -1 CALL DAMAGE(I,EN,EDIR) MNUM=36 GOTO 10032 C C WE DIDN'T HIT A BASE BUT WE HIT SOMETHING. DESTROY IT! C 10050 IF ((CHAR.LT.'1'.OR.CHAR.GT.'8').AND.CHAR.NE.'F') GOTO 10031 IF (CHAR.NE.'F') GOTO 10052 C C CAUGHT A FREIGHTER C DO 10051, II=1,8 IF (FLOAD(IU,II).EQ.0) GOTO 10051 IIX=FXCORD(IU,II) IIY=FYCORD(IU,II) IF (IIX.NE.IX.OR.IIY.NE.IY) GOTO 10051 C C FOUND THE OWNER C K=II IF (FNEAR(IU,II)) GOTO 20111 CALL FRDAM (II,DESTRY,BASPHA(I),IU) MNUM = 40 IF (DESTRY) SCORE(I) = SCORE(I) + 500 IF (DESTRY) MNUM = 39 GOTO 10032 10051 CONTINUE C C COULDN'T FIND THE OWNER C MNUM = 0 GOTO 10032 C C CAUGHT AN ENEMY STARSHIP C 10052 DECODE(1,10033,CHAR)K 10033 FORMAT (I1) 20111 MNUM=21 IF (.NOT.XSHIP(K)) GOTO 10031 MNUM=6 EN = BASPHA(I) IF (BASPHA(I).LT.4000) GOTO 10034 C C NOW WE HAVE A CHANCE OF DESTRUCTION C XXX=XCORD(K) YYY=YCORD(K) XX=XCORD(I) YY=YCORD(I) EN = BASPHA(I)-4000 CALL COURSE(XX,YY,XXX,YYY,EDIR,EDIS) CALL DAMAGE(K,EN,EDIR) EN = 4000 IF (SHIELD(K).GT.0) GOTO 10034 SCORE (I) = SCORE (I) + 500 CALL RESET(K) GOTO 10032 10034 XXX=XCORD(K) YYY=YCORD(K) XX=XCORD(I) YY=YCORD(I) CALL COURSE(XX,YY,XXX,YYY,EDIR,EDIS) CALL DAMAGE(K,EN,EDIR) 10031 DESTRY = .FALSE. IF (CHAR.EQ.'+'.OR.CHAR.EQ.'^') MNUM=7 IF (MNUM.EQ.7.AND.BASPHA(I).GE.500) DESTRY=.TRUE. IF (CHAR.EQ.'*') MNUM=11 IF (MNUM.EQ.11.AND.BASPHA(I).GT.2000) DESTRY=.TRUE. IF (CHAR.EQ.'@') MNUM=25 IF (MNUM.EQ.25.AND.BASPHA(I).GT.500) DESTRY=.TRUE. IF (CHAR.NE.'#') GOTO 10032 C C MUNCH UP A BLACK HOLE, AND RESEED IT C IF (BASPHA(I).GT.4000) DESTRY=.TRUE. MNUM=8 IF (.NOT.DESTRY) GOTO 10032 MNUM=31 SCORE(I)=SCORE(I)+1000. CALL UNIVIN(IX,IY,'.',IU) 10055 IIX=RAN(I1,I2)*IMAXX+1. IF (IIX .GT. IMAXX ) IIX = IMAXX IIY=RAN(I1,I2)*IMAXY+1. IF (IIY .GT. IMAXY ) IIY = IMAXY CALL UNIV(IIX,IIY,CHAR,IU) IF (CHAR.NE.'.') GO TO 10055 DO 10054, J=1,IHOLE(IU) LX=HX(IU,J) LY=HY(IU,J) CALL UNIV(LX,LY,CHAR,IU) IF (CHAR.EQ.'#') GOTO 10054 C IF (LX.NE.IX.AND.LY.NE.IY) CALL VFY (2) HX(IU,J)=IIX HY(IU,J)=IIY CALL UNIVIN(IIX,IIY,'#',IU) 10054 CONTINUE CALL UNIV(IIX,IIY,CHAR,IU) IF (CHAR.EQ.'#') GOTO 10032 WRITE (5,10056) KX,KY 10056 FORMAT (' EBASE -- Failed to reseed black hole at ',I3,',',I3) C CALL VFY(2) C C 10032 IF (MNUM.EQ.0) GOTO 10400 CALL SENT(I,MNUM) IF (DESTRY) CALL UNIVIN(IX,IY,'.',IU) GOTO 10030 C 10400 IF (CHAR.EQ.'H'.OR.CHAR.EQ.'R') GOTO 10030 WRITE (5,10401) I,II,III,CHAR 10401 FORMAT (' EBASE ERROR -- SHIP = ',I1,' BASE = ',2(I3,X), 1 ' CHAR = ',A1) C 10030 CONTINUE 10019 CONTINUE BASPHA(I)=0 FBASE(I)=.FALSE. PHA(I)=-1. 10001 CONTINUE RETURN END