      SUBROUTINE VENLNK
 
C-----------------------------------------------------------------------
C  VEN(US) L(I)NK (TO CORSIKA)
C
C  LINKS VENUS PACKAGE TO CORSIKA, NEEDS FIRST CALL OF VENINI
C  THIS SUBROUTINE IS CALLED FROM SDPM
C
C  DESIGN   : D. HECK    IK3  FZK KARLSRUHE
C-----------------------------------------------------------------------
 
*KEEP,INTER.
      COMMON /INTER/   AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN,
     *                 IDIF,ITAR
      DOUBLE PRECISION AVCH,AVCH3,DC0,DLOG,DMLOG,ECMDIF,ECMDPM,ELAB,
     *                 FNEUT,FNEUT2,GNU,PLAB,POSC2,POSC3,POSN2,POSN3,
     *                 RC3TO2,S,SEUGF,SEUGP,SLOG,SLOGSQ,SMLOG,
     *                 WIDC2,WIDC3,WIDN2,WIDN3,YCM,YY0,ZN
      INTEGER          IDIF,ITAR
*KEEP,PAM.
      COMMON /PAM/     PAMA,SIGNUM
      DOUBLE PRECISION PAMA(6000),SIGNUM(6000)
*KEEP,PARPAR.
      COMMON /PARPAR/  CURPAR,SECPAR,PRMPAR,OUTPAR,C,
     *                 E00,E00PN,PTOT0,PTOT0N,THICKH,ITYPE,LEVL
      DOUBLE PRECISION CURPAR(14),SECPAR(14),PRMPAR(14),OUTPAR(14),
     *                 C(50),E00,E00PN,PTOT0,PTOT0N,THICKH
      INTEGER          ITYPE,LEVL
*KEEP,PARPAE.
      DOUBLE PRECISION GAMMA,COSTHE,PHI,H,T,X,Y,CHI,BETA,GCM,ECM
      EQUIVALENCE      (CURPAR(2),GAMMA),  (CURPAR(3),COSTHE),
     *                 (CURPAR(4), PHI ),  (CURPAR(5), H    ),
     *                 (CURPAR(6), T   ),  (CURPAR(7), X    ),
     *                 (CURPAR(8), Y   ),  (CURPAR(9), CHI  ),
     *                 (CURPAR(10),BETA),  (CURPAR(11),GCM  ),
     *                 (CURPAR(12),ECM )
*KEEP,RANDPA.
      COMMON /RANDPA/  FAC,U1,U2,RD,NSEQ,ISEED,KNOR
      DOUBLE PRECISION FAC,U1,U2
      REAL             RD(3000)
      INTEGER          ISEED(103,10),NSEQ
      LOGICAL          KNOR
*KEEP,REST.
      COMMON /REST/    CONTNE,TAR,LT
      DOUBLE PRECISION CONTNE(3),TAR
      INTEGER          LT
*KEEP,RUNPAR.
      COMMON /RUNPAR/  FIXHEI,THICK0,HILOECM,HILOELB,
     *                 STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
     *                 MONIOU,MDEBUG,NUCNUC,
     *                 CETAPE,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE,
     *                 DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
      COMMON /RUNPAC/  DSN,HOST,USER
      DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
      REAL             STEPFC
      INTEGER          NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
     *                 SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
     *                 N1STTR,MDBASE
      INTEGER          CETAPE
      CHARACTER*79     DSN
      CHARACTER*20     HOST,USER
 
      LOGICAL          DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
     *                 FIX1I,FMUADD,FNKG,FPRINT,FDBASE
     *                ,GHEISH,GHESIG
*KEEP,VENUS.
      COMMON /VENUS/   ISH0,IVERVN,MTAR99,FVENUS,FVENSG
      INTEGER          ISH0,IVERVN,MTAR99
      LOGICAL          FVENUS,FVENSG
