| 1 | SUBROUTINE VAPOR(MAPROJ,INEW,JFIN,ITYP,PFRX,PFRY)
|
|---|
| 2 |
|
|---|
| 3 | C-----------------------------------------------------------------------
|
|---|
| 4 | C (E)VAPOR(ATION OF NUCLEONS AND ALPHA PARTICLES FROM FRAGMENT)
|
|---|
| 5 | C
|
|---|
| 6 | C TREATES THE REMAINING UNFRAGMENTED NUCLEUS
|
|---|
| 7 | C EVAPORATION FOLLOWING CAMPI APPROXIMATION
|
|---|
| 8 | C SEE: X. CAMPI AND J. HUEFNER, PHYS.REV. C24 (1981) 2199
|
|---|
| 9 | C AND J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990)
|
|---|
| 10 | C THIS SUBROUTINE IS CALLED FROM SDPM AND VSTORE
|
|---|
| 11 | C
|
|---|
| 12 | C ARGUMENTS INPUT:
|
|---|
| 13 | C MAPROJ = NUMBER OF NUCLEONS OF PROJECTILE
|
|---|
| 14 | C INEW = PARTICLE TYPE OF SPECTATOR FRAGMENT
|
|---|
| 15 | C ARGUMENTS OUTPUT:
|
|---|
| 16 | C JFIN = NUMBER OF FRAGMENTS
|
|---|
| 17 | C ITYP(1:JFIN) = NATURE (PARTICLE CODE) OF FRAGMENTS (GEANT)
|
|---|
| 18 | C PFRX(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN X-DIRECTION
|
|---|
| 19 | C PFRY(1:JFIN) = TRANSVERSE MOMENTUM OF FRAGMENTS IN Y-DIRECTION
|
|---|
| 20 | C
|
|---|
| 21 | C DESIGN : D. HECK IK3 FZK KARLSRUHE
|
|---|
| 22 | C-----------------------------------------------------------------------
|
|---|
| 23 |
|
|---|
| 24 | IMPLICIT NONE
|
|---|
| 25 | *KEEP,CONST.
|
|---|
| 26 | COMMON /CONST/ PI,PI2,OB3,TB3,ENEPER
|
|---|
| 27 | DOUBLE PRECISION PI,PI2,OB3,TB3,ENEPER
|
|---|
| 28 | *KEEP,DPMFLG.
|
|---|
| 29 | COMMON /DPMFLG/ NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
|
|---|
| 30 | INTEGER NFLAIN,NFLDIF,NFLPI0,NFLCHE,NFLPIF,NFRAGM
|
|---|
| 31 | *KEEP,RANDPA.
|
|---|
| 32 | COMMON /RANDPA/ FAC,U1,U2,RD,NSEQ,ISEED,KNOR
|
|---|
| 33 | DOUBLE PRECISION FAC,U1,U2
|
|---|
| 34 | REAL RD(3000)
|
|---|
| 35 | INTEGER ISEED(103,10),NSEQ
|
|---|
| 36 | LOGICAL KNOR
|
|---|
| 37 | *KEEP,RUNPAR.
|
|---|
| 38 | COMMON /RUNPAR/ FIXHEI,THICK0,HILOECM,HILOELB,
|
|---|
| 39 | * STEPFC,NRRUN,NSHOW,PATAPE,MONIIN,
|
|---|
| 40 | * MONIOU,MDEBUG,NUCNUC,
|
|---|
| 41 | * CETAPE,
|
|---|
| 42 | * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
|
|---|
| 43 | * N1STTR,MDBASE,
|
|---|
| 44 | * DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
|
|---|
| 45 | * FIX1I,FMUADD,FNKG,FPRINT,FDBASE
|
|---|
| 46 | * ,GHEISH,GHESIG
|
|---|
| 47 | COMMON /RUNPAC/ DSN,HOST,USER
|
|---|
| 48 | DOUBLE PRECISION FIXHEI,THICK0,HILOECM,HILOELB
|
|---|
| 49 | REAL STEPFC
|
|---|
| 50 | INTEGER NRRUN,NSHOW,PATAPE,MONIIN,MONIOU,MDEBUG,NUCNUC,
|
|---|
| 51 | * SHOWNO,ISHW,NOPART,NRECS,NBLKS,MAXPRT,NDEBDL,
|
|---|
| 52 | * N1STTR,MDBASE
|
|---|
| 53 | INTEGER CETAPE
|
|---|
| 54 | CHARACTER*79 DSN
|
|---|
| 55 | CHARACTER*20 HOST,USER
|
|---|
| 56 |
|
|---|
| 57 | LOGICAL DEBDEL,DEBUG,FDECAY,FEGS,FIRSTI,FIXINC,FIXTAR,
|
|---|
| 58 | * FIX1I,FMUADD,FNKG,FPRINT,FDBASE
|
|---|
| 59 | * ,GHEISH,GHESIG
|
|---|
| 60 | *KEND.
|
|---|
| 61 |
|
|---|
| 62 | DOUBLE PRECISION PFR(60),PFRX(60),PFRY(60)
|
|---|
| 63 | DOUBLE PRECISION AFIN,AGLH,APRF,BGLH,EEX,PHIFR,RANNOR,SPFRX,SPFRY
|
|---|
| 64 | INTEGER ITYP(60),IARM,INEW,ITYPRM,INRM,IS,IZRM,JC,JFIN,
|
|---|
| 65 | * K,L,LS,MAPROJ,MF,NFIN,NINTA,NNUC,NPRF,NSTEP
|
|---|
| 66 | EXTERNAL RANNOR
|
|---|
| 67 | C-----------------------------------------------------------------------
|
|---|
| 68 |
|
|---|
| 69 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : MAPROJ,INEW = ',MAPROJ,INEW
|
|---|
| 70 |
|
|---|
| 71 | ITYPRM = INEW
|
|---|
| 72 | NPRF = INEW/100
|
|---|
| 73 | NINTA = MAPROJ - NPRF
|
|---|
| 74 | IF ( NINTA .EQ. 0 ) THEN
|
|---|
| 75 | C NO NUCLEON HAS INTERACTED
|
|---|
| 76 | JFIN = 1
|
|---|
| 77 | PFR(1) = 0.D0
|
|---|
| 78 | ITYP(1) = INEW
|
|---|
| 79 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,NINTA= ',JFIN,NINTA
|
|---|
| 80 | RETURN
|
|---|
| 81 | ENDIF
|
|---|
| 82 |
|
|---|
| 83 | C EXCITATION ENERGY EEX OF PREFRAGMENT
|
|---|
| 84 | C SEE: J.J. GAIMARD, THESE UNIVERSITE PARIS 7, (1990), CHPT. 4.2
|
|---|
| 85 | EEX = 0.D0
|
|---|
| 86 | CALL RMMAR(RD,2*NINTA,1)
|
|---|
| 87 | DO 22 L = 1,NINTA
|
|---|
| 88 | IF ( RD(NINTA+L) .LT. RD(L) ) RD(L) = 1. - RD(L)
|
|---|
| 89 | EEX = EEX + RD(L)
|
|---|
| 90 | 22 CONTINUE
|
|---|
| 91 | C DEPTH OF WOODS-SAXON POTENTIAL TO FERMI SURFACE IS 0.040 GEV
|
|---|
| 92 | IF (DEBUG) WRITE(MDEBUG,*)'VAPOR : EEX = ',SNGL(EEX*0.04D0),' GEV'
|
|---|
| 93 | C EVAPORATION: EACH EVAPORATION STEP NEEDS ABOUT 0.020 GEV, THEREFORE
|
|---|
| 94 | C NSTEP IS EEX * 0.04/0.02 = EEX * 2.
|
|---|
| 95 | NSTEP = INT(EEX*2.D0)
|
|---|
| 96 |
|
|---|
| 97 | IF ( NSTEP .LE. 0 ) THEN
|
|---|
| 98 | C EXCITATION ENERGY TOO SMALL, NO EVAPORATION
|
|---|
| 99 | JFIN = 1
|
|---|
| 100 | PFR(1) = 0.D0
|
|---|
| 101 | ITYP(1) = INEW
|
|---|
| 102 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : JFIN,EEX = ',JFIN,SNGL(EEX)
|
|---|
| 103 | RETURN
|
|---|
| 104 | ENDIF
|
|---|
| 105 |
|
|---|
| 106 | C AFIN IS ATOMIC NUMBER OF FINAL NUCLEUS
|
|---|
| 107 | APRF = FLOAT(NPRF)
|
|---|
| 108 | AFIN = APRF - 1.6D0 * FLOAT(NSTEP)
|
|---|
| 109 | NFIN = MAX( INT(AFIN+0.5D0), 0 )
|
|---|
| 110 | C CORRESPONDS TO DEFINITION; FRAGMENTATION-EVAPORATION
|
|---|
| 111 | C CONVOLUTION EMU07 /MODEL ABRASION EVAPORATION (JNC FZK APRIL 94)
|
|---|
| 112 | C NNUC IS NUMBER OF EVAPORATING NUCLEONS
|
|---|
| 113 | NNUC = NPRF - NFIN
|
|---|
| 114 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NFIN,NNUC = ',NFIN,NNUC
|
|---|
| 115 | JC = 0
|
|---|
| 116 |
|
|---|
| 117 | IF ( NNUC .LE. 0 ) THEN
|
|---|
| 118 | C NO EVAPORATION
|
|---|
| 119 | JFIN = 1
|
|---|
| 120 | PFR(1) = 0.D0
|
|---|
| 121 | ITYP(1) = INEW
|
|---|
| 122 | RETURN
|
|---|
| 123 |
|
|---|
| 124 | ELSEIF ( NNUC .GE. 4 ) THEN
|
|---|
| 125 | C EVAPORATION WITH FORMATION OF ALPHA PARTICLES POSSIBLE
|
|---|
| 126 | C IARM, IZRM, INRM ARE NUMBER OF NUCLEONS, PROTONS, NEUTRONS OF
|
|---|
| 127 | C REMAINDER
|
|---|
| 128 | DO 31 LS = 1,NSTEP
|
|---|
| 129 | IARM = ITYPRM/100
|
|---|
| 130 | IF ( IARM .LE. 0 ) GOTO 100
|
|---|
| 131 | IZRM = MOD(ITYPRM,100)
|
|---|
| 132 | INRM = IARM - IZRM
|
|---|
| 133 | JC = JC + 1
|
|---|
| 134 | CALL RMMAR(RD,2,1)
|
|---|
| 135 | IF ( RD(1).LT.0.2 .AND. IZRM.GE.2 .AND. INRM.GE.2 ) THEN
|
|---|
| 136 | ITYP(JC) = 402
|
|---|
| 137 | NNUC = NNUC - 4
|
|---|
| 138 | ITYPRM = ITYPRM - 402
|
|---|
| 139 | ELSE
|
|---|
| 140 | IF ( RD(2)*(IZRM+INRM) .LT. IZRM ) THEN
|
|---|
| 141 | ITYP(JC) = 14
|
|---|
| 142 | ITYPRM = ITYPRM - 101
|
|---|
| 143 | ELSE
|
|---|
| 144 | ITYP(JC) = 13
|
|---|
| 145 | ITYPRM = ITYPRM - 100
|
|---|
| 146 | ENDIF
|
|---|
| 147 | NNUC = NNUC - 1
|
|---|
| 148 | ENDIF
|
|---|
| 149 | IF ( NNUC .LE. 0 ) GOTO 50
|
|---|
| 150 | 31 CONTINUE
|
|---|
| 151 | ENDIF
|
|---|
| 152 |
|
|---|
| 153 | IF ( NNUC .LT. 4 ) THEN
|
|---|
| 154 | C EVAPORATION WITHOUT FORMATION OF ALPHA PARTICLES
|
|---|
| 155 | CALL RMMAR(RD,NNUC,1)
|
|---|
| 156 | DO 32 IS = 1,NNUC
|
|---|
| 157 | IARM = ITYPRM/100
|
|---|
| 158 | IF ( IARM .LE. 0 ) GOTO 100
|
|---|
| 159 | IZRM = MOD(ITYPRM,100)
|
|---|
| 160 | JC = JC + 1
|
|---|
| 161 | IF ( RD(IS)*IARM .LT. IZRM ) THEN
|
|---|
| 162 | ITYP(JC) = 14
|
|---|
| 163 | ITYPRM = ITYPRM - 101
|
|---|
| 164 | ELSE
|
|---|
| 165 | ITYP(JC) = 13
|
|---|
| 166 | ITYPRM = ITYPRM - 100
|
|---|
| 167 | ENDIF
|
|---|
| 168 | 32 CONTINUE
|
|---|
| 169 | ENDIF
|
|---|
| 170 |
|
|---|
| 171 | 50 CONTINUE
|
|---|
| 172 | JC = JC + 1
|
|---|
| 173 | IF ( ITYPRM .GT. 101 ) THEN
|
|---|
| 174 | ITYP(JC) = ITYPRM
|
|---|
| 175 | ELSEIF ( ITYPRM .EQ. 101 ) THEN
|
|---|
| 176 | ITYP(JC) = 14
|
|---|
| 177 | ELSEIF ( ITYPRM .EQ. 100 ) THEN
|
|---|
| 178 | ITYP(JC) = 13
|
|---|
| 179 | ELSE
|
|---|
| 180 | JC = JC - 1
|
|---|
| 181 | IF ( ITYPRM .NE. 0 ) WRITE(MONIOU,*)
|
|---|
| 182 | * 'VAPOR : ILLEGAL PARTICLE ITYPRM =',ITYPRM
|
|---|
| 183 | ENDIF
|
|---|
| 184 |
|
|---|
| 185 | 100 JFIN = JC
|
|---|
| 186 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NO ITYP PFR'
|
|---|
| 187 | IF ( NFRAGM .EQ. 2 ) THEN
|
|---|
| 188 | C EVAPORATION WITH PT AFTER PARAMETRIZED JACEE DATA
|
|---|
| 189 | DO 150 MF = 1,JFIN
|
|---|
| 190 | PFR(MF) = RANNOR(0.088D0,0.044D0)
|
|---|
| 191 | IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
|
|---|
| 192 | 150 CONTINUE
|
|---|
| 193 | ELSEIF ( NFRAGM .EQ. 3 ) THEN
|
|---|
| 194 | C EVAPORATION WITH PT AFTER GOLDHABER'S MODEL (PHYS.LETT.53B(1974)306)
|
|---|
| 195 | DO 160 MF = 1,JFIN
|
|---|
| 196 | K = MAX( 1, ITYP(MF)/100 )
|
|---|
| 197 | BGLH = K * (MAPROJ - K) / FLOAT(MAPROJ-1)
|
|---|
| 198 | C THE VALUE 0.103 [GEV] IS SIGMA(0)=P(FERMI)/SQRT(5.)
|
|---|
| 199 | * AGLH = 0.103D0 * SQRT( BGLH )
|
|---|
| 200 | C THE VALUE 0.090 [GEV] IS EXPERIMENTALLY DETERMINED SIGMA(0)
|
|---|
| 201 | AGLH = 0.090D0 * SQRT( BGLH )
|
|---|
| 202 | PFR(MF) = RANNOR(0.D0,AGLH)
|
|---|
| 203 | IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
|
|---|
| 204 | 160 CONTINUE
|
|---|
| 205 | ELSE
|
|---|
| 206 | C EVAPORATION WITHOUT TRANSVERSE MOMENTUM
|
|---|
| 207 | DO 165 MF = 1,JFIN
|
|---|
| 208 | PFR(MF) = 0.D0
|
|---|
| 209 | IF (DEBUG) WRITE(MDEBUG,*) MF,ITYP(MF),SNGL(PFR(MF))
|
|---|
| 210 | 165 CONTINUE
|
|---|
| 211 | ENDIF
|
|---|
| 212 | C CALCULATE RESIDUAL TRANSVERSE MOMENTUM
|
|---|
| 213 | SPFRX = 0.D0
|
|---|
| 214 | SPFRY = 0.D0
|
|---|
| 215 | CALL RMMAR(RD,JFIN,1)
|
|---|
| 216 | DO 170 MF = 1,JFIN
|
|---|
| 217 | PHIFR = PI * RD(MF)
|
|---|
| 218 | PFRX(MF) = PFR(MF) * COS(PHIFR)
|
|---|
| 219 | PFRY(MF) = PFR(MF) * SIN(PHIFR)
|
|---|
| 220 | SPFRY = SPFRY + PFRY(MF)
|
|---|
| 221 | SPFRX = SPFRX + PFRX(MF)
|
|---|
| 222 | 170 CONTINUE
|
|---|
| 223 | C CORRECT ALL TRANSVERSE MOMENTA FOR MOMENTUM CONSERVATION
|
|---|
| 224 | SPFRX = SPFRX / JFIN
|
|---|
| 225 | SPFRY = SPFRY / JFIN
|
|---|
| 226 | DO 180 MF = 1,JFIN
|
|---|
| 227 | PFRX(MF) = PFRX(MF) - SPFRX
|
|---|
| 228 | PFRY(MF) = PFRY(MF) - SPFRY
|
|---|
| 229 | 180 CONTINUE
|
|---|
| 230 |
|
|---|
| 231 | IF (DEBUG) WRITE(MDEBUG,*) 'VAPOR : NINTA,JFIN= ',NINTA,JFIN
|
|---|
| 232 | RETURN
|
|---|
| 233 | END
|
|---|
