SUBROUTINE SETCRS
C**  SET COURSE
       COMMON/GENDTA/SDATE,COND(2),KLING,TMLEFT,ITORP,ENERGY,SHELDS
       COMMON /QUAD/IQAD(8,8),IQX,IQY
       COMMON /GALAX/IGALX(8,8)
       COMMON /SECT/SEC(64,64),ISX,ISY,ISX8,ISY8
        COMMON /DAMAGS/IRPARS(10,2),IRAND,IRATE,IDMGD,TSTRT,GTIME
       COMMON /RMULN/IRMLN,IRMX,IRMY,IHTMS
       COMMON /EKLNG/EKNG(6),IKS
 10    TYPE 1001
 1001  FORMAT($,'  INPUT COURSE> ')
       ACCEPT *,COURSE
C** ASSUME SUCCESSFUL MOVE
       COND(1) = 'GREE'
       COND(2) = 'N   '
       IF(COURSE .EQ. 0.0)GO TO 999
       IF(COURSE .LT. 1.0 .OR. COURSE .GE. 9.0) GO TO 10
 20    TYPE 1002
 1002  FORMAT($,'  WARP FACTOR? ')
       ACCEPT *,WARP
       IF(IRPARS(6,1) .LE. 0)GO TO 23
       IF(WARP .LE. .2)GO TO 23
       TYPE *,'**WARP ENGINES DAMAGED; MAXIMUM INPULSE POWER**'
       TYPE *,'**    WARP = .2    **'
       GO TO 20
 23    IF(WARP .EQ. 0.0)GO TO 999
C** UPDATE KLINGON ENERGY ARRAY FOR KLINGONS IN NEW POSITION
       DO 24 I=1,6
       ENRGY = RANDOM(IRAND)*350. + 1.0
       EKNG(I) = AMAX1(ENRGY,100.0)
 24    CONTINUE
       IF(WARP .LT. 0.0 .OR. WARP .GT. 8.0)GO TO 20
C** PENALIZE FOR MAOVEMNTS TO STARBASES
       IWRP = 1
       IF(WARP .GE. 2.0)IWRP = 2.5
       IF(WARP .GE. 4.0)IWRP = 4.5
       ENERGY = ENERGY - WARP*8.0*IWRP
       ANGLE = (COURSE - 1)/8 *2*3.14159
       COSANG = COS(ANGLE)
       SINANG = SIN(ANGLE)
       WFACT = WARP*8.
       SEC(ISX,ISY) = '    '
       XX = ISX
       YY = ISY
       DIST = 0.0
       KX = 0
       KY = 0
50    CONTINUE
       XX = XX + COSANG * WFACT
       YY = YY - SINANG * WFACT
       IX = XX +.5
       IY = YY +.5
       IF(IX .GT. 64)IX = IX - 64
       IF(IY .GT. 64)IY = IY - 64
       IF(IX .LE. 0) IX=64+ IX
       IF(IY .LE. 0)IY=64 +IY
       ISX = IX
       ISY = IY
 125   ISX8=(ISX-1)/8
       ISY8=(ISY-1)/8
       IQX =(ISX-1)/8 +1
       IQY =(ISY-1)/8 +1
C** UPDATE GALACTIC RECORD IF WE HAVE NOT BEEN HERE BEFORE
       IF(IGALX(IQX,IQY) .LT. 100)IGALX(IQX,IQY) = IQAD(IQX,IQY)
       ISX8 = ISX -ISX8*8
       ISY8 = ISY -ISY8*8
       IF(SEC(ISX,ISY) .EQ. '    ')GO TO 201
       COND(1) = 'END '
       IF(SEC(ISX,ISY) .EQ. '<K>')GO TO 210
       IF(SEC(ISX,ISY) .EQ. '(R)')COND(2) = 'ROMU'
       IF(SEC(ISX,ISY) .EQ. ':B:')COND(2) = 'BASE'
       IF(SEC(ISX,ISY) .EQ. ' * ')COND(2) = 'STAR'
       GO TO 999
 210   COND(2) = 'KLIN'
       KLING = KLING -1
       GO TO 999
C** CHECK FOR UNIDENTIFIED SHIP
 201    IF(ISX .NE. IRMX .OR. ISY .NE. IRMY)GO TO 400
        TYPE *,' ENTERPRISE GOES ON RED ALERT DUE TO NEAR COLLISION'
        TYPE *,' WITH AN UNIDENTIFIED FLYING OBJECT. ENSIGN CHEKOV'
        TYPE *,' WILL TAKE EVASIVE MANEUVERS TO AVIOD THE OBJECT.'
        TYPE *,' AS A RESULT OF THE NEAR COLLISION, THE ENTERPRISE'
        TYPE *,' HAS EXPIERENCED SEVERE DAMAGE.'
        COND(1) = 'RED '
        COND(2) = '    '
        SHELDS  = SHELDS * 0.35
        IRPARS(6,1) = 120.
        IRPARS(6,2) = SECNDS(TSTRT) + 120.
        ISX = ISX - 1
        GO TO 125
 400   SEC(ISX,ISY) = '-E-'
C** CHECK FOR DOCKED CONDITION
       IX = ISX-1
       IF(IX .EQ. 0)IX=64
       IY = ISY -1
       IF(IY .EQ. 0)IY =64
       ISAVE = IY
       DO 300 I=1,3
       IY = ISAVE
       DO 295 J=1,3
        IF(SEC(IX,IY) .NE. ':B:')GO TO 297
       COND(1) = 'DOCK'
       COND(2) = 'ED  '
        CALL DOCKED
       GO TO 900
 297   IY=IY+1
       IF(IY .GT. 64)IY = IY - 64
 295   CONTINUE
       IX = IX+1
       IF(IX .GT. 64)IX = IX -64
 300   CONTINUE
C** CHECK FOR RETURN FIRE
 900   CALL RFIRE
 999   RETURN
       END