SUBROUTINE FASORS
C** FIRE PHASORS
       COMMON /GENDTA/SDATE,COND(2),KLING,TMLEFT,ITORPS,ENERGY,SHELDS
       COMMON /QUAD/IQAD(8,8),IQX,IQY
       COMMON /SECT/SEC(64,64),ISX,ISY,ISX8,ISY8
       COMMON /DAMAGS/IRPARS(8,2),IRAND,IRATE,IDMGD,TSTRT,GTIME
       COMMON /EKLNG/EKNG(6),IKS
       DIMENSION IKX(6),IKY(6),DIST(6)
       DATA AKNG/'<K>'/
       IF(IRPARS(2,1) .LE. 0)GO TO 10
       TYPE *,' '
       TYPE *,' PHASORS DAMAGED - UNABLE TO FIRE'
       GO TO 999
 10    IEX = ISX
       IEY = ISY
       IK = 0
       DO 20 I=1,6
       DIST(I) = 0.0
 20    CONTINUE
C** SEARCH TOP ROW
       IDELX = 1
       IDELY = 1
 100   ISTRT = IEX - IDELX
       ISTOP = IEX + IDELX
       IRETN = 1
       IXX = IEX - IDELX
       IAX = IXX
       IF(IXX .LE. 0)IXX = 64 - IXX
       IYY = IEY + IDELY
       IAY = IYY
       IF(IYY .GT. 64)IYY = IYY - 64
       GO TO 150
C** SEARCH BOTTOM ROW
 110   IRETN = 2
       IXX = IEX - IDELX
       IAX = IXX
       IF(IXX .LE. 0)IXX = 64 + IXX
       IYY = IEY - IDELY
       IAY = IYY
       IF(IYY .LE. 0)IYY = 64 + IYY
       GO TO 150
C** SEARCH LEFT LINE
 120   IRETN = 3
       IXX = IEX - IDELX
       IAX = IXX
       IF(IXX .LE. 0)IXX = 64 + IXX
       IYY = IEY - IDELY + 1
       IAY = IYY
       IF(IYY .LE. 0)IYY = 64 + IYY
       ISTRT = IEY - IDELY + 1
       ISTOP = IEY + IDELY - 1
       GO TO 150
C** SEARCH RIGHT LINE
 130   IRETN = 4
       IXX = IEX + IDELX
       IAX = IXX
       IF(IXX .GT. 64)IXX = IXX - 64
       IYY = IEY - IDELY + 1
       IAY = IYY
       IF(IYY .LE. 0)IYY = 64 + IYY
       GO TO 150
C** ACTUAL SEARCH
 150   DO 160 I=ISTRT,ISTOP
       IF(SEC(IXX,IYY) .EQ. '(R)')TYPE 1006
 1006  FORMAT(' PHASORS CANNOT LOCK ONTO ROMULAN SHIP',
     *      /,' BECAUSE OF THEIR CLOAKING DEVICE.')
       IF(SEC(IXX,IYY) .NE. AKNG)GO TO 156
       IK = IK + 1
       IF(IK .LE. 6)GO TO 155
       TYPE *,' '
       TYPE *,' MORE THAN 6 KLINGONS WITHIN RANGE'
       TYPE *,' PHASORS WILL FIRE AT NEAREST 6'
       GO TO 800
 155   IKX(IK) = IXX
       IKY(IK) = IYY
       XTEMP = IEX - IAX
       YTEMP = IEY - IAY
       DIST(IK) = SQRT(XTEMP**2 + YTEMP**2)
C**     TYPE 9001,IAX,IAY,IXX,IYY,DIST(IK)
C9001   FORMAT(' IAX,IAY,IXX,IYY,DIST =',4I5,F10.3)
 156   IF(IRETN .GT. 2)GO TO 157
       IAX = IAX + 1
       IXX = IXX + 1
       IF(IXX .GT. 64)IXX = IXX - 64
       GO TO 160
 157   IAY = IAY + 1
       IYY = IYY + 1
       IF(IYY .GT. 64)IYY = IYY - 64
 160   CONTINUE
       GO TO (110,120,130,170)IRETN
       TYPE *,' '
       TYPE *,' *** PHASOR RETURN ERROR ***'
 170   IDELX = IDELX +1
       IDELY = IDELY +1
       IF(IDELX .LE. 3 .AND. IDELY .LE. 3)GO TO 100
 800   IKS = IK
       IF(IKS .EQ. 0)GO TO 991
       TYPE 1001,IKS
 1001  FORMAT(' PHASOR CONTROL',
     * /,' NUMBER KLINGONS IN RANGE  =',I5)
       TYPE 1002,(DIST(I),EKNG(I),I=1,IK)
 1002  FORMAT(' AT RANGE AND ENERGY:',/,6(2X,F10.3,2X,F10.3,/))
 850   TYPE 1003
 1003  FORMAT($' INPUT UNITS TO FIRE> ')
       ACCEPT *,UNITS
       IF(UNITS .EQ. 0.0)GO TO 999
       ENERGY = ENERGY - UNITS
       UNITS = UNITS/IK
C** FIRE
       DO 600 I=1,IKS
       IF(EKNG(I) .EQ. 0.0)GO TO 600
       EKNG(I) = EKNG(I) - UNITS*(6.5 - DIST(I) + 1.0)/6.5
       TEMP = EKNG(I)
       IF(TEMP .GT. 0.0)GO TO 650
       EKNG(I) = 0.0
       IK = IK -1
       KLING = KLING -1
       SEC(IKX(I),IKY(I)) = '    '
 650   K1 = (IKX(I) - 1)/8
       K2 = (IKY(I) - 1)/8
       K3 = IKX(I) -  K1*8
       K4 = IKY(I) - K2*8
       TYPE 1005,K3,K4,EKNG(I)
 1005  FORMAT(' KLINGON AT (',I3,',',I3,') UNITS LEFT =',F10.3)
       IF(EKNG(I) .GT. 0.0)GO TO 600
       K1 = K1 +1
       K2 = K2 +1
       IQAD(K1,K2) = IQAD(K1,K2) - 100
 600   CONTINUE
C** PACK BACK ENERGY ARRAY
       J = 1
       DO 610 I=1,6
       IF(EKNG(I) .EQ. 0.0)GO TO 610
       EKNG(J) = EKNG(I)
       J = J + 1
 610   CONTINUE
       GO TO 999
 991   TYPE *,'NO KLINGONS IN PHASOR RANGE'
 999   CALL RFIRE
       RETURN
       END