Programmer 7500

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

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

Wrap

Text File | 1986-12-15 | 28.0 KB | 374 lines

SUBROUTINE COLLIS 0447 c include 'tcommon.for' %include tcommon.for C ...SUBROUTINE TO DETERMINE ALL POSSIBLE COLLISIONS 0474 C ...E COLLISION WITH * 0475 IF(NSTARS.EQ.0)GO TO 115 0476 DO 100 I=1,NSTARS 0477 IF(STARS(I,1).EQ.0.)GO TO 100 0478 IF(RANGE(XQE,STARS(I,1),YQE,STARS(I,2)).GT.RAD(I))GO TO 100 0479 CALL RATING(1) 0480 100 CONTINUE 0481 C ...SUPERNOVA? 0482 110 IF(RAN(IZZ).GT.SNOVAP)GO TO 115 0483 NS=NSTARS*RAN(IZZ)+1. 0484 1101 WRITE(6,111)NS 0485 111 FORMAT(' STAR ',I1,' GOING SUPERNOVA!!') 0486 NTORPS=0 0487 IF(IGH.EQ.0)GO TO 1111 0488 CALL DLETE(5,1) 0489 1111 DO 1112 I=1,NSTARS 0490 IF(STARS(I,1).EQ.0.)GO TO 1112 0491 CALL DLETE(1,I) 0492 1112 CONTINUE 0493 IF(NROM.EQ.0)GO TO 1114 0494 DO 1113 I=1,NROM 0495 IF(XROM(I,1).EQ.0.)GO TO 1113 0496 CALL DLETE(4,I) 0497 1113 CONTINUE 0498 1114 IF(KLNGNS.EQ.0)GO TO 1116 0499 DO 1115 I=1,KLNGNS 0500 IF(XKL(I,1).EQ.0.)GO TO 1115 0501 CALL DLETE(3,I) 0502 1115 CONTINUE 0503 1116 IF(IBASE.EQ.0)GO TO 1117 0504 CALL DLETE(6,1) 0505 1117 X=DEFL 0506 IF(X.EQ.0.)GO TO 1118 0507 X=300000./X 0508 IF(X.GT.ZMAX)GO TO 1118 0509 GO TO 1119 0510 1118 X=ZMAX 0511 1119 WRITE(6,11911) 0512 11911 FORMAT(' SHIELDS DESTROYED') 0513 CALL DAMAGE(-1,X) 0514 DEFL=0. 0515 IF(ISTSH.EQ.0)GO TO 115 0516 WRITE(6,1120) 0517 1120 FORMAT(' SHUTTLECRAFT DESTROYED') 0518 DO 1121 I=1,9 0519 1121 IFNDS(I)=0 0520 ISTSH=0 0521 ISHD=0 0522 ISHNUM=ISHNUM-1 0523 C ...E WITH K. 0524 115 IF(IDOCK.EQ.2)GO TO 210 0525 IF(KLNGNS.EQ.0)GO TO 130 DO 120 I=1,KLNGNS IF(XKL(I,1).EQ.0.)GO TO 120 0528 IF(RANGE(XQE,XKL(I,1),YQE,XKL(I,2)).GT.RADEK)GO TO 120 0529 WRITE(6,1)LETR(2),LETR(3),I 0530 1 FORMAT(1X,A1,'-',A1,I1,' COLLISION') 0531 CALL DLETE(3,I) 0532 WRITE(6,2) 0533 2 FORMAT(' SHIELDS DESTROYED') 0534 CALL DAMAGE(0,DEFL) 0535 120 CONTINUE 0536 C ...E WITH R. 0537 130 IF(NROM.EQ.0)GO TO 150 0538 DO 140 I=1,NROM 0539 IF(XROM(I,1).EQ.0.)GO TO 140 0540 IF(RANGE(XQE,XROM(I,1),YQE,XROM(I,2)).GT.RADER)GO TO 140 0541 WRITE(6,1)LETR(2),LETR(4),I 0542 CALL DLETE(4,I) 0543 WRITE(6,2) 0544 CALL DAMAGE(0,DEFL) 0545 140 CONTINUE 0546 C ...E WITH G. 0547 150 IF(IGH.EQ.0)GO TO 170 0548 IF(RANGE(XQE,GHOST(1),YQE,GHOST(2)).GT.RADEG)GO TO 170 0549 WRITE(6,7)LETR(2),LETR(5) 0550 CALL DLETE(5,1) 0551 WRITE(6,2) 0552 CALL DAMAGE(0,DEFL) 0553 C ...E WITH B. MAY BE DOCKING. 0554 170 IF(IBASE.EQ.0)GO TO 190 0555 IF(RANGE(XQE,BASE(1),YQE,BASE(2)).GT.RADEB)GO TO 190 0556 IF(PSP.LE.DMXSPD)GO TO 180 0557 WRITE(6,7)LETR(2),LETR(6) 0558 CALL DLETE(6,1) 0559 WRITE(6,2) 0560 CALL DAMAGE(0,DEFL) 0561 GO TO 190 0562 180 IDOCK=1 0563 GO TO 210 0564 C ...E WITH T. 0565 190 IF(NTORPS.EQ.0)GO TO 205 0566 DO 200 I=1,NTORPS 0567 IF(TORPS(I,1).EQ.0.)GO TO 200 0568 X=RANGE(XQE,TORPS(I,1),YQE,TORPS(I,2)) 0569 IF(X.GT.RADET)GO TO 200 0570 C ...E FIRED TORPS CAN'T HURT E. 0571 IF(TORPS(I,4).LT.0.)GO TO 200 0572 Y=AMAX1(TPMIN,(1.-X**2/RADET**2)*TPOWR)/SHLDF 0573 WRITE(6,3)LETR(7),LETR(2) 0574 3 FORMAT(1X,A1,' HIT ON ',A1) 0575 CALL HITONE(Y) 0576 CALL DLETE(7,I) 0577 200 CONTINUE 0578 C ...E WITH BLACK HOLE. 0579 205 IF(IHOLE.EQ.0)GO TO 210 0580 IF(RANGE(XQE,FLOAT(IHOLE),YQE,FLOAT(JHOLE)).GT.HOLRAD)GO TO 210 0581 WRITE(6,206)LETR(2) 0582 206 FORMAT(1X,A1,' CAPTURED BY BLACK HOLE GRAVITATION FIELD!') 0583 IS=-1 0584 CALL EPMOVE(IS) 0585 GO TO 999 0586 C ...K WITH * 0587 210 IF(KLNGNS.EQ.0)GO TO 330 0588 IF(NSTARS.EQ.0)GO TO 230 0589 DO 220 I=1,KLNGNS 0590 IF(XKL(I,1).EQ.0.)GO TO 220 0591 DO 225 J=1,NSTARS 0592 IF(STARS(J,1).EQ.0.)GO TO 225 0593 IF(RANGE(XKL(I,1),STARS(J,1),XKL(I,2),STARS(J,2)).GT.RAD(I))GO TO 0594 1225 0595 WRITE(6,1)LETR(1),LETR(3),I 0596 IF(RAN(IZZ).GT.SNOVAP)GO TO 224 0597 NS=J 0598 GO TO 1101 0599 224 CALL DLETE(3,I) 0600 CALL DLETE(1,J) 0601 225 CONTINUE 0602 220 CONTINUE 0603 C ...K WITH K. 0604 230 IF(KLNGNS.LE.1)GO TO 250 0605 DO 240 I=1,KLNGNS 0606 IF(XKL(I,1).EQ.0.)GO TO 240 0607 DO 245 J=1,KLNGNS 0608 IF(XKL(J,1).EQ.0.)GO TO 245 0609 IF(J.EQ.I)GO TO 245 0610 IF(RANGE(XKL(I,1),XKL(J,1),XKL(I,2),XKL(J,2)).GT.RADKK)GO TO 245 0611 WRITE(6,5)LETR(3),I,LETR(3),J 0612 5 FORMAT(1X,A1,I1,'-',A1,I1,' COLLISION') 0613 CALL DLETE(3,I) 0614 CALL DLETE(3,J) 0615 245 CONTINUE 0616 240 CONTINUE 0617 C ...K WITH R. 0618 250 IF(KLNGNS.EQ.0)GO TO 330 0619 IF(NROM.EQ.0)GO TO 270 0620 DO 260 I=1,KLNGNS 0621 IF(XKL(I,1).EQ.0.)GO TO 260 0622 DO 265 J=1,NROM 0623 IF(XROM(J,1).EQ.0.)GO TO 265 0624 IF(RANGE(XKL(I,1),XROM(J,1),XKL(I,2),XROM(J,2)).GT.RADKR)GO TO 2650625 WRITE(6,5)LETR(3),I,LETR(4),J 0626 CALL DLETE(3,I) 0627 CALL DLETE(4,J) 0628 265 CONTINUE 0629 260 CONTINUE 0630 C ...K WITH G. 0631 270 IF(KLNGNS.EQ.0)GO TO 330 0632 DO 280 I=1,KLNGNS 0633 IF(XKL(I,1).EQ.0.)GO TO 280 0634 IF(IGH.EQ.0)GO TO 290 0635 IF(RANGE(XKL(I,1),GHOST(1),XKL(I,2),GHOST(2)).GT.RADKG)GO TO 280 0636 WRITE(6,1)LETR(5),LETR(3),I 0637 CALL DLETE(3,I) 0638 CALL DLETE(5,1) 0639 280 CONTINUE 0640 C ...K WITH B. 0641 290 IF(KLNGNS.EQ.0)GO TO 330 0642 IF(IBASE.EQ.0)GO TO 310 0643 DO 300 I=1,KLNGNS 0644 IF(XKL(I,1).EQ.0.)GO TO 300 0645 IF(RANGE(XKL(I,1),BASE(1),XKL(I,2),BASE(2)).GT.RADKB)GO TO 300 0646 WRITE(6,1)LETR(6),LETR(3),I 0647 CALL DLETE(3,I) 0648 CALL DLETE(6,1) 0649 IF(IDOCK.EQ.2)IDOCK=0 0650 300 CONTINUE 0651 C ...K WITH T. 0652 310 IF(KLNGNS.EQ.0)GO TO 330 0653 IF(NTORPS.EQ.0)GO TO 326 0654 DO 320 I=1,KLNGNS 0655 IF(XKL(I,1).EQ.0.)GO TO 320 0656 DO 325 J=1,NTORPS 0657 IF(TORPS(J,1).EQ.0.)GO TO 325 0658 IF(RANGE(XKL(I,1),TORPS(J,1),XKL(I,2),TORPS(J,2)).GT.RADKT)GO TO 30659 125 0660 IF(TORPS(J,4).LT.360..AND.TORPS(J,4).GE.0.)GO TO 325 0661 WRITE(6,6)LETR(7),LETR(3),I,XKL(I,1),XKL(I,2) 0662 6 FORMAT(1X,A1,' HIT ON ',A1,I1,' AT ',F4.1,',',F4.1) 0663 CALL DLETE(3,I) 0664 CALL DLETE(7,J) 0665 325 CONTINUE 0666 320 CONTINUE 0667 C ...K WITH BLACK HOLE. 0668 326 IF(IHOLE.EQ.0)GO TO 330 0669 DO 327 I=1,KLNGNS 0670 IF(XKL(I,1).EQ.0.)GO TO 327 0671 IF(RANGE(XKL(I,1),FLOAT(IHOLE),XKL(I,2),FLOAT(JHOLE)).GT.HOLRAD)GO0672 1 TO 327 0673 KCE=IBL(ICE,JCE)/100 0674 LCE=IBL(ICE,JCE)-KCE*100 0675 M=JGAL(KCE,LCE) 0676 WRITE(6,3261)LETR(3),I 0677 3261 FORMAT(1X,A1,I1,' CAPTURED BY BLACK HOLE') 0678 IF(M-M/1000*1000.LT.900)GO TO 3263 0679 CALL DLETE(3,I) 0680 GO TO 3265 0681 3263 WRITE(6,3262)KCE,LCE 0682 3262 FORMAT(' ESCAPED TO QUADRANT ',I2,',',I2) 0683 JGAL(ICE,JCE)=JGAL(ICE,JCE)-100 0684 IF(IDMG(6).EQ.0.OR.IDMG(7).EQ.0)IGAL(ICE,JCE)=JGAL(ICE,JCE) 0685 JGAL(KCE,LCE)=M+100 0686 3265 J J=I 0687 IF(ITRMEN(JJ+1).EQ.0)GO TO 97531 0688 IF(XKL(I,1).EQ.0.)GO TO 97532 0689 WRITE(6,97530)ITRMEN(JJ+1) 0690 97530 FORMAT(I4,' TROOPS CAPTURED BY ENEMY') 0691 GO TO 97533 0692 97532 WRITE(6,97534)ITRMEN(JJ+1) 0693 97534 FORMAT(I4,' TROOPS ON BOARD LOST') 0694 97533 ITRMEN(JJ+1)=0 0695 IF(ISTAT.EQ.0)GO TO 97531 0696 C ...STOP BEAMING. 0697 IF(JUP.EQ.3.AND.JFROM.EQ.JJ.OR.JDOWN.EQ.3.AND.JTO.EQ.JJ)ISTAT=99990698 97531 ICNTL(JJ+1)=0 0699 XKL(JJ,1)=0. 0700 327 CONTINUE 0701 C ...T WITH *. 0702 330 IF(NTORPS.EQ.0)GO TO 440 0703 IF(NSTARS.EQ.0)GO TO 350 0704 DO 340 I=1,NTORPS 0705 IF(TORPS(I,1).EQ.0.)GO TO 340 0706 DO 345 J=1,NSTARS 0707 IF(STARS(J,1).EQ.0.)GO TO 345 0708 IF(RANGE(TORPS(I,1),STARS(J,1),TORPS(I,2),STARS(J,2)).GT. RA0709 1D(I))GO TO 345 0710 IF(RAN(IZZ).GT.SNOVAP)GO TO 344 0711 NS=J 0712 GO TO 1101 0713 344 CALL DLETE(7,I) 0714 CALL DLETE(1,J) 0715 IF(NROM.EQ.0)GO TO 345 0716 IF(TORPS(I,4).GE.360..OR.TORPS(I,4).LT.0.)GO TO 345 0717 IF(RAN(IZZ).GT.PRORAS)GO TO 345 0718 WRITE(6,341) 0719 341 FORMAT(' OUTRAGED ALIENS DESTROY EVERY ROMULAN IN QUADRANT'/ 0720 1' IN RETALIATION FOR DESTRUCTION OF THEIR STAR SYSTEM!') 0721 DO 342 K=1,NROM 0722 IF(XROM(K,1).EQ.0.)GO TO 342 0723 CALL DLETE(4,K) 0724 342 CONTINUE 0725 345 CONTINUE 0726 340 CONTINUE 0727 C ...T WITH R. 0728 350 IF(NTORPS.EQ.0)GO TO 440 0729 IF(NROM.EQ.0)GO TO 370 0730 DO 360 I=1,NTORPS 0731 IF(TORPS(I,1).EQ.0.)GO TO 360 0732 DO 355 J=1,NROM 0733 IF(XROM(J,1).EQ.0.)GO TO 355 0734 IF(RANGE(TORPS(I,1),XROM(J,1),TORPS(I,2),XROM(J,2)).GT.RADTR) 0735 1 GO TO 355 0736 IF(TORPS(I,4).LT.360.AND.TORPS(I,4).GE.0.)GO TO 355 0737 IF(ICNTL(J+10).EQ.1.AND.TORPS(I,4).LT.0.)GO TO 355 0738 WRITE(6,6)LETR(7),LETR(4),J,XROM(J,1),XROM(J,2) 0739 CALL DLETE(4,J) 0740 CALL DLETE(7,I) 0741 355 CONTINUE 0742 360 CONTINUE 0743 C ...T WITH G. 0744 370 IF(NTORPS.EQ.0)GO TO 440 0745 IF(IGH.EQ.0)GO TO 390 0746 DO 380 I=1,NTORPS 0747 IF(TORPS(I,1).EQ.0.)GO TO 380 0748 X=RANGE(TORPS(I,1),GHOST(1),TORPS(I,2),GHOST(2) ) 0749 IF(X.GT.RADGT)GO TO 380 0750 C ...G FIRED T CAN'T HURT G. 0751 IF(TORPS(I,4).GE.360.)GO TO 380 0752 WRITE(6,3)LETR(7),LETR(5) 0753 CALL DLETE(7,I) 0754 Y=AMAX1(TPMIN,(1.-X**2/RADGT**2)*TPOWR) 0755 GHOST(13)=GHOST(13)-Y 0756 IF(GHOST(13).GE.0.)GO TO 380 0757 Y=GHOST(13) 0758 GHOST(13)=0. 0759 GHOST(3)=GHOST(3)-Y 0760 IF(GHOST(3).LT.XGHIT)GO TO 380 0761 CALL DLETE(5,1) 0762 GO TO 390 0763 380 CONTINUE 0764 C ...T WITH B. 0765 390 IF(NTORPS.EQ.0)GO TO 440 0766 IF(IBASE.EQ.0)GO TO 410 0767 DO 400 I=1,NTORPS 0768 IF(TORPS(I,1).EQ.0.)GO TO 400 0769 X=RANGE(TORPS(I,1),BASE(1),TORPS(I,2),BASE(2) ) 0770 IF(X.GT.RADBT)GO TO 400 0771 CALL DLETE(7,I) 0772 400 CONTINUE 0773 C ...T WITH T. 0774 410 IF(NTORPS.EQ.0)GO TO 440 0775 DO 420 I=1,NTORPS 0776 IF(TORPS(I,1).EQ.0.)GO TO 420 0777 DO 425 J=1,NTORPS 0778 IF(TORPS(J,1).EQ.0.)GO TO 425 0779 IF(J.EQ.I)GO TO 425 0780 IF(RANGE(TORPS(I,1),TORPS(J,1),TORPS(I,2),TORPS(J,2)).GT.RADTT 0781 1 )GO TO 425 0782 IF(RAN(IZZ).GT.PCTCOL)GO TO 425 0783 IF(TORPS(I,4).LT.0..AND.TORPS(J,4).LT.0.)GO TO 425 0784 WRITE(6,7)LETR(7),LETR(7) 0785 7 FORMAT(1X,A1,'-',A1,' COLLISION') 0786 CALL DLETE(7,I) 0787 CALL DLETE(7,J) 0788 425 CONTINUE 0789 420 CONTINUE 0790 C ...T WITH HOLE. 0791 IF(NTORPS.EQ.0)GO TO 440 0792 IF(IHOLE.EQ.0)GO TO 440 0793 DO 430 I=1,NTORPS 0794 IF(TORPS(I,1).EQ.0.)GO TO 430 0795 IF(RANGE(TORPS(I,1),FLOAT(IHOLE),TORPS(I,2),FLOAT(JHOLE)).GT.HOLRA0796 1D)GO TO 430 0797 CALL DLETE(7,I) 0798 430 CONTINUE 0799 C ...G WITH *. 0800 440 IF(IGH.EQ.0)GO TO 999 0801 IF(NSTARS.EQ.0)GO TO 460 0802 DO 450 I=1,NSTARS 0803 IF(STARS(I,1).EQ.0.)GO TO 450 0804 IF(RANGE(STARS(I,1),GHOST(1),STARS(I,2),GHOST(2)).GT.RAD(I)) 0805 1GO TO 450 0806 WRITE(6,1)LETR(5),LETR(1),I 0807 IF(RAN(IZZ).GT.SNOVAP)GO TO 445 0808 NS=I 0809 GO TO 1101 0810 445 CALL DLETE(1,I) 0811 CALL DLETE(5,1) 0812 GO TO 999 0813 450 CONTINUE 0814 C ...G WITH R. 0815 460 IF(NROM.EQ.0)GO TO 480 0816 DO 470 I=1,NROM 0817 IF(XROM(I,1).EQ.0.)GO TO 470 0818 IF(RANGE(XROM(I,1),GHOST(1),XROM(I,2),GHOST(2)).GT.RADGR) GO 0819 1TO 470 0820 WRITE(6,1)LETR(5),LETR(4),I 0821 CALL DLETE(4,I) 0822 CALL DLETE(5,1) 0823 GO TO 999 0824 470 CONTINUE 0825 C ...G WITH B. 0826 480 IF(IBASE.EQ.0)GO TO 490 0827 IF(RANGE(GHOST(1),BASE(1),GHOST(2),BASE(2)).GT.RADGB) GO TO 90828 199 0829 WRITE(6,7)LETR(5),LETR(6) 0830 CALL DLETE(6,1) 0831 CALL DLETE(5,1) 0832 IF(IDOCK.EQ.2)IDOCK=0 0833 C ...G WITH HOLE. 0834 490 IF(IHOLE.EQ.0)GO TO 999 0835 IF(RANGE(GHOST(1),FLOAT(IHOLE),GHOST(2),FLOAT(JHOLE)).GT.HOLRAD)GO0836 1 TO 999 0837 CALL DLETE(5,1) 0838 999 RETURN 0839 END 0840