C C C ********************************************** C * * C * RECONN. PROBES LAUNCH CONTROL SUBROUTINE * C * * C ********************************************** C SUBROUTINE PROBE(TABORT) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/MISC2/NPROB,L5,L8,GASP,ITASK,SDATE,AFILE(4),CFILE(4),DTLSTH COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,CMD,DLN LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD,TABORT C RAD(ANGLE)=0.017453293*ANGLE C IF(.NOT.TINTRD)GOTO 10 IF(ITR(4).NE.1 .AND. ITR(4).NE.2)GOTO 10 CALL DAMCON(83,97,.FALSE.) RETURN 10 TYPE 11 11 FORMAT(/1X'** RECONN. PROBES LAUNCH CONTROL:'/) WRITE(3,11) NPROB=NPROB+1 IF(NPROB.LT.4) GOTO 30 20 TYPE 21 21 FORMAT(1X,'* Probe supply exhausted') WRITE(3,21) TABORT=.TRUE. RETURN 30 TYPE 31,NPROB,NPROB 31 FORMAT(1X,'* Computer has activated telemetry link with Probe #', &I2/1X,'* PROBE #',I2,' READY FOR LAUNCH') WRITE(3,31)NPROB,NPROB 40 TYPE 41,POW 41 FORMAT(1X'* Power available:',I5/1X,'Launch angle & power allocat &ed? ',$) 50 READ(5,51,ERR=40)ANGL,PPOW 51 FORMAT(2F10.0) IPOW=PPOW ANGL=RAD(ANGL) IF(IPOW.GT.0 .AND. POW.GT.0) GOTO 2 NPROB=NPROB-1 TABORT=.TRUE. RETURN 2 IF(IPOW.GT.POW) GOTO 40 POW=POW-IPOW I1=0 J1=0 DO 3 J=0,IPOW/8 XJ=J I2=XJ*-SIN(ANGL)+0.5+FLOAT(R1) J2=XJ*COS(ANGL)+0.5+FLOAT(C1) IF(I2.EQ.I1 .AND.J2.EQ.J1) GOTO 3 IF(I2.GT.8 .OR. I2.LT.1 .OR. J2.GT.8 .OR. J2.LT.1) GOTO 80 60 TYPE 61,I2,J2,QUAD(I2,J2) 61 FORMAT(1X'QUADRANT:',I3,',',I3,' =',I4) WRITE(3,61)I2,J2,QUAD(I2,J2) NGAL(I2,J2)=QUAD(I2,J2) I1=I2 J1=J2 IF(RAN(II,JJ).LT.0.02*AINT(FLOAT(QUAD(I1,J1))/100.))GOTO 90 3 CONTINUE 70 TYPE 71,I2,J2 71 FORMAT(1X'* PROBE POWER EXHAUSTED IN QUADRANT',I2,',',I2) WRITE(3,71)I2,J2 GOTO 4 80 TYPE 81 81 FORMAT(1X'* CONTACT WITH PROBE LOST') WRITE(3,81) GOTO 4 90 TYPE 91,I1,J1 91 FORMAT(1X'* PROBE INTERCEPTED AND DESTROYED BY ENEMY IN QUADRANT &',I2,',',I2) WRITE(3,91)I1,J1 4 DATE=DATE+FLOAT(J*8)/100. RETURN END C C C ********************************************** C * * C * EMERGENCY HYPERSPACE MANEUVER SUBROUTINE * C * * C ********************************************** C SUBROUTINE HYPER(TABORT) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/ALPHA/ALPH(30) COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,CMD,DLN LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD,TABORT LOGICAL*1 ANS,ALPH C 10 TYPE 11 11 FORMAT(/1X'** HYPERSPACE MANEUVER CONTROL'/) WRITE(3,11) IF(POW.GE.100) GOTO 2 20 TYPE 21 21 FORMAT(1X,'* Insufficient power available (p<100)- order aborted') WRITE(3,21) RETURN 2 IF(.NOT.TALTOW)GOTO 30 80 TYPE 81 81 FORMAT(1X,'* Unable to use Hyperspace with vessel in tow - COMMAND & CANCELLED') WRITE(3,81) RETURN 30 TYPE 31 31 FORMAT(1X'IS HYPERSPACE ORDER CONFIRMED? ',$) 40 READ(5,41,ERR=30)ANS 41 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.ALPH(14))TABORT=.TRUE. IF(ANS.EQ.ALPH(25))GOTO 60 IF(TABORT)RETURN 50 TYPE 51 51 FORMAT(1X'*** ANSWER NOT ACCEPTABLE ---- use "Y" or "N" ***') GOTO 30 60 TYPE 61 61 FORMAT(1X'* Confirmation acknowledged - HYPERSPACE MANEUVER INITIA &TED'/) WRITE(3,61) CALL PAUSE(2) IF(RAN(II,JJ).GT.0.3)GOTO 1 70 TYPE 71 71 FORMAT(/1X'* HYPERSPACE MANEUVER UNSUCCESSFUL') WRITE(3,71) TDEST=.TRUE. RETURN 1 R1=INT(RAN(II,JJ)*10.)+1 C1=INT(RAN(II,JJ)*10.)+1 IF(R1.GT.8 .OR. C1.GT.8)GOTO 1 POW=POW-100 IG2=0 CALL QADSET RETURN END C C C ***************************************** C * * C * SUBROUTINE TO DISPLAY GALACTIC MAP * C * * C ***************************************** C SUBROUTINE GALMAP COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/SYMBL/DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR(10,10) INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H LOGICAL*1 DOT,STAR,SHP,KLIN,BASE,ROM,MINE,SECTOR,LOC,ENDB DATA ENDB/1H / C C CALL SPLFNC("16) 10 TYPE 11,(I,I=1,8) 11 FORMAT(1X,'** MAP OF ASSIGNED GALACTIC PATROL QUADRANTS'/2X,8(4X,I &2)/3X,49(1H-)) WRITE(3,11)(I,I=1,8) DO 1 J=1,8 20 TYPE 21,J 21 FORMAT(1X,I2,1H:,$) WRITE(3,21)J DO 2 I=1,8 LOC=ENDB IF(J.EQ.R1 .AND. I.EQ.C1)LOC=SHP IF(NGAL(J,I).EQ.-1)GOTO 40 30 TYPE 31,NGAL(J,I),LOC 31 FORMAT(1H+,I4,A1,1H:,$) WRITE(3,31)NGAL(J,I),LOC GOTO 2 40 TYPE 41 41 FORMAT(1H+,5H ? ,1H:,$) WRITE(3,41) 2 CONTINUE 50 TYPE 51 51 FORMAT(1H+,1X/3X,49(1H-)) WRITE(3,51) 1 CONTINUE RETURN END C C C *********************************************************** C * * C * SUBROUTINE TO CALCULATE BEARING & DISTANCE TO TARGET * C * * C *********************************************************** C SUBROUTINE CALC(TABORT,TNAV) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/ALPHA/ALPH(30) COMMON/NAV/CORSD,WF INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,COORD(4) LOGICAL TABORT,TNAV,TEST LOGICAL*1 ANS,BLA,ALPH,COMMA,DUMMY(2),IMAGE(20),Q,S,EE EQUIVALENCE(COMMA,ALPH(28)),(Q,ALPH(17)),(S,ALPH(19)) DATA BLA/' '/ C TNAV=.FALSE. TYPE 11 11 FORMAT(/1X'** COMPUTER TARGET CALCULATOR') 20 TYPE 21 21 FORMAT(1X,'TARGET COORDINATES? ',$) READ(5,31,ERR=20)NC,IMAGE 31 FORMAT(Q,20A1) IF(NC.EQ.0)GOTO 999 NN=0 N=0 DO 1 I=1,NC IF((IMAGE(I).EQ.BLA .OR. IMAGE(I).EQ.COMMA).AND.I.NE.1)GOTO 2 N=N+1 DUMMY(N)=IMAGE(I) IF(I.NE.NC)GOTO 1 2 NN=NN+1 IF(NN.GT.4)GOTO 900 DECODE(N,41,DUMMY,ERR=910)COORD(NN) 41 FORMAT(I2) N=0 IF(COORD(NN).LE.0 .OR. COORD(NN).GT.10)GOTO 920 1 CONTINUE GOTO(930,50,930,4),NN 50 TYPE 51 51 FORMAT(1X,'Is target in Quadrant or Sector coordinates? ',$) READ(5,61,ERR=50)ANS 61 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.ALPH(3) .OR. ANS.EQ.BLA)GOTO 999 IF(ANS.EQ.Q)GOTO 3 IF(ANS.NE.S)GOTO 50 TROW=(R1-1)*10+COORD(1) !SECTOR COORD. ONLY TCOL=(C1-1)*10+COORD(2) GOTO 5 3 IF(COORD(1).GT.8 .OR. COORD(2).GT.8)GOTO 920 COORD(3)=5 !QUAD COORD. ONLY COORD(4)=5 4 TROW=(COORD(1)-1)*10+COORD(3) !BOTH TCOL=(COORD(2)-1)*10+COORD(4) 5 SROW=(R1-1)*10+A !SHIP'S COORD. SCOL=(C1-1)*10+B ANGL=ANGLE(INT(TROW),INT(TCOL),INT(SROW),INT(SCOL)) DIST=0.1*SQRT((TROW-SROW)**2+(TCOL-SCOL)**2) TYPE 71,ANGL,DIST 71 FORMAT(1X'* Target bearing',F7.1,' degrees at a distance of',F6.2, &' units') WRITE(3,71)ANGL,DIST IF(ANS.NE.'S')GOTO 80 CALL FDSHLD(NS,TEST,INT(TROW),INT(TCOL),INT(SROW),INT(SCOL)) EE="0 IF(.NOT.TEST)GOTO 90 NS1=NS+1 IF(NS1.EQ.5)NS1=1 EE='s' 90 TYPE 91,EE,NS 91 FORMAT(1X,'* Shield',A1,I2,$) WRITE(3,91)EE,NS IF(.NOT.TEST)GOTO 110 TYPE 101,NS1 101 FORMAT(1H+,' &',I2,$) WRITE(3,101)NS1 110 TYPE 111 111 FORMAT(1H+,' facing target.') WRITE(3,111) 80 TYPE 81 81 FORMAT(/1X,'Do you want this course laid in as Navigation Setting? & ',$) READ(5,61,ERR=80)ANS CALL CAPMSK(ANS,1) IF(ANS.EQ.'N')RETURN IF(ANS.NE.'Y')GOTO 80 TNAV=.TRUE. CORSD=ANGL WF=DIST RETURN 900 TYPE 901 901 FORMAT(1X,'*** TOO MANY COORDINATES',$) GOTO 940 910 TYPE 911 911 FORMAT(1X,'*** INPUT ERROR',$) GOTO 940 920 TYPE 921 921 FORMAT(1X,'*** COORDINATES OUT OF RANGE',$) GOTO 940 930 TYPE 931 931 FORMAT(1X,'*** ODD NUMBER OF COORDINATES (need 2 or 4)',$) 940 TYPE 941 941 FORMAT(1H+,' - Please reenter ***') GOTO 20 999 TABORT=.TRUE. RETURN END C C C ***************************************** C * * C * SUBROUTINE FOR SELF-DESTRUCTION * C * * C ***************************************** C SUBROUTINE SELFDS(TABORT) COMMON QUAD(8,8),SECT(10,10),NGAL(8,8),K(7,5),STATUS(13),R1,C1,R,C &,H1,POW,SHLD(5),NTORP,A,B,H(7),N1,N2,N3,N4,N5,N6,II,JJ,RANK,ITR(4) COMMON/MISC1/ICAPV(5),M1,M2,DATE,DLN,BEARNG,NCAS(2),CMD,IG2,NPRIS, &IBELL COMMON/RATNG/NBASD,NRESC,NFRES,NROMD,NCAPAL,NPRTKN COMMON/WRDS/COND,KL,RM,GRN,RED,DCKD,DEST(2),DISAB(2),SHIP(16) COMMON/ALPHA/ALPH(30) COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD COMMON/TESTS2/TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO, &TBOSS COMMON/PERS/NAME1(16),NPL,NG,AVGTOT,PSWRD,IRNK,NSHP,IUIC(4) INTEGER SECT,QUAD,R1,C1,R,C,SHLD,H1,A,B,POW,H,DLN,CMD REAL*8 KL,RM,GRN,RED,DCKD,COND,DEST,DISAB,PSWRD LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TNEW,TTMOUT,TOVER,TSHLD,TBASLO,TSLFDS,TWARN,THELLO,TLONE, &TLOOS,TBALEN,TALSD,TINTRD,TBOSS,TABORT,TPASS LOGICAL*1 ANS,ALPH,EE1,EE2,EE3,ENDB,ENDS,SHIP,NAME1,PSWRD1(8) DATA ENDB,ENDS/1H ,1HS/ C IF(.NOT.TINTRD .OR. ITR(4).NE.1)GOTO 10 CALL DAMCON(87,97,.FALSE.) RETURN C 3 CALL SPLFNC("16) 10 TYPE 11 11 FORMAT(/1X,'** SELF-DESTRUCT AUTO SEQUENCER CONTROL'/) WRITE(3,11) TLONE=.FALSE. IF(COND.EQ.RED .AND. N6.EQ.0)GOTO 40 IF(N3.GT.0 .OR. TROM1)GOTO 30 20 TYPE 21 21 FORMAT(1X'* NO HOSTILE ALIENS PRESENT - use of Self-Destruct is qu &estioned'/) WRITE(3,21) TLONE=.TRUE. IF(N6.EQ.0)GOTO 40 30 TYPE 31,N6 31 FORMAT(1X'* WARNING - SELF-DESTRUCT WILL ALSO DESTROY STARBASE',I2 &/) WRITE(3,31) 40 TYPE 41 41 FORMAT(1X'Is order for initiating Self-Destruct Sequence confirmed &? ',$) 50 READ(5,51,ERR=40)ANS 51 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.'N')GOTO 999 IF(ANS.EQ.'Y') GOTO 1 60 TYPE 61 61 FORMAT(1X'*** ANSWER NOT ACCEPTABLE ---- Use "Y" or "N" ***') GOTO 40 1 CALL A8TOA1(PSWRD,PSWRD1) IF(.NOT.TPASS(PSWRD1,1))GOTO 999 EE1=ENDS IF(N3.EQ.1)EE1=ENDB NROM=0 IF(TROM1)NROM=1 EE2=ENDB IF(NROM.EQ.0)EE2=ENDS IF(N6.NE.0)N6=1 EE3=ENDB IF(N6.EQ.0)EE3=ENDS 70 TYPE 71,N3,KL,EE1,NROM,RM,EE2,N6,EE3 71 FORMAT(/1X'* CONFIRMATION ACKNOWLEDGED'/1X'* The following will al &so be destroyed:'/5X,I2,1X,A7,A1,5X,I2,1X,A7,A1,5X,I2,' STARBASE', &A1//1X'* SELF-DESTRUCT AUTO SEQUENCE INITIATED'/) WRITE(3,71)N3,KL,EE1,NROM,RM,EE2,N6,EE3 CALL PAUSE(2) 90 TYPE 91,IBELL 91 FORMAT(1X,'TIME UNTIL DESTRUCTION: 10',A1,$) DO 2 I=1,10 CALL PAUSE(2) CALL BACKSP(2) 100 TYPE 101,IBELL,10-I 101 FORMAT(1H+,A1,I2,$) 2 CONTINUE C CALL SPLFNC("16) 80 TYPE 81 81 FORMAT(1X//1X,10('*'),' SELF-DESTRUCTION COMPLETED ',10('*')/) WRITE(3,81) TDEST=.TRUE. TSLFDS=.TRUE. NBASD=NBASD+N6 IF(TLONE)RETURN N4=N4-N3-NROM NROMD=NROMD+NROM RETURN 999 TABORT=.TRUE. RETURN END C C C *********************************************************** C * * C * SUBROUTINE TO SET AUTO ALERT SWITCH FOR BATTLE ALERT * C * (AUTO SHIELD RAISER) * C * * C *********************************************************** C SUBROUTINE AUTOSH(TABORT) COMMON/TESTS1/TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW, &TBOFF,TALERT,TLOOS,TBALEN,TALSD,TINTRD LOGICAL TROM1,TROM2,TDISAB,TDEST,TWON,TLOST,TRESC,TALTOW,TBOFF, &TALERT,TLOOS,TBALEN,TALSD,TINTRD,TABORT,TPASS LOGICAL*1 ANS,YES,NO DATA YES,NO,ON,OFF/'Y','N','ON','OFF'/ C SWITCH=OFF IF(TALERT)SWITCH=ON 10 TYPE 11,SWITCH 11 FORMAT(/1X,'** AUTO ALERT SWITCH - switch is currently: ',A3) WRITE(3,11)SWITCH SWTCH1=ON IF(TALERT)SWTCH1=OFF 20 TYPE 21,SWTCH1 21 FORMAT(1X,'Do you want Auto Alert Switch turned ',A3,'? ',$) 30 READ(5,31,ERR=20)ANS 31 FORMAT(A1) CALL CAPMSK(ANS,1) IF(ANS.EQ.NO)TABORT=.TRUE. IF(TABORT)RETURN IF(ANS.NE.YES)GOTO 20 IF(TALERT)GOTO 1 TALERT=.TRUE. GOTO 40 1 TALERT=.FALSE. 40 TYPE 41,SWTCH1 41 FORMAT(/1X,'* Auto Alert Switch is now: ',A3) WRITE(3,41)SWTCH1 RETURN END