*KEND.
 
      PARAMETER (KOLLMX=2500)
      PARAMETER (MXEPS=10)
      PARAMETER (NDEP=129)
      PARAMETER (NDET=129)
      PARAMETER (NPRBMS=20)
      PARAMETER (NPTQ=129)
      PARAMETER (NSTRU=2049)
      COMMON /ACCUM/   AMSAC,ILAMAS,IMSG,INOIAC,IPAGE,JERR,NAEVT,NREVT
     *                ,NRPTL,NRSTR,NTEVT
      COMMON /CDEN/    MASSNR,RMX,R0
      COMMON /CIPIO/   IPIO
      COMMON /CNSTA/   AINFIN,PI,PIOM,PROM
      COMMON /COL/     BIMP,BMAX,COORD(4,KOLLMX),DISTCE(KOLLMX)
     *                ,QDEP(NDEP),QDET14(NDET),QDET16(NDET),QDET40(NDET)
     *                ,QDET99(NDET),RMPROJ,RMTARG(4),XDEP(NDEP)
     *                ,XDET14(NDET),XDET16(NDET),XDET40(NDET)
     *                ,XDET99(NDET)
     *                ,KOLL,LTARG,NORD(KOLLMX),NPROJ,NRPROJ(KOLLMX)
     *                ,NRTARG(KOLLMX),NTARG
      COMMON /CPRBMS/  PRBMS(NPRBMS)
      COMMON /CPTQ/    QPTH(NPTQ),QPTQ(NPTQ),XPTQ(NPTQ),QPTQMX,QPTHMX
      DOUBLE PRECISION SEEDC,SEEDI
      COMMON /CSEED/   SEEDC,SEEDI
      COMMON /FILES/   IFCH,IFDT,IFHI,IFMT,IFOP
      COMMON /NEVNT/   NEVNT
      COMMON /PARO1/   AMPRIF,AMSIAC,BMAXIM,BMINIM,CORE,CUTMSQ,CUTMSS
     *                ,DELMSS,DELREM,FCTRMX,GAUMX,OVERLP,PAREA,PDIQUA
     *                ,PHARD,PSPINL,PSPINH,PISPN,PTF,PTH,PTMX,PTQ,PUD
     *                ,PVALEN,QSEPC,QSETC,QMUST,QVAPC,QVATC,RADIAC
     *                ,RADIAS,RSTRAS,SIGJ,SIGPPI,TAUMAX,TAUMIN
     *                ,TAUMX,TAUNLL,TENSN,THEMAS,WPROJ,WTARG,WTMINI
     *                ,WTSTEP,XCUT
     *                ,IAQU,IFRADE,IOJINT,IOPBRK,IOPENT,IOPENU
     *                ,IOPTF,IOPTQ,IRESCL,IWCENT,KENTRO,KO1KO2
     *                ,LABSYS,MAXRES,NCLEAN,NCOLMX,NDECAW,NEQMN,NEQMX
     *                ,NSTTAU,NTRYMX,NUMTAU
      COMMON /PARO2/   AMPROJ,AMTARG,ANGMUE,ELEPTI,ELEPTO,ENGY
     *                ,PNLL,PNLLX,PROB(99),PROSEA,RHOPHI,TAUREA
     *                ,YHAHA,YMXIMI,YPJTL
     *                ,ICBAC(99,2),ICFOR(99,2),ICHOIC,ICLHIS,IDPM
     *                ,IDPROJ,IDTARG,IENTRO,IJPHIS,IMIHIS,IPAGI,ISH
     *                ,ISHEVT,ISHSUB,ISPALL,ISPHIS,ISTMAX,ISUP,IVI
     *                ,JPSI,JPSIFI,KUTDIQ,LAPROJ,LATARG,MAPROJ,MATARG
     *                ,MODSHO,NDECAX,NDECAY,NEVENT
      COMMON /PARO3/   ASUHAX(7),ASUHAY(7),OMEGA,SIGPPD,SIGPPE,UENTRO
     *                ,IWZZZZ
      COMMON /PARO4/   GRICEL,GRIDEL,GRIGAM,GRIRSQ,GRISLO
      COMMON /PARO5/   DELEPS,DELVOL
      COMMON /QUARKM/  SMAS,SSMAS,USMAS,UUMAS
      COMMON /STRU/    QSEP(NSTRU),QSET(NSTRU),QVAP(NSTRU)
     *                ,QVAT(NSTRU),XCUTAR,XSTRU(NSTRU)
     *                ,IDTG
      COMMON /STRU2/   DELTA0,DELTA1,QSEH(NSTRU),QSEPI(NSTRU)
     *                ,QVAH(NSTRU),QVAPI(NSTRU),XSE(NSTRU),XVA(NSTRU)
 
      DOUBLE PRECISION ERRER,VALUE
      INTEGER          IFLAG
 
      COMMON /VENLIN/  PTQ1,PTQ2,PTQ3,QMUST1,QMUST2,QMUST3
     *                ,IDTABL(100)
 
      EXTERNAL         SDENSI,SPTQ,SSE0,SVA0,SVA1
