SUBROUTINE SDPM C----------------------------------------------------------------------- C S(TARTING) D(UAL) P(ARTON) M(ODEL) C C THIS ROUTINE DETERMINES THE TARGET NUCLEUS. C IT CALLS ALSO THE VARIOUS INTERACTION MODELS. C FOR HDPM, THIS ROUTINE LOOKS, HOW MANY NUCLEONS INTERACT AND WHICH C RESIDUAL FRAGMENT OF THE PROJECTILE NUCLEUS REMAINS. C THIS SUBROUTINE IS CALLED FROM NUCINT AND PIGEN C C REDESIGN: D. HECK IK3 FZK KARLSRUHE C----------------------------------------------------------------------- IMPLICIT NONE *KEEP,AIR. COMMON /AIR/ COMPOS,PROBTA,AVERAW,AVOGAD DOUBLE PRECISION COMPOS(3),PROBTA(3),AVERAW,AVOGAD *KEEP,CONST. COMMON /CONST/ PI,PI2,OB3,TB3,ENEPER DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER *KEEP,DPMFLG. COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM *KEEP,GENER. COMMON /GENER/ GEN,ALEVEL DOUBLE PRECISION GEN,ALEVEL *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,ISTA. COMMON /ISTA/ IFINET,IFINNU,IFINKA,IFINPI,IFINHY INTEGER IFINET,IFINNU,IFINKA,IFINPI,IFINHY *KEEP,MULT. COMMON /MULT/ EKINL,MSMM,MULTMA,MULTOT DOUBLE PRECISION EKINL INTEGER MSMM,MULTMA(37,13),MULTOT(37,13) *KEEP,NCSNCS. COMMON /NCSNCS/ SIGN30,SIGN45,SIGN60,SIGO30,SIGO45,SIGO60, * SIGA30,SIGA45,SIGA60,PNOA30,PNOA45,PNOA60, * SIG30A,SIG45A,SIG60A DOUBLE PRECISION SIGN30(56),SIGN45(56),SIGN60(56), * SIGO30(56),SIGO45(56),SIGO60(56), * SIGA30(56),SIGA45(56),SIGA60(56), * PNOA30(1540,3),PNOA45(1540,3),PNOA60(1540,3), * SIG30A(56),SIG45A(56),SIG60A(56) *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,RANGE. COMMON /RANGE/ CC DOUBLE PRECISION CC(20) *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,SIGM. COMMON /SIGM/ SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO DOUBLE PRECISION SIGMA,SIGANN,SIGAIR,FRACTN,FRCTNO *KEEP,VKIN. COMMON /VKIN/ BETACM DOUBLE PRECISION BETACM *KEEP,VENUS. COMMON /VENUS/ ISH0,IVERVN,MTAR99,FVENUS,FVENSG INTEGER ISH0,IVERVN,MTAR99 LOGICAL FVENUS,FVENSG *KEND. DOUBLE PRECISION PFRX(60),PFRY(60) DOUBLE PRECISION COSTET,EA,P,PHIV,PTM,PT2, * SIGMAA,SIGMAN,SIGMAO,SIG45,S45SQ,S4530 DOUBLE PRECISION CGHSIG,EKIN EXTERNAL CGHSIG INTEGER ITYP(60),I,IA,IANEW,INACTA,INACTZ,INDEX,INEUTR, * IZ,IZNEW,J,JFIN,KNEW,L,LL,NPRPRO,NNEPRO C----------------------------------------------------------------------- IF ( DEBUG ) WRITE(MDEBUG,444) (CURPAR(I),I=1,9) 444 FORMAT(' SDPM : CURPAR=',1P,9E10.3) C IA IS MASS NUMBER OF PROJECTILE IA = ITYPE / 100 IF ( IA .GT. 56 ) THEN WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C TREATMENT OF GAMMAS COMING FROM EGS4 (PIGEN) IF ( ITYPE .EQ. 1 ) THEN C RATIOS OF CROSS SECTIONS GO LIKE A**0.91 FRACTN = COMPOS(1) * 11.04019D0 FRCTNO = FRACTN + COMPOS(2) * 12.46663D0 SIGAIR = FRCTNO + COMPOS(3) * 28.69952D0 C TARGET IS CHOSEN AT RANDOM CALL RMMAR( RD,1,1 ) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF C GAMMAS ARE TREATED BY VENUS, IF SUFFICIENT ENERGY IF ( FVENUS .AND. CURPAR(2) .GT. HILOELB ) THEN CALL VENLNK ELSE CALL HDPM ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NORMAL HADRON PROJECTILE ELSEIF ( ITYPE .LT. 100 ) THEN C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. ELSE C TARGET IS CHOSEN AT RANDOM ACCORDING TO CROSS SECTION C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS SECTION C AND IS SET IN BOX2 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS SECTIONS FOR PROJECTICLE WITH MASS NUMBER 1 SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(1) * +(S45SQ - S4530) * SIGN30(1) * +(S45SQ + S4530) * SIGN60(1) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(1) * +(S45SQ - S4530) * SIGO30(1) * +(S45SQ + S4530) * SIGO60(1) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(1) * +(S45SQ - S4530) * SIGA30(1) * +(S45SQ + S4530) * SIGA60(1) C INELASTIC CROSS SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER 1 SIGAIR = FRCTNO + COMPOS(3)*SIGMAA 333 CONTINUE CALL RMMAR( RD,1,1 ) IF(DEBUG)WRITE(MDEBUG,*)'SDPM : FRACTN=',SNGL(FRACTN), * 'FRCTNO=',SNGL(FRCTNO),'RD=',RD(1) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF ENDIF IF ( FVENUS ) THEN C MESONS, NUCLEONS AND STRANGE BARYONS ARE TREATED BY VENUS (JAN 95) IF ( (ITYPE .GE. 7 .AND. ITYPE .LE. 16) .OR. * (ITYPE .GE. 18 .AND. ITYPE .LE. 32) )THEN CALL VENLNK ELSE CALL HDPM ENDIF ELSE CALL HDPM ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HEAVY PRIMARY INCIDENT WITH IA NUCLEONS ELSEIF ( IA .LE. 56 ) THEN IZ = MOD(ITYPE,100) C WITH WHAT KIND OF TARGET DOES PROJECTILE INTERACT? IF ( FIXTAR ) THEN C TARGET OF FIRST INTERACTION IS FIXED LT = N1STTR IF ( N1STTR .EQ. 1 ) THEN TAR = 14.D0 ELSEIF ( N1STTR .EQ. 2 ) THEN TAR = 16.D0 ELSE TAR = 40.D0 ENDIF FIXTAR = .FALSE. CALL RMMAR( RD,2,1 ) ELSE C ONLY INELASTIC INTERACTIONS WITH HEAVY PRIMARY/FRAGMENT C SIGMA IS ENERGY DEPENDENT INELASTIC NUCLEON-NUCLEON CROSS SECTION C AND IS SET IN BOX2 C AUXIL. QUANTITIES FOR INTERPOLATION SIG45 = SIGMA - 45.D0 S45SQ = SIG45**2 / 450.D0 S4530 = SIG45 / 30.D0 C INELASTIC CROSS SECTIONS FOR PROJECTICLE WITH MASS NUMBER IA SIGMAN = (1.D0 - 2.D0 * S45SQ) * SIGN45(IA) * +(S45SQ - S4530) * SIGN30(IA) * +(S45SQ + S4530) * SIGN60(IA) FRACTN = COMPOS(1) * SIGMAN SIGMAO = (1.D0 - 2.D0 * S45SQ) * SIGO45(IA) * +(S45SQ - S4530) * SIGO30(IA) * +(S45SQ + S4530) * SIGO60(IA) FRCTNO = FRACTN + COMPOS(2) * SIGMAO SIGMAA = (1.D0 - 2.D0 * S45SQ) * SIGA45(IA) * +(S45SQ - S4530) * SIGA30(IA) * +(S45SQ + S4530) * SIGA60(IA) C INELASTIC CROSS SECTIONS OF AIR FOR PROJECTILE WITH MASS NUMBER IA SIGAIR = FRCTNO +COMPOS(3)*SIGMAA C TARGET IS CHOSEN AT RANDOM CALL RMMAR( RD,2,1 ) IF(DEBUG)WRITE(MDEBUG,*)'SDPM : FRACTN=',SNGL(FRACTN), * 'FRCTNO=',SNGL(FRCTNO),'RD=',RD(1) IF ( RD(1)*SIGAIR .LE. FRACTN ) THEN C INTERACTION WITH NITROGEN LT = 1 TAR = 14.D0 ELSEIF ( RD(1)*SIGAIR .LE. FRCTNO ) THEN C INTERACTION WITH OXYGEN LT = 2 TAR = 16.D0 ELSE C INTERACTION WITH ARGON LT = 3 TAR = 40.D0 ENDIF ENDIF C TREAT NUCLEUS BY VENUS, IF SELECTED AND ENERGY/NUCLEON HIGH ENOUGH IF ( FVENUS .AND. PAMA(ITYPE)*GAMMA .GT. HILOELB*IA ) THEN CALL VENLNK RETURN ENDIF C TREATMENT OF NUCLEUS-NUCLEUS INTERACTION IN HDPM BY SUPERPOSITION C C INDEX CALCULATION 1 P( I*(I-3)*0.5+J+1 ) C IZ IS NUMBER OF PROTONS IN PROJECTILE C LT IS INDEX FOR TARGET 1 = N, 2 = O, 3 = AR C INACTA IS NUMBER OF INTERACTING NUCLEONS C INACTZ IS NUMBER OF INTERACTING PROTONS C LOOK, HOW MANY NUCLEONS INTERACT DO 100 J = 1,IA-1 INACTA = J INDEX = IA * (IA-3) * 0.5 + 1 + J P = ( 1.D0 - S45SQ *2.D0 ) * PNOA45(INDEX,LT) * +( S45SQ - S4530 ) * PNOA30(INDEX,LT) * +( S45SQ + S4530 ) * PNOA60(INDEX,LT) IF ( RD(2) .LT. P ) GO TO 110 100 CONTINUE C ALL NUCLEONS INTERACT (INACTA EQUAL IA) INACTA = INACTA + 1 110 CONTINUE IANEW = IA - INACTA C REMAINING PROJECTILE WITH IANEW NUCLEONS DO 120 L = 2,8 SECPAR(L) = CURPAR(L) 120 CONTINUE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PROJECTILE NUCLEUS FRAGMENTS COMPLETELY, WRITE SPECTATOR NUCLEONS C ONTO STACK IF ( NFRAGM .EQ. 0 ) THEN C LOOK, HOW MANY PROTONS AND NEUTRONS ARE FORMED IZNEW = IANEW / 2.15D0 + 0.7D0 INEUTR = IANEW - IZNEW INACTZ = MAX( IZ-IZNEW, 0 ) IF ( IZNEW .GT. 0 ) THEN C PROTONS SECPAR(1) = 14.D0 DO 300 L = 1,IZNEW CALL TSTACK 300 CONTINUE ENDIF IF ( INEUTR .GT. 0 ) THEN C NEUTRONS SECPAR(1) = 13.D0 DO 310 L = 1,INEUTR CALL TSTACK 310 CONTINUE ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C NO FRAGMENTATION, BUT SUCCESSIVE ABRASION OF PROJECTILE NUCLEUS ELSE IF ( DEBUG ) WRITE( MDEBUG,111 ) TAR,INACTA,IANEW 111 FORMAT(' SDPM : TARGET=',F4.0,' INACTA=',I4,' IANEW=',I4) C ALL NUCLEONS INTERACT, NO RESIDUAL NUCLEUS IF ( IANEW .EQ. 0 ) THEN INACTZ = IZ IF ( DEBUG ) WRITE(MDEBUG,554) (CURPAR(I),I=1,9) 554 FORMAT (' SDPM : CURPAR=',1P,9E10.3) KNEW = 0 C REMAINING NUCLEUS IS A NUCLEON ELSEIF ( IANEW .EQ. 1 ) THEN CALL RMMAR( RD,1,1 ) IZNEW = NINT(RD(1)) INACTZ = IZ - IZNEW KNEW = 13 + IZNEW C REMAINING NUCLEUS GETS A CHARGE WHICH IS ABOUT HALF THE MASS NUMBER ELSEIF ( IANEW .GT. 1 ) THEN IZNEW = FLOAT(IANEW) / 2.15D0 + 0.7D0 INACTZ = MAX( IZ - IZNEW, 0 ) KNEW = IANEW*100 + IZNEW C REMAINING NUCLEUS DEEXCITES BY EVAPORATION OF NUCLEONS/ALPHA PARTCLS. IF ( NFRAGM .GE. 2 ) THEN JFIN=0 CALL VAPOR(IA,KNEW,JFIN,ITYP,PFRX,PFRY) IF ( JFIN .LE. 0 ) GOTO 190 KNEW = 0 DO 135 J=1,JFIN EA = GAMMA * PAMA(ITYP(J)) IF (DEBUG) WRITE (MDEBUG,*)'SDPM : J,ITYP,EA=', * J,ITYP,SNGL(EA) PTM = EA**2 - PAMA(ITYP(J))**2 PT2 = PFRX(J)**2 + PFRY(J)**2 IF ( PT2 .GE. PTM ) THEN IF (DEBUG) WRITE(MDEBUG,*)'SDPM : PT REJECT ',J GOTO 135 ENDIF IF ( PTM .GT. 0.D0 ) THEN COSTET = SQRT( 1.D0 - PT2/PTM ) ELSE COSTET = 1.D0 ENDIF IF ( PFRX(J) .NE. 0.D0 .OR. PFRY(J) .NE. 0.D0 ) THEN PHIV = ATAN2( PFRY(J), PFRX(J) ) ELSE PHIV = 0.D0 ENDIF CALL ADDANG( COSTHE,PHI, COSTET,PHIV, * SECPAR(3),SECPAR(4) ) IF ( SECPAR(3) .GE. C(29) ) THEN IF ( J .LT. JFIN ) THEN SECPAR(1) = ITYP(J) CALL TSTACK ELSE KNEW = ITYP(JFIN) IANEW = KNEW/100 ENDIF ELSE IF (DEBUG) WRITE(MDEBUG,*)'SDPM : ANGLE REJECT ',J ENDIF 135 CONTINUE ENDIF ENDIF C REMAINING NUCLEUS: MASS 5 CANNOT BE TREATED IN BOX2 IF ( KNEW/100 .EQ. 5 ) THEN IF ( MOD(KNEW,100) .GE. 3 ) THEN C MASS 5: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSE C MASS 5: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ENDIF C REMAINING NUCLEUS: MASS 8 CANNOT BE TREATED IN BOX2 ELSEIF ( KNEW/100 .EQ. 8 ) THEN IF ( MOD(KNEW,100) .GE. 5 ) THEN C MASS 8: SPLIT OFF ONE PROTON SECPAR(1) = 14.D0 CALL TSTACK KNEW = KNEW - 101 ELSEIF ( MOD(KNEW,100) .LE. 3 ) THEN C MASS 8: SPLIT OFF ONE NEUTRON SECPAR(1) = 13.D0 CALL TSTACK KNEW = KNEW - 100 ELSE C MASS 8: SPLIT OFF ONE ALPHA PARTICLE SECPAR(1) = 402.D0 CALL TSTACK KNEW = KNEW - 402 ENDIF ENDIF IF ( KNEW .GT. 0 ) THEN SECPAR(1) = KNEW CALL TSTACK IF ( DEBUG ) WRITE(MDEBUG,555) (SECPAR(I),I=1,9) 555 FORMAT (' SDPM : SECPAR=',1P,9E10.3) ENDIF ENDIF C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C HERE THE REACTING NUCLEONS ARE TREATED 190 NPRPRO = INACTZ NNEPRO = INACTA - INACTZ C TREAT INTERACTING NEUTRONS FROM PROJECTILE IF ( NNEPRO .GE. 1 ) THEN CURPAR(1) = 13.D0 ITYPE = 13 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) DO 200 LL = 1,NNEPRO C USE GHEISHA IF THE CROSS SECTION HAS BEEN CALCULATED FOR GHEISHA IF ( GHEISH .AND. ECM .LE. HILOECM ) THEN ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) CALL CGHEI ELSE C DETERMINE TYPE OF INTERACTION FOR NUCLEONS AND ANTINUCLEONS IF ( ECM .GT. CC(4) ) THEN C DUAL PARTON MODEL CALL HDPM ELSEIF ( ECM .GT. CC(3) ) THEN C USE THE INTERACTION ROUTINES OF PKF GRIEDER C 2 HEAVY ISOBARS AND ANNIHILATION CALL BOX63 ELSEIF ( ECM .GT. CC(2) ) THEN C 1 HEAVY ISOBAR + NUCLEON AND ANNIHILATION CALL BOX62 ELSEIF ( ECM .GT. CC(1) ) THEN C 1 LIGHT ISOBAR + NUCLEON AND ANNIHILATION CALL BOX61 ELSE C ELASTIC SCATTERING AND ANNIHILATION CALL BOX60 ENDIF ENDIF 200 CONTINUE ENDIF C TREAT INTERACTING PROTONS FROM PROJECTILE IN ROUTINE HDPM IF ( NPRPRO .GE. 1 ) THEN CURPAR(1) = 14.D0 ITYPE = 14 C CALCULATE GAMMA, BETA AND ENERGY IN CENTER OF MASS GCM = SQRT( GAMMA * 0.5D0 + 0.5D0 ) ECM = PAMA(ITYPE) * GCM * 2.D0 BETACM = SQRT( 1.D0 - 1.D0 / GCM**2 ) DO 210 LL = 1,NPRPRO C USE GHEISHA IF THE CROSS SECTION HAS BEEN CALCULATED FOR GHEISHA IF ( GHEISH .AND. ECM .LE. HILOECM ) THEN ELAB = PAMA(ITYPE) * GAMMA PLAB = ELAB * BETA EKIN = ELAB - PAMA(ITYPE) SIGAIR = CGHSIG(SNGL(PLAB),SNGL(EKIN),ITYPE) CALL CGHEI ELSE C DETERMINE TYPE OF INTERACTION FOR NUCLEONS AND ANTINUCLEONS IF ( ECM .GT. CC(4) ) THEN C DUAL PARTON MODEL CALL HDPM ELSEIF ( ECM .GT. CC(3) ) THEN C USE THE INTERACTION ROUTINES OF PKF GRIEDER C 2 HEAVY ISOBARS AND ANNIHILATION CALL BOX63 ELSEIF ( ECM .GT. CC(2) ) THEN C 1 HEAVY ISOBAR + NUCLEON AND ANNIHILATION CALL BOX62 ELSEIF ( ECM .GT. CC(1) ) THEN C 1 LIGHT ISOBAR + NUCLEON AND ANNIHILATION CALL BOX61 ELSE C ELASTIC SCATTERING AND ANNIHILATION CALL BOX60 ENDIF ENDIF 210 CONTINUE ENDIF C ALL PARTICLES, INCLUDING THE LEADING ONE, ARE NOW WRITTEN TO STACK ELSE WRITE(MONIOU,*) 'SDPM : NOT FORESEEN PARTICLE TYPE=',ITYPE STOP ENDIF RETURN END