c c MOVES.FOR c c Movement Routines c Includes modules: c EPMOVE c EACCEL c LEAVE_GAL c KMOVE c RMOVE c KRMOVE c OMOVE c XDSUM c c --------------------------------------------------------------------------- c SUBROUTINE epmove IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 dx,dy INTEGER*4 old_ice,old_jce c c Enterprise movement routine. Check if accelerating (& if able). c If not, compute drift motion. c IF (eforms .OR. ((psp .NE. dsp .OR. pdeg .NE. ddeg) .AND. 1(damage(Warp_drive) .LE. 0.0 .OR. damage(Impulse) .LE. 0.0))) THEN CALL eaccel(dx,dy) ! Enterprise must accelerate ELSE dx = COSD(pdeg) * psp dy = SIND(pdeg) * psp ENDIF c c Change position; see if left quadrant (or galaxy). c xqe = xqe + dx yqe = yqe + dy old_ice = ice old_jce = jce IF (xqe .GE. 10.5) THEN ice = ice + 1 xqe = xqe - 10.0 ELSEIF (xqe .LT. 0.5) THEN ice = ice - 1 xqe = xqe + 10.0 ENDIF IF (yqe .GE. 10.5) THEN jce = jce + 1 yqe = yqe - 10.0 ELSEIF (yqe .LT. 0.5) THEN jce = jce - 1 yqe = yqe + 10.0 ENDIF c c If left quadrant, then disremember things. If left galaxy - bad news. c IF (ice .NE. old_ice .OR. jce .NE. old_jce) THEN newquad = .TRUE. WRITE (ttyout,1)old_ice,old_jce CALL ereset(2) IF (ice .GT. nquad .OR. ice .LT. 1 .OR. jce .GT. nquad 1 .OR. jce .LT. 1) THEN CALL leave_gal(old_ice,old_jce,0) ELSE WRITE (ttyout,2) ice,jce ENDIF ENDIF c RETURN 1 FORMAT (' Leaving Quad ',i2,',',i2) 2 FORMAT (' Entering Quad ',i2,',',i2) END c c --------------------------------------------------------------------------- c SUBROUTINE eaccel(dx,dy) IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 dx,dy,Crctb,Rnd INTEGER*4 Fnr c REAL*4 delta,delv,dvel,acce,dchg,prspd,vvel,eused c c E accelerates. Determine which drive to use and hence how much energy. c IF (damage(Warp_drive) .GT. 0.0) THEN ! Use Impulse power IF (dsp .GT. 0.55 .AND. dsp .GT. psp) THEN dsp = MIN(dsp,MAX(psp,0.55)) WRITE (ttyout,5) dsp ENDIF acce = 5000. dchg = 15.0 dvel = 0.1 ELSE acce = 400. / tech(TECH_energy) dchg = 45.0 * tech(TECH_warp) dvel = 0.25 * tech(TECH_warp) IF (emerg_power) THEN dvel = dvel * 2.0 dchg = dchg * 2.0 acce = acce * 1.5 ENDIF ENDIF c c Compute how much of acceleration desired can occur this starminute. c prspd = psp dchg = MIN(dchg,180.0) delta = 0.0 delv = 0.0 c c Possibility of alien control. c IF (eforms .AND. (Fnr(1,10) .LE. 3 .OR. dsp .EQ. 0.0)) THEN ! They change course ddeg = Fnr(1,360) dsp = Rnd() + 1.0 ENDIF c c See if desired bearing/speed attained. c IF (ddeg .NE. pdeg) THEN ! Bearing change delta = ddeg - pdeg IF (ABS(delta) .GT. 180.0) delta = delta - SIGN(360.0,delta) IF (ABS(delta) .GT. dchg) delta = SIGN(dchg,delta) pdeg = Crctb(pdeg+delta) IF (pdeg .EQ. ddeg) WRITE (ttyout,2) ddeg ENDIF IF (dsp .NE. psp) THEN ! Speed change delv = SIGN(dvel,dsp-psp) IF (ABS(dsp-psp) .LT. ABS(delv)) delv = dsp-psp psp = psp + delv IF (psp .EQ. dsp) WRITE (ttyout,1) dsp c c If leaving hyperspace, only then generate the new quadrant entered. c IF (psp .LT. 1.0 .AND. prspd .GE. 1.0) THEN WRITE (ttyout,4) IF (newquad) CALL gen_quad IF (damage(SR_scan) .LE. 0.0) THEN CALL fill_quad CALL disp_srs ENDIF ENDIF c c Print message if entering hyperspace. c IF (psp .GE. 1.0 .AND. prspd .LT. 1.0) THEN WRITE (ttyout,3) CALL ereset(1) ENDIF ENDIF c c Calculate energy required. 2 Components: 1 for change in speed, other c for change in bearing at average speed of the maneuver. Note that at c sublight speeds, the energy usage is constant regardless of speed, c whereas at warp 1 and above, it is proportional to speed squared. c dy = ABS(delta) dx = SIND(dy) IF (dy .GT. 90.0) dx = dx + SIND(dy-90.0) IF (psp .GT. 1.0) THEN vvel = psp * psp ELSE vvel = 1.0 ENDIF eused = delv * delv * vvel * acce * 1 SQRT(dvel/tech(TECH_warp)) eused = eused + vvel * dx * acce * dvel * dvel * 1 SQRT(dvel/tech(TECH_warp)) c c Remove energy and check for being out of it. c energy = energy - eused CALL check_energy c c Emergency power can cause damage 5% of times used. c IF (emerg_power .AND. Fnr(1,20) .EQ. 13) THEN ! Damaged CALL dmg(3,psp) ENDIF CALL fizzle(eused,Warp_drive) c c Calculate position change. c dx = COSD(pdeg - delta / 2.0) * (psp - delv / 2.0) dy = SIND(pdeg - delta / 2.0) * (psp - delv / 2.0) c RETURN 1 FORMAT (' Desired speed of',f8.2,' attained.') 2 FORMAT (' Desired bearing of',f8.2,' attained.') 3 FORMAT (' Entering hyperspace!!') 4 FORMAT (' Leaving hyperspace!!!') 5 FORMAT (' Warp drive damaged...desired speed reduced to',f6.2) END c c --------------------------------------------------------------------------- c SUBROUTINE leave_gal(old_ice,old_jce,hole_num) IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c INTEGER*4 old_ice,old_jce,hole_num,Fnr REAL*4 Nermalu c REAL*4 save_defl,time c c Galactic limits exceeded (or black hole entered). Damage Enterprise c and put in new random quadrant. c WRITE (ttyout,1) save_defl = shields CALL dmg(2,SQRT(psp*500.0)) shields = save_defl c c May gain (1/3) or lose (2/3) time. c time = Nermalu(1.5,0.33) IF (Fnr(1,3) .EQ. 1) time = -time time_left = time_left + time last_refit = last_refit + time IF (time_left .LE. 0.0) CALL finished(Outta_time) c c Third argument determines if it was due to a black hole ( > 0). If so, c then can get exit quadrant from setup parameters, otherwise this is c randomly determined. c IF (hole_num .GT. 0) THEN ice = x_hole_to(hole_num,old_ice,old_jce) jce = y_hole_to(hole_num,old_ice,old_jce) ELSE 100 ice = Fnr(1,nquad) jce = Fnr(1,nquad) IF (ice .EQ. old_ice .AND. jce .EQ. old_jce) GOTO 100 ENDIF c c Set up random position (integral coordinates). c CALL ereset(2) xqe = Fnr(1,10) yqe = Fnr(1,10) WRITE (ttyout,2) ice,jce CALL gen_quad IF (damage(SR_scan) .LE. 0.0) THEN CALL fill_quad CALL disp_srs ENDIF c RETURN 1 FORMAT(' Galactic limits exceeded! Space-time warp!!') 2 FORMAT (' Reappearing in quadrant',i3,',',i3) END c c --------------------------------------------------------------------------- c SUBROUTINE kmove(xk,yk,n) IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' c REAL*4 xk,yk,Crctb INTEGER*4 n c REAL*4 xvec,yvec,zvec c c Compute best course. ZVEC returned as speed reduction due to proximity of c dangerous objects. XVEC and YVEC are location it is heading for (safest c direction possible). c CALL krmove(xk,yk,'K',n,xvec,yvec,zvec) kl_dsp(n) = MAX(0.05,0.5-zvec) CALL getbrg(kl_ddeg(n),0.0,xvec,0.0,yvec,xk,yk) c c If close to desired bearing, can double speed. c IF (Crctb(kl_pdeg(n)-kl_ddeg(n)) .LE. 30.0) 1 kl_dsp(n) = MIN(0.5,kl_dsp(n)*2.0) c RETURN END c c --------------------------------------------------------------------------- c SUBROUTINE rmove(n,p_rmove) IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' INCLUDE 'IO.FTN/Nolist' c REAL*4 Rnd,p_rmove LOGICAL*4 Check_objs INTEGER*4 n,Howmany_inq c INTEGER*4 ix,iy,jx,jy,kce,lce,newx,newy REAL dx,dy,xvec,yvec,zvec c c Check for movement. Romulans move on integer coordinates only, in jumps. c At level 1, they do not move. c IF (level .NE. Beginner .AND. Rnd() .LT. p_rmove) THEN ix = rom_x(n) iy = rom_y(n) c c Check for escape possibility (heavily damaged or relatively few left). c IF (rom_hits(n) .GE. 320.0 .OR. mrom/rleft .GE. 7) THEN c c Move towards nearest edge. c dx = ix - 5.5 dy = iy - 5.5 jx = SIGN(1.0,dx) jy = SIGN(1.0,dy) dx = ABS(dx) dy = ABS(dy) IF (dx .GT. dy+1.0) jy = 0 IF (dy .GT. dx+1.0) jx = 0 ELSE c c Call krmove to determine optimum point. c CALL krmove(rom_x(n),rom_y(n),'R',n,xvec,yvec,zvec) jx = SIGN(1.0,xvec) jy = SIGN(1.0,yvec) IF (ABS(xvec) .GE. 2.0*ABS(yvec)) jy = 0 IF (ABS(yvec) .GE. 2.0*ABS(xvec)) jx = 0 ENDIF c c Check for occupying same square as non-moving objects (R,B,*,hole). c newx = ix + jx newy = iy + jy IF (newx .GE. 1 .AND. newx .LE. 10 .AND. newy .GE. 1 1 .AND. newy .LE. 10 .AND. (jx .NE. 0 .OR. jy .NE. 0)) THEN IF (Check_objs(newx,newy)) THEN rom_x(n) = newx rom_y(n) = newy ENDIF RETURN ELSE ! Leaving quadrant (will not leave galaxy) IF (newx .LT. 1) THEN jx = -1 ELSEIF (newx .GT. 10) THEN jx = 1 ELSE jx = 0 ENDIF IF (newy .LT. 1) THEN jy = -1 ELSEIF (newy .GT. 10) THEN jy = 1 ELSE jy = 0 ENDIF IF (jx .EQ. 0 .AND. jy .EQ. 0) RETURN kce = ice + jx lce = jce + jy IF (kce .LT. 1 .OR. kce .GT. nquad .OR. lce .LT. 1 1 .OR. lce .GT. nquad) RETURN c c Make sure that quadrant doesn't already have 9 Romulans. c IF (Howmany_inq(kce,lce,Romulans) + clkloc(kce,lce) 1 .GE. 9) RETURN WRITE (ttyout,1) n,kce,lce IF (n .GT. n_rom-n_inv_rom) THEN clkloc(ice,jce) = clkloc(ice,jce) - 1 clkloc(kce,lce) = clkloc(kce,lce) + 1 ELSE galaxy(ice,jce) = galaxy(ice,jce) - Romulans galaxy(kce,lce) = galaxy(kce,lce) + Romulans ENDIF rom_ctl(n) = Destroyed ENDIF ENDIF c RETURN 1 FORMAT (' R',i1,' escaped to quadrant',i3,',',i3) END c c --------------------------------------------------------------------------- c SUBROUTINE krmove(x,y,type,n,xvec,yvec,zvec) IMPLICIT NONE INCLUDE 'ST84.FTN/Nolist' c REAL*4 Crctb,x,y,xvec,yvec,zvec INTEGER*4 n CHARACTER type*1 c REAL*4 dx,dy,vpx,vpy,avoid,delta,dist,bearing,d1,d2,d3,p0,p1,p2 REAL*4 xa,ya,vx,vy INTEGER*4 m,ix,iy c c K/R collision avoidance routine. Computes an optimum point (xvec,yvec) c to head for by calculating the weighted sum for objects in the quadrant c him times the distance from him, then returns that point as the direction c to head for. c In the case of Klingons, a speed reduction factor (zvec) is also calculated c which increases as the K passes close to many moving objects, so as to c minimize a collision when changing course and turning in an arc. c If there are enemy troops on board fighting, then they will not try c so hard to avoid collisions. Klingons also have a tendency to crowd the c Enterprise. c Every object has an avoidance factor that is arbitrarily set to increase c or decrease the relative avoidance of that object by the enemy. c xvec = 0.0 yvec = 0.0 zvec = 0.0 IF (type .EQ. 'K') CALL xdsum(xqe,yqe,x,y,-25.0,xvec,yvec,zvec) c c Avoid (other) Klingons. c DO m = 1,n_kl IF ((m .NE. n .OR. type .NE. 'K') .AND. 1 kl_ctl(m) .NE. Destroyed) THEN IF (kl_ctl(m) .EQ. Them) THEN avoid = 10.0 ELSE avoid = 7.0 ENDIF CALL xdsum(kl_x(m),kl_y(m),x,y,avoid,xvec,yvec,zvec) ENDIF ENDDO c c Avoid (other) Romulans. c DO m = 1,n_rom IF ((m .NE. n .OR. type .NE. 'R') .AND. 1 rom_ctl(m) .NE. Destroyed) THEN IF (rom_ctl(m) .EQ. Them) THEN avoid = 11.0 ELSE avoid = 8.0 ENDIF CALL xdsum(rom_x(m),rom_y(m),x,y,avoid,xvec,yvec,zvec) ENDIF ENDDO c c Avoid planets (Klingons only). c IF (type .EQ. 'K') THEN DO m = 1,n_planet IF (planet_ctl(m) .NE. Destroyed) THEN CALL xdsum(planet_x(m),planet_y(m),x,y,15.0,xvec,yvec,zvec) ENDIF ENDDO c c Avoid starbases. c DO m = 1,n_base IF (base_ctl(m) .NE. Destroyed) THEN CALL xdsum(base_x(m),base_y(m),x,y,2.0,xvec,yvec,zvec) ENDIF ENDDO ENDIF c c Avoid edges, unless trying to escape, then head for them. c Must sum components separately. Will not leave galaxy. c IF (type .EQ. 'K' .AND. (kl_hits(n) .GE. 240.0 1 .OR. nkl/kleft .GE. 7)) THEN avoid = -15.0 ELSE avoid = 22.0 ENDIF vpx = SIGN(MIN(10.5-x,x-0.5),5.5-x) vpy = SIGN(MIN(10.5-y,y-0.5),5.5-y) ix = SIGN(1.0,-vpx) + ice iy = SIGN(1.0,-vpy) + jce IF (( .NOT. (ix .GE. 1 .AND. ix .LE. nquad .AND. iy .GE. 1 1 .AND. iy .LE. nquad)) .OR. avoid .GT. 0.0) THEN dx = ABS(vpx) ** 3.5 dy = ABS(vpy) ** 3.5 xa = vpx / dx * avoid ya = vpy / dy * avoid xvec = xvec + xa yvec = yvec + ya IF (type .EQ. 'K' .AND. avoid .GT. 0.0) THEN zvec = zvec + 1.11 / (dx + dy) ENDIF ENDIF c c Avoid ghostships. c DO m = 1,n_gh IF (gh_ctl(m) .NE. Destroyed) THEN CALL xdsum(gh_x(m),gh_y(m),x,y,3.0,xvec,yvec,zvec) ENDIF ENDDO c c Avoid (enemy) torpedos. Computes possible path of torp and avoids heading c into that path. At level 1, Klingons don't dodge torps. c IF (type .EQ. 'K' .AND. level .EQ. Beginner) GOTO 500 DO m = 1,n_torp IF (torp_ctl(m) .EQ. You) THEN CALL getbrg(delta,x,torp_x(m),y,torp_y(m),vpx,vpy) dist = SQRT(vpx*vpx+vpy*vpy) bearing = torp_pdeg(m) vpx = Crctb(delta + 90.0) vpy = Crctb(delta - 90.0) c c Exclude torps not headed this way. c IF ((vpx .GE. vpy .OR. (bearing .LT. vpy .AND. bearing 1 .GT. vpx)) .AND. (bearing .LT. vpy .OR. bearing .GT. 2 vpx)) THEN c c "D1" is correction factor for torpedo frame of reference. c "D2" is bearing + correction for reference frame. c "D3" is direction from me to path of T in my frame of reference. c "P0" is cross-product of absolute distance and perpendicular distance c for estimating closeness function. c "P1" and "P2" are estimated x and y coordinates of the closest point c of approach between me and this torpedo. c d1 = Crctb(360.0 - bearing) delta = Crctb(delta + 180.0) d2 = Crctb(delta + d1) d3 = Crctb(bearing + SIGN(90.0,d2-180.0)) p0 = MAX(0.1,SQRT(ABS(SIND(d2)*dist)*dist)) p1 = x + COSD(d3) * p0 p2 = y + SIND(d3) * p0 CALL xdsum(p1,p2,x,y,4.0,xvec,yvec,zvec,xvec,yvec,zvec) ENDIF ENDIF ENDDO c c Set all factors to 1.0 if none were set. c 500 IF (xvec .EQ. 0.0 .AND. yvec .EQ. 0.0) THEN xvec = 1.0 yvec = 1.0 zvec = 1.0 ENDIF c RETURN END c c --------------------------------------------------------------------------- c SUBROUTINE omove(x,y,sp,deg,d_sp,d_deg,m_sp,m_deg) IMPLICIT NONE c REAL*4 Crctb,x,y,sp,deg,d_sp,d_deg,m_sp,m_deg c REAL*4 delta,delv,dx,dy c c Common movement routine for many objects. c delv = MIN(m_sp,ABS(d_sp-sp)) ! Speed change IF (d_sp .LT. sp) delv = -delv ! Deccelaration delta = d_deg - deg ! Bearing change IF (ABS(delta) .GT. 180.0) delta = delta - SIGN(360.,delta) IF (ABS(delta) .GT. m_deg) delta = SIGN(m_deg,delta) c c Compute incremental change in position. c dx = COSD(deg + delta / 2.0) * (sp + delv / 2.0) dy = SIND(deg + delta / 2.0) * (sp + delv / 2.0) c c Compute new speed, bearing, and position. c sp = sp + delv deg = Crctb(deg + delta) x = x + dx y = y + dy c RETURN END c c --------------------------------------------------------------------------- c SUBROUTINE xdsum(x,y,xkr,ykr,avoid,xvec,yvec,zvec) IMPLICIT NONE c REAL*4 x,y,xkr,ykr,avoid,xvec,yvec,zvec c REAL*4 vpx,vpy,dist c c Add in this objects nearness to weighted sum of avoidance factors. c vpx = xkr - x vpy = ykr - y dist = ABS(vpx) ** 3.5 + ABS(vpy) ** 3.5 xvec = xvec + vpx / dist * avoid yvec = yvec + vpy / dist * avoid zvec = zvec + 1.11 / dist c RETURN END