Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / TRY1.FOR < prev next >

Wrap

Text File | 1986-12-15 | 41.9 KB | 565 lines

subroutine try1 5077 c Include 'Tcommon.For' %Include Tcommon.For Character*8 Nhelpl,Nblank,Npass Character*4 Cbtype,Idam,Ievas,Ilet,Ihelps,Cdir Data nhelpl/'7777 '/ 120 call qtime(istart) 5115 if(iok.eq.1)go to 66666 5116 if(nrw.eq.1.and.ntime.lt.29700.and.istart.ge.28800.and.nsw.eq.0) 5117 1 go to 55500 5118 if(nrw.eq.1.and.ntime.ge.42300.and.istart.ge.46800. 5119 1 and.istart.lt.61200.and.nsw.eq.0)go to 55500 5120 if(nrw.eq.1.and.istart.ge.29700.and.istart.lt.42300) 5121 1 call rating(3) 5122 if(nrw.eq.1.and.istart.ge.47700.and.istart.lt.61200) 5123 1 call rating(3) 5124 go to 66666 5125 55500 write(*,55501) 5126 55501 format(' you have 15 minutes to finish the game or save it!') 5127 nsw=1 5128 c ...ask for command 5129 66666 write(*,99) 5130 99 format(' command? ') 5131 READ(*,*,ERR=899,END=4321)ICM c if this guy knows about gamesave , do it if(icm.eq.69) call rstart(2) IF(ICM.EQ.XHELP)GO TO 899 5133 IF(ICM.EQ.0.OR.ICM.LT.-1.OR.ICM.GT.22)GO TO 66666 5134 IF(ICM.NE.-1)GO TO 140 5135 C ...PRINT COMMANDS 5136 CALL CPAGE 5137 WRITE(*,801) 5138 801 format(' 1 - set course/speed 2 - short scan'/ 5139 1' 3 - long scan 4 - phasers'/ 5140 1' 5 - torpedos 6 - pulsive beams'/ 5141 1' 7 - travel/wait 8 - status report'/ 5142 1' 9 - damage control 10 - evasive maneuvers'/ 5143 1' 11 - emergency evasive maneuvers 12 - raise deflectors'/ 5144 1' 13 - drop deflectors 14 - propose truce'/ 5145 1' 15 - short range track 16 - galactic update'/ 5146 1' 17 - plot bearing 18 - self destruct'/ 5147 1' 19 - transporters 20 - communications'/ 5148 1' 21 - shuttlecraft 22 - ship''s computer'/ 5149 1' 23 - autopilot 24 - orbit black holes'/) 5150 C ...NO ADD'L INFO REQUIRED 5151 GO TO 120 5152 140 IF(ICM.EQ.2.OR.ICM.EQ.3.OR.ICM.EQ.9.OR.ICM.EQ.16)CALL CPAGE 5153 IF(ICM.EQ.17.OR.ICM.EQ.18)CALL CPAGE 5154 GO TO (121,150,150,124,125,126,127,150,129,130,131,132,150,150, 5155 1150, 150,150,138,139,141,142,143),ICM 5156 C ...1 COMMAND. REQUEST COURSE AND SPEED. MAKE NECESARY CORRECTIONS.5157 121 WRITE(*,97)PDEG 5158 97 FORMAT(' NEW BEARING(',F4.0,') ') 5159 READ(*,*,ERR=898,END=4321)X IF(X.EQ.XHELP)GO TO 898 5161 1210 IF(X.LT.360.)GO TO 1211 5162 NNN=360 5163 NN=X 5164 XX=X-NN 5165 X=MOD(NN,NNN) 5166 X=X+XX 5167 GO TO 1212 5168 1211 IF(X.GE.0.)GO TO 1212 5169 X=-X 5170 NNN=360 5171 NN=X 5172 XX=X-NN 5173 X=MOD(NN,NNN) 5174 X=360-X-XX 5175 1212 XDDEG=X 5176 1213 WRITE(*,96)PSP 5177 96 FORMAT(' warp factor(',f5.3,') ') 5178 READ(*,*,ERR=897,END=4321)X 5179 IF(X.EQ.XHELP)GO TO 897 5180 IF(X.LT.0.)GO TO 998 5181 XDSP=X 5182 GO TO 150 5183 C ...4 COMMAND. GET STRENGTH AND WHETHER FWD OR REAR. 5184 124 WRITE(*,95) 5185 95 format(' Energize Phasers'/' Forward or Rear ') 5186 READ(*,94,END=4321)cDIR 5187 94 FORMAT(A1) 5188 IF(cDIR.EQ.LETR(10))GO TO 1241 5189 IF(cDIR.NE.LETR(4))GO TO 896 5190 IDIR=3 5191 GO TO 1242 5192 1241 IDIR=1 5193 C ...SUBTRAVT ENERGY THAT IS QUEUED TO BE USED IN PREV. CMNDS. 5194 1242 XNRGY=ENERGY-PNRGY 5195 IF(EFP(1).NE.0.)XNRGY=ENERGY 5196 1243 WRITE(*,91)XNRGY 5197 91 format(' energy (available=',f8.1,') ') 5198 READ(*,*,ERR=895,END=4321)PNRGY 5199 IF(PNRGY.EQ.XHELP)GO TO 895 5200 IF(PNRGY.LT.XNRGY)GO TO 1244 5201 WRITE(*,1245) 5202 1245 FORMAT(' NOT ENOUGH ENERGY AVAILABLE') 5203 GO TO 1243 5204 1244 IF(PNRGY.GT.0.)GO TO 150 5205 PNRGY=0. 5206 GO TO 998 5207 12551 WRITE(*,93)ITORP 5208 93 format(' photon torpedos'/' how may to fire (',i2,' max) ') 5209 READ(*,*,ERR=894,END=4321)MTORPS 5210 IF(MTORPS.EQ.XHELP)GO TO 894 5211 GO TO 12553 5212 125 IF(ITORP.NE.0)GO TO 12551 5213 WRITE(*,12552) 5214 12552 FORMAT(' PHOTON TORPEDOS EXPENDED') 5215 GO TO 998 5216 12553 IF(MTORPS.LE.0.OR.MTORPS.GT.ITORP)GO TO 998 5217 C ... DTORP IS BRNG ARRAY. 5218 1252 DO 1251 J=1,MTORPS 5219 12522 WRITE(*,89)J 5220 89 format(' bearing for torpedo ',i3,' ') 5221 read(*,*,ERR=893,END=4321)X 5222 IF(X.EQ.XHELP)GO TO 893 5223 C ...NOTE THAT CANCELLATION OF ONE CAUSES ALL TO BE CANCELLED. 5224 IF(X.LT.0.OR.X.GE.360.)GO TO 998 5225 DTORP(J)=X 5226 1251 CONTINUE 5227 IF(ITFIRE.EQ.0)MINR=0 5228 GO TO 150 5229 C ...TRACTOR BEAMS. COMPUTER CALCULATES STRENGTH NECESSARY. 5230 126 WRITE (*,87) 5231 87 format(' pulsive beams'/' tractor or repulsor ') 5232 READ(*,94,END=4321)cBTYPE 5233 IBTYP=1 5234 IF(cBTYPE.EQ.LETR(7))GO TO 150 5235 IF(cBTYPE.NE.LETR(4))GO TO 892 5236 IBTYP=2 5237 XNRGY=ENERGY-PNRGY 5238 IF(ETR(1).NE.0.)XNRGY=ENERGY 5239 1261 WRITE(*,91)XNRGY 5240 READ(*,*,ERR=891,END=4321)PNRGY 5241 IF(PNRGY.EQ.XHELP)GO TO 891 5242 IF(PNRGY.LT.XNRGY)GO TO 1262 5243 WRITE(*,1245) 5244 GO TO 1261 5245 1262 IF(PNRGY.GT.0.)GO TO 1263 5246 PNRGY=0. 5247 GO TO 998 5248 1263 IF(KLNGNS.LE.1)GO TO 1264 5249 WRITE(*,9112) 5250 9112 format(' which klingon?') 5251 read(*,*,ERR=871,END=4321)IBTYPE 5252 IF(IBTYPE.EQ.XHELP)GO TO 871 5253 IF(IBTYPE.LE.0.OR.IBTYPE.GT.KLNGNS)GO TO 998 5254 IBTYP=-IBTYPE 5255 GO TO 150 5256 1264 IBTYP=-1 5257 GO TO 150 5258 C ...TRAVEL. GET NO. OF STARMINUTES. 5259 127 WRITE(*,77707) 5260 77707 format(' travel how many star minutes? ') 5261 READ(*,*,ERR=890,END=4321)ITRSTP 5262 IF(ITRSTP.EQ.XHELP)GO TO 890 5263 IF(ITRSTP.GT.0)GO TO 1271 5264 ITRSTP=0 5265 GO TO 998 5266 1271 ITRSTP=MAX0(0,ITRSTP-2) 5267 GO TO 150 5268 C ...DAMAGE CONTROL. NOW POSSIBLE TO REASSIGN REPAIR CREWS. 5269 129 WRITE(*,77708) 5270 77708 format(' damage control request? ') 5271 READ(*,94,END=4321)IDAM 5272 JDAM=1 5273 IF(IDAM.EQ.LETR(4))GO TO 150 5274 IF(IDAM.EQ.LETR(11))GO TO 1297 5275 IF(IDAM.NE.NHELPS)GO TO 998 5276 GO TO 875 5277 1297 JDAM=2 5278 C CALL CPAGE 5279 WRITE(*,1291)IPROB1 5280 1291 format(' current priorities are:',10i4) 5281 J=1 5282 K=2 5283 DO 77720 I=1,5 5284 WRITE(*,77721)J,NAMD(J),K,NAMD(K) 5285 77721 FORMAT(1X,I2,' - ',A8,5X,I2,' - ',A8) 5286 J=J+2 5287 K=K+2 5288 77720 CONTINUE 5289 1293 WRITE(*,77709) 5290 77709 format(' reassignment? ') 5291 read(*,*,END=4321,ERR=874)IPROB2 5292 IF(IPROB2(1).EQ.XHELP)GO TO 874 5293 C ...CHECK IF SUM <=100. 5294 IS=0 5295 DO 1295 J=1,10 5296 IF(IPROB2(J).LT.0)GO TO 998 5297 1295 IS=IS+IPROB2(J) 5298 IF(IS.LE.100)GO TO 150 5299 WRITE(*,1292)IPROB2 5300 1292 format(' illegal reassignment:',10i4) 5301 GO TO 1293 5302 130 WRITE(*,183) 5303 183 format(' evasive maneuvers') 5304 GO TO 1305 5305 131 WRITE(*,88885) 5306 88885 format(' emergency evasive maneuvers') 5307 1305 WRITE(*,77710) 5308 77710 format(' port,starboard, or reverse ') 5309 READ(*,94,ERR=889,END=4321)IEVAS 5310 IEVDR=1 5311 IF(IEVAS.EQ.LETR(11))GO TO 150 5312 IF(IEVAS.EQ.LETR(4))GO TO 1306 5313 IF(IEVAS.EQ.NHELPS)GO TO 889 5314 IF(IEVAS.NE.LETR(12))GO TO 998 5315 IEVDR=2 5316 GO TO 150 5317 1306 IEVDR=3 5318 GO TO 150 5319 C ...RAISE DEFLECTORS. NEGATIVE NUMBERS ACCEPTED. 5320 132 XNRGY=ENERGY-PNRGY 5321 1322 WRITE(*,81)XNRGY,DEFL 5322 81 format(' raise deflectors'/' energy = ',f7.0,' shields = ',f8.1) 5323 write(*,77711) 5324 77711 format(' power to shields? ') 5325 read(*,*,err=888,end=4321)addfl 5326 if(addfl.eq.xhelp)go to 888 5327 if(addfl.lt.xnrgy)go to 150 5328 write(*,1245) 5329 go to 1322 5330 c ...self destruct 5331 c 138 call cpage 5332 138 write(*,1381) 5333 1381 format(' destruct sequence entered!!!!!!'/ 5334 1' the enterprise will self destruct in 10 seconds'/ 5335 1' 10'/ 5336 1' 9'/ 5337 1' 8'/ 5338 1' 7'/ 5339 1' 6'/ 5340 1' self destruct in 5 seconds! fail-safe mechanism engaged'/ 5341 1' only the commander can override with his password'/ 5342 1' enter password to continue:') 5343 1384 read(*,1382,end=4321)npass 5344 1382 format(a8) 5345 if(npass.ne.mpass)go to 887 5346 write(*,1383) 5347 1383 format(' 5'/ 5348 1' 4'/ 5349 1' 3'/ 5350 1' 2'/ 5351 1' 1') 5352 go to 150 5353 c ...transporters. 5354 139 if(jjstat.gt.0)go to 994 5355 if(istat.eq.0.or.istat.eq.9999)go to 1397 5356 write(*,941) 5357 941 format(' transporters already in use. retype command when previous5358 1 order is complete.') 5359 go to 998 5360 1397 write(*,601) 5361 601 format(' energize transporters'/' from?[a,i] ') read(*,940,err=886,end=4321)ifrom,kfrom 5363 940 format(a1,i1) 5364 if(ifrom.eq.letr(3))go to 1395 5365 if(ifrom.eq.letr(4))go to 1395 5366 if(ifrom.eq.letr(5))go to 1395 5367 if(ifrom.eq.letr(6))go to 1395 5368 if(ifrom.ne.letr(2))go to 886 5369 1395 write(*,1399) 5370 1399 format(' how many men?[i] ') read(*,*,err=885,end=4321)ibmen 5372 if(ibmen.eq.xhelp)go to 885 5373 if(ibmen.le.0)go to 998 5374 13961 write(*,1396) 5375 1396 format(' to?[a,i] ') read(*,940,err=884,end=4321)ito,mto 5377 if(ito.eq.letr(3))go to 150 5378 if(ito.eq.letr(4))go to 13905 5379 if(ito.eq.letr(5))go to 150 5380 if(ito.ne.letr(2))go to 884 5381 go to 150 5382 13905 if(icloak.ne.2.or.mto.ne.1)go to 150 5383 13907 write(*,13906) 5384 13906 format(' type guess coordinates') 5385 read(*,*,err=8835,end=4321)iguess,jguess 5386 if(iguess.eq.xhelp)go to 8835 5387 if(iguess.eq.xrom(1,1).and.jguess.eq.xrom(1,2))go to 150 5388 write(*,13908) 5389 13908 format(' wrong guess') 5390 go to 998 5391 c ...intership communications 5392 141 write(*,1401) 5393 1401 format(' intership communications') 5394 go to 1405 5395 14051 write(*,1406) 5396 1406 format(' communications intercepted and jammed!') 5397 actpjm=actpjm+pjminc 5398 go to 998 5399 1405 write(*,1396) 5400 read(*,940,err=883,end=4321)ito,kto 5401 lto=3 5402 if(ito.eq.letr(4))go to 1407 5403 if(ito.eq.letr(5))go to 1408 5404 if(ito.eq.letr(6))go to 1411 5405 if(ito.ne.letr(3))go to 883 5406 go to 1410 5407 1407 lto=4 5408 go to 1410 5409 1408 lto=5 5410 go to 1410 5411 1411 lto=6 5412 1410 write(*,1409) 5413 1409 format(' message?'/ 5414 1' 1 - change course 4 - fire phasers'/ 5415 1' 5 - fire torpedos 6 - self destruct'/ 5416 1' 8 - status report 9 - damage report'/ 5417 1' 12 - raise deflectors 17 - plot bearing') 5418 read(*,*,err=882,end=4321)imsg 5419 if(imsg.eq.xhelp)go to 882 5420 c ...enemy intercept message?. 5421 if(klngns.eq.0)go to 14097 5422 do 14098 j=1,klngns 5423 if(icntl(j+1).ne.1.and.xkl(j,1).ne.0.)go to 14095 5424 14098 continue 5425 14097 if(nrom.eq.0)go to 14099 5426 do 14096 j=1,nrom 5427 if(icntl(j+10).ne.1.and.xrom(j,1).ne.0.)go to 14093 5428 14096 continue 5429 go to 14099 5430 14095 if(ran(izz).gt.actpjm)go to 14097 5431 go to 14051 5432 14093 if(ran(izz).le.actpjm)go to 14051 5433 14099 go to(14001,998,998,14004,14005,150,998,150,150,998,998,14012,998,5434 1 998,998,998,14017),imsg 5435 go to 998 5436 c ...change course. illegal if romulan or base 5437 14001 if(lto.eq.4)go to 998 5438 if(lto.eq.6)go to 998 5439 write(*,14020) 5440 14020 format(' new bearing?') 5441 read(*,*,err=881,end=4321)kbrg 5442 if(kbrg.eq.xhelp)go to 881 5443 14002 if(kbrg.ge.0)go to 14003 5444 kbrg=kbrg+360 5445 go to 14002 5446 14003 if(kbrg.lt.360)go to 14021 5447 kbrg=kbrg-360 5448 go to 14003 5449 14021 write(*,14022) 5450 14022 format(' warp factor?') 5451 read(*,*,err=880,end=4321)xwrp 5452 if(xwrp.eq.xhelp)go to 880 5453 if(xwrp.lt.0.)go to 998 5454 go to 150 5455 c ...fire phasers. illegal if romulan or base. 5456 14004 if(lto.eq.4)go to 998 5457 if(lto.eq.6)go to 998 5458 if(lto.ne.5)go to 150 5459 write(*,77712) 5460 77712 format(' # times to fire? ') 5461 read(*,*,end=4321,err=873)nghtfp 5462 if(nghtfp.eq.xhelp)go to 873 5463 if(nghtfp.le.0)go to 998 5464 go to 150 5465 c ...fire torpedo. illegal if klingon or base. 5466 14005 if(lto.eq.3)go to 998 5467 if(lto.eq.6)go to 998 5468 write(*,14025) 5469 14025 format(' bearing(s) for torpedo(s)?') 5470 do 14024 j=1,5 5471 14024 rtbrg(j)=-1. 5472 read(*,*,err=879,end=4321)rtbrg 5473 if(trbrg.eq.xhelp)go to 879 5474 if(rtbrg(1).lt.0.)go to 998 5475 go to 150 5476 c ...deflectors. ghostship only. neg now okay for lowering. 5477 14012 if(lto.ne.5)go to 998 5478 write(*,14027) 5479 14027 format(' power to deflectors?') 5480 read(*,*,err=878,end=4321)sdef 5481 if(sdef.eq.xhelp)go to 878 5482 go to 150 5483 c ...plot bearing. legal for base only. 5484 14017 if(lto.ne.6)go to 998 5485 go to 150 5486 c ...shuttlecraft. 5487 142 write(*,1421) 5488 1421 format(' shuttlecraft command?') 5489 read(*,94,end=4321)ilet 5490 jschm=1 5491 if(ilet.eq.letr(4))go to 1425 5492 if(ilet.ne.letr(2))go to 877 5493 14211 write(*,1422) 5494 1422 format(' which star systems') 5495 read(*,*,err=876,end=4321)ishstr 5496 if(ishstr(1).eq.xhelp)go to 876 5497 if(ishstr(1).le.0)go to 998 5498 go to 150 5499 1425 jschm=2 5500 go to 150 5501 c ...computer requests. 5502 143 write(*,77713) 5503 77713 format(' computer request? ') 5504 read(*,94,end=4321,err=872)ilet 5505 if(ilet.eq.letr(5))go to 1431 5506 if(ilet.eq.letr(6))go to 1432 5507 if(ilet.eq.letr(12))go to 1433 5508 if(ilet.eq.letr(4))go to 1434 5509 if(ilet.eq.letr(13).and.icloak.lt.0)go to 1435 5510 if(ilet.eq.letr(7))go to 1436 5511 if(ilet.ne.nhelps)go to 998 5512 go to 872 5513 1431 jschm=1 5514 go to 150 5515 1432 jschm=2 5516 go to 150 5517 1433 jschm=3 5518 go to 150 5519 1434 jschm=4 5520 go to 150 5521 1435 jschm=5 5522 write(*,77716) 5523 77716 format(' turn cloaking device on (y or n)?') 5524 read(*,94,err=4321)iclkon 5525 if(iclkon.eq.ihelps)go to 870 5526 go to 150 5527 1436 jschm=6 5528 go to 150 5529 c ...end of command input. do things which occurred in the interim. 5530 150 call qtime(itime) 5531 nsteps=(itime-istart) 5532 if(nsteps.le.0)nsteps=1 5533 155 istart=itime 5534 nhold=nhold+nsteps 5535 if(nhold.ge.itfctr)go to 88888 5536 go to 3000 5537 88888 nsteps=itfctr 5538 nhold=nhold-itfctr 5539 88890 if(nhold.lt.itfctr)go to 88889 5540 nsteps=nsteps+itfctr 5541 nhold=nhold-itfctr 5542 go to 88890 5543 88889 call action 5544 3000 call procm 5545 nhold=nhold+nsteps 5546 if(nhold.ge.itfctr)go to 88891 5547 go to 88899 5548 88891 nsteps=itfctr 5549 nhold=nhold-itfctr 5550 88898 if(nhold.lt.itfctr)go to 88899 5551 nsteps=nsteps+itfctr 5552 nhold=nhold-itfctr 5553 go to 88898 5554 88899 call action 5555 if(nhold.ge.itfctr)go to 88891 5556 go to 120 5557 998 write(*,996) 5558 pnrgy=0. 5559 996 format(' +++cancelled+++') 5560 icm=99 5561 go to 150 5562 994 write(*,993)letr(jup),jfrom 5563 993 format(' transporters already energized for ',a1,i1,' destruct') 5564 go to 998 5565 4321 stop 5566 899 call help(7777) 5567 call qtime(istart) 5568 go to 120 5569 898 call help(25) 5570 call qtime(istart) 5571 go to 121 5572 897 call help(26) 5573 call qtime(istart) 5574 go to 1213 5575 896 call help(27) 5576 call qtime(istart) 5577 go to 124 5578 895 call help(28) 5579 call qtime(istart) 5580 go to 1243 5581 894 call help(29) 5582 call qtime(istart) 5583 go to 12551 5584 893 call help(30) 5585 call qtime(istart) 5586 go to 1252 5587 892 call help(31) 5588 call qtime(istart) 5589 go to 126 5590 891 call help(32) 5591 call qtime(istart) 5592 go to 1261 5593 890 call help(34) 5594 call qtime(istart) 5595 go to 127 5596 889 call help(38) 5597 call qtime(istart) 5598 go to 1305 5599 888 call help(39) 5600 call qtime(istart) 5601 go to 1322 5602 887 if(npass.ne.nhelpl)go to 998 5603 call help(40) 5604 call qtime(istart) 5605 go to 1384 5606 886 if (ifrom.ne.nhelps)go to 998 5607 call help(41) 5608 call qtime(istart) 5609 go to 139 5610 885 call help(42) 5611 call qtime(istart) 5612 go to 1395 5613 884 call help(43) 5614 call qtime(istart) 5615 go to 13961 5616 8835 call help(44) 5617 call qtime(istart) 5618 go to 13907 5619 883 call help(45) 5620 call qtime(istart) 5621 go to 1405 5622 882 call help(46) 5623 call qtime(istart) 5624 go to 1410 5625 881 call help(47) 5626 call qtime(istart) 5627 go to 14001 5628 880 call help(48) 5629 call qtime(istart) 5630 go to 14021 5631 879 call help(49) 5632 call qtime(istart) 5633 go to 14005 5634 878 call help(50) 5635 call qtime(istart) 5636 go to 14012 5637 877 call help(52) 5638 call qtime(istart) 5639 go to 142 5640 876 call help(53) 5641 call qtime(istart) 5642 go to 14211 5643 875 call help(35) 5644 call qtime(istart) 5645 go to 129 5646 874 call help(36) 5647 call qtime(istart) 5648 go to 1293 5649 873 call help(51) 5650 call qtime(istart) 5651 go to 14004 5652 872 call help(54) 5653 call qtime(istart) 5654 go to 143 5655 871 call help(33) 5656 call qtime(istart) 5657 go to 1263 5658 870 call help(55) 5659 call qtime(istart) 5660 go to 1435 5661 end 5662