
      SUBROUTINE BEAM                                                   0103

c	include 'tcommon.for'
	%include tcommon.for

      IF(IDMG(8).NE.0)GO TO 998                                         0129
      IUP=JUP-2                                                         0130
      IDOWN=JDOWN-2                                                     0131
      KNDX=(JUP-3)*9+JFROM+1                                            0132
      LNDX=(JDOWN-3)*9+JTO+1                                            0133
C     ...THIS IS A FUDGE TO INDEX IBMENR VIA ITRMEN ARRAY               0134
      IF(JUP.EQ.6)KNDX=26                                               0135
      IF(JUP.EQ.2)KNDX=1                                                0136
      IF(JDOWN.EQ.2)LNDX=1                                              0137
      IF(ISTAT.EQ.9999)GO TO 998                                        0138
C     ...CHECK IF FROM OBJ STILL THERE                                  0139
99    GO TO (100,200,300,400),IUP                                       0140
      X1=XQE                                                            0141
      Y1=YQE                                                            0142
      GO TO 500                                                         0143
100   IF(JFROM.GT.KLNGNS)GO TO 998                                      0144
      IF(XKL(JFROM,1).EQ.0.)GO TO 998                                   0145
      IF(ITRUCE.EQ.1.AND.ICNTL(JFROM+1).NE.1)GO TO 1000                 0146
      X1=XKL(JFROM,1)                                                   0147
      Y1=XKL(JFROM,2)                                                   0148
      GO TO 500                                                         0149
200   IF(JFROM.GT.NROM)GO TO 998                                        0150
      IF(XROM(JFROM,1).EQ.0.)GO TO 998                                  0151
      IF(ITRUCE.EQ.1.AND.ICNTL(JFROM+10).NE.1)GO TO 1000                0152
      X1=XROM(JFROM,1)                                                  0153
      Y1=XROM(JFROM,2)                                                  0154
      GO TO 500                                                         0155
300   IF(IGH.EQ.0)GO TO 998                                             0156
      KNDX=20                                                           0157
      X1=GHOST(1)                                                       0158
      Y1=GHOST(2)                                                       0159
      GO TO 500                                                         0160
400   IF(IBASE.EQ.0)GO TO 998                                           0161
      X1=BASE(1)                                                        0162
      Y1=BASE(2)                                                        0163
C     ...CHECK IF TO OBJ STILL THERE                                    0164
500   GO TO (110,210,310,998),IDOWN                                     0165
      X2=XQE                                                            0166
      Y2=YQE                                                            0167
      GO TO 510                                                         0168
110   IF(JTO.GT.KLNGNS)GO TO 998                                        0169
      IF(XKL(JTO,1).EQ.0.)GO TO 998                                     0170
      IF(ITRUCE.EQ.1.AND.ICNTL(JTO+1).NE.1)GO TO 1000                   0171
      X2=XKL(JTO,1)                                                     0172
      Y2=XKL(JTO,2)                                                     0173
      GO TO 510                                                         0174
210   IF(JTO.GT.NROM)GO TO 998                                          0175
      IF(XROM(JTO,1).EQ.0.)GO TO 998                                    0176
      IF(ITRUCE.EQ.1.AND.ICNTL(JTO+10).NE.1)GO TO 1000                  0177
      X2=XROM(JTO,1)                                                    0178
      Y2=XROM(JTO,2)                                                    0179
      GO TO 510                                                         0180
310   IF(IGH.EQ.0)GO TO 998                                             0181
      ICNTL(20)=1                                                       0182
      LNDX=20                                                           0183
      X2=GHOST(1)                                                       0184
      Y2=GHOST(2)                                                       0185
C     ...MAX OF IDAMRP MEN CAN TRANSPORT AT ONCE.                       0186
510   NBEAM=MIN0(IDAMRP,ISTAT,ITRMEN(KNDX))                             0187
      ITRMEN(KNDX)=ITRMEN(KNDX)-NBEAM                                   0188
      ITRMEN(LNDX)=ITRMEN(LNDX)+NBEAM                                   0189
525   ISTAT=ISTAT-NBEAM                                                 0190
C     ...CUMULATE TOTAL NO. OF MEN BEAMED                               0191
      ITBEAM=ITBEAM+NBEAM                                               0192
      ENERGY=ENERGY-NBEAM*TRNRGY*RANGE(X1,X2,Y1,Y2)                     0193
      IF(ENERGY.LE.0.)CALL RATING(2)                                    0194
      IF(ISTAT.NE.0.AND.ITRMEN(KNDX).NE.0)GO TO 1000                    0195
      WRITE(6,1)ITBEAM                                                  0196
1     FORMAT(' TRANSPORT COMPLETE ',I4,' MEN BEAMED OVER')              0197
      IF(JJSTAT.LE.0)GO TO 540                                          0198
530   CALL DLETE(JUP,JFROM)                                             0199
      JJSTAT=0                                                          0200
540   ITBEAM=0                                                          0201
      ISTAT=0                                                           0202
      IF(JJSTAT.EQ.0)GO TO 1000                                         0203
      WRITE(6,3)                                                        0204
3     FORMAT(' TRANSPORTERS REENERGIZED')                               0205
      KNDX=(JJUP-3)*9+JJFROM+1                                          0206
      ISTAT=ITRMEN(KNDX)                                                0207
      JUP=JJUP                                                          0208
      JFROM=JJFROM                                                      0209
      JTO=JJTO                                                          0210
      JDOWN=JJDOWN                                                      0211
      JJSTAT=1                                                          0212
      IF(ISTAT.EQ.0)GO TO 530                                           0213
      GO TO 1000                                                        0214
C     ...TRANSPORT AUTOMATICALLY STOPPED IF TO OR FROM OBJ MISSING.     0215
998   WRITE(6,2)ITBEAM                                                  0216
2     FORMAT(' TRANSPORTING STOPPED AFTER ',I4,' MEN')                  0217
      JJSTAT=0                                                          0218
      GO TO 540                                                         0219
1000  RETURN                                                            0220
      END                                                               0221
20 
30098 ITM=ITM+ITRMEN(J)         