C======================================================================
C
C     TREK7 MODULE F
C CONVERTED TO PC BY: DAN GAHLINGER
C ENTIRE MODULE TYPE-EXACT CHECK 04/25/2000 BY: D.G.
C
C   SHIP DAMAGE ROUTINES
C
C BOOM    LIRPA   GRUP1   GRUP2   GRUP3   TPAU
C OXMYX   GOTU    GOTME   FORBIN  QUARK   POS
C
C======================================================================

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - BOOM
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE BOOM(J)
      COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP
      COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4)
      COMMON /G/ZAP(4),ICOLA(4),IROWA(4),LOCK(4),ICOIL(4)
      COMMON /H/ANGLE(4),RANG(4),LOCKT(4)
      COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25),
     *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES
      COMMON /M/MAP(60,60),IBLK,IENM1(8),IEE(4),IGLE,IM(4),III,ISTAR
      COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25)
      COMMON /S/IBPOB(8),IBPOE(25)
      COMMON /U/LAUNCH,NUMOUT,NUME(2)
      IF(ISTAT.EQ.2)GO TO 2
      MAP(IGLER(J),IGLEC(J))=IBLK
2     IGLER(J)=0
      IGLEC(J)=0
      NUMOUT=NUMOUT-1
      IF(IBPOE(J).EQ.0)GO TO 1
      IBPOE(J)=0
      II(IBPSE(J))=II(IBPSE(J))-1
      NUME(IBPSE(J))=NUME(IBPSE(J))-1
      IBPSE(J)=0
      RETURN
1     I3=I3-1
      RETURN
      END

C     -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C    - LIRPA
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      INTEGER FUNCTION LIRPA(AA,II)
      COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      LIRPA=ALOG((101.-AA)*II*II/DISTP)/0.700619195-6.605
      RETURN
      END

C     DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7
C CONVERTED TO PC BY: DAN GAHLINGER
C
C     - GRUP 1
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE GRUP1(IVV,MI)
      COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2)
      COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25)
      COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2)
      IVA=IXIF(IVV)
      CALL GOTME(IVA,MI)
      DFLCT(MI)=DFLCT(MI)-FLOAT(IVA)*1.6
      DO 350 I71=1,4
      IF(ICHOE(I71).EQ.0)GO TO 350
      IF(I71.EQ.IBPSC(MI))GO TO 350
      CALL GOTU(IVA,I71)
350   CONTINUE
      RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - GRUP2 -
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE GRUP2(IVV,MI)
      COMMON /B/NDEAB(2),IPHOB(2),IONB(2),IGOB(2),IFIB(2)
      COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2)
      COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2)
        COMMON /TOM/ITOM
      IVA=IXIF(IVV)
      DFLCB(MI)=DFLCB(MI)-FLOAT(IVA)*1.6
      DO 351 I71=1,4
      IF(ICHOE(I71).EQ.0)GO TO 351
      CALL GOTU(IVA,I71)
351   CONTINUE
      IGOB(MI)=1
      CALL RANDO(I8,IVA/2,IVA*2)
      NDEAB(MI)=NDEAB(MI)-I8
      IF(NDEAB(MI).LT.0)NDEAB(MI)=0
      IF(IVA.GT.2)IFIB(MI)=0
      RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - GRUP3 -
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE GRUP3(IVV,MI)
      COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2)
      COMMON /I/IONK(8),ISPOK(8),ION(4),ISPOT(4)
      COMMON /K/IWHO(8),DIST(8),KILLZ,KILLR,KILLD,KILLG,IGOCO(8)
      COMMON /S/IBPOB(8),IBPOE(25)
      COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2)
        COMMON /TOM/ITOM
      IVA=IVV
      IF(IONK(MI).EQ.1)IVA=IVV+2
      IVA=IXIF(IVA)
      DFLCK(MI)=DFLCK(MI)-FLOAT(IVA)*1.6
      DO 352 I71=1,4
      IF(ICHOE(I71).EQ.0)GO TO 352
      CALL GOTU(IVA,I71)
352   CONTINUE
      IF(IBPOB(MI).EQ.0)GO TO 374
      CALL RANDO(I8,IVA/2,IVA)
      IBPOB(MI)=IBPOB(MI)-I8
      IF(IBPOB(MI).GT.0)GO TO 374
      CALL TPAU(MI)
      CALL OXMYX
