home *** CD-ROM | disk | FTP | other *** search
- SUBROUTINE TSHUTL 5663
-
- c include 'tcommon.for'
- %include tcommon.for
-
- EQUIVALENCE(ISHST,ISTSH) 5701
- DATA PRSHXD,ZFIND,NTTF/.01,.4,18/ 5702
- PCT(A,B)=(A-B)/B*100. 5703
- C ...ISDH SHOWS WANTS. ISTSH SHOWS STATUS. 5704
- C ...ISHD=1-9. EXPLORE STAR SYSTEM 1-9. 5705
- C ...ISHD=99. RETURN TO E. 5706
- C ...ISHD=0. DO NOTHING. 5707
- C ...ISTSH=1-9. ON STAR SYSTEM 1-9. 5708
- C ...ISTSH=99. IN SPACE. 5709
- C ...ISTSH=0. ON E. 5710
- IF(ISHD.EQ.99)GO TO 500 5711
- C ...EXPLORE NEW STAR SYSTEM. 5712
- IF(ISHST.EQ.ISHD)GO TO 999 5713
- IF(ISTSH.NE.0)GO TO 100 5714
- WRITE(*,1) 5715
- 1 FORMAT(' SHUTTLECRAFT LAUNCHED') 5716
- SHX=XQE 5717
- SHY=YQE 5718
- C ...MOVE IT. 5719
- 100 CALL GETBRG(SHDEG,SHX,STARS(ISHD,1),SHY,STARS(ISHD,2),VPX,VPY) 5720
- IF(ISTSH.EQ.99)GO TO 110 5721
- VPX=SQRT(VPX*VPX+VPY*VPY)/SHVX/100.-.01 5722
- WRITE(*,101)VPX 5723
- 101 FORMAT(' ARRIVAL IN ',F4.2,' STARDAYS') 5724
- 110 ISTSH=99 5725
- SHX=SHX+COSD(SHDEG)*SHVX 5726
- SHY=SHY+SIND(SHDEG)*SHVX 5727
- C ...CHECK IF ENTERING STAR SYSTEM. 5728
- IF(RANGE(SHX,STARS(ISHD,1),SHY,STARS(ISHD,2)).GT.RADSS)GO TO 999 5729
- ISHST=ISHD 5730
- WRITE(*,2)ISHD 5731
- 2 FORMAT(' STAR SYSTEM ',I2,' ENTERED AND EXPLORED') 5732
- C ...FINDS. DO NOT TELL UNTIL RETURN UNLESS DESTROYED. 5733
- IF(IFNDS(ISHD).NE.0)GO TO 300 5734
- IF(RAN(IZZ).GE.PRSHXD)GO TO 200 5735
- 155 WRITE(*,3) 5736
- 3 FORMAT(' SHUTTLECRAFT LOST OR DESTROYED') 5737
- ISHD=0 5738
- ISHST=0 5739
- JMSG=0 5740
- DO 156 J=1,9 5741
- IF(IFNDS(J).EQ.-1)GO TO 156 5742
- IFNDS(J)=0 5743
- ISHSTR(J)=0 5744
- 156 CONTINUE 5745
- ISHNUM=ISHNUM-1 5746
- GO TO 999 5747
- 200 X=RAN(IZZ) 5748
- DO 210 J=1,NTTF 5749
- IF(X.LE.ZFIND+(J-1)*((1.-ZFIND)/NTTF))GO TO 220 5750
- 210 CONTINUE 5751
- 220 IFNDS(ISHD)=J 5752
- 230 ISHST=ISHD 5753
- ISHD=ISHSTR(2) 5754
- IF(ISHD.LE.0.OR.STARS(ISHD,1).EQ.0.)ISHD=99 5755
- DO 240 J=2,10 5756
- 240 ISHSTR(J-1)=ISHSTR(J) 5757
- GO TO 999 5758
- 300 WRITE(*,301) 5759
- 301 FORMAT(' WE''VE BEEN HERE BEFORE, YOU DUMMY!') 5760
- GO TO 230 5761
- C ...RETURN TO E. 5762
- 500 IF(ISHST.EQ.0)GO TO 996 5763
- IF(JMSG.NE.0)GO TO 502 5764
- JMSG=1 5765
- DO 501 J=1,NSTARS 5766
- IF(IFNDS(J).EQ.15)GO TO 503 5767
- 501 CONTINUE 5768
- GO TO 502 5769
- 503 WRITE(*,504) 5770
- 504 FORMAT(' SHUTTLECRAFT TAKEN OVER BY DANGEROUS ALIENS. TYPE "1" TO 5771
- 1DESTROY IT.') 5772
- READ(*,506,ERR=503,END=4321)K 5773
- 506 FORMAT(I1) 5774
- IF(K.EQ.1)GO TO 155 5775
- 502 DO 50201 I=1,10 5776
- 50201 ISHSTR(I)=0 5777
- CALL GETBRG(SHDEG,SHX,XQE,SHY,YQE,VPX,VPY) 5778
- SHX=SHX+COSD(SHDEG)*SHVX 5779
- C ...CHECK FOR RETURN. PRINT FINDINGS. 5780
- IF(ISHST.EQ.99)GO TO 505 5781
- VPX=SQRT(VPX*VPX+VPY*VPY)/SHVX/100. 5782
- WRITE(*,101)VPX 5783
- ISTSH=99 5784
- 505 SHY=SHY+SIND(SHDEG)*SHVX 5785
- IF(RANGE(SHX,XQE,SHY,YQE).GE.RADES)GO TO 999 5786
- WRITE(*,4) 5787
- 4 FORMAT(' SHUTTLECRAFT RETURNED') 5788
- JJ=0 5789
- DO 550 J=1,NSTARS 5790
- IF(IFNDS(J).LE.1)GO TO 550 5791
- K=IFNDS(J)-1 5792
- IFNDS(J)=-1 5793
- GO TO (601,602,603,604,605,606,607,608,609,610,611,6115,612,613,615794
- 14,615,616),K 5795
- C ...DISEASE. 5796
- 601 IF(IDSES.EQ.1)GO TO 550 5797
- WRITE(*,701) 5798
- 701 FORMAT(' VIRULENT DISEASE RAMPAGING ON ENTERPRISE!') 5799
- IDSES=1 5800
- VDSES=RAN(IZZ)*VDSESM 5801
- VSTRDS=RAN(IZZ)*.15+VSTRM 5802
- GO TO 555 5803
- C ...WARP DRIVE ACCELERATION INCREASE. 5804
- 602 IF(DVWP.GE.1.)GO TO 6025 5805
- XINC=DVWP+2.*DVWP*DVWP*RAN(IZZ) 5806
- GO TO 6016 5807
- 6025 XINC=DVWP+.3*DVWP*RAN(IZZ) 5808
- 6016 IXRAT=PCT(XINC,DVWP) 5809
- IF(IXRAT.EQ.0)GO TO 550 5810
- WRITE(*,702)NAMD(1),IXRAT 5811
- 702 FORMAT(' ',A10,' ACCELERATION INCREASED ',I3,'%') 5812
- C ...REVISE ENERGY USAGE TO COMPENSATE FOR INCREASED ACCELERATION. 5813
- VPY=IXRAT/100. 5814
- VPX=EWRP 5815
- EWRP=DVWP*DVWP*EWRP/(XINC*XINC) 5816
- DVWP=XINC 5817
- IXRAT=-PCT(VPX,EWRP0) 5818
- EWRP0=EWRP/(1.-FLOAT(IXRAT)/100.) 5819
- C ...ALSO INCREMENT DEG CHANGE/SM, ALTHOUGH NOT BY SO MUCH. 5820
- DGWP=DGWP+RAN(IZZ)*DGWP/3. 5821
- IF(DGWP.GT.90.)DGWP=90. 5822
- GO TO 555 5823
- C ...WAPR DRIVE EFFICIENCY. 5824
- 603 XINC=EWRP-1.7*SQRT(EWRP)*RAN(IZZ) 5825
- IXRAT=-PCT(XINC,EWRP) 5826
- IF(IXRAT.EQ.0)GO TO 550 5827
- WRITE(*,703)NAMD(1),IXRAT 5828
- 703 FORMAT(1X,A10,' EFFICIENCY INCREASED BY ',I3,'%') 5829
- EWRP=XINC 5830
- EVENU=EVENU-IXRAT/100.*EVENU 5831
- GO TO 555 5832
- C ...PHASER IMPROVEMENT. 5833
- 604 XINC=DISTPE+.5*SQRT(DISTPE)*RAN(IZZ) 5834
- IXRAT=PCT(XINC,DISTPE) 5835
- IF(IXRAT.EQ.0)GO TO 550 5836
- WRITE(*,704)NAMD(3),IXRAT 5837
- 704 FORMAT(1X,A10,' EFFECTIVENESS INCREASED BY ',I3,'%') 5838
- DISTPE=XINC 5839
- GO TO 555 5840
- C ...TORP V INCREASE. 5841
- 605 ETVEL=ETVEL+(.9-ETVEL)/5. 5842
- WRITE(*,705)NAMD(4),ETVEL 5843
- 705 FORMAT(1X,A10,' VELOCITY INCREASED TO ',F5.3) 5844
- GO TO 555 5845
- C ...TORP RATE OF FIRE. 5846
- 606 IETOFT=IETOFT+1 5847
- WRITE(*,706)NAMD(4),IETOFT 5848
- 706 FORMAT(1X,A10,' RATE NOW ',I2,' PER STAR-MINUTE') 5849
- GO TO 555 5850
- 607 XINC=DISTGT+.5*SQRT(DISTGT)*RAN(IZZ) 5851
- IXRAT=PCT(XINC,DISTGT) 5852
- IF(IXRAT.EQ.0)GO TO 550 5853
- WRITE(*,704)NAMD(5),IXRAT 5854
- DISTGT=XINC 5855
- DISTKR=DISTKR+IXRAT/100.*DISTKR 5856
- GO TO 555 5857
- 608 XINC=CODDS+CODDS*CODDS*5.*RAN(IZZ) 5858
- IXRAT=PCT(XINC,CODDS) 5859
- IF(IXRAT.EQ.0)GO TO 550 5860
- WRITE(*,708)IXRAT 5861
- 708 FORMAT(' TROOP FIGHTING EFFECTIVENESS VS KLINGONS INCREASED BY ',I5862
- 13,'%') 5863
- CODDS=XINC 5864
- GO TO 555 5865
- 609 XINC=EODDS+EODDS*EODDS*2.5*RAN(IZZ) 5866
- IXRAT=PCT(XINC,EODDS) 5867
- IF(IXRAT.EQ.0)GO TO 550 5868
- WRITE(*,709)IXRAT 5869
- 709 FORMAT(' TROOP FIGHTING EFFECTIVENESS VS ROMULANS INCREASED BY ',I5870
- 13,'%') 5871
- EODDS=XINC 5872
- GO TO 555 5873
- C ...TRANSPORTERS. 5874
- 610 JDAMRP =FLOAT(IDAMRP)+2.*SQRT(FLOAT(IDAMRP))*RAN(IZZ) 5875
- IF(JDAMRP.EQ.IDAMRP)GO TO 550 5876
- IDAMRP=JDAMRP 5877
- WRITE(*,706) NAMD(8),IDAMRP 5878
- GO TO 555 5879
- C ...COMMUNICATIONS. 5880
- 611 XINC=PJAM-2.*PJAM*(PJAM)*RAN(IZZ) 5881
- IXRAT=PCT(-XINC,-PJAM) 5882
- IXRAT=-IXRAT 5883
- IF(IXRAT.EQ.0)GO TO 550 5884
- WRITE(*,710)NAMD(9),IXRAT 5885
- 710 FORMAT(1X,A10,' INTERCEPTION PROBABILITY REDUCED BY ',I3,'%') 5886
- PJAM=XINC 5887
- GO TO 555 5888
- C ...SHIELDS IMPROVEMENT. 5889
- 6115 XINC=SHLDF+RAN(IZZ)*.2*SHLDF 5890
- IXRAT=PCT(XINC,SHLDF) 5891
- IF(IXRAT.EQ.0)GO TO 550 5892
- WRITE(*,6112)IXRAT 5893
- 6112 FORMAT(' SHIELDS IMPROVED BY ',I3 ,'%') 5894
- SHLDF=XINC 5895
- GO TO 555 5896
- C ...ALIEN FORCE-HOSTILE 5897
- 612 IF (IALSS.NE.0)GO TO 550 5898
- IXRAT=RAN(IZZ)*40.+10. 5899
- XINC=ENERGY/IXRAT/100. 5900
- WRITE(*,712)J,IXRAT,XINC 5901
- 712 FORMAT(' ALIEN BEINGS FROM STAR SYSTEM ',I1,' DRAINING'/ ' EN5902
- 1TERPRISE ENERGY BANKS AT THE RATE OF ',I3,' UNITS/STARMINUTE'/ 5903
- 1 ' ZERO ENERGY LEVEL IN ',F6.2,' STARDAYS!!') 5904
- ALEDR=IXRAT 5905
- IALIC=ICE 5906
- IALJC=JCE 5907
- IALSS=J 5908
- GO TO 555 5909
- C ...ENERGY FORMS 5910
- 613 IF(NDRA.EQ.1)GO TO 550 5911
- IF(IDMG(1).NE.0)GO TO 550 5912
- WRITE(*,713) 5913
- 713 FORMAT(' SEMI-SENTIENT ENERGY FORMS INVADING ENTERPRISE COMPUTER B5914
- 1ANKS!'/ ' ENTERPRISE WARP DRIVE ENGINES UNDER ALIEN CONTROL!!5915
- 1') 5916
- NDRA=1 5917
- DSP=RAN(IZZ)+1. 5918
- JMSG=0 5919
- DDEG=RAN(IZZ)*360. 5920
- GO TO 555 5921
- C ...TROOP REINFORCEMENTS. 5922
- 614 IXRAT=RAN(IZZ)*NTROPS+1. 5923
- WRITE(*,714)IXRAT,J 5924
- 714 FORMAT(1X,I4,' ANDROID TROOP REINFORCEMENTS FROM FRIENDLY CIVILIZA5925
- 1TION'/ ' ON STAR SYSTEM ',I1) 5926
- ITRMEN(1)=ITRMEN(1)+IXRAT 5927
- GO TO 555 5928
- C ...IMPROVED TRANSPORTER ENERGY USAGE. 5929
- 615 XINC=TRNRGY-RAN(IZZ)*TRNRGY*TRNRGY*.5 5930
- IXRAT=-PCT(XINC,TRNRGY) 5931
- IF(IXRAT.LE.0)GO TO 500 5932
- WRITE(*,703)NAMD(8),IXRAT 5933
- TRNRGY=XINC 5934
- GO TO 555 5935
- C ...MICROTRIBBLES. 5936
- 616 SDAYS=RAN(IZZ)+1. 5937
- WRITE(*,716) 5938
- 716 FORMAT(' MICRO-TRIBBLES MULTIPLYING OUT OF CONTROL IN COMPUTER BAN5939
- 1KS!!') 5940
- IDMG(10)=IDMG(10)+SDAYS*100. 5941
- GO TO 555 5942
- 555 JJ=1 5943
- 550 CONTINUE 5944
- IF(JJ.EQ.1)GO TO 800 5945
- WRITE(*,575) 5946
- 575 FORMAT(' NOTHING OF VALUE FOUND THIS EXPLORATION') 5947
- 800 ISTSH=0 5948
- ISHD=0 5949
- 999 RETURN 5950
- 4321 STOP 5951
- C ...RETURN NOT POSSIBLE. 5952
- 996 WRITE(*,995) 5953
- 995 FORMAT(' RETURN NOT POSSIBLE') 5954
- GO TO 999 5955
- END 5956