C-----------------------------------------------------------------------
 
      IF ( DEBUG ) WRITE(MDEBUG,*) 'VENLNK: TAR',SNGL(TAR)
 
      NSTRUC = NSTRU
      IF ( DEBUG ) THEN
        ISH  = ISH0
      ELSE
        ISH  = 0
      ENDIF
      NEVNT = SHOWNO
C  SET RANDOM NUMBER GENERATOR STATUS
      SEEDC=ISEED(2,1)+1.D9*ISEED(3,1)
C  CALCULATE ENERGY IN LAB SYSTEM FOR ELASTICITY FOR VARIOUS PROJECTILES
      IF     ( ITYPE .EQ. 1 ) THEN
C  TREAT PHOTON PROJECTILES (FROM EGS)
        CALL RMMAR(RD,1,1)
        IF ( RD(1) .LE. 0.5 ) THEN
          ITYPE = 7
        ELSE
          ITYPE = 17
        ENDIF
        ELAB  = CURPAR(2)
        CURPAR(2) = ELAB / PAMA(ITYPE)
      ELSEIF ( ITYPE .LT. 100 ) THEN
C  TREAT ORDINARY PROJECTILES
        ELAB  = CURPAR(2) * PAMA(ITYPE)
      ELSE
C  TREAT NUCLEI PROJECTILES
        NPROT = MOD(ITYPE,100)
        NNEUT = ITYPE/100 - NPROT
        ELAB  = CURPAR(2) * ( PAMA(14)*NPROT + PAMA(13)*NNEUT )
      ENDIF
C  SET TARGET PARAMETERS
      MATARG = NINT(TAR)
      IDTARG = 1120
      AMTARG = PAMA(14)
      IF     ( TAR. EQ. 14.D0 ) THEN
        LTARG  = 1
        LATARG = 7
      ELSEIF ( TAR .EQ. 16.D0 ) THEN
        LTARG  = 2
        LATARG = 8
      ELSEIF ( TAR .EQ. 40.D0 ) THEN
        LTARG  = 3
        LATARG = 18
      ELSE
        WRITE(MONIOU,*)'VENLNK: UNDEFINED TARGET TAR=',SNGL(TAR)
      ENDIF
 
C  FOR THE CASE OF AN ARBITRARY TARGET (NOT AIR)
      IF ( LTARG .GT. 3 ) THEN
        MASSNR = MATARG
        IF ( MASSNR .GT. 1 ) THEN
          IF ( MASSNR .NE. MTAR99 ) THEN
            R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
            CX = R0+FCTRMX*0.54
            RMTARG(4) = CX
            CALL UTQUAF(SDENSI,NDET,XDET99,QDET99,0.,.33*CX,.66*CX,CX)
            MTAR99 = MATARG
          ENDIF
        ELSE
          RMTARG(4) = 0.
        ENDIF
      ENDIF
 
C  SET PROJECTILE PARAMETERS
      IF ( ITYPE .LT. 100 ) THEN
        IDPROJ = IDTABL(ITYPE)
        IF     ( IDPROJ .EQ. 20  .OR.  IDPROJ .EQ. -20 ) THEN
C  TREAT NEUTRAL KAONS  (K(0)S AND K(0)L)
          CALL RMMAR(RD,1,1)
          IF ( RD(1) .LE. 0.5 ) THEN
            IDPROJ = 230
          ELSE
            IDPROJ = -230
          ENDIF
        ELSEIF ( IDPROJ .EQ. 2130 ) THEN
C  VENUS CANNOT TREAT LAMBDA, TAKE INSTEAD SIGMA(0))
          IDPROJ = 1230
        ELSEIF ( IDPROJ .EQ. -2130 ) THEN
C  VENUS CANNOT TREAT ANTI-LAMBDA, TAKE INSTEAD ANTI-SIGMA(0))
          IDPROJ = -1230
        ENDIF
