home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / STAR79.FOR < prev    next >
Encoding:
Text File  |  1986-12-15  |  10.9 KB  |  360 lines
  1.       SUBROUTINE STAR79
  2.  
  3. c    include 'tcommon.for'
  4.     %include tcommon.for
  5.  
  6.     character iiiii,idup
  7.       character*8 NAMEX,PASSX,IDEMO,moldnm,noldnm
  8.       datA POINT/0./
  9.     data IDEMO/'master  '/,NAMEX/'        '/,PASSX/'        '/
  10.     CALL QTIME(IZZ)
  11.       J=10
  12.       J=MOD(IZZ,J)
  13.       J=J*10
  14.       J=MOD(IZZ,J)
  15.       DO 78888 I=1,J
  16.       IIIIII=RAN(IZZ)
  17. 78888 CONTINUE
  18. C     ...SET USER LIMITS 
  19. 5666  WRITE(*,1)
  20. 1     format(/      ' At any point in the game where information is requ4592
  21.      1ired,'/' you may request a short explanation by typing "7777".'/' 4593
  22.      1good luck! you''ll need it.')
  23. 5655  WRITE(*,77702)
  24. 77702 FORMAT(' Enter your last name: ')
  25.     read(*,676,end=9680)namex
  26. c      read(*,676)namex
  27.       write(*,77703)
  28. 77703 format(' enter your password: ')
  29.       read(*,676,end=9680)passx
  30.       iikk=1
  31.       moldnm=iyes
  32. 81818 likk=iikk 
  33.       read(3,rec=likk,err=5666)mname,points,mpass,x6,x7,irst
  34.       if(namex.eq.mname.and.passx.eq.mpass)go to 71717
  35.       if(moldnm.eq.mname)go to 9776
  36.       moldnm=mname
  37.     iikk=iikk+1
  38.       go to 81818
  39. 71717 mmkey=iikk
  40.       if(irst.eq.1)call rstart(1)
  41.       if(irst.eq.1)return
  42.  
  43.       write(*,77777)
  44. 77777 format(' Do you want to change your password (y or n)? ')
  45.       read(*,6,ERR=5666,END=9680)IIIII
  46.       IF(IIIII.NE.'Y')GO TO 5654
  47.       WRITE(*,77888)
  48. 77888 FORMAT(' Enter new password: ')
  49.       READ(*,676,END=9680)PASSX
  50.       IF(PASSX.EQ.'shazam'.AND.MNAME.EQ.'master')GO TO 77779
  51.       IF(MNAME.EQ.IDEMO)GO TO 5654
  52.       MPASS=PASSX
  53. 5654  WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst
  54.       GO TO 77714
  55. 77779 WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst
  56. 65656 WRITE(*,77780)
  57. 77780 FORMAT(' Do you want to add a name to the file (Y or N)? ')
  58.       READ(*,6,ERR=5666,END=9680)IIIII
  59.       IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 77789
  60.       WRITE(*,77781)
  61. 77781 FORMAT(' Enter the last name: ')
  62.       READ(*,676,END=9680)NAMEX
  63. 676   FORMAT(A8)
  64.       WRITE(*,77783)
  65. 77783 FORMAT(' Enter the password: ')
  66.       READ(*,676,END=9680)PASSX
  67.       IIKK=1
  68.       MOLDNM=IYES
  69. 77784 READ(3,REC=IIKK,ERR=5666)MNAME,POINTS,MPASS,X6,X7
  70.       IF(MNAME.EQ.MOLDNM)GO TO 77785
  71.       MOLDNM=MNAME
  72.       GO TO 77784
  73. 77785 WRITE(3,REC=IIKK)NAMEX,POINT,PASSX,X6,X7,irst
  74.       WRITE(*,77786)NAMEX,PASSX
  75. 77786 FORMAT(' Inductee ',A8,' has been added.  password = ',a8)
  76.       IIKK=IIKK+1
  77.       WRITE(3,REC=IIKK)NAMEX,POINT,MPASS,X6,X7,irst
  78.       GO TO 65656
  79. 77789 WRITE(*,77790)
  80. 77790 FORMAT(' Do you want to display a name on the file (Y or N)? ')
  81.       READ(*,6,ERR=5666,END=9680)IIIII
  82.       IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 88889
  83.       WRITE(*,77791)
  84. 77791 FORMAT(' Enter the last name: ')
  85.       READ(*,676,END=9680)NAMEX
  86.       IIKK=1
  87.       MOLDNM=IYES
  88.       NOLDNM=NAMEX
  89. 77794 READ(3,REC=IIKK,ERR=5666)NAMEX,X,PASSX,X6,X7
  90.       IF(NAMEX.EQ.NOLDNM)GO TO 77795
  91.       IF(NAMEX.EQ.MOLDNM)GO TO 77798
  92.       MOLDNM=NAMEX
  93.       GO TO 77794
  94. 77795 WRITE(3,REC=IIKK)NAMEX,X,PASSX,X6,X7,irst
  95.       WRITE(*,77796)namex,passx
  96. 77796 format(1x,a8,' is on the file.  password = ',a8)
  97.       GO TO 77789
  98. 77798 WRITE(*,77797)NOLDNM
  99. 77797 format(1x,a8,' is not on the file.')
  100.       go to 77789
  101. 88889 write(*,77740)
  102. 77740 format(' do you want to add a holiday (Y or N)? ')
  103.       READ(*,6,ERR=5666,END=9680)IIIII
  104.       IF(IIIII.NE.'Y'.or.iiiii.ne.'y')GO TO 77714 
  105.       WRITE(*,77741)
  106. 77741 FORMAT(' Enter the next two holidays[I]: ')
  107.       READ(*,*,END=9680)NHOL1,NHOL2
  108.       READ(3,REC=1,ERR=5666)X1,X2,X3,X4,X5,X6,X7
  109.       WRITE(3,REC=1)X1,X2,X3,X4,X5,NHOL1,NHOL2
  110.  
  111. 77714 READ(3,REC=MMKEY,ERR=5666)MNAME,POINTS,MPASS,X6,X7,irst
  112.       WRITE(3,REC=MMKEY)MNAME,POINTS,MPASS,X6,X7,irst
  113.       IOK=0
  114.       CALL QTIME(NTIME)
  115.       CALL QDATE(NDATE)
  116.       IYR=NDATE/1000
  117.       IDAY=NDATE-IYR*1000
  118.       ISTYR=77
  119.       IDIFF=IYR-ISTYR
  120.       ISEVEN=7
  121.       ITOT=IDIFF/4 
  122.       ITOT=ITOT+IDIFF+IDAY-1
  123.       ITOT=MOD(ITOT,ISEVEN)
  124.       ITOT=ITOT+1
  125.       IF(ITOT.EQ.1.OR.ITOT.EQ.2)GO TO 44400
  126.       IF(ITOT.EQ.7.AND.NTIME.GE.54000)GO TO 44400
  127.       READ(3,REC=1,ERR=5666)X1,X2,X3,X4,X5,NHOL1,NHOL2
  128.       IF(NDATE.EQ.NHOL1.OR.NDATE.EQ.NHOL2)GO TO 44400
  129.       IF(NTIME.GE.28800.AND.NTIME.LT.42300)GO TO 5678
  130.       IF(NTIME.GE.46800.AND.NTIME.LT.61200)GO TO 5678
  131.       GO TO 44401
  132. 44400 IOK=1
  133. 44401 WRITE(*,677)
  134. 677   FORMAT(' Do you want this game rated (Y or N)? ')
  135.       READ(*,6,END=9680)IDUP
  136. 6     FORMAT(A1)
  137.       IF(IDUP.NE.NHELPS)GO TO 779
  138.       CALL HELP(59)
  139.       GO TO 5654
  140. 779   IF(IDUP.NE.'Y')GO TO 5678
  141.       NRW=1
  142.       WRITE(9,rec=1)MNAME,POINTS,MPASS,MMKEY
  143.       IF(POINTS.NE.0.)GO TO 778
  144.       IRANK=1
  145.       GO TO 769
  146. C     ...PRINT CURRENT STATUS OF PLAYER.
  147. 778   DO 772 I=1,NRANKS
  148.       IF(RANKPT(I)-POINTS)772,771,773
  149. 771   IRANK=I
  150.       GO TO 769
  151. 773   IRANK=I-1
  152.       GO TO 769
  153. 772   CONTINUE
  154.       IRANK=NRANKS
  155. 769   XNEED=RANKPT(IRANK+1)-POINTS
  156. 768   WRITE(*,668)RANKS(1,IRANK),RANKS(2,IRANK),MNAME 
  157. 668   FORMAT(' Welcome on board the Enterprise, ',2A8,2X,A8/      ' you 4728
  158.      1have the con!')
  159.       IF(IRANK.EQ.NRANKS)GO TO 5678
  160.       WRITE(*,675)XNEED,RANKS(1,IRANK+1),RANKS(2,IRANK+1)
  161. 675   FORMAT(' You need ',f5.2,' points to reach the rank of ',2A8)
  162. 5678  IF(NRW.EQ.0)WRITE(9,rec=1)MNAME,POINTS,MPASS,NRW
  163.       WRITE(*,5656)
  164. 5656  FORMAT(' Enter game level desired.[1/3] ')
  165.       READ(*,*,ERR=800,END=9680)LEVEL
  166.       IF(LEVEL.EQ.XHELP)GO TO 800
  167.       IF(LEVEL.LE.0.OR.LEVEL.GT.3)GO TO 800 
  168. 11111 WRITE(*,5657)
  169. 5657  FORMAT(' Enter galactic dimensions.[2/10] ')
  170.       READ(*,*,ERR=801,END=9680)NQUAD
  171.       IF(NQUAD.EQ.XHELP)GO TO 801
  172.       IF(NQUAD.LT.2.OR.NQUAD.GT.10)GO TO 801
  173.       MMAX=NQUAD*NQUAD*2-2
  174.       NMAX=400/(NQUAD*NQUAD)
  175.       IF(LEVEL-2)200,300,400
  176. 200   MAXKQ=3
  177.       MAXRQ=3
  178.     MAXBQ=1
  179.       MINK=3
  180.       MINR=3
  181.       ICLOAK=0
  182.       PHOLE=0.
  183.       SNOVAP=0.
  184.       GO TO 500
  185. 300    iCLOAK=0
  186.       PHOLE=0.
  187.       SNOVAP=0.
  188.       GO TO 500
  189. 400     ICLOAK=1 
  190.  
  191. 500   WRITE(*,77704)
  192. 77704 FORMAT(' Mimimum enemy vessels?[I] ')
  193.       READ(*,*,ERR=50,END=9680)MTOT
  194.       IF(MTOT.EQ.XHELP)GO TO 50
  195.       IF(MTOT.GT.MMAX)MTOT=MMAX
  196.       NTOT=MIN0(MTOT,MMAX)
  197.       NTOT=MAX0(NTOT,MINK+MINR)
  198.       NTOT=NTOT+SIGN(.15*RAN(IZZ)*NTOT,.5-RAN(IZZ))
  199.       NTOT=MIN0(NTOT,MMAX)
  200.       NTOT=MAX0(NTOT,MINK+MINR)
  201.       IF(NTOT.LT.MTOT)NTOT=MTOT
  202.       NKL=NTOT*RAN(IZZ)
  203.       IF(NKL.LE.0)NKL=1
  204.       IF(NKL.GT.MAXK)NKL=MAXK
  205.       IF(MROM.LE.MAXR)GO TO 82829
  206.       MROM=MAXR
  207.       NKL=NTOT-MROM
  208. 82829 MROM=NTOT-NKL
  209.       NDIFF=MROM-NKL
  210.       IF(NDIFF.LT.0)GO TO 82828
  211.       IF(NDIFF.LE.25)GO TO 55
  212.       NDIFF=NDIFF/2
  213.       NKL=NKL+NDIFF
  214.       MROM=MROM-NDIFF
  215.       GO TO 82829
  216. 82828 NDIFF=NKL-MROM
  217.       IF(NDIFF.LE.25)GO TO 55
  218.       NDIFF=NDIFF/2
  219.       NKL=NKL-NDIFF
  220.       MROM=MROM+NDIFF
  221.       GO TO 82829
  222. 55    WRITE(*,5)
  223. 5     FORMAT(' Enter game speed 1 (fast) to 50 (slow) ') 
  224.       READ(*,*,END=9680)ITFCTR
  225.       IF(ITFCTR.LE.0)ITFCTR=1
  226.       IF(ITFCTR.GT.50)ITFCTR=50
  227.       WRITE(*,7)ITFCTR
  228. 7     FORMAT(' Timing Factor = ',I3)
  229.       NS=RAN(IZZ)*99.+1.
  230. C     ...DETERMINE SETUP FOR THIS GAME
  231.       SDATE=RAN(IZZ)*5000.+500.
  232.       XTIME=NKL*XKTIME+MROM*RTIME
  233.       XTIME=XTIME+SQRT(XTIME)*RAN(IZZ)
  234. C     ...REUSE XKTIME AND RTIME.
  235.       XKTIME=.2
  236.       RTIME=XTIME/NTOT
  237.       FDATE=SDATE+XTIME
  238.       NBASES= SQRT(2.*FLOAT(NTOT))/NMAX+1.
  239.       LEFTK=NKL
  240.       LEFTR=MROM
  241. C     ...OUTPUT STARTING CONDITIONS
  242.       CALL CPAGE
  243.       WRITE(*,3)SDATE,NS,NKL,MROM,NTOT,XTIME,FDATE
  244. 3     format(' Space, the Final Frontier.'/      ' This is a Voyage of t4813
  245.      1he Starship "Enterprise".'/      ' its five year mission, to explo4814
  246.      1re strange new worlds,'/      ' to seek out new life and new civil4815
  247.      1izations,'/      ' to boldly go where no man has gone before! '   4816
  248.      1//      '                    S T A R   T R E K'/       '          4817
  249.      1  August 1984 Joseph V. DiMeo Consulting     '/       '-----------4818
  250.      1-------------------------------------------------'/        ' Order4819
  251.      1s: Stardate ',F7.2,'   Starfleet Command (TOP SECRET)'//      ' co4820
  252.      1mmunications with sector ',i2,' of the galaxy were suddenly'/     4821
  253.      1 ' cut off a few stardays ago. The last report from that area'/   4822
  254.      1   ' was that a fleet of ',i3,' Klingons and ' ,i3,' Romulans had'4823
  255.      1/      ' invaded and destroyed every federation ship in the area.'4824
  256.      1/      ' your mission, as the pride of the federation starfleet,'/4825
  257.      1      ' is to destroy the entire enemy force (',i3,' vessels).'/  4826
  258.      1    ' you have only ',f6.2,' stardays to accomplish your task, as 4827
  259.      1The'/      ' federation president''s reelection campaign begins on4828
  260.      1 stardate'/      f8.2,' and, as you well know, his opponent propos4829
  261.      1es appropriations'/      ' cutbacks for the space academy and elim4830
  262.      1ination of the '/      ' traditional vulcan bowl game.')
  263. C     ...SET UP GALACTIC MAP(JGAL).
  264. C     ...IGAL SET INITIALLY TO ALL -1S 
  265.     pause ' Press  Return to continue '
  266.     call cpage
  267. 99    continue
  268.     DO 100    J=1,NQUAD
  269.       DO 100    I=1,NQUAD
  270.       IGAL(I,J)=-1
  271.       JGAL(I,J)=RAN(IZZ)*MAXSQ
  272. C     ...PUT IN BLACK HOLES AND WHERE THEY GO TO.
  273.       IBL(I,J)=0
  274.       IF(RAN(IZZ).GT.PHOLE)GO TO 100
  275. 95    CONTINUE
  276.     Q=RAN(IZZ)
  277.     ICE=RAN(IZZ)*NQUAD+1.
  278.       JCE=RAN(IZZ)*NQUAD+1.
  279.       IF(ICE.EQ.I.AND.JCE.EQ.J)GO TO 95
  280.       IBL(I,J)=ICE*100+JCE
  281. 100   CONTINUE
  282. C     ...PUT THINGS IN QUADRANTS
  283.       CALL PLIN(NBASES,MAXBQ*10,10)
  284.       CALL PLIN(NKL,MAXKQ*100,100)
  285.       CALL PLIN(MROM,MAXRQ*1000,1000)
  286. C     ...ENTERPRISE IN UNOCCUPIED QUADRANT
  287.       MMAX=9999
  288.       DO 110 I=1,NQUAD
  289.       DO 110 J=1,NQUAD
  290.       IF(JGAL(I,J).GE.MMAX)GO TO 110
  291.       MMAX=JGAL(I,J)
  292.       ICE=I
  293.       JCE=J
  294.       IF(MMAX.LE.99)GO TO 111
  295. 110   CONTINUE
  296.       GO TO 99
  297. 111   CONTINUE
  298.       JCPS=0
  299. C     ...SETUP E
  300.       ENERGY=SENRGY
  301.       DO 9944 I=2,20
  302.       ITRMEN(I)=0
  303.       ICNTL(I)=0
  304. 9944  CONTINUE
  305.       ITRMEN(1)=IFGHTM
  306.       MEN=NMEN
  307.       ITORP=NTRP
  308.       ISTSH=0
  309.       ISHD=0
  310. C     ...ZERO DAMAGE ARRAY
  311.       DO 995    I=1,10
  312.       IF(I.EQ.10)GO TO 995
  313.       IFNDS(I)=0
  314. 995   IDMG(I)=0
  315.       IX=RAN(IZZ)*10.+1.
  316.       IY=RAN(IZZ)*10.+1.
  317.       XQE=IX
  318.       YQE=IY
  319.       DEFL=0.
  320. C     ...START WITH SHORT RANGE SCAN
  321.       IDOCK=0
  322.       PNRGY=0.
  323.       IHWARP=0
  324.       DDEG=0.
  325.       PDEG=0.
  326.       DSP=0.
  327.       PSP=0.
  328.       ITRUCE=0
  329.       ITRSTP=0
  330.       ITFIRE=0
  331.       IHERE=0
  332.       CALL SCAN 
  333. C     ...START TIMER. NTSTPS=TOTAL NO OF STEPS TO DATE
  334.       NTSTPS=0
  335.       DVWP0=DVWP
  336.       EWRP0=EWRP
  337.       DISTP0=DISTPE
  338.       ETVEL0=ETVEL
  339.       IETOF0=IETOFT
  340.       DISTG0=DISTGT
  341.       CODDS0=CODDS
  342.       EODDS0=EODDS
  343.       IDAMR0=IDAMRP
  344.       SHLDF0=SHLDF
  345.       TRNRG0=TRNRGY
  346.       PJAM0=PJAM
  347.       RETURN
  348. 800   CALL HELP(56)
  349.       GO TO 5678
  350. 801   CALL HELP(57)
  351.       GO TO 11111
  352. 50    CALL HELP(58)
  353.       GO TO 500
  354. 9776  WRITE(*,9777)
  355. 9777  FORMAT(' SORRY, BUT YOU ARE NOT AUTHORIZED TO USE THIS PROGRAM.') 4919
  356. 9680    close (3)
  357.     close (9)
  358.     STOP
  359.       END
  360.