SUBROUTINE PROCM c include 'tcommon.for' %include tcommon.for character*8 DEFLEC,moldnm DATA DEFLEC/'DFLECTRS'/ C ...PROCESS ACTIVITIES PREVIOUSLY SCHEDULED AND QUEUE THEM FOR C ...ACTION. PCT(A,B)=(B-A)/A*100. 1 IF(ICM.EQ.99)GO TO 5000 IF(ICM.LE.0)GO TO 5000 CALL CHEKDG(ICM,IR) IF(IR.EQ.1)GO TO 998 GO TO (3001,3002,3003,3004,3005,3006,4000,3008,3009,3010,3011,3012 1 ,3013,3014,3015,3016,3017,3018,3019,3020,3031,3033),ICM GO TO 5000 C ...MUST CHECK DAMAGE INDIVDUALLY HERE AS TWO TYPES OF MOTION C ...INVOLVED. 3001 IF(IDMG(1).EQ.0)GO TO 30013 IF(XDSP.LE.PSP.OR.XDSP.LE.SIM)GO TO 30011 WRITE(6,30019)NAMD(1) 30019 FORMAT(1X,A10, ' DAMAGED') WRITE(6,30119)PSP 30119 FORMAT(' DESIRED SPEED SET TO ',F5.3) DSP=PSP DDEG=XDDEG C ...CHECK DAMAGE TO IMPULSE DRIVE. 30011 IF(IDMG(2).EQ.0)GO TO 30013 WRITE(6,30019)NAMD(2) DDEG=PDEG DSP=PSP WRITE(6,30119)DSP GO TO 998 30013 DDEG=XDDEG DSP=XDSP IF(ITRUCE.EQ.0)GO TO 4000 WRITE(6,33333) 33333 FORMAT(' TRUCE BROKEN...NORMAL ACTIVITIES RESUME') ITRUCE=0 GO TO 4000 C ...SHORT RANGE SCAN. STOP TIMER FOR PRINT TIME. 3002 IF(PSP.GE.1.)GO TO 994 IHERE=1 CALL SCAN CALL QTIME(JTIME) ISTART=JTIME GO TO 4000 C ...LONG RANGE SCAN. STOP TIMER FOR PRINTING. 3003 I=ICE-1 J=ICE+1 K=JCE-1 L=JCE+1 IF(I.LT.1)I=1 IF(J.GT.NQUAD)J=NQUAD IF(K.LT.1)K=1 IF(L.GT.NQUAD)L=NQUAD DO 30032 M=I,J DO 30032 N=K,L IGAL(M,N)=JGAL(M,N) 30032 CONTINUE C CALL CPAGE WRITE(6,30033)ICE,JCE 30033 FORMAT(' LONG RANGE SENSOR SCAN AROUND QUADRANT ',I2,',',I2) WRITE(6,30034) 30034 FORMAT(' ---------------------------') N=L 30035 N=N-1 IF(N.LT.K)GO TO 30037 WRITE(6,30036)(JGAL(M,N),M=I,J) 30036 FORMAT(3(2X,I4,' :',2X)) WRITE(6,30034) GO TO 30035 30037 CALL QTIME(JTIME) ISTART=JTIME GO TO 4000 C ...PHASER FIRING SETUP. 3004 IF(PSP.GE.1.)GO TO 994 EFP(1)=NTSTPS+NMEN/MEN EFP(2)=IDIR EFP(3)=PNRGY IF(ITRUCE.EQ.0)GO TO 4000 WRITE(6,33333) ITRUCE=0 GO TO 4000 C ...TORPS SETUP FIRING AREA. 3005 IF(PSP.GE.1.)GO TO 994 M=ITFIRE+1 ITFIRE=ITFIRE+MTORPS ITORP=ITORP-MTORPS NC=1 NF=1 DO 30052 J=M,ITFIRE C ...SLOWDOWN DUE TO CREW REDUCTION BELOW 50% NORMAL. EFT(J,1)=NTSTPS+NF+NMEN/MEN-1 EFT(J,2)=DTORP(J-M+1) NC=NC+1 IF(NC.LE.IETOFT)GO TO 30052 NC=1 NF=NF+1 30052 CONTINUE IF(ITRUCE.EQ.0)GO TO 4000 ITRUCE=0 WRITE(6,33333) GO TO 4000 C ...PULSIVE BEAMS. 3006 IF(PSP.GE.1.)GO TO 994 ETR(1)=NTSTPS+NMEN/MEN ETR(2)=IBTYP IF(IBTYP.EQ.1)GO TO 4000 ETR(3)=PNRGY IF(ITRUCE.EQ.0)GO TO 4000 ITRUCE=0 WRITE(6,33333) GO TO 4000 C ...STATUS REPORT. 3008 XNRGY=ENERGY-PNRGY WRITE(6,30081)XTIME,XNRGY,ITORP,PSP,PDEG,DEFL,ISHNUM 30081 FORMAT(' STATUS REPORT'/' DAYS LEFT: ',F6.2,6X,'ENERGY: ',F8.2,6X, 1 'TORPS: ',I3/' SPEED: ',F6.3,6X,'BEARING: ',F4.0,' SHIELDS 1: ',F7.1,' SHUTTLECRAFT ON BOARD: ',I1) C ...ALSO PRINT TECHNOLOGICAL IMPROVEMENTS. IF(DVWP.EQ.DVWP0)GO TO 2 IXRAT=PCT(DVWP0,DVWP) WRITE(6,702)NAMD(1),IXRAT 702 FORMAT(' ',A10,' ACCELERATION INCREASED ',I3,'%') 2 IF(EWRP.EQ.EWRP0)GO TO 3 IXRAT=-PCT(EWRP0,EWRP) WRITE(6,703)NAMD(1),IXRAT 703 FORMAT(1X,A10,' EFFICIENCY INCREASED BY ',I3,'%') 3 IF(DISTPE.EQ.DISTP0)GO TO 4 IXRAT=PCT(DISTP0,DISTPE) WRITE(6,704)NAMD(3),IXRAT 704 FORMAT(1X,A10,' EFFECTIVENESS INCREASED BY ',I3,'%') 4 IF(ETVEL.EQ.ETVEL0)GO TO 5 WRITE(6,705)NAMD(4),ETVEL 705 FORMAT(1X,A10,' VELOCITY INCREASED TO ',F5.3) 5 IF(IETOFT.EQ.IETOF0)GO TO 6 WRITE(6,706)NAMD(4),IETOFT 706 FORMAT(1X,A10,' RATE NOW ',I2,' PER STAR-MINUTE') 6 IF(DISTGT.EQ.DISTG0)GO TO 7 IXRAT=PCT(DISTG0,DISTGT) WRITE(6,704)NAMD(5),IXRAT 7 IF(CODDS.EQ.CODDS0)GO TO 8 IXRAT=PCT(CODDS0,CODDS) WRITE(6,708)IXRAT 708 FORMAT(' TROOP FIGHTING EFFECTIVENESS VS KLINGONS INCREASED BY ',I 13,'%') 8 IF(EODDS.EQ.EODDS0)GO TO 9 IXRAT=PCT(EODDS0,EODDS) WRITE(6,709)IXRAT 709 FORMAT(' TROOP FIGHTING EFFECTIVENESS VS ROMULANS INCREASED BY ',I 13,'%') 9 IF(IDAMRP.EQ.IDAMR0)GO TO 14 IXRAT=PCT(FLOAT(IDAMR0),FLOAT(IDAMRP)) WRITE(6,706) NAMD(8),IDAMRP 14 IF(TRNRG0.EQ.TRNRGY)GO TO 10 IXRAT=-PCT(TRNRG0,TRNRGY) WRITE(6,703)NAMD(8),IXRAT 10 IF(PJAM.EQ.PJAM0)GO TO 11 IXRAT=-PCT(PJAM0,PJAM) WRITE(6,710)NAMD(9),IXRAT 710 FORMAT(1X,A10,' INTERCEPTION PROBABILITY REDUCED BY ',I3,'%') 11 IF(SHLDF.EQ.SHLDF0)GO TO 12 IXRAT=PCT(SHLDF0,SHLDF) WRITE(6,6112)IXRAT 6112 FORMAT(' SHIELDS IMPROVED BY ',I3,'%') 12 IF(ICLOAK.GE.0)GO TO 13 SDAYS=-ICLOAK/100. WRITE(6,7101)SDAYS 7101 FORMAT(' CLOAKING DEVICE AVAILABLE FOR ',F5.2,' STARDAYS') 13 CALL QTIME(ISTART) GO TO 4000 C ...DAMAGE REPORT. 3009 IF(JDAM.NE.2)GO TO 30999 WRITE(6,30991) 30991 FORMAT(' REPAIR CREWS REASSIGNED') 30999 TOTAL=0. N=0 DO 30992 J=1,10 IF(JDAM.EQ.2)IPROB1(J)=IPROB2(J) IF(IDMG(J).EQ.0)GO TO 30992 TOTAL=TOTAL+IPROB1(J) N=N+1 30992 IPROB2(J)=0 IF(JDAM.EQ.2)GO TO 4000 WRITE(6,30091) 30091 FORMAT(' DAMAGE REPORT') JJ=0 IF(N.EQ.0)GO TO 37379 DO 30092 J=1,10 IF(IDMG(J).EQ.0)GO TO 30092 JJ=1 SDAYS=IDMG(J)/100. *FLOAT(NMEN)/FLOAT(MEN) ASSN=((100.-TOTAL)/N+IPROB1(J))/100. JSSN=ASSN*100. DAYS=1.E7 IF(ASSN.LE.0.)GO TO 39899 DAYS=SDAYS/ASSN/ERPRRT 39899 WRITE(6,30093)NAMD(J),DAYS,JSSN 30093 FORMAT(1X,A8,2X,'-',F5.2,' STARDAYS',' (',I3,'%)') 30092 CONTINUE 37379 IF(JJ.EQ.1)GO TO 30094 WRITE(6,30095) 30095 FORMAT(' NO DAMAGE') C ...CHECK MEN KILLED. 30094 IF(MEN.EQ.NMEN)GO TO 30099 KMEN=NMEN-MEN WRITE(6,30096)KMEN,MEN 30096 FORMAT(1X,I4,' CREW KILLED - ',I4,' LEFT') 30099 ITM=0 DO 30098 J=1,20 30098 ITM=ITM+ITRMEN(J) IF(ITM.EQ.IFGHTM)GO TO 4000 KMEN=IFGHTM-ITM IF(KMEN.LT.0)KMEN=0 WRITE(6,30097)KMEN,ITM 30097 FORMAT(1X,I4,' TROOPS KILLED - ',I4,' LEFT') GO TO 4000 C ...EVASIVE MANEUVERS. 3010 IF(PSP.GE.1.0)GO TO 994 DSP=EVMSP IF(IDMG(1).EQ.0.OR.IDMG(2).EQ.0)GO TO 30111 IF(IDMG(1).EQ.0)GO TO 30104 WRITE(6,30019)NAMD(1) IF(IDMG(2).EQ.0)GO TO 998 30104 WRITE(6,30019)NAMD(2) WRITE(6,30119)SIM NBASES=0 GO TO 998 30111 IF(IEVDR.EQ.1)GO TO 30101 IF(IEVDR.EQ.3)GO TO 30103 PDEG=PDEG-90. IF(PDEG.LT.0.)PDEG=PDEG+360. X=EVENU IF(IDMG(1).NE.0)X=X*2.5 GO TO 30102 30101 PDEG=PDEG+90. X=EVENU IF(IDMG(1).NE.0)X=X*2.5 30105 IF(PDEG.GE.360.)PDEG=PDEG-360. GO TO 30102 30103 PDEG=PDEG+180. X=EVENU*1.5 IF(IDMG(1).NE.0)X=X*2.5 GO TO 30105 30102 ENERGY=ENERGY-X IF(ENERGY.LE.0.)CALL RATING(2) DDEG=PDEG IF(ITRUCE.EQ.0)GO TO 4000 ITRUCE=0 WRITE(6,33333) GO TO 4000 C ...EMERGENCY EVASIVE MANEUVERS.MUST USE WARP DRIVE. 3011 IF(PSP.GE.1.)GO TO 994 DSP=EEVMSP NBASES=99 IF(IDMG(1).EQ.0)GO TO 30111 GO TO 30104 C ...RAISE DEFLECTORS. 3012 IF(ADDFL.LT.-DEFL)GO TO 3013 DEFL=DEFL+ADDFL ENERGY=ENERGY-ADDFL IF(ENERGY.LE.0.)CALL RATING(2) GO TO 4000 C ...DROP DEFLECTORS. 3013 ENERGY=ENERGY+DEFL WRITE(6,30131) 30131 FORMAT(' DROP DEFLECTORS') DEFL=0. GO TO 4000 C ...PROPOSE TRUCE. 3014 IF(PSP.GE.1.)GO TO 994 WRITE(6,30141) 30141 FORMAT(' TRUCE PROPOSED') X=0. Y=0. JJ=0 IF(KLNGNS.EQ.0)GO TO 30143 DO 30142 J=1,KLNGNS IF(XKL(J,1).EQ.0.)GO TO 30142 IF(ICNTL(J+1).EQ.1)GO TO 30142 IF(ITRMEN(J+1).NE.0)GO TO 30146 JJ=1 X=X+XKL(J,7) Y=Y+XKLHIT 30142 CONTINUE 30143 IF(NROM.EQ.0)GO TO 30145 DO 30144 J=1,NROM IF(XROM(J,1).EQ.0.)GO TO 30144 IF(ICNTL(J+10).EQ.1)GO TO 30144 IF(ITRMEN(J+10).NE.0)GO TO 30146 JJ=1 X=X+XROM(J,3) Y=Y+XRMHIT 30144 CONTINUE 30145 IF(JJ.EQ.0)GO TO 30146 C ...ACCEPTED ONLY IF ALL ENEMY AT LEAST 75% DAMAGED. IF(RAN(IZZ).GT.(X/Y)/THITR)GO TO 30146 WRITE(6,30147) 30147 FORMAT(' TRUCE ACCEPTED') ITRUCE=1 GO TO 4000 30146 WRITE(6,30148) 30148 FORMAT(' TRUCE OFFER DECLINED') GO TO 4000 C ...SHORT RANGE TRACK. 3015 IF(PSP.GE.1.)GO TO 994 WRITE(6,30151) 30151 FORMAT(' SHORT RANGE TRACK') IF(KLNGNS.EQ.0)GO TO 30154 DO 30152 J=1,KLNGNS IF(XKL(J,1).EQ.0.)GO TO 30152 WRITE(6,30157)LETR(3),J,(XKL(J,K),K=1,4) 30157 FORMAT(1X,A1,I1,' AT ',F4.1,',',F4.1,' SPEED: ',F6.3,' BEARING: ', 1F5.0) 30153 FORMAT(1X,A1,1X,' AT ',F4.1,',',F4.1,' SPEED: ',F6.3,' BEARING: ', 1F5.0) 30152 CONTINUE 30154 IF(NTORPS.EQ.0)GO TO 30156 DO 30155 J=1,NTORPS IF(TORPS(J,1).EQ.0.)GO TO 30155 WRITE(6,30153)LETR(7),(TORPS(J,K),K=1,4) 30155 CONTINUE 30156 WRITE(6,30153)LETR(2),XQE,YQE,PSP,PDEG IF(ISTSH.NE.99)GO TO 30174 WRITE(6,30153)LETR(12),SHX,SHY,SHVX,SHDEG 30174 IF(IGH.EQ.0)GO TO 30159 WRITE(6,30153)LETR(5),(GHOST(K),K=1,2),(GHOST(L),L=4,5) 30159 CALL QTIME(ISTART) GO TO 4000 C ...GALACTIC MAP DISPLAY. C 3016 CALL CPAGE 3016 WRITE(6,30163) 30163 FORMAT(' GALACTIC UPDATE') I=NQUAD+1 30161 I=I-1 IF(I.LT.1)GO TO 30166 DO 30164 J=1,NQUAD IF(I.EQ.JCE.AND.J.EQ.ICE)GO TO 30165 IPQ(J,I)=LETR(9) GO TO 30164 30165 IPQ(J,I)=LETR(2) 30164 CONTINUE WRITE(6,30162)(IGAL(J,I),IPQ(J,I),J=1,NQUAD) 30162 FORMAT(1X,10(I4,A1,2X)) GO TO 30161 30166 CALL QTIME(ISTART) c##### GO TO 4000 C ....PLOT BEARING. 3017 WRITE(6,30171) 30171 FORMAT(' PLOT BEARING') IF(PSP.GE.1.)GO TO 30176 IF(NSTARS.EQ.0)GO TO 30175 DO 30172 J=1,NSTARS IF(STARS(J,1).EQ.0.)GO TO 30172 CALL GETBRG(DELTA,XQE,STARS(J,1),YQE,STARS(J,2),VPX,VPY) VSX=SQRT(VPX*VPX+VPY*VPY) WRITE(6,30173)LETR(1),J,STARS(J,1),STARS(J,2),DELTA,VSX ,RAD(J) 30173 FORMAT(1X,A1,I1,' AT ',F4.1,',',F4.1,' BEARING: ',F4.0,' DISTANCE: 1 ',F4.1,' RADIUS: ',F3.2) 30172 CONTINUE 30175 IF(IBASE.EQ.0)GO TO 4000 CALL GETBRG(DELTA,XQE,BASE(1),YQE,BASE(2),VPX,VPY) VSX=SQRT(VPX*VPX+VPY*VPY) WRITE(6,30180)LETR(6),BASE(1),BASE(2),DELTA,VSX ,RADEB 30180 FORMAT(1X,A1,' AT ',F4.1,',',F4.1,' BEARING: ',F4.0,' DISTANCE: 1 ',F4.1,' RADIUS: ',F3.2) GO TO 4000 C ...IF WARP 1 OR HIGHER, GIVE QUADRANTS OF STARBASES. 30176 DO 30177 I=1,NQUAD DO 30177 J=1,NQUAD IF((JGAL(I,J)-JGAL(I,J)/100*100)/10.EQ.0) GO TO 30177 WRITE(6,30178)I,J 30178 FORMAT(' STARBASE IN QUADRANT ',I2,',',I2) 30177 CONTINUE DO 38179 I=1,NQUAD DO 38179 J=1,NQUAD IF(IGAL(I,J).LT.0.OR.IBL(I,J).LE.0)GO TO 38179 WRITE(6,38174)I,J 38174 FORMAT(' BLACK HOLE IN QUADRANT ',I2,',',I2) 38179 CONTINUE GO TO 4000 C ...SELF DESTRUCT 3018 CALL RATING(7) GO TO 4000 C ...TRANSPORTERS. 3019 IF(PSP.GE.1.)GO TO 994 IF(IFROM.EQ.LETR(3))GO TO 1391 IF(IFROM.EQ.LETR(4))GO TO 1392 IF(IFROM.EQ.LETR(5))GO TO 1393 IF(IFROM.EQ.LETR(6))GO TO 1394 IF(IFROM.NE.LETR(2))GO TO 998 LUP=2 GO TO 1395 1394 LUP=6 GO TO 1395 1391 LUP=3 IF(KFROM.LT.1.OR.KFROM.GT.KLNGNS)GO TO 998 GO TO 1395 1392 LUP=4 IF(KFROM.LT.1.OR.KFROM.GT.NROM)GO TO 998 GO TO 1395 1393 LUP=5 1395 CONTINUE IF(ITO.EQ.LETR(3))GO TO 13901 IF(ITO.EQ.LETR(4))GO TO 13902 IF(ITO.EQ.LETR(5))GO TO 13903 IF(ITO.NE.LETR(2))GO TO 998 LDOWN=2 GO TO 13905 13901 LDOWN=3 IF(MTO.LT.1.OR.MTO.GT.KLNGNS)GO TO 998 IF(ITRUCE.EQ.0.OR.ICNTL(MTO+1).EQ.1)GO TO 13905 ITRUCE=0 WRITE(6,33333) GO TO 13905 13902 LDOWN=4 IF(MTO.LT.1.OR.MTO.GT.NROM)GO TO 998 IF(ITRUCE.EQ.0.OR.ICNTL(MTO+10).EQ.1)GO TO 13905 ITRUCE=0 WRITE(6,33333) GO TO 13905 13903 LDOWN=5 C ...COMMAND OK NOW. 13905 ISTAT=IBMEN JTO=MTO JFROM=KFROM JDOWN=LDOWN JUP=LUP GO TO 4000 C ...OTHER SHIP ACTIVITIES UNDER E CONTROL. 3020 IF(PSP.GE.1.)GO TO 994 GO TO (30201,992,992,30204,30205,30206,992,30208,30209,992 ,992, 130212,992,992,992,992,30217),IMSG C ...K COURSE CHANGE. 30201 IF(LTO.EQ.5)GO TO 30240 IF(ICNTL(KTO+1).NE.1)GO TO 992 IF(ITRMEN(KTO+1).LE.0)GO TO 992 XKL(KTO,6)=KBRG XKL(KTO,5)=AMIN1(ABS(XWRP),VMXKL) GO TO 4000 C ...K FIRE PHASER. 30204 IF(LTO.EQ.5)GO TO 30250 IF(ICNTL(KTO+1).NE.1)GO TO 992 IF(ITRMEN(KTO+1).LE.0)GO TO 992 XKL(KTO,8)=NTSTPS+1+(CREWK/ITRMEN(KTO+1)*SKDLAY+RAN (IZZ)*XKF 1PST) GO TO 4000 C ...R FIRE TORPEDO. 30205 IF(LTO.EQ.5)GO TO 30260 IF(ICNTL(KTO+10).NE.1)GO TO 992 IF(ITRMEN(KTO+10).LE.0)GO TO 992 XROM(KTO,4)=NTSTPS+1+(SCREWR/ITRMEN(KTO+10)*SRDLY+RAN (IZZ)*X 1RFTS)*XRMHIT/(XRMHIT-XROM(KTO,3)) c$$ GO TO 4000 C ...SCUTTLE SHIP C ...JJSTAT=0 NORMAL C ...JJSTAT < 0 TRANSPORTERS QUEUED FOR USE BY AUTO-DESTRUCT. C ...JJSTAT > 0 TRANSPORTERS CURRENTLY IN USE FOR AUTO-DESTRUCT. 30206 L=LTO-2 IF(LTO.EQ.5)KTO=1 M=(L-1)*9+KTO+1 IF(ICNTL(M).NE.1)GO TO 992 IF(ITRMEN(M).EQ.0)GO TO 992 IF(JJSTAT.NE.0)GO TO 39299 SDAYS=0. IF(ISTAT.EQ.0)GO TO 39200 C ...TRANSPORTERS IN USE. SET UP JJSTAT TO INDICATE WE ARE WAITNG. JJSTAT=-ISTAT/(IDAMRP+1)-1 GO TO 39202 39200 ISTAT=ITRMEN(M) JJSTAT=1 JFROM=KTO JUP=LTO JDOWN=2 JTO=1 SDAYS=(ISTAT/(IDAMRP+1)+1)/100. GO TO 39204 39202 SDAYS=SDAYS-JJSTAT/100. JJFROM=KTO JJUP=LTO JJDOWN=2 JJTO=1 SDAYS=SDAYS+(ITRMEN(M)/(IDAMRP+1)+1)/100. IISTAT=ITRMEN(M) 39204 WRITE(6,39203)SDAYS 39203 FORMAT(' DESTRUCT IN ',F5.2,' STARDAYS') GO TO 4000 39299 WRITE(6,39298)LETR(JUP),JFROM 39298 FORMAT(' RETYPE COMMAND WHEN ',A1,I1,' DESTRUCT SEQUENCE COMPLETED 1') GO TO 998 C ...STATUS REPORT 30208 IF(LTO.EQ.6)GO TO 30299 LTO=LTO-2 GO TO (30281,30285,30288),LTO C ...KLINGON STATUS 30281 IF(ICNTL(KTO+1).NE.1)GO TO 992 WRITE(6,30282)LETR(3),KTO,(XKL(KTO,J),J=1,4),ITRMEN(KTO+1) 30282 FORMAT(' STATUS REPORT FOR ',A1,I1,' AT ',F4.1,',',F4.1/ ' SP 1EED: ',F5.3,' BEARING: ',F4.0,' MEN ON BOARD: ',I5) GO TO 4000 C ...ROMULAN STATUS 30285 IF(ICNTL(KTO+10).NE.1)GO TO 992 WRITE(6,30283)LETR(4),KTO,XROM(KTO,1),XROM(KTO,2),ITRMEN(KTO+10) 30283 FORMAT(' STATUS REPORT FOR ',A1,I1,' AT ',F4.1,',',F4.1/ ' ME 1N ON BOARD: ',I5) GO TO 4000 C ...GHOSTSHIP STATUS 30288 IF(IGH.EQ.0)GO TO 992 IF(ICNTL(20).NE.1)GO TO 992 WRITE(6,30284)LETR(5),GHOST(1),GHOST(2),GHOST(4),GHOST(5), (G 1HOST(K),K=11,13),ITRMEN(20) 30284 FORMAT(' STATUS REPORT FOR ',A1,' AT ',F4.1,',',F4.1/ ' SPEED 1: ',F5.3,' BEARING: ',F4.0,' ENERGY: ',F7.1, ' TORPS: ',F3.0/ 1' SHIELD STRENGTH: ',F6.1,' MEN ON BOARD: ',I5) GO TO 4000 C ...DAMAGE REPORT 30209 LTO=LTO-2 GO TO (30291,30295,30298),LTO C ...KLINGON DAMAGE 30291 IF(ICNTL(KTO+1).NE.1)GO TO 992 WRITE(6,30292)LETR(3),KTO,XKL(KTO,7) 30292 FORMAT(' DAMAGE REPORT FOR ',A1,I1,' HITS: ',F5.1) GO TO 4000 C ...ROMULAN DAMAGE 30295 IF(ICNTL(KTO+10).NE.1)GO TO 992 WRITE(6,30292)LETR(4),KTO,XROM(KTO,3) GO TO 4000 C ...GHOSTSHIP DAMAGE 30298 IF(IGH.EQ.0)GO TO 992 IF(ICNTL(20).NE.1)GO TO 992 WRITE(6,30292)LETR(5),IGH,GHOST(3) 3991 IF(IGHPH.EQ.0)WRITE(6,30293)NAMD(3) 30293 FORMAT(1X,A10,' DEAD') 3992 IF(IGHTR.EQ.0)WRITE(6,30293)NAMD(4) 3993 IF(IGHDR.EQ.0)WRITE(6,30293)NAMD(2) 3994 IF(IGHDE.EQ.0)WRITE(6,30293)DEFLEC GO TO 4000 C ...G RAISE DEFLECTORS. 30212 IF(ICNTL(20).NE.1)GO TO 992 IF(IGHDE.EQ.0)GO TO 3994 IF(SDEF)30213,992,30214 C ...DROP 30213 SDEF=AMAX1(SDEF,-GHOST(13)) 30215 GHOST(13)=GHOST(13)+SDEF GHOST(11)=GHOST(11)-SDEF GO TO 4000 C ...RAISE 30214 SDEF=AMIN1(SDEF,GHOST(11)) GO TO 30215 C ...CHANGE COURSE 30240 IF(ICNTL(20).NE.1)GO TO 992 IF(ITRMEN(20).LE.0)GO TO 992 IF(IGHDR.EQ.0)GO TO 3993 GHOST(6)=AMIN1(XWRP,GHVMX) GHOST(7)=KBRG GO TO 4000 C ...G FIRE P. 30250 IF(ICNTL(20).NE.1)GO TO 992 IF(ITRMEN(20).LE.0)GO TO 992 IF(IGHPH.EQ.0)GO TO 3991 GHOST(10)=NTSTPS+1+FLOAT(MIN0(MXCRGH,ITRMEN(20)))/ FLOAT(ITRM 1EN(20)) GO TO 4000 C ...G FIRE T. 30260 IF(ICNTL(20).NE.1)GO TO 992 IF(ITRMEN(20).LE.0)GO TO 992 IF(IGHTR.EQ.0)GO TO 3992 GHOST(8)=NTSTPS+1+FLOAT(MIN0(MXCRGH,ITRMEN(20)))/ FLOAT(ITRME 1N(20)) GO TO 4000 C ...COMMUNICATION WITH B. 30299 IF(IBASE.EQ.0)GO TO 992 WRITE(6,30294)IBMENR 30294 FORMAT(' STARBASE TROOPS AVAILABLE: ',I4) GO TO 4000 C ...PLOT BEARING FROM BASE. 30217 IF(IBASE.EQ.0)GO TO 992 WRITE(6,30171) IF(NSTARS.EQ.0)GO TO 30218 DO 30219 J=1,NSTARS IF(STARS(J,1).EQ.0.)GO TO 30219 CALL GETBRG(DELTA,BASE(1),STARS(J,1),BASE(2),STARS(J,2),VPX,VPY) VSX=SQRT(VPX*VPX+VPY*VPY) WRITE(6,30173)LETR(1),J,STARS(J,1),STARS(J,2),DELTA,VSX ,RAD(J) 30219 CONTINUE 30218 CALL GETBRG(DELTA,BASE(1),XQE,BASE(2),YQE,VPX,VPY) VSX=SQRT(VPX*VPX+VPY*VPY) WRITE(6,30180)LETR(2),XQE,YQE,DELTA,VSX,RADEB GO TO 4000 C ...SHUTTLECRAFT ACTIVITIES. 3031 IF(PSP.GE.1.)GO TO 994 IF(ISHNUM.LE.0)GO TO 30314 GO TO (30310,30315),JSCHM C ...EXPLORE. 30310 IF(ISHSTR(1).GT.NSTARS.OR.ISHSTR(1).LE.0)GO TO 998 IF(STARS(ISHSTR(1),1).EQ.0.)GO TO 998 ISHD=ISHSTR(1) IF(ISTSH.NE.99)GO TO 4000 SDAYS=RANGE(SHX,STARS(ISHSTR(1),1),SHY,STARS(ISHSTR(1),2))/SHVX/10 10. WRITE(6,30313)SDAYS 30313 FORMAT(' ARRIVAL IN ',F4.2,' STARDAYS') GO TO 4000 C ...RETURN 30314 WRITE(6,30311) 30311 FORMAT(' NO SHUTTLECRAFT ON BOARD') GO TO 998 30315 IF(ISTSH.EQ.0)GO TO 998 ISHD=99 IF(ISTSH.NE.99)GO TO 4000 SDAYS=RANGE(SHX,XQE,SHY,YQE)/100./SHVX WRITE(6,30313)SDAYS GO TO 4000 C ...COMPUTER REQUESTS. 3033 IF(PSP.GE.1.)GO TO 994 GO TO (30331,30334,30338,30340,30370,30360),JSCHM GO TO 998 C ...ENERGY FOR G. 30331 IF(IGH.EQ.0)GO TO 992 X=(GHOST(1)-XQE)**2+(GHOST(2)-YQE)**2 X=X/DISTGT*PTRGH WRITE(6,30332)X 30332 FORMAT(F8.0,' UNITS ENERGY REQUIRED') GO TO 4000 C ...WHERE HOLE WILL TAKE YOU. 30334 IF(IHOLE.EQ.0)GO TO 992 I=IBL(ICE,JCE)/100 J=IBL(ICE,JCE)-I*100 WRITE(6,30335)I,J 30335 FORMAT(' HOLE GOES TO QUADRANT ',I2,',',I2) GO TO 4000 C ...SHUTTLECRAFT ROUND TRIP TIME. 30338 IF(ISTSH.EQ.99)GO TO 30350 DO 30351 I=1,9 IF (ISTSH.EQ.I)GO TO 30350 30351 CONTINUE IF(ISHSTR(1).LE.0.OR.NSTARS.EQ.0)GO TO 992 30350 JTIME=0 Y=SHX Z=SHY IF(ISHD.ne.99)go to 100 X=RANGE(Y,XQE,Z,YQE) JTIME=JTIME+X/SHVX go to 30336 100 continue DO 30339 I=1,10 J=ISHSTR(I) IF(J.LE.0)GO TO 30333 IF(STARS(J,1).EQ.0.)GO TO 30333 X=RANGE(Y,STARS(J,1),Z,STARS(J,2)) Y=STARS(J,1) Z=STARS(J,2) JTIME=JTIME+X/SHVX GO TO 30339 30333 X=RANGE(Y,XQE,Z,YQE) JTIME=JTIME+X/SHVX GO TO 30336 30339 CONTINUE GO TO 992 30336 WRITE(6,30337)JTIME 30337 FORMAT(' ROUND TRIP TIME = ',I4,' STARMINUTES') GO TO 4000 30340 CALL CPAGE IIKK=0 WRITE(6,30341) 30341 FORMAT(' COMMUNIQUE FROM STARFLEET COMMAND! '/' THE CURRENT RANKS 1 HAVE BEEN OBTAINED BY THE FOLLOWING OFFICERS:') 30342 IRNK=14 IIKK=IIKK+1 READ(3,REC=IIKK,ERR=30347)MNAME,POINTS,MPASS,X6,X7 IF(MNAME.EQ.MOLDNM)GO TO 30347 MOLDNM=MNAME 30344 IF(POINTS.GE.RANKPT(IRNK))GO TO 30345 IRNK=IRNK-1 GO TO 30344 30345 WRITE(6,30346)RANKS(1,IRNK),RANKS(2,IRNK),MNAME,POINTS 30346 FORMAT(2A8,' ',A8,' CURRENTLY HAS POINTS = ',F6.2) GO TO 30342 30347 READ(3,REC=MMKEY,ERR=4000)MNAME,POINTS,MPASS,X6,X7 GO TO 4000 30370 ION=0 IF(ICLKON.EQ.IYES)ION=1 GO TO 4000 30360 CALL QTIME(ITC) ITM1=ITC/3600 ITC=ITC-ITM1*3600 ITM2=ITC/60 ITM3=ITC-ITM2*60 WRITE(6,30361)ITM1,ITM2,ITM3 30361 FORMAT(' CURRENT TIME FROM COMPUTER BANKS: ',I2,':',I2,':',I2) GO TO 4000 C ...CANCELLED COMMAND DUE TO ILLEGAL REQUEST VALUE OR CHANGE IN C ...SYSTEM STATUS. 998 WRITE(6,996) IF(ICM.EQ.6)ETR(1)=0. IF(ICM.EQ.5)EFT(1,1)=0. IF(ICM.EQ.4)EFP(1)=0. PNRGY=0. 996 FORMAT(' ***CANCELLED***') GO TO 4000 C ...ILLEGAL COMMAND AREA. 994 WRITE(6,993) IF(ICM.GE.4.AND.ICM.LE.6)GO TO 998 993 FORMAT(' IMPOSSIBLE - HYPERSPACE!') GO TO 4000 C ...NEW ONE HERE. 992 WRITE(6,991) 991 FORMAT(' NOT UNDER E CONTROL OR OTHERWISE IMPOSSIBLE') C ...FINISH UP. 4000 CALL QTIME(JTIME) NSTEPS=(JTIME-ISTART)+ITRSTP*ITFCTR ISTART=JTIME ITRSTP=0 IF(NSTEPS.LE.0)NSTEPS=1 5000 RETURN END  5438 if(lto.eq.6)go to 998