c c EDO.FOR c c Enterprise does things c Includes modules: c DO_PHASOR c DO_TORP c DO_TRACTOR c DO_REPULSOR c DO_TRANS c DO_SHUTTLE c GET_FINDINGS c c -------------------------------------------------------------------------- c SUBROUTINE do_phasor IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' c INTEGER*4 n c c Compute phasor hit on enemy. c DO n = 1,n_kl ! On Klingons IF (kl_ctl(n) .EQ. Them)CALL phasor_hit('K',n,xqe,yqe, 1 pdeg,ph_dir,ph_nrg,tech(TECH_phasor)) ENDDO DO n = 1,n_rom ! On Romulans IF (rom_ctl(n) .EQ. Them)CALL phasor_hit('R',n,xqe,yqe, 1 pdeg,ph_dir,ph_nrg,tech(TECH_phasor)) ENDDO c c Reduce energy and check level. c energy = energy - ph_nrg CALL check_energy CALL fizzle(ph_nrg,phasor) ph_nrg = 0.0 c RETURN END c c -------------------------------------------------------------------------- c SUBROUTINE do_torp IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 crctb c INTEGER*4 i,n REAL*4 vpx,vpy,x,y,delta c c Enterprise launch torpedo(s). Check damage that may have occurred in interim. c IF (damage(torpedo) .GT. 0.0) THEN itorp = itorp + itfire WRITE (ttyout,1) itfire itfire = 0 RETURN ENDIF c c Check if room in torps array. c DO n = 1,MIN(itfire,INT(tech(TECH_trate))) ! Number launched per starminute IF (n_torp .GE. M_torp) RETURN n_torp = n_torp + 1 c c Get initial launch velocity and insert into array. c vpx = COSD(pdeg) * psp + COSD(tbrg(1)) * tech(TECH_tvel) vpy = SIND(pdeg) * psp + SIND(tbrg(1)) * tech(TECH_tvel) torp_x(n_torp) = xqe torp_y(n_torp) = yqe CALL getbrg(delta,0.0,vpx,0.0,vpy,x,y) torp_pdeg(n_torp) = Crctb(delta) torp_psp(n_torp) = SQRT(vpx*vpx + vpy*vpy) torp_ctl(n_torp) = You c c Move down array to be fired by one and print message. c itfire = itfire - 1 itorp = itorp - 1 DO i = 1,itfire tbrg(i) = tbrg(i+1) ENDDO WRITE (ttyout,2) CALL fizzle(1.0,torpedo) ENDDO c RETURN 1 FORMAT (' Damage control: cancelled',i3,' torpedo launchings.') 2 FORMAT (' Torpedo away!') END c c -------------------------------------------------------------------------- c SUBROUTINE do_tractor IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 dist,req c c Tractor beam to pull in Ghostship. c dist = (gh_x(1) - xqe) ** 2 + (gh_y(1) - yqe) ** 2 req = dist * 100.0 / (4.0 * tech(TECH_pulse)) IF (energy .LE. req) THEN ! Insufficient energy..cancel WRITE (ttyout,1) ELSE energy = energy - req WRITE (ttyout,2) gh_energy(1),gh_torp(1) energy = energy + gh_energy(1) itorp = itorp + gh_torp(1) troops = troops + gh_troops(1) CALL delete('G',1) CALL fizzle(req,pulsar) ENDIF c tr_nrg = .FALSE. RETURN c 1 FORMAT (' Insufficient energy for tractor beams...command cancelled.') 2 FORMAT (' Docked with ghostship. Transferring',f7.1,' energy and', 1 i3,' torpedos.') END c c -------------------------------------------------------------------------- c SUBROUTINE do_repulsor IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c LOGICAL*4 klq c REAL*4 dist,moved,delta,x,y c c c Get distance to Klingon and calculate how much we'll push him. c dist = (kl_x(rp_tgt) - xqe) ** 2 + (kl_y(rp_tgt) - yqe) ** 2 moved = rp_nrg * (0.0267 * tech(TECH_pulse)) / dist c c Get bearing and from that calculate displacement. Then move him. c There is also some velocity reduction involved. c CALL getbrg(delta,xqe,kl_x(rp_tgt),yqe,kl_y(rp_tgt),x,y) x = COSD(delta) * moved y = SIND(delta) * moved kl_x(rp_tgt) = kl_x(rp_tgt) + x kl_y(rp_tgt) = kl_y(rp_tgt) + y kl_psp(rp_tgt) = MAX(0.0,kl_psp(rp_tgt) - ABS(moved) / 8.0) c c Check for pushing him out of quadrant. Print message showing motion. c IF (.NOT. klq(rp_tgt)) THEN ! KLQ will print its own messages WRITE (ttyout,1)rp_tgt,kl_x(rp_tgt),kl_y(rp_tgt), 1 kl_psp(rp_tgt),kl_pdeg(rp_tgt) ENDIF c c Subtract energy used (check for out of energy condition), and return. c energy = energy - rp_nrg CALL check_energy CALL fizzle(rp_nrg,pulsar) rp_nrg = 0.0 RETURN c 1 FORMAT (' K',i1,' moved to ',f5.2,',',f5.2,' speed:',f5.2, 1 ' Bearing:',f5.0) END c c -------------------------------------------------------------------------- c SUBROUTINE do_trans IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c LOGICAL*4 Check_loc REAL*4 Range c INTEGER*4 beamed REAL*4 x1,x2,y1,y2 c c Check to see if damaged in the interim. c IF (damage(Transporter) .GT. 0.0) THEN WRITE (ttyout,3) trans_ntrp = 0 RETURN ENDIF c c Must check if from & to objects still there each turn. c IF (.NOT. Check_loc(trans_to,trans_to_num,x1,y1) .OR. 1.NOT. Check_loc(trans_from,trans_from_num,x2,y2)) THEN WRITE (ttyout,1) trans_ntrp = 0 RETURN ENDIF c c Take troops out of "FROM" object. Note that there may be fewer than c desired (perhaps due to fighting or damage). c IF (trans_from .EQ. 'E') THEN ! From Enterprise beamed = MIN(IFIX(tech(TECH_trans)),troops,trans_ntrp) troops = troops - beamed ELSEIF (trans_from .EQ. 'B') THEN ! From starbase beamed = MIN(IFIX(tech(TECH_trans)),base_troops(1), 1 trans_ntrp) base_troops(1) = base_troops(1) - beamed ELSEIF (trans_from .EQ. 'G') THEN ! From ghostship beamed = MIN(IFIX(tech(TECH_trans)),gh_troops(1), 1 trans_ntrp) gh_troops(1) = gh_troops(1) - beamed ELSEIF (trans_from .EQ. 'K') THEN ! From Klingon beamed = MIN(IFIX(tech(TECH_trans)), 1 kl_troops(trans_from_num),trans_ntrp) kl_troops(trans_from_num) = kl_troops(trans_from_num) - beamed ELSEIF (trans_from .EQ. 'R') THEN ! From Romulan beamed = MIN(IFIX(tech(TECH_trans)), 1 rom_troops(trans_from_num),trans_ntrp) rom_troops(trans_from_num) = rom_troops(trans_from_num) - beamed ENDIF IF (beamed .EQ. 0) GOTO 400 c c Add troops to "TO" object. No limits on how many may reside there. c IF (trans_to .EQ. 'E') THEN ! to Enterprise troops = troops + beamed ELSEIF (trans_to .EQ. 'B') THEN ! to starbase base_troops(1) = base_troops(1) + beamed ELSEIF (trans_to .EQ. 'G') THEN ! to ghostship IF (gh_troops(1) .EQ. 0) THEN WRITE (ttyout,4) IF (gh_damage(1) .GT. 0.0) WRITE (ttyout,5) NINT(gh_damage(1)) ENDIF gh_troops(1) = gh_troops(1) + beamed gh_ctl(1) = You ELSEIF (trans_to .EQ. 'K') THEN ! to Klingon kl_troops(trans_to_num) = kl_troops(trans_to_num) + beamed ELSEIF (trans_to .EQ. 'R') THEN ! to Romulan rom_troops(trans_to_num) = rom_troops(trans_to_num) + beamed ENDIF c c If all men have been transferred, or none were transferred this turn, c then stop the beaming. c 400 trans_ntrp = trans_ntrp - beamed IF (trans_ntrp .EQ. 0 .OR. beamed .EQ. 0) THEN WRITE (ttyout,2) trans_ntrp = 0 ENDIF c c Costs energy to transport. c energy = energy - beamed * tech(TECH_trnrg) * 0.5 * 1 SQRT(Range(x1,x2,y1,y2)) CALL check_energy CALL fizzle(FLOAT(beamed),transporter) c RETURN c 1 FORMAT (' Transport cancelled due to destruction of source/target.') 2 FORMAT (' Transport complete.') 3 FORMAT (' Transport cancelled because of damage.') 4 FORMAT (' Ghostship captured.') 5 FORMAT (' Approximately',i3,' units damage to ghostship.') END c c -------------------------------------------------------------------------- c SUBROUTINE do_shuttle IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c LOGICAL*4 Check_loc INTEGER*4 Fnr REAL*4 Rnd,Range c REAL*4 x,y,delta,xto,yto,prob,x1,y1 INTEGER*4 n c c Branch on desired shuttlecraft activity. c IF (shuttle .EQ. SH_home) THEN ! Head for home CALL getbrg(delta,shtl_x,xqe,shtl_y,yqe,x,y) c c Shuttlecraft heading for another planet. c ELSEIF (shuttle .EQ. SH_to_planet) THEN IF (shtl_x .EQ. 0.0) THEN ! Now on Enterprise WRITE (ttyout,1) shtl_x = xqe shtl_y = yqe ENDIF CALL getbrg(delta,shtl_x,planet_x(shtl_path(1)),shtl_y, 1 planet_y(shtl_path(1)),x,y) c c Shuttlecraft on a planet. Exploration occurs. c ELSEIF (shuttle .EQ. SH_at_planet) THEN IF (Fnr(1,3) .EQ. 1) THEN ! Done, go to next target IF (shtl_path(1) .EQ. 0) THEN ! Heading home WRITE (ttyout,3) 'completed' xto = xqe yto = yqe shuttle = SH_home ELSE ! Check for existence WRITE (ttyout,4) shtl_planet,shtl_path(1) IF (.NOT. check_loc('P',shtl_path(1),x1,y1)) THEN WRITE (ttyout,2) WRITE (ttyout,3) 'aborted' xto = xqe yto = yqe shuttle = SH_home ELSE xto = planet_x(shtl_path(1)) yto = planet_y(shtl_path(1)) shuttle = SH_to_planet ENDIF ENDIF CALL getbrg(delta,shtl_x,xto,shtl_y,yto,x,y) c c Record what was found (not told until S returns to E). c prob = Rnd() DO n = 1,M_find+1 IF (prob .LE. 0.4 + (n-1) * 0.6 / (M_find + 1)) THEN findings(shtl_planet) = n - 1 GOTO 100 ENDIF ENDDO findings(shtl_planet) = 0 c c Print warning message if something very dangerous found. c 100 IF ((findings(shtl_planet) .EQ. FIND_eforms .AND. 1 Fnr(1,2) .EQ. 1) .OR. Fnr(1,100) .EQ. 1) THEN ! Print warning message WRITE (ttyout,5) ENDIF ELSE ! Stays there and explores some more RETURN ENDIF ELSEIF (shuttle .EQ. SH_destruct) THEN ! Destroy it shuttle = SH_lost WRITE (ttyout,6) RETURN ENDIF c c Now move shuttle if it's moving and see if it reaches its destination. c shtl_x = shtl_x + COSD(delta) * 0.25 shtl_y = shtl_y + SIND(delta) * 0.25 IF (shuttle .EQ. SH_to_planet) THEN ! Check of reached next planet IF (Range(shtl_x,planet_x(shtl_path(1)),shtl_y, 1 planet_y(shtl_path(1))) .LT. 1.0) THEN ! Arrived shtl_planet = shtl_path(1) WRITE (ttyout,7) shtl_planet c c Miniscule probability of shuttle being lost in space or on planet. c IF (Fnr(1,50) .EQ. 13) THEN WRITE (ttyout,8) shuttle = SH_lost RETURN ENDIF DO n = 2,9 ! Move array down shtl_path(n-1) = shtl_path(n) ENDDO shtl_path(9) = 0 c c If already been here, then go to next planet, or home if done. c IF (explored(shtl_planet)) THEN WRITE (ttyout,9) IF (shtl_path(1) .GT. 0) THEN shuttle = SH_to_planet ELSE shuttle = SH_home ENDIF ELSE explored(shtl_planet) = .TRUE. shuttle = SH_at_planet ENDIF ENDIF ELSE ! It's on its way home IF (Range(shtl_x,xqe,shtl_y,yqe) .LT. 1.0) THEN ! onboard CALL get_findings shuttle = SH_onboard shtl_x = 0.0 shtl_y = 0.0 RETURN ENDIF ENDIF c RETURN c 1 FORMAT (' Shuttlecraft launched.') 2 FORMAT (' Destination no longer exists.') 3 FORMAT (' Mission ',a,' - heading back to Enterprise.') 4 FORMAT (' Shuttlecraft leaving planet',i2,' heading for planet',i2) 5 FORMAT (' Emergency transmission from shuttlecraft -'/ 1 ' Mayday, mayday; Captain, we %a&&@rE brgn tkc.f. al^e@!s...'/ 2 /' Transmissions ceased.') 6 FORMAT (' Shuttlecraft destroyed.') 7 FORMAT (' Shuttlecraft landing on planet',i2,'...exploring.') 8 FORMAT (' Shuttlecraft lost or destroyed...') 9 FORMAT (' We''ve been here before, dummy!') END c c -------------------------------------------------------------------------- c SUBROUTINE get_findings IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 Rnd,Nermal,Nermalu LOGICAL*4 Get_int INTEGER*4 Fnr c c Print shuttlecraft findings upon return to Enterprise. c INTEGER*4 n,m,nfound,found REAL*4 t,x,Decr,Incr c Decr(x) = (1.0 - MAX(0.02,Rnd()*x)) Incr(x) = (1.0 + MAX(0.02,Rnd()*x)) c c Count number of goodies found. c nfound = n_planet DO n = 1,n_planet found = findings(n) IF (found .EQ. FIND_disease .AND. .NOT. disease) THEN WRITE (ttyout,1) n disease = .TRUE. virulency = Nermal(30.0,5.0) p_cure = MAX(0.05,Rnd() * .18) ELSEIF (found .EQ. FIND_warp) THEN WRITE (ttyout,2) item_name(warp_drive) tech(TECH_warp) = tech(TECH_warp) * Incr(0.2) ELSEIF (found .EQ. FIND_energy) THEN WRITE (ttyout,2) item_name(warp_drive) tech(TECH_energy) = tech(TECH_energy) * Incr(0.25) ELSEIF (found .EQ. FIND_phasor) THEN WRITE (ttyout,2) item_name(phasor) tech(TECH_phasor) = tech(TECH_phasor) * Incr(0.22) ELSEIF (found .EQ. FIND_tvel) THEN WRITE (ttyout,2) item_name(torpedo) tech(TECH_tvel) = tech(TECH_tvel) + (0.9 - 1 tech(TECH_tvel)) / 5.0 ELSEIF (found .EQ. FIND_trate) THEN WRITE (ttyout,2) item_name(torpedo) tech(TECH_trate) = tech(TECH_trate) + 1 ELSEIF (found .EQ. FIND_pulse) THEN WRITE (ttyout,2) item_name(pulsar) tech(TECH_pulse) = tech(TECH_pulse) * Incr(0.2) ELSEIF (found .EQ. FIND_att_kl) THEN WRITE (ttyout,3) n tech(TECH_att_kl) = tech(TECH_att_kl) * Incr(0.1) ELSEIF (found .EQ. FIND_att_rom) THEN WRITE (ttyout,3) n tech(TECH_att_rom) = tech(TECH_att_rom) * Incr(0.25) ELSEIF (found .EQ. FIND_trans) THEN WRITE (ttyout,2) item_name(transporter) tech(TECH_trans) = tech(TECH_trans) + Fnr(1,12) ELSEIF (found .EQ. FIND_trnrg) THEN WRITE (ttyout,2) item_name(transporter) tech(TECH_trnrg) = tech(TECH_trnrg) * Decr(0.2) ELSEIF (found .EQ. FIND_commun) THEN WRITE (ttyout,2) item_name(communications) tech(TECH_commun) = tech(TECH_commun) * Decr(0.125) ELSEIF (found .EQ. FIND_shields) THEN WRITE (ttyout,4) n tech(TECH_shield) = tech(TECH_shield) * Incr(0.2) ELSEIF (found .EQ. FIND_aliens .AND. .NOT. aliens) THEN alien_rate = MAX(20.0,Nermalu(50.0,0.5)) t = energy / alien_rate WRITE (ttyout,5) n,alien_rate,t aliens = .TRUE. alien_planet = n ELSEIF (found .EQ. FIND_eforms .AND. .NOT. eforms) THEN WRITE (ttyout,6) eforms = .TRUE. ELSEIF (found .EQ. FIND_androids) THEN m = Fnr(5,40) troops = troops + m WRITE (ttyout,7) n,m ELSEIF (found .EQ. FIND_tribbles .AND. .NOT. tribbles) THEN WRITE (ttyout,8) tribbles = .TRUE. autopilot = .FALSE. autoprint = .FALSE. ELSEIF (found .EQ. FIND_gromblies .AND. .NOT. gromblies) THEN gromblies = .TRUE. IF (Fnr(1,2) .EQ. 1) THEN ! Will trade T for E WRITE (ttyout,9) n 100 IF (Get_int('Amount of energy',m,'GROMBLIES E_T')) THEN IF (m .GE. energy .OR. m .LT. 0) THEN WRITE (ttyout,10) energy GOTO 100 ENDIF energy = energy - m IF (Fnr(1,10) .LE. 3 .AND. m .GT. 0) THEN WRITE (ttyout,11) ELSE itorp = itorp + m / 250 ENDIF ENDIF ELSE ! They trade E for T WRITE (ttyout,12) n 200 IF (Get_int('Number to trade',m,'GROMBLIES T_E')) THEN IF (m .GT. itorp .OR. m .LT. 0) THEN WRITE (ttyout,13) itorp GOTO 200 ENDIF itorp = itorp - m IF (Fnr(1,10) .LE. 3 .AND. m .GT. 0) THEN WRITE (ttyout,11) ELSE energy = energy + m * 250 ENDIF ENDIF ENDIF ELSE ! Found nothing nfound = nfound - 1 ENDIF findings(n) = 0 ENDDO c IF (nfound .EQ. 0) THEN WRITE (ttyout,14) ENDIF c RETURN 1 FORMAT (' Virulent disease brought back from planet',i2) 2 FORMAT (' Found technological improvement to ',a) 3 FORMAT (' Found advanced weapons for troops on planet',i2) 4 FORMAT (' Improved shielding method discovered on planet',i2) 5 FORMAT (' Alien beings on planet',i2,' draining energy banks ', 1 'at rate of',f5.0,' per starminute!'/' Zero energy levels ', 2 ' in',-2pf7.2,' stardates!!!') 6 FORMAT (' Semi-sentient energy forms invading warp drive engines!'/ 1 ' Enterprise under alien control!!') 7 FORMAT (' Friendly robot civilization on planet',i2,' gives you', 1 i4,' android troops') 8 FORMAT (' Microtribbles multiplying out of control in computer ', 1 'memory banks'/ 2 ' Computer unusable until they are exterminated.') 9 FORMAT (' Gromblies on planet',i2,' offer torpedos in exchange ', 1 'for energy.') 10 FORMAT (' You only have',f7.1,' energy available.') 11 FORMAT (' The Gromblies have just welched on their end of the deal.') 12 FORMAT (' Gromblies on planet',i2,' offer energy in exchange for ', 1 ' torpedos.') 13 FORMAT (' You only have',i3,' torpedos available.') 14 FORMAT (' Nothing of the remotest interest was found this time out.') END c