C  ALL OTHER PARTICLE CODES UNCHANGED
        CALL IDMASS(IDPROJ,AMPROJ)
        LAPROJ = -1
        MAPROJ = 1
        PNLL   = CURPAR(2)*AMPROJ
      ELSE
C  PROJECTILE IS NUCLEUS
        IDPROJ = 1120
        CALL IDMASS(IDPROJ,AMPROJ)
        LAPROJ = MOD(ITYPE,100)
        MAPROJ = ITYPE/100
        PNLL   = CURPAR(2)*(PAMA(14)+PAMA(13))*0.5
      ENDIF
 
      IF ( ABS(IDPROJ) .LT. 1000 ) THEN
        IF ( ABS(IDPROJ) .EQ. 230  .OR.  ABS(IDPROJ) .EQ. 130 ) THEN
C  DIFFRACTIVE PROBABILITY FOR KAON PROJECTILES
          WPROJ = 0.24
        ELSE
C  DIFFRACTIVE PROBABILITY FOR PION PROJECTILES
          WPROJ = 0.20
        ENDIF
      ELSE
C  DIFFRACTIVE PROBABILITY FOR BARYON PROJECTILES
        WPROJ = 0.32
      ENDIF
C  DIFFRACTIVE PROBABILITY FOR TARGET (ALWAYS NUCLEONS)
      WTARG = 0.32
 
      ENGY = SQRT( 2.*SQRT(PNLL**2+AMPROJ**2)*AMTARG+AMTARG**2
     *                     +AMPROJ**2 )
      IF ( DEBUG ) WRITE(MDEBUG,*)'VENLNK: ELAB = ',PNLL,
     *                                   ' ENGY = ',ENGY
CDH   IF ( ENGY .LT. 12. ) THEN
      IF ( ENGY .LT. 9.5 ) THEN
        WRITE (IFMT,*)'VENLNK: ENGY, IDPROJ=',ENGY,IDPROJ
        CALL UTSTOP('VENLNK: INCIDENT ENERGY TOO SMALL       ')
      ENDIF
      ENGYI = ENGY
      PNLLI = PNLL
      IF ( PNLL .LT. 1.E2 * AMPROJ ) THEN
        TRM  = SQRT(PNLL**2+AMPROJ**2)
        ENGY = SQRT((TRM+AMTARG-PNLL)*(TRM+AMTARG+PNLL))
      ELSE
        TRM  = AMPROJ**2*0.5/PNLL+AMTARG
        ENGY = SQRT(TRM*(2.*PNLL+TRM))
      ENDIF
      D1 = ABS(PNLLI-PNLL)/PNLL
      D2 = ABS(ENGYI-ENGY)/ENGY
      IF ( D1 .GT. 1.E-3  .OR.  D2 .GT. 1.E-3 ) THEN
        IF ( ISH .GE. 0 ) THEN
          CALL UTMSG('VENLNK')
          WRITE(IFCH,*)'*****  PNLL,PNLLI:',PNLL,PNLLI
          WRITE(IFCH,*)'*****  ENGY,ENGYI:',ENGY,ENGYI
          CALL UTMSGF
        ENDIF
      ENDIF
      S = ENGY**2
      SROOTI = 1./ENGY
      PNLLX = UTPCM(ENGY,AMPROJ,AMTARG)
      YHAHA = LOG((SQRT(PNLL**2+S)+PNLL)/ENGY)
      YPJTL = LOG((SQRT(PNLL**2+AMPROJ**2)+PNLL)/AMPROJ)
      IF ( ISH .GE. 91 ) WRITE(IFCH,*)'VENLNK: YPJTL=',YPJTL
 
      ENGYLG = LOG(ENGY)
      QMUST = QMUST1+QMUST2*ENGYLG+QMUST3*ENGYLG**2
      PTQ = PTQ1+PTQ2*ENGYLG+PTQ3*ENGYLG**2
CDH   PHARD = 0.030+0.12*(LOG10(S)-LOG10(30.**2))
      PHARD = 0.030+0.12*(LOG10(S)-2.9542425)
      PHARD = MIN(1.,PHARD)
      PHARD = MAX(0.030,PHARD)
 
