C========================================================== C C TREK7 MODULE B C CONVERTED TO PC BY: DAN GAHLINGER C ENTIRE MODULE TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C USER COMMAND ROUTINES C C AREX CANCEL CHEKOV DEFLOC NODEFL GODOT C GOLLUM INFO INST UHURA ORWELL BLOCH C SCOTT STONE ECCLE TRACLC NOTRAC VULCAN C MRESS SHADOW C C========================================================= C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C AREX - C SUBROUTINE AREX LOGICAL CYRANO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCOL(4) IF(TWARP(IT).NE.0.)GO TO 15 WRITE(L,625) 625 FORMAT(' NO WARP LEFT - BREAK OUT THE OARS') RETURN 15 IF(A.EQ.0.OR.B.EQ.0)GO TO 150 WARP(IT)=A ITCOL(IT)=B/100. ITROW(IT)=B-ITCOL(IT)*100 IF(CYRANO(ITROW(IT),ITCOL(IT)).OR.WARP(IT).GT.TWARP(IT).OR.WARP(IT *).LT.0)GO TO 6581 RETURN 150 WRITE(L,508)TWARP(IT) 508 FORMAT(' ENTER WARP FACTOR - BETWEEN 0 AND ',F10.7,': ',$) READ(L,*,ERR=6580)WARP(IT) 24 FORMAT(F15.7) 151 IF(WARP(IT).GT.TWARP(IT).OR.WARP(IT).LT.0)GO TO 6581 WRITE(L,506) 506 FORMAT(' ENTER TARGET COORDINATES: ',$) READ(L,507,ERR=6580)ITCOL(IT),ITROW(IT) 507 FORMAT(2I2) IF(CYRANO(ITCOL(IT),ITROW(IT)))GO TO 6581 658 RETURN 6580 CALL ILLDAT 6581 CALL OOPS(L) WARP(IT)=0. GO TO 658 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C CANCEL - C SUBROUTINE CANCEL(IBORD) DIMENSION IGOK(5) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(4) COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) DATA IGOK/'T','P','B','Y','D'/ IF(IGOL(1).EQ.'C')GO TO 67210 IF(IGOL(1).NE.IBLK)GO TO 6720 67210 WRITE(L,6704) 6704 FORMAT(' ENTER COMMANDS YOU WISH CANCELLED (P,T,B,Y,D, H FOR * HELP)') 6708 READ(L,6705)(IGOL(I),I=1,6) 6705 FORMAT(6A1) 6720 IF(IGOL(1).NE.'H')GO TO 6706 WRITE(L,6707) 6707 FORMAT(' ENTER A STRING OF LETTERS REPRESENTING THE COMMANDS YOU W *ISH CANCELLED-'/' ''P'' TO CANCEL PHASER, ''T'' FOR TORPEDO/DISRUP *TOR'/' ''B'' FOR BOARD, ''Y'' FOR YANK, ''D'' FOR DEFLECT') GO TO 6708 6706 DO 6711 I7=1,6 DO 6709 I=1,5 IF(IGOL(I7).EQ.IGOK(I))GO TO (671,6712,674,6700,6701),1 6709 CONTINUE RETURN 6712 IF(LOCK(IT).NE.1)GO TO 6711 LOCK(IT)=0 PHASR(IT)=PHASR(IT)+ZAP(IT) WRITE(L,672) 672 FORMAT(' PHASER COMMAND CANCELLED') GO TO 6711 671 IF(LOCKT(IT).NE.1)GO TO 6711 LOCKT(IT)=0 IPHOT(IT)=IPHOT(IT)+1 WRITE(L,673) 673 FORMAT(' TORPEDO/DISRUPTOR COMMAND CANCELLED') GO TO 6711 674 IBORD=0 WRITE(L,675) 675 FORMAT(' BOARD COMMAND CANCELLED') GO TO 6711 6700 IPULL(IT)=0 WRITE(L,6702) 6702 FORMAT(' YANK COMMAND CANCELLED') GO TO 6711 6701 IPUSH(IT)=0 WRITE(L,6703) 6703 FORMAT(' DEFLECT COMMAND CANCELLED') 6711 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - CHEKOV - C SUBROUTINE CHEKOV LOGICAL LOKI DIMENSION IBOLT(4,2) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(4) DATA IBOLT/'PHOT','ON T','ORPE','DOES','DISR','UPTO','R BO','LTS'/ IF(LOKI(LOCKT(IT)))RETURN C PRINT 33244,JS C33244 FORMAT(//' TOP OF CHEKOV (TREKB) JS=',I6//) IF(IPHOT(IT).GT.0)GO TO 71 75 WRITE(L,72)(IBOLT(I,JS),I=1,4) 72 FORMAT(' THERE ARE NO ',4A4,' LEFT') C PRINT 22244 C22244 FORMAT(//' CHEKOV 22244 before 71 - first write'//) RETURN 71 DISTP=ANGLE(IT) C PRINT 22255 C22255 FORMAT(//' CHEKOV 22255 AFTER 71 IPHOT >= 0'//) RANG(IT)=10. IF(A.EQ.0)GO TO 7100 ANGLE(IT)=A GO TO 71 C7100 PRINT 22211 C22211 FORMAT(//' CHEKOV 22211 at 7100 JS=',I4//) 7100 WRITE(L,3)IPHOT(IT),(IBOLT(I,JS),I=1,4) 73 FORMAT(' YOU HAVE',I3,1X,4A4/' ENTER ANGLE: ') C PRINT 22266 C22266 FORMAT(//' CHEKOV 22266 AFTER 73'//) 77 READ(L,*,ERR=130)ANGLE(IT) 24 FORMAT(F15.7) 711 IPHOT(IT)=IPHOT(IT)-1 C PRINT 22233 C22233 FORMAT(//' CHEKOV 22233 after 711'//) LOCKT(IT)=1 WRITE(L,3) 3 FORMAT(' WEAPON LOCKED ON TARGET') RETURN 130 ANGLE(IT)=DISTP CALL OOPS(L) CALL ILLDAT RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K. 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - DEFLOC C SUBROUTINE DEFLOC LOGICAL LOKI,NODEFL,CYRANO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) IF(LOKI(IPUSH(IT)))RETURN IF(NODEFL(IT))RETURN IF(A.EQ.0.OR.B.EQ.0)GO TO 61 PUSH(IT)=A IPUSHC(IT)=B/100. IPUSHR(IT)=B-IPUSHC(IT)*100. GO TO 62 61 WRITE(L,21)DISTP 21 FORMAT(' RANGE OF BEAM IS',F4.0,' UNITS'/' ENTER TARGET COORDINATE *S: ',$) A=0 READ(L,22,ERR=250)IPUSHC(IT),IPUSHR(IT) 22 FORMAT(2I2) 62 IF(CYRANO(IPUSHR(IT),IPUSHC(IT)))GO TO 23 33 NA=MMAP(IPUSHR(IT),IPUSHC(IT)) IF(NA.EQ.IGLE)GO TO 267 IF(NA.EQ.IM(IT))GO TO 267 GO TO 330 267 IF(A.NE.0)GO TO 63 WRITE(L,53) 53 FORMAT(' ENTER DISTANCE YOU WISH TO PUSH OBJECT: ',$) READ(L,*,ERR=250)PUSH(IT) 29 FORMAT(F15.7) 63 WRITE(L,56)PUSH(IT) 56 FORMAT(' THIS WILL USE ',F11.7,' UNITS OF DEFLECTOR SHIELD * ENERGY') GO TO 57 330 IF(A.NE.0)GO TO 57 WRITE(L,34) 34 FORMAT(' ENTER THE AMOUNT OF DEFLECTOR SHIELD ENERGY YOU WISH TO U *SE'/' (ENTER A NEGATIVE NUMBER FOR HELP)') READ(L,29,ERR=250)PUSH(IT) 57 IF(PUSH(IT).EQ.0)GO TO 23 IF(PUSH(IT).GT.DFLCT(IT))GO TO 264 IF(PUSH(IT).GT.0)GO TO 35 WRITE(L,36) 36 FORMAT(' IF THE TARGET IS A SHIP-'/' THE AMOUNT OF ENERGY (E) ENTE *RED WILL SLOW THE ATTACKING ENEMY'/' SHIP''S SPEED BY A FACTOR OF * 2**(-E/5)'/' EG. 5 WILL CUT THE SHIP''S SPEED IN HALF,'/' 10 WILL * SLOW IT TO 1/4 SPEED, 15 WILL SLOW IT TO 1/8 SPEED' //' IF THE TA *RGET IS AN EAGLE OR MINE-'/' 1 UNIT OF DEFLECTOR SHIELD ENERGY IS * NEEDED FOR EACH UNIT THIS OBJECT'/' IS PUSHED AWAY'//' IF THE TAR *GET IS EMPTY SPACE OR AN ION STORM- NOTHING WILL HAPPEN'//' IF THE * TARGET IS A STAR, DOOMSDAY MACHINE OR MOONBASE ALPHA-'/' NOTHING * WILL HAPPEN AS THE TARGET IS TOO MASSIVE FOR THE DEFLECTORS'/' TO * HANDLE') PUSH(IT)=0. IF(A.NE.0)GO TO 61 GO TO 33 35 IPUSH(IT)=1 WRITE(L,37) 37 FORMAT(' DEFLECTORS LOCKED ON TARGET') RETURN 264 WRITE(L,265) 265 FORMAT(' NOT ENOUGH ENERGY TO LOCK BEAM') GO TO 23 250 CALL ILLDAT 23 CALL OOPS(L) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - NODEFL - C LOGICAL FUNCTION NODEFL(IT) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) NODEFL=.FALSE. I7=33 IF(IT.GT.2)I7=8 6 DISTP=9-MA(IT,I7) IF(MA(IT,I7).EQ.0)DISTP=10. IF(MA(IT,I7).NE.9)RETURN 4 WRITE(L,5) 5 FORMAT(' NAVIGATIONAL DEFLECTOR HAS BEEN DESTROYED') IPUSH(IT)=0 NODEFL=.TRUE. RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - GODOT - C C- LET'S GO C- WE CAN'T C- WHY NOT? C- WE'RE WAITING FOR SUBROUTINE GODOT DIMENSION LEN1(31),LEN2(31) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /V/IWEB(2),IWEBZ,INVIS(4) IF(A.EQ.0)GO TO 5171 DISTP=A GO TO 51702 5171 WRITE(L,121)NOMAP(IT) 121 FORMAT(' ENTER RADIUS OF MAP - BETWEEN 1 AND',I3,': ',$) READ(L,*,ERR=5170)DISTP 24 FORMAT(F15.7) 51702 N=DISTP IF(N.GE.1.AND.N.LE.NOMAP(IT))GO TO 550 51701 CALL OOPS(L) RETURN 5170 CALL ILLDAT GO TO 51701 550 I7=IENTR(IT)-N I8=IENTR(IT)+N IV=IENTC(IT)-N IVV=IENTC(IT)+N IF(I7.LT.1)I7=1 IF(I8.GT.60)I8=60 IF(IV.LT.1)IV=1 IF(IVV.GT.60)IVV=60 DO 552 J=IV,IVV 552 LEN1(J-IV+1)=J-(J/10)*10 WRITE(L,5175)(LEN1(J),J=1,IVV-IV+1) 5175 FORMAT(3X,31I1) DO 5173 J=1,I8-I7+1 IV1=I8-J+1 JTK=IV1/10 C ENCODE(1,5174,NB)JTK WRITE(NA,'(I1)')JTK JTK=IV1-JTK*10 C ENCODE(1,5174,NA)JTK 5174 WRITE(NA,'(I1)')JTK C5174 FORMAT(I1) C NOTE THIS IS WHERE WE ATTEMPT TO CONVERT THE ENCODE STATMENTS-ONLY 2! JTK=0 DO 100 I=IV,IVV JTK=JTK+1 NC=MMAP(IV1,I) LEN2(JTK)=NC IF(NC.EQ.IBLK)GO TO 100 IF(NC.EQ.III)GO TO 100 IF(NC.EQ.ISTAR)GO TO 100 IF(NC.NE.IENM1(2))GO TO 101 IF(INVIS(IT).EQ.1)GO TO 100 LEN2(JTK)=IBLK IF(ISPOK(2).EQ.1)LEN2(JTK)=III GO TO 100 101 IF(NC.NE.IENM1(6))GO TO 102 IF(IARMZ(5).NE.1)GO TO 100 IF(IKLNR(6).NE.J)GO TO 100 IF(IKLNC(6).NE.I)GO TO 100 IF(INVIZ(IT).EQ.1)GO TO 100 LEN2(JTK)=IBLK IF(ISPOK(6).EQ.1)LEN2(JTK)=III GO TO 100 102 IF(NC.LT.IM(1))GO TO 100 IF(NC.GT.IM(4))GO TO 100 IF(NC.NE.IM(IT))GO TO 103 LEN2(JTK)='M' GO TO 100 103 LEN2(JTK)=IBLK 100 CONTINUE 5173 WRITE(L,5172)IV1,(LEN2(I),I=1,JTK),NB,NA 5172 FORMAT(I3,33A1) WRITE(L,5175)(LEN1(J),J=1,IVV-IV+1) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - GOLLUM - C C- MY PRECIOUS SUBROUTINE GOLLUM COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /U/LAUNCH,NUMOUT,NUME(2) IF(NUMOUT.EQ.0)RETURN WRITE(L,302) 302 FORMAT(' EAGLES-'/) I7=0 DO 301 I=1,LAUNCH IF(IGLER(I).EQ.0)GO TO 301 I7=I7+1 WRITE(L,303)I,IGLEC(I),IGLER(I) 303 FORMAT('+',I2,' - (',I2,',',I2,') ',$) IF(I7.NE.5)GO TO 301 I7=0 WRITE(L,304) 304 FORMAT(/' ',$) 301 CONTINUE WRITE(L,304) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C C - INFO C SUBROUTINE INFO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) WRITE(L,587)(INAME(IQ0,IT),IQ0=1,3),DFLCT(IT),IENTC(IT),IENTR(IT), *NDEAD(IT) 587 FORMAT(22X,'DEFLECTORS POSITION'/1X,3A4,13X,F5.1,4X,'(',I2,',',I2, *')',5X,'CREW REMAINING=',I4) DO 770 N=1,4 IF(ICHOE(N).EQ.0.OR.ICHOE(N).EQ.3)GO TO 770 IF(N.EQ.IT)GO TO 770 WRITE(L,771)(INAME(IQ0,N),IQ0=1,3),DFLCT(N),IENTC(N),IENTR(N) 771 FORMAT(1X,3A4,13X,F5.1,4X,'(',I2,',',I2,')') 770 CONTINUE DO 772 N=1,2 IF(ICHOB(N).EQ.0)GO TO 772 WRITE(L,773)(ISIDE(IQ0,N),IQ0=1,3),IBASE(N),DFLCB(N),IBASC(N), *IBASR(N) 773 FORMAT(1X,3A4,' STARBASE ',I3,1X,F5.1,4X,')',I2,',',I2,')') 772 CONTINUE DO 760 N=1,8 IF(ICHOS(N).EQ.0)GO TO 760 IF(N.NE.6.AND.IBPSB(N).EQ.IS)GO TO 761 GO TO (761,762,761,761,763,764,763,761),N 761 WRITE(L,755)(IENM2(I,N),I=1,4),DFLCK(N),IKLNC(N),IKLNR(N) 755 FORMAT(1X,4A4,7X,F5.1,4X,'(',I2,',',I2,')') GO TO 760 762 IF(INVIS(IT).EQ.1)GO TO 761 WRITE(L,757)(IENM2(I,2),I=1,4) 757 FORMAT(1X,4A4,7X,'UNKNOWN UNKNOWN') GO TO 760 763 WRITE(L,756)(IENM2(I,N),I=1,4),IKLNC(N),IKLNR(N) 756 FORMAT(1X,4A4,7X,'UNKNOWN (',I2,',',I2,')') GO TO 760 764 IF(IARMZ(4).EQ.1.AND.IMAGZ.GT.0)GO TO 91 IF(IARMZ(5).EQ.1.AND.INVIZ(IT).EQ.0)GO TO 91 WRITE(L,755)(IENM2(I,6),I=1,4),DFLCK(6),IKLNC(6),IKLNR(6) GO TO 760 91 WRITE(L,757)(IENM2(I,6),I=1,4) 760 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C IIIII N N SSSSS TTTTT C I NN N S T C I N N N SSSSS T C I N NN S T C IIIII N N SSSSS T C SUBROUTINE INST COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) WRITE(L,3) 3 FORMAT(' HERE ARE YOUR COMMANDS TO THE SHIP. '/' TYPE IN THE WORD * OR ITS FIRST TWO LETTERS TO INITIATE THE DESIRED ACTION'/ *' HELP - PRINT THESE INSTRUCTIONS'/ *' TRANSFER - TRANSFER OF ENERGY FROM ONE SYSTEM TO ANOTHER'/ *' PHASER LOCK PHASER BANKS ON TARGET'/ *' TORPEDO LOCK PHOTON TORPEDOES/DISRUPTORS ON TARGET'/ *' MINE - SET THE RANGE AT WHICH A TORPEDO BECOMES A MINE'/ *' YANK - LOCK TRACTOR BEAM ON TARGET'/ *' DEFLECT - LOCK DEFLECTOR BEAM ON TARGET'/ *' RESET - RESET PHASERS + TORPEDOES/DISRUPTORS ONTO TARGETS PREVIO *USLY SET') WRITE(L,5) 5 FORMAT(' BOARD - PREPARE TO TRANSPORT A BOARDING PARTY'/ *' CANCEL - CANCELS PHASER, TORPEDO, BOARD, YANK AND/OR DEFLECT COM *MANDS'/ *' COURSE - SET A NEW COURSE'/ *' GO - MOVE AND FIRE WEAPONRY IN ANY SEQUENCE') WRITE(L,4) 4 FORMAT(' MAP - PRINT A MAP OF YOUR SURROUNDINGS'/ *' INFO - TYPE OUT STATUS OF SHIPS IN THE GAME'/ *' EAGLE TYPE OUT POSITION OF EAGLES'/ *' SPOCK GIVES PROBABILITIES AND DISTANCES'/ *' CREW - GIVES NUMBER OF CREW ON YOUR SHIP AND ON BOARDED SHIPS'/ *' DAMAGE - ALL DECKS REPORT DAMAGE FACTORS'/ *' ENEMY ADD ANOTHER ENEMY SHIP TO THE GAME'/ *' RADIO USE SUBSPACE RADIO TO CONTACT OTHER MANUALLY-OPERATED * SHIPS'/ *' ATTACK - STARBASE OR BOARDED VESSELS ATTACK'/ *' CEASE STARBASE OR BOARDED VESSELS STOP ATTACKING'/ *' NOSTOP - DO NOT STOP THE GAME WHEN ALL THE ENEMIES HAVE BEEN DEF *EATED'/ *' SURRENDER - SURRENDER'/) WRITE(L,800) 800 FORMAT(' IF YOU WISH TO ENTER THE COORDINATES (60,60) OR (1, 1), *'/' TYPE 6060 OR 0101.') WRITE(L,801) 801 FORMAT(' THE RANGE OF A PHOTON TORPEDO OR DISRUPTOR BOLT IS 10 UNI *TS'/' NOTE ALSO THAT THERE IS A MAXIMUM AMOUNT OF DAMAGE THAT CAN * BE DONE'/' WHEN A PHASER BEAM IS FIRED. THUS YOU ARE ADVISED NOT * TO WASTE YOUR ENERGY'/' BY FIRING TOO MUCH AT A TIME. I ADVISE AB *OUT 500 UNITS PER SHOT') 32 WRITE(L,33) 33 FORMAT(' IF WE ENTER AN ION STORM WE WILL RECEIVE DAMAGE'/' AND O *UR SPEED WILL BE CUT IN HALF') WRITE(L,38) 38 FORMAT(' ENEMY STRATEGY AND STRENGTH-') 34 WRITE(L,37) 35 FORMAT(' KLINGONS ALWAYS ATTACK'/' ROMULANS RETREAT WHEN YOUR SHIE *LDS EXCEED THEIRS BY 20,'/' AND DO NOT TRAVEL ON A DIRECT COURSE * TO OR FROM YOU WHEN ATTACKING'/' OR RETREATING'/' THOLIANS ALW *AYS ATTACK, BUT HALT WHEN THEY ARE 8 UNITS AWAY + USE THEIR WEB', */' GORNS RETREAT UNTIL THEIR SHIELDS ARE > THAN YOURS BY 25', */' ORIONS MAKE CLOSE PASSES AT US AND FIRE WHEN THEY"RE CLOSEST'/ *' THE DOOMSDAY MACHINE EATS STARS, MINES, + US'/' MOONBASE ALPHA * LAUNCHES 5 WAVES OF 5 EAGLES') 36 WRITE(L,35) 37 FORMAT(' ENEMY',12X,'WARP FIREPOWER'//' KLINGONS',9X,'7-9 450-110 *0'/' ROMULANS',9X,'7-9 300-1000'/' THOLIANS',9X,'5-10 600-900'/' *GORNS',12X,'11 350-900'/' ORIONS',11X,'12 500-1100'/' KZINTI *',11X,'PLAYER PROGRAMMABLE'/' DOOMSDAY MACHINE ??? 1000-2000'/' M *OONBASE ALPHA 0 500'/' EAGLES',11X,'2.9 200'//'FIREPOWER IS *GIVEN IN EQUIVALENT ENTERPRISE PHASER UNITS') RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - UHURA - C SUBROUTINE UHURA INTEGER JCOMS(5) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,MES(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /J/KODE(2,8),STATIC(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM DATA JCOMS/'T','R','J','D','H'/ WRITE(L,1) 1 FORMAT(' ENTER COMMUNICATIONS COMMAND (T,R,J,D,HELP, *STOP): ',$) 43 READ(L,14)NA DO 40 I7=1,5 IF(NA.EQ.JCOMS(I7))GO TO (4,4,6,7,41),I7 40 CONTINUE RETURN 41 WRITE(L,42) 42 FORMAT(' ENTER ''T'' FOR SHIP-TO-SHIP TRANSMISSION'/' ''R'' FOR SH *IP-TO-SHIP RECEPTION'/' ''J'' TO JAM SUBSPACE FREQUENCIES'/' ''D'' * TO ACTIVATE DISTRESS SIGNAL') GO TO 43 200 CALL ILLDAT GO TO 20 7 DO 8 I=1,4 IF(ICHOE(I).EQ.0)GO TO 8 IF(I.EQ.IT)GO TO 8 I7=I+4 WRITE(I7,9)(INAME(IQ0,IT),IQ0=1,3) 9 FORMAT(' WE ARE RECEIVING A DISTRESS SIGNAL FROM THE ',3A4) 8 CONTINUE WRITE(L,10) 10 FORMAT(' DISTRESS SIGNAL TRANSMITTED') RETURN 6 WRITE(L,11) 11 FORMAT(' ENTER PHASER ENERGY YOU WISH TO EXPEND JAMMING SUBSPACE C *OMMUNICATIONS') READ(L,*,ERR=200)DISTP 12 FORMAT(F15.7) IF(DISTP.GT.PHASR(IT).OR.DISTP.LT.-STATIC(IT))GO TO 20 STATIC(IT)=STATIC(IT)+DISTP PHASR(IT)=PHASR(IT)-DISTP DISTP=STATIC(IT)/5. IF(DISTP.LT.1.)DISTP=1. WRITE(L,13)DISTP 13 FORMAT(' THIS WILL BOOST SUBSPACE INTERFERENCE LEVELS BY A MAXIMUM * OF ',F6.1,' TIMES NORMAL') RETURN 4 WRITE(L,5) 5 FORMAT(' ENTER SHIP YOU WISH TO CONTACT (E,P,H,C): ',$) READ(L,14)NA 14 FORMAT(A1) DO 15 I=1,4 IF(NA.EQ.IEE(I))GO TO 16 15 CONTINUE 20 CALL OOPS(L) RETURN 16 IF(I.NE.IT)GO TO 18 WRITE(L,19) 19 FORMAT(' YOU''RE TALKING TO YOURSELF !?!') GO TO 20 18 IF(ICHOE(I).NE.1)GO TO 20 AJUST=1. DO 21 IV=1,4 IF(STATIC(IT).EQ.0)GO TO 21 DISTP=STATIC(IV)/1000.*(200.-DI(IENTR(IV),IENTC(IV),IENTR(IT), *IENTC(IT))-DI(IENTR(IV),IENTC(IV),IENTR(I),IENTC(I))) IF(DISTP.LT.1.)DISTP=1. AJUST=AJUST*DISTP 21 CONTINUE AJUST=AJUST*DI(IENTR(I),IENTC(I),IENTR(IT),IENTC(IT))*(ISPOT(IT)+1 *)*(ISPOT(I)+1)*2.5 IF(ICHOS(7).EQ.1.OR.AJUST.GT.100.)AJUST=100. 23 WRITE(L,22)AJUST 22 FORMAT(' SUBSPACE INTERFERENCE LEVEL=',F6.2,'% -ENTER PHASER ENERG *Y TO BE USED: ',$) READ(L,12,ERR=200)DISTP IF(DISTP.GT.PHASR(IT).OR.DISTP.LE.0.)GO TO 20 HARLAN=AJUST*AJUST/(5.0*DISTP) IF(HARLAN.GT.AJUST)HARLAN=AJUST WRITE(L,24)HARLAN 24 FORMAT(' INTERFERENCE LEVEL NOW=',F6.2,'% -ENTER CODE (O(HAILING F *REQ) TO 8,STOP): ',$) READ(L,2,ERR=200)MMIN 2 FORMAT(I1) PHASR(IT)=PHASR(IT)-DISTP IF(MMIN.LT.0.OR.MMIN.GT.8)GO TO 20 IF(MMIN.EQ.0.OR.IS.EQ.(IBPSC(I)+1)/2)GO TO 38 WRITE(L,39) 39 FORMAT(' BUT THE OTHER SHIP WON''T BE ABLE TO UNDERSTAND YOU!') GO TO 20 38 IF(I7.EQ.2)GO TO 25 WRITE(L,26) 26 FORMAT(' ENTER YOUR MESSAGE (80 CHARACTERS MAX.)') I8=L GO TO 27 25 I8=IBPSC(I)+4 WRITE(I8,28)(INAME(IQ0,IT),IQ0=1,3) 28 FORMAT(' ENTER ANY MESSAGE YOU HAVE FOR THE ',3A4,' (80 CHARS * MAX.)') 27 READ(I8,29)MES 29 FORMAT(80A1) N=HARLAN*0.8 IF(N.LT.1)N=1 IF(N.GT.150)N=150 DO 32 IV=1,N CALL RANDO(JTK,32,93) JTK=JTK*2 CALL RANDO(ISTAT,1,80) C DECODE(5,320,JTK)MES(ISTAT) C320 FORMAT(A5) 320 READ(JTK,'(A5)')MES(ISTAT) C ATTEMPT #1 TO CONVERT DECODE - THIS IS THE ONLY PLACE DECODE IS USED! 32 CONTINUE IF(I7.EQ.2)GO TO 33 I8=IBPSC(I)+4 WRITE(I8,34)(INAME(IQ0,IT),IQ0=1,3),MES 34 FORMAT(' MESSAGE FROM THE ',3A4/1X,80A1) GO TO 35 33 WRITE(L,34)(INAME(IQ0,I),IQ0=1,3),MES 35 DO 36 JTK=1,4 IF(ICHOE(JTK).NE.1)GO TO 36 IF(JTK.EQ.IT)GO TO 36 IF(JTK.EQ.I)GO TO 36 IF(MMIN.EQ.0)GO TO 37 IF(IS.EQ.(IBPSC(JTK)+1)/2)GO TO 37 IF(KODE(IS,MMIN).EQ.1)GO TO 37 CALL RANDO(IV,1,10) IF(IV.GT.1)GO TO 36 KODE(IS,MMIN)=1 37 I8=IT ISTAT=I IF(I7.EQ.1)GO TO 370 I8=I ISTAT=IT 370 N=IBPSC(JTK)+4 WRITE(N,380)(INAME(IQ0,I8),IQ0=1,3),(INAME(IQ0,ISTAT),IQ0=1,3),MES 380 FORMAT(' WE HAVE INTERCEPTED AND DECODED THE FOLLOWING MESSAGE'/ *' FROM THE ',3A4,' TO THE ',3A4/1X,80A1) 36 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - ORWELL - C SUBROUTINE ORWELL(IBORD,NUM,IROW,ICOL) LOGICAL CYRANO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) JTK=7 IF(JS.EQ.2)JTK=26 I7=MA(IT,JTK)+1 IF(I7.EQ.1)GO TO 15 WRITE(L,20)I7 20 FORMAT(' THE DECK CONTAINING THE TRANSPORTERS HAS RECEIVED'/ *' DAMAGE FACTOR',I3,'. IF THIS IS VERY LARGE, A NUMBER OF'/ *' YOUR PARTY MAY NOT SURVIVE THE TELEPORTATION.') 15 IF(A.EQ.0.OR.B.EQ.0)GO TO 12 NUM=A ICOL=B/100 IROW=B-ICOL*100 GO TO 13 12 WRITE(L,1) 1 FORMAT(' BOARDING PARTY PREPARATION - ENTER NUMBER OF CREW'/ *' TO BE TRANSPORTED DOWN (ENTER A NEGATIVE AMOUNT IF CREW IS TO BE * BEAMED UP)') READ(L,4,ERR=14)NUM 4 FORMAT(I7) WRITE(L,8) 8 FORMAT(' ENTER CO-ORDINATES OF TARGET') READ(L,9,ERR=14)ICOL,IROW 9 FORMAT(2I2) 13 IF(CYRANO(IROW,ICOL))GO TO 10 IBORD=1 RETURN 14 CALL ILLDAT 10 CALL OOPS(L) 5 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C BLOCH - C C- I HAVE THE HEART OF A CHILD C- (I KEEP IT IN A JAR ON MY DESK) SUBROUTINE BLOCH COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(4) IF(LOCK(IT).NE.0)GO TO 901 IF(ICOIL(IT).EQ.1)GO TO 908 IF(PHASR(IT)-ZAP(IT).LT.0)GO TO 902 LOCK(IT)=1 PHASR(IT)=PHASR(IT)-ZAP(IT) WRITE(L,903) 903 FORMAT(' PHASERS RE-LOCKED ON TARGET') GO TO 901 902 WRITE(L,904) 904 FORMAT('-NOT ENOUGH ENERGY TO RE-LOCK PHASERS') GO TO 901 908 WRITE(L,909) 909 FORMAT(' MAIN COIL BURNOUT - PHASERS UNDER REPAIR') 901 IF(LOCKT(IT).NE.0)RETURN IF(IPHOT(IT).LE.0)GO TO 905 LOCKT(IT)=1 IPHOT(IT)=IPHOT(IT)-1 IF(JS.EQ.1)GO TO 900 WRITE(L,910) 910 FORMAT(' DISRUPIOR BOLTS RE-LOCKED ON TARGET') RETURN 900 WRITE(L,906) 906 FORMAT(' PHOTON TORPEDOES RE-LOCKED ON TARGET') RETURN 905 IF(JS.EQ.1)GO TO 911 WRITE(L,912) 912 FORMAT(' NO DISRUPTOR BOLTS LEFT') RETURN 911 WRITE(L,907) 907 FORMAT(' NO PHOTON TORPEDOES LEFT') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C SSSS CCCC OOO TTTTT TTTTT C S C O O T T C SSS C O O T T C S C O O T T C SSSS SSSS OOO T T SUBROUTINE SCOTT INTEGER TRANS(8) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) DATA TRANS/'PW','WP','WD','DW','PD','DP','TD','DD'/ 625 WRITE(L,600)DFLCT(IT),PHASR(IT),TWARP(IT),IPHOT(IT) 600 FORMAT(' DEFLECTORS=',F11.7,', PHASERS=',F13.7,', WARP=',F10.7, *', TORPS=',I3) 6320 IF(DFLCT(IT).LT.0)DFLCT(IT)=0 632 WRITE(L,6331) 6331 FORMAT(' ENTER PW,WP,WD,DW,PD,DP,TD,DD,HELP,STOP: ',$) ZAP=0. READ(L,92,ERR=6461)NA,ZAP 92 FORMAT(A2,1X,F15.7) IF(NA.EQ.'HE')GO TO 651 IF(NA.EQ.'ST')GO TO 6 IF(NA.EQ.'**')GO TO 700 IF(NA.EQ.'??')GO TO 625 627 DO 636 I=1,8 IF(TRANS(I).EQ.NA)GO TO 635 636 CONTINUE GO TO 646 6461 CALL ILLDAT IF(NA.EQ.'HE')GO TO 651 IF(NA.EQ.'ST')GO TO 6 GO TO 646 635 IF(ZAP.NE.0)GO TO 628 WRITE(L,634) 634 FORMAT(' TYPE IN AMOUNT YOU WISH TO TRANSFER: ',$) 660 READ(L,24,ERR=6461)ZAP 24 FORMAT(F15.7) 628 IF(ZAP.LT.0.AND.I.NE.8)GO TO 646 GO TO (637,638,639,640,641,642,643,6601),I 646 CALL OOPS(L) 6 RETURN 637 IF(ZAP.GT.PHASR(IT))GO TO 646 ZAP=ZAP/1000. IF(TWARP(IT)+ZAP.GT.10.)ZAP=10.-TWARP(IT) TWARP(IT)=TWARP(IT)+ZAP PHASR(IT)=PHASR(IT)-1000.*ZAP GO TO 6320 638 IF(ZAP.GT.TWARP(IT))GO TO 646 TWARP(IT)=TWARP(IT)-ZAP PHASR(IT)=PHASR(IT)+ZAP*1000. GO TO 6320 639 IF(ZAP.GT.TWARP(IT))GO TO 646 ZAP=ZAP*10 IF(DFLCT(IT)+ZAP.GT.100.)ZAP=100.-DFLCT(IT) DFLCT(IT)=DFLCT(IT)+ZAP TWARP(IT)=TWARP(IT)-ZAP/10. GO TO 6320 640 IF(ZAP.GT.DFLCT(IT))GO TO 646 ZAP=ZAP/10. IF(TWARP(IT)+ZAP.GT.10.)ZAP=10.-TWARP(IT) TWARP(IT)=TWARP(IT)+ZAP DFLCT(IT)=DFLCT(IT)-ZAP*10. GO TO 6320 641 IF(ZAP.GT.PHASR(IT))GO TO 646 ZAP=ZAP/100. IF(DFLCT(IT)+ZAP.GT.100.)ZAP=100.-DFLCT(IT) DFLCT(IT)=DFLCT(IT)+ZAP PHASR(IT)=PHASR(IT)-ZAP*100. GO TO 6320 642 IF(ZAP.GT.DFLCT(IT))GO TO 646 DFLCT(IT)=DFLCT(IT)-ZAP PHASR(IT)=PHASR(IT)+ZAP*100. GO TO 6320 643 IF(ZAP.GT.FLOAT(IPHOT(IT)))GO TO 646 IF(DFLCT(IT)+6.*ZAP.GT.100.)ZAP=IFIX((100.-DFLCT(IT))/6.) DFLCT(IT)=DFLCT(IT)+6.*ZAP IPHOT(IT)=IPHOT(IT)-IFIX(ZAP) GO TO 6320 651 WRITE(L,650) 650 FORMAT(' TYPE IN 2 LETTERS (A2) - 1ST LETTER IS THE SYSTEM YOU WIS *H TO TRANSFER ENERGY FROM'/' AND THE 2ND LETTER IS WHERE YOU WISH * TO TRANSFER IT TO'/' (WARP ENGINES(W), PHASER BANKS(P), TORPEDO/D *ISRUPTOR BANKS(T),DEFLECTOR SHIELDS(D))'/' (PW,WP,WD,DW,PD, *DP,TD)'/) 38 WRITE(L,39) 39 FORMAT(' 1 WARP = 10 DEFLECTOR SHIELD UNITS = 1000 PHASER UNITS'/ *' 1 PHOTON TORPEDO = 6 DEFLECTOR SHIELD UNITS') WRITE(L,6500) 6500 FORMAT(' THE ''DD'' COMMAND TRANSFERS DEFLECTOR SHIELD ENERGY BETW *EEN SHIPS'/' AS LONG AS YOU ARE WITHIN ONE UNIT OF EACH OTHER. '/ *' WHEN ASKED TO TYPE IN THE AMOUNT OF ENERGY, TYPE A POSITIVE NUMB *ER'/' TO GIVE THE OTHER SHIP THAT AMOUNT OF ENERGY FROM YOUR DEFLE *CTORS.'/' TYPE A NEGATIVE NUMBER TO TAKE THAT AMOUNT OF ENERGY FRO *M'/' THE OTHER SHIP AND PUT IT IN YOUR DEFLECTORS (YOU CAN ONLY TA *KE'/' ENERGY FROM A BOARDED SHIP).'/' YOU''LL ALSO BE ASKED TO ENT *ER THE LETTER OF THE SHIP YOU WISH'/' TO TRANSFER ENERGY WITH - TY *PE ''K'' FOR KLINGON, ''R'' FOR ROMULAN'/' ''Z'' FOR KZINTI, ETC.' *//' IF YOU TYPE ''**'', YOU CAN TRANSFER ENERGY, PERSONNEL AND TOR *PEDOES WITH STARBASE') GO TO 632 6601 WRITE(L,661) 661 FORMAT( ' ENTER LETTER OF SHIP YOU WISH TO TRANSFER ENERGY * WITH: ',$) READ(L,93)NA 93 FORMAT(A1) DO 662 I=1,8 IF(IENM1(I).EQ.NA)GO TO 663 662 CONTINUE GO TO 6460 663 IF(ICHOS(I).EQ.0)GO TO 646 IF(DI(IKLNC(I),IKLNR(I),IENTC(IT),IENTR(IT)).LT.2.)GO TO 665 672 WRITE(L,664) 664 FORMAT(' SHIP OUT OF RANGE') GO TO 6320 665 IF(ZAP.LT.0)GO TO 666 IF(ZAP.GT.DFLCT(IT))GO TO 646 IF(DFLCK(I)+ZAP.GT.100.)ZAP=100.-DFLCK(I) 667 DFLCK(I)=DFLCK(I)+ZAP 678 DFLCT(IT)=DFLCT(IT)-ZAP GO TO 6320 666 IF(IBPSB(I).NE.IS)GO TO 646 IF(DFLCK(I)+ZAP.LT.0)GO TO 646 IF(DFLCT(IT)-ZAP.GT.100.)ZAP=DFLCT(IT)-100. GO TO 667 6460 DO 670 I=1,4 IF(IEE(I).EQ.NA)GO TO 671 670 CONTINUE GO TO 646 671 IF(ICHOE(I).EQ.0.OR.ICHOE(I).EQ.3)GO TO 646 IF(DI(IENTR(I),IENTC(I),IENTR(IT),IENTC(IT)).GE.2.)GO TO 672 IF(ZAP.LT.0)GO TO 676 IF(ZAP.GT.DFLCT(IT))GO TO 646 IF(DFLCT(I)+ZAP.GT.100.)ZAP=100.-DFLCT(I) 677 DFLCT(I)=DFLCT(I)+ZAP GO TO 678 676 IF((IBPSC(I)+1)/2.NE.IS)GO TO 646 IF(ICHOE(I).EQ.1)GO TO 646 IF(DFLCT(I)+ZAP.LT.0)GO TO 646 IF(DFLCT(IT)-ZAP.GT.100.)ZAP=DFLCT(IT)-100. GO TO 677 700 DO 701 I=1,2 IF(ICHOB(I).EQ.0)GO TO 701 IF(IBPSS(I).NE.IS)GO TO 701 IF(DI(IENTR(IT),IENTC(IT),IBASR(I),IBASC(I)).GE.2.)GO TO 701 CALL STONE GO TO 6320 701 CONTINUE WRITE(L,702) 702 FORMAT(' WE ARE NOT DOCKED AT OUR STARBASE') GO TO 6320 END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - STONE - C SUBROUTINE STONE COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /B/NDEAB(2),IPHOB(2),IONB(2),IGOB(2),IFIB(2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) 7 WRITE(L,5)NDEAB(I),NDEAD(IT) 5 FORMAT(' TYPING A NEGATIVE NUMBER TO THE NEXT 3 GUESTIONS WILL CAU *SE THOSE THINGS TO BE'/' TRANSFERRED FROM YOU TO THE STARBASE'/' W *E HAVE',I5,' PERSONNEL, YOU HAVE ',I4,/' HOW MANY DO YOU WISH TO R *EINFORCE YOUR SHIP? ',$) IV=1 READ(L,6,ERR=13)I7 6 FORMAT(I7) IF(I7.GT.NDEAB(I).OR.I7.GT.NDEAD(IT))GO TO 7 NDEAD(IT)=NDEAD(IT)+I7 NDEAB(I)=NDEAB(I)-I7 IF(NDEAB(I).GT.0)ICHOB(I)=1 10 WRITE(L,8)DFLCB(I),DFLCT(IT) 8 FORMAT(' OUR DEFLECTORS=',F11.7,', YOUR DEFLECTORS=',F11.7/' BY HO *W MUCH DO YOU WISH TO BOOST YOUR SHIELDS? ',$) IV=2 READ(L,9,ERR=13)DISTP 9 FORMAT(F15.7) IF(DISTP.GT.DFLCB(I).OR.DISTP.GT.DFLCT(IT))GO TO 10 IF(DFLCT(IT)+DISTP.GT.100.)DISTP=100.-DFLCT(IT) IF(DFLCB(I)-DISTP.GT.300.)DISTP=DFLCB(I)-300. DFLCT(IT)=DFLCT(IT)+DISTP DFLCB(I)=DFLCB(I)-DISTP 12 WRITE(L,11)IPHOB(I),IPHOT(IT) 11 FORMAT(' WE HAVE ',I2,' PHOTON TORPEDOES/DISRUPTOR BOLTS, YOU HAVE *',I3/' HOW MANY DO YOU WISH? ',$) IV=3 READ(L,6,ERR=13)I7 IF(I7.GT.IPHOB(I).OR.I7.GT.IPHOT(IT))GO TO 12 IPHOT(IT)=IPHOT(IT)+I7 IPHOB(I)=IPHOB(I)-I7 1 CONTINUE RETURN 13 CALL ILLDAT GO TO (7,10,12),IV RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - ECCLE - C SUBROUTINE ECCLE(NANU) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /K/IWHO(8),DIST(8),KILLZ,KILLR,KILLD,KILLG,IGOCO(8) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),Ll2R(5),LI2C(5),IGO(4),MINES COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) IF(NANU.EQ.1)GO TO 720 WRITE(L,705) 705 FORMAT(' PLEASE STANDBY......') DO 704 I=1,4 IF(ICHOE(I).NE.1)GO TO 704 IF(I.EQ.IT)GO TO 704 N=IBPSC(I)+4 WRITE(N,703) 703 FORMAT(' A REQUEST HAS BEEN MADE FOR A NEW COMPUTER-CONTROLLED ENE *MY. DO YOU AGREE?') READ(N,702)NA 702 FORMAT(A1) IF(NA.NE.'Y')GO TO 701 704 CONTINUE WRITE(L,716) 716 FORMAT(' ENTER THE LETTER STANDING FOR THE ENEMY YOU WISH IN THE G *AME'/' (''K'' FOR KLINGON, ETC.) ENTER A ''?'' IF YOU WISH AN ENEM *Y CHOSEN AT RANDOM') READ(L,702)NA DO 717 I=1,8 IF(NA.EQ.IENM1(I))GO TO 718 717 CONTINUE 7070 I7=0 DO 706 I=1,7 706 I7=I7+ICHOS(I) IF(I7.GE.6)GO TO 712 707 CALL RANDO(I,1,7) IF(I.EQ.6)GO TO 707 718 IF(ICHOS(I).EQ.1)GO TO 7070 708 CALL RANDO(IKLNR(I),2,59) CALL RANDO(IKLNC(I),2,59) NA=MMAP(IKLNR(I),IKLNC(I)) IF(NA.NE.IBLK.AND.NA.NE.III)GO TO 708 IF(I.NE.8)GO TO 600 IF(NA.EQ.III)GO TO 708 IF(NUMOUT.EQ.0)GO TO 600 WRITE(L,601) 601 FORMAT(' YOU MUST GET RID OF ALL EAGLES BEFORE YOU CAN'/ *' FIGHT ANOTHER MOONBASE') RETURN 600 ICHOS(I)=1 DFLCK(I)=100. IONK(I)=0 ISPOK(I)=0 IBPSB(I)=0 IF(I.NE.7)IBPOB(I)=0 IGOCO(I)=1 JTK=1 IF(I.NE.6)GO TO 719 CALL KZIN CALL NIVEN GO TO 710 719 IF(I.NE.8)GO TO 709 DFLCK(8)=70. LAUNCH=0 IF(LAUNCH.GE.25)GO TO 709 CALL LEGUIN(0,0) 709 CALL ASIMOV(NA,I) MMAP(IKLNR(I),IKLNC(I))=IENM1(I) 710 WRITE(L,711)(IENM2(IV,I),IV=1,4) 711 FORMAT(' REINFORCEMENTS ARE IN THE FORM OF A SHINY NEW'//10X,4A4/) I3=I3+1 ISHAK=0 IF(NOSTOP.EQ.2)NOSTOP=1 RETURN 712 WRITE(L,714) 714 FORMAT(' WHY DON''T YOU TRY FIGHTING THE ENEMIES YOU ALREADY * HAVE?') RETURN 701 DO 700 N=1,4 IF(ICHOE(N).NE.1)GO TO 700 IV=N+4 WRITE(IV,715) 715 FORMAT(' REQUEST FOR ENEMY VETOED') 700 CONTINUE NANU=1 RETURN 720 WRITE(L,721) 721 FORMAT(' REQUEST HAS ALREADY BEEN VETOED - TRY AGAIN NEXT TURN') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 - C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - TRACLC C SUBROUTINE TRACLC LOGICAL LOKI,NOTRAC,CYRANO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) IF(LOKI(IPULL(IT)))RETURN IF(NOTRAC(IT))RETURN IF(A.EQ.0.OR.B.EQ.0)GO TO 58 PULL(IT)=A IPULLC(IT)=B/100. IPULLR(IT)=B-IPULLC(IT)*100. GO TO 59 58 WRITE(L,21)DISTP 21 FORMAT(' RANGE OF BEAM IS, F4. 0, UNITS'/' ENTER TARGET COORD *INATES: ',$) A=0 READ(L,22,ERR=250)IPULLC(IT),IPULLR(IT) 22 FORMAT(2I2) 59 IF(CYRANO(IPULLR(IT),IPULLC(IT)))GO TO 23 26 NA=MMAP(IPULLR(IT),IPULLC(IT)) IF(NA.EQ.IGLE)GO TO 261 IF(NA.EQ.IM(IT))GO TO 261 GO TO 260 261 IF(A.NE.0)GO TO 60 WRITE(L,50) 50 FORMAT(' ENTER DISTANCE YOU WISH TO PULL OBJECT: ',$) READ(L,29,ERR=250)PULL(IT) 60 PULL(IT)=PULL(IT)/10. WRITE(L,51)PULL(IT) 51 FORMAT(' THIS WILL USE ',F10.7,' UNITS OF WARP ENERGY') GO TO 52 260 IF(A.NE.0)GO TO 52 WRITE(L,28) 28 FORMAT(' ENTER THE AMOUNT OF WARP ENERGY YOU WISH TO USE'/' (ENTER * A NEGATIVE NUMBER FOR HELP)') READ(L,29,ERR=250)PULL(IT) 29 FORMAT(F15.7) 52 IF(PULL(IT).EQ.0)GO TO 23 IF(PULL(IT).GT.TWARP(IT))GO TO 264 IF(PULL(IT).GT.0)GO TO 40 WRITE(L,41) 41 FORMAT(' IF THE TARGET IS A SHIP-'/' THE AMOUNT OF ENERGY (E) ENTE *RED WILL SLOW THE RETREATING ENEMY'/' SHIP''S SPEED BY A FACTOR OF * 2**(-E/0. 5)'/' EG. 0.5 WILL CUT THE SHIP''S SPEED IN HALF, '/' 1 *.0 WILL SLOW IT TO 1/4 SPEED, 1.5 WILL SLOW IT TO 1/8 SPEED'//' IF *THE TARGET IS AN EAGLE OR MINE'/' 0.1 UNITS OF WARP ENERGY ARE NEE *DED FOR EACH UNIT THIS OBJECT IS PULL-ED IN'//' IF THE TARGET IS E *MPTY SPACE OR AN ION STORM-NOTHING WILL HAPPEN'//' IF THE TARGET I *S A STAR, DOOMSDAY MACHINE OR MOONBASE ALPHA-'/' NOTHING WILL HAPP *EN AS THE TARGET IS TOO MASSIVE FOR THE TRACTORS'/' TO HANDLE') PULL(IT)=0. IF(A.NE.0)GO TO 58 GO TO 26 40 IPULL(IT)=1 WRITE(L,42) 42 FORMAT(' TRACTORS LOCKED ON TARGET') RETURN 264 WRITE(L,265) 265 FORMAT(' NOT ENOUGH ENERGY TO LOCK BEAM') GO TO 23 250 CALL ILLDAT 23 CALL OOPS(L) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - NOTRAC - C LOGICAL FUNCTION NOTRAC(IT) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) NOTRAC=.FALSE. I7=27 IF(IT.GT.2)I7=5 6 DISTP=9-MA(IT,I7) IF(MA(IT,I7).EQ.0)DISTP=10. IF(MA(IT,I7).NE.9)RETURN WRITE(L,3) 3 FORMAT(' TRACTOR BEAM MACHINERY ROOM HAS BEEN DESTROYED') IPULL(IT)=0 NOTRAC=.TRUE. RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - VULCAN - C SUBROUTINE VULCAN INTEGER PONFAR(6) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) DATA PONFAR/'HE','WE','WA','PH','DO','DI'/ WRITE(L,1) 1 FORMAT(' SPOCK HERE, CAPTAIN.....') 2 WRITE(L,201) 201 FORMAT(' ENTER WEB,WARP,PHASER,DOOM,DIST,HELP FOR HELP,STOP * TO STOP') 8 READ(L,4)NA 4 FORMAT(A2) DO 9 I=1,10 IF(PONFAR(I).EQ.NA)GO TO (10,20,23,24,26,28),I 9 CONTINUE IF(NA.EQ.'ST')GO TO 200 GO TO 6 10 WRITE(L,5) 5 FORMAT(' ENTER ''WEB'' TO LIST PROBABILITIES IF CAUGHT IN A WEB'/ *' ''WARP'' FOR ENGINE PROBABILITIES'/ *' ''PHASER'' FOR PROBS. OF PHASERS AND TORPEDOES/DISRUPTORS'/ *' ''DOOM'' FOR PROBABILITES FOR DOOMSDAY MACHINE'/ *' ''DIST'' TO CALCULATE DISTANCE BETWEEN COORDINATES AND CALCULATE *'/' PROB. OF A PHASER HIT WHEN FIRED AT THE GIVEN COORDINATES'/) GO TO 8 20 WRITE(L,21) 21 FORMAT(' IF WE GO WARP 10, PROB. OF ESCAPING WEB=14.2657142857%'/ *' IF WE GO LESS THAN WARP 10, PROB. OF ESCAPE=0%'/ *' IF WE FIRE A TORPEDO, PROB. THAT IT WILL PENETRATE WEB=25%'/5X, *' PROB. THAT IT WILL NOT PIERCE WEB=50%'/ *5X,' PROB. THAT IT WILL BOUNCE BACK AND STRIKE US=25%') GO TO 2 23 I7=(MA(IT,20)+1)*5 WRITE(L,22)I7 22 FORMAT(' PROB. OF US LOSING STEERING CONTROL AND VEERING OFF COURS *E=',I3,'%'/' IF YOUR NACELLES THREATEN TO RIP OFF IF YOU EXCEED A * CERTAIN SPEED,'/' PROB. THAT IT WILL RIP OFF=(AMOUNT BY WHICH LIM *IT IS EXCEEDED*10+10)%'/' HOWEVER, IF THE LIMIT AT WHICH THE NAC *ELLES THREATEN TO RIP OFF IS WARP 1'/' (IE. THE NACELLE SUPPORT * PYLON IS DESTROYED), THEN IF YOU EXCEED'/' WARP 1, PROB. THAT IT * WILL RIP OFF=100%'/' IF WARP ENERGY GOES BELOW 0. 5, THE WARP ENG *INES WILL BE SHUT DOWN.'/' TO MOVE THEREAFTER YOU WILL HAVE TO BOO *ST WARP ENERGY AND'/' WAIT A TURN TO RE-ENERGIZE THE ENGINES') GO TO 2 24 WRITE(L,25) 25 FORMAT(' PROB. OF TORPS/DISRUPTORS SHORT-CIRCUITING WHEN FIRED=, *7%'/' PROB. OF PHASER BANKS SHORT-CIRCUITING WHEN FIRED=5%'/ *' PROB. OF A MAIN COIL BURNOUT WHEN PHASERS ARE FIRED=5%'/ *10X,' PROB. THAT MAIN COIL WILL BE REPAIRED=28.57%, 33.33%, 40%'/ *10X,' DEPENDING ON REPAIR MODE') GO TO 2 26 WRITE(L,27) 27 FORMAT(' PROB. THAT A PHASER BEAM WILL BOUNCE OFF THE DOOMSDAY MAC *HINE=66. 6666667%'/' PROB. THAT A MINE WILL EXPLODE AND CAUSE DAMA *GE WHEN MACHINE EATS IT=71.4265714%'/' IF YOU GO CLOSER TO THE MAC *HINE THAN THE NEAREST STAR IT WILL EAT YOU'/' YOU CANNOT TRANSPORT * ONTO THE DOOMSDAY MACHINE'/' WHEN THE MACHINE IS DESTROYED, EVERY *THING WITHIN 7 UNITS IS DESTROYED AS WELL') GO TO 2 28 WRITE(L,29) 29 FORMAT(' ENTER THE COORDINATES IN THE FORM AABB,CCDD') READ(L,30,ERR=6)I7,I8,N,IV 30 FORMAT(2I2,1X,2I2) DISTP=DI(I7,I8,N,IV) AJUST=100.-(DISTP*2.5) IF(AJUST.LT.0.)AJUST=0 WRITE(L,31)DISTP,AJUST 31 FORMAT(' DISTANCE=',F/' PROBABILITY OF A PHASER HIT AT THIS DISTAN *CE=',F8.4,'%') GO TO 2 6 WRITE(L,7) 7 FORMAT(' YOUR REQUEST FAILS TO FALL WITHIN LOGICAL PARAMETERS') 200 WRITE(L,3) 3 FORMAT(' SPOCK OUT ......') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - MRESS - C SUBROUTINE MRESS LOGICAL LOKI,CYRANO COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES 11 IF(LOKI(LOCK(IT)))GO TO 12 IF(ICOIL(IT).EQ.0)GO TO 400 WRITE(L,401) 401 FORMAT(' PHASERS INOPERATIVE - MAIN COIL BURNOUT UNDER REPAIR') GO TO 12 400 IF(PHASR(IT).GT.0)GO TO 21 WRITE(L,22) 22 FORMAT(' YOUR PHASER BANKS ARE DEPLETED') GO TO 12 21 DISTP=ZAP(IT) I7=ICOLA(IT) I8=IROWA(IT) IF(A.EQ.0.OR.B.EQ.0)GO TO 210 ZAP(IT)=A ICOLA(IT)=B/100. IROWA(IT)=B-ICOLA(IT)*100 IF(ZAP(IT).LT.0.OR.ZAP(IT).GT.PHASR(IT))GO TO 1200 GO TO 240 210 WRITE(L,23)PHASR(IT) 23 FORMAT(' YOU HAVE ',F6.0,' UNITS OF ENERGY IN YOUR PHASER BANKS * TYPE IN HOW MANY YOU WISH TO USE: ',$) 27 READ(L,24,ERR=1201)ZAP(IT) 24 FORMAT(F15.7) IF(ZAP(IT).LE.0.OR.ZAP(IT).GT.PHASR(IT)+0.0001)GO TO 1200 391 WRITE(L,758) 758 FORMAT(' PLEASE ENTER COORDINATES OF TARGET: ',$) READ(L,507,ERR=1201)ICOLA(IT),IROWA(IT) 507 FORMAT(2I2) 240 IF(CYRANO(IROWA(IT),ICOLA(IT)))GO TO 1200 IF(ICOLA(IT).EQ.IENTC(IT).AND.IROWA(IT).EQ.IENTR(IT))GO TO 1200 WRITE(L,504) 504 FORMAT(' PHASERS LOCKED ON TARGET') PHASR(IT)=PHASR(IT)-ZAP(IT) IF(PHASR(IT).LT.0)PHASR(IT)=0 LOCK(IT)=1 12 RETURN 1200 ZAP(IT)=DISTP ICOLA(IT)=I7 IROWA(IT)=I8 CALL OOPS(L) GO TO 12 1201 CALL ILLDAT GO TO 1200 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - SHADOW - C- THE WEED OF CRIME BEARS BITTER FRUIT SUBROUTINE SHADOW(J) COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP COMMON /B/NDEAB(2),IPHOB(2),IONB(2),IGOB(2),IFIB(2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80) COMMON /K/IWHO(8),DIST(8),KILLZ,KILLR,KILLD,KILLG,IGOCO(8) COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) WRITE(L,1) 1 FORMAT(' ENTER SHIP LETTER (''*'' FOR STARBASE): ',$) READ(L,2)NA 2 FORMAT(A1) IF(NA.NE.ISTAR)GO TO 100 WRITE(L,3) 3 FORMAT(' ENTER STARBASE NUMBER: ',$) READ(L,4,ERR=500)I7 4 FORMAT(I7) DO 5 I=1,2 IF(I7.EQ.IBASE(I))GO TO 6 5 CONTINUE GO TO 501 C- WHO KNOWS WHAT EVIL LURKS IN THE HEARTS OF MEN? 6 IF(IBPSS(I).NE.IS)GO TO 501 IFIB(I)=J DO 7 I8=1,4 IF(ICHOE(I8).EQ.0)GO TO 7 IF((IBPSC(I8)+1)/2.NE.IS)GO TO 7 IV=IBPSC(I8)+4 IF(J.EQ.0)GO TO 8 WRITE(IV,9)ISIDE(1,I),ISIDE(2,I),I7 9 FORMAT(1X,2A5,' STARBASE',I3, ' HAS CEASED FIRING') GO TO 7 8 WRITE(IV,10)ISIDE(1,I),ISIDE(2,I),I7 10 FORMAT(1X,2A5,' STARBASE',I3,' ATTACKING') 7 CONTINUE RETURN 100 DO 105 I=1,8 IF(NA.EQ.IENM1(I))GO TO 106 105 CONTINUE GO TO 501 106 IF(IBPSB(I).NE.IS)GO TO 501 IGOCO(I)=J DO 107 I8=1,4 IF(ICHOE(I8).EQ.0)GO TO 107 IF((IBPSC(I8)+1)/2.NE.IS)GO TO 107 IV=IBPSC(I8)+4 IF(J.EQ.0)GO TO 108 WRITE(IV,109)(IENM2(N,I),N=1,4) 109 FORMAT(1X,4A4,' RETURNING TO NEAREST ALLIED VESSEL') GO TO 107 108 WRITE(IV,110)(IENM2(N,I),N=1,4) 110 FORMAT(1X,4A4,' ATTACKING') 107 CONTINUE RETURN C- THE SHADOW KNOWS!!! 500 CALL ILLDAT 501 CALL OOPS(L) RETURN END