SUBROUTINE STAR79 c include 'tcommon.for' %include tcommon.for character iiiii,idup character*8 NAMEX,PASSX,IDEMO,moldnm,noldnm datA POINT/0./ data IDEMO/'master '/,NAMEX/' '/,PASSX/' '/ CALL QTIME(IZZ) J=10 J=MOD(IZZ,J) J=J*10 J=MOD(IZZ,J) DO 78888 I=1,J IIIIII=RAN(IZZ) 78888 CONTINUE C ...SET USER LIMITS 5666 WRITE(*,1) 1 format(/ ' At any point in the game where information is requ4592 1ired,'/' you may request a short explanation by typing "7777".'/' 4593 1good luck! you''ll need it.') 5655 WRITE(*,77702) 77702 FORMAT(' Enter your last name: ') read(*,676,end=9680)namex c read(*,676)namex write(*,77703) 77703 format(' enter your password: ') read(*,676,end=9680)passx iikk=1 moldnm=iyes 81818 likk=iikk read(3,rec=likk,err=5666)mname,points,mpass,x6,x7,irst if(namex.eq.mname.and.passx.eq.mpass)go to 71717 if(moldnm.eq.mname)go to 9776 moldnm=mname iikk=iikk+1 go to 81818 71717 mmkey=iikk if(irst.eq.1)call rstart(1) if(irst.eq.1)return write(*,77777) 77777 format(' Do you want to change your password (y or n)? ') read(*,6,ERR=5666,END=9680)IIIII IF(IIIII.NE.'Y')GO TO 5654 WRITE(*,77888) 77888 FORMAT(' Enter new password: ') READ(*,676,END=9680)PASSX IF(PASSX.EQ.'shazam'.AND.MNAME.EQ.'master')GO TO 77779 IF(MNAME.EQ.IDEMO)GO TO 5654 MPASS=PASSX 5654 WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst GO TO 77714 77779 WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst 65656 WRITE(*,77780) 77780 FORMAT(' Do you want to add a name to the file (Y or N)? ') READ(*,6,ERR=5666,END=9680)IIIII IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 77789 WRITE(*,77781) 77781 FORMAT(' Enter the last name: ') READ(*,676,END=9680)NAMEX 676 FORMAT(A8) WRITE(*,77783) 77783 FORMAT(' Enter the password: ') READ(*,676,END=9680)PASSX IIKK=1 MOLDNM=IYES 77784 READ(3,REC=IIKK,ERR=5666)MNAME,POINTS,MPASS,X6,X7 IF(MNAME.EQ.MOLDNM)GO TO 77785 MOLDNM=MNAME GO TO 77784 77785 WRITE(3,REC=IIKK)NAMEX,POINT,PASSX,X6,X7,irst WRITE(*,77786)NAMEX,PASSX 77786 FORMAT(' Inductee ',A8,' has been added. password = ',a8) IIKK=IIKK+1 WRITE(3,REC=IIKK)NAMEX,POINT,MPASS,X6,X7,irst GO TO 65656 77789 WRITE(*,77790) 77790 FORMAT(' Do you want to display a name on the file (Y or N)? ') READ(*,6,ERR=5666,END=9680)IIIII IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 88889 WRITE(*,77791) 77791 FORMAT(' Enter the last name: ') READ(*,676,END=9680)NAMEX IIKK=1 MOLDNM=IYES NOLDNM=NAMEX 77794 READ(3,REC=IIKK,ERR=5666)NAMEX,X,PASSX,X6,X7 IF(NAMEX.EQ.NOLDNM)GO TO 77795 IF(NAMEX.EQ.MOLDNM)GO TO 77798 MOLDNM=NAMEX GO TO 77794 77795 WRITE(3,REC=IIKK)NAMEX,X,PASSX,X6,X7,irst WRITE(*,77796)namex,passx 77796 format(1x,a8,' is on the file. password = ',a8) GO TO 77789 77798 WRITE(*,77797)NOLDNM 77797 format(1x,a8,' is not on the file.') go to 77789 88889 write(*,77740) 77740 format(' do you want to add a holiday (Y or N)? ') READ(*,6,ERR=5666,END=9680)IIIII IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 77714 WRITE(*,77741) 77741 FORMAT(' Enter the next two holidays[I]: ') READ(*,*,END=9680)NHOL1,NHOL2 READ(3,REC=1,ERR=5666)X1,X2,X3,X4,X5,X6,X7 WRITE(3,REC=1)X1,X2,X3,X4,X5,NHOL1,NHOL2 77714 READ(3,REC=MMKEY,ERR=5666)MNAME,POINTS,MPASS,X6,X7,irst WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst IOK=0 CALL QTIME(NTIME) CALL QDATE(NDATE) IYR=NDATE/1000 IDAY=NDATE-IYR*1000 ISTYR=77 IDIFF=IYR-ISTYR ISEVEN=7 ITOT=IDIFF/4 ITOT=ITOT+IDIFF+IDAY-1 ITOT=MOD(ITOT,ISEVEN) ITOT=ITOT+1 IF(ITOT.EQ.1.OR.ITOT.EQ.2)GO TO 44400 IF(ITOT.EQ.7.AND.NTIME.GE.54000)GO TO 44400 READ(3,REC=1,ERR=5666)X1,X2,X3,X4,X5,NHOL1,NHOL2 IF(NDATE.EQ.NHOL1.OR.NDATE.EQ.NHOL2)GO TO 44400 IF(NTIME.GE.28800.AND.NTIME.LT.42300)GO TO 5678 IF(NTIME.GE.46800.AND.NTIME.LT.61200)GO TO 5678 GO TO 44401 44400 IOK=1 44401 WRITE(*,677) 677 FORMAT(' Do you want this game rated (Y or N)? ') READ(*,6,END=9680)IDUP 6 FORMAT(A1) IF(IDUP.NE.NHELPS)GO TO 779 CALL HELP(59) GO TO 5654 779 IF(IDUP.NE.'Y')GO TO 5678 NRW=1 WRITE(9,rec=1)MNAME,POINTS,MPASS,MMKEY IF(POINTS.NE.0.)GO TO 778 IRANK=1 GO TO 769 C ...PRINT CURRENT STATUS OF PLAYER. 778 DO 772 I=1,NRANKS IF(RANKPT(I)-POINTS)772,771,773 771 IRANK=I GO TO 769 773 IRANK=I-1 GO TO 769 772 CONTINUE IRANK=NRANKS 769 XNEED=RANKPT(IRANK+1)-POINTS 768 WRITE(*,668)RANKS(1,IRANK),RANKS(2,IRANK),MNAME 668 FORMAT(' Welcome on board the Enterprise, ',2A8,2X,A8/ ' you 4728 1have the con!') IF(IRANK.EQ.NRANKS)GO TO 5678 WRITE(*,675)XNEED,RANKS(1,IRANK+1),RANKS(2,IRANK+1) 675 FORMAT(' You need ',f5.2,' points to reach the rank of ',2A8) 5678 IF(NRW.EQ.0)WRITE(9,rec=1)MNAME,POINTS,MPASS,NRW WRITE(*,5656) 5656 FORMAT(' Enter game level desired.[1/3] ') READ(*,*,ERR=800,END=9680)LEVEL IF(LEVEL.EQ.XHELP)GO TO 800 IF(LEVEL.LE.0.OR.LEVEL.GT.3)GO TO 800 11111 WRITE(*,5657) 5657 FORMAT(' Enter galactic dimensions.[2/10] ') READ(*,*,ERR=801,END=9680)NQUAD IF(NQUAD.EQ.XHELP)GO TO 801 IF(NQUAD.LT.2.OR.NQUAD.GT.10)GO TO 801 MMAX=NQUAD*NQUAD*2-2 NMAX=400/(NQUAD*NQUAD) IF(LEVEL-2)200,300,400 200 MAXKQ=3 MAXRQ=3 MAXBQ=1 MINK=3 MINR=3 ICLOAK=0 PHOLE=0. SNOVAP=0. GO TO 500 300 iCLOAK=0 PHOLE=0. SNOVAP=0. GO TO 500 400 ICLOAK=1 500 WRITE(*,77704) 77704 FORMAT(' Mimimum enemy vessels?[I] ') READ(*,*,ERR=50,END=9680)MTOT IF(MTOT.EQ.XHELP)GO TO 50 IF(MTOT.GT.MMAX)MTOT=MMAX NTOT=MIN0(MTOT,MMAX) NTOT=MAX0(NTOT,MINK+MINR) NTOT=NTOT+SIGN(.15*RAN(IZZ)*NTOT,.5-RAN(IZZ)) NTOT=MIN0(NTOT,MMAX) NTOT=MAX0(NTOT,MINK+MINR) IF(NTOT.LT.MTOT)NTOT=MTOT NKL=NTOT*RAN(IZZ) IF(NKL.LE.0)NKL=1 IF(NKL.GT.MAXK)NKL=MAXK IF(MROM.LE.MAXR)GO TO 82829 MROM=MAXR NKL=NTOT-MROM 82829 MROM=NTOT-NKL NDIFF=MROM-NKL IF(NDIFF.LT.0)GO TO 82828 IF(NDIFF.LE.25)GO TO 55 NDIFF=NDIFF/2 NKL=NKL+NDIFF MROM=MROM-NDIFF GO TO 82829 82828 NDIFF=NKL-MROM IF(NDIFF.LE.25)GO TO 55 NDIFF=NDIFF/2 NKL=NKL-NDIFF MROM=MROM+NDIFF GO TO 82829 55 WRITE(*,5) 5 FORMAT(' Enter game speed 1 (fast) to 50 (slow) ') READ(*,*,END=9680)ITFCTR IF(ITFCTR.LE.0)ITFCTR=1 IF(ITFCTR.GT.50)ITFCTR=50 WRITE(*,7)ITFCTR 7 FORMAT(' Timing Factor = ',I3) NS=RAN(IZZ)*99.+1. C ...DETERMINE SETUP FOR THIS GAME SDATE=RAN(IZZ)*5000.+500. XTIME=NKL*XKTIME+MROM*RTIME XTIME=XTIME+SQRT(XTIME)*RAN(IZZ) C ...REUSE XKTIME AND RTIME. XKTIME=.2 RTIME=XTIME/NTOT FDATE=SDATE+XTIME NBASES= SQRT(2.*FLOAT(NTOT))/NMAX+1. LEFTK=NKL LEFTR=MROM C ...OUTPUT STARTING CONDITIONS CALL CPAGE WRITE(*,3)SDATE,NS,NKL,MROM,NTOT,XTIME,FDATE 3 format(' Space, the Final Frontier.'/ ' This is a Voyage of t4813 1he Starship "Enterprise".'/ ' its five year mission, to explo4814 1re strange new worlds,'/ ' to seek out new life and new civil4815 1izations,'/ ' to boldly go where no man has gone before! ' 4816 1// ' S T A R T R E K'/ ' 4817 1 August 1984 Joseph V. DiMeo Consulting '/ '-----------4818 1-------------------------------------------------'/ ' Order4819 1s: Stardate ',F7.2,' Starfleet Command (TOP SECRET)'// ' co4820 1mmunications with sector ',i2,' of the galaxy were suddenly'/ 4821 1 ' cut off a few stardays ago. The last report from that area'/ 4822 1 ' was that a fleet of ',i3,' Klingons and ' ,i3,' Romulans had'4823 1/ ' invaded and destroyed every federation ship in the area.'4824 1/ ' your mission, as the pride of the federation starfleet,'/4825 1 ' is to destroy the entire enemy force (',i3,' vessels).'/ 4826 1 ' you have only ',f6.2,' stardays to accomplish your task, as 4827 1The'/ ' federation president''s reelection campaign begins on4828 1 stardate'/ f8.2,' and, as you well know, his opponent propos4829 1es appropriations'/ ' cutbacks for the space academy and elim4830 1ination of the '/ ' traditional vulcan bowl game.') C ...SET UP GALACTIC MAP(JGAL). C ...IGAL SET INITIALLY TO ALL -1S pause ' Press Return to continue ' call cpage 99 continue DO 100 J=1,NQUAD DO 100 I=1,NQUAD IGAL(I,J)=-1 JGAL(I,J)=RAN(IZZ)*MAXSQ C ...PUT IN BLACK HOLES AND WHERE THEY GO TO. IBL(I,J)=0 IF(RAN(IZZ).GT.PHOLE)GO TO 100 95 CONTINUE Q=RAN(IZZ) ICE=RAN(IZZ)*NQUAD+1. JCE=RAN(IZZ)*NQUAD+1. IF(ICE.EQ.I.AND.JCE.EQ.J)GO TO 95 IBL(I,J)=ICE*100+JCE 100 CONTINUE C ...PUT THINGS IN QUADRANTS CALL PLIN(NBASES,MAXBQ*10,10) CALL PLIN(NKL,MAXKQ*100,100) CALL PLIN(MROM,MAXRQ*1000,1000) C ...ENTERPRISE IN UNOCCUPIED QUADRANT MMAX=9999 DO 110 I=1,NQUAD DO 110 J=1,NQUAD IF(JGAL(I,J).GE.MMAX)GO TO 110 MMAX=JGAL(I,J) ICE=I JCE=J IF(MMAX.LE.99)GO TO 111 110 CONTINUE GO TO 99 111 CONTINUE JCPS=0 C ...SETUP E ENERGY=SENRGY DO 9944 I=2,20 ITRMEN(I)=0 ICNTL(I)=0 9944 CONTINUE ITRMEN(1)=IFGHTM MEN=NMEN ITORP=NTRP ISTSH=0 ISHD=0 C ...ZERO DAMAGE ARRAY DO 995 I=1,10 IF(I.EQ.10)GO TO 995 IFNDS(I)=0 995 IDMG(I)=0 IX=RAN(IZZ)*10.+1. IY=RAN(IZZ)*10.+1. XQE=IX YQE=IY DEFL=0. C ...START WITH SHORT RANGE SCAN IDOCK=0 PNRGY=0. IHWARP=0 DDEG=0. PDEG=0. DSP=0. PSP=0. ITRUCE=0 ITRSTP=0 ITFIRE=0 IHERE=0 CALL SCAN C ...START TIMER. NTSTPS=TOTAL NO OF STEPS TO DATE NTSTPS=0 DVWP0=DVWP EWRP0=EWRP DISTP0=DISTPE ETVEL0=ETVEL IETOF0=IETOFT DISTG0=DISTGT CODDS0=CODDS EODDS0=EODDS IDAMR0=IDAMRP SHLDF0=SHLDF TRNRG0=TRNRGY PJAM0=PJAM RETURN 800 CALL HELP(56) GO TO 5678 801 CALL HELP(57) GO TO 11111 50 CALL HELP(58) GO TO 500 9776 WRITE(*,9777) 9777 FORMAT(' SORRY, BUT YOU ARE NOT AUTHORIZED TO USE THIS PROGRAM.') 4919 9680 close (3) close (9) STOP END  4403 GHOST(11)=RAN(IZZ)*GHEMX