home *** CD-ROM | disk | FTP | other *** search
-
- 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
