SUBROUTINE DLETE(NTYP,NUM) 0934 c include 'tcommon.for' %include tcommon.for GO TO (100,999,300,400,500,600,700),NTYP 0964 999 RETURN 0965 C ...DELETE *. 0966 100 JGAL(ICE,JCE)=JGAL(ICE,JCE)-1 0967 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0) IGAL(ICE,JCE)=JGAL(ICE,JCE) 0968 X=STARS(NUM,1) 0969 Y=STARS(NUM,2) 0970 STARS(NUM,1)=0. 0971 JJ=1 0972 DO 110 J=1,NSTARS 0973 IF(STARS(J,1).EQ.0.)GO TO 110 0974 JJ=0 0975 GO TO 120 0976 110 CONTINUE 0977 NSTARS=0 0978 C ...SHUTTLECRAFT DESTROYED - FINDINGS LOST. 0979 120 IF(ISTSH.NE.NUM.OR.ISHD.EQ.99)GO TO 200 0980 WRITE(6,11) 0981 11 FORMAT(' SHUTTLECRAFT DESTROYED') 0982 ISTSH=0 0983 ISHD=0 0984 DO 150 J=1,9 0985 IF(IFNDS(J).EQ.-1)GO TO 150 0986 IFNDS(J)=0 0987 150 CONTINUE 0988 DO 151 J=1,10 0989 151 ISHSTR(J)=0 0990 ISHNUM=ISHNUM-1 0991 GO TO 888 0992 200 IF(ISTSH.NE.99.OR.ISHD.NE.NUM)GO TO 888 0993 WRITE(6,12) 0994 12 FORMAT(' SHUTTLECRAFT OBJECTIVE DESTROYED') 0995 C ...FIND NEW OBJECTIVE (NEAREST UNEXPLORED STAR) IF POSSIBLE. 0996 IF(NSTARS.EQ.0)GO TO 290 0997 JJ=ISHSTR(2) 0998 IF(JJ.LE.0.OR.STARS(JJ,1).EQ.0.)GO TO 290 0999 DO 225 J=2,10 1000 225 ISHSTR(J-1)=ISHSTR(J) 1001 DIST=RANGE(SHX,STARS(JJ,1),SHY,STARS(JJ,2)) 1002 IF(JJ.EQ.0)GO TO 290 1003 DX=DIST/SHVX/100. 1004 WRITE(6,230)JJ,DX 1005 230 FORMAT(' GOING ON TO STAR SYSTEM ',I1,' ARRIVAL IN ',F4.2,' STARDA1006 1YS') 1007 ISHD=JJ 1008 GO TO 888 1009 290 WRITE(6,295) 1010 295 FORMAT(' TURNING BACK') 1011 ISHD=99 1012 DO 296 I=1,10 1013 296 ISHSTR(I)=0 1014 GO TO 888 1015 C ...DELETE K. 1016 300 LEFTK=LEFTK-1 1017 JGAL(ICE,JCE)=JGAL(ICE,JCE)-100 1018 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0) IGAL(ICE,JCE)=JGAL(ICE,JCE) 1019 X=XKL(NUM,1) 1020 Y=XKL(NUM,2) 1021 XKL(NUM,1)=0. 1022 JJ=1 1023 DO 310 J=1,KLNGNS 1024 IF(XKL(J,1).EQ.0.)GO TO 310 1025 JJ=0 1026 GO TO 320 1027 310 CONTINUE 1028 KLNGNS=0 1029 320 IF(ITRMEN(NUM+1).EQ.0)GO TO 330 1030 WRITE(6,301)ITRMEN(NUM+1) 1031 301 FORMAT(I4,' TROOPS ON BOARDS LOST') 1032 ITRMEN(NUM+1)=0 1033 IF(ISTAT.EQ.0)GO TO 330 1034 C ...SET ISTAT TO STOP BEAMING 1035 IF(JUP.EQ.3.AND.JFROM.EQ.NUM.OR.JDOWN.EQ.3.AND.JTO.EQ.NUM)ISTAT=991036 199 1037 330 ICNTL(NUM+1)=0 1038 GO TO 888 1039 C ...DELETE ROMULAN. 1040 400 LEFTR=LEFTR-1 1041 JGAL(ICE,JCE)=JGAL(ICE,JCE)-1000 1042 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0) IGAL(ICE,JCE)=JGAL(ICE,JCE) 1043 X=XROM(NUM,1) 1044 Y=XROM(NUM,2) 1045 XROM(NUM,1)=0. 1046 IF(ICLOAK.EQ.2.AND.NUM.EQ.1)ICLOAK=1 1047 JJ=1 1048 DO 410 J=1,NROM 1049 IF(XROM(J,1).EQ.0.)GO TO 410 1050 JJ=0 1051 GO TO 420 1052 410 CONTINUE 1053 NROM=0 1054 420 IF(ITRMEN(NUM+10).EQ.0)GO TO 430 1055 WRITE(6,301)ITRMEN(NUM+10) 1056 ITRMEN(NUM+10)=0 1057 IF(ISTAT.EQ.0)GO TO 430 1058 C ...SET ISTAT TO STOP BEAMING 1059 IF(JUP.EQ.4.AND.JFROM.EQ.NUM.OR.JDOWN.EQ.4.AND.JTO.EQ.NUM)ISTAT=991060 199 1061 430 ICNTL(NUM+10)=0 1062 GO TO 888 1063 C ...DELETE G. 1064 500 IGH=0 1065 X=GHOST(1) 1066 IF(ITRMEN(20).EQ.0)GO TO 530 1067 WRITE(6,301)ITRMEN(20) 1068 ITRMEN(20)=0 1069 IF(ISTAT.EQ.0)GO TO 530 1070 C ...SET ISTAT TO STOP BEAMING 1071 IF(JUP.EQ.5.OR.JDOWN.EQ.5)ISTAT=9999 1072 530 ICNTL(20)=0 1073 Y=GHOST(2) 1074 GO TO 888 1075 C ...DELETE B. 1076 600 IBASE=0 1077 X=BASE(1) 1078 Y=BASE(2) 1079 IBMENR=0 1080 JGAL(ICE,JCE)=JGAL(ICE,JCE)-10 1081 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0) IGAL(ICE,JCE)=JGAL(ICE,JCE) 1082 GO TO 888 1083 C ...DELETE T. 1084 700 TORPS(NUM,1)=0. 1085 JJ=1 1086 DO 710 J=1,NTORPS 1087 IF(TORPS(J,1).EQ.0.)GO TO 710 1088 JJ=0 1089 GO TO 999 1090 710 CONTINUE 1091 NTORPS=0 1092 GO TO 999 1093 C ...PRINT MESSAGE 1094 888 WRITE(6,1)LETR(NTYP),NUM,X,Y 1095 1 FORMAT(1X,A1,I1,' AT ',F4.1,',',F4.1,' DESTROYED') 1096 IF(LEFTR.EQ.0.AND.LEFTK.EQ.0)CALL RATING(4) 1097 GO TO 999 1098 END 1099 AY FROM TOR