C======================================================================= C * C DONALD ECCLESTONE * C AND * C DAN GAHLINGER * C PRESENT * C - * C T H E H O L Y T E R R O R * C * C TTTTT RRRR EEEEE K K 777777 * C T R R E K K 7 * C T RRRR EEEE KKK 7 * C T R R E K K 7 * C T R R EEEEE K K 7 * C * C======================================================================= C * C COPYRIGHT (C) 1979 DONALD M. ECCLESTONE (VAX/VMS FORTRAN) * C 74 HUNT VILLAGE CRESCENT, LONDON ONTARIO CANADA N6H 4A4 * C NOTE: THE ABOVE ADDRESS IS NO LONGER VALID, SORRY KIDDIES (01/01/93) * C======================================================================= C * C COPYRIGHT (C) 1993 DAN GAHLINGER - (MSDOS/486/AMD-K2-400/FORTRAN) * C INTERNET - DAN@ZEROFUSION.COM --- HTTP://ZEROFUSION.COM/TREK7 * C * C======================================================================= C THE FOLLOWING PUNCHES MAY BE FOUND IN THIS DECK - * C THE ALPHABET -- ABCDEFGHIJKLMNOPQRSTUVWXYZ * C THE DIGITS -- 0123456789 * C 12-8-7 EXCLAMATION MARK !!!!!!!!!!!!!!!!!!!!!!! C 0-8-5 QUOTATION MARK (DOUBLE QUOTE) """"""""""""""""""""""" C 0-8-6 NUMBER SIGN (POUND SIGN) ####################### C 11-8-3 DOLLAR SIGN $$$$$$$$$$$$$$$$$$$$$$$ C 0-8-7 PERCENT SIGN %%%%%%%%%%%%%%%%%%%%%%% C 11-8-7 AMPERSAND &&&&&&&&&&&&&&&&&&&&&&& C 8-4 APOSTROPHE (SINGLE QUOTE) ''''''''''''''''''''''' C 0-8-4 LEFT PARNETHESIS ((((((((((((((((((((((( C 12-8-4 RIGHT PARNETHESIS ))))))))))))))))))))))) C 11-8-4 ASTERISK *********************** C 12 PLUS SIGN +++++++++++++++++++++++ C 0-8-3 COMMA ,,,,,,,,,,,,,,,,,,,,,,, C 11 MINUS SIGN (HYPHEN) (DASH) ----------------------- C 12-8-3 PERIOD (DECIMAL POINT) ....................... C 0-1 SLASH /////////////////////// C 11-0 COLON ::::::::::::::::::::::: C 0-8-2 SEMICOLON ;;;;;;;;;;;;;;;;;;;;;;; C 12-8-6 LEFT ANGLE BRACKET (LESS THAN)<<<<<<<<<<<<<<<<<<<<<<< C 8-3 EQUAL SIGN ======================= C 11-8-6 RIGHT ANGLE BRACKET(GREATER THAN) >>>>>>>>>>>>>>>>>> C 12-0 QUESTION MARK ??????????????????????? C 8-5 AT SIGN @@@@@@@@@@@@@@@@@@@@@@@ C 11-8-5 LEFT SQUARE BRACKET [[[[[[[[[[[[[[[[[[[[[[[ C 8-7 BACKSLASH \\\\\\\\\\\\\\\\\\\\\\\ C 12-8-5 RIGHT SQUARE BRACKET ]]]]]]]]]]]]]]]]]]]]]]] C 8-5 UP-ARROW (CIRCUMFLEX) ^^^^^^^^^^^^^^^^^^^^^^^ C 8-2 BACK-ARROW OR UNDERSCORE _______________________ C======================================================================= C * C A - MAINLINE AND OFT-USED ROUTINES * C B - USER COMMAND ROUTINES * C C - M-O SHIP OPERATIONS * C D - SHIP INITIALIZATION * C E - C-O SHIP OPERATIONS * C F - SHIP DAMAGE ROUTINES * C G - MISC. ROUTINES (C-O WEAPONRY, ION STORMS, M-O NEW TURN, REPAIR) * C * C======================================================================= C * C TREK7 MODULE A * C -- CONVERTED TO PC BY: DAN GAHLINGER -- * C ENTIRE MODULE TYPE-EXACT CHECK 04/26/2000 BY: D.G. * C * C MAINLINE AND OFT-USED ROUTINES * C * C MAINLINE GAMOVR RANDO HORTA CYRANO DI * C ANG FOSTER IXIF LOKI ILLDAT OOPS * C ILLDAS * C * C======================================================================= C***** MODULE NOTE: A.FOR (KLIN <- HANDWRITTEN) ***** C TYPE-EXACT CHECK 04/26/2000 BY: D.G. INTEGER CMAND(26) LOGICAL ITAKA(6) LOGICAL GAMOVR,SULU,SAREK,SPOCK,HARPO,LARRY,CURLY 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCOL(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(4) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /J/KODE(2,8),STATIC(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),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 /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) 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 /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /W/IDEX(2,33,20) COMMON /TOM/ITOM EQUIVALENCE(II(1),I1),(II(2),I2) DATA CMAND/'IN','MA','TR','CO','PH','TO','GO','CA','EA', *'BO','YA','DE','HE','MI','RE','RA','CE','AT','DA','CR','SP', *'EN','NO','SU','HN','VE'/ DATA NNO/'N'/ ITOM=12345 L=5 LLL=6 PRINT 9988 9988 FORMAT(/' DONALD ECCLESTONE (C)1979 AND DAN GAHLINGER (C)1993 * PRESENT'//' T H E H O L Y T E R R O R - * T R E K 7'///) WRITE(LLL,10910) 10910 FORMAT(' TYPE IN A RANDOM NUMBER BETWEEN 1-32767') READ(L,*)ITOM C***** ABOVE WRITE WAS ORIGINALLY 1-99999 ***** CALL HARLIE 946 IGO(1)=0 94 CALL FIZBIN LAST=0 LLAST=0 NOSTOP=0 IO=0 IF(IGO(1).EQ.0)MINES=0 890 DO 128 I=1,4 IGO(I)=0 IF(ICHOE(I).EQ.0)GO TO 128 L=I+4 800 FORMAT(' TYPE HELP FOR HELP') C TEXT TO THIS POINT WAS HAND TYPED 128 CONTINUE 130 IT=0 L=4 129 IT=IT+1 IF(IT.GT.4)GO TO 23310 IBORD=0 L=IBPSC(IT)+4 JS=(IT+1)/2 IS=(IBPSC(IT)+1)/2 IPUSH(IT)=0 IPULL(IT)=0 STATIC(IT)=0 NANU=0 IF(ICHOE(IT).NE.1)GO TO 129 L=5 C JUST MANUALLY SET L TO 5 (ORIGINALLY 4) CALL SAURON 234 WRITE(LLL,10)(INAME(IQ0,IT),IQ0=1,3) 10 FORMAT(/1X,3A4,' COMMAND: ',$) A=0.0 B=0.0 READ(L,920,ERR=3)NA,A,B 920 FORMAT(A2,1X,2F15.7) IGOL(1)=IBLK GO TO 4 3 A=0.0 B=0.0 CALL ILLDAS(IGOL,L) 4 DO 636 I=1,26 IF(CMAND(I).EQ.NA)GO TO (585,517,632,15,11,13,330,670,3001, *680,310,320,571,666,900,700,200,210,360,352,351, *705,350,519,690,695),I 636 CONTINUE WRITE(LLL,800) GO TO 234 C IN 585 CALL INFO GO TO 234 C MA 517 CALL GODOT GO TO 234 C TR 632 CALL SCOTT GO TO 234 C CO 15 CALL AREX GO TO 234 C PH 11 CALL MRESS GO TO 234 C TO 13 CALL CHEKOV GO TO 234 C CA 670 CALL CANCEL(IBORD) GO TO 234 C EA 3001 CALL GOLLUM GO TO 234 C BO 680 CALL ORWELL(IBORD,NUMBO,IRBO,ICBO) GO TO 234 C YA 310 CALL TRACLC GO TO 234 C DE 320 CALL DEFLOC GO TO 234 C HE 571 CALL INST GO TO 234 C MI 666 IF(LOCKT(IT).NE.1)GO TO 668 DISTP=RANG(IT) IF(A.EQ.0)GO TO 6660 RANG(IT)=A GO TO 6661 6660 WRITE(LLL,667) 667 FORMAT(' ENTER RANGE AT WHICH TORPEDO IS TO BECOME A MINE - BETWEE *N 1.5 AND 10') READ(L,*,ERR=66801)RANG(IT) 24 FORMAT(F15.7) 6661 IF(RANG(IT).LT.1.5.OR.RANG(IT).GT.10.)GO TO 6680 GO TO 234 66801 CALL ILLDAT 6680 CALL OOPS(LLL) RANG(IT)=DISTP GO TO 234 668 WRITE(LLL,6683) 6683 FORMAT(' PLEASE USE TORPEDO COMMAND BEFORE THIS COMMAND') GO TO 234 C RE 900 CALL BLOCH GO TO 234 C RA 700 CALL UHURA GO TO 234 C CE 200 CALL SHADOW(1) GO TO 234 C AT 210 CALL SHADOW(0) GO TO 234 C DA 360 I8=0 II8=0 WRITE(LLL,359) 359 FORMAT(' DAMAGE FACTOR- DECK') DO 3611 I=1,33 I7=MA(IT,I)+1 IF(I7.EQ.1)GO TO 3611 I8=1 II8=6 WRITE(LLL,362)I7 362 FORMAT(I3,'-',$) CALL FORBIN(JS,I,L,'+') 3611 CONTINUE IF(I8.EQ.0)WRITE(LLL,3612) 3612 FORMAT(' NO DAMAGE TO SHIP') GO TO 234 C CR 352 WRITE(LLL,1450) 1450 FORMAT(' CREW-') DO 1440 I=1,4 IF(ICHOE(I).NE.1)GO TO 1440 IF(IBPSC(I).EQ.IBPSC(IT))WRITE(LLL,353)NDEAD(I), *(INAME(IQ0,I),IQ0=1,3) 353 FORMAT(1X,I4,' ON ',3A4) 1440 CONTINUE DO 1451 I=1,2 IF(ICHOB(I).EQ.0)GO TO 1451 IF(IBPSS(I).EQ.IS)WRITE(LLL,146)NDEAD(I),IBASE(I) 146 FORMAT(1X,I4,' ON STARBASE',I3) 1451 CONTINUE IF(IBPOB(7).EQ.0)GO TO 354 DO 355 I=1,8 IF(I.EQ.7.OR.ICHOS(I).EQ.0)GO TO 355 IF(IBPOB(I).EQ.0)GO TO 355 IF(IBPSB(I).NE.IS)GO TO 355 WRITE(LLL,356)IBPOB(I),(IENM2(N,I),N=1,4) 356 FORMAT(1X,I4,' ON ',4A4) 355 CONTINUE 354 IF(NUME(IS).EQ.0)GO TO 234 DO 357 I=1,LAUNCH IF(IBPOE(I).EQ.0)GO TO 357 IF(IGLER(I).EQ.0)GO TO 357 IF(IBPSE(I).NE.IS)GO TO 357 WRITE(LLL,358)IBPOE(I),I 358 FORMAT(1X,I4,' ON EAGLE ',I2) 357 CONTINUE GO TO 234 C SP 351 CALL VULCAN GO TO 234 C EN 705 CALL ECCLE(NANU) GO TO 234 C NO 350 NOSTOP=1 GO TO 234 C SU 519 IF(IJ(3-IS).EQ.0)GO TO 5190 DO 170 I=1,4 IF(ICHOE(I).EQ.0)GO TO 170 I7=I+4 II7=I7+1 WRITE(II7,171)(INAME(IQ0,IT),IQ0=1,3) 171 FORMAT(' THE ',3A4,' WISHES TO SURRENDER') 170 CONTINUE ISURR(IT)=1 WRITE(LLL,133) 133 FORMAT(' PRESENT YOUR SURRENDER TO THE NEAREST ENEMY VESSEL') GO TO 234 5190 WRITE(LLL,910)(INAME(IQ0,IT),IQ0=1,3) 910 FORMAT(/' THE STARSHIP ',3A4,' IS NOW RAISING THE WHITE FLAG') WRITE(LLL,91)IBASE((IBPSC(IT)+1)/2),(INAME(IQ0,IT),IQ0=1,3) 91 FORMAT(/' STARBASE',I3,' CALLING THE ',3A4,/' DUE TO YOUR COWAR *DLY SURRENDER, WE HAVE LOST FACE.'/' FOR THIS ACT YOU ARE DEMOTED * TO CESSPOOL CLEANER 4TH CLASS.') C C MMAP(IENTR(IT),IENTC(IT))=IBLK IF(ISPOT(IT).EQ.1)MMAP(IENTR(IT),IENTC(IT))=III ICHOE(IT)=0 IJ(IS)=IJ(IS)-1 II(IS)=II(IS)-1 LAST=L LLAST=LLL IF(I1+I2.EQ.0)GO TO 98 GO TO 129 98 WRITE(LLAST,300) 300 FORMAT(' ANOTHER GAME ?') READ(LAST,92)NA 92 FORMAT(A1) L=LAST LLL=LLAST IF(NNO.NE.NA)GO TO 940 WRITE(LLAST,90) 90 FORMAT('1',15('-'),' KEEP ON TREKKIN'' ',15('-')/'1 IF ANY E *RRORS ARE DETECTED, PLEASE SEND ME A COPY OF THE'/' ERRONEOUS PART *OF THE GAME. ALSO, IF YOU HAVE ANY COMMENTS, '/' COMPLAINTS, COMPL *IMENTS, QUESTIONS OR SUGGESTIONS ABOUT THE'/' PRGGRAM, I AM ANXIOU *S TO HEAR THEM.'/////', CONTACT-'//' DONALD ECCLESTONE,'/,5X, *'C/O DAN GAHLINGER VIA,'/' DAN@ZEROFUSION.COM -',5X) STOP 940 IF(MINES.GT.5)GO TO 946 DO 945 I=1,4 IF(IENTR(I).EQ.0)GO TO 945 MMAP(IENTR(I),IENTC(I))=IBLK IF(ISPOT(I).EQ.1)MMAP(IENTR(I),IENTC(I))=III 945 CONTINUE DO 942 I=1,8 IF(ICHOS(I).EQ.0)GO TO 942 MMAP(IKLNR(I),IKLNC(I))=IBLK IF(ISPOK(I).EQ.1)MMAP(IKLNR(I),IKLNC(I))=III 942 CONTINUE IF(NUMOUT.EQ.0)GO TO 944 DO 943 I=1,25 IF(IGLER(I).NE.0)MMAP(IGLER(I),IGLEC(I))=IBLK 943 CONTINUE 944 IGO(1)=1 WRITE(LLAST,941) 941 FORMAT(' SAME MAP?') READ(LAST,92)NA IF(NA.EQ.NNO)IGO(1)=0 GO TO 94 C HN 690 CONTINUE GO TO 234 C VE 695 CONTINUE WRITE(LLL,696) 696 FORMAT(' 7.0 DEVELOPMENTAL') GO TO 234 C GO 330 IF(IGOL(1).NE.IBLK)GO TO 331 3380 WRITE(LLL,332) 332 FORMAT(' ENTER COMMAND STRING (M,P,T,B,Y,D,C,H FOR HELP)') READ(L,333)IGOL 333 FORMAT(80A1) 331 IF(IGOL(1).NE.'H')GO TO 334 WRITE(LLL,335) 335 FORMAT(' ENTER A STRING OF CHARACTERS INDICATING THE SEQUENCE IN W *HICH'/' YOU WISH TO EXECUTE AN ACTION - TYPE'/' ''M'' TO MOVE'/' ' *'P'' TO FIRE PHASERS'/' ''T'' TO FIRE TORPS/DISRUPTORS'/' ''B'' TO * INITIATE A BOARDING PARTY'/' ''Y'' TO ENGAGE A TRACTOR BEAM'/' AN *D/OR ''D'' TO ENGAGE A DEFLECTOR BEAM. '/' EG. IF YOU WISH TO FIRE * A TORPEDO THEN ENGAGE A TRACTOR BEAM THEN INITIATE A'/' BOARDING * PARTY THEN MOVE THEN FIRE PHASERS THEN ENGAGE A DEFLECTOR BEAM,'/ *' TYPE ''TYBMPD''.'/' NOTE THAT YOU DON''T HAVE TO USE ALL THE CHA *RACTERS-'/' COMMANDS SUCH AS ''M'' OR ''PT'' OR ''BY'' ARE POSSIBL *E.') WRITE(LLL,336) 336 FORMAT(' IF THE FIRST CHARACTER IN THE STRING IS A ''C'','/' THE *GO COMMAND IS CANCELLED') WRITE(LLL,337) 337 FORMAT(' OTHER FORMS--'/' EG. B(M)(PT) -IF THE BOARD IS SUCCESSFUL *, WE MOVE ELSE WE FIRE PHASERS AND TORPEDOES.'/' THUS THE BACKUS-N *AUR FORM OF THE GO-LINE IS-'/' ::= / (< *GO-LINE>)() / () / NIL'/'::=M */P/T/B/Y/D'/' CAUTION -THE GO-LINE SHOULD BE 80 CHARACTERS OR LESS * IN LENGTH AND SHOULD NOT NEST MORE THAN 6 LEVELS.') GO TO 3380 334 IF(IGOL(1).EQ.'C')GO TO 234 LNA=0 MOVE=0 IGO(IT)=2 LVL=1 ITAKA(1)=.FALSE. 338 IF(ICHOE(IT).NE.1)GO TO 129 339 LNA=LNA+1 ISTAT=0 IF(LNA.LE.80)GO TO 340 343 IF(TWARP(IT).LT.0.5)GO TO 129 IF(NOMOV(IT).EQ.1)GO TO 129 IF(MA(IT,29).EQ.9.AND.MA(IT,30).EQ.9)GO TO 129 CALL ENTEMP(MOVE) IF(GAMOVR(LAST))GO TO 98 GO TO 129 340 IF(IGOL(LNA).EQ.IBLK)GO TO 339 IF(IGOL(LNA).NE.'(')GO TO 341 IF(ITAKA(LVL))GO TO 342 CALL FOSTER(LNA) ITAKA(LVL)=.TRUE. GO TO 339 342 LVL=LVL+1 IF(LVL.GT.6)GO TO 343 ITAKA(LVL)=.FALSE. GO TO 339 341 IF(IGOL(LNA).NE.')')GO TO 344 LVL=LVL-1 IF(LVL.LE.0)GO TO 343 ITAKA(LVL)=.FALSE. GO TO 339 344 ITAKA(LVL)=.FALSE. IF(IGOL(LNA).NE.'M')GO TO 345 IF(NOMOV(IT).EQ.0)GO TO 346 WRITE(LLL,3470) 3470 FORMAT(' MOVEMENT IMPOSSIBLE UNTIL ENGINES RE-ENERGIZED') GO TO 339 346 MOVE=MOVE+1 IF(MOVE.GT.1)GO TO 343 ITAKA(LVL)=SULU(J) GO TO 347 345 IF(IGOL(LNA).NE.'P')GO TO 348 IF(LOCK(IT).EQ.1)ITAKA(LVL)=SAREK(J) GO TO 347 348 IF(IGOL(LNA).NE.'T')GO TO 349 IF(LOCKT(IT).EQ.1)ITAKA(LVL)=SPOCK(J) GO TO 347 349 IF(IGOL(LNA).NE.'B')GO TO 365 IF(IBORD.EQ.1)ITAKA(LVL)=HARPO(IBORD,NUMBO,IRBO,ICBO) GO TO 347 365 IF(IGOL(LNA).NE.'Y')GO TO 366 IF(IPULL(IT).EQ.1)ITAKA(LVL)=LARRY(J) GO TO 347 366 IF(IGOL(LNA).NE.'D')GO TO 343 IF(IPUSH(IT).EQ.1)ITAKA(LVL)=CURLY(J) 347 IF(GAMOVR(LAST))GO TO 98 GO TO 339 23310 DO 23312 I=1,2 IF(ICHOB(I).NE.1)GO TO 23312 IF(NDEAB(I).LE.0)GO TO 23313 IF(IFIB(I).EQ.1)GO TO 23313 IF(DFLCB(I).LE.25.)GO TO 23313 CALL BALOK 23313 IF(IONB(I).NE.0)CALL TALOS IF(IGOB(I).EQ.0)DFLCB(I)=DFLCB(I)+10. IF(DFLCB(I).GT.300.)DFLCB(I)=300. IGOB(I)=0 23312 CONTINUE IF(GAMOVR(LAST))GO TO 98 23311 CALL ATACK IF(GAMOVR(LAST))GO TO 98 CALL ENEMY DO 301 MI=1,4 IF(ION(MI).NE.0.OR.ISPOT(MI).NE.0)CALL FINNEY(MI) 301 CONTINUE IF(GAMOVR(LAST))GO TO 98 GO TO 130 END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C BLOCK DATA 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) DATA IENM1/'K','R','T','G','O','Z','D','A'/ DATA IENM2/'KLIN','GON ','WARS' *,'HIP ','ROMU','LAN ','WARS','HIP ','THOL','IAN ','WARS','HIP ', *'GORN',' WAR', 'SHIP',' ','ORIO', 'N PR','IVAT','EER ', *'KZIN','TI W','ARSH','IP ','DOOM', *'SDAY',' MAC','HINE','MOON','BASE',' ALP','HA '/ DATA IBLK,ISTAR,III,IGLE/' ','*','I','='/ DATA IEE/'E','P','H','C'/,INAME/'ENTE','RPRI','SE ','POTE', *'MPKI','N ','HAVO','C ',' ', *'CARN','AGE ',' '/,ISIDE/'FEDE','RATI','ON ', *'KLIN','GON ',' ' */,IM/'1','2','3','4'/ END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- c TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - GAMOVR C LOGICAL FUNCTION GAMOVR(LAST) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) 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) GAMOVR=.FALSE. 546 DO 762 I=1,8 IONK(I)=0 IF(ICHOS(I).NE.0.AND.DFLCK(I).LT.0)CALL HADES 762 CONTINUE DO 154 I=1,2 IF(ICHOB(I).EQ.0)GO TO 154 J=IBPSS(I) IF(DFLCB(I).GE.0)GO TO 155 CALL EREBUS GO TO 1540 155 IF(NDEAB(I).GT.0)GO TO 154 IF(ICHOB(I).EQ.2)GO TO 154 CALL CHARON 1540 II(J)=II(J)-1 154 CONTINUE DO 134 I=1,4 IF(ICHOE(I).EQ.0.OR.ICHOE(I).EQ.3)GO TO 134 IF(DFLCT(I).GE.0)GO TO 2320 CALL STYX IF(I7.EQ.2)GO TO 1341 GO TO 1340 2320 IF(ICHOE(I).EQ.2)GO TO 134 IF(NDEAD(I).GT.0)GO TO 134 CALL BELIAL 1340 J=(IBPSC(I)+1)/2 IJ(J)=IJ(J)-1 II(J)=II(J)-1 1341 LAST=IBPSC(I)+4 134 CONTINUE IF(IJ(1)+IJ(2).EQ.0)GO TO 98 IF(ISHAK.EQ.1)GO TO 100 IF(II(1).NE.0.AND.II(2)+I3.EQ.0)GO TO 139 IF(II(2).NE.0.AND.II(1)+I3.EQ.0)GO TO 139 GO TO 100 139 IF(NOSTOP.EQ.2)GO TO 100 DO 1400 I=1,4 IF(ICHOE(I).NE.1)GO TO 1400 J=I+4 JJJ=J+1 JTK=(IBPSC(I)+1)/2 WRITE(JJJ,767)(ISIDE(IQ0,JTK),IQ0=1,3),IBASE(JTK), *(INAME(IQ0,I),IQ0=1,3) 767 FORMAT(1X,3A4,' STARBASE',I3,' CALLING THE',3A4,/' *S, CAPTAIN - OUR SIDE HAS DEFEATED THE ENEMY') LAST=J IF(NOSTOP.EQ.1)WRITE(JJJ,7650) 7650 FORMAT(' CONTINUING ..........') 1400 CONTINUE IF(NOSTOP.EQ.0)GO TO 98 NOSTOP=2 GO TO 100 98 GAMOVR=.TRUE. 100 ISTAT=0 RETURN END C --DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - RANDO - C SUBROUTINE RANDO(IX,IY,IZ) COMMON /TOM/ITOM INTEGER*2 ISHRT,ISHIT REAL RT ISHRT=ITOM ISHIT=ITOM C this is a kludge to make the VMS random num. gen. to work. C PRINT 22222,IX,IY,IZ C22222 FORMAT(//' TOP OF RANDO IX=',I6,' IY=',I6,' IZ=',I6//) C RT=RAN(ISHRT,ISHIT) C above line and next line to fix RAN call for other compilers (non-vax) c thus this code may no longer work on the vax RT=RAN(ITOM) ITOM=IFIX(RT*10000.) 4 TEMP=FLOAT(MOD(ITOM,100))/100. IX=(IZ-IY+1)*TEMP+IY C PRINT 22233,IX,IY,IZ C22233 FORMAT(//' END OF RANDO IX=',I6,' IY=',I6,' IZ=',I6//) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - HORTA - C SUBROUTINE HORTA(ISTR,ISTC,ITAR,ITAC,RAD,BERNG,IL,AJUS,IGNOR, *DIST,KPLOT) INTEGER KPLOT(10),INTER(19) LOGICAL CYRANO COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 DATA INTER/'E','P','H','C','K','R','T','G','O','Z','D','A','*', *'=','1','2','3','4','I'/ IF(IO.EQ.1)PRINT 1970,N,ISTR,ISTC,ITAR,ITAC,RAD,BERNG,AJUS, *IGNOR 1970 FORMAT(' BEGIN HORTA N=',I5,' ISTR=',I5,' ISTC=',I5,' ITAR=',I5, *' ITAC=',I5,' RAD=',F15.7,' BERNG=',F15.7,' AJUS=',F15.7, *' IGNOR=',I5) IDIST=0 DISTP=0.0 I7=ISTR I8=ISTC IL=1 J=0 M=0 IF(N.GT.2)GO TO 2 X=DI(ITAC,ITAR,ISTC,ISTR) PRINT 12345,X 12345 FORMAT(//' HORTA (TREKA) X=',I7//) SINA=FLOAT(ITAR-ISTR)/X COSA=FLOAT(ITAC-ISTC)/X GO TO 3 2 SINA=SIN(BERNG+AJUS) COSA=COS(BERNG+AJUS) 3 IF(SINA.NE.0.AND.COSA.NE.0)GO TO 4 DISTP=DISTP+1.00 IF(SINA.EQ.0)M=M+1 IF(COSA.EQ.0)J=J+1 GO TO 5 4 D1=ABS(FLOAT(J+1)/SINA) D2=ABS(FLOAT(M+1)/COSA) IF(ABS(D1-D2).LE.0-02)GO TO 60 IF(D1.GT.D2)GO TO 6 DISTP=D1 J=J+1 GO TO 5 60 DISTP=D1 J=J+1 M=M+1 GO TO 5 6 DISTP=D2 M=M+1 5 IF(DISTP.GT.RAD)GO TO 7 I7=ISTR+SIGN(FLOAT(J),SINA) I8=ISTC+SIGN(FLOAT(M),COSA) IF(CYRANO(I7,I8))GO TO 8 21 NA=MMAP(I7,I8) IF(NA.NE.INTER(19))GO TO 22 IF(IGNOR.EQ.1)GO TO 19 GO TO 15 22 IF(NA.NE.IBLK)GO TO 9 19 IF(N.NE.3)GO TO 13 IF(IFIX(DISTP).NE.IFIX(DISTP)/2*2)GO TO 3 IF(IDIST.EQ.IFIX(DISTP))GO TO 3 KPLOT(IL)=I8 KPLOT(IL+1)=I7 IDIST=IFIX(DISTP) IL=IL+2 GO TO 3 9 DO 10 MMIN=1,18 IF(MMIN.EQ.IV)GO TO 10 IF(NA.NE.INTER(MMIN))GO TO 10 IF(MMIN.NE.10)RETURN IF(I8.NE.IKLNC(6))GO TO 10 IF(I7.EQ.IKLNR(6))RETURN 10 CONTINUE GO TO 13 8 MMIN=20 RETURN 7 MMIN=21 RETURN 13 IF(ISTAT.EQ.11)MMAP(I7,I8)=INTER(19) IF(N.EQ.5)GO TO 17 IF(N.NE.1)GO TO 3 IF(I7.NE.ITAR)GO TO 3 IF(I8.NE.ITAC)GO TO 3 MMIN=22 RETURN 15 MMIN=19 RETURN 17 Q=DI(ITAC,ITAR,I8,I7) IF(Q.LT.DIST)DIST=Q GO TO 3 END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - CYRANO C LOGICAL FUNCTION CYRANO(IR,IC) CYRANO=.FALSE. IF(IR.LT.1.OR.IR.GT.60.OR.IC.LT.1.OR.IC.GT.60)CYRANO=.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/26/2000 BY: D.G. C C - DI - C FUNCTION DI(I,J,K,L) DI=SQRT(FLOAT((I-K)**2+(J-L)**2)) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - ANG C FUNCTION ANG(IVR,IVC) IF(IVC.NE.0)GO TO 1 ANG=90. GO TO 2 1 ANG=ABS(ATAN(FLOAT(IVR)/FLOAT(IVC)))*180./3.14159265 2 IF(IVC.LT.0.AND.IVR.GE.0)ANG=180.-ANG IF(IVC.LT.0.AND.IVR.LT.0)ANG=180.+ANG IF(IVC.GE.0.AND.IVR.LT.0)ANG=360.-ANG RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - FOSTER C SUBROUTINE FOSTER(LNA) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN I7=1 1 LNA=LNA+1 IF(LNA.GT.80)GO TO 2 IF(IGOL(LNA).EQ.'(')I7=I7+1 IF(IGOL(LNA).EQ.')')I7=I7-1 IF(I7.NE.0)GO TO 1 2 RETURN END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E. K C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C -IXIF - C INTEGER FUNCTION IXIF(IVV) IXIF=IVV IF(IVV.LT.0)IXIF=0 IF(IVV.GT.10)IXIF=10 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - LOKI - C LOGICAL FUNCTION LOKI(IP) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN LOKI=.FALSE. IF(IP.NE.1)RETURN LOKI=.TRUE. WRITE(LLL,1) 1 FORMAT(' WEAPON PREVIOUSLY LOCKED') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 - C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C ILLDAT - C C WHEN FOROTS VERSION 5 DETECTS AN INPUT ERROR, IT BACKSPACES TO THE C BEGINNING OF THE ILLEGAL RECORD, AND A BRANCH IS MADE TO THE STATEMENT C SPECIFIED BY ERR IN THE READ STATEMENT. THIS ROUTINE IS CALLED TO C CLEAR OUT THIS RECORD SO THE NEXT READ WILL GET DATA FROM THE TTY. SUBROUTINE ILLDAT COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN READ(L,1) 1 FORMAT(1X) RETURN END C C C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C- OOPS - C SUBROUTINE OOPS(LLL) WRITE(LLL,1) 1 FORMAT(' ILLEGAL ENTRY - COMMAND CANCELLED') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - ILLDAS C SUBROUTINE ILLDAS(IGOL,L) DIMENSION IGOL(80) READ(L,1)IGOL 1 FORMAT(3X,80A1) RETURN END 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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(LLL,673) 673 FORMAT(' TORPEDO/DISRUPTOR COMMAND CANCELLED') GO TO 6711 674 IBORD=0 WRITE(LLL,675) 675 FORMAT(' BOARD COMMAND CANCELLED') GO TO 6711 6700 IPULL(IT)=0 WRITE(LLL,6702) 6702 FORMAT(' YANK COMMAND CANCELLED') GO TO 6711 6701 IPUSH(IT)=0 WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,3) 3 FORMAT(' WEAPON LOCKED ON TARGET') RETURN 130 ANGLE(IT)=DISTP CALL OOPS(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,53) 53 FORMAT(' ENTER DISTANCE YOU WISH TO PUSH OBJECT: ',$) READ(L,*,ERR=250)PUSH(IT) 29 FORMAT(F15.7) 63 WRITE(LLL,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(LLL,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(LLL,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(LLL,37) 37 FORMAT(' DEFLECTORS LOCKED ON TARGET') RETURN 264 WRITE(LLL,265) 265 FORMAT(' NOT ENOUGH ENERGY TO LOCK BEAM') GO TO 23 250 CALL ILLDAT 23 CALL OOPS(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL) 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(LLL,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 INA=NA+1 WRITE(INA,'(I1)')JTK JTK=IV1-JTK*10 C ENCODE(1,5174,NA)JTK 5174 WRITE(INA,'(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(LLL,5172)IV1,(LEN2(I),I=1,JTK),NB,NA 5172 FORMAT(I3,33A1) WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,302) 302 FORMAT(' EAGLES-'/) I7=0 DO 301 I=1,LAUNCH IF(IGLER(I).EQ.0)GO TO 301 I7=I7+1 WRITE(LLL,303)I,IGLEC(I),IGLER(I) 303 FORMAT('+',I2,' - (',I2,',',I2,') ',$) IF(I7.NE.5)GO TO 301 I7=0 WRITE(LLL,304) 304 FORMAT(/' ',$) 301 CONTINUE WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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(LLL,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(LLL,757)(IENM2(I,2),I=1,4) 757 FORMAT(1X,4A4,7X,'UNKNOWN UNKNOWN') GO TO 760 763 WRITE(LLL,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(LLL,755)(IENM2(I,6),I=1,4),DFLCK(6),IKLNC(6),IKLNR(6) GO TO 760 91 WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN WRITE(LLL,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(LLL,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(LLL,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(LLL,800) 800 FORMAT(' IF YOU WISH TO ENTER THE COORDINATES (60,60) OR (1, 1), *'/' TYPE 6060 OR 0101.') WRITE(LLL,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(LLL,33) 33 FORMAT(' IF WE ENTER AN ION STORM WE WILL RECEIVE DAMAGE'/' AND O *UR SPEED WILL BE CUT IN HALF') WRITE(LLL,38) 38 FORMAT(' ENEMY STRATEGY AND STRENGTH-') 34 WRITE(LLL,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(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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 II7=I7+1 WRITE(II7,9)(INAME(IQ0,IT),IQ0=1,3) 9 FORMAT(' WE ARE RECEIVING A DISTRESS SIGNAL FROM THE ',3A4) 8 CONTINUE WRITE(LLL,10) 10 FORMAT(' DISTRESS SIGNAL TRANSMITTED') RETURN 6 WRITE(LLL,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(LLL,13)DISTP 13 FORMAT(' THIS WILL BOOST SUBSPACE INTERFERENCE LEVELS BY A MAXIMUM * OF ',F6.1,' TIMES NORMAL') RETURN 4 WRITE(LLL,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(LLL) RETURN 16 IF(I.NE.IT)GO TO 18 WRITE(LLL,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(LLL,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(LLL,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(LLL,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(LLL,26) 26 FORMAT(' ENTER YOUR MESSAGE (80 CHARACTERS MAX.)') I8=L GO TO 27 25 I8=IBPSC(I)+4 II8=I8+1 WRITE(II8,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 II8=I8+1 WRITE(II8,34)(INAME(IQ0,IT),IQ0=1,3),MES 34 FORMAT(' MESSAGE FROM THE ',3A4/1X,80A1) GO TO 35 33 WRITE(LLL,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 NNN=N+1 WRITE(NNN,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,903) 903 FORMAT(' PHASERS RE-LOCKED ON TARGET') GO TO 901 902 WRITE(LLL,904) 904 FORMAT('-NOT ENOUGH ENERGY TO RE-LOCK PHASERS') GO TO 901 908 WRITE(LLL,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(LLL,910) 910 FORMAT(' DISRUPIOR BOLTS RE-LOCKED ON TARGET') RETURN 900 WRITE(LLL,906) 906 FORMAT(' PHOTON TORPEDOES RE-LOCKED ON TARGET') RETURN 905 IF(JS.EQ.1)GO TO 911 WRITE(LLL,912) 912 FORMAT(' NO DISRUPTOR BOLTS LEFT') RETURN 911 WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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(LLL) 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(LLL,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(LLL,39) 39 FORMAT(' 1 WARP = 10 DEFLECTOR SHIELD UNITS = 1000 PHASER UNITS'/ *' 1 PHOTON TORPEDO = 6 DEFLECTOR SHIELD UNITS') WRITE(LLL,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(LLL,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(LLL,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(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,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(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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 NNN=N+1 WRITE(NNN,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(LLL,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(LLL,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(LLL,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(LLL,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 IVI=IV+1 WRITE(IVI,715) 715 FORMAT(' REQUEST FOR ENEMY VETOED') 700 CONTINUE NANU=1 RETURN 720 WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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(LLL,50) 50 FORMAT(' ENTER DISTANCE YOU WISH TO PULL OBJECT: ',$) READ(L,29,ERR=250)PULL(IT) 60 PULL(IT)=PULL(IT)/10. WRITE(LLL,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(LLL,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(LLL,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(LLL,42) 42 FORMAT(' TRACTORS LOCKED ON TARGET') RETURN 264 WRITE(LLL,265) 265 FORMAT(' NOT ENOUGH ENERGY TO LOCK BEAM') GO TO 23 250 CALL ILLDAT 23 CALL OOPS(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,1) 1 FORMAT(' SPOCK HERE, CAPTAIN.....') 2 WRITE(LLL,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(LLL,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(LLL,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(LLL,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(LLL,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(LLL,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(LLL,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(LLL,31)DISTP,AJUST 31 FORMAT(' DISTANCE=',F/' PROBABILITY OF A PHASER HIT AT THIS DISTAN *CE=',F8.4,'%') GO TO 2 6 WRITE(LLL,7) 7 FORMAT(' YOUR REQUEST FAILS TO FALL WITHIN LOGICAL PARAMETERS') 200 WRITE(LLL,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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,401) 401 FORMAT(' PHASERS INOPERATIVE - MAIN COIL BURNOUT UNDER REPAIR') GO TO 12 400 IF(PHASR(IT).GT.0)GO TO 21 WRITE(LLL,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(LLL,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(LLL,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(LLL,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(LLL) 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),LLL,II1,INA,IVI,II7,II8,NNN 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(LLL,1) 1 FORMAT(' ENTER SHIP LETTER (''*'' FOR STARBASE): ',$) READ(L,2)NA 2 FORMAT(A1) IF(NA.NE.ISTAR)GO TO 100 WRITE(LLL,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 IVI=IV+1 IF(J.EQ.0)GO TO 8 WRITE(IVI,9)ISIDE(1,I),ISIDE(2,I),I7 9 FORMAT(1X,2A5,' STARBASE',I3, ' HAS CEASED FIRING') GO TO 7 8 WRITE(IVI,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 IVI=IV+1 IF(J.EQ.0)GO TO 108 WRITE(IVI,109)(IENM2(N,I),N=1,4) 109 FORMAT(1X,4A4,' RETURNING TO NEAREST ALLIED VESSEL') GO TO 107 108 WRITE(IVI,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(LLL) RETURN END C===================================================== C C TREK7 MODULE C C C M-0 SHIP OPERATIONS C C SULU DUNSEL LAUREL HARDY SPOCK SAREK C MUDD HARPO TPRING CHICO ZEPPO TANRU C LARRY CURLY MOE C C===================================================== C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C SSSS U U L U U C S U U L U U C SSS U U L U U C S U U L U U C SSSS UUU LLLLL UUU LOGICAL FUNCTION SULU(J) LOGICAL CYRANO C C integer itzro,itvl1 real rtzro,rtvl1 C inserted to take care of call list problems C*** 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCOL(4) COMMON /I/IDNK(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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM SULU=.FALSE. ISTAT=0 IF(ITCOL(IT).EQ.IENTC(IT).AND.ITROW(IT).EQ.IENTR(IT))GO TO 1002 IF(MA(IT,29).NE.9.OR.MA(IT,30).NE.9)GO TO 110 IF(MA(IT,28).EQ.9)GO TO 111 IF(WARP(IT).LT.2.0)GO TO 110 WARP(IT)=1.5 WRITE(LLL,113) 113 FORMAT(' WARP ENGINE NACELLES ARE DESTROYED AND THUS WARP GREATER * THAN 1 IS IMPOSSIBLE') GO TO 110 111 WRITE(LLL,112) 112 FORMAT(' ALL ENGINES ARE DESTROYED - MOVEMENT IMPOSSIBLE') WARP(IT)=0.0 RETURN 110 DO 1000 J=1,2 IF(IWEB(J).NE.IT)GO TO 1000 IF(WARP(IT).LT.10.)GO TO 1000 CALL RANDO(IV,1,7) IF(IV.GT.1)GO TO 1000 IWEB(J)=0 WRITE(LLL,1001)(INAME(IQ0,IT),IQ0=1,3) 1001 FORMAT(' THE ',3A4,' HAS BROKEN FREE OF THE WEB') 1000 CONTINUE IF(IWEB(1).NE.IT.AND.IWEB(2).NE.IT)GO TO 1004 WRITE(LLL,1003)(INAME(IQ0,IT),IQ0=1,3) 1003 FORMAT(' THE ',3A4,' IS TRAPPED IN A WEB') RETURN 1004 DO 100 J=1,2 IF(MA(IT,J+30).EQ.0.OR.MA(IT,J+28).EQ.9)GO TO 100 IF(MA(IT,J+30).EQ.9.AND.WARP(IT).GT.1.)GO TO 109 IF(HIVEL(IT,J).GE.WARP(IT))GO TO 100 I7=10*(WARP(IT)-HIVEL(IT,J)) IF(I7.GT.0)I7=I7+10 CALL RANDO(IV,1,100) IF(IV.GT.I7)GO TO 100 109 CALL LAUREL(J) 100 CONTINUE 205 IF(WARP(IT).GT.TWARP(IT))WARP(IT)=TWARP(IT) 1002 IF(WARP(IT).LE.1.)GO TO 10020 CALL RANDO(I7,1,100) IF(I7.GT.(MA(IT,20)+1)*3)GO TO 10020 J=IFIX(TWARP(IT)) IF(J.EQ.0)RETURN WRITE(LLL,200) 200 FORMAT(' SHORT-CIRCUIT IN WARP DRIVE ENGINEERING ROOM-'/' OUR SHIP * HAS LOST STEERING CONTROL AND IS VEERING OFF COURSE') 201 CALL RANDO(IV,0,J) CALL RANDO(I7,IENTR(IT)-IV,IENTR(IT)+IV) CALL RANDO(I8,IENTC(IT)-IV,IENTC(IT)+IV) IF(CYRANO(I7,I8))GO TO 201 NA=MMAP(I7,I8) IF(NA.NE.IBLK.AND.NA.NE.III)GO TO 201 J=0 GO TO 5327 10020 IF(ITCOL(IT).EQ.IENTC(IT).AND.ITROW(IT).EQ.IENTR(IT))GO TO 600 Q=WARP(IT) BERNG=ANG(ITROW(IT)-IENTR(IT),ITCOL(IT)-IENTC(IT)) DO 224 I7=1,4 IF(ICHOE(I7).NE.1)GO TO 224 IF(I7.EQ.IT)GO TO 224 MMIN=0 CALL DUNSEL(IENTR(IT),IENTC(IT),Q,BERNG) IF(MMIN.LT.2)GO TO 222 MMIN=MMIN-2 WRITE(LLL,223)(INAME(IQ0,I7),IQ0=1,3) 223 FORMAT(' THE ',3A4,' HAS US CAUGHT IN A DEFLECTOR BEAM') 222 IF(MMIN.EQ.0)GO TO 224 WRITE(LLL,225)(INAME(IQ0,I7),IQ0=1,3) 225 FORMAT(' THE ',3A4,' HAS US CAUGHT IN A TRACTOR BEAM') 224 CONTINUE IF(Q.LT.1.)RETURN N=1 IV=IT IGNORE=0 itzro=0 rtzro=0.0 itvl1=1 770 CALL HORTA(IENTR(IT),IENTC(IT),ITROW(IT),ITCOL(IT),Q, *rtzro,itvl1,rtzro,IGNORE,rtzro,itzro) J=0 IF(MMIN.GT.12)GO TO 532 DFLCT(IT)=-1. IF(MMIN.LT.5)GO TO 166 MMIN=MMIN-4 DO 1390 J=1,4 IF(ICHOE(J).EQ.0)GO TO 1390 N=J+4 NNN=N+1 WRITE(NNN,235)(INAME(IQ0,IT),IQ0=1,3),(IENM2(IV,MMIN),IV=1,4) 235 FORMAT(' THE ', 3A4, ' HAS COLLIDED WITH THE ',4A4/' WHICH HAS * EXPLODED') 1390 CONTINUE DFLCK(MMIN)=-1. GO TO 343 166 DO 167 J=1,4 IF(ICHOE(J).EQ.0)GO TO 167 N=J+4 NNN=N+1 WRITE(NNN,168)(INAME(IQ0,IT),IQ0=1,3),(INAME(IQ0,MMIN),IQ0=1,3) 168 FORMAT(' THE ',3A4,' HAS RAMMED THE ',3A4) 167 CONTINUE DFLCT(MMIN)=-1. 343 MMAP(I7,I8)=IBLK MMAP(IENTR(IT),IENTC(IT))=IBLK IF(ISPOT(IT).EQ.1)MMAP(IENTR(IT),IENTC(IT))=III RETURN 532 IF(MMIN.NE.13)GO TO 5330 5320 WRITE(LLL,535) 535 FORMAT(' OUR COURSE IS BLOCKED BY A STAR') IV1=I7 IVV=I8 rtvl1=1.5 itvl1=1 itzro=0 rtzro=0.0 CALL HORTA(IV1,IVV,IENTR(IT),IENTC(IT),rtvl1,rtzro,itzro, *rtzro,itvl1,rtzro,itzro) 5327 MMAP(IENTR(IT),IENTC(IT))=IBLK IF(ISPOT(IT).EQ.1)MMAP(IENTR(IT),IENTC(IT))=III ISPOT(IT)=0 IENTR(IT)=I7 IENTC(IT)=I8 IF(IGO(IT).EQ.2)IGO(IT)=1 IF(MMAP(IENTR(IT),IENTC(IT)).EQ.III)ISPOT(IT)=1 IF(J.EQ.1)GO TO 770 MMAP(IENTR(IT),IENTC(IT))=IEE(IT) IF(IENTR(IT).NE.ITROW(IT).OR.IENTC(IT).NE.ITCOL(IT))GO TO 550 600 WRITE(LLL,601) 601 FORMAT(' WE''VE REACHED TARGET COORDINATES') SULU=.TRUE. 550 DO 552 I7=1,5 IF(LI2R(I7).EQ.0)GO TO 552 IF(LI2(IT).EQ.I7)GO TO 552 IF(IABS(IENTR(IT)-LI2R(I7)).GT.5)GO TO 552 IF(IABS(IENTC(IT)-LI2C(I7)).GT.5)GO TO 552 CALL RANDO(I8,1,12) WRITE(LLL,553)I8,LI2C(I7),LI2R(I7) 553 FORMAT(' SENSORS DETECT A DEPOSIT OF DILITHIUM CRYSTALS ON PLANET * ',I2/' OF SYSTEM (',I2,',',I2,'). ACQUISITION OPERATIONS WILL COM *MENCE'/' IF WE CLOSE TO WITHIN 1 UNIT OF THE SYSTEM.') LI2(IT)=I7 GO TO 430 552 CONTINUE 430 DO 5520 I7=1,5 IF(LI2R(I7).EQ.0)GO TO 5520 IF(IABS(IENTR(IT)-LI2R(I7)).GT.1)GO TO 5520 IF(IABS(IENTC(IT)-LI2C(I7)).GT.1)GO TO 5520 CALL RANDO(J,3500,6500) WRITE(LLL,551)LI2C(I7),LI2R(I7),J 551 FORMAT(' ACQUISITION AND PROCESSING OF DILITHIUM CRYSTALS FROM SYS *TEM (',I2,',',I2,') PROCEEDING. '/' PHASER ENERGY INCREASED BY',I5, *' UNITS. ACQUISITION TERMINATED.') PHASR(IT)=PHASR(IT)+J LI2R(I7)=0 LI2C(I7)=0 5501 LI2(IT)=0 5520 CONTINUE 5321 RETURN 5322 IF(MMIN.NE.19)GO TO 5327 ION(IT)=1 IGNORE=1 Q=(Q-DISTP)/2. J=1 IF(I7.EQ.ITROW(IT).AND.I8.EQ.ITCOL(IT))J=0 GO TO 5327 5323 IF(MMIN.GT.18)GO TO 5322 DO 228 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 228 N=IV+4 NNN=N+1 WRITE(NNN,16)(INAME(IQ0,IT),IQ0=1,3), *(INAME(IQ0,MMIN-14),IQ0=1,3),I8,I7 16 FORMAT(1X,3A4,' COLLIDED WITH ',3A4,' MINE AT (',I2,',',I2,')') 228 CONTINUE GO TO 227 5330 IF(MMIN.NE.14)GO TO 5323 DO 5331 IV=1,LAUNCH IF(I7.EQ.IGLER(IV).AND.I8.EQ.IGLEC(IV))GO TO 5332 5331 CONTINUE 5332 DO 226 N=1,4 IF(ICHOE(N).EQ.0)GO TO 226 IVV=N+4 IIVV=IVV+1 WRITE(IIVV,5333)(INAME(IQ0,IT),IQ0=1,3),IV,I8,I7,IV, *(INAME(IQ0,IT),IQ0=1,3) 5333 FORMAT(1X,3A4,' COLLIDED WITH EAGLE',I3,' AT (',I2,',',I2,')'/' EA *GLE',I3,' DESTROYED'/' DAMAGE REPORT TO THE ',3A4) 226 CONTINUE CALL BOOM(IV) 227 CALL RANDO(IV,1,100) IVV=ALOG((101.-DFLCT(IT))*IV+10.)/0.700619195-1.8185 CALL GRUP1(IVV,IT) GO TO 5327 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - DUNSEL - C SUBROUTINE DUNSEL(J1,J2,Q1,Q2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) IF(IPULL(I7).EQ.0)GO TO 1 IF(IPULLC(I7).NE.J2.OR.IPULLR(I7).NE.J1)GO TO 1 IPULL(I7)=0 B=ANG(IENTR(I7)-J1,IENTC(I7)-J2) IV=ABS(B-Q2) IF(IV.LT.90.OR.IV.GT.270)GO TO 1 MMIN=1 Q1=Q1/2.0**(PULL(I7)*2.0) 1 IF(IPUSH(I7).EQ.0)GO TO 2 IF(IPUSHC(I7).NE.J2.OR.IPUSHR(I7).NE.J1)GO TO 2 IPUSH(I7)=0 B=ANG(J1-IENTR(I7),J2-IENTC(I7)) IV=ABS(B-Q2) IF(IV.LT.90.OR.IV.GT.270)GO TO 2 Q1=Q1/2.0**(PUSH(I7)/5.) MMIN=MMIN+2 2 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - LAUREL - C SUBROUTINE LAUREL(J) integer itzro,itvl1 real rtzro,rtvl1 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCOL(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 /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) 109 WRITE(LLL,102)J 102 FORMAT(' NACELLE',I2,' HAS RIPPED FREE OF THE SECONDARY HULL') IF(IGO(IT).EQ.2)IGO(IT)=1 IF(MA(IT,J+28).GT.0)MANUM(IT)=MANUM(IT)-1 MANUM(IT)=MANUM(IT)+1 MA(IT,J+28)=9 MA(IT,J+30)=9 TWARP(IT)=TWARP(IT)-FLOAT(MA(IT,J+28)-K(IT,J+3))/2. IF(TWARP(IT).LT.0)TWARP(IT)=0. K(IT,J+3)=MA(IT,J+28) N=2 itzro=0 rtzro=0. rtvl1=85.0 itvl1=1 IV=IT CALL HORTA(IENTR(IT),IENTC(IT),ITROW(IT),ITCOL(IT), *rtvl1,rtzro,itzro,rtzro,itvl1,rtzro,itzro) IF(MMIN.GT.4)GO TO 202 DO 203 N=1,4 IF(ICHOE(N).EQ.0)GO TO 203 IV=N+4 IVI=IV+1 WRITE(IVI,204)(INAME(IQ0,IT),IQ0=1,3),J,(INAME(IQ0,MMIN),IQ0=1,3) 204 FORMAT(1X,3A4,' NACELLE',I2,' HIT THE ',3A4) 203 CONTINUE CALL GRUP1(10,MMIN) CALL HARDY CALL GRUP1(10,MMIN) GO TO 205 202 IF(MMIN.GT.12)GO TO 206 MMIN=MMIN-4 DO 207 N=1,4 IF(ICHOE(N).EQ.0)GO TO 207 IV=N+4 IVI=IV+1 WRITE(IVI,208)(INAME(IQ0,IT),IQ0=1,3),J,(IENM2(IVV,MMIN),IVV=1,4) 208 FORMAT(1X,3A4,' NACELLE',I2,' HIT ',4A4) 207 CONTINUE CALL GRUP3(10,MMIN) CALL HARDY CALL GRUP3(10,MMIN) GO TO 205 206 IF(MMIN.NE.13)GO TO 209 DO 210 MI=1,2 IF(I7.NE.IBASR(MI))GO TO 210 IF(I8.NE.IBASC(MI))GO TO 210 DO 211 N=1,4 IF(ICHOE(N).EQ.0)GO TO 211 IV=N+4 IVI=IV+1 WRITE(IVI,212)(INAME(IQ0,IT),IQ0=1,3),J,(ISIDE(IQ0,MI),IQ0=1,3), *IBASE(MI) 212 FORMAT(1X,3A4,' NACELLE',I2,' HIT ',3A4,' STARBASE',I3) 211 CONTINUE CALL GRUP2(10,MI) CALL HARDY CALL GRUP2(10,MI) GO TO 205 210 CONTINUE DO 213 N=1,4 IF(ICHOE(N).EQ.0)GO TO 213 IV=N+4 IVI=IV+1 WRITE(IVI,214)(INAME(IQ0,IT),IQ0=1,3),J,I8,I7 214 FORMAT(1X,3A4,' NACELLE',I2,' HIT STAR AT (',I2,',',I2,')') 213 CONTINUE GO TO 205 209 IF(MMIN.NE.14)GO TO 216 DO 217 MI=1,LAUNCH IF(I7.NE.IGLER(MI))GO TO 217 IF(I8.NE.IGLEC(MI))GO TO 217 DO 218 N=1,4 IF(ICHOE(N).EQ.0)GO TO 218 IV=N+4 IVI=IV+1 WRITE(IVI,219)(INAME(IQ0,IT),IQ0=1,3),J,MMIN 219 FORMAT(1X,3A4,' NACELLE',I2,' DESTROYED EAGLE',I3) 218 CONTINUE CALL BOOM(MMIN) GO TO 205 217 CONTINUE 216 IF(MMIN.GT.18)GO TO 205 MMAP(I7,I8)=IBLK DO 220 N=1,4 IF(ICHOE(N).EQ.0)GO TO 220 WRITE(IVI,221)(INAME(IQ0,IT),IQ0=1,3),J,I8,I7 221 FORMAT(1X,3A4,' NACELLE',I2,' DESTROYED MINE AT (',I2,',',I2,')') 220 CONTINUE 205 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - HARDY - SUBROUTINE HARDY COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) DO 1 I=1,4 IF(ICHOE(I).EQ.0)GO TO 1 J=I+4 JJJ=J+1 WRITE(JJJ,2) 2 FORMAT(' DAMAGE FROM SECONDARY EXPLOSIONS-') 1 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/26/2000 BY: D.G. C C SSSS PPPP OOO CCCC K K C S P P O O C K K C SSS PPPP O O C KKK C S P O O C K K C SSSS P OOO CCCC K K LOGICAL FUNCTION SPOCK(J) integer itzro,itvl1 real rtzro,rtvl1 DIMENSION IBOLT(4,2),KPLOT(10) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(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 /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM DATA IBOLT/'PHOT','ON T','ORPE','DO ','DISR','UPTO','R BO','LT'/ DATA FUDGE/0.700619195/ IWOW(X)=IFIX(ALOG((101.-X)*IV1)/FUDGE-1.8185) SPOCK=.FALSE. 74 CALL RANDO(IV1,1,100) LOCKT(IT)=0 IF(IGO(IT).EQ.2)IGO(IT)=1 IF(IV1.GT.7)GO TO 76 IF(JS.EQ.2)GO TO 100 WRITE(LLL,78) 78 FORMAT(' PHOTON TORPEDO BANKS HAVE SHORT-CIRCUITED.') GO TO 101 100 WRITE(LLL,102) 102 FORMAT(' DISRUPTOR BANKS HAVE SHORT-CIRCUITED.') 101 WRITE(LLL,103) 103 FORMAT(5X,'THEIR NUMBER HAS DIMINISHED BY ONE-QUARTER') IPHOT(IT)=FLOAT(IPHOT(IT))*0.75 GO TO 50 76 IF(IWEB(1).NE.IT.AND.IWEB(2).NE.IT)GO TO 761 CALL RANDO(IV,1,4) IF(IV.EQ.1)GO TO 761 WRITE(LLL,1001)(IBOLT(J,JS),J=1,4) 1001 FORMAT(1X,4A4,'FAILED TO PIERCE THE WEB') IF(IV.NE.4)GO TO 50 DO 104 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 104 I8=I7+4 II8=I8+1 WRITE(II8,105)(IBOLT(J,JS),J=1,4),(INAME(IQ0,IT),IQ0=1,3) 105 FORMAT(1X,4A4,'BOUNCED OFF THE WEB AND HAS STRUCK THE ',3A4/' DAMA *GE REPORT-') 104 CONTINUE IVV=IWOW(DFLCT(IT)) CALL GRUP1(IVV,IT) GO TO 50 761 N=3 ANGLE(IT)=ANGLE(IT)*3.14159265/180. IV=0 AJUST=0.0 itzro=0 itvl1=1 rtzto=0.0 CALL HORTA(IENTR(IT),IENTC(IT),itzro, *itzro,RANG(IT),ANGLE(IT),J,AJUST,iitvl1,itzro,KPLOT) ANGLE(IT)=ANGLE(IT)*180./3.14159265 J=J-1 IF(J.LE.1)GO TO 529 WRITE(LLL,528)(KPLOT(IV),IV=1,J) 528 FORMAT(10(I3,',',I2)) 529 IF(MMIN.GT.4)GO TO 106 DO 107 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 107 I8=I7+4 II8=I8+1 WRITE(II8,108)(INAME(IQ0,IT),IQ0=1,3),(IBOLT(J,JS),J=1,4), *(INAME(IQ0,MMIN),IQ0=1,3) 108 FORMAT(1X,3A4,1X,4A4,' HAS SCORED A HIT ON THE ',3A4) 107 CONTINUE IVV=IWOW(DFLCT(MMIN)) CALL GRUP1(IVV,MMIN) SPOCK=.TRUE. GO TO 50 106 IF(MMIN.GT.12)GO TO 109 MMIN=MMIN-4 DO 110 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 110 I8=I7+4 II8=I8+1 WRITE(II8,111)(INAME(IQ0,IT),IQ0=1,3),(IBOLT(J,JS),J=1,4),(IENM2( *J,MMIN),J=1,4) 111 FORMAT(1X,3A4,1X,4A4,'HIT ',4A4) 110 CONTINUE IVV=IWOW(DFLCK(MMIN)) CALL GRUP3(IVV,MMIN) SPOCK=.TRUE. GO TO 50 109 IF(MMIN.NE.13)GO TO 112 DO 119 IV=1,2 IF(IBASR(IV).NE.I7)GO TO 119 IF(IBASC(IV).EQ.I8)GO TO 120 119 CONTINUE WRITE(LLL,526)(IBOLT(J,JS),J=1,4) 526 FORMAT(1X,4A4,'HAS SCORED A HIT ON A STAR') GO TO 50 120 DO 121 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 121 I8=I7+4 II8=I8+1 WRITE(II8,122)(INAME(IQ0,IT),IQ0=1,3),(IBOLT(J,JS),J=21,4), *(ISIDE(IQ0,IV),IQ0=1,3),IBASE(IV) 122 FORMAT(1X,3A4,1X,4A4,' HAS HIT ',3A4,' STARBASE',I3) 121 CONTINUE IVV=IWOW(DFLCB(IV)/3.) CALL GRUP2(IVV,IV) SPOCK=.TRUE. GO TO 50 112 IF(MMIN.NE.14)GO TO 113 DO 5541 IV=1,LAUNCH IF(IGLER(IV).NE.I7)GO TO 5541 IF(IGLEC(IV).EQ.I8)GO TO 5542 5541 CONTINUE 5542 DO 114 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 114 I8=I7+4 II8=I8+1 WRITE(II8,115)(INAME(IQ0,IT),IQ0=1,3),(IBOLT(J,JS),J=1,4),IV 115 FORMAT(1X,3A4,1X,4A4,' DESTROYED EAGLE',I3) 114 CONTINUE CALL BOOM(IV) SPOCK=.TRUE. GO TO 50 113 IF(MMIN.GT.18)GOTO 116 WRITE(LLL,117)(IBOLT(J,JS),J=1,4),I8,I7 117 FORMAT(1X,4A4,'DETONATED MINE AT (',I2,',',I2,')') MMAP(I7,I8)=IBLK GO TO 50 116 IF(MMIN.NE.20)GO TO 118 555 J=I7 IVV=I8 N=2 IV=0 rtvl1=1.5 CALL HORTA(J,IVV,IENTR(IT),IENTC(IT), *rtvl1,itzro,itzro,itzro,itvl1,itzro,itzro) IF(MMIN.EQ.20)GO TO 555 118 IF(I8.EQ.IENTC(IT).AND.I7.EQ.IENTR(IT))GO TO 557 WRITE(LLL,81)(IBOLT(J,JS),J=1,4),I8,I7 81 FORMAT(1X,4A4,'FAILED TO HIT ANYTHING'/' NOW A MINE AT (',I2,',', *I2,')') MINES=MINES+1 MMAP(I7,I8)=IM(IT) GO TO 50 557 WRITE(LLL,806)(IBOLT(J,JS),J=1,4) 806 FORMAT(1X,4A4,'LOST') 50 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 - SAREK - C LOGICAL FUNCTION SAREK(J) LOGICAL MUDD 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) DATA FUDGE/0.700619195/ IWOX(X)=IFIX(ALOG((101.-X)*IV*ZAP(IT)/FLOAT(N)/FUDGE-10.4915)) SAREK=.FALSE. 520 CALL RANDO(IV,1,100) LOCK(IT)=0 IF(IGO(IT).EQ.2)IGO(IT)=1 IF(IV.GT.4)GO TO 29 PHASR(IT)=PHASR(IT)*0.75 WRITE(LLL,31) 31 FORMAT(' PHASER BANKS HAVE SHORT-CIRCUITED AND ARE REDUCED'/' TO 3 */4 THEIR ORIGINAL ENERGY') GO TO 50 29 IF(IV.GT.8)GO TO 1010 ICOIL(IT)=1 WRITE(LLL,1011) 1011 FORMAT(' MAIN COIL BURNOUT IN THE PHASER BANKS-'/' PHASERS ARE NOW *INOPERATIVE UNTIL REPAIRS ARE COMPLETE') GO TO 50 1010 N=DI(IENTR(IT),IENTC(IT),IROWA(IT),ICOLA(IT)) IF(N.EQ.0)GO TO 125 J=IROWA(IT)-IENTR(IT) IV1=ICOLA(IT)-IENTC(IT) IVV=0 DO 123 I=1,4 IF(ICHOE(I).EQ.0)GO TO 123 IF(I.EQ.IT)GO TO 123 I7=IENTR(I)-IENTR(IT) I8=IENTC(I)-IENTC(IT) IF(MUDD(J,IV1,I7,I8,N))IVV=I 123 CONTINUE DO 780 I=1,8 IF(ICHOS(I).EQ.0)GO TO 780 I7=IKLNR(I)-IENTR(IT) I8=IKLNC(I)-IENTC(IT) IF(MUDD(J,IV1,I7,I8,N))IVV=I+4 780 CONTINUE DO 124 I=1,2 IF(ICHOB(I).EQ.0)GO TO 124 I7=IBASR(I)-IENTR(IT) I8=IBASC(I)-IENTC(IT) IF(MUDD(J,IV1,I7,I8,N))IVV=I+12 124 CONTINUE IF(NUMOUT.EQ.0)GO TO 34 DO 760 I=1,LAUNCH IF(IGLER(I).EQ.0)GO TO 760 I7=IGLER(I)-IENTR(IT) I8=IGLEC(I)-IENTC(IT) IF(MUDD(J,IV1,I7,I8,N))IVV=I+14 760 CONTINUE 34 I=IVV IF(I.GT.0.AND.2.5*FLOAT(N).LE.IV)GO TO 801 125 WRITE(LLL,33) 33 FORMAT(' PHASER BEAM MISSED') GO TO 50 801 IF(I.GT.4)GO TO 1250 DO 126 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 126 I8=I7+4 II8=I8+1 WRITE(II8,127)(INAME(IQ0,IT),IQ0=1,3),(INAME(IQ0,I),IQ0=1,3) 127 FORMAT(1X,3A4,' PHASER BEAM HIT ',3A4) 126 CONTINUE IVV=IWOX(DFLCT(I)) CALL GRUP1(IVV,I) GO TO 500 1250 IF(I.GT.12)GO TO 128 I=I-4 IF(I.NE.7)GO TO 135 CALL RANDO(IV1,1,3) IF(IV1.EQ.1)GO TO 135 WRITE(LLL,776) 776 FORMAT(' PHASER BEAM BOUNCED OFF DOOMSDAY MACHINE') GO TO 50 135 DO 129 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 129 I8=I7+4 II8=I8+1 WRITE(II8,130)(INAME(IQ0,IT),IQ0=1,3),(IENM2(J,I),J=1,4) 130 FORMAT(1X,3A4,' PHASER BEAM HIT ',4A4) 129 CONTINUE IVV=IWOX(DFLCK(I)) CALL GRUP3(IVV,I) GO TO 500 128 IF(I.GT.14)GO TO 131 I=I-12 DO 132 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 132 I8=I7+4 II8=I8+1 WRITE(II8,133)(INAME(IQ0,IT),IQ0=1,3),(ISIDE(IQ0,I),IQ0=1,3), *IBASE(I) 133 FORMAT(1X,3A4,' PHASER BEAM HIT ',3A4,' STARBASE',I3) 132 CONTINUE DISTP=DFLCB(I)/3. IVV=IWOX(DISTP) CALL GRUP2(IVV,I) GO TO 500 131 I=I-14 DO 134 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 134 I8=I7+4 II8=I8+1 WRITE(II8,1350)(INAME(IQ0,IT),IQ0=1,3),I 1350 FORMAT(1X,3A4,' PHASER BEAM DESTROYED EAGLE',I3) 134 CONTINUE CALL BOOM(I) 500 SAREK=.TRUE. 50 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - MUDD C LOGICAL FUNCTION MUDD(J,IV1,I7,I8,N) MUDD=.FALSE. IF(IV1.EQ.0)GO TO 1014 IF(I8.NE.0)GO TO 1015 1014 IF(IV1.NE.I8)GO TO 780 IF(IABS(J)/J.EQ.IABS(I7)/I7)GO TO 1016 GO TO 780 1015 IF(J.EQ.0)GO TO 1013 IF(I7.NE.0)GO TO 1017 1013 IF(J.NE.I7)GO TO 780 IF(IABS(IV1)/IV1.EQ.IABS(I8)/I8)GO TO 1016 GO TO 780 1017 IF(FLOAT(IV1)/FLOAT(J).NE.FLOAT(I8)/FLOAT(I7))GO TO 780 IF(IABS(IV1)/IV1.NE.IABS(I8)/I8)GO TO 780 1016 MMIN=SQRT(FLOAT(I8**2+I7**2)) IF(MMIN.GT.N)GO TO 780 J=I7 IV1=I8 N=MMIN MUDD=.TRUE. 780 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 - HARPO - C LOGICAL FUNCTION HARPO(IBORD,NUM,IROW,ICOL) LOGICAL CHICO 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) 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 /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) COMMON /V/IWEB(2),IWEBZ,INVIS(4) HARPO=.FALSE. IBORD=0 JTK=7 IF(JS.EQ.2)JTK=26 I8=0 IF(MA(IT,JTK).LT.9)GO TO 100 2 WRITE(LLL,3) 3 FORMAT(' TRANSPORTER ROOMS DESTROYED - CANNOT BEAM A BOARDING * PARTY') 5 RETURN 100 IF(NUM.EQ.0)RETURN IF(NUM.LE.NDEAD(IT))GO TO 301 119 WRITE(LLL,118) 118 FORMAT(' NUMBER IN PARTY GREATER THAN CREW ONBOARD -OPERATION CANC *ELLED') RETURN 301 IF((IENTC(IT)-ICOL)**2+(IENTR(IT)-IROW)**2.LE.25)GO TO 302 102 WRITE(LLL,103) 103 FORMAT(' BOARDING TARGET OUT OF TRANSPORTER RANGE -OPERATION CANCE *LLED') RETURN 302 IF(IGO(IT).EQ.2)IGO(IT)=1 WRITE(LLL,101) 101 FORMAT(' BOARDING PARTY OPERATION NOW COMMENCING') DO 104 I=1,8 IF(IROW.EQ.IKLNR(I).AND.ICOL.EQ.IKLNC(I))GO TO 105 104 CONTINUE DO 215 I=1,4 IF(IROW.EQ.IENTR(I).AND.ICOL.EQ.IENTC(I))GO TO 303 215 CONTINUE IF(MMAP(IROW,ICOL).EQ.IGLE)GO TO 130 IF(MMAP(IROW,ICOL).EQ.ISTAR)GO TO 107 IF(NUM.LT.0)RETURN WRITE(LLL,106) 106 FORMAT(' BOARDING PARTY MATERIALIZED IN DEEP SPACE -ALL HAVE PERIS *HED') NDEAD(IT)=NDEAD(IT)-NUM RETURN 105 IF(I.NE.7)GO TO 304 WRITE(LLL,113) 113 FORMAT('TRANSPORTER BEAM BOUNCED OFF DOOMSDAY MACHINE') 500 IF(NUM.GT.0)NDEAD(IT)=NDEAD(IT)-NUM RETURN 304 IF(.NOT.CHICO(NUM,ICOL,IROW,IBPOB(I),DFLCK(I),IBPSB(I),IBPOB(7), *NDEAD(IT),1))RETURN HARPO=.TRUE. IF(IBPOB(I).NE.0)GO TO 135 CALL TPAU(I) 135 CALL OXMYX IF(I.NE.6)GO TO 143 IPLANZ=1 IRUNZ=150 IDEVZ=0 143 RETURN 303 IF(I.NE.IT)GO TO 306 WRITE(LLL,111) 111 FORMAT(' BOARDING PARTY MATERIALIZED IN OUR SHIP') HARPO=.TRUE. RETURN 306 I6=(IBPSC(I)+1)/2 IF(.NOT.CHICO(NUM,ICOL,IROW,NDEAD(I),DFLCT(I),I6,I5,NDEAD(IT),2)) *RETURN HARPO=.TRUE. GO TO 135 130 DO 131 I=1,LAUNCH IF(IGLER(I).EQ.0)GO TO 131 IF(ICOL.EQ.IGLEC(I).AND.IROW.EQ.IGLER(I))GO TO 132 131 CONTINUE 132 DISTP=0. IF(.NOT.CHICO(NUM,ICOL,IROW,IBPOE(I),DISTP,IBPSE(I),NUME(IS),NDEAD *(IT),3))GO TO 137 HARPO=.TRUE. IF(IBPOE(I).LE.20)GO TO 308 WRITE(LLL,141)I 141 FORMAT(' SO MANY PEOPLE HAVE MATERIALIZED ONTO EAGLE',I3,' THAT IT * HAS BURST') GO TO 142 137 IF(DISTP.GE.0)RETURN 142 WRITE(LLL,136)I 136 FORMAT(' EAGLE',I3,' DESTROYED') HARPO=.FALSE. CALL BOOM(I) RETURN 308 IF(IBPOE(I).EQ.0)CALL TPRING(I) RETURN 107 DO 210 I=1,2 IF(IROW.EQ.IBASR(I).AND.ICOL.EQ.IBASC(I))GO TO 307 210 CONTINUE IF(NUM.LT.0)GO TO 309 WRITE(LLL,108) 108 FORMAT(' BOARDING PARTY MATERIALIZED IN A STAR -ALL HAVE SIZZLED') GO TO 500 309 WRITE(LLL,204) 204 FORMAT(' 2 TRANSPORTER TECHNICIANS KILLED WHEN PLASMA FROM STAR MA *TERIALIZED'/' IN TRANSPORTER CHAMBER') NDEAD(IT)=NDEAD(IT)-2 RETURN 307 IF(.NOT.CHICO(NUM,ICOL,IROW,NDEAB(I),DFLCB(I),IBPSS(I),I5,NDEAD(IT *),4))RETURN HARPO=.TRUE. IF(NUM.LT.0.AND.NDEAB(I).EQ.0)WRITE(LLL,213)ISIDE(1,I),ISIDE(2,I), *IBASE(I) 213 FORMAT(1X,2A5,' STARBASE',I3,' EVACUATED') RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - TPRING - C C THIS SUBROUTINE WAS HAND TYPED BY DG NOV. 17/1999 C SUBROUTINE TPRING(J) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) DO 142 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 142 I7=IV+4 II7=I7+1 WRITE(II7,208)J 208 FORMAT(' CONTROL OF EAGLE',I3,' HAS BEEN LOST') 142 CONTINUE II(IBPSE(J))=II(IBPSE(J))-1 NUME(IBPSE(J))=NUME(IBPSE(J))-1 IBPSE(J)=0 I3=I3+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 - CHICO - C LOGICAL FUNCTION CHICO(NUM,ICOL,IROW,IHORDE,DEFLT,ISID,ICNT, *IFROM,J) LOGICAL ZEPPO 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) CHICO=.FALSE. IF(ISID.NE.IS)GO TO 100 IF(NUM.GT.0)GO TO 50 IF(IHORDE+NUM.GE.0)GO TO 10 WRITE(LLL,2) 2 FORMAT(' NUMBER IN PARTY GREATER THAN CREW ONBOARD -OPERATION CANC *ELLED') RETURN 10 IF(J.NE.2)GO TO 1 I8=IBPSC(I)+4 IV=-NUM II8=I8+1 WRITE(II8,13)INAME(1,IT),INAME(2,IT),IV 13 FORMAT(' DO YOU WISH THE ',2A5,' TO BEAM OFF',I5,' OF YOUR CREW?') READ(I8,14)NA 14 FORMAT(A1) IF(NA.EQ.'Y')GO TO 1 WRITE(LLL,15)INAME(1,I),INAME(2,I) 15 FORMAT(1X,2A5,' CAPTAIN DOES NOT WANT TO SPARE HIS CREW') RETURN 1 IHORDE=IHORDE+NUM IFROM=IFROM-NUM CHICO=.TRUE. RETURN 50 WRITE(LLL,51)NUM 51 FORMAT(' CREW ON SHIP REINFORCED BY',I4) IF(J.EQ.4.AND.IHORDE.EQ.0)II(IS)=II(IS)+1 IF(J.NE.2)GO TO 1 I8=IBPSC(I)+4 IF(ICHOE(I).NE.2)GO TO 11 ICHOE(I)=1 ISURR(I)=0 II(IS)=II(IS)+1 IJ(IS)=IJ(IS)+1 II8=I8+1 WRITE(II8,52)INAME(I,IT),INAME(2,IT) 52 FORMAT(' OUR SHIP HAS BEEN REINFORCED BY THE ',2A5,' YOU ARE BACK *IN CONTROL') GO TO 1 11 WRITE(II8,12)INAME(1,IT),INAME(2,IT) 12 FORMAT(' OUR SHIP HAS BEEN REINFORCED BY THE ',2A5) GO TO 1 100 IF(NUM.GT.0)GO TO 140 WRITE(LLL,141) 141 FORMAT(' NONE OF OUR CREW IS ON THE TARGET SHIP -OPERATION CANCELL *ED') RETURN 140 I7=(120.-(MA(IT,JTK)+1)*DEFLT)*FLOAT(NUM)/100./DI(IENTC(IT),IENTR( *IT),ICOL,IROW) IF((DEFLT.LE.10.0.AND.MA(IT,JTK).LE.4).OR.(I7.GT.NUM))I7= *(0.95*FLOAT(NUM)) IFROM=IFROM-NUM IF(I7.LT.0)I7=0 WRITE(LLL,101)I7 101 FORMAT(1X,I4, ' OF THE BOARDING PARTY HAVE SURVIVED SO FAR') IF(I7.GT.0)GO TO 102 105 IF(DEFLT.LT.0)RETURN WRITE(LLL,103) 103 FORMAT(' THE ENEMY HAS CRUSHED THE BOARDING PARTY') RETURN 102 IF(J.NE.3)GO TO 104 IF(I7.LT.2)GO TO 105 WRITE(LLL,106)I 106 FORMAT(' THE BOARDING PARTY HAS SEIZED CONTROL OF EAGLE',I3) GO TO 122 104 IF(J.EQ.2)GO TO 200 IF(ISID.NE.0)GO TO 130 CALL RANDO(IV,1,200) IF(IV.GT.I7)GO TO 105 GO TO 120 130 CALL RANDO(IV,1,100) IF(IV.LE.50*I7/IHORDE)GO TO 120 CALL RANDO(IV,0,I7/2) IHORDE=IHORDE-IV GO TO 105 120 WRITE(LLL,121) 121 FORMAT(' THE BOARDING PARTY HAS SEIZED CONTROL OF THE ENEMY SHIP') 122 CALL RANDO(IV,1,7) IF(IV.NE.1)GO TO 123 WRITE(LLL,124) 124 FORMAT(' BUT AS THEIR LAST ACT, THE ENEMY HAS PLANTED A'/' SELF-DE *STRUCT DEVICE ON THEIR SHIP, WHICH HAS EXPLODED') DEFLT=-1. RETURN 123 IF(IV.NE.2)GO TO 125 204 WRITE(LLL,126) 126 FORMAT(' BUT THE BOARDING PARTY HAS MUTINIED AND DEFECTED TO THE E *NEMY') IF(ISID.NE.0)IHORDE=IHORDE+I7 RETURN 125 IF(ISID.NE.0)GO TO 127 I3=I3-1 ICNT=ICNT+1 GO TO 128 127 IF(J.EQ.4.AND.IHORDE.EQ.0)GO TO 128 II(ISID)=II(ISID)-1 IF(J.NE.3)GO TO 128 NUME(ISID)=NUME(ISID)-1 NUME(IS)=NUME(IS)+1 128 ISID=IS II(ISID)=II(ISID)+1 IHORDE=I7 CHICO=.TRUE. RETURN 200 I8=IBPSC(I)+4 IF(ISURR(I).EQ.1)GO TO 235 IF(ICHOE(I).EQ.2)GO TO 235 N=(I+1)/2 A=1.0 CALL RANDO(IDEKU,1,33) IDEKL=IDEKU II8=I8+1 WRITE(II8,201)I7 201 FORMAT(1X,I4,' ENEMY TROOPS HAVE MATERIALIZED ONTO WHAT''S LEFT * OF ') CALL TANRU(IDEKU) CALL RANDO(IV,1,6) IF(IV.NE.5)GO TO 202 WRITE(II8,203) 203 FORMAT(' BUT THEY HAVE DEFECTED TO JOIN YOUR CREW') GO TO 204 202 IF(.NOT.ZEPPO(IDEKU,IDEKL,DEFLT,ISID,IHORDE,IFROM))GO TO 105 235 CHICO=.TRUE. WRITE(LLL,121) WRITE(II8,205) 205 FORMAT(' INTRUDERS HAVE TAKEN OVER OUR SHIP') IF(ICHOE(I).EQ.2)GO TO 206 II(ISID)=II(ISID)-1 IJ(ISID)=IJ(ISID)-1 206 IBPSC(I)=IBPSC(IT) ICHOE(I)=1 ISURR(I)=0 IHORDE=I7 II(IS)=II(IS)+1 IJ(IS)=IJ(IS)+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 - ZEPPO - C LOGICAL FUNCTION ZEPPO(IDEKU,IDEKL,DEFLT,ISID,IHORDE,IFROM) DIMENSION KODOS(7) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /J/KODE(2,8),STATIC(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) ZEPPO=.FALSE. DO 21 IV=1,7 21 KODOS(IV)=0 NODEK=1 IF(I7.LE.15)GO TO 36 25 WRITE(II8,27) 27 FORMAT(' HERE IS A LIST OF YOUR INTRUDER CONTROL COMANDS-'/ *' 0-PRINT THESE INSTRUCTIONS'/' 1-SOUND INTRUDER ALERT'/ *' 2-EVACUATE PERSONNEL FROM ENEMY-HELD AREAS'/ *' 3-CLOSE SECTION ISOLATION DOORS/SEAL OFF ENEMY-HELD AREAS'/ *' 4-FLOOD ENEMY-HELD AREAS WITH NEURAL GAS'/ *' 5-FLUSH RADIOACTIVE WASTE INTO ENEMY-HELD AREAS'/ *' 6-DEPRESSURIZE ENEMY-HELD AREAS'/' 7-DISPATCH SECUTY TEAMS TO * ENEMY-HELD AREAS'/' 8-ACTIVATE SELF-DESTRUCT MECHANISM'/ *' 9-OFFER NO RESISTANCE - SURRENDER') WRITE(LLL,28) 28 FORMAT(' STANDBY WHILE THE ENEMY FORCES TRY TO DEFEND THEIR SHIP') KORAX=1 ISPRED=4 ADED=1.0 BDED=0.95 GO TO 32 34 I7=FLOAT(I7)*BDED IF(I7.GT.IHORDE)GO TO 22 IF(I7.LE.15)GO TO 36 22 IF(I7.LE.NODEK)GO TO 32 A=1.0 WRITE(II8,29) 29 FORMAT(' INTRUDERS HAVE SPREAD INTO-') DO 30 MMIN=1,ISPRED*KORAX IF(MMIN.GT.ISPRED/2)GO TO 31 IF(IDEKL.GE.33)GO TO 31 33 IDEKL=IDEKL+1 NODEK=NODEK+1 CALL TANRU(IDEKL) GO TO 30 31 IF(NODEK.GE.33)GO TO 30 IF(IDEKU.LE.1)GO TO 33 IDEKU=IDEKU-1 CALL TANRU(IDEKU) NODEK=NODEK+1 30 CONTINUE KORAX=1 32 MMIN=ISPRED*IHORDE/FLOAT(33-NODEK)+5 CALL RANDO(IV,0,MMIN) IV=IV*A*ADED IHORDE=IHORDE-IV IF(IHORDE.LE.0.OR.NODEK.GE.33)GO TO 35 39 WRITE(II8,37)IHORDE,I7 37 FORMAT(' CREW REMAINING=',I4,' INTRUDERS REMAINING=',I4/' ENTER Y *OUR INTRUDER CONTROL COMMAND:',$) READ(I8,38,ERR=410)IV 38 FORMAT(I1) IF(IV.LT.1)GO TO 41 IF(IV.EQ.9)GO TO 35 IF(IV.EQ.8)GO TO 49 IF(IV.EQ.7)GO TO 48 IF(KODOS(IV).EQ.0)GO TO 40 WRITE(II8,401) 401 FORMAT(' YOU''VE ALREADY DONE THAT') GO TO 39 41 WRITE(II8,27) GO TO 39 410 IV=L L=I8 CALL ILLDAT L=IV GO TO 39 40 KODOS(IV)=1 GO TO (42,43,44,45,46,47),IV 42 WRITE(II8,50) 50 FORMAT(' INTRUDER ALERT SOUNDED') ADED=ADED*0.8 GO TO 34 43 WRITE(II8,51) 51 FORMAT(' PERSONNEL EVACUATED') KORAX=2 ADED=ADED*0.6 GO TO 34 44 WRITE(II8,52) 52 FORMAT(' ENEMY-HELD AREAS SEALED OFF- ENEMY NOW RESORTING TO BLAS *TING THROUGH BULKHEADS') ISPRED=ISPRED/2 GO TO 34 45 WRITE(II8,53) 53 FORMAT(' ENEMY-HELD AREAS GASSED') CALL RANDO(MMIN,85,95) I7=I7*(FLOAT(MMIN)/100.) GO TO 34 46 WRITE(II8,54) 54 FORMAT(' ENEMY AREAS FLOODED WITH RADIOACTIVE WASTE') CALL RANDO(MMIN,77,85) ADED=ADED+FLOAT(MMIN)/100. BDED=BDED*FLOAT(MMIN)/100. GO TO 34 47 WRITE(II8,55) 55 FORMAT(' ENEMY AREAS DEPRESSURIZED') ADED=ADED*1.3 BDED=BDED*0.7 GO TO 34 480 IV=L L=I8 CALL ILLDAT L=IV 48 WRITE(II8,56) 56 FORMAT(' ENTER NUMBER OF CREW TO MAKE UP THE SECURITY FORCES') READ(I8,57,ERR=480)MMIN 57 FORMAT(I7) IF(MMIN.LT.0.OR.MMIN.GT.IHORDE)GO TO 48 CALL RANDO(IV,1,100) IF(IV.LE.50*MMIN/I7)GO TO 36 WRITE(II8,59) 59 FORMAT(' ENEMY FORCES HAVE WIPED OUT OUR SECURITY FORCES') IHORDE=IHORDE-MMIN CALL RANDO(IV,0,IFIX(MMIN*0.75)) I7=I7-IV GO TO 34 49 IF(KODOS(7).EQ.0)GO TO 58 WRITE(II8,60) 60 FORMAT(' THE SELF-DESTRUCT ROUTINE DOES NOT WORK') GO TO 39 58 IF(IDEKU.GT.ISID)GO TO 61 WRITE(II8,62) 62 FORMAT(' SINCE THE BRIDGE HAS BEEN CAPTURED,') WRITE(II8,60) GO TO 39 61 CALL RANDO(IV,1,3) KODOS(7)=1 IF(IV.GT.2)GO TO 63 WRITE(II8,60) GO TO 34 63 DO 75 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 75 I8=IV+4 II8=I8+1 WRITE(II8,64)INAME(1,IT),INAME(2,IT) 64 FORMAT(1X,2A5,' SELF-DESTRUCT ROUTINE ACTIVATED') 75 CONTINUE DEFLT=-1. RETURN 36 WRITE(II8,65) 65 FORMAT(' OUR FORCES HAVE VANQUISHED THE INTRUDERS') CALL RANDO(IV,1,5) IF(IV.GT.1)GO TO 69 WRITE(II8,66) 66 FORMAT(' BUT THE LAST INTRUDER DETONATED A BOMB BEFORE HIS CAPTURE *DAMAGE REPORT-') DO 67 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 67 IF(IV.EQ.I)GO TO 67 MMIN=IV+4 MMIN=MMIN+1 WRITE(MMIN,68)INAME(1,I),INAME(2,I) 68 FORMAT(' A BOMB HAS BEEN DETONATED IN THE ',2A5,'-DAMAGE REPORT-') MMIN=MMIN-1 C OLD CODE just wrote to MMIN, +1 and -1 added to change unit # 67 CONTINUE IVV=8 DFLCT(I)=DEFLT NDEAD(I)=IHORDE CALL GRUP1(IVV,I) DEFLT=DFLCT(I) IHORDE=NDEAD(I) 69 IF(I.GT.2)GO TO 70 WRITE(II8,71) 71 FORMAT(' USING TRUTH DRUGS, PSYCHOTRICORDERS, AND VERIFIER * SCANS,') GO TO 72 70 WRITE(II8,73) 73 FORMAT(' USING MIND-SIFTERS AND AGONIZERS,') 72 WRITE(II8,74)INAME(1,IT),INAME(2,IT),IFROM,DFLCT(IT),PHASR(IT), *TWARP(IT),IPHOT(IT),ITEMP(IT) 74 FORMAT(' WE HAVE UNCOVERED THE FOLLOWING INFORMATION FROM THE PRIS *ONERS-'/' THEY ARE FROM THE ',2A5,' THEIR SHIP''S CREW IS NOW',I4, *'DEFLECTORS= ',F11.7,' UNITS. PHASERS=',F13.7,' UNITS'/' MAX. WARP *=',F10.7,'. NO. TORPEDOES/DISRUPTORS=',I3,' ENGINE TEMP=',I5, *' DEGREES') CALL RANDO(IV,1,3) IF(IV.GT.1)RETURN CALL RANDO(IV,1,8) KODE(IS,IV)=1 RETURN 35 ZEPPO=.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 TANRU - C SUBROUTINE TANRU(NOMAD) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN CALL FORBIN(N,NOMAD,I8,' ') IF(I.GT.2)GO TO 30 IF(NOMAD.EQ. 4)A=A+0.2 IF(NOMAD.EQ. 5)A=A+0.3 IF(NOMAD.EQ. 6)A=A+2.2 IF(NOMAD.EQ. 7)A=A+1.2 IF(NOMAD.EQ.21)A=A+0.3 IF(NOMAD.EQ.22)A=A+0.3 IF(NOMAD.EQ.23)A=A+0.2 RETURN 30 IF(NOMAD.EQ. 8)A=A+1.8 IF(NOMAD.EQ.10)A=A+0.1 IF(NOMAD.EQ.11)A=A+0.2 IF(NOMAD.EQ.17)A=A+0.4 IF(NOMAD.EQ.19)A=A+1.1 IF(NOMAD.EQ.21)A=A+0.4 IF(NOMAD.EQ.22)A=A+0.9 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 LARRY - C LOGICAL FUNCTION LARRY(J) LOGICAL NOTRAC 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) LARRY=.TRUE. IF(NOTRAC(IT))GO TO 205 200 IPULL(IT)=0 IF(DI(IENTC(IT),IENTR(IT),IPULLC(IT),IPULLR(IT)).LE.DISTP)GOTO 202 WRITE(LLL,201) 201 FORMAT(' TARGET OUT OF TRACTOR RANGE') GO TO 205 202 IF(PULL(IT).GT.TWARP(IT))PULL(IT)=TWARP(IT) TWARP(IT)=TWARP(IT)-PULL(IT) IF(IGO(IT).EQ.2)IGO(IT)=1 WRITE(LLL,203) 203 FORMAT(' TRACTOR BEAM ON') NA=MMAP(IPULLR(IT),IPULLC(IT)) IF(NA.EQ.IGLE)GO TO 2040 IF(NA.EQ.IBLK.OR.NA.EQ.III.OR.NA.EQ.ISTAR)GO TO 205 IF(NA.EQ.IEE(IT))GO TO 205 DO 269 IV=1,4 IF(NA.EQ.IM(IV))GO TO 2040 269 CONTINUE IPULL(IT)=1 GO TO 205 2040 RAD=PULL(IT)*10. BERNG=ANG(IENTR(IT)-IPULLR(IT),IENTC(IT)-IPULLC(IT))* *3.14159265/180. CALL MOE(IPULLC(IT),IPULLR(IT),RAD,BERNG) IF(DISTP/10.0.LT.PULL(IT))TWARP(IT)=TWARP(IT)+PULL(IT)-DISTP/10. RETURN 205 LARRY=.FALSE. 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 - CURLY - C LOGICAL FUNCTION CURLY(J) LOGICAL NODEFL 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /P/IPULL(4),IPUSH(4),PULL(4),PUSH(4),IPULLR(4),IPULLC(4), *IPUSHR(4),IPUSHC(4) CURLY=.TRUE. IF(NODEFL(IT))GO TO 305 300 IPUSH(IT)=0 AJUST=DI(IENTC(IT),IENTR(IT),IPUSHC(IT),IPUSHR(IT)) IF(AJUST.LE.DISTP)GO TO 302 WRITE(LLL,301) 301 FORMAT(' TARGET OUT OF DEFLECTOR RANGE') GO TO 305 302 IF(PUSH(IT).GT.DFLCT(IT))PUSH(IT)=DFLCT(IT) DFLCT(IT)=DFLCT(IT)-PUSH(IT) IF(IGO(IT).EQ.2)IGO(IT)=1 WRITE(LLL,303) 303 FORMAT(' DEFLECTOR BEAM ON') NA=MMAP(IPUSHR(IT),IPUSHC(IT)) IF(NA.EQ.IGLE)GO TO 304 IF(NA.EQ.IBLK.OR.NA.EQ.III.OR.NA.EQ.ISTAR)GO TO 305 IF(NA.EQ.IEE(IT))GO TO 305 DO 284 IV=1,4 IF(NA.EQ.IM(IV))GO TO 304 284 CONTINUE IPUSH(IT)=1 GO TO 305 304 RAD=PUSH(IT) IF(AJUST+RAD.GT.DISTP)RAD=DISTP-AJUST BERNG=ANG(IPUSHR(IT)-IENTR(IT),IPUSHC(IT)-IENTC(IT))*3.141592615/ *180. CALL MOE(IPUSHC(IT),IPUSHR(IT),RAD,BERNG) IF(DISTP.LT.PUSH(IT))DFLCT(IT)=DFLCT(IT)+PUSH(IT)-DISTP RETURN 305 CURLY=.FALSE. 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 - MOE - C SUBROUTINE MOE(IPUC,IPUR,RAD,BERNG) 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) 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) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) KLIGAT(X)=IFIX(ALOG((101.-X)*FLOAT(IV))/0.700619195-1.8185) 204 N=4 CALL RANDO(IV,20,100) IIV=1 IF(MMAP(IPUR,IPUC).EQ.IGLE)IIV=2 IGNORE=1 IF(IIV.EQ.1)GO TO 206 IGNORE=0 DO 209 IVV=1,LAUNCH IF(IPUC.EQ.IGLEC(IVV).AND.IPUR.EQ.IGLER(IVV))GO TO 206 209 CONTINUE itzro=0 206 CALL HORTA(IPUR,IPUC,itzro,itzro,RAD,BERNG,itzro, *itzro,IGNORE,itzro,itzro) IF(MMIN.GT.4)GO TO 308 DO 270 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 270 I81=I71+4 II81=I81+1 IF(IIV.EQ.2)GO TO 271 IF(MMAP(I7,I8).EQ.IEE(IT))GO TO 221 WRITE(II81,272)INAME(1,MMIN),INAME(2,MMIN) 272 FORMAT(' MINE HIT ',2A5,'-DAMAGE REPORT-') GO TO 270 271 WRITE(II81,273)IVV,INAME(1,MMIN),INAME(2,MMIN) 273 FORMAT(' EAGLE',I3,' HIT THE ',2A5,'-DAMAGE REPORT-') 270 CONTINUE CALL GRUP1(KLIGAT(DFLCT(MMIN)),MMIN) GO TO 215 308 MMIN=MMIN-4 IF(MMIN.GT.8)GO TO 205 DO 274 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 274 I81=I71+4 II81=I81+1 IF(IIV.EQ.2)GO TO 210 WRITE(II81,207)(IENM2(I,MMIN),I=1,4) 207 FORMAT(' MINE HIT ',4A4,'-DAMAGE REPORT-') GO TO 274 210 WRITE(II81,211)IVV,(IENM2(I,MMIN),I=1,4) 211 FORMAT(' EAGLE',I3,' HIT ',4A4,' -DAMAGE REPORT-') 274 CONTINUE CALL GRUP3(KLIGAT(DFLCK(MMIN)),MMIN) GO TO 215 205 IF(MMIN.GT.9)GO TO 224 DO 275 I71=1,2 IF(IBASR(I71).NE.I7)GO TO 275 IF(IBASC(I71).EQ.I8)GO TO 276 275 CONTINUE GO TO 220 276 MMIN=I71 DO 277 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 277 I81=I71+4 II81=I81+1 IF(IIV.EQ.2)GO TO 278 WRITE(II81,279)ISIDE(1,MMIN),ISIDE(2,MMIN),IBASE(MMIN) 279 FORMAT(' MINE HIT ',2A5,' STARBASE',I3,'-DAMAGE REPORT-') GO TO 277 278 WRITE(II81,280)IVV,ISIDE(1,MMIN),ISIDE(2,MMIN),IBASE(MMIN) 280 FORMAT(' EAGLE',I3,' HIT ',2A5,' STARBASE',I3,'-DAMAGE REPORT-') 277 CONTINUE CALL GRUP2(KLIGAT(DFLCB(MMIN)/3.),MMIN) GO TO 215 220 IF(IIV.EQ.2)GO TO 227 WRITE(LLL,228) 228 FORMAT(' MINE HAS COLLIDED WITH A STAR') GO TO 215 227 DO 282 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 282 I81=I71+4 II81=I81+1 WRITE(II81,229)IVV 229 FORMAT(' EAGLE',I3,' HAS COLLIDED WITH A STAR') 282 CONTINUE GO TO 215 221 WRITE(LLL,231) 231 FORMAT(' OUR SHIP HAS RECOVERED A MINE') IPHOT(IT)=IPHOT(IT)+1 GO TO 215 222 IF(MMIN.GT.15)GO TO 225 DO 283 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 283 I81=I71+4 II81=I81+1 WRITE(II81,233)IVV 233 FORMAT(' EAGLE',I3,' DESTROYED IN ION STORM') 283 CONTINUE GO TO 215 223 IF(MMIN.GT.14)GO TO 222 MMAP(I7,I8)=IBLK IF(IIV.EQ.2)GO TO 234 WRITE(LLL,235) 235 FORMAT(' MINE DESTROYED ON COLLISION WITH ANOTHER MINE') GO TO 215 234 DO 281 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 281 I81=I71+4 II81=I81+1 WRITE(II81,236)IVV 236 FORMAT(' EAGLE',I3,' DESTROYED WHEN HIT WITH MINE') 281 CONTINUE GO TO 215 224 IF(MMIN.GT.10)GO TO 223 DO 237 I=1,LAUNCH IF(I7.EQ.IGLER(I).AND.I8.EQ.IGLEC(I))GO TO 238 237 CONTINUE 238 DO 242 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 242 I81=I71+4 II81=I81+1 IF(IIV.EQ.1)GO TO 240 WRITE(II81,239)IVV,I 239 FORMAT(' EAGLE',I3,' COLLIDED WITH EAGLE',I3/' BOTH EAGLES * DESTROYED') GO TO 242 240 WRITE(II81,241)I 241 FORMAT(' EAGLE',I3,' DESTROYED WHEN IT HIT A MINE') 242 CONTINUE CALL BOOM(I) GO TO 215 225 IF(MMIN.GT.16)GO TO 226 N=2 243 I71=I7 I81=I8 itzro=0 itvl1=1 rtzro=0.0 rtvl1=1.5 CALL HORTA(I71,I81,IENTR(IT),IENTC(IT),rtvl1, *itzro,itzro,itzro,itvl1,itzro,itzro) IF(MMIN.EQ.20)GO TO 243 226 MMAP(IPUR,IPUC)=IBLK IF(IIV.EQ.2)GO TO 244 MMAP(I7,I8)=IM(IT) WRITE(LLL,245)I8,I7 245 FORMAT(' MINE MOVED TO (',I2,',',I2,')') GO TO 400 244 MMAP(I7,I8)=IGLE IGLER(IVV)=I7 IGLEC(IVV)=I8 WRITE(LLL,246)IVV,I8,17 246 FORMAT(' EAGLE',I3,' MOVED TO (',I2,',',I2,')') GO TO 400 215 IF(IIV.EQ.2)GO TO 247 MMAP(IPUR,IPUC)=IBLK GO TO 400 247 CALL BOOM(IVV) GO TO 400 400 RETURN END C================================================= C C TREK7 MODULE D C CONVERTED TO PC BY: DAN GAHLINGER C ENTIRE MODULE TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C SHIP INITIALIZATION AND TERMINATION C C HADES TOPHET EREBUS CHARON STYX BELIAL C HARLIE FIZBIN TIMEX MENDEZ KZIN C C================================================= C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - HADES - C SUBROUTINE HADES 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /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 /U/LAUNCH,NUMOUT,NUME(2) N=I J=IBPSB(N) IF(J.NE.0)GO TO 54 I3=I3-1 GO TO 763 54 II(J)=II(J)-1 IBPSB(N)=0 763 CALL TOPHET(N) IF(N.NE.7)RETURN 766 IV=I7-7 IVV=I8-7 IV1=I7+7 IZA=I8+7 IF(IV.LE.0)IV=1 IF(IVV.LE.0)IVV=1 IF(IV1.GT.60)IV1=60 IF(IZA.GT.60)IZA=60 DO 780 N=IV,IV1 DO 780 J=IVV,IZA IF((I8-J)**2+(I7-N)**2.LE.49)MMAP(N,J)=IBLK 780 CONTINUE DO 769 N=1,8 IF(ICHOS(N).EQ.0)GO TO 769 IF(N.EQ.7)GO TO 769 IF((IKLNC(N)-I8)**2+(IKLNR(N)-I7)**2.GT.49)GO TO 769 ISPOK(N)=0 CALL TOPHET(N) 769 CONTINUE IF(NUMOUT.EQ.0)GO TO 7690 DO 7691 N=1,LAUNCH IF(IGLER(N).EQ.0)GO TO 7691 IF((IGLER(N)-I7)**2+(IGLEC(N)-I8)**2.GT.49)GO TO 7691 DO 540 KOENIG=1,4 IF(ICHOE(KOENIG).EQ.0)GO TO 540 J=KOENIG+4 JJJ=J+1 WRITE(JJJ,7692)N 7692 FORMAT(' EAGLE',I3,' DESTROYED BY EXPLOSION') 540 CONTINUE CALL BOOM(N) 7691 CONTINUE 7690 DO 55 KOENIG=1,4 IF(ICHOE(KOENIG).EQ.0)GO TO 55 IF((IENTC(KOENIG)-I8)**2+(IENTR(KOENIG)-I7)**2.GT.49)GO TO 55 DO 56 J=1,4 IF(ICHOE(J).EQ.0)GO TO 56 IV=J+4 IVI=IV+1 WRITE(IVI,772)(INAME(IQ0,KOENIG),IQ0=1,3) 772 FORMAT(' THE ',3A4,' HAS BEEN ENGULFED BY THE EXPLOSION'/' FROM * THE DOOMSDAY MACHINE') 56 CONTINUE DFLCT(KOENIG)=-10. 55 CONTINUE DO 58 N=1,2 IF(ICHOB(N).EQ.0)GO TO 58 IF((IBASC(N)-I8)**2+(IBASR(N)-I7)**2.GT.49)GO TO 58 DFLCB(N)=-10. DO 580 J=1,4 IF(ICHOE(J).EQ.0)GO TO 580 I7=J+4 II7=I7+1 WRITE(II7,59)(ISIDE(IQ0,N),IQ0=1,3),IBASE(N) 59 FORMAT(1X,3A4,' STARBASE',I3,' ENGULFED BY EXPLOSION FROM DOOMSDAY *MACHINE') 580 CONTINUE 58 CONTINUE DO 57 N=1,5 IF(LI2R(N).EQ.0)GO TO 57 IF((LI2R(N)-I7)**2+(LI2C(N)-I8)**2.GT.49)GO TO 57 LI2R(N)=0 LI2C(N)=0 57 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/26/2000 BY: D.G. C C - TOPHET C SUBROUTINE TOPHET(NX) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) ICHOS(NX)=0 IF(NX.EQ.7)GO TO 52 IF(IBPOB(NX).EQ.0)GO TO 52 IBPOB(NX)=0 IBPOB(7)=IBPOB(7)-1 52 I7=IKLNR(NX) I8=IKLNC(NX) IKLNR(NX)=0 IKLNC(NX)=0 IF(ISTAT.EQ.2)GO TO 165 MMAP(I7,I8)=IBLK IF(ISPOK(N).EQ.1)MMAP(I7,I8)=III 165 DO 53 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 53 J=IV+4 JJJ=J+1 WRITE(JJJ,102)(IENM2(MMIN,NX),MMIN=1,4) 102 FORMAT(/' SENSORS REPORT THAT AN EXPLOSION HAS PULVERIZED THE '14A *4/' INTO POWDERED DUST') 53 CONTINUE DO 50 J=1,2 IF(NX+4.EQ.IWEB(J))IWEB(J)=0 IF(NX.EQ.J*3)IWEB(J)=0 50 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/26/2000 BY: D.G. C C - EREBUS - C SUBROUTINE EREBUS 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /T/ICHOE(4),ICHOS(8),ICHOB(2) IF(ISTAT.EQ.2)GO TO 163 163 ICHOB(I)=0 DFLCB(I)=0 NDEAB(I)=0 IONB(I)=0 DO 156 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 156 N=I7+4 NNN=N+1 WRITE(NNN,157)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 157 FORMAT(' SENSORS REPORT THE DESTRUCTION OF ',3A4,' STARBASE',I3) 156 CONTINUE IBASE(I)=IBASE(I)+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/26/2000 BY: D.G. C C - CHARON - C SUBROUTINE CHARON 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) ICHOB(I)=2 NDEAB(I)=0 DO 158 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 158 N=I7+4 NNN=N+1 WRITE(NNN,159)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 159 FORMAT(' SENSORS DETECT NO LIFE FORMS ABOARD ',3A4,' STARBASE',I3) 158 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/26/200 BY: D.G. C C - STYX C SUBROUTINE STYX 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) 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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM CALL RANDO(IV,1,33) IVV=I+4 J=(I+1)/2 IIVV=IVV+1 2380 WRITE(IIVV,238)IBASE(J),(INAME(IQ0,I),IQ0=1,3) 238 FORMAT(' STARBASE',I3,' CALLING ',3A4,'.........'/' AN EXPLOSION H *AS OCCURRED IN') CALL FORBIN(J,IV,IVV,' ') WRITE(IIVV,2382) 2382 FORMAT(' AND HAS SPREAD AND ENGULFED YOUR SHIP, DESTROYING YOU'/ *' AND REDUCING YOUR SHIP TO A LUMP OF MOLTEN SLAG') IF(I.EQ.IT)MMIN=1 IF(ISTAT.EQ.2)GO TO 164 MMAP(IENTR(I),IENTC(I))=IBLK IF(ISPOT(I).EQ.1)MMAP(IENTR(I),IENTC(I))=III 164 DFLCT(I)=0 NDEAD(I)=0 IENTR(I)=0 IENTC(I)=0 ION(I)=0 ISPOT(I)=0 DO 135 I7=1,4 IF(I7.EQ.I)GO TO 135 IV=I7+4 IVI=IV+1 IF(ICHOE(I7).NE.0)WRITE(IVI,136)(INAME(IQ0,I),IQ0=1,3) 136 FORMAT(' SENSORS REPORT THE DESTRUCTION OF THE ',3A4) 135 CONTINUE IF(IWEB(1).EQ.I)IWEB(1)=0 IF(IWEB(2).EQ.I)IWEB(2)=0 I7=ICHOE(I) ICHOE(I)=3 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K. 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - BELIAL - C SUBROUTINE BELIAL COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) IVV=I+4 IIVV=IVV+1 WRITE(IIVV,615) 615 FORMAT(' CREW REMAINING IS ZERO'/9X,'THUS THERE IS NO ONE LEFT TO * CONTROL THE SHIP') NDEAD(I)=0 ICHOE(I)=2 DO 137 I7=1,4 IF(I7.EQ.I)GO TO 137 IV=I7+4 IVI=IV+1 IF(ICHOE(I7).NE.0)WRITE(IVI,136)(INAME(IQ0,I),IQ0=1,3) 136 FORMAT(' SENSORS DETECT NO LIFE FORMS ABOARD THE ',3A4) 137 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK (W/CONVERSION) 04/25/2000 BY: D.G. C - HARLIE C C THIS ROUTINE DOES THE DATA FILE ACCESS - NOTE FOR CONVERSION C SUBROUTINE HARLIE COMMON /W/IDEX(2,33,20) C C ORIGINAL COMMENTED CODE: C C OPEN(UNIT=1,DEVICE='DRA0:',ACCESS='RANDIN',MODE='ASCII',FILE='KIRK. C *DAT',DIRECTORY='050030.D.WORK',RECORD SIZE=80) C OPEN(UNIT=2,DEVICE='DRA0:',ACCESS='RANDIN',MODE='ASCII',FILE='KOLOTH C *.DAT',DIRECTORY='050030.D.WORK',RECORD SIZE=80) C C ORIGINAL CODE: C C OPEN(UNIT=1,TYPE='OLD',ACCESS='DIRECT', C *FORM='FORMATTED', C *RECORDTYPE='FIXED',RECORDSIZE=80,readonly, C *ORGANIZATION='RELATIVE',NAME='SYS$USERS:KIRK.DAT') C C OPEN(UNIT=2,TYPE='OLD',ACCESS='DIRECT', C *FORM='FORMATTED', C *RECORDTYPE='FIXED',RECORDSIZE=80,readonly, C *ORGANIZATION='RELATIVE',NAME='SYS$USERS:KOLOTH.DAT') C OPEN(UNIT=1,TYPE='OLD',readonly, *ORGANIZATION='SEQUENTIAL',NAME='KIRK.DAT') OPEN(UNIT=2,TYPE='OLD',readonly, *ORGANIZATION='SEQUENTIAL',NAME='KOLOTH.DAT') DO 1 I=1,33 C READ(1'I,10)(IDEX(1,I,J),J=1,20) C 1 READ(2'I,10)(IDEX(2,I,J),J=1,20) READ(1,10)(IDEX(1,I,J),J=1,20) 1 READ(2,10)(IDEX(2,I,J),J=1,20) 10 FORMAT(20A4) c close the files so that some other joe might play CLOSE(1) CLOSE(2) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - FIZBIN - C SUBROUTINE FIZBIN INTEGER LAP(3600),LA(132),LK(56),IGOM(8) EQUIVALENCE(LAP,MMAP),(LA,MA),(LK,K) C*** integer itom2,idev(2) integer*2 icnt C used by vax version 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCOL(4) COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4) COMMON /H/ANGLE(4),RANG(4),LOCKT(4) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /J/KODE(2,8),STATIC(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),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 /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) 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 /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /W/IDEX(2,33,20) COMMON /TOM/ITOM 94 CALL RANDO(IBASE(1),1,17) CALL RANDO(IBASE(2),1,17) IF(IBASE(1).EQ.IBASE(2))GO TO 94 CALL TIMEX LAUNCH=0 ISHAK=0 NUMOUT=0 DO 8910 I=1,25 IGLER(I)=0 IGLEC(I)=0 IBPSE(I)=0 8910 IBPOE(I)=0 ISTAT=0 MMIN=0 105 WRITE(LLL,104) 104 FORMAT(' ENTER THE MANUALLY-OPERATED SHIPS YOU WISH BY ENTERING A * STRING CONTAINING-'/' ''E'' FOR ENTERPRISE, ''P'' FOR POTEMPKIN *FEDERATION),'/' ''H'' FOR HAVOC, ''C'' FOR CARNAGE (KLINGON)') READ(L,332)(IGOM(I),I=1,4) 332 FORMAT(4A1) 107 DO 108 I=1,4 ICHOE(I)=0 DO 108 J=1,4 IF(IGOM(J).NE.IEE(I))GO TO 108 ICHOE(I)=1 ISTAT=ISTAT+1 108 CONTINUE C PRINT 11122,ISTAT,ICHOE(1),IGOM(1),I C11122 FORMAT(//' 108 ISTAT=',I4,' ICHOE(1)=',I4,' IGOM(1)=',A1,' I=',I4) IF(ISTAT.EQ.0)GO TO 105 IF(ISTAT.EQ.1.AND.ICHOE(1).EQ.1)GO TO 111 WRITE(LLL,109) C109 FORMAT(' WHEN I STOP TYPING, HIT %C AND ENTER THE FOLLOWING COMMAN C *DS-'/' ASSIGN TTYAA 5'/' ASS TTYBB 6'/' ASS TTYCC 7'/' ASS TTY C *DD E3'/' . CONTINUE'/' '//' (WHERE AA, BB, CC, DD ARE THE TTY''S C * CONTROLLING THE ENTERPRISE, '/' POTEMPKIN, HAVOC AND CARNAGE RESPE C *CTIVELY)'/' (IF YOU''RE NOT PLAYING SOME OF THE SHIPS, DON''T BOTH C *ER'/' ENTERING THEIR ASSIGN COMMANDS)'/' (IF YOU''VE HAD THE FORES C *IGHT TO DO ALL THIS, JUST HIT )') C READ(L,92)NA C92 FORMAT(A1) 109 FORMAT(' It is time to assign terminals to TREK7. To do *this you need to know'/' the device name of the terminals *that you will be using.'/' If you do not know this then *stop the game and find out.'/' To do this type "show term", *the first piece of information is the name of our terminal'/' *for example "TUB1:". Find out the name of all the terminals *'/' and then restart the game.') c***vax version c icnt=5 do 926 itom2=1,4 if(igom(itom2).eq.'E')goto 921 if(igom(itom2).eq.'P')goto 922 if(igom(itom2).eq.'H')goto 923 if(igom(itom2).eq.'C')goto 924 goto 926 c c 921 write(L,9211) 9211 format(' If you want the Enterprise to play off of this *terminal then type a blank.'/' Do not type in the name of *this terminal, This causes the game to die.') read(L,9212)(idev(j),j=1,2) 9212 format(2(a4)) if(idev(1).eq.' ')goto 926 goto 926 c c 922 write(L,9221) 9221 format(' The Potempkin is assigned to terminal ',$) read(L,9222)(idev(j),j=1,2) 9222 format(2(a4)) goto 926 c c 923 write(L,9231) 9231 format(' The Havoc is assigned to terminal ',$) read(L,9232)(idev(j),j=1,2) 9232 format(2(a4)) goto 926 c c 924 write(L,9241) 9241 format(' The Carnage is assigned to terminal ',$) read(L,9242)(idev(j),j=1,2) 9242 format(2(a4)) c c 926 continue c c c C*** C111 PRINT 11133,ISTAT,ICHOE(1),IGOM(1),I C11133 FORMAT(//' 111 ISTAT=',I4,' ICHOE(1)=',I4,' IGOM(1)=',A1,' I=',I4) 111 DO 110 I=1,4 C PRINT 11188,I,ICHOE(I) C11188 FORMAT(//' INSIDE TOP OF 110 LOOP, I=',I4,' ICHOE(I)=',I4//) IF(ICHOE(I).EQ.0)GO TO 110 C PRINT 11266,I,IPHOT(I),IENTR(I) C11266 FORMAT(//' RSTUPID TEST I=',I4,' IPHOT(I)=',I4,' IENTR(I)=',I4//) CALL RANDO(IENTR(I),1,60) C PRINT 11244,I,IPHOT(1),IPHOT(I) C11244 FORMAT(//' 3STUPID TEST I=',I4,' IPHOT(1)=',I4,' IPHOT(I)=',I4//) CALL RANDO(IENTC(I),1,60) C PRINT 11255,I,IPHOT(1),IPHOT(I) C11255 FORMAT(//' 4STUPID TEST I=',I4,' IPHOT(1)=',I4,' IPHOT(I)=',I4//) IBPSC(I)=I ISPOT(I)=0 ION(I)=0 ZAP(I)=0 INVIS(I)=0 TWARP(I)=10. LOCK(I)=-1 LOCKT(I)=-1 ICOIL(I)=0 WARP(I)=0. NOMOV(I)=0 IPHOT(I)=12 C PRINT 11199,IPHOT(I) C11199 FORMAT(//' IN 110 LOOP JUST SET IPHOT TO 12, IPHOT(I)=',I4//) C PRINT 11211,I,IPHOT(1),IPHOT(I) C11211 FORMAT(//' STUPID TEST I=',I4,' IPHOT(1)=',I4,' IPHOT(I)=',I4//) PHASR(I)=6000. DFLCT(I)=100. ISURR(I)=0 RANG(I)=10. NOMAP(I)=15 MANUM(I)=0 ITEMP(I)=4000 NDEAD(I)=430 NOMOV(I)=0 C PRINT 11233,I,IPHOT(1),IPHOT(I) C11233 FORMAT(//' 2STUPID TEST I=',I4,' IPHOT(1)=',I4,' IPHOT(I)=',I4//) LI2(I)=0 C PRINT 11177,I,IPHOT(I) C11177 FORMAT(//' IN 110 LOOP, I=',I4,' IPHOT(I)=',I6//) 110 CONTINUE C PRINT 11144,ISTAT,ICHOE(1),IGOM(1),I C11144 FORMAT(//' 110 ISTAT=',I4,' ICHOE(1)=',I4,' IGOM(1)=',A1,' I=',I4) I3=0 DO 120 I=1,2 II(I)=0 NUME(I)=0 ICHOB(I)=0 IONB(I)=0 IBPSS(I)=I NDEAB(I)=1000 IPHOB(I)=20 IWEB(I)=0 IGOB(I)=0 IFIB(I)=0 120 DFLCB(I)=300. INDUZ=0 IXRYZ=0 IWEBZ=0 ISTAZ=0 KILLR=1 KILLG=1 KILLD=1 IONNO=0 112 CALL RANDO(I7,1,4) IF(ICHOE(I7).EQ.0)GO TO 112 L=I7+4 DO 113 I=1,4 IF(I.EQ.I7.OR.ICHOE(I).EQ.0)GO TO 113 I8=I+4 II8=I8+1 IF(I8.EQ.5)I8=6 WRITE(II8,114)(INAME(IQ0,I7),IQ0=1,3) 114 FORMAT(' PLEASE WAIT WHILE THE ',3A4,' CHOOSES THE ENEMIES') IF(I8.EQ.6)I8=5 113 CONTINUE WRITE(LLL,751) 751 FORMAT(' PICK THE OPPONENT(S) YOU WISH TO FIGHT BY TYPING IN A STR *ING OF LETTERS-'/' EACH LETTER CORRESPONDING TO THE OPPONENT YOU W *ISH TO BATTLE.'/' TYPE ''K'' FOR KLINGONS, ''R'' FOR ROMULANS'/' *''T'' FOR THOLIANS, ''G'' FOR GORNS'/' ''O'' FOR ORIONS, ''Z'' FOR * KZINTI'/' ''D'' FOR A DOOMSDAY MACHINE'/' AND/OR ''A'' FOR MOONBA *SE ALPHA') READ(L,752)(IGOM(I),I=1,8) 752 FORMAT(8A1) DO 7531 I=1,8 DFLCK(I)=100. IBPOB(I)=0 IBPSB(I)=0 ICHOS(I)=0 ISPOK(I)=0 IONK(I)=0 IGOCO(I)=1 DO 753 J=1,8 IF(IGOM(J).NE.IENM1(I))GO TO 753 ICHOS(I)=1 753 CONTINUE 7531 CONTINUE DFLCK(8)=70. IF(ICHOS(6).EQ.1)CALL KZIN IF(IGO(1).EQ.1)GO TO 1260 DO 501 I=1,3600 501 LAP(I)=IBLK CALL RANDO(IV,0,10) IF(IV.EQ.0)GO TO 1260 DO 647 N=1,IV 648 CALL RANDO(IVV,4,11) CALL RANDO(MMIN,1,60) CALL RANDO(J,1,60) I7=MMIN+IVV I8=J+IVV IF(I7.GT.60)GO TO 648 IF(I8.GT.60)GO TO 648 DO 649 IVV=J,I8 DO 649 I=MMIN,I7 649 MMAP(I,IVV)=III 647 CONTINUE 1260 II(1)=ICHOE(1)+ICHOE(2) II(2)=ICHOE(3)+ICHOE(4) IJ(1)=II(1) IJ(2)=II(2) DO 115 I=1,8 115 IF(ICHOS(I).EQ.1)I3=I3+1 DO 119 IVV=1,2 J=3-IVV IF(II(IVV).EQ.0.OR.II(J).NE.0)GO TO 119 CALL MENDEZ(J) 119 CONTINUE DO 116 IVV=1,2 IF(II(IVV).EQ.0)GO TO 116 IF(ICHOB(IVV).NE.0)GO TO 116 IF(II(3-IVV).NE.ICHOB(3-IVV))GO TO 117 IF(3*II(IVV).GT.I3)GO TO 116 117 CALL MENDEZ(IVV) 116 CONTINUE IF(II(2).EQ.0.AND.I3.EQ.0)ISHAK=1 IF(II(1).EQ.0.AND.I3.EQ.0)ISHAK=1 IF(ISHAK.EQ.0)GO TO 126 DO 122 J=1,4 I=J+4 II1=I+1 IF(ICHOE(J).EQ.1)WRITE(II1,6100) 6100 FORMAT(' BEGINNING SHAKEDOWN CRUISE') 122 CONTINUE 126 IF(IGO(1).EQ.1)GO TO 5020 WRITE(LLL,610) 610 FORMAT(' HOW MANY STARS DO YOU WISH IN YOUR 60 X 60 FIELD - BETWEE *N 0 AND 500') GO TO 655 1262 CALL ILLDAT GO TO 126 655 READ(L,*,ERR=1262)DISTP 1261 IF(DISTP.GT.1500.)GO TO 126 24 FORMAT(F15.7) 123 I7=IFIX(DISTP) IF(I7.LT.0)GO TO 126 ISTAT=0 IF(I7.EQ.0)GO TO 5022 DO 502 I=1,17 CALL RANDO(IV,1,60) CALL RANDO(IVV,1,60) IF(ISTAT.GE.5)GO TO 502 CALL RANDO(J,1,100) IF(J.GT.5)GO TO 502 ISTAT=ISTAT+1 LI2R(ISTAT)=IV LI2C(ISTAT)=IVV 502 MMAP(IV,IVV)=ISTAR 5022 IF(ISTAT.GE.5)GO TO 5020 DO 5021 I=ISTAT+1,5 LI2R(I)=0 5021 LI2C(I)=0 5020 DO 125 I=1,4 IF(ICHOE(I).EQ.0)GO TO 125 IF(MMAP(IENTR(I),IENTC(I)).NE.III)GO TO 1250 ISPOT(I)=1 ION(I)=1 1250 MMAP(IENTR(I),IENTC(I))=IEE(I) 125 CONTINUE DO 754 I=1,8 IKLNR(I)=0 IKLNC(I)=0 IF(ICHOS(I).NE.1)GO TO 754 7501 CALL RANDO(I7,2,59) CALL RANDO(I8,2,59) NA=MMAP(I7,I8) IF(NA.NE.IBLK.AND.NA.NE.ISTAR.AND.NA.NE.III)GO TO 7501 IF(I.EQ.8.AND.NA.EQ.III)GO TO 7501 IKLNR(I)=I7 IKLNC(I)=I8 7502 IF(I.NE.6.OR.ICHOS(6).EQ.0)GO TO 750 CALL NIVEN GO TO 754 750 CALL ASIMOV(NA,I) 151 MMAP(I7,I8)=IENM1(I) 754 CONTINUE IF(ICHOS(2).EQ.0)GO TO 89 DO 127 I=1,4 IF(ICHOE(I).EQ.0)GO TO 127 IF(DI(IKLNC(2),IKLNR(2),IENTC(I),IENTR(I)).GE.5)GO TO 127 INVIS(I)=1 127 CONTINUE 890 IF(IARMZ(5).EQ.0)GO TO 89 IF(ICHOS(6).EQ.0)GO TO 89 DO 891 I=1,4 IF(ICHOE(I).EQ.0)GO TO 891 IF(DI(IKLNC(6),IKLNR(6),IENTC(I),IENTR(I)).GE.ICLOZ)GO TO 891 INVIZ(I)=1 891 CONTINUE 89 ISTAT=0 DO 170 I=1,8 KODE(1,I)=0 170 KODE(2,I)=0 DO 171 I=1,2 CALL RANDO(IV,0,2) IF(IV.EQ.0)GO TO 171 CALL RANDO(I8,1,8) KODE(I,I8)=1 CALL RANDO(JTK,0,2) IF(JTK.NE.0)GO TO 171 IVV=2*I DO 1710 MMIN=IVV-1,IVV IF(ICHOE(MMIN).EQ.0)GO TO 1710 J=MMIN+4 JJJ=J+1 WRITE(JJJ,172)I8 172 FORMAT(' INTELLIGENCE REPORTS THAT THE ENEMY HAVE BROKEN CODE',I2) 1710 CONTINUE 171 CONTINUE DO 118 I=1,56 LA(I)=0 118 LK(I)=0 DO 747 I=57,132 747 LA(I)=0 IF(ICHOS(8).NE.1)GO TO 8900 CALL LEGUIN(0,0) 8900 RETURN END C - TAKES A LICKIN' BUT KEEPS ON TICKIN' C CONVETED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. (JOKE - THIS NEVER GETS USED!) C C TIMEX C SUBROUTINE TIMEX IMPLICIT INTEGER (A-Z) DIMENSION I(2),MON(12),F(12) C FOLLOWING DATA CREATES AN ERROR SO WE FUDGE IT C DATA MON/-28580569024,-30711668672,-26969825216,-33349361600, C *-26969595840,-28496682944,-28496748480,-33328750528,-23731888064, C *-25887629248,-26374102976,-31785377728/ C HERES MY NEW CODE APR/21/2000 C THIS NEVER GETS USED, SO NOBODY CARES C DATA MON/9024,8672,5216,1600, C *5840,2944,8480,528,8064, C *9248,2976,7728/ C DATA F/0,3,3,6,1,4,6,2,5,0,3,5/ C NEW FORTRAN AND Y2K CHANGE THE NEXT TWO LINES, NO LONGER VALID C CALL DATE(I) C CALL TIME(D,A) C FAKE CODE ENTERED NEXT TWO LINES TO FIX ANOTHER BUG (FAKE BUG) D=1 IF(D.EQ.2)GO TO 99 C LINE BELOW CAUSES FALSE ERROR IN TIMEX LINE 18 RETURN C ABOVE LINE MAY GENERATE A FALSE ERROR C CALL SETRAN(M) 99 STOP END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/26/2000 BY: D.G. C C - MENDEZ SUBROUTINE MENDEZ(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),LLL,II1,INA,IVI,II7,II8,NNN 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 /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM I=1 N=4 IF(II(1).EQ.0)I=3 IF(II(2).EQ.0)N=2 IF(J.EQ.2.AND.ICHOB(1).EQ.1)I=3 DO 1 MMIN=I,N IF(ICHOE(MMIN).EQ.0)GO TO 1 I8=MMIN+4 II8=I8+1 WRITE(II8,2)(ISIDE(IQ0,J),IQ0=1,3) 2 FORMAT(' DO YOU WISH A ',3A4,' STARBASE?') READ(I8,3)NA 3 FORMAT(A1) IF(NA.NE.'Y')GO TO 4 1 CONTINUE ICHOB(J)=1 CALL RANDO(IBASR(J),1,60) CALL RANDO(IBASC(J),1,60) IF(MMAP(IBASR(J),IBASC(J)).EQ.III)IONB(J)=1 MMAP(IBASR(J),IBASC(J))=ISTAR II(J)=II(J)+1 RETURN 4 DO 5 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 5 IF(IV.EQ.MMIN)GO TO 5 I8=IV+4 II8=I8+1 WRITE(II8,6)(ISIDE(IQ0,J),IQ0=1,3),(INAME(IQ0,MMIN),IQ0=1,3) 6 FORMAT(1X,3A4,' STARBASE VETOED BY ',3A4) 5 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/26/2000 BY: D.G. C C - KZIN - C SUBROUTINE KZIN COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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),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 /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /S/IBPOB(8),IBPOE(25) COMMON /V/IWEB(2),IWEBZ,INVIS(4) 1 IF(IBPOB(6).NE.0)RETURN WRITE(LLL,2) 2 FORMAT(' THE KZINTI ARE A SPECIAL ENEMY- THEY ARE PLAYER PROGRAMMA *BLE.'/' THUS THE PLAYER ENTERS PARAMETERS REGARDING THE ENEMY STRE *NGTH'/' AND STRATEGY.') 7 WRITE(LLL,3) 3 FORMAT(//' TYPE OF STRATEGY -- ENTER A NUMBER-'/ *' ''1'' FOR ATTACK/RETREAT'/ *' ''2'' FOR KAMIKAZE'/ *' ''3'' FOR CLOSE PASSES (EG. ORIONS)') N=1 READ(L,9,ERR=73)DISTP IPLANZ=IFIX(DISTP) IF(IPLANZ.LT.1.OR.IPLANZ.GT.3)GO TO 7 IF(IPLANZ.NE.1)GO TO 15 10 WRITE(LLL,8) 8 FORMAT(' ENTER A NUMBER REPRESENTING BY HOW MUCH YOUR *'/' DEFLECTORS MUST EXCEED THE KZINTIS'' BEFORE THE KZINTI START' */'TO RETREAT.'/' EG. 30 MEANS THE KZINTI RETREAT WHEN YOUR * DEFLECTORS ARE'/5X,' GREATER THAN THEIRS BY AT LEAST 30.'/, *' EG. -30 MEANS THE KZINTI RETREAT UNLESS THEY EXCEED YOUR *'/5x,' DEFLECTORS BY AT LEAST 30.') N=2 READ(L,9,ERR=73)DISTP 9 FORMAT(F15.7) IRUNZ=IFIX(DISTP) 131 WRITE(LLL,130) 130 FORMAT(' ENTER A NUMBER (IN DEGREES BETWEEN 0 AND 180) REPRESENTI *NG'/' THE MAXIMUM ANGLE THE KZINTIS` PATH MAY DEVIATE FROM A PATH * HEADING'/' STRAIGHT TOWARDS YOU (ATTACK) OR STRAIGHT AWAY FROM Yo *U (RETREAT).'/' EG. 0 MEANS THEY WILL HEAD STRAIGHT FOR YOU WHEN T *HEY ATTACK'/5X,'OR STRAIGHT AWAY FROM YOU WHEN THE RETREAT.'/' EG. * 90 MEANS THEIR PATH MAY RANDOMLY DEVIATE OFF TO THE SIDE A MAXIMU *M'/5X,'OF 90 DEGREES FROM HEADING STAIGHT AT YOU OR STAIGHT AWAY F *ROM YOU') N=3 READ(L,9,ERR=73)DISTP IDEVZ=IFIX(DISTP) IF(IDEVZ.LT.0.OR.IDEVZ.GT.180)GO TO 131 15 WRITE(LLL,16) 16 FORMAT(' TYPE OF ENGINES -- ENTER A NUMBER-'/ *' ''1'' FOR IONIC DRIVE ENGINES'/ *' ''2'' FOR WARP DRIVE ENGINES') N=4 READ(L,9,ERR=73)DISTP IDRIZ=IFIX(DISTP) IF(IDRIZ.LT.1.OR.IDRIZ.GT.2)GO TO 15 21 WRITE(LLL,20) 20 FORMAT(' ENTER MAXIMUM WARP -- BETWEEN 2 AND 12') N=5 READ(L,9,ERR=73)DISTP IMAXZ=IFIX(DISTP) IF(IMAXZ.LT.2.OR.IMAXZ.GT.12)GO TO 21 WRITE(LLL,25) 25 FORMAT(' DO YOU WANT THE KZINTIS'' SPEED TO BE UNAFFECTED BY ION S *TORMS?') N=6 READ(L,11,ERR=73)NA 11 FORMAT(A1) IF(NA.EQ.'Y')IONNO=1 30 WRITE(LLL,31) 31 FORMAT(' ARMAMENT -- ENTER A STRING OF DIGITS-'/ *' ''1'' FOR INDUCTION BEAMS'/ *' ''2'' FOR X-RAY LASER CANNON'/ *' ''3'' FOR WEB (LIKE THOLIAN''S)'/ *' ''4'' FOR DECOY IMAGES'/ *' ''5'' FOR CLOAKING DEVICE'/ *' AND/OR ''6'' FOR STASIS FIELD') READ(L,32,ERR=73)(IONK(I7),I7=1,6) 32 FORMAT(6I1) DO 33 I8=1,6 IARMZ(I8)=0 DO 33 I7=1,6 IF(IONK(I7).EQ.I8)IARMZ(I8)=1 33 CONTINUE DO 330 I8=1,6 330 IONK(I8)=0 IF(IARMZ(1).EQ.0)GO TO 40 35 WRITE(LLL,34) 34 FORMAT(' ENTER INDUCTION BEAM STRENGTH IN PHASER UNITS') N=7 READ(L,9,ERR=73)DISTP IF(DISTP.GE.250.)GO TO 400 WRITE(LLL,401) 401 FORMAT(' NUMBER TOO SMALL') GO TO 35 400 INDUZ=IFIX(DISTP)/10 40 IF(IARMZ(2).EQ.0)GO TO 70 71 WRITE(LLL,72) 72 FORMAT(' ENTER X-RAY CANNON STRENGTH IN PHASER UNITS') N=8 READ(L,9,ERR=73)DISTP IF(DISTP.GE.250.)GO TO 700 WRITE(LLL,401) GO TO 71 700 IXRYZ=IFIX(DISTP)/10 70 IF(IARMZ(3).EQ.0)GO TO 50 41 WRITE(LLL,42) 42 FORMAT(' ENTER RANGE OF WEB') N=9 READ(L,9,ERR=73)DISTP IWEBZ=IFIX(DISTP) IF(IWEBZ.LE.0)GO TO 41 50 IF(IARMZ(4).EQ.0)GO TO 53 54 WRITE(LLL,55) 55 FORMAT(' ENTER NUMBER OF FALSE IMAGES TO BE GENERATED- * AT MOST 15') N=10 READ(L,9,ERR=73)DISTP IMAGZ=IFIX(DISTP) IF(IMAGZ.LT.0.OR.IMAGZ.GT.15)GO TO 54 58 WRITE(LLL,57) 57 FORMAT(' ENTER RADIUS WITHIN WHICH THE IMAGES ARE TO BE * GENERATED') N=11 READ(L,9,ERR=73)DISTP IMAGRZ=IFIX(DISTP) IF(IMAGRZ.LT.1.OR.IMAGRZ.GT.50)GO TO 58 53 IF(IARMZ(5).EQ.0)GO TO 60 51 WRITE(LLL,52) 52 FORMAT(' ENTER RANGE AT WHICH ENTERPRISE CAN DETECT THE KZINTI SH *IP'/' THROUGH THE CLOAKING DEVICE') N=12 READ(L,9,ERR=73)DISTP ICLOZ=IFIX(DISTP) IF(ICLOZ.LE.0)GO TO 51 60 IF(IARMZ(6).EQ.0)GO TO 29 61 WRITE(LLL,62) 62 FORMAT(' ENTER RANGE OF STASIS FIELD') N=13 READ(L,9,ERR=73)DISTP IABSZ=IFIX(DISTP) IF(IABSZ.LE.0)GO TO 61 64 WRITE(LLL,63) 63 FORMAT('ENTER STRENGTH OF STASIS FIELD IN EQUIVALENT PHASER UNIT *S PER TURN') N=14 READ(L,9,ERR=73)DISTP ISTAZ=IFIX(DISTP) IF(ISTAZ.LT.1)GO TO 64 29 KILLZ=100 WRITE(LLL,27) 27 FORMAT(' IF YOU WISH THE KZINTI TO BE NEUTRAL UNTIL FIRED AT'/' O *R UNTIL YOU COME WITHIN A CERTAIN RANGE, ENTER THE RANGE AT WHICH' */' THEY BECOME HOSTILE.'/' IF NOT, TYPE ''100''.') N=15 READ(L,9,ERR=73)DISTP KILLZ=IFIX(DISTP) IF(KILLZ.LE.0.OR.KILLZ.GT.100)GO TO 29 280 IF(IARMZ(1).EQ.1.OR.IARMZ(2).EQ.1)GO TO 28 IARMZ(1)=1 IARMZ(2)=1 INDUZ=90 IXRYZ=90 28 RETURN 73 CALL ILLDAT GO TO (7,10,131,15,21,30,35,71,41,54,58,51,61,64,280),N END C==================================================== C TREK7 MODULE E C CONVERTED TO PC BY: DAN GAHLINGER C ENTIRE MODULE TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C C-O SHIP OPERATIONS C C ATACK MORDOR PIKE DOOMVE EDIBLE MNERVA C ASIMOV NIVEN WODEN ALPHA SIMAK LEGUIN C C==================================================== C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C AAA TTTTT AAA CCC K K C A A T A A C K K C AAAAA T AAAAA C KKK C A A T A A C K K C A A T A A CCC K K C SUBROUTINE ATACK LOGICAL MORDOR integer itzro,itvl1 real rtzro,rtvl1 COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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),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 /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM DO 1000 I=1,8 N=4 DIST(I)=100. IF(ICHOS(I).NE.1)GO TO 1000 IF(IWEB(1).EQ.I+4)GO TO 1000 IF(IWEB(2).EQ.I+4)GO TO 1000 IF(IO.EQ.1)PRINT 1970,I 1970 FORMAT(' BEGIN ATACK I=',I7) IF(MORDOR(MM,MN,RAD,BERNG))GO TO 1000 IF(I.EQ.5.OR.I.EQ.6)GO TO 10100 GO TO 1010 1010 N=4 10100 BERNG=BERNG*3.14159265/180. AJUST=0.0 IGNORE=0 IV=I+4 IF(IONNO.EQ.1.AND.I.EQ.6)IGNORE=1 itzro=0 10101 CALL HORTA(IKLNR(I),IKLNC(I),MM,MN,RAD,BERNG, *itzro,AJUST,IGNORE,DIST(I),itzro) IF(IO.EQ.1)PRINT 1972,MMIN,I7,I8,DISTP 1972 FORMAT(' MMIN=',I7,' I7=',I7,' I8=',I7,' DISTP=',F15.7) IF(MMIN.LT.5)GO TO 101 IF(MMIN.LT.15)GO TO 100 IF(MMIN.LT.19)GO TO 103 IF(MMIN.EQ.19)GO TO 102 IF(MMIN.EQ.21)GO TO 106 100 IF(I.GT.3)GO TO 106 AJUST=AJUST+0.2617993 IF(AJUST.GT.6.283184)GO TO 107 IONK(I)=0 IGNORE=0 GO TO 10101 106 RAD=RAD-DISTP+1.42 IVV=0 IF(IONNO.EQ.1.AND.I.EQ.6)IGNORE=1 1060 IVVV=N N=2 10801 I81=I8 I71=I7 rtzro=0.0 itvl1=1 rtvl1=1.5 CALL HORTA(I71,I81,IKLNR(I),IKLNC(I), *rtvl1,rtzro,itzro,rtzro,itvl1,rtzro,itzro) IF(MMIN.NE.I+4.AND.MMIN.NE.19.AND.MMIN.LT.21)GO TO 10801 1080 MMAP(IKLNR(I),IKLNC(I))=IBLK IF(ISPOK(I).EQ.1)MMAP(IKLNR(I),IKLNC(I))=III ISPOK(I)=0 IKLNR(I)=I7 IKLNC(I)=I8 IF(MMAP(I7,I8).EQ.III)ISPOK(I)=1 IF(IVV.EQ.1)GO TO 10093 IF(IVV.EQ.2)GO TO 10101 N=IVVV AJUST=AJUST+0.7653981 IF(AJUST.GT.10.)GO TO 10093 GO TO 10101 101 IF(N.EQ.5)GO TO 106 IF(N.EQ.6)GO TO 1061 IVV=1 GO TO 1060 102 RAD=(RAD-DISTP)/2. IONK(I)=1 IGNORE=1 IVV=2 GO TO 1080 107 IVV=1 GO TO 1060 103 CALL MNERVA(I) IVV=1 MMAP(I7,I8)=IBLK GO TO 1080 108 IVV=1 GO TO 1080 1061 DO 535 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 535 L=IV+4 WRITE(LLL,1062)(INAME(IQ0,MMIN),IQ0=1,3) 1062 FORMAT(' THE KZINTI WARSHIP HAS RAMMED THE ',3A4) 535 CONTINUE MMAP(I7,I8)=IBLK MMAP(IKLNR(6),IKLNC(6))=IBLK IF(ISPOK(6).EQ.1)MMAP(IKLNR(6),IKLNC(6))=III DFLCT(MMIN)=-1. DFLCK(6)=-1. ISTAT=2 RETURN 10093 IF(I.NE.6)GO TO 1063 CALL NIVEN GO TO 1000 1063 CALL ASIMOV(MMAP(IKLNR(I),IKLNC(I)),I) IF(I.NE.2)GO TO 1029 1205 N=DFLCK(I)/5. IF(N.EQ.0)GO TO 672 CALL RANDO(J,1,N) IF(J.GT.1)GO TO 1029 672 DO 536 IV=1,4 IF(ICHOE(IV).NE.1)GO TO 536 L=IV+4 INVIS(IV)=1 WRITE(LLL,1030) 1030 FORMAT(' THERE HAS BEEN A BREAKDOWN IN THE ROMULAN WARSHIP''S CLO *AKNG DEVICE'/' AND THE SHIP CAN NOW BE PICKED UP BY OUR SENSORS') 536 CONTINUE 1029 MMAP(I7,I8)=IENM1(I) 1000 CONTINUE IF(ICHOS(8).EQ.0.AND.NUMOUT.EQ.0)RETURN KOENIG=1 CALL ALPHA 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 - MORDOR C C -WHERE THE SHADOWS LIE LOGICAL FUNCTION MORDOR(MM,MN,RAD,BERNG) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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),LI2R(5),LI2C(5),IGO(4),MINES COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /G/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM MORDOR=.TRUE. CALL PIKE(IKLNR(I),IKLNC(I),IBPSB(I)) IF(MMIN.EQ.0)GO TO 1000 DIST(I)=DISTP IWHO(I)=MMIN IF(I.EQ.8)GO TO 1000 IF(MMIN.GT.4)GO TO 500 MM=IENTR(MMIN) MN=IENTC(MMIN) A=DFLCT(MMIN) GO TO 501 500 IF(MMIN.GT.6)GO TO 502 I7=MMIN-4 MM=IBASR(I7) MN=IBASC(I7) A=DFLCB(I7) GO TO 501 502 IF(MMIN.GT.14)GO TO 503 I7=MMIN-6 MM=IKLNR(I7) MN=IKLNC(I7) A=DFLCK(I7) GO TO 501 503 I7=MMIN-14 MM=IGLER(I7) MN=IGLEC(I7) A=0 501 AJUST=0. IONK(I)=0 GO TO (1006,1001,1002,1007,1011,110,1012),I 1006 CALL RANDO(J,7,9) IF(DIST(I).LE.1.5)GO TO 1000 RAD=FLOAT(J) 1005 AJUST=0.0 1009 IF(IBPSB(I).EQ.0.OR.IGOCO(I).EQ.0)GO TO 600 DISTP=100. IVV=0 DO 601 IV=1,4 IF(ICHOE(IV).NE.1.OR.(IBPSC(IV)+1)/2.NE.IBPSB(I))GO TO 601 B=DI(IKLNR(I),IKLNC(I),IENTR(IV),IENTC(IV)) IF(B.GT.DISTP)GO TO 601 IVV=IV DISTP=B 601 CONTINUE IF(IVV.EQ.0)GO TO 600 MM=IENTR(IVV) MN=IENTC(IVV) AJUST=0. N=4 600 IV=MM-IKLNR(I) IVV=MN-IKLNC(I) BERNG=ANG(IV,IVV) 1101 BERNG=BERNG+AJUST IF(BERNG.LT.0)BERNG=BERNG+360. IF(BERNG.GT.360.)BERNG=BERNG-360. DO 504 I7=1,4 IF(ICHOE(I7).NE.1)GO TO 504 CALL DUNSEL(IKLNR(I),IKLNC(I),RAD,BERNG) 504 CONTINUE MORDOR=.FALSE. 1000 RETURN 1001 CALL RANDO(J,7,9) RAD=FLOAT(J) IV=KILLR DO 10010 J=1,4 10010 INVIS(J)=0 IF(DISTP.LE.10..OR.KILLR.NE.1)KILLR=2 IF(A-DFLCK(2).GT.20.)KILLR=3 IV=IV-KILLR I71=MMIN+4 GO TO (1003,10031,1004),KILLR 1003 CALL RANDO(J,1,360) BERNG=FLOAT(J) GO TO 1009 10031 CALL RANDO(J,-90,90) AJUST=FLOAT(J) II71=I71+1 IF(MMIN.LT.5.AND.IV.NE.0)WRITE(II71,10032) 10032 FORMAT(' ROMULAN SHIP ATTACKING') GO TO 1009 1004 CALL RANDO(J,90,270) AJUST=FLOAT(J) II71=I71+1 IF(MMIN.LT.5.AND.IV.NE.0)WRITE(II71,10033) 10033 FORMAT(' ROMULAN SHIP RETREATING') GO TO 1009 1002 IF(DISTP.LE.8.)GO TO 1000 CALL RANDO(J,5,10) RAD=FLOAT(J) IF(DISTP-8..LT.RAD)RAD=DISTP-6.5 GO TO 1005 1007 RAD=11. KILLG=1 IF(DFLCK(4)-A.LT.25.)KILLG=2 IF(KILLG.EQ.1)GO TO 1005 1008 AJUST=180. GO TO 1009 1011 RAD=12. 123 AJUST=ABS(ATAN(1.1/DISTP))*180./3.14159265 N=5 GO TO 1009 110 RAD=IMAXZ N=4 IF(IDRIZ.EQ.1)ISTAT=11 IF(KILLZ.EQ.100)GO TO 124 IF(DISTP.LE.KILLZ)GO TO 125 CALL RANDO(I7,1,360) AJUST=I7 GO TO 1009 125 KILLZ=100 124 GO TO (121,122,123),IPLANZ 121 AJUST=0. IF(A-DFLCK(6).GT.IRUNZ)AJUST=180. CALL RANDO(I7,-IDEVZ,IDEVZ) AJUST=AJUST+I7 GO TO 1009 122 AJUST=0. N=6 GO TO 1009 1012 CALL DOOMVE(MM,MN) GO TO 1000 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - PIKE - C SUBROUTINE PIKE(J1,J2,J3) 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /G/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 /U/LAUNCH,NUMOUT,NUME(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) DISTP=100. MMIN=0 DO 1 IVV=1,4 IF(ICHOE(IVV).EQ.0.OR.ICHOE(IVV).EQ.3)GO TO 1 IF(J3.EQ.(IBPSC(IVV)+1)/2)GO TO 1 AJUST=DI(J1,J2,IENTR(IVV),IENTC(IVV)) IF(AJUST.GE.DISTP)GO TO 1 IF(AJUST.EQ.0)GO TO 1 DISTP=AJUST MMIN=IVV 1 CONTINUE DO 2 IVV=1,2 IF(ICHOB(IVV).EQ.0)GO TO 2 IF(J3.EQ.IBPSS(IVV))GO TO 2 AJUST=DI(J1,J2,IBASR(IVV),IBASC(IVV)) IF(AJUST.GE.DISTP)GO TO 2 IF(AJUST.EQ.0)GO TO 2 IF(J3.EQ.0.AND.IJ(IBPSS(IVV)).EQ.0)GO TO 2 DISTP=AJUST MMIN=IVV+4 2 CONTINUE DO 3 IVV=1,8 IF(ICHOS(IVV).NE.1)GO TO 3 IF(J3.EQ.IBPSB(IVV))GO TO 3 AJUST=DI(J1,J2,IKLNR(IVV),IKLNC(IVV)) IF(AJUST.GE.DISTP)GO TO 3 IF(AJUST.EQ.0)GO TO 3 IF(IVV.NE.2)GO TO 10 IF(INVIS(2*J3-1)+INVIS(2*J3).EQ.0.OR.AJUST.GT.5)GO TO 3 GO TO 11 10 IF(IVV.NE.6.OR.IARMZ(5).EQ.0)GO TO 11 IF(INVIZ(2*J3-1)+INVIZ(2*J3).EQ.0.OR.AJUST.GT.ICLOZ)GO TO 3 11 DISTP=AJUST MMIN=IVV+6 3 CONTINUE 4 IF(NUMOUT.EQ.0)RETURN DO 5 IVV=1,LAUNCH IF(IGLER(IVV).EQ.0)GO TO 5 IF(J3.EQ.IBPSE(IVV))GO TO 5 AJUST=DI(J1,J2,IGLER(IVV),IGLEC(IVV)) IF(AJUST.GE.DISTP)GO TO 5 IF(AJUST.EQ.0)GO TO 5 DISTP=AJUST MMIN=IVV+14 5 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 - DOOMVE - C SUBROUTINE DOOMVE(MM,MN) INTEGER EDIBLE COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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),LI2R(5),LI2C(5),IGD(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 /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM 1012 IGNORE=IFIX(DISTP) DO 506 N=I,IGNORE IVVV=IKLNR(7)-N+1 IVV=IKLNR(7)+N-1 I71=IKLNC(7)-N I81=IKLNC(7)+N IF(IVVV.LT.1)IVVV=1 IF(I71.LT.1)I71=1 IF(IVV.GT.60)IVV=60 IF(I81.GT.60)I81=60 I7=IKLNR(7)-N IF(I7.LT.1)GO TO 507 DO 508 I8=I71,I81 J=EDIBLE(MM,MN) IF(J.GT.0)GO TO 510 508 CONTINUE 507 I7=IKLNR(7)+N IF(I7.GT.60)GO TO 509 DO 511 I8=I71,I81 J=EDIBLE(MM,MN) IF(J.GT.0)GO TO 510 511 CONTINUE 509 I8=IKLNC(7)-N IF(I8.LT.1)GO TO 512 DO 513 I7=IVVV,IVV J=EDIBLE(MM,MN) IF(J.GT.0)GO TO 510 513 CONTINUE 512 I8=IKLNC(7)+N IF(I8.GT.60)GO TO 506 DO 515 I7=IVVV,IVV J=EDIBLE(MM,MN) IF(J.GT.0)GO TO 510 515 CONTINUE 506 CONTINUE I7=MM I8=MN GO TO 517 510 IV=IKLNC(7) IVV=IKLNR(7) MMAP(IVV,IV)=IBLK IF(ISPOK(7).EQ.1)MMAP(IVV,IV)=III ISPOK(7)=0 IKLNC(7)=I8 IKLNR(7)=I7 MMAP(I7,I8)=IENM1(7) GO TO (514,516,517),J 514 DO 518 IV=1,5 IF(I7.NE.LI2R(IV))GO TO 516 IF(I8.NE.LI2C(IV))GO TO 516 LI2C(IV)=0 LI2R(IV)=0 GO TO 1000 518 CONTINUE DO 519 IV=1,2 IF(I7.NE.IBASR(IV))GO TO 519 IF(I8.NE.IBASC(IV))GO TO 519 529 DFLCB(IV)=-1. ISTAT=2 DO 5190 IVV=1,4 IF(ICHOE(IVV).EQ.0)GO TO 5190 I71=IVV+4 II71=I71+1 WRITE(II71,521)(ISIDE(IQ0,IV),IQ0=1,3),IBASE(IV) 521 FORMAT(' THE DOOMSDAY MACHINE HAS EATEN ',3A4,' STARBASE',I3) 5190 CONTINUE 519 CONTINUE GO TO 1000 516 CALL RANDO(IV,1,7) IF(IV.GT.2)GO TO 520 DO 522 J=1,4 IF(ICHOE(J).EQ.0)GO TO 522 IV=J+4 IVI=IV+1 WRITE(IVI,523) 523 FORMAT(' THE DOOMSDAY MACHINE HAS JUST EATEN A MINE - NO DAMAGE') 522 CONTINUE GO TO 1000 520 CALL MNERVA(7) GO TO 1000 517 ISTAT=2 IF(MMIN.GT.4)GO TO 525 DFLCT(MMIN)=-1. DO 526 IVV=1,4 IF(ICHOE(IVV).EQ.0)GO TO 526 IV=IVV+4 IVI=IV+1 WRITE(IVI,527)(INAME(IQ0,MMIN),IQ0=1,3) 527 FORMAT(' THE DOOMSDAY MACHINE HAS EATEN THE ',3A4) 526 CONTINUE GO TO 1000 525 IF(MMIN.GT.6)GO TO 528 IV=MMIN-4 GO TO 529 528 IF(MMIN.GT.14)GO TO 530 MMIN=MMIN-6 DFLCK(MMIN)=-1. DO 531 IVV=1,4 IF(ICHOE(IVV).EQ.0)GO TO 531 IV=IVV+4 IVI=IV+1 WRITE(IVI,532)(IENM2(J,MMIN),J=1,4) 532 FORMAT(' THE DOOMSDAY MACHINE HAS EATEN THE ',4A4) 531 CONTINUE GO TO 1000 530 MMIN=MMIN-14 CALL BOOM(MMIN) DO 533 IVV=1,4 IF(ICHOE(IVV).EQ.0)GO TO 533 IV=IVV+4 IVI=IV+1 WRITE(IVI,534)MMIN 534 FORMAT(' THE DOOMSDAY MACHINE HAS EATEN EAGLE',I3) 533 CONTINUE GO TO 1000 1000 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 - EDIBLE - C INTEGER FUNCTION EDIBLE(MM,MN) 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),LLL,II1,INA,IVI,II7,II8,NNN 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) EDIBLE=0 NA=MMAP(I7,I8) IF(NA.EQ.IBLK.OR.NA.EQ.III)RETURN IF(NA.NE.ISTAR)GO TO 1 DO 3 IK=1,2 IF(MM.EQ.IBASR(IK).AND.MN.EQ.IBASC(IK).AND.IJ(IBPSS(IK)).EQ.0) *RETURN 3 CONTINUE EDIBLE=1 RETURN 1 IF(NA.LT.'1'.OR.NA.GT.'4')GO TO 2 EDIBLE=2 RETURN 2 IF(MM.NE.I7)RETURN IF(MN.EQ.I8)EDIBLE=3 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 - MNERVA - C SUBROUTINE MNERVA(J) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IEE(4),MINES COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM CALL RANDO(IV,10,100) IVV=IFIX(ALOG((101.-DFLCK(J))*IV+10.)/0.700619195-1.8185) DO 141 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 141 L=IV+4 WRITE(LLL,401)(IENM2(N,J),N=1,4) 401 FORMAT(1X,4A4,' HAS COLLIDED WITH A MINE - DAMAGE REPORT-') 141 CONTINUE CALL GRUP3(IVV,J) MINES=MINES-1 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K C CONVERTED TO PC BY: DAN GAHLINGER C TYPE-EXACT CHECK 04/27/2000 BY: D.G. C C - ASIMOV - C SUBROUTINE ASIMOV(NA,K) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR IF(NA.NE.III)RETURN IONK(K)=1 ISPOK(K)=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 - NIVEN - C SUBROUTINE NIVEN LOGICAL WODEN COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGD(4),MINES COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /Q/IARMZ(6),INDUZ,IXRYZ,IMAGZ,IMAGRZ,IABSZ,ISTAZ,INVIZ(4), *ICLOZ,IONNO,IPLANZ,IRUNZ,IDEVZ,IDRIZ,IMAXZ COMMON /TOM/ITOM 85 IF(IARMZ(4).EQ.0)GO TO 81 IF(IMAGZ.EQ.0)GO TO 81 MMIN=0 DO 86 N=1,IMAGZ 87 CALL RANDO(IV,-IMAGRZ,IMAGRZ) CALL RANDO(IVV,-IMAGRZ,IMAGRZ) MMIN=MMIN+1 IF(MMIN.GT.20)GO TO 81 IV=IKLNR(6)+IV IVV=IKLNC(6)+IVV IF(.NOT.WODEN(IV,IVV,MMAP(IV,IVV)))GO TO 87 MMIN=0 86 MMAP(IV,IVV)=IENM1(6) DO 83 MMIN = 1,20 CALL RANDO(IV,IKLNR(6)-3,IKLNR(6)+3) CALL RANDO(IVV,IKLNC(6)-3,IKLNC(6)+3) IF(.NOT.WODEN(IV,IVV,MMAP(IV,IVV)))GO TO 83 IKLNR(6)=IV IKLNC(6)=IVV GO TO 88 83 CONTINUE 88 CALL ASIMOV(MMAP(IKLNR(6),IKLNC(6)),6) 81 MMAP(IKLNR(6),IKLNC(6))=IENM1(6) 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 - WODEN - C LOGICAL FUNCTION WODEN(I,J,NA) LOGICAL CYRANO COMMON /M/MMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR WODEN=.FALSE. IF(CYRANO(I,J))RETURN IF(NA.NE.IBLK.AND.NA.NE.III.AND.NA.NE.IENM1(6))RETURN WODEN=.TRUE. RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C checked type-exact 04/24/2000 by DG C C - ALPHA - C SUBROUTINE ALPHA integer itzro,itvl1 real rtzro,rtvl1 COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) CALL SIMAK(J1,J2) ISTAT=0 I=0 IV=0 BDIS=DI(J1,J2,IKLNR(8),IKLNC(8)) IF(IO.EQ.1)PRINT 1978,J1,J2,BDIS 1978 FORMAT(' BEGIN ALPHA J1=',I5,' J2=',I5,' BDIS=',F15.7) DO 2 IVV=1,LAUNCH IF(IGLER(IVV).EQ.0)GO TO 2 RAD=2.9 I7=J1-IGLER(IVV) I8=J2-IGLEC(IVV) IF(BDIS.LE.5.)GO TO 18 IF(IABS(I7).LE.3.AND.IABS(I8).LE.3)GO TO 2 18 BERNG=ANG(I7,I8)*3.14159265/180. AJUST=0.0 7 N=4 IGNORE=0 itzro=0 CALL HORTA(IGLER(IVV),IGLEC(IVV), *itzro,itzro,RAD,BERNG,itzro,AJUST,IGNORE,itzro,itzro) IF(IO.EQ.1)PRINT 1979,IVV,MMIN,I7,I8 1979 FORMAT(' =#=',I3,' MMIN=',I5,' I7=',I5,' I8=',I5) IF(MMIN.GE.15.AND.MMIN.LE.18)GO TO 5 IF(MMIN.EQ.21)GO TO 10 I=1 RAD=RAD-DISTP+1.42 AJUST=AJUST+0.785398163 IF(AJUST.GT.7.)GO TO 2 N=2 I4=0 6 I71=I7 I81=I8 IGNORE=0 I4=I4+1 rtzro=0.0 itzro=0 rtvl1=1.5 CALL HORTA(I71,I81,IGLER(IVV),IGLEC(IVV), *rtvl1,rtzro,itzro,rtzro,IGNORE,itzro,itzro) 1981 IF(MMIN.EQ.14.AND.I7.EQ.IGLER(IVV).AND.I8.EQ.IGLEC(IVV))GO TO 11 IF(MMIN.LT.21)GO TO 6 11 MMAP(IGLER(IVV),IGLEC(IVV))=IBLK MMAP(I7,I8)=IGLE IGLER(IVV)=I7 IGLEC(IVV)=I8 IF(I.EQ.1)GO TO 7 GO TO 2 5 DO 12 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 12 I81=I71+4 II81=I81+1 WRITE(II81,8)IVV 8 FORMAT(' EAGLE',I3,' DESTROYED ON COLLISION WITH A MINE') 12 CONTINUE MMAP(I7,I8)=IBLK CALL BOOM(IVV) MINES=MINES-1 GO TO 2 10 I=0 GO TO 11 2 CONTINUE IF(LAUNCH.LT.25.AND.ICHOS(8).NE.0)CALL LEGUIN(J1,J2) 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 - SIMAK - C SUBROUTINE SIMAK(J1,J2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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/T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) I71=IKLNR(8) I81=IKLNC(8) DO 13 I=1,LAUNCH IF(IGLER(I).EQ.0)GO TO 13 I71=IGLER(I) I81=IGLEC(I) GO TO 14 13 CONTINUE 14 AJUST=100. JTK=0 DO 15 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 15 DISTP=DI(IENTR(I7),IENTC(I7),I71,I81) IF(DISTP.GT.AJUST)GO TO 15 AJUST=DISTP JTK=I7 15 CONTINUE 16 J1=IENTR(JTK) J2=IENTC(JTK) 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 - LEGUIN - C SUBROUTINE LEGUIN(J3,J4) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /U/LAUNCH,NUMOUT,NUME(2) COMMON /TOM/ITOM J1=J3 J2=J4 IF(J1.EQ.0)CALL SIMAK(J1,J2) I71=J1-IKLNR(8) IVV=J2-IKLNC(8) DISTP=0.785396163 IF(I71.EQ.0)DISTP=0. IF(IVV.EQ.0)DISTP=2.0*DISTP IF(IVV.LT.0)DISTP=3.14159265-DISTP IF(I71.LT.0)DISTP=-DISTP AJUST=0.0 I81=1 I8=LAUNCH+1 107 IF(I8.GT.25)GO TO 113 I71=IFIX(1.8*SIN(DISTP+AJUST))+IKLNR(8) IVV=IFIX(1.8*COS(DISTP+AJUST))+IKLNC(8) IF(MMAP(I71,IVV).EQ.IBLK)GO TO 105 101 DO 122 JTK=1,4 IF(MMAP(I71,IVV).EQ.IEE(JTK))GO TO 123 IF(MMAP(I71,IVV).EQ.IM(JTK))GO TO 102 122 CONTINUE GO TO 110 123 DO 124 MMIN=1,4 IF(ICHOE(MMIN).EQ.0)GO TO 124 N=MMIN+4 NNN=N+1 WRITE(NNN,103)I8,(INAME(IQ0,JTK),IQ0=1,3),I8, *(INAME(IQ0,JTK),IQ0=1,3) 103 FORMAT(' EAGLE',I3, ' CRASHED INTO ',3A4, ' ON TAKE-OFF'/ *' EAGLE',I3,' DESTROYED'/1X,3A4,' DAMAGE REPORT-') 124 CONTINUE CALL RANDO(IV,1,100) J1=ALOG((101.-DFLCT(JTK))*IV+10.)/0.700619195-1.8185 CALL GRUP1(J1,JTK) NUMOUT=NUMOUT-1 IGLER(I8)=0 IGLEC(I8)=0 GO TO 106 102 DO 125 J1=1,4 IF(ICHOE(J1).EQ.0)GO TO 125 J2=J1+4 JJ2=J2+1 WRITE(JJ2,104)I8 104 FORMAT(' EAGLE',I3,' DESTROYED ON COLLISION WITH A MINE') 125 CONTINUE MMAP(I71,IVV)=IBLK MINES=MINES-1 NUMOUT=NUMOUT-1 IGLER(I8)=0 IGLEC(I8)=0 GO TO 106 105 MMAP(I71,IVV)=IGLE IGLER(I8)=I71 IGLEC(I8)=IVV IF(IBPOB(8).EQ.0)GO TO 1060 IBPOB(8)=IBPOB(8)-2 NUME(IBPSB(8))=NUME(IBPSB(8))+1 II(IBPSB(8))=II(IBPSB(8))+1 IBPOE(I8)=2 IBPSE(I8)=IBPSB(8) GO TO 106 1060 I3=I3+1 106 I81=I81+1 I8=I8+1 110 IF(AJUST.GT.0)GO TO 111 AJUST=0.765398163-AJUST GO TO 112 111 AJUST=-AJUST 112 IF(AJUST.GT.-6.28.AND.I81.LE.5)GO TO 107 113 LAUNCH=LAUNCH+I81-1 NUMOUT=NUMOUT+I81-1 120 RETURN END C====================================================================== C C TREK7 MODULE F C CONVERTED TO PC BY: DAN GAHLINGER C ENTIRE MODULE TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C SHIP DAMAGE ROUTINES C C BOOM LIRPA GRUP1 GRUP2 GRUP3 TPAU C OXMYX GOTU GOTME FORBIN QUARK POS C C====================================================================== C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - BOOM C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE BOOM(J) 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),LLL,II1,INA,IVI,II7,II8,NNN 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 /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/MMMAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /S/IBPOB(8),IBPOE(25) COMMON /U/LAUNCH,NUMOUT,NUME(2) IF(ISTAT.EQ.2)GO TO 2 MMMAP(IGLER(J),IGLEC(J))=IBLK 2 IGLER(J)=0 IGLEC(J)=0 NUMOUT=NUMOUT-1 IF(IBPOE(J).EQ.0)GO TO 1 IBPOE(J)=0 II(IBPSE(J))=II(IBPSE(J))-1 NUME(IBPSE(J))=NUME(IBPSE(J))-1 IBPSE(J)=0 RETURN 1 I3=I3-1 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - LIRPA C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C INTEGER FUNCTION LIRPA(AA,II) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN LIRPA=ALOG((101.-AA)*II*II/DISTP)/0.700619195-6.605 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C C - GRUP 1 C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE GRUP1(IVV,MI) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) IVA=IXIF(IVV) CALL GOTME(IVA,MI) DFLCT(MI)=DFLCT(MI)-FLOAT(IVA)*1.6 DO 350 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 350 IF(I71.EQ.IBPSC(MI))GO TO 350 CALL GOTU(IVA,I71) 350 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - GRUP2 - C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE GRUP2(IVV,MI) COMMON /B/NDEAB(2),IPHOB(2),IONB(2),IGOB(2),IFIB(2) COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IVA=IXIF(IVV) DFLCB(MI)=DFLCB(MI)-FLOAT(IVA)*1.6 DO 351 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 351 CALL GOTU(IVA,I71) 351 CONTINUE IGOB(MI)=1 CALL RANDO(I8,IVA/2,IVA*2) NDEAB(MI)=NDEAB(MI)-I8 IF(NDEAB(MI).LT.0)NDEAB(MI)=0 IF(IVA.GT.2)IFIB(MI)=0 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C C - GRUP3 - C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE GRUP3(IVV,MI) 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 /S/IBPOB(8),IBPOE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IVA=IVV IF(IONK(MI).EQ.1)IVA=IVV+2 IVA=IXIF(IVA) DFLCK(MI)=DFLCK(MI)-FLOAT(IVA)*1.6 DO 352 I71=1,4 IF(ICHOE(I71).EQ.0)GO TO 352 CALL GOTU(IVA,I71) 352 CONTINUE IF(IBPOB(MI).EQ.0)GO TO 374 CALL RANDO(I8,IVA/2,IVA) IBPOB(MI)=IBPOB(MI)-I8 IF(IBPOB(MI).GT.0)GO TO 374 CALL TPAU(MI) CALL OXMYX 374 IF(MI.EQ.2)KILLR=2 IF(MI.EQ.7)KILLD=2 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C CONVERTED TO PC BY: DAN GAHLINGER C C - TPAU - C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE TPAU(J) 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),LLL,II1,INA,IVI,II7,II8,NNN 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) DO 142 IV=1,4 IF(ICHOE(IV).EQ.0)GO TO 142 I7=IV+4 II7=I7+1 WRITE(II7,207)(IENM2(N,J),N=1,4) 207 FORMAT(' CONTROL OF THE ',4A4,' HAS BEEN LOST') 142 CONTINUE II(IBPSB(J))=II(IBPSB(J))-1 IBPSB(J)=0 IBPOB(7)=IBPOB(7)-1 I3=I3+1 IBPOB(J)=0 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K C CONVERTED TO PC BY: DAN GAHLINGER C C - OXMYX - C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE OXMYX COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /V/IWEB(2),IWEBZ,INVIS(4) DO 133 N=1,2 IF(IWEB(N).GT.4)GO TO 134 IF(IBPSB(3*N).EQ.(IBPSC(IWEB(N))+1)/2)IWEB(N)=0 GO TO 133 134 IF(IWEB(N).EQ.0)GO TO 133 IF(IBPSB(3*N).EQ.IBPSB(IWEB(N)-4))IWEB(N)=0 133 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - GOTU - C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C SUBROUTINE GOTU(IVV,I71) L=I71+4 GO TO (40,43,45,90,48,92,52,55,58,61,62),IVV+1 40 WRITE(LLL,42) 42 FORMAT(' NO DAMAGE') GO TO 50 43 WRITE(LLL,242) 242 FORMAT(' DAMAGE FACTOR 1- VERY LITTLE DAMAGE SUSTAINED') GO TO 50 45 WRITE(LLL,47) 47 FORMAT(' DAMAGE FACTOR 2- MINOR DAMAGE SUSTAINED') GO TO 50 90 WRITE(LLL,91) 91 FORMAT(' DAMAGE FACTOR 3- MINOR STRUCTURAL DAMAGE'/16X,'- THERE IS * A DENT IN THE VESSEL') GO TO 50 48 WRITE(LLL,51) 51 FORMAT(' DAMAGE FACTOR 4- VESSEL MODERATELY DAMAGED') GO TO 50 92 WRITE(LLL,93) 93 FORMAT(' DAMAGE FACTOR 5- LIFE SUPPORT SYSTEM BREAKDOWN IN PARTS * OF THE VESSEL') GO TO 50 52 WRITE(LLL,54) 54 FORMAT(' DAMAGE FACTOR 6- HEAVY INTERNAL DAMAGE TO VESSEL') GO TO 50 55 WRITE(LLL,57) 57 FORMAT(' DAMAGE FACTOR 7- HEAVY STRUCTURAL DAMAGE TO VESSEL') GO TO 50 58 WRITE(LLL,60) 60 FORMAT(' DAMAGE FACTOR 8- A NUMBER OF DECKS HAVE RUPTURED ON THE * VESSEL') GO TO 50 61 WRITE(LLL,63) 63 FORMAT(' DAMAGE FACTOR 9- THE VESSEL HAS BEEN ROCKED BY AN EXP *LOSION') GO TO 50 62 WRITE(LLL,64) 64 FORMAT(' DAMAGE FACTOR 10- VESSEL PARTIALLY DESTROYED') 50 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 - C CONVERTED TO PC BY: DAN GAHLINGER C C -GOTME - C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C SUBROUTINE GOTME(IVL,IT) INTEGER POS COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /TOM/ITOM IVV=IVL IC=0 JJ=0 L=IBPSC(IT)+4 IS=(IT+1)/2 IF(IVV.EQ.0)GO TO 110 IF(IVV.EQ.1)GO TO 112 113 IVVV=IVV-1 1130 DO 121 J=1,33 IF(MA(IT,J).LT.IVVV)GO TO 111 121 CONTINUE IVV=IVV+1 IF(IVV.LE.10)GO TO 113 DFLCT(IT)=-1. GO TO 232 111 JJ=JJ+IFIX(FLOAT(IVVV+1)*1.6+0.5) IF(IVVV.EQ.IC)GO TO 200 GO TO (114,120,1200,1212,130,137,145,155,156),IVVV 110 WRITE(LLL,42) 42 FORMAT(' NO DAMAGE') GO TO 232 112 WRITE(LLL,242) 242 FORMAT(' DAMAGE FACTOR 1- VERY LITTLE DAMAGE SUSTAINED') GO TO 232 114 CALL RANDO(J,1,3) IF(J.NE.3)GO TO 119 WRITE(LLL,4005) 4005 FORMAT(' DAMAGE FACTOR 2- TOILETS HAVE BACKED UP IN') GO TO 200 119 WRITE(LLL,117) 117 FORMAT(' DAMAGE FACTOR 2- MINOR DAMAGE TO') GO TO 200 120 WRITE(LLL,1210) 1210 FORMAT('DAMAGE FACTOR 3- MINOR STRUCTURAL DAMAGE- THERE IS A DENT * IN') GO TO 200 1200 CALL RANDO(J,1,3) GO TO (123,50,4004),J 50 WRITE(LLL,51) 51 FORMAT(' DAMAGE FACTOR 4- POWER FAILURE IN') GO TO 200 4004 WRITE(LLL,4007) 4007 FORMAT(' DAMAGE FACTOR 4- THERE IS A BURST WATER MAIN IN') GO TO 200 123 WRITE(LLL,124) 124 FORMAT(' DAMAGE FACTOR 4- MODERATE DAMAGE TO') GO TO 200 1212 WRITE(LLL,1213) 1213 FORMAT(' DAMAGE FACTOR 5- LIFE SUPPORT SYSTEM BREAKDOWN IN') GO TO 200 130 WRITE(LLL,136) 136 FORMAT(' DAMAGE FACTOR 6- HEAVY DAMAGE TO') GO TO 200 137 WRITE(LLL,143) 143 FORMAT(' DAMAGE FACTOR 7- A FIRE HAS BROKEN OUT IN') GO TO 200 145 WRITE(LLL,153) 153 FORMAT(' DAMAGE FACTOR 8- AN EXPLOSION HAS OCCURRED IN') GO TO 200 155 WRITE(LLL,163) 163 FORMAT(' DAMAGE FACTOR 9- PARTIAL DESTRUCTION OF') GO TO 200 156 WRITE(LLL,173) 173 FORMAT(' DAMAGE FACTOR 10- DESTRUCTION OF') 200 CALL RANDO(IV,1,33) IF(MA(IT,IV).GE.IVVV)GO TO 200 IF(MA(IT,IV).NE.0)GO TO 701 MANUM(IT)=MANUM(IT)+1 701 IF(IVVV.NE.9)GO TO 70 IF(IV.LT.29)GO TO 70 IF(IV.GT.30)GO TO 70 MANUM(IT)=MANUM(IT)-1 70 MA(IT,IV)=IVVV CALL FORBIN(IS,IV,L,' ') IC=IVVV CALL RANDO(IV,1,15) IVVV=IVVV*IV/9 IF(IVVV.EQ.0)IVVV=1 IVV=IVVV+1 IF(IV.LE.9)GO TO 1130 402 IF(IT.EQ.1)CALL QUARK(L) 4015 IF(MA(IT,14).GT.K(IT,2))PHASR(IT)=PHASR(IT)-MA(IT,14)*300. IF(PHASR(IT).LT.0)PHASR(IT)=0. K(IT,2)=MA(IT,14) TWARP(IT)=TWARP(IT)-FLOAT(MA(IT,29)-K(IT,4))/2. TWARP(IT)=TWARP(IT)-FLOAT(MA(IT,30)-K(IT,5))/2. K(IT,4)=MA(IT,29) K(IT,5)=MA(IT,30) IF(MA(IT,28).LT.4.OR.K(IT,6).GE.4)GO TO 657 TWARP(IT)=TWARP(IT)-1. K(IT,6)=MA(IT,28) 657 IF(TWARP(IT).LT.0)TWARP(IT)=0 J=0 IF(IS.EQ.2)GO TO 100 IF(IT.NE.1)GO TO 5000 IF(K(1,10).GT.4.OR.MA(1,7).LE.4)GO TO 5000 J=1 WRITE(LLL,4010) 4010 FORMAT(' DR. MCCOY IS DEAD JIM') C ORIGINALLY IT SAID DR. MCCOY HAS CROAKED - CHANGED NOV. 15/1999 5000 IPHOT(IT)=IPHOT(IT)-IFIX(FLOAT(IPHOT(IT))*FLOAT(MA(IT,3)-K(IT,14)) */12.) K(IT,14)=MA(IT,3) IF(MA(IT,8).LT.4.OR.K(IT,3).EQ.1)GO TO 215 K(IT,3)=1 WRITE(LLL,4009) 4009 FORMAT(' CPU SYSTEM 2 HAS BEEN INITIALIZED AND IS TAKING OVER'/ *' THE FUNCTIONS OF THE DISABLED CPU UNIT') 215 IF(MA(IT,23).GT.K(IT,1))DFLCT(IT)=DFLCT(IT)-(MA(IT,23)-K(IT,1))*3 K(IT,1)=MA(IT,23) JJ=JJ+2*POS(MA(IT,4)-K(IT,7))+3*POS(MA(IT,5)-K(IT,8)) *+22*POS(MA(IT,6)-K(IT,9))+12*POS(MA(IT,7)-K(IT,10)) *+3*POS(MA(IT,21)-K(IT,11))+3*POS(MA(IT,22)-K(IT,12)) *+2*POS(MA(IT,23)-K(IT,13)) K(IT, 7)=MA(IT, 4) K(IT, 8)=MA(IT, 5) K(IT, 9)=MA(IT, 6) K(IT,10)=MA(IT, 7) K(IT,11)=MA(IT,21) K(IT,12)=MA(IT,22) K(IT,13)=MA(IT,23) NOMAP(IT)=15-MA(IT,33) GO TO 500 100 IPHOT(IT)=IPHOT(IT)-FLOAT(IPHOT(IT)*(MA(IT,29)+MA(IT,30)- *K(IT,14)))/24 K(IT,14)=MA(IT,29)+MA(IT,30) IF(MA(IT,5).LT.4.OR.K(IT,3).EQ.1)GO TO 101 K(IT,3)=1 WRITE(LLL,4007) 101 IF(MA(IT,13).GT.K(IT,1))DFLCT(IT)=DFLCT(IT)-(MA(IT,13)-K(IT,1))*3 K(IT,1)=MA(IT,13) JJ=JJ+I8*POS(MA(IT,8)-K(IT,7))+POS(MA(IT,10)-K(IT,8))+ *2*POS(MA(IT,11)-K(IT,9))+4*POS(MA(IT,17)-K(IT,10))+ *11*POS(MA(IT,19)-K(IT,11))+4*POS(MA(IT,21)-K(IT,12))+ *9*POS(MA(IT,22)-K(IT,13)) K(IT, 7)=MA(IT, 8) K(IT, 8)=MA(IT,10) K(IT, 9)=MA(IT,11) K(IT,10)=MA(IT,17) K(IT,11)=MA(IT,19) K(IT,12)=MA(IT,21) K(IT,13)=MA(IT,22) NOMAP(IT)=15-MA(IT,13) 500 CALL RANDO(IV,J,JJ) CALL RANDO(N,J,JJ) CALL RANDO(IC,0,JJ) CALL RANDO(IVVV,0,JJ) IF(N.GT.IV)IV=N NDEAD(IT)=NDEAD(IT)-IV IF(NDEAD(IT).GT.0)GO TO 5001 IV=IV+NDEAD(IT) NDEAD(IT)=0 IC=0 IVVV=0 5001 IGO(IT)=0 WRITE(LLL,406)IV,IC,IVVV 406 FORMAT('CASUALTIES-',I5,' KILLED',5X,I5,' WOUNDED',5X,I5, *' MAIMED') 232 CONTINUE RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - FORBIN C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C SUBROUTINE FORBIN(J,I,L,NA) CHARACTER*1 NA C ABOVE LINE SUGGESTED BY S.LIONEL (COMPAQ) COMMON /W/IDEX(2,33,20) K=16 2 IF(IDEX(J,I,K).NE.' ')GO TO 1 K=K-1 GO TO 2 1 WRITE(LLL,3)NA,(IDEX(J,I,M),M=1,K) 3 FORMAT(A1,1X,20A4) RETURN END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C CONVERTED TO PC BY: DAN GAHLINGER C C - QUARK - C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C SUBROUTINE QUARK(L1) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM CALL RANDO(IV,1,35) IF(IV.GT.7)GO TO 4015 GO TO(40152,4016,4018,40150,40151,40209,4021),IV 40152 WRITE(LLL,4017) 4017 FORMAT(' MR. SPOCK IS MAKING OBSCENE GESTURES BEHIND YOUR BACK') GO TO 4015 4016 WRITE(LLL,4019) 4019 FORMAT('SCOTTY IS MAKING RATHER DUBIOUS COMMENTS ABOUT *YOUR ANCESTRY') GO TO 4015 4018 WRITE(LLL,4020) 4020 FORMAT(' A MESSAGE HAS BEEN RECEIVED OVER SVB-SPACE RADIO. MESSAGE * AS FOLLOWS-'//25X,'--DIE FEDERATION PIGS--'//) GO TO 4015 40150 WRITE(LLL,40200) 40200 FORMAT(' THE ENTERPRISE''S PRIZE TURNIP HAS RUPTURED'/' DESTROYING * THE CREW''S MORALE') GO TO 4015 40151 IF(II(2)+ICHOS(1).EQ.0)GO TO 4015 CALL RANDO(IVVV,1,30000) AJUST=63.*FLOAT(IVVV) WRITE(LLL,40201)AJUST 40201 FORMAT(' THE KLINGONS HAVE JUST BEAMED ABOARD ',F8.0,' TRIBBLES') GO TO 4015 40209 IF(K(1,10).GT.4)GO TO 4015 WRITE(LLL,4022) 4022 FORMAT(' DR. MCCOY IS PASSING OUT THE CYANIDE TABLETS') GO TO 4015 4021 IF(K(1,10).GT.4)GO TO 4015 C NEXT LINE WAS L, BUT TO NORMALIZE, CHANGED CALL TO QUARK TO L1 THUS CHANGED LL1=L1+1 WRITE(LL1,4023) 4023 FORMAT(' SPOCK HAS MADE DR. MCCOY AN HONOURARY VULCAN',/,' BY *STUFFING HIS EARS IN A PENCIL SHARPENER') 4015 RETURN END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C CONVERTED TO PC BY: DAN GAHLINGER C - POS - C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C INTEGER FUNCTION POS(I) POS=I IF(POS.LT.0)POS=0 RETURN END C==================================================================== C * C TREK7 MODULE G * C * C -- CONVERTED TO PC BY: DAN GAHLINGER -- * C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C * C MISCALLANEOUS ROUTINES * C * C ENTEMP BALOK TALOS ENEMY MOLOCH DONE * C THOLIA KNUTH BLISH FINNEY SAURON MCCOY * C RPAIR * C * C==================================================================== C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C C - ENTEMP - C C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C DG NOV. 15/1999 - CALL_LIB$EOL AND SO FORTH ARE NOT PART OF ORIG PRINTOUT C CALL_LIB$EOL AND SO FORTH HAVE THUS BEEN REMOVED TO REFLECT ORIG SOURCE C SUBROUTINE ENTEMP(MOVE) 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4) COMMON /F/WARP(4),ITROW(4),ITCCL(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IF(MOVE.GT.0)GO TO 3331 IF(ITEMP(IT).EQ.4000)GO TO 546 ITEMP(IT)=ITEMP(IT)-600 GO TO 3332 3331 CALL RANDO(I7,75,125) IF(WARP(IT).GT.6.)GO TO 3333 ITEMP(IT)=ITEMP(IT)+(WARP(IT)-6.)*I7 GO TO 3332 3333 ITEMP(IT)=ITEMP(IT)+(WARP(IT)-6.)*FLOAT(I7)*(FLOAT(MA(IT,29))/9.+ *1.)*(FLOAT(MA(IT,30))/9.+1.) 3332 IF(ITEMP(IT).LT.4000)ITEMP(IT)=4000 WRITE(LLL,3334)ITEMP(IT) 3334 FORMAT(' ENGINE TEMP. = ',I5,' DEGREES') IF(ITEMP(IT).LT.5500)GO TO 546 IF(ITEMP(IT).GT.6200)GO TO 3335 3336 FORMAT(' ENGINES OVERHEATING -TEMPERATURES ARE NEAR CRITICAL') GO TO 546 3335 WRITE(LLL,3337) 3337 FORMAT(' TEMPERATURES ARE BOYOND CRITICAL POINT') IF(ITEMP(IT).GE.7500)WRITE(LLL,3338) 3338 FORMAT(' EXPLOSION IMMINENT!!!') CALL RANDO(I7,1,100) IF(I7.GT.(ITEMP(IT)-6200)/100)GO TO 546 I8=MA(IT,29)+MA(IT,30)+1 CALL RANDO(I7,0,I8) J=1 IF(I7.GT.MA(IT,29))J=2 IF(MA(IT,28+J).EQ.9)J=3-J IF(MA(IT,28+J).GT.0)MANUM(IT)=MANUM(IT)-1 MA(IT,28+J)=9 TWARP(IT)=TWARP(IT)-4.5+K(IT,3+J)/2 IF(TWARP(IT).LT.0)TWARP(IT)=0 K(IT,3+J)=9 WRITE(LLL,3339)J,J 3339 FORMAT(' ENGINEERING HERE SIR - MATTER AND ANTI-MATTER ARE NO WIT *HIN RED-ZONE PROXIMITY'/' AUTOMATIC RELAYS CUTTING IN..... NACELLE *',I2,' JETTISONNED'/' NACELLE',I2,' HAS EXPLODED - DAMAGE REPORT D *UE TO PROXIMITY OF BLAST-') DO 162 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 162 IF(I7.EQ.IT)GO TO 162 I8=I7+4 II8=I8+1 WRITE(II8,1630)(INAME(IQ0,IT),IQ0=1,3),J 1630 FORMAT(1X,3A4,' NACELLE',I2,' HAS EXPLODED - DAMAGE REPORT-') 162 CONTINUE IVV=10 CALL GRUP1(IVV,IT) 546 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C - BALOK - C SUBROUTINE BALOK 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM I7=IBPSS(I) IF(IJ(I7).EQ.0)I7=0 CALL PIKE(IBASR(I),IBASC(I),I7) IF(MMIN.EQ.0)GO TO 1 IF(DISTP.GT.20.)GO TO 1 DFLCB(I)=DFLCB(I)-5.0 CALL RANDO(IVV,1,100) IF(IVV.LE.DISTP*2.5)GO TO 1 IF(MMIN.GT.14)GO TO 2 IF(MMIN.GT.4)GO TO 3 DO 4 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 4 I8=I7+4 II8=I8+1 WRITE(II8,5)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(INAME(IQ0,MMIN),IQ0=1,3) 5 FORMAT(/1X,3A4,' STARBASE',I3,' HAS SCORED A HIT ON THE ',3A4,'-DA *MAGE REPORT-') 4 CONTINUE CALL GRUP1(LIRPA(DFLCT(MMIN),50),MMIN) GO TO 1 3 IF(MMIN.GT.6)GO TO 6 MMIN=MMIN-4 DO 7 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 7 I8=I7+4 II8=I8+1 WRITE(II8,8)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(ISIDE(IQ0,MMIN),IQ0=1,3),IBASE(MMIN) 8 FORMAT(/1X,3A4,' STARBASE',I3,' HIT ',3A4,' STARBASE',I3, *'-DAMAGE REPORT-') 7 CONTINUE CALL GRUP2(LIRPA(DFLCB(MMIN)/3.,50),MMIN) GO TO 1 6 MMIN=MMIN-6 IF(MMIN.NE.7)GO TO 15 CALL RANDO(I7,1,3) IF(I7.EQ.2)GO TO 15 DO 16 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 16 I8=I7+4 II8=I8+1 WRITE(II8,17)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 17 FORMAT(/1X,3A4,' STARBASE',I3,' PHASERS BOUNCED OFF DOOMSDAY * MACHINE') 16 CONTINUE GO TO 1 15 DO 9 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 9 I8=I7+4 II8=I8+1 WRITE(II8,18)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I), *(IENM2(IV,MMIN),IV=1,4) 18 FORMAT(/1X,3A4,' STARBASE',I3,' HIT ',4A4,'-DAMAGE REPORT-') 9 CONTINUE CALL GRUP3(LIRPA(DFLCK(MMIN),50),MMIN) GO TO 1 2 MMIN=MMIN-14 DFLCB(I)=DFLCB(I)+4.9 DO 10 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 10 I8=I7+4 II8=I8+1 WRITE(II8,11)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I),MMIN 11 FORMAT(/1X,3A4,' STARBASE',I3,' DESTROYED EAGLE',I3) 10 CONTINUE CALL BOOM(MMIN) 1 RETURN END C- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHCEK 04/25/2000 BY: D.G. C- TALOS - C SUBROUTINE TALOS COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM DO 13 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 13 I8=I7+4 II8=I8+1 WRITE(II8,14)(ISIDE(IQ0,I),IQ0=1,3),IBASE(I) 14 FORMAT(/' ION STORM DAMAGE TO ',3A4,' STARBASE',I3,' AS FOLLOWS-') 13 CONTINUE CALL RANDO(IV,1,20) IVV=ALOG((101.-DFLCB(I)/3.)*IV)/0.700619195-3. CALL GRUP2(IVV,I) RETURN END C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHCEK 04/25/2000 BY: D.G. C C EEEEE N N EFEEE M M Y Y C E NN N E MM MM Y Y C EEEE N N N EEEE M M M Y C E N NN E M M Y C EEEEE N N EEEEE M M Y C SUBROUTINE ENEMY LOGICAL BLISH COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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),LI2R(5),LI2C(5),IGO(4),MINES 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 /V/IWEB(2),IWEBZ,INVIS(4) COMMON /TOM/ITOM LOGICAL MOLOCH KOENIG=0 JTK=0 1101 DO 1100 I=1,8 ISTAT=0 IF(I.NE.8)GO TO 11010 CALL DUNE 11010 IF(ICHOS(I).EQ.0)GO TO 1100 107 GO TO (1103,1104,1105,1106,1107,1109,1108,11090),I 1103 CALL RANDO(IV,45,110) GO TO 1109 1104 CALL RANDO(IV,30,100) GO TO 1109 1105 CALL RANDO(IV,60,90) GO TO 1109 1106 CALL RANDO(IV,35,90) GO TO 1109 1107 CALL RANDO(IV,50,100) GO TO 1109 1108 CALL RANDO(IV,100,200) GO TO 1109 11090 IV=50 1109 CALL PIKE(IKLNR(I),IKLNC(I),IBPSB(I)) IF(MMIN.EQ.0)GO TO 232 IF(DIST(I).GE.DISTP)GO TO 3390 IF(MOLOCH(IWHO(I)))GO TO 3390 DISTP=DIST(I) MMIN=IWHO(I) ISTAT=6 3390 IF(I.NE.2)GO TO 378 DO 360 I7=1,4 IF(ICHOE(I7).NE.1)GO TO 380 IF(DI(IENTR(I7),IENTC(I7),IKLNR(2),IKLNC(2)).GT.5.)GO TO 380 INVIS(I7)=1 I8=I7+4 II8=I8+1 WRITE(II8,381) 381 FORMAT(' THE ROMULAN SHIP IS NOW WITHIN SENSOR RANGE') KILLR=2 380 CONTINUE IF(KILLR.NE.1)GO TO 339 IF(DISTP.GT.10.)GO TO 1100 KILLR=2 GO TO 339 378 IF(I.EQ.3)CALL THOLIA IF(I.NE.7)GO TO 379 IF(KILLD.EQ.1.AND.DISTP.GT.7.)GO TO 1100 KILLD=1 GO TO 339 379 IF(I.NE.6)GO TO 339 IF(DISTP.GT.KILLZ.AND.DFLCK(6).EQ.100.)GO TO 1100 CALL KNUTH 339 IF(MMIN.EQ.0)GO TO 1100 IF(DISTP.GT.25.)GO TO 1100 IF(I.NE.6)GO TO 33900 360 IF(BLISH(JTK))GO TO 1100 33900 CALL RANDO(IVV,1,100) IF(IVV.LE.DISTP*3.)GO TO 232 IF(MMIN.GT.4)GO TO 340 MI=MMIN DO 341 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 341 I8=I7+4 II8=I8+1 WRITE(II8,342)(IENM2(J,I),J=1,4),(INAME(IQ0,MI),IQ0=1,3) 342 FORMAT(/1X,4A4,' HAS SCORED A HIT ON THE ',3A4,'-DAMAGE REPORT-') 341 CONTINUE CALL GRUP1(LIRPA(DFLCT(MI),IV),MI) GO TO 232 340 IF(MMIN.GT.6)GO TO 343 MI=MMIN-4 DO 344 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 344 I8=I7+4 II8=I8+1 WRITE(II8,330)(IENM2(J,I),J=1,4),(ISIDE(IQ0,MI),IQ0=1,3),IBASE(MI) 330 FORMAT(/1X,4A4,' HAS HIT ',3A4,' STARBASE',I3,'-DAMAGE REPORT-') 344 CONTINUE CALL GRUP2(LIRPA(DFLCB(MI)/3.,IV),MI) GO TO 232 343 IF(MMIN.GT.14)GO TO 345 MI=MMIN-6 IF(MI.NE.7)GO TO 3460 CALL RANDO(I8,1,3) IF(I8.EQ.2)GO TO 3460 DO 3461 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 3461 I8=I7+4 II8=I8+1 WRITE(II8,3462)(IENM2(J,I),J=1,4) 3462 FORMAT(/1X,4A4,' FIRE BOUNCED OFF DOOMSDAY MACHINE') 3461 CONTINUE GO TO 232 3460 DO 346 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 346 I8=I7+4 II8=I8+1 WRITE(II8,347)(IENM2(J,I),J=1,4),(IENM2(J,MI),J=1,4) 347 FORMAT(/1X,4A4,' HAS SCORED A HIT ON ',4A4,'-DAMAGE REPORT-') 346 CONTINUE CALL GRUP3(LIRPA(DFLCK(MI),IV),MI) GO TO 232 345 MI=MMIN-14 DO 348 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 348 I8=I7+4 II8=I8+1 WRITE(II8,349)(IENM2(J,I),J=1,4),MI 349 FORMAT(/1X,4A4,' DESTROYED EAGLE',I3) 348 CONTINUE 338 CALL BOOM(MI) 232 IF(I.EQ.6)GO TO 360 1100 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/25/2000 BY: D.G. C C - MOLOCH - C LOGICAL FUNCTION MOLOCH(MMIN) 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 /T/ICHOE(4),ICHOS(8),ICHOB(2) MOLOCH=.FALSE. IF(MMIN.GT.4)GO TO 1 IF(ICHOE(MMIN).NE.0.AND.ICHOE(MMIN).NE.3)RETURN 10 MOLOCH=.TRUE. RETURN 1 IF(MMIN.GT.6)GO TO 2 IF(ICHOB(MMIN-4).NE.0)RETURN GO TO 10 2 IF(MMIN.GT.14)GO TO 3 IF(ICHOS(MMIN-6).EQ.1)RETURN GO TO 10 3 IF(IGLER(MMIN-14).NE.0)RETURN GO TO 10 END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - DUNE - C SUBROUTINE DUNE DIMENSION ISID(3,3) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25), *IBASR(2),IBABC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES 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 /U/LAUNCH,NUMOUT,NUME(2) COMMON /TOM/ITOM DATA ISID/'FEDE','RATI','ON ','KLIN','GON ',' ', *'MOON','BASE',' '/ IF(NUMOUT.EQ.0)KOENIG=3 1110 KOENIG=KOENIG+1 GO TO (315,318,316),KOENIG GO TO 1100 315 CALL RANDO(IS,1,2) 323 IV=NUME(IS) 320 IF(NUME(IS).EQ.0)GO TO 1110 322 DO 319 I7=1,LAUNCH IF(IGLER(I7).NE.0.AND.IBPSE(I7).EQ.IS)GO TO 321 319 CONTINUE 318 IS=3-IS GO TO 323 316 IS=0 IV=NUMOUT-NUME(1)-NUME(2) IF(IV.EQ.0)GO TO 1110 GO TO 322 321 CALL PIKE(IGLER(I7),IGLEC(I7),IBPSE(I7)) IF(MMIN.EQ.0)GO TO 1110 IV=FLOAT(IV)*20.*(1.0-DISTP*0.045) IF(IV.LE.0)GO TO 1110 IF(KOENIG.EQ.3)IS=3 IF(MMIN.GT.4)GO TO 324 MI=MMIN DO 325 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 325 I8=I7+4 II8=I8+1 WRITE(II8,326)(ISID(IQ0,IS),IQ0=1,3),(INAME(IQ0,MI),IQ0=1,3) 326 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',3A4,'-DAMAGE REPORT-') 325 CONTINUE CALL GRUP1(LIRPA(DFLCT(MI),IV),MI) GO TO 1110 324 IF(MMIN.GT.6)GO TO 328 MI=MMIN-4 DO 329 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 329 I8=I7+4 II8=I8+1 WRITE(II8,3300)(ISID(IQ0,IS),IQ0=1,3),(ISIDE(IQ0,MI),IQ0=1,3), *IBASE(MI) 3300 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',3A4,' STARBASE',I3,'-DAMAGE *REPORT-') 329 CONTINUE CALL GRUP2(LIRPA(DFLCB(MI)/3.,IV),MI) GO TO 1110 328 IF(MMIN.GT.14)GO TO 332 MI=MMIN-6 IF(MI.EQ.7)IV=IV/3 DO 333 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 333 I8=I7+4 II8=I8+1 WRITE(II8,334)(ISID(IQ0,IS),IQ0=1,3),(IENM2(J,MI),J=1,4) 334 FORMAT(/1X,3A4,' BOARDED EAGLES HIT ',4A4,'-DAMAGE REPORT-') 333 CONTINUE CALL GRUP3(LIRPA(DFLCK(MI),IV),MI) GO TO 1110 332 MI=MMIN-14 DO 336 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 336 I8=I7+4 II8=I8+1 WRITE(II8,337)(ISID(IQ0,IS),IQ0=1,3),MI 337 FORMAT(/1X,3A4,' BOARDED EAGLES DESTROYED EAGLE ',I2) 336 CONTINUE CALL BOOM(MI) GO TO 1110 1100 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECKED 04/25/2000 BY: D.G. C C - THOLIA - C SUBROUTINE THOLIA DIMENSION IWHE(3,2),IIDIM(2) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) DATA IWHE/'THOL','IAN ',' ','KZIN','TI ',' '/,IIDIM(1)/8/ IIDIM(2)=IWEBZ NN=I/3 IF(IWEB(NN).NE.0)GO TO 232 IF(ISTAT.EQ.6)GO TO 232 IF(DISTP.GT.IIDIM(NN))GO TO 232 IF(MMIN.GT.4)GO TO 229 IF(IWEB(3-NN).EQ.MMIN)GO TO 232 DO 228 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 228 I8=I7+4 II8=I8+1 WRITE(II8,1102)(INAME(IQ0,MMIN),IQ0=1,3),(IWHE(IQ0,NN),IQ0=1,3) 1102 FORMAT(' THE ',3A4,' IS TRAPPED IN A',3A4,'WEB') 228 CONTINUE IWEB(NN)=MMIN GO TO 232 229 IV=MMIN-6 IF(IV.LT.1)GO TO 232 IF(IV.EQ.7)GO TO 232 IF(IV.GT.8)GO TO 232 IF(IWEB(3-NN).EQ.MMIN-2)GO TO 232 DO 227 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 227 I8=I7+4 II8=I8+1 WRITE(II8,314)(IENM2(J,IV),J=1,4),(IWHE(IQ0,NN),IQ0=1,3) 314 FORMAT(' THE ',4A4,' IS TRAPPED IN A',3A4,'WEB') 227 CONTINUE IWEB(NN)=MMIN-2 232 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - KNUTH - C SUBROUTINE KNUTH COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(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),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 /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /V/IWEB(2),IWEBZ,INVIS(4) KILLZ=100 IF(IARMZ(5).EQ.0)GO TO 363 DO 382 I7=1,4 INVIZ(I7)=0 IF(ICHOE(I7).NE.1)GO TO 382 IF(DI(IENTR(I7),IENTC(I7),IKLNR(6),IKLNC(6)).GT.ICLOZ)GO TO 382 INVIZ(I7)=1 I8=I7+4 II8=I8+1 WRITE(II8,383) 383 FORMAT(' THE KZINTI SHIP IS NOW WITHIN SENSOR RANGE') 382 CONTINUE 363 IF(IARMZ(3).EQ.0.OR.IWEB(2).NE.0)GO TO 364 CALL THOLIA 364 IF(IARMZ(6).EQ.0)GO TO 1100 IF(DISTP.GT.IABSZ)GO TO 1100 IF(MMIN.GT.14)GO TO 1100 IF(MMIN.GT.4)GO TO 367 DO 365 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 365 I8=I7+4 II8=I8+1 WRITE(II8,366)(INAME(IQ0,MMIN),IQ0=1,3) 366 FORMAT(/1X,3A4,' IS WITHIN RANGE OF KZINTI STASIS FIELD') 365 CONTINUE PHASR(MMIN)=PHASR(MMIN)-ISTAZ DFLCT(MMIN)=DFLCT(MMIN)-ISTAZ/100. TWARP(MMIN)=TWARP(MMIN)-ISTAZ/1000. IF(PHASR(MMIN).LT.0)PHASR(MMIN)=0 IF(TWARP(MMIN).LT.0)TWARP(MMIN)=0 GO TO 1100 367 IF(MMIN.GT.6)GO TO 368 MI=MMIN-4 DO 369 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 369 I8=I7+4 II8=I8+1 WRITE(II8,370)(ISIDE(IQ0,MI),IQ0=1,3),IBASE(MI) 370 FORMAT(/1X,3A4,' STARBASE',I3,' IS WITHIN RANGE OF KZINTI STASIS F *IELD') 369 CONTINUE DFLCB(MI)=DFLCB(MI)-ISTAZ/100. GO TO 1100 368 MI=MMIN-6 IF(MI.EQ.7)GO TO 1100 DO 372 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 372 I8=I7+4 II8=I8+1 WRITE(II8,373)(IENM2(J,MI),J=1,4) 373 FORMAT(/1X,4A4,' IS WITHIN RANGE OF KZINTI STASIS FIELD') 372 CONTINUE DFLCK(MI)=DFLCK(MI)-ISTAZ/100. 1100 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - BLISH - C DG: NOTE - THIS MODULE IS DEDICATED IN MEMORY OF THE LATE JAMES BLISH C LOGICAL FUNCTION BLISH(JT) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN 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 /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) BLISH=.FALSE. 360 JT=JT+1 GO TO (359,356,1100),JT 359 IF(IARMZ(1).EQ.0)GO TO 360 IV=INDUZ DO 357 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 357 I8=I7+4 II8=I8+1 WRITE(II8,358) 358 FORMAT(/' KZINTI WARSHIP FIRING INDUCTION BEAM') 357 CONTINUE GO TO 33900 356 IF(IARMZ(2).EQ.0)GO TO 360 IF(.NOT.MOLOCH(MMIN))GO TO 355 CALL PIKE(IKLNR(6),IKLNC(6),IBPSB(6)) IF(MMIN.EQ.0)GO TO 360 355 IV=IXRYZ DO 361 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 361 I8=I7+4 II8=I8+1 WRITE(II8,362) 362 FORMAT(/' KZINTI WARSHIP FIRING X-RAY LASER CANNON') 361 CONTINUE GO TO 33900 1100 BLISH=.TRUE. 33900 RETURN END C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/24/2000 BY: D.G. C C - FINNEY - C SUBROUTINE FINNEY(MI) COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MMIN,ISTAT,JTK,KOENIG, *IGNORE,IO,IGOL(80),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4) COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM DATA FUDGE/0.700619195/ ION(MI)=0 DO 376 I7=1,4 IF(ICHOE(I7).EQ.0)GO TO 376 I8=I7+4 II8=I8+1 WRITE(II8,377)(INAME(IQ0,MI),IQ0=1,3) 377 FORMAT(/' ION STORM DAMAGE TO ',3A4) 376 CONTINUE CALL RANDO(IV,1,20) IVV=ALOG((101.-DFLCT(MI))*IV)/FUDGE-3. CALL GRUP1(IVV,MI) RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C C - SAURON - C SUBROUTINE SAURON 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) 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) COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25) COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2) COMMON /TOM/ITOM IDOK=0 DO 131 J=1,4 IF(ICHOE(J).EQ.0)GO TO 131 IF(IBPSC(IT).EQ.J)GO TO 131 I=J+4 II1=I+1 WRITE(II1,132)(INAME(IQ0,IT),IQ0=1,3) 132 FORMAT(' PLEASE STANDBY WHILE THE ',3A4,' TAKES ITS TURN') 131 CONTINUE DO 1 I=1,2 IF(ICHOB(I).NE.1)GO TO 1 IF(IBPSS(I).NE.IS)GO TO 1 IF(DI(IENTR(IT),IENTC(IT),IBASR(I),IBASC(I)).GE.2)GO TO 1 IDOK=1 CALL MCCOY 1 CONTINUE 2330 IF(TWARP(IT).GE.0.5)GO TO 422 IF(NOMOV(IT).EQ.1)GO TO 423 NOMOV(IT)=1 WRITE(LLL,421) 421 FORMAT(' WARP ENERGY IS UNDER 0.5 SO THE WARP ENGINES HAVE BEEN SH *UT DOWN'/' TO CONSERVE POWER') ITEMP(IT)=0 GO TO 423 422 IF(NOMOV(IT).EQ.0)GO TO 423 NOMOV(IT)=0 ITEMP(IT)=4000 WRITE(LLL,424) 424 FORMAT(' ENGINEERING HERE SIR - WE''VE ENGAGED ENGINE RESTART CYCL *E'/' AND SHOULD BE ABLE TO MOVE NOW') 423 IF(IGO(IT).EQ.0)GO TO 23302 IF(NDEAD(IT).LT.100)GO TO 23302 IF(IDOK.EQ.1)GO TO 23302 IF(MANUM(IT).EQ.0)GO TO 23303 CALL RANDO(I7,1,4*IGO(IT)) WRITE(LLL,425) 425 FORMAT(' DAMAGE CONTROL PARTIES COMMENCING REPAIRS') 429 IF(MANUM(IT).GT.8)GO TO 426 428 DO 427 I=1,33 IF(MA(IT,I).EQ.0)GO TO 427 I7=I7-1 IF(I7.LT.0)GO TO 23303 CALL RPAIR IF(MANUM(IT).EQ.0)GO TO 23303 427 CONTINUE GO TO 23303 426 CALL RANDO(I,1,33) IF(MA(IT,I).EQ.0)GO TO 426 I7=I7-1 IF(I7.LT.0)GO TO 23303 CALL RPAIR IF(MANUM(IT).LT.8)GO TO 426 GO TO 426 23303 IF(IGO(IT).EQ.1)GO TO 23302 IF(PHASR(IT)+DFLCT(IT)*100.+TWARP(IT)*1000.0.GE.26000.)GO TO 23302 IF(PHASR(IT).LT.6000.)PHASR(IT)=PHASR(IT)+500. DFLCT(IT)=DFLCT(IT)+10. TWARP(IT)=TWARP(IT)+1. IF(DFLCT(IT).GT.100.)DFLCT(IT)=100. IF(TWARP(IT).GT.10.)TWARP(IT)=10. 23302 DO 405 I=1,2 HIVEL(IT,I)=10.-MA(IT,I+30) IF(MA(IT,I+30).EQ.0.OR.MA(IT,I+26).EQ.9)GO TO 405 WRITE(LLL,406)1,HIVEL(IT,I) 406 FORMAT(' ** NOTE **- NACELLE',I2,' MAY RIP OFF IF WARP SPEED EXCEE *DS',F6.2) 405 CONTINUE K(IT,4)=MA(IT,29) K(IT,5)=MA(IT,30) K(IT,6)=MA(IT,28) IF(JS.EQ.2)GO TO 144 K(IT,1)=MA(IT,23) K(IT,2)=MA(IT,14) K(IT,14)=MA(IT,3) NOMAP(IT)=15-MA(IT,33) GO TO 145 144 K(IT,1)=MA(IT,13) K(IT,2)=MA(IT,14) K(IT,14)=MA(IT,29)+MA(IT,30) NOMAP(IT)=15-MA(IT,13) 145 IF(ICOIL(IT).EQ.0)GO TO 234 CALL RANDO(I7,1,7-IGO(IT)) IF(I7.GT.2)GO TO 234 ICOIL(IT)=0 WRITE(LLL,4020) 4020 FORMAT(' REPAIRS COMPLETE - PHASERS ARE NOW OPERATIVE') 234 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C TYPE-EXACT CHECK 04/25/2000 BY: D.G. C - MCCOY - C -- NOV./1999 -DG: I WOULD LIKE TO DEDICATE THIS COMMENT IN MEMORY OF THE C LATE DEFOREST KELLEY WHO PASSED AWAY ONLY SOME MONTHS AGO. OUR THOUGHTS C AND OUR HEARTS WILL BE WITH YOU ALWAYS. MR. KELLEY WILL BE SADLY MISSED. C I THINK MR. KELLEY PASSED AWAY AUG/1999 AT THE AGE OF 78 SUBROUTINE MCCOY 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2) 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 /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2) COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) WRITE(LLL,2)INAME(1,IT),INAME(2,IT),IBASE(I) 2 FORMAT(' THE ',2A5,' IS DOCKED AT STARBASE ',I2/' REPAIRS COMMENCI *NG-') DO 3 I7=1,33 MA(IT,I7)=MA(IT,I7)-3 IF(MA(IT,I7).GT.0)GO TO 3 IF(MA(IT,I7).EQ.-3)GO TO 4 MANUM(IT)=MANUM(IT)-1 4 MA(IT,I7)=0 3 CONTINUE IF(MA(IT,29).EQ.6)MANUM(IT)=MANUM(IT)+1 IF(MA(IT,30).EQ.6)MANUM(IT)=MANUM(IT)+1 IF(PHASR(IT)+DFLCT(IT)*100.+TWARP(IT)*1000.0.GE.26000.)GOTO 5 DFLCT(IT)=DFLCT(IT)+10. IF(PHASR(IT).LT.6000.)PHASR(IT)=PHASR(IT)+500. TWARP(IT)=TWARP(IT)+1. IF(DFLCT(IT).GT.100.)DFLCT(IT)=100. IF(TWARP(IT).GT.10.)TWARP(IT)=10. 5 IF(ICOIL(IT).EQ.0)GO TO 7 ICOIL(IT)=0 WRITE(LLL,14) 14 FORMAT(' PHASERS NOW OPERATIVE') 7 RETURN END C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -- C C -- CONVERTED TO PC BY: DAN GAHLINGER -- C C - RPAIR - C C THIS WAS HAND-TYPED 21/APR/2000 BY: D.G. SUBROUTINE RPAIR 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),LLL,II1,INA,IVI,II7,II8,NNN COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4), *NOMOV(4) IF(I.EQ.29.AND.MA(IT,29).EQ.9)RETURN IF(I.EQ.30.AND.MA(IT,30).EQ.9)RETURN CALL RANDO(I8,1,5) MA(IT,I)=MA(IT,I)-I8 IF(MA(IT,I).GT.0)RETURN MA(IT,I)=0 MANUM(IT)=MANUM(IT)-1 RETURN END