home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / REPAIR.FOR < prev    next >
Encoding:
Text File  |  1986-12-15  |  8.7 KB  |  124 lines
  1.       SUBROUTINE REPAIR                                                 3684
  2.  
  3. c    include 'tcommon.for'
  4.     %include tcommon.for
  5.  
  6.     character*8 deflec
  7.       DATA TRKL,TRRM/1.7,2.1/                                           3716
  8.  
  9. c
  10. c    n.b. idtk may be a local variable with a name corresponding
  11. c    to a common block variable - be prepared to change it!
  12.  
  13.       ITDK=0
  14. C     ...DAMAGE REPAIR SECTION                                          3718
  15.       data DEFLEC/'DFLECTRS'/
  16. 2800  FACTR=1.                                                          3719
  17.       IF(ITRUCE.EQ.1)FACTR=TFACTR                                       3720
  18.       IF(PSP.GE.1.)GO TO 2840                                           3721
  19. C     ...KLINGON REPAIR.                                                3722
  20.       IF(KLNGNS.EQ.0)GO TO 2820                                         3723
  21.       DO 2810    J=1,KLNGNS                                             3724
  22.       IF(XKL(J,1).EQ.0.)GO TO 2810                                      3725
  23.       IF(ICNTL(J+1).EQ.1)GO TO 2805                                     3726
  24.       XKL(J,7)=XKL(J,7)-RPRKL*FACTR *XKL(J,9)/CREWK                     3727
  25.       GO TO 2806                                                        3728
  26. C     ...SLOWER IF UNDER E CONTROL.                                     3729
  27. 2805  XKL(J,7)=XKL(J,7)-RPRKL*FACTR*ITRMEN(J+1)/CREWK/TRKL              3730
  28. 2806  IF(XKL(J,7).LT.0.)XKL(J,7)=0.                                     3731
  29. 2810  CONTINUE                                                          3732
  30. 2820  IF(NROM.EQ.0)GO TO 2840                                           3733
  31. C     ...ROMULAN REPAIR.                                                3734
  32.       DO 2830    J=1,NROM                                               3735
  33.       IF(XROM(J,1).EQ.0.)GO TO 2830                                     3736
  34.       IF(ICNTL(J+10).EQ.1)GO TO 2835                                    3737
  35.       XROM(J,3)=XROM(J,3)-RPRRM*FACTR   *CREWR(J)/SCREWR                3738
  36.       GO TO 2836                                                        3739
  37. C     ...SLOWER IF UNDER E CONTROL.                                     3740
  38. 2835  XROM(J,3)=XROM(J,3)-RPRRM*FACTR*ITRMEN(J+10)/SCREWR/TRRM          3741
  39. 2836  IF(XROM(J,3).LT.0.)XROM(J,3)=0.                                   3742
  40. 2830  CONTINUE                                                          3743
  41. C     ...E DAMAGE REPAIR BY CREW.                                       3744
  42. 2840  XTRP=0.                                                           3745
  43.       JTRP=0                                                            3746
  44.       DO 2850 J=1,10                                                    3747
  45.       IF(IDMG(J).EQ.0)GO TO 2850                                        3748
  46.       XTRP=XTRP+IPROB1(J)                                               3749
  47.       JTRP=JTRP+1                                                       3750
  48. 2850  CONTINUE                                                          3751
  49.       IF(JTRP.EQ.0)GO TO 2860                                           3752
  50.       XTRP=(100.-XTRP)/JTRP                                             3753
  51.       DO 2855 K=1,10                                                    3754
  52.       IF(IDMG(K).EQ.0)GO TO 2855                                        3755
  53.       IF(RAN(IZZ).GT.FLOAT(MEN)/FLOAT(NMEN)*(IPROB1(K)+XTRP)/100.)      3756
  54.      1  GO TO 28                                                        3757
  55.      155                                                                3758
  56.       IDMG(K)=IDMG(K)-FACTR*ERPRRT                                      3759
  57.       IF(IDMG(K).GT.0)GO TO 2855                                        3760
  58.       IDMG(K)=0                                                         3761
  59.       IF(K.EQ.1)IHWARP=0                                                3762
  60.       write(*,2856)NAMD(K)                                              3763
  61. 2856  FORMAT(1X,A10,' REPAIRED!')                                       3764
  62. 2855  CONTINUE                                                          3765
  63. C     ...G DAMAGE REPAIR BY E TROOPS.                                   3766
  64. 2860  IF(IGH.EQ.0.OR.ICNTL(20).NE.1)GO TO 2900                          3767
  65.       FIXR=FLOAT(ITRMEN(20))/FLOAT(MXCRGH)*TFACTR                       3768
  66.       GHOST(3)=GHOST(3)-RPRGH*FACTR*FIXR                                3769
  67.       IF(GHOST(3).LT.0.)GHOST(3)=0.                                     3770
  68.       IF(IGHPH.EQ.1)GO TO 2881                                          3771
  69.       IF(RAN(IZZ).GT.FIXR*PPHASD*PPHASD)GO TO 2881                      3772
  70.       write(*,2885)LETR(5),NAMD(3)                                      3773
  71. 2885  FORMAT(1X,A1,1X,A10,' REPAIRED')                                  3774
  72.       IGHPH=1                                                           3775
  73.       GO TO 2900                                                        3776
  74. 2881  IF(RAN(IZZ).GT.FIXR*PTORPD*PTORPD)GO TO 2882                      3777
  75.       IF(IGHTR.EQ.1)GO TO 2882                                          3778
  76.       write(*,2885)LETR(5),NAMD(4)                                      3779
  77.       IGHTR=1                                                           3780
  78.       GO TO 2900                                                        3781
  79. 2882  IF(RAN(IZZ).GT.FIXR*PDRVD*PDRVD)GO TO 2883                        3782
  80.       IF(IGHDR.EQ.1)GO TO 2883                                          3783
  81.       write(*,2885)LETR(5),NAMD(2)                                      3784
  82.       IGHDR=1                                                           3785
  83.       GO TO 2900                                                        3786
  84. 2883  IF(RAN(IZZ).GT.FIXR*PDEFD*PDEFD)GO TO 2900                        3787
  85.       IF(IGHDE.EQ.1)GO TO 2900                                          3788
  86.       write(*,2885)LETR(5),DEFLEC                                       3789
  87.       IGHDE=1                                                           3790
  88. C     ...DISEASE ACTIVE AREA.                                           3791
  89. 2900  IF(IDSES.EQ.0)GO TO 2929                                          3792
  90. 45    KLED=MULTK1*VDSES*RAN(IZZ)*FLOAT(MEN+ITRMEN(1))/FLOAT(NMEN+IFGHTM)3793
  91.       KKLED=RAN(IZZ)*KLED                                               3794
  92.       LKLED=MIN0(KLED-KKLED,MEN)                                        3795
  93.       KKLED=MIN0(KLED-LKLED,ITRMEN(1))                                  3796
  94.       KLED=LKLED+KKLED                                                  3797
  95.       MEN=MEN-LKLED                                                     3798
  96.       ITRMEN(1)=ITRMEN(1)-KKLED                                         3799
  97.       IF(ITRMEN(1).LT.0)ITRMEN(1)=0                                     3800
  98.       IF(KLED.EQ.0)GO TO 55                                             3801
  99.       write(*,2901)                                                     3802
  100. 2901  FORMAT(' DISEASE LOSSES -')                                       3803
  101.       IF(MEN.GT.6)GO TO 50                                              3804
  102.       CALL RATING(5)                                                    3805
  103. 50    write(*,2)KLED,MEN, ITRMEN(1)                                     3806
  104.       ITDK=ITDK+KLED                                                    3807
  105. 2     FORMAT(' MEN KILLED: ',I4,' CREW LEFT: ',I4,' TROOPS LEFT: ',I4)  3808
  106. 55    IF(RAN(IZZ).GT.VSTRDS)GO TO 2929                                  3809
  107.       IDSES=0                                                           3810
  108.       write(*,2802)ITDK                                                 3811
  109. 2802  FORMAT(' DISEASE CURE FOUND AFTER ',I3,' FATALITIES ')            3812
  110.       ITDK=0                                                            3813
  111. C     ...ALIEN BEINGS DRAINING E ENERGY BANKS.                          3814
  112. 2929  IF(IALSS.EQ.0)GO TO 3000                                          3815
  113.       IF(IALIC.NE.ICE.OR.IALJC.NE.JCE)GO TO 2950                        3816
  114.       IF(NSTARS.EQ.0.OR.STARS(IALSS,1).EQ.0.)GO TO 2950                 3817
  115.       ENERGY=ENERGY-ALEDR                                               3818
  116.       IF(ENERGY.LE.0.)CALL RATING(2)                                    3819
  117.       GO TO 3000                                                        3820
  118. 2950  IALSS=0                                                           3821
  119. C     ...USING UP CLOAKING DEVICE FREE TIME.                            3822
  120. 3000  IF(ICLOAK.GE.0)GO TO 3100                                         3823
  121.       ICLOAK=ICLOAK+1                                                   3824
  122. 3100  RETURN                                                            3825
  123.       END                                                               3826
  124.