C  PROJECTILE
      XCUT  = CUTMSQ*SROOTI
      XCUT2 = XCUT**2
      IF ( ABS(IDPROJ) .GE. 1000 ) THEN
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF PROJECTILE
        IPIO = 0
        CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*)'VENLNK: SSE0:IFLAG=',IFLAG
        QSEPC = VALUE
        CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*)'VENLNK: SVA0:IFLAG=',IFLAG
        QVAPC = VALUE
      ELSE
C  STRUCTURE FUNCTION INTEGRAL FOR MESONS OF PROJECTILE
        IPIO = 1
        A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2
        A1 =  5.0 - 1.875*XCUT2
        A2 = -3.3333333 + 0.26666667*XCUT2
        A3 =  1.25
        A4 = -0.2
        ROOT  = SQRT(XCUT2+1.)
        QSEPC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) )
     *                   - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) )
        CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
        IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                      WRITE(IFCH,*)'VENLNK: SVA1:IFLAG=',IFLAG
        QVAPC = VALUE
      ENDIF
      IDTG = IPIO
 
C  TARGET
      IF ( IDTG .EQ. 1 ) THEN
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET
          IPIO = 0
          CALL UINTEG(VALUE,SSE0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*)'VENLNK: SSE0:IFLAG=',IFLAG
          QSETC = VALUE
          CALL UINTEG(VALUE,SVA0,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*)'VENLNK: SVA0:IFLAG=',IFLAG
          QVATC = VALUE
        ELSE
          IPIO=1
          QVATC = QVAPC
          QSETC = QSEPC
        ENDIF
      ELSE
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          QVATC = QVAPC
          QSETC = QSEPC
        ELSE
C  STRUCTURE FUNCTION INTEGRAL FOR BARYONS OF TARGET
          IPIO=1
          A0 = -5.0 + 6.6666667*XCUT2 - 0.53333333*XCUT2**2
          A1 =  5.0 - 1.875*XCUT2
          A2 = -3.3333333 + 0.26666667*XCUT2
          A3 =  1.25
          A4 = -0.2
          ROOT  = SQRT(XCUT2+1.)
          QSETC = 0.9*( (1.-XCUT2*A1)*( LOG(1.+ROOT)-LOG(XCUT) )
     *                     - XCUT*A0 + ROOT*(A0+A1+A2+A3+A4) )
          CALL UINTEG(VALUE,SVA1,0.D0,1.D0,0.D0,1.D-5,1,ERRER,IFLAG)
          IF ( IFLAG .GT. 3  .AND.  ISH .GT. 0 )
     *                        WRITE(IFCH,*)'VENLNK: SVA1:IFLAG=',IFLAG
          QVATC = VALUE
        ENDIF
      ENDIF
      IF ( ISH .EQ. 16 .OR. DEBUG ) THEN
        WRITE(IFCH,301) QVAPC, QSEPC, QVATC, QSETC
 301    FORMAT(' VENLNK: QVAPC, QSEPC, QVATC, QSETC=',4(F10.7,2X))
      ENDIF
 
      IF ( PROSEA .GE. 0. ) THEN
        QVAPC = 1.0
        QVATC = 1.0
        QSEPC = PROSEA
        QSETC = PROSEA
      ENDIF
 
      XCUT = CUTMSS*SROOTI
      XCUTAR = XCUT
      B = MIN( 0.05, XCUT*500. )
      A = MIN( 0.2*B, XCUT*100. )
      PNLLLG = LOG(PNLL)
      DELTA0 = EXP(-2.791922 - 0.2091742 * PNLLLG)
      DELTA1 = EXP(-3.885293 - 0.2029558 * PNLLLG)
      CALL UTQSEA(A,B,1.)
      IF ( XCUT .LT. 0.04  ) THEN
        NEND=1.+REAL(NSTRUC)*2./PI*ACOS(1.-2./PI*ACOS(1.-25.*XCUT))
      ELSE
        NEND = NSTRUC
      ENDIF
 
      IF ( ABS(IDPROJ) .GE. 1000 ) THEN
        IPIO = 0
        DO 203 N = 1,NSTRUC
          QSEP(N) = QSEH(N)
 203    CONTINUE
        DO 2031 N = NEND,NSTRUC
          QVAP(N) = QVAH(N) - DELTA0
 2031   CONTINUE
      ELSE
        IPIO = 1
        DO 204 N = 1,NSTRUC
          QSEP(N) = QSEPI(N)
 204    CONTINUE
        DO 2041 N = NEND,NSTRUC
          QVAP(N) = QVAPI(N) - DELTA1
 2041   CONTINUE
      ENDIF
      CALL UTQVAL(QVAP,NEND)
 
      IF ( IDTG .EQ. 0 ) THEN
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          DO 205 N=1,NSTRUC
            QSET(N) = QSEP(N)
            QVAT(N) = QVAP(N)
 205      CONTINUE
        ELSE
          IPIO = 1
          DO 209 N = 1,NSTRUC
            QSET(N) = QSEPI(N)
 209      CONTINUE
          DO 2091 N = NEND,NSTRUC
            QVAT(N) = QVAPI(N) - DELTA1
 2091     CONTINUE
          CALL UTQVAL(QVAT,NEND)
        ENDIF
 
      ELSE
        IF ( ABS(IDTARG) .GE. 1000 ) THEN
          IPIO = 0
          DO 210 N = 1,NSTRUC
            QSET(N) = QSEH(N)
 210      CONTINUE
          DO 2101 N = NEND,NSTRUC
            QVAT(N) = QVAH(N) - DELTA0
 2101     CONTINUE
          CALL UTQVAL(QVAT,NEND)
 
        ELSE
          IPIO = 1
          DO 216 N=1,NSTRUC
            QSET(N) = QSEP(N)
            QVAT(N) = QVAP(N)
 216      CONTINUE
        ENDIF
      ENDIF
 
      IF ( ISH .EQ. 21 ) THEN
        CALL UTHSEA
        CALL UTSTOP(' VENLNK:                                ')
      ENDIF
 
      QPTHMX = 0.5/PTH**2-PTH**2/(2.*(PTH**2+PTMX**2)**2)
      IF     ( IOPTQ .EQ. 2 ) THEN
        QPTQMX = 1. - EXP(-PI*PTMX**2/(4.*PTQ**2) )
      ELSEIF ( IOPTQ .EQ. 3 ) THEN
        QPTQMX = 1. - PTQ**2/(PTQ**2+PTMX**2)
      ELSE
        CX = PTMX
        CALL UTQUAF(SPTQ,NPTQ,XPTQ,QPTQ,0.,.33*CX,.66*CX,CX)
      ENDIF
 
      SIGPPI = -1.0