374   IF(MI.EQ.2)KILLR=2
      IF(MI.EQ.7)KILLD=2
      RETURN
      END

C DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - TPAU -
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE TPAU(J)
      COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP
      COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      COMMON /N/INAME(3,4),IENM2(4,8),ISIDE(3,2),IBASE(2)
      COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25)
      COMMON /S/IBPOB(8),IBPOE(25)
      COMMON/T/ICHOE(4),ICHOS(8),ICHOB(2)
      DO 142 IV=1,4
      IF(ICHOE(IV).EQ.0)GO TO 142
      I7=IV+4
      WRITE(I7,207)(IENM2(N,J),N=1,4)
207   FORMAT(' CONTROL OF THE ',4A4,' HAS BEEN LOST')
142   CONTINUE
      II(IBPSB(J))=II(IBPSB(J))-1
      IBPSB(J)=0
      IBPOB(7)=IBPOB(7)-1
      I3=I3+1
      IBPOB(J)=0
      RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - OXMYX -
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE OXMYX
      COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25)
      COMMON /V/IWEB(2),IWEBZ,INVIS(4)
      DO 133 N=1,2
      IF(IWEB(N).GT.4)GO TO 134
      IF(IBPSB(3*N).EQ.(IBPSC(IWEB(N))+1)/2)IWEB(N)=0
      GO TO 133
134   IF(IWEB(N).EQ.0)GO TO 133
      IF(IBPSB(3*N).EQ.IBPSB(IWEB(N)-4))IWEB(N)=0
133   CONTINUE
      RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - GOTU -
C TYPE-EXACT CHECK 04/25/2000 BY: D.G.
C
      SUBROUTINE GOTU(IVV,I71)
      L=I71+4
      GO TO (40,43,45,90,48,92,52,55,58,61,62),IVV+1
40    WRITE(L,42)
42    FORMAT(' NO DAMAGE')
      GO TO 50
43    WRITE(L,242)
242   FORMAT(' DAMAGE FACTOR 1- VERY LITTLE DAMAGE SUSTAINED')
      GO TO 50
45    WRITE(L,47)
47    FORMAT(' DAMAGE FACTOR 2- MINOR DAMAGE SUSTAINED')
      GO TO 50
