home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / startrek / part15 < prev    next >
Encoding:
Internet Message Format  |  1993-04-06  |  14.5 KB
  1. Path: uunet!noc.near.net!howland.reston.ans.net!usc!sdd.hp.com!decwrl!decwrl!concert!lester.appstate.edu!pembvax1.pembroke.edu!rennie
  2. From: rennie@pembvax1.pembroke.edu
  3. Newsgroups: vmsnet.sources.games
  4. Subject: Star Trek - Part [15/18]
  5. Date: 7 Apr 93 11:04:29 EDT
  6. Organization: Pembroke State University
  7. Lines: 463
  8. Message-ID: <1993Apr7.110429.1@pembvax1.pembroke.edu>
  9. NNTP-Posting-Host: papa.pembroke.edu
  10. Xref: uunet vmsnet.sources.games:657
  11.  
  12. -+-+-+-+-+-+-+-+ START OF PART 15 -+-+-+-+-+-+-+-+
  13. X      NUM = GALAXY(IQX,IQY)`20
  14. X      IF(NUM. GT. 899) GO TO IWHERE`20
  15. XC--------GO AHEAD AND MOVE.`20
  16. X      GALAXY(ISX,ISY) = GALAXY(ISX,ISY) -100
  17. X`09ISX=IQX
  18. X`09ISY=IQY
  19. X      GALAXY(ISX,ISY)=GALAXY(ISX,ISY)+100`20
  20. X      IF(ISCATE .EQ. 0) GO TO 40
  21. XC--------S.C. HAS SCOOTED.  REMOVE HIM FROM CURRENT QUADRANT.`20
  22. X`09ISCATE=0
  23. X`09ISATB=0
  24. X`09ISHERE=0
  25. X`09IENTESC=0
  26. X      FUTURE(7)=1E38`20
  27. X      DO 21 I=1,NENHERE`20
  28. X`09LOCSUP=I
  29. X`09IX=KX(I)
  30. X`09IY=KY(I)
  31. X      IF(QUAD(IX,IY) .EQ. IHS) GO TO 22`20
  32. X 21   CONTINUE
  33. X 22   CALL LEAVE
  34. X      QUAD(IX,IY)=IHDOT`20
  35. X      CALL SORTKL`20
  36. X      GO TO 40
  37. XC--------TRY SOME OTHER MANEUVERS`20
  38. X 23   IF((IDELTX .EQ. 0) .OR. (IDELTY .EQ. 0)) GO TO 30`20
  39. XC--------TRY MOVING JUST IN X DIRECTION.
  40. X`09IQY=ISY
  41. X`09ASSIGN 25 TO IWHERE
  42. X`09GO TO 15
  43. XC--------THEN TRY MOVING JUST IN Y DIRECTION.`20
  44. X25`09IQY=ISY+IDELTY
  45. X`09IQX=ISX
  46. X`09ASSIGN 300 TO IWHERE
  47. X`09GO TO 15
  48. XC--------ATTEMPT ANGLE MOVE.
  49. X 30   IF(IDELTX.NE.0) GO TO 35
  50. X`09IQX=ISX+1
  51. X`09ASSIGN 32 TO IWHERE
  52. X`09GO TO 15
  53. X 32   IQX = ISX-1`20
  54. X`09ASSIGN 300 TO IWHERE
  55. X`09GO TO 15
  56. X 35   IQY = ISY+1`20
  57. X`09ASSIGN 36 TO IWHERE
  58. X`09GO TO 15
  59. X 36   IQY = ISY-1`20
  60. X`09ASSIGN 300 TO IWHERE
  61. X`09GO TO 15
  62. XC--------SUPER-COMMANDER HAS MOVED.  CHECK SITUATION.`20
  63. XC--------CHECK FOR A HELPFUL PLANET.
  64. X 40   DO 44 I=1,INPLAN
  65. X      IPLAN = I`20
  66. X      IF((PLNETS(I,1) .NE. ISX) .OR.(PLNETS(I,2) .NE. ISY)) GO TO 44
  67. X      IF(PLNETS(I,4) .NE. 1) GO TO 45
  68. XC--------DESTROY PLANET.
  69. X      DO 43 J=1,5`20
  70. X 43   PLNETS(IPLAN,J) = 0
  71. X      NEWSTUF(ISX,ISY) = NEWSTUF(ISX,ISY)-1`20
  72. X      IF(DAMAGE(9) .GT. 0)  GO TO 45
  73. X      CALL SKIP(1)
  74. X      CALL PROUT(47HLT. UHURA:  "CAPTAIN, STARFLEET COMMAND REPORTS,47)
  75. X      CALL CRAM(13H  A PLANET IN)`20
  76. X      CALL CRAMLOC(1,ISX,ISY)`20
  77. X      CALL CRAMDMP(19H HAS BEEN DESTROYED)
  78. X      CALL PROUT(26H  BY THE SUPER-COMMANDER.",26)`20
  79. X      GO TO 45
  80. X 44   CONTINUE
  81. XC--------CHECK FOR A BASE.
  82. X 45   IF(REMBASE .EQ. 0) GO TO 60`20
  83. X      DO 46 I=1,REMBASE`20
  84. X`09IBQX=BASEQX(I)
  85. X`09IBQY=BASEQY(I)
  86. X 46   IF(IBQX.EQ.ISX .AND. IBQY.EQ.ISY .AND. ISX.NE.BATX .AND. ISY.NE.
  87. X     +  BATY) GO TO 80
  88. XC--------CHECK FOR INTELLIGENCE REPORT.`20
  89. X      IF(RANF(0) .GT. 0.2) RETURN`20
  90. X      IF(DAMAGE(9).GT.0. .OR. STARCH(ISX,ISY).GT.0) RETURN
  91. X      CALL SKIP(1)
  92. X      CALL PROUT(52HLT. UHURA:  "CAPTAIN, STARFLEET INTELLIGENCE REPORTS
  93. X     +,52)`20
  94. X      CALL CRAM(27H  THE SUPER-COMMANDER IS IN)`20
  95. X`09CALL CRAMLOC(1,ISX,ISY)
  96. X`09CALL CRAMDMP(2H.")
  97. XC--------NOTHING ELSE TO DO.
  98. X      RETURN
  99. XC--------NOTHING AVAILABLE.  GO INTO HIBERNATION.`20
  100. X 60   FUTURE(6)=1E38
  101. X`09RETURN
  102. XC--------ATTACK A BASE.`20
  103. X 80   ISATB=1`20
  104. X      FUTURE(7)=DATE+1.0+2.0*RANF(0)
  105. X      IF(BATX.NE.0.0) FUTURE(7)=FUTURE(7)+FUTURE(5)-DATE `20
  106. X`09LOC=IHS
  107. X`09CALL SOS
  108. X300   RETURN     `20
  109. X      END`20
  110. $ CALL UNPACK TRSCOM.FOR;1 689501820
  111. $ create 'f'
  112. X      SUBROUTINE SCORE
  113. XC
  114. XC`0931-MAY-79
  115. XC`09MAKE SCORE COME OUT UNCONDITIONALLY ON TERMINAL
  116. XC`09RETURN WITH LUN=2 IF SCORE WAS PRINTED ON LP
  117. XC
  118. X`09INCLUDE 'TREKCOM/NOLIST'
  119. X`09LOGICAL*1 ISHIP
  120. X      COMMON/PLAQ/ISCORE,PERDATE,ISKILL`20
  121. X`09COMMON/PRLUN/LUN
  122. X`09EQUIVALENCE (ISHIP,SHIP)
  123. X      ISKILL=SKILL
  124. X      TIMUSED=DATE-INDATE`20
  125. X      IF(TIMUSED.EQ.0 .OR. REMKL.NE.0) TIMUSED=AMAX1(TIMUSED,5.0)`20
  126. X      PERDATE=(KILLC+KILLK+NSCKILL)/TIMUSED`20
  127. X      ITHPERD=500.0*PERDATE+0.5`20
  128. X      IWON=0
  129. X      IF(GAMEWON .NE. 0) IWON=100.0*SKILL`20
  130. X      IF(ISHIP .EQ. IHE) KLSHIP=0
  131. X      IF(ISHIP .EQ. IHF) KLSHIP=1
  132. X      IF(ISHIP .EQ. 0)   KLSHIP=2
  133. X      IDIED=0`20
  134. X      IF(ALIVE .EQ. 0) IDIED=200
  135. X      IF(GAMEWON .EQ. 0) NROMREM=0
  136. X      ISCORE = 10*KILLK + 50*KILLC + ITHPERD + IWON - IDIED`20
  137. X     C  -100*BASEKL -100*KLSHIP -45*NHELP -5*STARKL -CASUAL`20
  138. X     C +20*NROMKL+200*NSCKILL-10*NPLANKL+NROMREM
  139. X100   CALL SKIP(1)
  140. X      CALL PROUT(12HYOUR SCORE--,12)`20
  141. X      CALL SKIP(1)
  142. X      IF(NROMKL .EQ. 0) GO TO 1`20
  143. X      CALL CRAMI(NROMKL,6)
  144. X      CALL CRAM(35H ROMULANS DESTROYED                           )
  145. X`09CALL CRAMI(20*NROMKL,10)
  146. X`09CALL CREND
  147. X 1    IF(NROMREM .EQ. 0) GO TO 5
  148. X      CALL CRAMI(NROMREM,6)`20
  149. X      CALL CRAM(35H ROMULANS CAPTURED                                 )`20
  150. X`09CALL CRAMI(NROMREM,10)
  151. X`09CALL CREND
  152. X 5    IF(KILLK .EQ. 0) GO TO 10`20
  153. X      CALL CRAMI(KILLK,6)`20
  154. X      CALL CRAM(35H ORDINARY KLINGONS DESTROYED       )`20
  155. X      CALL CRAMI(10*KILLK,10)`20
  156. X      CALL CREND
  157. X 10   IF(KILLC .EQ. 0) GO TO 12`20
  158. X      CALL CRAMI(KILLC,6)`20
  159. X      CALL CRAM(35H KLINGON COMMANDERS DESTROYED      )`20
  160. X      CALL CRAMI(50*KILLC,10)`20
  161. X      CALL CREND
  162. X 12   IF(NSCKILL .EQ. 0) GO TO 15`20
  163. X      CALL CRAMI(NSCKILL,6)`20
  164. X      CALL CRAM(35H SUPER-COMMANDER DESTROYED            )
  165. X      CALL CRAMI(200,10)
  166. X      CALL CREND
  167. X 15   IF(ITHPERD .EQ. 0) GO TO 20`20
  168. X      CALL CRAMF(PERDATE,6,2)`20
  169. X      CALL CRAM(35H KLINGONS PER STARDATE, AVERAGE    )`20
  170. X      CALL CRAMI(ITHPERD,10)
  171. X      CALL CREND
  172. X 20   IF(STARKL .EQ. 0) GO TO 30
  173. X      CALL CRAMI(STARKL,6)
  174. X      CALL CRAM(35H STARS DESTROYED BY YOUR ACTION    )`20
  175. X      CALL CRAMI(-5*STARKL,10)
  176. X      CALL CREND
  177. X30`09IF(NPLANKL.EQ.0) GO TO 32
  178. X`09CALL CRAMI(NPLANKL,6)
  179. X      CALL CRAM(35H PLANETS DESTROYED BY YOUR ACTION       )
  180. X      CALL CRAMI(-10*NPLANKL,10)`20
  181. X`09CALL CREND
  182. X 32   IF(BASEKL .EQ. 0) GO TO 35
  183. X      CALL CRAMI(BASEKL,6)
  184. X      CALL CRAM(35H BASES DESTROYED BY YOUR ACTION    )`20
  185. X      CALL CRAMI(-100*BASEKL,10)
  186. X      CALL CREND
  187. X 35   IF(NHELP .EQ. 0) GO TO 40`20
  188. X      CALL CRAMI(NHELP,6)`20
  189. X      CALL CRAM(35H CALLS FOR HELP FROM STARBASE      )`20
  190. X      CALL CRAMI( -45*NHELP,10)`20
  191. X      CALL CREND
  192. X 40   IF(CASUAL .EQ. 0) GO TO 45
  193. X      CALL CRAMI(CASUAL,6)
  194. X      CALL CRAM(35H CASUALTIES INCURRED               )`20
  195. X      CALL CRAMI(-CASUAL,10)
  196. X      CALL CREND
  197. X 45   IF(KLSHIP .EQ. 0) GOTO 50`20
  198. X      CALL CRAMI(KLSHIP,6)
  199. X      CALL CRAM(35H SHIP(S) LOST OR DESTROYED         )`20
  200. X      CALL CRAMI(-100*KLSHIP,10)
  201. X      CALL CREND
  202. X 50   IF(ALIVE .NE. 0) GO TO 60`20
  203. X      CALL PROUT(`20
  204. X     +   50HPENALTY FOR GETTING YOURSELF KILLED           -200,50)
  205. X 60   IF(GAMEWON .EQ. 0) GO TO 70`20
  206. X      CALL CRAM(18HBONUS FOR WINNING )
  207. X      IF(SKILL .EQ. 1) CALL CRAM(13HNOVICE GAME           )`20
  208. X      IF(SKILL .EQ. 2) CALL CRAM(13HFAIR GAME              )
  209. X      IF(SKILL .EQ. 3) CALL CRAM(13HGOOD GAME             )`20
  210. X      IF(SKILL .EQ. 4) CALL CRAM(13HEXPERT GAME                )
  211. X      IF(SKILL .EQ. 5) CALL CRAM(13HEMERITUS GAME)
  212. X      CALL CRAM(10H            )
  213. X      CALL CRAMI(IWON,10)`20
  214. X      CALL CREND
  215. X 70   CALL PROUT(0,1)`20
  216. X      CALL CRAM(41HTOTAL SCORE                              )`20
  217. X      CALL CRAMI(ISCORE,10)`20
  218. X      CALL CREND
  219. X`09IF(LUN.EQ.2)RETURN
  220. X`09CALL SKIP(1)
  221. X`09CALL PROMPT
  222. X`091  ('DO YOU WANT A COPY OF YOUR SCORE ON THE LINE PRINTER? ',54)
  223. X`09IF(JA(DUMMY).EQ.0)RETURN
  224. X   `09LUN=2
  225. X`09CALL CLOSE(2)
  226. X`09CALL ASSIGN(2,'LP:')
  227. X`09GO TO 100
  228. X      END`20
  229. $ CALL UNPACK TRSCORE.FOR;1 1717895743
  230. $ create 'f'
  231. X      SUBROUTINE SETUP
  232. X`09INCLUDE 'TREKCOM/NOLIST'
  233. X      EQUIVALENCE (CRACKS(2),SHUTUP)
  234. XC--------PREPARE THE ENTERPRISE`20
  235. X      SHIP=IHE
  236. X`09INENRG=5000.0
  237. X`09ENERGY=5000.0
  238. X`09INSHLD=2500.0
  239. X`09SHLD=2500.0
  240. X`09SHLDUP=0
  241. X`09SHLDCHG=0
  242. X`09INLSR=4.0
  243. X`09LSUPRES=4.0
  244. X      CALL IRAN8(QUADX,QUADY)`20
  245. X      CALL IRAN10(SECTX,SECTY)
  246. X`09INTORPS=10
  247. X`09TORPS=10
  248. X      WARPFAC=5.0`20
  249. X      WFACSQ=25.0`20
  250. X      DO 3 I=1,NDEVICE
  251. X3     DAMAGE(I)=0.0`20
  252. X`09ISUBDAM=0
  253. XC--------SET UP ASSORTED GAME PARAMETERS
  254. X      SHUTUP=0.0
  255. X`09BATX=0
  256. X`09BATY=0
  257. X      IDATE=31.0*RANF(0)+20.0`20
  258. X`09DATE=100*IDATE
  259. X`09INDATE=DATE
  260. X`09KILLK=0
  261. X`09KILLC=0
  262. X`09NKINKS=0
  263. X`09NHELP=0
  264. X`09RESTING=0
  265. X`09CASUAL=0
  266. X`09NROMKL=0
  267. X`09ISATB=0
  268. X`09ISCATE=0
  269. X`09IMINE=0
  270. X`09ICRYSTL=0
  271. X`09ICRAFT=0
  272. X`09NSCKILL=0
  273. X`09NPLANKL=0
  274. X`09ISCRAFT=1
  275. X`09LANDED=-1
  276. X`09CRYPROB=0.05
  277. X`09ICSOS=0
  278. X`09ISSOS=0
  279. X      ALIVE=1`20
  280. X      DOCKFAC=0.25
  281. X      DO 4 I=1,8
  282. X      DO 4 J=1,8
  283. X      NEWSTUF(I,J)=0
  284. X4     STARCH(I,J)=0`20
  285. XC--------INITIALIZE TIMES FOR EXTRANEOUS EVENTS`20
  286. X      FUTURE(1)=DATE+EXPRAN(0.5*INTIME)`20
  287. X      FUTURE(2)=DATE+EXPRAN(1.5*INTIME/REMCOM)
  288. X      FUTURE(3)=DATE+EXPRAN(0.5*INTIME)`20
  289. X      FUTURE(4)=DATE+EXPRAN(0.3*INTIME)`20
  290. X      FUTURE(5)=1E38`20
  291. X      FUTURE(6)=1E38`20
  292. X      IF(NSCREM.GT.0) FUTURE(6)=DATE+0.2777`20
  293. X      FUTURE(7)=1E38`20
  294. XC--------PUT STARS IN THE GALAXY
  295. X      INSTAR=0
  296. X      DO 5 I=1,8
  297. X      DO 5 J=1,8
  298. X      K = RANF(0) * 9 + 1`20
  299. X      INSTAR=INSTAR+K`20
  300. X5     GALAXY(I,J)=K`20
  301. X      STARKL=0
  302. XC-------LOCATE STARBASES IN THE GALAXY (IMPROVED PLACEMENT)`20
  303. X      DO 9 I=1,INBASE      `20
  304. X6     CALL IRAN8(IX,IY)    `20
  305. X      IF(GALAXY(IX,IY).GE.10) GOTO 6 `20
  306. X      IF(I.EQ.1) GOTO 8    `20
  307. X      LIM=I-1    `20
  308. X      DO 7 J=1,LIM
  309. X      DISTQ=(IX-BASEQX(J))**2 + (IY-BASEQY(J))**2`20
  310. X      IF(DISTQ .LT. 6*(6-INBASE) .AND. RANF(0.) .LT. 0.75) GOTO 6  `20
  311. X7     CONTINUE   `20
  312. X8     BASEQX(I)=IX
  313. X      BASEQY(I)=IY
  314. X      STARCH(IX,IY)= -1    `20
  315. X9     GALAXY(IX,IY)=GALAXY(IX,IY)+10 `20
  316. X      BASEKL=0   `20
  317. XC--------POSITION ORDINARY KLINGON BATTLE CRUISERS
  318. X      KREM=INKLING-INCOM-NSCREM`20
  319. X      KLUMPER=0.25*SKILL*(9-LENGTH)+1.0`20
  320. X      KLUMPER=MIN0(9,KLUMPER)`20
  321. X 10   KLUMP=(1.0-RANF(0)**2)*KLUMPER
  322. X      IF(KLUMP .GT. KREM) KLUMP=KREM
  323. X      NUM=100*KLUMP`20
  324. X 15   CALL IRAN8(IX,IY)`20
  325. X      IF(GALAXY(IX,IY)+NUM .GT. 999) GO TO 15`20
  326. X      GALAXY(IX,IY)=GALAXY(IX,IY)+NUM`20
  327. X      KREM=KREM-KLUMP`20
  328. X      IF(KREM .NE. 0) GO TO 10
  329. XC--------POSITION KLINGON COMMAND SHIPS`20
  330. X      DO 18 I=1,INCOM`20
  331. X 16   CALL IRAN8(IX,IY)`20
  332. X      IF(GALAXY(IX,IY).LT.99 .AND. RANF(0).LT.0.75) GO TO 16
  333. X      IF(GALAXY(IX,IY) .GT. 899)GO TO 16
  334. X      IF(I .EQ. 1)GO TO 17
  335. X      IM1=I-1`20
  336. X      DO 1605 JJ=1,IM1
  337. X      IF(CX(JJ) .EQ. IX .AND. CY(JJ) .EQ. IY)GO TO 16`20
  338. X1605  CONTINUE
  339. X17    GALAXY(IX,IY)=GALAXY(IX,IY)+100`20
  340. X      CX(I)=IX
  341. X18    CY(I)=IY
  342. XC--------LOCATE PLANETS IN GALAXY`20
  343. X      DO 20 I=1,INPLAN
  344. X 19   CALL IRAN8(IX,IY)`20
  345. X      IF(NEWSTUF(IX,IY) .GT. 0) GO TO 19
  346. X`09NEWSTUF(IX,IY)=1
  347. X`09PLNETS(I,1)=IX
  348. X`09PLNETS(I,2)=IY
  349. XC--------DECIDE WHAT KIND OF PLANET  M=1, N=2, O=3.`20
  350. X      PLNETS(I,3)=RANF(0)*3. + 1.
  351. XC--------DECIDE WHETHER DILITHIUM CRYSTALS ARE PRESENT.`20
  352. X      PLNETS(I,4)=1.2*RANF(0)
  353. X      PLNETS(I,5)=0
  354. X 20   CONTINUE
  355. XC--------LOCATE ROMULANS.`20
  356. X      DO 21 I=1,NROMREM`20
  357. X      CALL IRAN8(IX,IY)`20
  358. X 21   NEWSTUF(IX,IY)=NEWSTUF(IX,IY)+10
  359. XC--------LOCATE THE SUPER-COMMANDER, IF NEEDED.`20
  360. X      IF(NSCREM .LT. 1) GO TO 23
  361. X 22   CALL IRAN8(IX,IY)`20
  362. X      IF(GALAXY(IX,IY) .GT. 899) GO TO 22`20
  363. X`09ISX=IX
  364. X`09ISY=IY
  365. X      GALAXY(IX,IY)=GALAXY(IX,IY)+100`20
  366. X 23   IDATE = DATE
  367. X      CALL SKIP(1)
  368. X      SNAP=0
  369. XC--------DECIDE IF GALAXY NEEDS A "THING"`20
  370. X      IF((RANF(0) .GT. 0.04) .OR. (THINGX .EQ. -1)) GO TO 2301
  371. X      CALL IRAN8(THINGX,THINGY)`20
  372. X      GO TO 24
  373. X2301`09THINGX=0
  374. X`09THINGY=0
  375. XC--------PRINT BRIEF INITIAL MESSAGE
  376. X 24   CALL CRAM('STARDATE')`20
  377. X      CALL CRAMI(IDATE,5)`20
  378. X      CALL CREND
  379. X      CALL CRAMI(INKLING,5)`20
  380. X      CALL CRAMDMP(9H KLINGONS)`20
  381. X      CALL PROUT(31HAN UNKNOWN NUMBER OF ROMULANS   ,31)  `20
  382. X      IF(NSCREM .EQ. 0) GO TO 25
  383. X      CALL PROUT(33HAND ONE (GULP) <SUPER-COMMANDER>.,33)
  384. X 25   CALL CRAMI(IFIX(INTIME),5)
  385. X      CALL CRAMDMP(10H STARDATES)`20
  386. X      CALL CRAMI(INBASE,5)
  387. X      CALL CRAM(24H STARBASES:  QUADRANTS  )
  388. X      DO 50 I=1,INBASE
  389. X      CALL CRAMLOC(0,BASEQX(I),BASEQY(I))`20
  390. X      IF(I .LT. INBASE)CALL CRAM(2H,  )`20
  391. X50    CONTINUE
  392. X      CALL CREND
  393. X      CALL SKIP(1)
  394. X      CALL CRAM(30HTHE ENTERPRISE IS CURRENTLY IN)
  395. X      CALL CRAMLOC(1,QUADX,QUADY)`20
  396. X      CALL CRAM(1H,)
  397. X      CALL CRAMLOC(2,SECTX,SECTY)`20
  398. X      CALL CREND
  399. X`09CALL SKIP(1)
  400. X`09CALL CRAM(10HGOOD LUCK.)
  401. X      IF(NSCREM.GT.0)        CALL CRAM(17H  YOU'LL NEED IT.   )`20
  402. X      CALL CREND
  403. X      CALL NEWQUAD
  404. X      RETURN
  405. X      END`20
  406. $ CALL UNPACK TRSETUP.FOR;1 109008224
  407. $ create 'f'
  408. X      SUBROUTINE SETWARP
  409. X`09INCLUDE 'TREKCOM/NOLIST'
  410. X`09REAL*8 AITEM
  411. X`09COMMON/SCANBF/KEY,AITEM
  412. X`09EQUIVALENCE (FNUM,AITEM)
  413. X 10   CALL SCAN
  414. X      IF(KEY .NE. IHEOL) GO TO 20`20
  415. X`09CALL PROMPT(18H WARP FACTOR:      ,18)
  416. X      GO TO 10
  417. X20`09IF(KEY .NE. IHREAL) GO TO 40
  418. X      IF(DAMAGE(6) .GT. 10.0) GO TO 70
  419. X      IF(DAMAGE(6) .GT. 0.0  .AND. FNUM .GT. 4.0) GO TO 80
  420. X      IF(FNUM .LT. 1.0) GO TO 50`20
  421. X      IF(FNUM .GT. 10.0) GO TO 60
  422. X      OLDFAC=WARPFAC
  423. X      WARPFAC=FNUM`20
  424. X      WFACSQ=WARPFAC*WARPFAC
  425. XC--------GIVE ACCEPTANCE MESSAGE FOR WARP FACTORS <= 6 OR REDUCED`20
  426. X      IF(WARPFAC .LE. OLDFAC .OR. WARPFAC .LE. 6.0) GO TO 31
  427. X      IF(WARPFAC .LT. 8.00) GO TO 32`20
  428. X`09GO TO 33
  429. X 31   CALL CRAM(29HHELMSMAN SULU:  "WARP FACTOR )`20
  430. X      CALL CRAMF(WARPFAC,0,1)`20
  431. X      CALL CRAMDMP(11H, CAPTAIN.")
  432. X      RETURN
  433. XC--------GIVE WARNING MESSAGES FOR WARP FACTORS ABOVE WARP 6
  434. X 32   CALL PROUT(`20
  435. X     +  61HENGINEER SCOTT:  "AYE, BUT OUR MAXIMUM SAFE SPEED IS WARP 6."
  436. X     +   ,61)
  437. X      RETURN
  438. X 33   IF(WARPFAC .EQ. 10.0) GO TO 36
  439. X      CALL PROUT(`20
  440. X     +   65HENGINEER SCOTT:  "AYE, CAPTAIN, BUT OUR ENGINES MAY NOT TAKE
  441. X     + IT.",65)
  442. X      RETURN
  443. X 36   CALL PROUT(`20
  444. X     +   46HENGINEER SCOTT:  "AYE, CAPTAIN, WE'LL TRY IT.",46)      `20
  445. X      RETURN
  446. XC--------GIVE REFUSAL MESSAGES FOR BAD WARP COMMANDS
  447. X 40   CALL BEGPARD
  448. X      RETURN
  449. X 50   CALL PROUT(`20
  450. X     +   52HHELMSMAN SULU:  "WE CAN'T GO BELOW WARP 1, CAPTAIN.",52)`20
  451. X      RETURN
  452. X 60   CALL PROUT(`20
  453. X     +   52HHELMSMAN SULU:  "OUR TOP SPEED IS WARP 10, CAPTAIN.",52)`20
  454. X      RETURN
  455. X 70   CALL PROUT(25HWARP ENGINES INOPERATIVE.,25)
  456. X      RETURN
  457. X 80   CALL PROUT(45HENGINEER SCOTT:  "I'M DOING MY BEST, CAPTAIN,,45)
  458. X      CALL PROUT(41H  BUT RIGHT NOW WE CAN ONLY GO WARP 4."  ,41)   `20
  459. X      RETURN
  460. X      END`20
  461. $ CALL UNPACK TRSETWARP.FOR;1 306671700
  462. $ create 'f'
  463. X      SUBROUTINE SHIELDS
  464. X`09INCLUDE 'TREKCOM/NOLIST'
  465. X`09LOGICAL*1 ITEM
  466. X`09REAL*8 AITEM
  467. X`09COMMON/SCANBF/KEY,AITEM
  468. X`09EQUIVALENCE (FNUM,AITEM),(ITEM,AITEM)
  469. X      IDIDIT=0
  470. X      CALL SCAN  `20
  471. X      IF(KEY .NE. IHEOL) GO TO 30`20
  472. X 15   CALL PROMPT(40HDO YOU WISH TO CHANGE SHIELD ENERGY?    ,40)`20
  473. X      IF(JA(DUMMY)) GO TO 8010
  474. +-+-+-+-+-+-+-+-  END  OF PART 15 +-+-+-+-+-+-+-+-
  475.