Programmer 7500

home *** CD-ROM | disk | FTP | other *** search

/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / SCAN.FOR < prev next >

Wrap

Text File | 1986-12-15 | 20.8 KB | 281 lines

SUBROUTINE SCAN 4227 c include 'tcommon.for' %include tcommon.for character*8 JCOND(4) DIMENSION IBAD(100,2) character*4 NUMS(9) ,ILET(2),JPQ(10,10) data nums/'1','2','3','4','5','6','7','8','9'/ data ILET/'+','-'/ data jcond/'GREEN','YELLOW','ORANGE',' RED'/ DO 100 I=1,10 4265 DO 100 J=1,10 4266 JPQ(I,J)=LETR(9) 4267 100 IPQ(I,J)=LETR(8) 4268 IF(IHERE.EQ.2)GO TO 1001 4269 IF(IDMG(6).GT.0)GO TO 105 4270 C CALL CPAGE 4271 WRITE(*,1)ICE,JCE 4272 1 FORMAT(' SHORT RANGE SENSOR SCAN FOR QUADRANT ',I2,',',I2 ) 4273 C ...CALCULATE CURRENT RATING AND TIME RATIO. 4274 R=LEFTK+LEFTR 4275 S=NKL+MROM 4276 IR=(S-R)/S*1000. 4277 TRATE=XTIME/R 4278 KP=1 4279 IPLUSM=(TRATE-RTIME)/RTIME*100. 4280 IF(IPLUSM.LT.0)KP=2 4281 IPLUSM=IABS(IPLUSM) 4282 WRITE(*,21) 4283 105 IF(IHERE.GE.1)GO TO 1000 4284 C ...RESET ARRAYS TO LOSE THINGS LEFT BEHIND. 4285 9876 ETR(1)=0. 4286 EFP(1)=0. 4287 EFT(1,1)=0. 4288 ITORP=ITORP+ITFIRE 4289 ITFIRE=0 4290 DO 2017 J=1,18 4291 ITKL(J)=0 4292 2017 JTKL(J)=0 4293 ACTPJM=PJAM 4294 IF(ISTSH.EQ.0)GO TO 9873 4295 ISTSH=0 4296 ISHD=0 4297 ISHNUM=ISHNUM-1 4298 9873 DO 9872 J=1,9 4299 9872 IFNDS(J)=0 4300 DO 9889 J=1,10 4301 9889 ISHSTR(J)=0 4302 DO 9875 J=2,20 4303 ICNTL(J)=0 4304 9875 ITRMEN(J)=0 4305 IF(ISTAT.NE.0)ISTAT=9999 4306 DO 9874 J=1,30 4307 9874 TORPS(J,1)=0. 4308 IF(ICLOAK.LT.0.AND.ION.EQ.1)GO TO 4646 4309 IX=XQE+.5 4310 IY=YQE+.5 4311 IPQ(IX,IY)=LETR(2) 4312 4646 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0) IGAL(ICE,JCE)=JGAL(ICE,JCE) 4313 C ...GET CONTENTS FROM JGAL 4314 ICNTNT=JGAL(ICE,JCE) 4315 NROM=ICNTNT/1000 4316 KLNGNS=ICNTNT/100-NROM*10 4317 IBASE=(ICNTNT-ICNTNT/100*100)/10 4318 NSTARS=ICNTNT-ICNTNT/10*10 4319 NTORPS=0 4320 IGH=0 4321 IF(RAN(IZZ).LE.PRGH)IGH=1 4322 IF(ICLOAK.EQ.2)ICLOAK=1 4323 NBAD=0 4324 C ...EVERYTHING STARTS ON INTEGRAL COORDINATES 4325 C ...FLAG THOSE POINTS TOO NEAR TO E TO PUT OBJECTS. 4326 DO 200 I=1,10 4327 DO 200 J=1,10 4328 DIST=(I-XQE)**2+(J-YQE)**2 4329 IF(SQRT(DIST).GT.ESDIST)GO TO 200 4330 NBAD=NBAD+1 4331 IBAD(NBAD,1)=I 4332 IBAD(NBAD,2)=J 4333 200 CONTINUE 4334 IHOLE=0 4335 IF(IBL(ICE,JCE).EQ.0)GO TO 9877 4336 CALL PUTIN(IHOLE,JHOLE,NBAD,IBAD,LETR(9)) 4337 9877 ISTORM=0 4338 IF(LEVEL.NE.3)GO TO 9879 4339 PSTORM=(NSTARS**3)/1000. 4340 IF(RAN(IZZ).GT.PSTORM)GO TO 9879 4341 CALL PUTIN(ISTORM,JSTORM,NBAD,IBAD,LETR(8)) 4342 6534 FORMAT(' WARNING - NUCLEONIC DISTURBANCES SIGHTED IN QUADRANT.') 4343 C ...PUT THINGS IN. NO TWO OBJECTS IN SAME PLACE. 4344 9879 IF(KLNGNS.EQ.0)GO TO 300 4345 DO 110 I=1,KLNGNS 4346 CALL PUTIN(IX,IY,NBAD,IBAD,LETR(3)) 4347 JPQ(IX,IY)=NUMS(I) 4348 XKL(I,1)=IX 4349 XKL(I,2)=IY 4350 XKL(I,3)=0. 4351 XKL(I,4)=0. 4352 XKL(I,5)=0. 4353 XKL(I,6)=0. 4354 IX=RAN(IZZ)*XKFPST+NTSTPS+1 4355 XKL(I,8)=IX 4356 XKL(I,7)=0. 4357 C ...RANDOM K CREW STRENGTH AROUND MEAN. 4358 IX=CREWK +SIGN(RAN(IZZ)*25.,.5-RAN(IZZ)) 4359 XKL(I,9)=IX 4360 110 CONTINUE 4361 300 IF(NROM.EQ.0)GO TO 150 4362 JUMP=1 4363 IF(ICLOAK.EQ.1.AND.RAN(IZZ).LE.PRCLDN)JUMP=2 4364 DO 310 I=1,NROM 4365 CALL PUTIN(IX,IY,NBAD,IBAD,LETR(4)) 4366 IF(I.NE.1)GO TO 33305 4367 IF(JUMP.EQ.2)GO TO 33307 4368 33305 SCR=SCREWR 4369 JPQ(IX,IY)=NUMS(I) 4370 GO TO 33308 4371 33307 SCR=SCREWR*1.33 4372 IPQ(IX,IY)=LETR(8) 4373 ICLOAK=2 4374 33308 XROM(I,1)=IX 4375 XROM(I,2)=IY 4376 XROM(I,3)=0. 4377 C ...RANDOM R CREW STRENGTH AROUND MEAN. 4378 IX=SCR+SIGN(RAN(IZZ)*35.,.5-RAN(IZZ)) 4379 CREWR(I)=IX 4380 IX=RAN(IZZ)*XRFTS+NTSTPS 4381 XROM(I,4)=IX 4382 310 CONTINUE 4383 150 IF(NSTARS.EQ.0)GO TO 170 4384 DO 160 I=1,NSTARS 4385 CALL PUTIN(IX,IY,NBAD,IBAD,LETR(1)) 4386 JPQ(IX,IY)=NUMS(I) 4387 STARS(I,1)=IX 4388 STARS(I,2)=IY 4389 RAD(I)=RAN(IZZ)*.75+.25 4390 160 CONTINUE 4391 170 IF(IGH.EQ.0)GO TO 180 4392 CALL PUTIN(IX,IY,NBAD,IBAD,LETR(5)) 4393 GHOST(1)=IX 4394 GHOST(2)=IY 4395 GHOST(3)=0. 4396 GHOST(4)=RAN(IZZ)*GHVMX 4397 GHOST(6)=GHOST(4) 4398 GHOST(5)=RAN(IZZ)*360. 4399 GHOST(7)=GHOST(5) 4400 GHOST(8)=0. 4401 GHOST(9)=0. 4402 GHOST(10)=0. 4403 GHOST(11)=RAN(IZZ)*GHEMX 4404 IX=RAN(IZZ)*GHTMX+1. 4405 GHOST(12)=IX 4406 GHOST(13)=0. 4407 IGHPH=1 4408 IF(RAN(IZZ).LE.PPHASD)IGHPH=0 4409 IGHTR=1 4410 IF(RAN(IZZ).LE.PTORPD)IGHTR=0 4411 IGHDR=1 4412 IF(RAN(IZZ).LE.PDRVD)IGHDR=0 4413 IGHDE=1 4414 IF(RAN(IZZ).LE.PDEFD)IGHDE=0 4415 180 IF(IBASE.EQ.0)GO TO 1900 4416 CALL PUTIN(IX,IY,NBAD,IBAD,LETR(6)) 4417 BASE(1)=IX 4418 BASE(2)=IY 4419 MAXRQ=0 4420 IBMENR=RAN(IZZ)*SBMNR 4421 GO TO 1900 4422 1000 IF(IDMG(6).GT.0)RETURN 4423 C ...ALREADY HERE. PUT THINGS IN THEIR PLACE ACCORDING TO PROPER 4424 C ...HIERARCHY. 4425 1001 IF(ISTSH.NE.99)GO TO 1010 4426 IX=SHX+.5 4427 IY=SHY+.5 4428 IPQ(IX,IY)=LETR(12) 4429 C ...TO SET UP IPQ FOR PRINTING QUAD IF ALREADY GENERATED. 4430 1010 IF(NTORPS.EQ.0)GO TO 1100 4431 DO 1050 I=1,NTORPS 4432 IF(TORPS(I,1).EQ.0.)GO TO 1050 4433 IX=TORPS(I,1)+.5 4434 IY=TORPS(I,2)+.5 4435 IPQ(IX,IY)=LETR(7) 4436 1050 CONTINUE 4437 GO TO 1100 4438 1300 IF(IBASE.EQ.0)GOTO 1200 4439 IX=BASE(1) 4440 IY=BASE(2) 4441 IPQ(IX,IY)=LETR(6) 4442 1200 IF(IGH.EQ.0)GO TO 1550 4443 IX=GHOST(1) +.5 4444 IY=GHOST(2) +.5 4445 IPQ(IX,IY)=LETR(5) 4446 GO TO 1550 4447 1500 IF(NROM.EQ.0)GOTO 1400 4448 DO 1350 I=1,NROM 4449 IF(XROM(I,1).EQ.0.)GO TO 1350 4450 IF(ICLOAK.EQ.2.AND.IHERE.NE.2.AND.I.EQ.1)GO TO 1350 4451 IX=XROM(I,1) 4452 IY=XROM(I,2) 4453 IPQ(IX,IY)=LETR(4) 4454 JPQ(IX,IY)=NUMS(I) 4455 1350 CONTINUE 4456 1400 IF(KLNGNS.EQ.0)GO TO 1900 4457 DO 1450 I=1,KLNGNS 4458 IF(XKL(I,1).EQ.0.)GO TO 1450 4459 IX=XKL(I,1)+.5 4460 IY=XKL(I,2)+.5 4461 IPQ(IX,IY)=LETR(3) 4462 JPQ(IX,IY)=NUMS(I) 4463 1450 CONTINUE 4464 GO TO 1900 4465 1100 IX=XQE+.5 4466 IY=YQE+.5 4467 IF(ICLOAK.LT.0.AND.ION.EQ.1)GO TO 1300 4468 IPQ(IX,IY)=LETR(2) 4469 GO TO 1300 4470 1550 IF(NSTARS.EQ.0)GO TO 1500 4471 DO 1600 I=1,NSTARS 4472 IF(STARS(I,1).EQ.0.)GO TO 1600 4473 IX=STARS(I,1) 4474 IY=STARS(I,2) 4475 IPQ(IX,IY)=LETR(1) 4476 JPQ(IX,IY)=NUMS(I) 4477 1600 CONTINUE 4478 GO TO 1500 4479 C ...PRINTOUT AREA. 4480 1900 ICOND=1 4481 IF(IDMG(6).GT.0)RETURN 4482 IF(IHERE.EQ.2)RETURN 4483 IGAL(ICE,JCE)=JGAL(ICE,JCE) 4484 IF(ENERGY.LE.500.)ICOND=2 4485 IF(NROM+KLNGNS.EQ.0)GO TO 1950 4486 IF(KLNGNS.EQ.0)GO TO 1920 4487 DO 1910 J=1,KLNGNS 4488 IF(XKL(J,1).EQ.0..OR.ICNTL(J+1).EQ.1)GO TO 1910 4489 ICOND=3 4490 GO TO 1950 4491 1910 CONTINUE 4492 1920 IF(NROM.EQ.0)GO TO 1950 4493 DO 1930 J=1,NROM 4494 IF(XROM(J,1).EQ.0..OR.ICNTL(J+10).EQ.1)GO TO 1930 4495 ICOND=3 4496 GO TO 1950 4497 1930 CONTINUE 4498 1950 IF(IHOLE.EQ.0)GO TO 1975 4499 IPQ(IHOLE,JHOLE)=LETR(9) 4500 1975 IF(ICOND.EQ.3.AND.DEFL.EQ.0.)ICOND=4 4501 WRITE(*,11)(IPQ(I,10),JPQ(I,10),I=1,10),SDATE,XTIME 4502 WRITE(*,12)(IPQ(I,9),JPQ(I,9),I=1,10),JCOND(ICOND) 4503 WRITE(*,13)(IPQ(I,8),JPQ(I,8),I=1,10),XQE,YQE 4504 WRITE(*,14)(IPQ(I,7),JPQ(I,7),I=1,10),ENERGY 4505 WRITE(*,15)(IPQ(I,6),JPQ(I,6),I=1,10) ,ITORP 4506 WRITE(*,16)(IPQ(I,5),JPQ(I,5),I=1,10),LEFTK ,LEFTR 4507 WRITE(*,17)(IPQ(I,4),JPQ(I,4),I=1,10),MEN,ITRMEN(1) 4508 WRITE(*,18)(IPQ(I,3),JPQ(I,3),I=1,10),DEFL 4509 WRITE(*,19)(IPQ(I,2),JPQ(I,2),I=1,10),PDEG,PSP 4510 WRITE(*,20)(IPQ(I,1),JPQ(I,1),I=1,10),IR,TRATE,ILET(KP),IPLUSM 4511 11 FORMAT(1X,20A1,5X,'STARDATE: ',F7.2,' LEFT: ',F6.2) 4512 12 FORMAT(1X,20A1,5X,'CONDITION: ',A10) 4513 13 FORMAT(1X,20A1,5X,'SHIP POSITION: ',F4.1,',',F4.1) 4514 14 FORMAT(1X,20A1,5X,'ENERGY: ',F8.2) 4515 15 FORMAT(1X,20A1,5X,'TORPEDOS: ',I2) 4516 16 FORMAT(1X,20A1,5X,'ENEMY LEFT(K,R): ',I3,',',I3) 4517 17 FORMAT(1X,20A1,5X,'CREW: ',I4,' TROOPS: ',I4) 4518 18 FORMAT(1X,20A1,5X,'DEFLECTOR POWER: ',F8.2) 4519 19 FORMAT(1X,20A1,5X,'BEARING: ',F4.0,' SPEED: ',F5.3) 4520 20 FORMAT(1X,20A1,5X,'RATING: ',I3,' TIME RATIO: ',F4.2,'(',A1,I3,'%)4521 1') 4522 WRITE(*,21) 4523 21 FORMAT(' ------------------------------') 4524 IF(KLNGNS+NROM.LT.9.OR.IHERE.NE.0)GO TO 99998 4525 WRITE(*,65310) 4526 65310 FORMAT(' WELCOME TO THE CONVENTION! HEH, HEH, HEH...') 4527 99998 IF(ISTORM.EQ.0.OR.IHERE.NE.0)GO TO 99999 4528 WRITE(*,6534) 4529 99999 IF(IHERE.EQ.0)IHERE=1 4530 RETURN 4531 END 4532