home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / games / vmsnet / startrek / part14 < prev    next >
Encoding:
Internet Message Format  |  1993-04-06  |  14.5 KB
  1. Path: uunet!zaphod.mps.ohio-state.edu!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 [14/18]
  5. Date: 7 Apr 93 11:03:08 EDT
  6. Organization: Pembroke State University
  7. Lines: 447
  8. Message-ID: <1993Apr7.110308.1@pembvax1.pembroke.edu>
  9. NNTP-Posting-Host: papa.pembroke.edu
  10. Xref: uunet vmsnet.sources.games:656
  11.  
  12. -+-+-+-+-+-+-+-+ START OF PART 14 -+-+-+-+-+-+-+-+
  13. X97`09CALL PROUT(14HTRIP COMPLETE.,14)
  14. X`09RETURN
  15. XC--------LANDING PARTY BOARDS GALILEO FOR TRIP BACK TO SHIP.
  16. X 98   CALL PROUT(35HYOU AND YOUR MINING PARTY BOARD THE   ,35)`20
  17. X      CALL PROUT(`20
  18. X     +51HSHUTTLE CRAFT FOR THE TRIP BACK TO THE ENTERPRISE.     ,51)`20
  19. X      CALL SKIP(1)
  20. X      CALL PROUT(26HTHE SHORT HOP BEGINS . . .   ,26)
  21. X`09ICRAFT=1
  22. X`09LANDED=-1
  23. X`09ASSIGN 99 TO IWHERE
  24. X`09GO TO 96
  25. X99`09ICRAFT=0
  26. X`09ISCRAFT=1
  27. X`09IF(IMINE.NE.0) ICRYSTL=1
  28. X`09IMINE=0
  29. X`09GO TO 97
  30. XC--------LANDING PARTY HEADS DOWN TO PLANET.
  31. X 100  CALL PROUT(36HMINING PARTY ASSEMBLES IN THE HANGAR  ,36)`20
  32. X      CALL PROUT(`20
  33. X     +51HDECK, READY TO BOARD THE SHUTTLE CRAFT "GALILEO."     ,51) `20
  34. X      CALL SKIP(1)
  35. X      CALL PROUT(41HTHE HANGAR DOORS OPEN;  THE TRIP BEGINS.  ,41)  `20
  36. X`09ICRAFT=1
  37. X`09ISCRAFT=0
  38. X`09ASSIGN 110 TO IWHERE
  39. X`09GO TO 96
  40. X110`09LANDED=1
  41. X`09ICRAFT=0
  42. X`09GO TO 97
  43. XC*`20
  44. X      ENTRY DEATHRA`20
  45. XC*`20
  46. X`09IDIDIT=0
  47. X`09CALL SKIP(1)
  48. X      IF(SHIP .EQ. IHE) GO TO 113`20
  49. X      CALL PROUT(34HYE FAERIE QUEENE HAS NO DEATH RAY.,34)`20
  50. X      RETURN
  51. X 113  IF(NENHERE .GE. 1) GO TO 115
  52. X      CALL PROUT(56HSULU:  "BUT SIR, THERE ARE NO ENEMIES IN THIS QUADRA
  53. X     +NT.",56)
  54. X`09RETURN
  55. X115   IF(DAMAGE(14).LE.0) GOTO 116   `20
  56. X      CALL PROUT(17HDEATHRAY DAMAGED.,17)
  57. X      RETURN     `20
  58. X116   IDIDIT=1   `20
  59. X      CALL PROUT(44HKIRK:  "PREPARE FOR ACTIVATION OF DEATHRAY!",44)`20
  60. X      CALL SKIP(1)
  61. X      CALL PROUT(37HSPOCK:  "PREPARATIONS COMPLETE, SIR.",37)
  62. X      CALL PROUT(16HKIRK:  "ENGAGE!",16) `20
  63. X`09CALL SKIP(1)
  64. X      CALL PROUT(45HWHIRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR,45)
  65. X      R=RANF(0)`20
  66. X      IF(R .GT. 0.30) GO TO 130`20
  67. XC--------BANG!   `20
  68. X      CALL PROUT(32HSULU:  "CAPTAIN!  IT'S WORKING!",32)  `20
  69. X      CALL REDALRT
  70. X      CALL PROUT(41H***MATTER-ANTIMATTER IMPLOSION IMMINENT! ,41)   `20
  71. X      GO TO 5610
  72. XC--------SUCCESS!`20
  73. X130   CALL PROUT(32HSULU:  "CAPTAIN!  IT'S WORKING!",32)     `20
  74. X`09CALL SKIP(1)
  75. X      NENHER2=NENHERE`20
  76. X      DO 135 I=1,NENHER2
  77. X`09II=KX(1)
  78. X`09JJ=KY(1)
  79. X 135  CALL DEADKL(II,JJ,QUAD(II,JJ),II,JJ)
  80. X      CALL SKIP(1)
  81. X      CALL PROUT(42HENSIGN CHEKOV:  "CONGRATULATIONS CAPTAIN!",42)  `20
  82. X      IF(REMKL .EQ. 0) CALL FINISH(1)`20
  83. X      IF(REMKL .EQ. 0) RETURN`20
  84. X      CALL SKIP(1)
  85. X      CALL PROUT(`20
  86. X     +56HSPOCK:  "CAPTAIN, I BELIEVE THE "EXPERIMENTAL DEATH RAY",56)
  87. X      IF(RANF(0).GT..05) GOTO 140    `20
  88. X      CALL PROUT(22HIS STILL OPERATIONAL.",22)  `20
  89. X      RETURN     `20
  90. X140   CALL PROUT(33HHAS BEEN RENDERED DISFUNCTIONAL.",33) `20
  91. X      DAMAGE(14)=39.95     `20
  92. X      RETURN     `20
  93. X      END`20
  94. $ CALL UNPACK TRPLANET.FOR;1 946500293
  95. $ create 'f'
  96. X      SUBROUTINE PLAQUE`20
  97. XC
  98. XC`0930-MAY-79
  99. XC`09OUTPUT DATE WITH LOWER-CASE CHARACTERS
  100. XC`0931-MAY-79
  101. XC`09DON'T RE-OPEN OUTPUT IF LUN=2 ON ENTRY
  102. XC
  103. X`09INCLUDE 'TREKCOM/NOLIST'
  104. X      COMMON/PLAQ/ISCORE,PERDATE,ISKILL`20
  105. X`09LOGICAL*1 NAME(30)
  106. X`09COMMON/SCANBF/KEY,AITEM
  107. X`09COMMON/PRLUN/LUN
  108. X`09LUNSAV=LUN
  109. X`09LUN=1
  110. X11`09CALL PROMPT('ENTER NAME (UP TO 30 CHARACTERS): ',34)
  111. X`09LUN=LUNSAV
  112. X`09READ(1,20,ERR=11,END=11) ICHAR,NAME
  113. X20`09FORMAT(Q,30A1)
  114. X`09NSKIP=65-ICHAR/2
  115. X`09IF(LUN.EQ.2)GO TO 25
  116. X`09LUN=2
  117. X`09CALL CLOSE(2)
  118. X`09CALL ASSIGN(2,'LP:')
  119. X25`09WRITE(2,30)
  120. X30`09FORMAT('1')
  121. X`09CALL SKIP(4)
  122. XC--------DRAW ENTERPRISE PICTURE.`20
  123. X`09CALL PROUT(114H                                                 `20
  124. X     +              EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE,`20
  125. X     +114)`20
  126. X      CALL PROUT (114H                                      EEE        `20
  127. X     +             E  : :                                         :  E,`20
  128. X     +114)`20
  129. X      CALL PROUT (114H                                    EE   EEE     `20
  130. X     +             E  : :                   NCC-1701              :  E,`20
  131. X     +114)`20
  132. X      CALL PROUT (113H                    EEEEEEEEEEEEEEEE        EEEEEE`20
  133. X     +EEEEEEEEE    E  : :                                         : E,
  134. X     +114)`20
  135. X      CALL PROUT (112H                     E                           `20
  136. X     +         E    EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE
  137. X`091 ,114)
  138. X      CALL PROUT (81H                      EEEEEEEEE               EEEEE
  139. X     +EEEEEEEE                 E  E ,81)`20
  140. X      CALL PROUT (81H                               EEEEEEE   EEEEE    E
  141. X     +          E              E  E ,81)`20
  142. X      CALL PROUT (81H                                      EEE         `20
  143. X     + E          E            E  E ,81)`20
  144. X      CALL PROUT (81H                                                  `20
  145. X     +    E         E          E  E ,81)`20
  146. X      CALL PROUT (81H                                                  `20
  147. X     +      EEEEEEEEEEEEE      E  E ,81)`20
  148. X      CALL PROUT (87H                                                  `20
  149. X     +   EEE :           EEEEEEE  EEEEEEEE,87)`20
  150. X      CALL PROUT (88H                                                  `20
  151. X     + :E    :                 EEEE       E,88)
  152. X      CALL PROUT (88H                                                  `20
  153. X     +.-E   -:-----                       E,88)
  154. X      CALL PROUT (88H                                                  `20
  155. X     + :E    :                            E,88)
  156. X      CALL PROUT (87H                                                  `20
  157. X     +   EE  :                    EEEEEEEE,87)`20
  158. X      CALL PROUT (81H                                                 `20
  159. X     +     EEEEEEEEEEEEEEEEEEEEEEE   ,81)
  160. X      CALL SKIP(3)
  161. X      CALL PROUT(74H                                                   `20
  162. X     +   U. S. S. ENTERPRISE,74)`20
  163. X 5    CALL SKIP(1)
  164. X      CALL SKIP(3)
  165. X      CALL PROUT(93H                                  For demonstrating`20
  166. X     +outstanding ability as a starship captain,93)`20
  167. X      CALL SKIP(1)
  168. X      CALL PROUT(81H                                                Star
  169. V     `20
  170. X     +fleet Command bestows to you ,81)
  171. X      CALL SKIP(1)
  172. X      DO 8 I=1,NSKIP
  173. X 8    CALL CRAM(1H )
  174. X`09CALL CRAMS(NAME,ICHAR)
  175. X      CALL CREND
  176. X      CALL SKIP(1)
  177. X      CALL PROUT(71H                                                   `20
  178. X     +       the rank of ,71)  `20
  179. X`09CALL SKIP(1)
  180. X      CALL PROUT(75H                                                   `20
  181. X     +   "Commodore Emeritus",75)`20
  182. X`09CALL SKIP(1)
  183. X      CALL CRAM(58H                    `20
  184. X     +                                     )
  185. X      IF(ISKILL .EQ. 4) CALL CRAM(8H Expert )`20
  186. X      IF(ISKILL .EQ. 5) CALL CRAM(9HEmeritus )
  187. X      CALL CRAMDMP(5Hlevel)
  188. X`09CALL SKIP(1)
  189. X      CALL CRAM(66H                                                    `20
  190. X`091 This day of )
  191. X`09CALL FOR$DATE(NAME)
  192. X`09NAME(5)=NAME(5)+32
  193. X`09NAME(6)=NAME(6)+32
  194. X`09CALL CRAMS(NAME,9)
  195. X`09CALL CREND
  196. X      CALL SKIP(1)
  197. X      CALL CRAM(69H                                                    `20
  198. X`091   Your score:  )
  199. X`09CALL CRAMI(ISCORE,0)
  200. X`09CALL CREND
  201. X      CALL SKIP(1)
  202. X      CALL CRAM(76H                                                   `20
  203. X`091Klingons per stardate:   )
  204. X`09CALL CRAMF(PERDATE,0,2)
  205. X`09CALL CREND
  206. X      RETURN     `20
  207. X      END`20
  208. $ CALL UNPACK TRPLAQUE.FOR;1 339143108
  209. $ create 'f'
  210. X      SUBROUTINE PRELIM`20
  211. XC
  212. XC`095-APR-79
  213. XC`09UPDATE THE GREETING MESSAGE.
  214. XC
  215. XC--------PRINT A BUNCH OF GARBAGE WHEN GAME IS FIRST ENTERED
  216. X`09CALL ASSIGN(1,'TT:')
  217. X`09CALL PROUT(28H** U.T. "SUPER" STAR TREK **,28)
  218. X`09CALL PROUT(25HADAPTED FOR VAX/VMS BY MK,25)
  219. X`09CALL SKIP(1)
  220. X`09CALL PROUT(26HLIST THE FILE STARTREK.DOC,26)
  221. X`09CALL PROUT(25HFOR PLAYING INSTRUCTIONS.,25)
  222. X`09CALL SKIP(1)
  223. XC`09CALL PROUT(
  224. XC`091 44HFOR LATEST ON UPDATES, TYPE "TRKNEWS" AS    ,44)
  225. XC      CALL PROUT(`20
  226. XC     $52HYOUR GAME.  FOR PLAYING INSTRUCTIONS ENTER "TRKINST"  ,52) `20
  227. X      RETURN
  228. X      END`20
  229. $ CALL UNPACK TRPRELIM.FOR;1 1211258963
  230. $ create 'f'
  231. X      SUBROUTINE PROUT(LINE,KOUNT)
  232. X`09COMMON/PRLUN/LUN
  233. X`09BYTE LINE(120)
  234. X`09DATA LUN/1/
  235. X`09CALL CHEW
  236. X`09WRITE (LUN,100,ERR=900) (LINE(I),I=1,KOUNT)
  237. X100`09FORMAT (1X120A1)
  238. X      RETURN
  239. X`09ENTRY PROMPT(LINE,KOUNT)
  240. X`09CALL CHEW
  241. X`09WRITE (LUN,101,ERR=900) (LINE(I),I=1,KOUNT)
  242. X101`09FORMAT ('$',120A1)
  243. X900`09CONTINUE
  244. X`09RETURN
  245. X      END`20
  246. $ CALL UNPACK TRPROUT.FOR;1 422139800
  247. $ create 'f'
  248. X      SUBROUTINE RAM(IBUMPD,IENM,IX,IY)`20
  249. X`09INCLUDE 'TREKCOM/NOLIST'
  250. X`09LOGICAL*1 IENM
  251. X      CALL REDALRT
  252. X      CALL PROUT(22H***COLLISION IMMINENT.,22)`20
  253. X      CALL SKIP(2)
  254. X      CALL CRAM3AS
  255. X      CALL CRAMSHP
  256. X      TYPE=1.0   `20
  257. X      IF(IENM .EQ. IHT) TYPE=0.5     `20
  258. X      IF(IENM .EQ. IHR) TYPE=1.5
  259. X      IF(IENM .EQ. IHC) TYPE=2.0
  260. X      IF(IENM .EQ. IHS) TYPE=2.5
  261. X      IF(IBUMPD .EQ. 0) CALL CRAM(6H RAMS )`20
  262. X      IF(IBUMPD .EQ. 1) CALL CRAM(11H RAMMED BY )`20
  263. X      CALL CRAMENA(IENM,2,IX,IY)
  264. X      CALL CREND
  265. X      CALL DEADKL(IX,IY,IENM,SECTX,SECTY)`20
  266. X      CALL CRAM3AS
  267. X      CALL CRAMSHP
  268. X      CALL CRAMDMP(17H HEAVILY DAMAGED.)
  269. X      ICAS=10.0+20.0*RANF(0)
  270. X      CALL CRAM(19H***SICKBAY REPORTS )`20
  271. X      CALL CRAMI(ICAS,0)
  272. X      CALL CRAMDMP(12H CASUALTIES.)`20
  273. X      CASUAL=CASUAL+ICAS
  274. X      DO 10 L=1,NDEVICE`20
  275. X      IF(DAMAGE(L) .LT. 0) GO TO 10`20
  276. X      IF(L.EQ.14) GOTO 10  `20
  277. X      EXTRADM=(10.0*TYPE*RANF(0)+1.0)*DAMFAC
  278. X      DAMAGE(L)=DAMAGE(L)+TIME+EXTRADM
  279. X 10   CONTINUE
  280. X`09ISUBDAM=1
  281. X      SHLDUP=0
  282. X      IF(REMKL.NE.0) CALL DREPORT    `20
  283. X      IF(REMKL .EQ. 0) CALL FINISH(1)`20
  284. X      RETURN
  285. X      END`20
  286. $ CALL UNPACK TRRAM.FOR;1 723538988
  287. $ create 'f'
  288. X`09 REAL FUNCTION RANF(DUMMY)
  289. XC
  290. XC`0925-APR-79
  291. XC`09CHANGED TO USE THE ONE-ARGUMENT VERSION OF THE RAN FUNCTION,
  292. XC`09AND TO USE AN INTEGER*4 SEED.
  293. XC
  294. X`09INTEGER*4 IRAN,ISEED
  295. XC*
  296. X`09RANF=RAN(IRAN)
  297. X`09RETURN
  298. XC*
  299. X`09ENTRY RANSET(ISEED)
  300. XC*
  301. X`09IRAN=ISEED
  302. X`09RETURN
  303. X`09END
  304. $ CALL UNPACK TRRANF.FOR;1 152251633
  305. $ create 'f'
  306. X      SUBROUTINE SCAN`20
  307. XC
  308. XC`095-APR-79
  309. XC`09ACCEPT LOWER CASE ALPHA INPUT AND CONVERT TO UPPER CASE.
  310. XC`09CALL GETOUT WHEN A CTRL/Z IS TYPED TO ERASE THE SCREEN
  311. XC`09AND EXIT.
  312. XC
  313. X`09INCLUDE 'TREKCOM/NOLIST'
  314. X`09REAL*8 AITEM,TITEM
  315. X`09COMMON/SCANBF/KEY,AITEM
  316. X`09EQUIVALENCE (FNUM,AITEM)
  317. X`09BYTE LINE(80),KHAR,ITEM(8)
  318. X`09EQUIVALENCE (TITEM,ITEM)
  319. X      DATA ICH,KHAR,ITEM/80,1H ,0,0,0,0,0,0,0,0/
  320. XC--------READ IN NEW LINE IF NEEDED.
  321. X4     IF(ICH.LT.80) GO TO 5
  322. X`09READ (1,100,ERR=700,END=900) ICHAR,LINE
  323. X100`09FORMAT (Q,80A1)
  324. X`09LINE(ICHAR+1)=0
  325. X 5    AITEM=0
  326. X      ASSIGN 10 TO IRET
  327. X 10   IF(KHAR .EQ. 1H ) GO TO 500
  328. XC--------IF END-OF LINE IS HIT, RETURN WITH AITEM=0.
  329. X`09IF(ICHAR.EQ.0) GOTO 15
  330. X`09IF(KHAR.NE.0) GOTO 20
  331. X 15   KEY=IHEOL
  332. X      GO TO 600
  333. XC--------IF INPUT IS NOT NUMERIC, PACK ALL CHARACTERS TOGETHER UP TO
  334. XC        A BLANK OR END-OF-LINE, AND RETURN IN 10H FORMAT.
  335. X 20   IF(KHAR.EQ.1H+ .OR. KHAR.EQ.1H- .OR. KHAR.EQ.1H.) GO TO 40
  336. X      IF(KHAR.GE.1H0 .AND. KHAR.LE.1H9) GO TO 40
  337. X      IF(KHAR .LT. 1HA .OR. KHAR .GT. 1HZ) GO TO 500
  338. X      KEY=IHALPHA
  339. X      ASSIGN 25 TO IRET
  340. X      ICHX=1
  341. X      GO TO 26
  342. X25`09ICHX=ICHX+1
  343. X      IF(KHAR .EQ. 0 .OR. KHAR .EQ. 1H ) GOTO 30`20
  344. X26      IF(ICHX .LE. 8) ITEM(ICHX)=KHAR
  345. X`09GOTO 500
  346. X30`09IF(ICHX.GT.8) GOTO 35
  347. X`09DO 34 IT=ICHX,8
  348. X34`09ITEM(IT)=1H`20
  349. X35`09AITEM=TITEM
  350. X`09RETURN
  351. XC--------INPUT IS NUMERIC.  RETURN AS A REAL NUMBER.
  352. X 40   KEY=IHREAL
  353. X      SIGN=1.0
  354. X      KEXPON=0
  355. X`09KFRACT=0
  356. X      ASSIGN 50 TO IRET
  357. X      IF(KHAR .EQ. 1H+) GO TO 500
  358. X      IF(KHAR .NE. 1H-) GO TO 50
  359. X      SIGN=-1.0
  360. X      GO TO 500
  361. X 50   IF(KHAR.LT.1H0 .OR. KHAR.GT.1H9) GO TO 60
  362. X`09IT=KHAR
  363. X      FNUM=10.0*FNUM+FLOAT(IT-"60)
  364. X      KEXPON=KEXPON-KFRACT
  365. X      GO TO 500
  366. X 60   IF(KHAR .NE. 1H.) GO TO 70
  367. X      IF(KFRACT .NE. 0) GO TO 15
  368. X      KFRACT=1
  369. X      GO TO 500
  370. X 70   AITEM=SIGN*AITEM*10.0**KEXPON
  371. X      RETURN
  372. XC--------ROUTINE TO  RETURN NEXT CHARACTER IN 1H FORMAT
  373. XC--------LOWER CASE IS CONVERTED TO UPPER CASE
  374. X 500  ICH=ICH+1
  375. X      IF(ICH .LE. 80) GO TO 510
  376. X      ICH=1
  377. X 510  KHAR=LINE(ICH)
  378. X      IF(KHAR .GE. "140) KHAR=KHAR-"40
  379. X      GO TO IRET
  380. XC*
  381. X      ENTRY CHEW
  382. XC--------DISCARD REMAINDER OF LAST LINE READ IN.
  383. X600   ICH=80
  384. X      KHAR=1H`20
  385. X      RETURN
  386. X700`09CALL PROUT(15HTTY READ ERROR.,15)
  387. X`09GO TO 4
  388. X900`09CONTINUE
  389. X`09CALL GETOUT
  390. X      END`20
  391. $ CALL UNPACK TRSCAN.FOR;1 1316950373
  392. $ create 'f'
  393. X      SUBROUTINE SCOM`20
  394. X`09INCLUDE 'TREKCOM/NOLIST'
  395. X`09LOGICAL*1 LOC
  396. X      DIMENSION BDIST(5)
  397. X      EQUIVALENCE (CRACKS(5),LOCSUP),(LOC,LOCSUP)
  398. XC--------COMPUTE DISTANCES TO STARBASES.
  399. X      IF(REMBASE .LE. 0) GO TO 60`20
  400. X`09BDMAX=0.
  401. X`09SX=ISX
  402. X`09SY=ISY
  403. X      DO 1 I=1,REMBASE
  404. X`09BQX=BASEQX(I)
  405. X`09BQY=BASEQY(I)
  406. X 1    BDIST(I) = SQRT((BQX-SX)**2 +(BQY-SY)**2)`20
  407. XC--------SORT INTO NEAREST FIRST ORDER.`20
  408. X      IF(REMBASE.LE.1) GO TO 4
  409. X      MINUS1 = REMBASE -1`20
  410. X 2    ISWITCH = 0`20
  411. X      DO 3 I=1, MINUS1
  412. X      IF(BDIST(I) .LE. BDIST(I+1)) GO TO 3
  413. X`09T=BDIST(I)
  414. X`09BDIST(I)=BDIST(I+1)
  415. X`09BDIST(I+1)=T
  416. X      ISWITCH = 1`20
  417. X 3    CONTINUE
  418. X      IF(ISWITCH.NE.0) GO TO 2
  419. XC--------LOOK FOR NEAREST BASE WITHOUT A COMMANDER, NO ENTERPRISE, AND
  420. XC--------WITHOUT TOO MANY KLINGONS, AND NOT ALREADY UNDER ATTACK.`20
  421. X4`09IFINDIT=0
  422. X`09IWHICHB=0
  423. X      DO 8 I=1, REMBASE`20
  424. X`09IBQX=BASEQX(I)
  425. X`09IBQY=BASEQY(I)
  426. X      IF((IBQX .EQ. QUADX) .AND. (IBQY .EQ. QUADY)) GO TO 8`20
  427. X      IF((IBQX .EQ. BATX) .AND. (IBQY .EQ. BATY)) GO TO 8`20
  428. X      NUM=GALAXY(IBQX,IBQY)`20
  429. X      IF(NUM .GT. 899) GO TO 8
  430. X      IF(REMCOM .LE. 0) GO TO 6`20
  431. X      DO 5 J=1, REMCOM
  432. X 5    IF((IBQX .EQ. CX(J)) .AND. (IBQY .EQ. CY(J))) GO TO 7`20
  433. X6`09IFINDIT=1
  434. X`09IWHICHB=I
  435. X`09GO TO 10
  436. X 7    IF (IFINDIT .EQ. 2) GO TO 8`20
  437. X`09IFINDIT=2
  438. X`09IWHICHB=I
  439. X 8    CONTINUE
  440. X      IF(IFINDIT  .EQ. 0) RETURN
  441. X`09IBQX=BASEQX(IWHICHB)
  442. X`09IBQY=BASEQY(IWHICHB)
  443. XC--------DECIDE HOW TO MOVE TOWARD BASE.
  444. X 10   IDELTX = IBQX -ISX
  445. X      IF(IDELTX .GT. 1) IDELTX = 1
  446. X      IF(IDELTX .LT. -1) IDELTX=-1
  447. X      IDELTY=IBQY-ISY`20
  448. X      IF(IDELTY .GT. 1) IDELTY = 1
  449. X      IF(IDELTY .LT. -1) IDELTY=-1
  450. XC--------ATTEMPT FIRST TO MOVE IN BOTH X AND Y DIRECTION.`20
  451. X`09IQX=ISX+IDELTX
  452. X`09IQY=ISY+IDELTY
  453. X      ASSIGN 23 TO IWHERE`20
  454. XC--------MAKE CHECKS ON POSSIBLE DESTINATION QUADRANT.
  455. X 15   IF((IQX .EQ. QUADX) .AND. (IQY .EQ. QUADY)) GO TO IWHERE
  456. X      IF((IQX.LT.1).OR.(IQX.GT.8).OR.(IQY.LT.1).OR.(IQY.GT.8))
  457. X     +  GO TO IWHERE
  458. +-+-+-+-+-+-+-+-  END  OF PART 14 +-+-+-+-+-+-+-+-
  459.