C  CALCULATE ENERGY DEPENDENT CROSS SECTION FOR BARYONS
      CALL RACPRO('GRI',QMUST,NPRBMS,PRBMS)
      IF     ( ABS(IDPROJ) .LE. 120  .OR.  ABS(IDPROJ) .EQ. 220 ) THEN
C  CROSS SECTION FOR PIONS (OR ETA FOR PHOTONS FROM EGS)
        SIGPPI = SIGPPI * 0.6667
      ELSEIF ( ABS(IDPROJ) .EQ. 130  .OR.  ABS(IDPROJ) .EQ. 230 ) THEN
C  CROSS SECTION FOR KAONS
        SIGPPI = SIGPPI * 0.5541
      ENDIF
 
      MASSNR = MAPROJ
      RMPROJ = 0.
      IF ( MASSNR .GT. 1 ) THEN
        R0 = 1.19*MASSNR**(.3333333) -1.61*MASSNR**(-.3333333)
        CX = R0+FCTRMX*0.54
        RMPROJ = CX
        CALL UTQUAF(SDENSI,NDEP,XDEP,QDEP,0.,.33*CX,.66*CX,CX)
      ENDIF
 
      IF ( IDPM .EQ. 1 ) THEN
        QSEPC = 0.
        QSETC = 0.
      ENDIF
      BMAX = RMPROJ+RMTARG(LTARG)
 
      IF ( ISH .GE. 91 ) WRITE(IFCH,*)'VENLNK: AVENUS IS NOW CALLED'
      CALL AVENUS
 
C  NOW BRING PARTICLES TO CORSIKA STACK
      CALL VSTORE
 
      IF ( ISH .GE. 91 ) WRITE(IFCH,*)'VENLNK: (EXIT)'
      RETURN
      END