90    WRITE(L,91)
91    FORMAT(' DAMAGE FACTOR 3- MINOR STRUCTURAL DAMAGE'/16X,'- THERE IS
     * A DENT IN THE VESSEL')
      GO TO 50
48    WRITE(L,51)
51    FORMAT(' DAMAGE FACTOR 4- VESSEL MODERATELY DAMAGED')
      GO TO 50
92    WRITE(L,93)
93    FORMAT(' DAMAGE FACTOR 5- LIFE SUPPORT SYSTEM BREAKDOWN IN PARTS
     * OF THE VESSEL')
      GO TO 50
52    WRITE(L,54)
54    FORMAT(' DAMAGE FACTOR 6- HEAVY INTERNAL DAMAGE TO VESSEL')
      GO TO 50
55    WRITE(L,57)
57    FORMAT(' DAMAGE FACTOR 7- HEAVY STRUCTURAL DAMAGE TO VESSEL')
      GO TO 50
58    WRITE(L,60)
60    FORMAT(' DAMAGE FACTOR 8- A NUMBER OF DECKS HAVE RUPTURED ON THE
     * VESSEL')
      GO TO 50
61    WRITE(L,63)
63    FORMAT(' DAMAGE FACTOR 9- THE VESSEL HAS BEEN ROCKED BY AN EXP
     *LOSION')
      GO TO 50
62    WRITE(L,64)
64    FORMAT(' DAMAGE FACTOR 10- VESSEL PARTIALLY DESTROYED')
50    RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 -
C CONVERTED TO PC BY: DAN GAHLINGER
C
C -GOTME -
C TYPE-EXACT CHECK 04/25/2000 BY: D.G.
C
      SUBROUTINE GOTME(IVL,IT)
      INTEGER POS
      COMMON /C/L,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      COMMON /D/DFLCT(4),DFLCK(8),DFLCB(2)
      COMMON /E/PHASR(4),TWARP(4),IPHOT(4),NDEAD(4),ISURR(4)
      COMMON /L/IENTR(4),IENTC(4),IKLNR(8),IKLNC(8),IGLER(25),IGLEC(25),
     *IBASR(2),IBASC(2),LI2(4),LI2R(5),LI2C(5),IGO(4),MINES
      COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4),
     *NOMOV(4)
      COMMON /R/IBPSC(4),IBPSB(8),IBPSS(2),IBPSE(25)
        COMMON /TOM/ITOM
      IVV=IVL
      IC=0
      JJ=0
      L=IBPSC(IT)+4
      IS=(IT+1)/2
      IF(IVV.EQ.0)GO TO 110
      IF(IVV.EQ.1)GO TO 112
113   IVVV=IVV-1
1130  DO 121 J=1,33
      IF(MA(IT,J).LT.IVVV)GO TO 111
121   CONTINUE
      IVV=IVV+1
      IF(IVV.LE.10)GO TO 113
      DFLCT(IT)=-1.
      GO TO 232
111   JJ=JJ+IFIX(FLOAT(IVVV+1)*1.6+0.5)
      IF(IVVV.EQ.IC)GO TO 200
      GO TO (114,120,1200,1212,130,137,145,155,156),IVVV
110   WRITE(L,42)
42    FORMAT(' NO DAMAGE')
      GO TO 232
112   WRITE(L,242)
242   FORMAT(' DAMAGE FACTOR 1- VERY LITTLE DAMAGE SUSTAINED')
      GO TO 232
114   CALL RANDO(J,1,3)
      IF(J.NE.3)GO TO 119
      WRITE(L,4005)
4005  FORMAT(' DAMAGE FACTOR 2- TOILETS HAVE BACKED UP IN')
      GO TO 200
119   WRITE(L,117)
117   FORMAT(' DAMAGE FACTOR 2- MINOR DAMAGE TO')
      GO TO 200
120   WRITE(L,1210)
1210  FORMAT('DAMAGE FACTOR 3- MINOR STRUCTURAL DAMAGE- THERE IS A DENT
     * IN')
      GO TO 200
1200  CALL RANDO(J,1,3)
      GO TO (123,50,4004),J
50    WRITE(L,51)
51    FORMAT(' DAMAGE FACTOR 4- POWER FAILURE IN')
      GO TO 200
4004  WRITE(L,4007)
4007  FORMAT(' DAMAGE FACTOR 4- THERE IS A BURST WATER MAIN IN')
      GO TO 200
123   WRITE(L,124)
124   FORMAT(' DAMAGE FACTOR 4- MODERATE DAMAGE TO')
      GO TO 200
1212  WRITE(L,1213)
1213  FORMAT(' DAMAGE FACTOR 5- LIFE SUPPORT SYSTEM BREAKDOWN IN')
      GO TO 200
130   WRITE(L,136)
136   FORMAT(' DAMAGE FACTOR 6- HEAVY DAMAGE TO')
      GO TO 200
137   WRITE(L,143)
143   FORMAT(' DAMAGE FACTOR 7- A FIRE HAS BROKEN OUT IN')
      GO TO 200
145   WRITE(L,153)
153   FORMAT(' DAMAGE FACTOR 8- AN EXPLOSION HAS OCCURRED IN')
      GO TO 200
155   WRITE(L,163)
163   FORMAT(' DAMAGE FACTOR 9- PARTIAL DESTRUCTION OF')
      GO TO 200
156   WRITE(L,173)
173   FORMAT(' DAMAGE FACTOR 10- DESTRUCTION OF')
200   CALL RANDO(IV,1,33)
      IF(MA(IT,IV).GE.IVVV)GO TO 200
      IF(MA(IT,IV).NE.0)GO TO 701
      MANUM(IT)=MANUM(IT)+1
701   IF(IVVV.NE.9)GO TO 70
      IF(IV.LT.29)GO TO 70
      IF(IV.GT.30)GO TO 70
      MANUM(IT)=MANUM(IT)-1
70    MA(IT,IV)=IVVV
      CALL FORBIN(IS,IV,L,' ')
      IC=IVVV
      CALL RANDO(IV,1,15)
      IVVV=IVVV*IV/9
      IF(IVVV.EQ.0)IVVV=1
      IVV=IVVV+1
      IF(IV.LE.9)GO TO 1130
402   IF(IT.EQ.1)CALL QUARK(L)
4015  IF(MA(IT,14).GT.K(IT,2))PHASR(IT)=PHASR(IT)-MA(IT,14)*300.
      IF(PHASR(IT).LT.0)PHASR(IT)=0.
      K(IT,2)=MA(IT,14)
      TWARP(IT)=TWARP(IT)-FLOAT(MA(IT,29)-K(IT,4))/2.
      TWARP(IT)=TWARP(IT)-FLOAT(MA(IT,30)-K(IT,5))/2.
      K(IT,4)=MA(IT,29)
      K(IT,5)=MA(IT,30)
      IF(MA(IT,28).LT.4.OR.K(IT,6).GE.4)GO TO 657
      TWARP(IT)=TWARP(IT)-1.
      K(IT,6)=MA(IT,28)
657   IF(TWARP(IT).LT.0)TWARP(IT)=0
      J=0
      IF(IS.EQ.2)GO TO 100
      IF(IT.NE.1)GO TO 5000
      IF(K(1,10).GT.4.OR.MA(1,7).LE.4)GO TO 5000
      J=1
      WRITE(L,4010)
4010  FORMAT(' DR. MCCOY IS DEAD JIM')
C ORIGINALLY IT SAID DR. MCCOY HAS CROAKED - CHANGED NOV. 15/1999
5000  IPHOT(IT)=IPHOT(IT)-IFIX(FLOAT(IPHOT(IT))*FLOAT(MA(IT,3)-K(IT,14))
     */12.)
      K(IT,14)=MA(IT,3)
      IF(MA(IT,8).LT.4.OR.K(IT,3).EQ.1)GO TO 215
      K(IT,3)=1
      WRITE(L,4009)
4009  FORMAT(' CPU SYSTEM 2 HAS BEEN INITIALIZED AND IS TAKING OVER'/
     *' THE FUNCTIONS OF THE DISABLED CPU UNIT')
215   IF(MA(IT,23).GT.K(IT,1))DFLCT(IT)=DFLCT(IT)-(MA(IT,23)-K(IT,1))*3
      K(IT,1)=MA(IT,23)
      JJ=JJ+2*POS(MA(IT,4)-K(IT,7))+3*POS(MA(IT,5)-K(IT,8))
     *+22*POS(MA(IT,6)-K(IT,9))+12*POS(MA(IT,7)-K(IT,10))
     *+3*POS(MA(IT,21)-K(IT,11))+3*POS(MA(IT,22)-K(IT,12))
     *+2*POS(MA(IT,23)-K(IT,13))
      K(IT, 7)=MA(IT, 4)
      K(IT, 8)=MA(IT, 5)
      K(IT, 9)=MA(IT, 6)
      K(IT,10)=MA(IT, 7)
      K(IT,11)=MA(IT,21)
      K(IT,12)=MA(IT,22)
      K(IT,13)=MA(IT,23)
      NOMAP(IT)=15-MA(IT,33)
      GO TO 500
100   IPHOT(IT)=IPHOT(IT)-FLOAT(IPHOT(IT)*(MA(IT,29)+MA(IT,30)-
     *K(IT,14)))/24
      K(IT,14)=MA(IT,29)+MA(IT,30)
      IF(MA(IT,5).LT.4.OR.K(IT,3).EQ.1)GO TO 101
      K(IT,3)=1
      WRITE(L,4007)
101   IF(MA(IT,13).GT.K(IT,1))DFLCT(IT)=DFLCT(IT)-(MA(IT,13)-K(IT,1))*3
      K(IT,1)=MA(IT,13)
      JJ=JJ+I8*POS(MA(IT,8)-K(IT,7))+POS(MA(IT,10)-K(IT,8))+
     *2*POS(MA(IT,11)-K(IT,9))+4*POS(MA(IT,17)-K(IT,10))+
     *11*POS(MA(IT,19)-K(IT,11))+4*POS(MA(IT,21)-K(IT,12))+
     *9*POS(MA(IT,22)-K(IT,13))
      K(IT, 7)=MA(IT, 8)
      K(IT, 8)=MA(IT,10)
      K(IT, 9)=MA(IT,11)
      K(IT,10)=MA(IT,17)
      K(IT,11)=MA(IT,19)
      K(IT,12)=MA(IT,21)
      K(IT,13)=MA(IT,22)
      NOMAP(IT)=15-MA(IT,13)
500   CALL RANDO(IV,J,JJ)
      CALL RANDO(N,J,JJ)
      CALL RANDO(IC,0,JJ)
      CALL RANDO(IVVV,0,JJ)
      IF(N.GT.IV)IV=N
      NDEAD(IT)=NDEAD(IT)-IV
      IF(NDEAD(IT).GT.0)GO TO 5001
      IV=IV+NDEAD(IT)
      NDEAD(IT)=0
      IC=0
      IVVV=0
5001  IGO(IT)=0
      WRITE(L,406)IV,IC,IVVV
406   FORMAT('CASUALTIES-',I5,' KILLED',5X,I5,' WOUNDED',5X,I5,
     *' MAIMED')
232   CONTINUE
      RETURN
      END

C -- DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - FORBIN
C TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      SUBROUTINE FORBIN(J,I,L,NA)
      COMMON /W/IDEX(2,33,20)
      K=16
2     IF(IDEX(J,I,K).NE.'    ')GO TO 1
      K=K-1
      GO TO 2
1     WRITE(L,3)NA,(IDEX(J,I,M),M=1,K)
3     FORMAT(A1,1X,20A4)
      RETURN
      END

C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C CONVERTED TO PC BY: DAN GAHLINGER
C
C - QUARK -
C   TYPE-EXACT CHECK 04/25/2000 BY: D.G.
C
      SUBROUTINE QUARK(L)
      COMMON /A/IT,IS,II(2),IJ(2),I3,JS,ISHAK,NOSTOP
      COMMON /C/L1,A,B,I,NA,IV,I7,I8,N,DISTP,AJUST,MIN,ISTAT,JTK,KOENIG,
     *IGNORE,IO,IGOL(80)
      COMMON /O/MA(4,33),K(4,14),NOMAP(4),MANUM(4),HIVEL(4,2),ITEMP(4),
     *NOMOV(4)
      COMMON /T/ICHOE(4),ICHOS(8),ICHOB(2)
        COMMON /TOM/ITOM
      CALL RANDO(IV,1,35)
      IF(IV.GT.7)GO TO 4015
      GO TO(40152,4016,4018,40150,40151,40209,4021),IV
40152 WRITE(L,4017)
4017  FORMAT(' MR. SPOCK IS MAKING OBSCENE GESTURES BEHIND YOUR BACK')
      GO TO 4015
4016  WRITE(L,4019)
4019  FORMAT('SCOTTY IS MAKING RATHER DUBIOUS COMMENTS ABOUT
     *YOUR ANCESTRY')
      GO TO 4015
4018  WRITE(L,4020)
4020  FORMAT(' A MESSAGE HAS BEEN RECEIVED OVER SVB-SPACE RADIO. MESSAGE
     * AS FOLLOWS-'//25X,'--DIE FEDERATION PIGS--'//)
      GO TO 4015
40150 WRITE(L,40200)
40200 FORMAT(' THE ENTERPRISE''S PRIZE TURNIP HAS RUPTURED'/' DESTROYING
     * THE CREW''S MORALE')
      GO TO 4015
40151 IF(II(2)+ICHOS(1).EQ.0)GO TO 4015
      CALL RANDO(IVVV,1,30000)
      AJUST=63.*FLOAT(IVVV)
      WRITE(L,40201)AJUST
40201 FORMAT(' THE KLINGONS HAVE JUST BEAMED ABOARD ',F8.0,' TRIBBLES')
      GO TO 4015
40209 IF(K(1,10).GT.4)GO TO 4015
      WRITE(L,4022)
4022  FORMAT(' DR. MCCOY IS PASSING OUT THE CYANIDE TABLETS')
      GO TO 4015
4021  IF(K(1,10).GT.4)GO TO 4015
      WRITE(L,4023)
4023  FORMAT(' SPOCK HAS MADE DR. MCCOY AN HONOURARY VULCAN',/,' BY
     *STUFFING HIS EARS IN A PENCIL SHARPENER')
4015  RETURN
      END

C - DONALD ECCLESTONE SUBPROGRAM FOR T R E K 7 --
C
C CONVERTED TO PC BY: DAN GAHLINGER
C - POS -
C   TYPE-EXACT CHECK 04/24/2000 BY: D.G.
C
      INTEGER FUNCTION POS(I)
      POS=I
      IF(POS.LT.0)POS=0
      RETURN
      END
