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) 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 WRITE(J,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 WRITE(IV,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 WRITE(I7,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) 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 WRITE(J,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) 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 WRITE(N,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) 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 WRITE(N,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) 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 2380 WRITE(IVV,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(IVV,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 IF(ICHOE(I7).NE.0)WRITE(IV,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) 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 WRITE(IVV,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 IF(ICHOE(I7).NE.0)WRITE(IV,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) 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(L,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(L,109) 109 FORMAT(' WHEN I STOP TYPING, HIT %C AND ENTER THE FOLLOWING COMMAN *DS-'/' ASSIGN TTYAA 5'/' ASS TTYBB 6'/' ASS TTYCC 7'/' ASS TTY *DD 8'/'. CONTINUE'/' '//' (WHERE AA, BB, CC, DD ARE THE TTY''S * CONTROLLING THE ENTERPRISE,'/' POTEMPKIN, HAVOC AND CARNAGE RESPE *CTIVELY)'/' (IF YOU''RE NOT PLAYING SOME OF THE SHIPS, DON''T BOTH *ER'/' ENTERING THEIR ASSIGN COMMANDS)'/' (IF YOU''VE HAD THE FORES *IGHT TO DO ALL THIS, JUST HIT )') READ(L,92)NA 92 FORMAT(A1) C109 FORMAT(' It is time to assign terminals to TREK7. To do C *this you need to know'/' the device name of the terminals C *that you will be using.'/' If you do not know this then C *stop the game and find out.'/' To do this type "show term", C *the first piece of information is the name of our terminal'/' C *for example "TUB1:". Find out the name of all the terminals C *'/' and then restart the game.') c***vax version c C icnt=5 C do 926 itom2=1,4 C if(igom(itom2).eq.'E')goto 921 C if(igom(itom2).eq.'P')goto 922 C if(igom(itom2).eq.'H')goto 923 C if(igom(itom2).eq.'C')goto 924 C goto 926 c c C921 write(L,9211) C9211 format(' If you want the Enterprise to play off of this C *terminal then type a blank.'/' Do not type in the name of C *this terminal, This causes the game to die.') C read(L,9212)(idev(j),j=1,2) C9212 format(2(a4)) C if(idev(1).eq.' ')goto 926 C call assign(5,idev,icnt) C goto 926 c c C922 write(L,9221) C9221 format(' The Potempkin is assigned to terminal ',$) C read(L,9222)(idev(j),j=1,2) C9222 format(2(a4)) C call assign(6,idev,icnt) C goto 926 c c C923 write(L,9231) C9231 format(' The Havoc is assigned to terminal ',$) C read(L,9232)(idev(j),j=1,2) C9232 format(2(a4)) C call assign(7,idev,icnt) C goto 926 c c C924 write(L,9241) C9241 format(' The Carnage is assigned to terminal ',$) C read(L,9242)(idev(j),j=1,2) C9242 format(2(a4)) C call assign(8,idev,icnt) c c C926 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 WRITE(I8,114)(INAME(IQ0,I7),IQ0=1,3) 114 FORMAT(' PLEASE WAIT WHILE THE ',3A4,' CHOOSES THE ENEMIES') 113 CONTINUE WRITE(L,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 IF(ICHOE(J).EQ.1)WRITE(I,6100) 6100 FORMAT(' BEGINNING SHAKEDOWN CRUISE') 122 CONTINUE 126 IF(IGO(1).EQ.1)GO TO 5020 WRITE(L,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 WRITE(J,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) 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 WRITE(I8,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 WRITE(I8,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) 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(L,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(L,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(L,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(L,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(L,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(L,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(L,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(L,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(L,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(L,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(L,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(L,401) GO TO 71 700 IXRYZ=IFIX(DISTP)/10 70 IF(IARMZ(3).EQ.0)GO TO 50 41 WRITE(L,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(L,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(L,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(L,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(L,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(L,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(L,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