home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / FORTRAN / SUPERT87.ZIP / BEAM.FOR < prev    next >
Encoding:
Text File  |  1986-12-15  |  7.2 KB  |  100 lines
  1.  
  2.       SUBROUTINE BEAM                                                   0103
  3.  
  4. c    include 'tcommon.for'
  5.     %include tcommon.for
  6.  
  7.       IF(IDMG(8).NE.0)GO TO 998                                         0129
  8.       IUP=JUP-2                                                         0130
  9.       IDOWN=JDOWN-2                                                     0131
  10.       KNDX=(JUP-3)*9+JFROM+1                                            0132
  11.       LNDX=(JDOWN-3)*9+JTO+1                                            0133
  12. C     ...THIS IS A FUDGE TO INDEX IBMENR VIA ITRMEN ARRAY               0134
  13.       IF(JUP.EQ.6)KNDX=26                                               0135
  14.       IF(JUP.EQ.2)KNDX=1                                                0136
  15.       IF(JDOWN.EQ.2)LNDX=1                                              0137
  16.       IF(ISTAT.EQ.9999)GO TO 998                                        0138
  17. C     ...CHECK IF FROM OBJ STILL THERE                                  0139
  18. 99    GO TO (100,200,300,400),IUP                                       0140
  19.       X1=XQE                                                            0141
  20.       Y1=YQE                                                            0142
  21.       GO TO 500                                                         0143
  22. 100   IF(JFROM.GT.KLNGNS)GO TO 998                                      0144
  23.       IF(XKL(JFROM,1).EQ.0.)GO TO 998                                   0145
  24.       IF(ITRUCE.EQ.1.AND.ICNTL(JFROM+1).NE.1)GO TO 1000                 0146
  25.       X1=XKL(JFROM,1)                                                   0147
  26.       Y1=XKL(JFROM,2)                                                   0148
  27.       GO TO 500                                                         0149
  28. 200   IF(JFROM.GT.NROM)GO TO 998                                        0150
  29.       IF(XROM(JFROM,1).EQ.0.)GO TO 998                                  0151
  30.       IF(ITRUCE.EQ.1.AND.ICNTL(JFROM+10).NE.1)GO TO 1000                0152
  31.       X1=XROM(JFROM,1)                                                  0153
  32.       Y1=XROM(JFROM,2)                                                  0154
  33.       GO TO 500                                                         0155
  34. 300   IF(IGH.EQ.0)GO TO 998                                             0156
  35.       KNDX=20                                                           0157
  36.       X1=GHOST(1)                                                       0158
  37.       Y1=GHOST(2)                                                       0159
  38.       GO TO 500                                                         0160
  39. 400   IF(IBASE.EQ.0)GO TO 998                                           0161
  40.       X1=BASE(1)                                                        0162
  41.       Y1=BASE(2)                                                        0163
  42. C     ...CHECK IF TO OBJ STILL THERE                                    0164
  43. 500   GO TO (110,210,310,998),IDOWN                                     0165
  44.       X2=XQE                                                            0166
  45.       Y2=YQE                                                            0167
  46.       GO TO 510                                                         0168
  47. 110   IF(JTO.GT.KLNGNS)GO TO 998                                        0169
  48.       IF(XKL(JTO,1).EQ.0.)GO TO 998                                     0170
  49.       IF(ITRUCE.EQ.1.AND.ICNTL(JTO+1).NE.1)GO TO 1000                   0171
  50.       X2=XKL(JTO,1)                                                     0172
  51.       Y2=XKL(JTO,2)                                                     0173
  52.       GO TO 510                                                         0174
  53. 210   IF(JTO.GT.NROM)GO TO 998                                          0175
  54.       IF(XROM(JTO,1).EQ.0.)GO TO 998                                    0176
  55.       IF(ITRUCE.EQ.1.AND.ICNTL(JTO+10).NE.1)GO TO 1000                  0177
  56.       X2=XROM(JTO,1)                                                    0178
  57.       Y2=XROM(JTO,2)                                                    0179
  58.       GO TO 510                                                         0180
  59. 310   IF(IGH.EQ.0)GO TO 998                                             0181
  60.       ICNTL(20)=1                                                       0182
  61.       LNDX=20                                                           0183
  62.       X2=GHOST(1)                                                       0184
  63.       Y2=GHOST(2)                                                       0185
  64. C     ...MAX OF IDAMRP MEN CAN TRANSPORT AT ONCE.                       0186
  65. 510   NBEAM=MIN0(IDAMRP,ISTAT,ITRMEN(KNDX))                             0187
  66.       ITRMEN(KNDX)=ITRMEN(KNDX)-NBEAM                                   0188
  67.       ITRMEN(LNDX)=ITRMEN(LNDX)+NBEAM                                   0189
  68. 525   ISTAT=ISTAT-NBEAM                                                 0190
  69. C     ...CUMULATE TOTAL NO. OF MEN BEAMED                               0191
  70.       ITBEAM=ITBEAM+NBEAM                                               0192
  71.       ENERGY=ENERGY-NBEAM*TRNRGY*RANGE(X1,X2,Y1,Y2)                     0193
  72.       IF(ENERGY.LE.0.)CALL RATING(2)                                    0194
  73.       IF(ISTAT.NE.0.AND.ITRMEN(KNDX).NE.0)GO TO 1000                    0195
  74.       WRITE(6,1)ITBEAM                                                  0196
  75. 1     FORMAT(' TRANSPORT COMPLETE ',I4,' MEN BEAMED OVER')              0197
  76.       IF(JJSTAT.LE.0)GO TO 540                                          0198
  77. 530   CALL DLETE(JUP,JFROM)                                             0199
  78.       JJSTAT=0                                                          0200
  79. 540   ITBEAM=0                                                          0201
  80.       ISTAT=0                                                           0202
  81.       IF(JJSTAT.EQ.0)GO TO 1000                                         0203
  82.       WRITE(6,3)                                                        0204
  83. 3     FORMAT(' TRANSPORTERS REENERGIZED')                               0205
  84.       KNDX=(JJUP-3)*9+JJFROM+1                                          0206
  85.       ISTAT=ITRMEN(KNDX)                                                0207
  86.       JUP=JJUP                                                          0208
  87.       JFROM=JJFROM                                                      0209
  88.       JTO=JJTO                                                          0210
  89.       JDOWN=JJDOWN                                                      0211
  90.       JJSTAT=1                                                          0212
  91.       IF(ISTAT.EQ.0)GO TO 530                                           0213
  92.       GO TO 1000                                                        0214
  93. C     ...TRANSPORT AUTOMATICALLY STOPPED IF TO OR FROM OBJ MISSING.     0215
  94. 998   WRITE(6,2)ITBEAM                                                  0216
  95. 2     FORMAT(' TRANSPORTING STOPPED AFTER ',I4,' MEN')                  0217
  96.       JJSTAT=0                                                          0218
  97.       GO TO 540                                                         0219
  98. 1000  RETURN                                                            0220
  99.       END                                                               0221
  100.