SUBROUTINE RNIJMLSJ(R,TYPE,VPOT,FI,DFI,DDFI) ************************************************************************ ** NIJMEGEN NUCLEON-NUCLEON POTENTIAL PROGRAM ** ** ------------------------------------------ ** ** Version 1.0: June 1994 ** ** Version 1.1: March 1995 ** ** E-mail: info@nn-online.org ** Reference: Stoks et al. Phys.Rev. C49 (1994) June ** ** ** ** Refined and extended version of the 1978 Nijmegen NN potential ** ** in coordinate space on LSJ basis. ** ** Basic references for formulas and set up of this program can be ** ** found in Phys.Rev.D17 (1978) 768 and Phys.Rev.C40 (1989) 2226. ** ** Reference: V.G.J.Stoks et.al. Phys.Rev. C49 (1994) June ** ** ** ** INPUT: R in fermi ** ** ----- TYPE 'PP', 'NP', 'PN', or 'NN' (character*2) ** ** ** ** OUTPUT: central VC, spin-spin VSS, tensor VT, spin-orbit VLS, ** ** ------ asymmetric spin-orbit VLSA, quadratic spin-orbit VQ12 ** ** potentials in MeV. ** ** Nonlocal term FI (dimensionless) ** ** DFI (dimension MeV) 1st derivative ** ** DDFI (dimension MeV**2) 2nd derivative ** ** All these terms are communicated via ** ** COMMON/POTS/VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP ** ** This subroutine returns a 2x2 potential matrix VPOT ** ** in MeV which is the partial-wave coordinate-space ** ** potential for the partial wave PHNAME (see below) ** **--------------------------------------------------------------------** ** Potential decomposition in coordinate space plane-wave basis: ** ** V(r) = VC ** ** + VSS (SIG1.SIG2) ** ** + VT S12 ** ** + VLS L.(SIG1+SIG2)/2 ** ** + VLSA L.(SIG1-SIG2)/2 (NOT USED !!!) ** ** + VQ12 [(SIG1.L)(SIG2.L)+(SIG2.L)(SIG1.L)]/2 ** ** - [Laplacian FI + FI Laplacian]/2Mred ** ** ** ** COMMON-blocks which have to be filled beforehand: ** ** + COMMON/EMANHP/PHNAME ** ** PHNAME is character*3 and contains the name of the ** ** phase shift in the spectral notation. ** ** - singlets: 1S0 1P1 1D2 1F3 1G4 ... ** ** - triplets uncoupled: 3P0 3P1 3D2 3F3 3G4 ... ** ** - triplets coupled: 3C1 3C2 3C3 3C4 ... ** ** where 3C1 denotes 3S1 - epsilon1 - 3D1 channel ** ** 3C2 denotes 3P2 - epsilon2 - 3F2 channel ... ** ** + COMMON/CHOICE/IDPAR ** ** IDPAR is an integer and denotes the various different ** ** models that can be chosen. ** ** IDPAR=0: nijm93: potential for pp and np together. ** ** including a phenomenological ** ** parameter to give the 1S0 pp and np ** ** phase shift/scattering length ** ** difference ** ** 1: nijmI : Reidlike model, each partial wave has** ** its own parameterset ** ** 2: nijmII: like nijmI, but fully local ** ** + COMMON/RELKIN/NONREL ** ** NONREL is a logical used in the IDPAR=1 and 2 options.** ** NONREL=.TRUE. gives the deuteron binding energy of ** ** B=2.224575 MeV using non-relativistic ** ** kinematics. ** ** NONREL=.FALSE. gives the deuteron binding energy of ** ** B=2.224575 MeV using relativistic ** ** kinematics. ** ** Model IDPAR=0 gives the deuteron only using ** ** relativistic kinematics ==> NONREL=.FALSE. ** ** ** ** NOTE: ALL potential models use a fixed fpi**2=0.075 for the ** ** ----- pion-nucleon coupling constant at the pion pole, which ** ** is represented by the DATA FPPPI0/0.075D0/ statement. ** ** ** ** The PP potentials were fitted with the Coulomb given by ** ** V_Coul(r) = alpha'/r where ** ** alpha' = 2*k*eta'/M_p ** ** eta' = (T_lab+M_p)/sqrt[T_lab**2+2*M_p*T_lab]/fsc ** ** fsc = 137.0359895 ** ** Eqs.(25), (26), (10) from Phys.Rev.C38(1988)15. ** ************************************************************************ IMPLICIT REAL*8 (A-H,O-Z) REAL*8 VPOT(2,2) INTEGER SPIN CHARACTER PHNAME*3, PHNAM0*3, TYPE*2, CAPS*12, SMAL*12 COMMON/EMANHP/PHNAME COMMON/CHOICE/IDPAR COMMON/POTS/ VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP DATA PHNAM0/'***'/ DATA CAPS/'CSPDFGHIKLMN'/, SMAL/'cspdfghiklmn'/ SAVE NCHAN,SPIN,L,J,ISO VC =0D0 VSS =0D0 VT =0D0 VLS =0D0 VLSA=0D0 VQ12=0D0 FIC =0D0 FICP =0D0 FICPP=0D0 IF(PHNAME.NE.PHNAM0) THEN DO 5 LL=1,12 IF(PHNAME(2:2).EQ.SMAL(LL:LL)) THEN WRITE(PHNAME(2:2),'(A1)') CAPS(LL:LL) ENDIF 5 CONTINUE PHNAM0=PHNAME NCHAN=1 IF(PHNAME(2:2).EQ.'C') NCHAN=2 IF(PHNAME(1:1).EQ.'1') SPIN=0 IF(PHNAME(1:1).EQ.'3') SPIN=1 READ(PHNAME,'(2X,I1)') J L=J IF(PHNAME.EQ.'3P0') L=1 IF(NCHAN.EQ.2) L=J-1 ISO=MOD(SPIN+L+1,2) ENDIF IF(TYPE.EQ.'pp') THEN TYPE='PP' ELSEIF(TYPE.EQ.'np') THEN TYPE='NP' ELSEIF(TYPE.EQ.'pn') THEN TYPE='PN' ELSEIF(TYPE.EQ.'nn') THEN TYPE='NN' ENDIF CALL NYMPOT(R,TYPE,ISO) IF(NCHAN.EQ.1)THEN IF(SPIN.EQ.0)THEN VPOT(1,1) = VC - 3D0*VSS - J*(J+1)*VQ12 ELSEIF(L.EQ.J)THEN VPOT(1,1) = VC + VSS + 2D0*VT - VLS + (1D0-J*(J+1))*VQ12 ELSEIF(L.EQ.(J+1))THEN VPOT(1,1) = VC + VSS - 2D0*(J+2)/(2*J+1)*VT . - (J+2)*VLS + (J+2)*(J+2)*VQ12 ENDIF ELSE VPOT(1,1) = VC + VSS - 2D0*(J-1)/(2*J+1)*VT + . (J-1)*VLS + (J-1)*(J-1)*VQ12 VPOT(2,2) = VC + VSS - 2D0*(J+2)/(2*J+1)*VT - . (J+2)*VLS + (J+2)*(J+2)*VQ12 VPOT(1,2) = 6D0*DSQRT(J*(J+1)*1D0)/(2*J+1)*VT VPOT(2,1) = VPOT(1,2) ENDIF IF(IDPAR.EQ.2) THEN FI = 0D0 DFI = 0D0 DDFI= 0D0 ELSE FI = FIC DFI = FICP DDFI= FICPP ENDIF RETURN END ************************************************************************ SUBROUTINE NYMPOT(R,TYPE,ISO) IMPLICIT REAL*8 (A-H,O-Z) REAL*8 NEUTM CHARACTER PHNAME*3,PHNAM0*3, TYPE*2, TYP0*2 LOGICAL FIRST COMMON/EMANHP/PHNAME COMMON/CHOICE/IDPAR COMMON/POTS/ VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP COMMON/MESONM/AMPI,AMETA,AMETP, AMRO,AMOM,AMFI, AMA0,AMEP,AMF0, . AMPIC,AMROC,AMA0C,AWPIC,AWROC,AWA0C, AVSC COMMON/PARAMS/PAR(6,5) COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2, . ALVE,THV ,GV1, GRO,GOM,GFI, GRO2,GOM2,GFI2, . ALVM, FV1, FRO,FOM,FFI, FRO2,FOM2,FFI2, . ALGS,THGS,GS1, GA0,GEP,GF0, GA02,GEP2,GF02, . GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI, . FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2 COMMON/YUKEFF/ARO,AMR1,AROC,AMRC1,AWRC1,BRO,AMR2,BROC,AMRC2,AWRC2, . AVSC1,AVSC2, AEPS,AME1,BEPS,AME2 COMMON/BROADM/GAMRO,THRRO,GAMRC,THRRC,GAMEP,THRE0,THREC,NRO,NEP COMMON/SCALIN/AMT,AMPV COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4, . GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4 COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2, . AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2, . AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2 DATA FPPPI0/0.075D0/, FIRST/.FALSE./ DATA TYP0/'XX'/, PHNAM0/'***'/, IDPAR0/-1/ DATA PI/3.14159265358979323846D0/, SRPI/1.7724538509055160273D0/ SAVE ISIGN,CONV,PROTM,NEUTM,HBARC IF(FIRST) GOTO 10 FIRST = .TRUE. CONV = PI/180D0 ** Nucleon and meson masses (Particle Data Group 1990) HBARC = 197.327053D0 PROTM = 938.27231D0 NEUTM = 939.56563D0 AMT = 938.27231D0 AMPV = 139.5675D0 AMPIC = 139.5675D0 AMPI = 134.9739D0 AMETA = 548.8D0 AMETP = 957.5D0 AMROC = 768.3D0 AMRO = 768.7D0 AMOM = 781.95D0 AMFI =1019.412D0 AMA0C = 983.3D0 AMA0 = 983.3D0 AMF0 = 975.6D0 AVSC = ((NEUTM-PROTM)/AMROC)**2 FAC = 2D0*DSQRT(PROTM*NEUTM)/(PROTM+NEUTM) AWPIC = FAC*DSQRT(AMPIC**2 - (NEUTM-PROTM)**2) AWROC = FAC*DSQRT(AMROC**2 - (NEUTM-PROTM)**2) AWA0C = FAC*DSQRT(AMA0C**2 - (NEUTM-PROTM)**2) ** Broad rho-meson: spectral density to two effective Yukawa's ** Yukawa's fitted to PHI0C 0.001 - 2 fm (steps 0.002, ALAMV=825 MeV) GAMRO = 152.4D0 THRRO = AMPIC+AMPIC GAMRC = 149.1D0 THRRC = AMPIC+AMPI NRO = 1 ARO = 0.2655205D0 BRO = 0.5607493D0 AMR1 = 645.3772D0 AMR2 = 878.3667D0 AROC = 0.3875515D0 BROC = 0.4508341D0 AMRC1= 674.1521D0 AMRC2= 929.9742D0 AWRC1 = FAC*DSQRT(AMRC1**2 - (NEUTM-PROTM)**2) AWRC2 = FAC*DSQRT(AMRC2**2 - (NEUTM-PROTM)**2) AVSC1 = ((NEUTM-PROTM)/AMRC1)**2 AVSC2 = ((NEUTM-PROTM)/AMRC2)**2 10 CONTINUE IF(TYPE.EQ.TYP0) THEN IF(IDPAR0.EQ.IDPAR) THEN IF((IDPAR.EQ.1 .OR. IDPAR.EQ.2) .AND. PHNAME.NE.PHNAM0) THEN GOTO 15 ELSE GOTO 20 ENDIF ENDIF ENDIF TYP0=TYPE IF(TYPE.EQ.'PP') THEN AMY = PROTM AMN = PROTM I3Y = 1 I3N = 1 ELSEIF(TYPE.EQ.'NP') THEN AMY = NEUTM AMN = PROTM I3Y =-1 I3N = 1 ELSEIF(TYPE.EQ.'PN') THEN AMY = PROTM AMN = NEUTM I3Y = 1 I3N =-1 ELSEIF(TYPE.EQ.'NN') THEN AMY = NEUTM AMN = NEUTM I3Y =-1 I3N =-1 ENDIF ISIGN = I3Y*I3N CALL AMFACS 15 PHNAM0=PHNAME IDPAR0=IDPAR CALL NYMPAR(ISIGN) C pseudovec vector tensor scalar pomeron C FPI GRO FRO GA0 GPOM C PV1 GV1 FOM GEP GPOMP C ALPV ALVE FFI GF0 AMPOM C THPV THV RHOC% THGS AMPOMP C Cut-off ALAMP ALAMV ALAM ALAMS AMEP C 2 Yukawa AEPS AME1 BEPS AME2 GAMEP ** (joined) cutoffs for pseudoscalar, vector, scalar ALAMP = PAR(5,1) ALAMV = PAR(5,2) ALAMS = PAR(5,4) ALAM = PAR(5,3) IF(ALAMP.EQ.0D0) ALAMP=ALAM IF(ALAMV.EQ.0D0) ALAMV=ALAM IF(ALAMS.EQ.0D0) ALAMS=ALAM ** pseudovector couplings FPI = DSQRT(FPPPI0*DEXP(-(AMPI/ALAMP)**2)) PV1 = PAR(2,1) ALPV = PAR(3,1) THPV = PAR(4,1)*CONV ** vector couplings GRO = PAR(1,2) GV1 = PAR(2,2) ALVE = PAR(3,2) THV = PAR(4,2)*CONV ** tensor couplings FRO = PAR(1,3) FOM = PAR(2,3) FFI = PAR(3,3) ** scalar couplings GA0 = PAR(1,4) GEP = PAR(2,4) GF0 = PAR(3,4) THGS = PAR(4,4)*CONV ** diffractive contribution GPOM = PAR(1,5) GPOMP = PAR(2,5) AMPOM = PAR(3,5) AMPOMP= PAR(4,5) IF(AMPOMP.EQ.0D0) AMPOMP=AMPOM AMPOM2= AMPOM*AMPOM AMPOM4= AMPOM2*AMPOM2 APOMP2= AMPOMP*AMPOMP APOMP4= APOMP2*APOMP2 CALL NYMCOP(ISIGN) GROGOM = GRO*GOM GROFOM = GRO*FOM/(2D0*AMT) FROGOM = FRO/(2D0*AMT)*GOM FROFOM = FRO*FOM/(4D0*AMT*AMT) ** Broad epsilon-meson: spectral density to two effective Yukawa's ** Yukawa's fitted to PHI0C from 0.001 to 2 fm (steps 0.005) AMEP = PAR(5,5) GAMEP = PAR(6,5) THRE0 = AMPI+AMPI THREC = AMPIC+AMPIC NEP = 0 AEPS = PAR(6,1) AME1 = PAR(6,2) BEPS = PAR(6,3) AME2 = PAR(6,4) ** isospin dependence 20 FACISO= 4D0*ISO-2D0 GA0C2 = FACISO*GA0*GA0 FPIC2 = FACISO*FPI*FPI/(AMPV*AMPV) GROC2 = FACISO*GRO*GRO FROC2 = FACISO*FRO*FRO/(4D0*AMT*AMT) GFPROC= FACISO*(GRO*FRO+FRO*GRO)/(2D0*AMT) GFMROC= FACISO*(GRO*FRO-FRO*GRO)/(2D0*AMT) IF(PHNAME.EQ.'1S0' .AND. (TYPE.EQ.'NP'.OR.TYPE.EQ.'PN')) THEN ** Phenomenological phase-shift difference in PP and NP 1S0 GROC2=GROC2*(1D0+PAR(4,3)) FROC2=FROC2*(1D0+PAR(4,3)) ENDIF FPOM2 = (GPOM *AMPOM /AMT)**2 * 4D0*AMPOM /SRPI FPOMP2= (GPOMP*AMPOMP/AMT)**2 * 4D0*AMPOMP/SRPI RH = R/HBARC CALL RSPACE(RH,TYPE) CALL POTFUN(RH,TYPE,ISIGN,FACISO) RETURN END ************************************************************************ SUBROUTINE AMFACS IMPLICIT REAL*8 (A-H,O-Z) COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2, . AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2, . AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2 AMY2 = AMY*AMY AMYI = 1D0/AMY AMYI2 = AMYI*AMYI AMN2 = AMN*AMN AMNI = 1D0/AMN AMNI2 = AMNI*AMNI AMYPN = AMY+AMN AMYMN = AMY-AMN AMYPN2= AMYPN*AMYPN AMYMN2= AMYMN*AMYMN AY2PN2= AMY2+AMN2 AY2MN2= AMY2-AMN2 AMYN = AMY*AMN AMYNI = AMYI*AMNI AMYNI2= AMYNI*AMYNI AYPNI2= AMYI2+AMNI2 AYMNI2= AMYI2-AMNI2 REDM = AMYN/AMYPN ALF = 4D0*REDM/AMYPN IF(AMY.EQ.AMN) ALF = 1D0 RETURN END ************************************************************************ SUBROUTINE NYMPAR(ISIGN) IMPLICIT REAL*8 (A-H,O-Z) COMMON/PARAMS/PAR(6,5) COMMON/CHOICE/IDPAR DIMENSION PARTR1(5,6) C pseudovec vector tensor scalar pomeron C FPI GRO FRO GA0 GPOM C PV1 GV1 FOM GEP GPOMP C ALPV ALVE FFI GF0 AMPOM C THPV THV RHOC% THGS AMPOMP C Cut-off ALAMP ALAMV ALAM ALAMS AMEP C 2 Yukawa AEPS AME1 BEPS AME2 GAMEP C---------------------------------------------------------------------- ** Parameter-set with separate cutoffs, and fitted to all data(Nijm93) DATA PARTR1/ 1 .2720668D+00,.9209319D+00,.3770582D+01,.1384689D+01,.5228672D+01 2,.1595311D+00,.2594356D+01,.5816365D+00,.5310001D+01,.2204600D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.3484505D+01,.2081618D+03 4,-.230000D+02,.3750000D+02,.4371144D-01,.3790000D+02,.0000000D+00 5,.1177107D+04,.9045040D+03,.0000000D+00,.5544013D+03,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ IF(IDPAR.EQ.0) THEN DO 1 I=1,6 DO 1 J=1,5 1 PAR(I,J)=PARTR1(J,I) ELSEIF(IDPAR.EQ.1) THEN CALL PHSRDL(ISIGN) ELSEIF(IDPAR.EQ.2) THEN CALL PHSLOC(ISIGN) ENDIF WRITE(*,*) ' NIJMEGEN POTENTIAL PARAMETERS ARE:' DO 4 I=1,6 4 WRITE(*,5) (PAR(I,J),J=1,5) 5 FORMAT(5(1X,D15.7)) RETURN END ************************************************************************ C This subroutine reads the parameters of the 0-350 MeV fitted C Reidlike potential, Jan 1993, chi**2/data=1.03 C----------------------------------------------------------------------- SUBROUTINE PHSRDL(ISIGN) IMPLICIT REAL*8 (A-H,O-Z) CHARACTER PHNAME*3 LOGICAL NONREL COMMON/PARAMS/PAR(6,5) COMMON/EMANHP/PHNAME COMMON/RELKIN/NONREL DIMENSION APP1S0(5,6),ANP1S0(5,6),PAR1P1(5,6),PAR1D2(5,6), . PAR1F3(5,6),PAR1G4(5,6),PAR3P1(5,6),PAR3D2(5,6), . PAR3F3(5,6),PAR3G4(5,6),PAR3P0(5,6),PAR3C1(5,6), . PAR3C2(5,6),PAR3C3(5,6),PAR3C4(5,6),PARRST(5,6), . PNR3C1(5,6) DATA APP1S0/ 1 .2702427D+00,.6723103D+00,.3697581D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4846532D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4744299D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA ANP1S0/ 1 .2702427D+00,.6723103D+00,.3423514D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4942984D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1P1/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.3290519D+01,.5473693D-01,.4784616D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1D2/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.0000000D+00,.5473693D-01,.2348432D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.3639503D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1F3/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.4812761D+01,.5473693D-01,.6316315D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1G4/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.4142482D+01,.5473693D-01,.4859055D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3P1/ 1 .2702427D+00,.6723103D+00,.0000000D+00,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4980991D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4923498D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3D2/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5880449D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.1693534D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3F3/ 1 .2702427D+00,.6723103D+00,.8961465D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5458122D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3G4/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.3201615D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3P0/ 1 .2702427D+00,.6723103D+00,.3160965D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.3726932D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C1/ 1 .2706937D+00,.2598577D+01,.2125742D+01,.8334762D+00,.2751792D+01 2,.0000000D+00,.2536422D+01,.5473693D-01,.4906761D+01,.44371888D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8848614D+03,.6465221D+03,.0000000D+00,.6990612D+03,.7600000D+03 6,.1690008D+00,.5831763D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C2/ 1 .2702427D+00,.6723103D+00,.5188648D+01,.8334762D+00,.3668014D+01 2,.1341669D+00,.0000000D+00,.5473693D-01,.3995761D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8275346D+03,.0000000D+00,.5831699D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C3/ 1 .2702427D+00,.6723103D+00,.3877361D+01,.8334762D+00,.4723766D+01 2,.2811080D+00,.0000000D+00,.5473693D-01,.4818122D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C4/ 1 .2702427D+00,.6723103D+00,.7551377D+01,.8334762D+00,.2360920D+01 2,.2871299D+00,.0000000D+00,.5473693D-01,.4855317D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PARRST/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ C Parameters for a nonlocal potential with non-relativistic deuteron DATA PNR3C1/ 1 .2707126D+00,.2588931D+01,.2120162D+01,.8334762D+00,.2751792D+01 2,.0000000D+00,.2521404D+01,.5473693D-01,.4889314D+01,.44371806D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8848614D+03,.6465221D+03,.0000000D+00,.6990612D+03,.7600000D+03 6,.1690008D+00,.5831292D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DO 1 I=1,6 DO 1 J=1,5 IF(PHNAME.EQ.'1S0') THEN IF(ISIGN.EQ. 1) PAR(I,J)=APP1S0(J,I) IF(ISIGN.EQ.-1) PAR(I,J)=ANP1S0(J,I) ELSEIF(PHNAME.EQ.'1P1') THEN PAR(I,J)=PAR1P1(J,I) ELSEIF(PHNAME.EQ.'1D2') THEN PAR(I,J)=PAR1D2(J,I) ELSEIF(PHNAME.EQ.'1F3') THEN PAR(I,J)=PAR1F3(J,I) ELSEIF(PHNAME.EQ.'1G4') THEN PAR(I,J)=PAR1G4(J,I) ELSEIF(PHNAME.EQ.'3P0') THEN PAR(I,J)=PAR3P0(J,I) ELSEIF(PHNAME.EQ.'3P1') THEN PAR(I,J)=PAR3P1(J,I) ELSEIF(PHNAME.EQ.'3D2') THEN PAR(I,J)=PAR3D2(J,I) ELSEIF(PHNAME.EQ.'3F3') THEN PAR(I,J)=PAR3F3(J,I) ELSEIF(PHNAME.EQ.'3G4') THEN PAR(I,J)=PAR3G4(J,I) ELSEIF(PHNAME.EQ.'3C1') THEN IF(.NOT.NONREL) PAR(I,J)=PAR3C1(J,I) IF(NONREL) PAR(I,J)=PNR3C1(J,I) ELSEIF(PHNAME.EQ.'3C2') THEN PAR(I,J)=PAR3C2(J,I) ELSEIF(PHNAME.EQ.'3C3') THEN PAR(I,J)=PAR3C3(J,I) ELSEIF(PHNAME.EQ.'3C4') THEN PAR(I,J)=PAR3C4(J,I) ELSE PAR(I,J)=PARRST(J,I) ENDIF 1 CONTINUE RETURN END ************************************************************************ C This subroutine reads the parameters of the 0-350 MeV fitted C local potential (without Q**2), Jan 1993, chi**2/data=1.03 C----------------------------------------------------------------------- SUBROUTINE PHSLOC(ISIGN) IMPLICIT REAL*8 (A-H,O-Z) CHARACTER PHNAME*3 LOGICAL NONREL COMMON/PARAMS/PAR(6,5) COMMON/EMANHP/PHNAME COMMON/RELKIN/NONREL DIMENSION APP1S0(5,6),ANP1S0(5,6),PAR1P1(5,6),PAR1D2(5,6), . PAR1F3(5,6),PAR1G4(5,6),PAR3P1(5,6),PAR3D2(5,6), . PAR3F3(5,6),PAR3G4(5,6),PAR3P0(5,6),PAR3C1(5,6), . PAR3C2(5,6),PAR3C3(5,6),PAR3C4(5,6),PARRST(5,6), . PNR3C1(5,6) DATA APP1S0/ 1 .2702427D+00,.6723103D+00,.4006116D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4669822D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.3909783D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4692497D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA ANP1S0/ 1 .2702427D+00,.6723103D+00,.7407998D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4626459D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2196159D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4722381D+03,.6130152D+00,.1021139D+04,.6400000D+03/ C DATA PAR1P1/ C 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 C 2,.2871299D+00,.2849628D+01,.5473693D-01,.5411714D+01,.4437220D+00 C 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 C 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 C 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 C 6,.1690008D+00,.5217623D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1P1/ . .2702427D+00,.6723103D+00,.0000000D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.3430827D+01,.5473693D-01,.2825877D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+03,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1D2/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4138573D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2243917D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4367031D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1F3/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.3983000D+01,.5473693D-01,.5627977D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR1G4/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2037620D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3P1/ 1 .2702427D+00,.6723103D+00,.0000000D+00,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4171550D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.3368384D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4530824D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3D2/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5469270D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.1847244D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3F3/ 1 .2702427D+00,.6723103D+00,.6012926D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5530460D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3G4/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.3663270D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3P0/ 1 .2702427D+00,.6723103D+00,.2761025D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.3041218D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8275346D+03,.0000000D+00,.1134832D+04,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C1/ 1 .2702427D+00,.1607944D+01,.1841778D+01,.5469244D+00,.3469472D+01 2,.2871299D+00,.2240543D+01,.5473693D-01,.4035077D+01,.4437213D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.5151821D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8275346D+03,.0000000D+00,.8044237D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C2/ 1 .2702427D+00,.6723103D+00,.5816373D+01,.8334762D+00,.3957678D+01 2,.2353573D+00,.0000000D+00,.5473693D-01,.4143714D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2781205D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8275346D+03,.0000000D+00,.6121468D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C3/ 1 .2702427D+00,.6723103D+00,.4050335D+01,.8334762D+00,.4316501D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5048592D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PAR3C4/ 1 .2702427D+00,.6723103D+00,.7347855D+01,.8334762D+00,.2579081D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.5157279D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DATA PARRST/ 1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01 2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ C Parameters for a local potential with non-relativistic deuteron DATA PNR3C1/ 1 .2702427D+00,.1710842D+01,.1781765D+01,.5362515D+00,.3461562D+01 2,.2871299D+00,.2247159D+01,.5473693D-01,.4028595D+01,.44387996D+00 3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.5184792D+03 4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00 5,.8275346D+03,.0000000D+00,.8044237D+03,.0000000D+00,.7600000D+03 6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/ DO 1 I=1,6 DO 1 J=1,5 IF(PHNAME.EQ.'1S0') THEN IF(ISIGN.EQ. 1) PAR(I,J)=APP1S0(J,I) IF(ISIGN.EQ.-1) PAR(I,J)=ANP1S0(J,I) ELSEIF(PHNAME.EQ.'1P1') THEN PAR(I,J)=PAR1P1(J,I) ELSEIF(PHNAME.EQ.'1D2') THEN PAR(I,J)=PAR1D2(J,I) ELSEIF(PHNAME.EQ.'1F3') THEN PAR(I,J)=PAR1F3(J,I) ELSEIF(PHNAME.EQ.'1G4') THEN PAR(I,J)=PAR1G4(J,I) ELSEIF(PHNAME.EQ.'3P0') THEN PAR(I,J)=PAR3P0(J,I) ELSEIF(PHNAME.EQ.'3P1') THEN PAR(I,J)=PAR3P1(J,I) ELSEIF(PHNAME.EQ.'3D2') THEN PAR(I,J)=PAR3D2(J,I) ELSEIF(PHNAME.EQ.'3F3') THEN PAR(I,J)=PAR3F3(J,I) ELSEIF(PHNAME.EQ.'3G4') THEN PAR(I,J)=PAR3G4(J,I) ELSEIF(PHNAME.EQ.'3C1') THEN IF(.NOT.NONREL) PAR(I,J)=PAR3C1(J,I) IF(NONREL) PAR(I,J)=PNR3C1(J,I) ELSEIF(PHNAME.EQ.'3C2') THEN PAR(I,J)=PAR3C2(J,I) ELSEIF(PHNAME.EQ.'3C3') THEN PAR(I,J)=PAR3C3(J,I) ELSEIF(PHNAME.EQ.'3C4') THEN PAR(I,J)=PAR3C4(J,I) ELSE PAR(I,J)=PARRST(J,I) ENDIF 1 CONTINUE RETURN END ************************************************************************ SUBROUTINE NYMCOP(ISIGN) IMPLICIT REAL*8 (A-H,O-Z) COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2, . ALVE,THV ,GV1, GRO,GOM,GFI, GRO2,GOM2,GFI2, . ALVM, FV1, FRO,FOM,FFI, FRO2,FOM2,FFI2, . ALGS,THGS,GS1, GA0,GEP,GF0, GA02,GEP2,GF02, . GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI, . FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2 COMMON/SCALIN/AMT,AMPV DATA SR3/1.7320508075688772935D0/ ** pseudovector coupling constants PV8 = FPI * (4D0*ALPV-1D0)/SR3 COST = DCOS(THPV) SINT = DSIN(THPV) FETA = COST*PV8 - SINT*PV1 FETP = SINT*PV8 + COST*PV1 FPI2 = FPI*FPI/(AMPV*AMPV) * ISIGN FETA2= FETA*FETA/(AMPV*AMPV) FETP2= FETP*FETP/(AMPV*AMPV) ** vector coupling constants GV8 = GRO * (4D0*ALVE-1D0)/SR3 COST = DCOS(THV) SINT = DSIN(THV) GFI = COST*GV8 - SINT*GV1 GOM = SINT*GV8 + COST*GV1 GRO2 = GRO*GRO * ISIGN GOM2 = GOM*GOM GFI2 = GFI*GFI ** tensor coupling constants COST = DCOS(THV) SINT = DSIN(THV) FV8 = COST*(GFI+FFI) + SINT*(GOM+FOM) - GV8 FV1 =-SINT*(GFI+FFI) + COST*(GOM+FOM) - GV1 ALVM = (SR3*(GV8+FV8)+(GRO+FRO))/(4D0*(GRO+FRO)) FRO2 = FRO*FRO/(4D0*AMT*AMT) * ISIGN FOM2 = FOM*FOM/(4D0*AMT*AMT) FFI2 = FFI*FFI/(4D0*AMT*AMT) GFPRO = (GRO*FRO+FRO*GRO)/(2D0*AMT) * ISIGN GFPOM = (GOM*FOM+FOM*GOM)/(2D0*AMT) GFPFI = (GFI*FFI+FFI*GFI)/(2D0*AMT) GFMRO = (GRO*FRO-FRO*GRO)/(2D0*AMT) * ISIGN GFMOM = (GOM*FOM-FOM*GOM)/(2D0*AMT) GFMFI = (GFI*FFI-FFI*GFI)/(2D0*AMT) ** scalar coupling constants COST = DCOS(THGS) SINT = DSIN(THGS) GS8 = COST*GEP + SINT*GF0 GS1 =-SINT*GEP + COST*GF0 ALGS = (SR3*GS8+GA0)/(4D0*GA0) GA02 = GA0*GA0 * ISIGN GEP2 = GEP*GEP GF02 = GF0*GF0 RETURN END ************************************************************************ SUBROUTINE RSPACE(RH,TYPE) IMPLICIT REAL*8 (A-H,O-Z) CHARACTER TYPE*2 DIMENSION RES1(7), RES2(7) COMMON/MESONM/AMPI,AMETA,AMETP, AMRO,AMOM,AMFI, AMA0,AMEP,AMF0, . AMPIC,AMROC,AMA0C,AWPIC,AWROC,AWA0C, AVSC COMMON/YUKEFF/ARO,AMR1,AROC,AMRC1,AWRC1,BRO,AMR2,BROC,AMRC2,AWRC2, . AVSC1,AVSC2, AEPS,AME1,BEPS,AME2 COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4, . GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4 COMMON/RMAT/ A(7,13),B(7) C** Pseudoscalar mesons pi, eta, eta' CALL REGGE(RH,AMPI,ALAMP,A(1,2)) CALL REGGE(RH,AMETA,ALAMP,A(1,3)) CALL REGGE(RH,AMETP,ALAMP,A(1,4)) C** Vector mesons rho, omega, phi CALL REGGE(RH,AMR1,ALAMV,RES1) CALL REGGE(RH,AMR2,ALAMV,RES2) DO 11 I=1,7 A(I,6) = ARO*RES1(I) + BRO*RES2(I) 11 CONTINUE CALL REGGE(RH,AMOM,ALAMV,A(1,7)) CALL REGGE(RH,AMFI,ALAMV,A(1,8)) DO 12 I=1,7 B(I)=A(I,6)-A(I,7) 12 CONTINUE c** Scalar mesons a0(980), epsilon, f0(975) CALL REGGE(RH,AMA0,ALAMS,A(1,10)) CALL REGGE(RH,AME1,ALAMS,RES1) CALL REGGE(RH,AME2,ALAMS,RES2) DO 13 I=1,7 A(I,11) = AEPS*RES1(I) + BEPS*RES2(I) 13 CONTINUE CALL REGGE(RH,AMF0,ALAMS,A(1,12)) C** Isospin-1 mesons (pi+, rho+, a0+) IF(TYPE.EQ.'NP' .OR. TYPE.EQ.'PN') THEN CALL REGGE(RH,AWPIC,ALAMP,A(1,1)) CALL REGGE(RH,AWRC1,ALAMV,RES1) CALL REGGE(RH,AWRC2,ALAMV,RES2) DO 14 I=1,7 A(I,5) = AROC*RES1(I) + BROC*RES2(I) C* Second part vector-vector potential (same as scalar potential) A(I,13)= AVSC1*AROC*RES1(I) + AVSC2*BROC*RES2(I) 14 CONTINUE CALL REGGE(RH,AWA0C,ALAMS,A(1,9)) ENDIF RETURN END ************************************************************************ SUBROUTINE REGGE(RH,AM,ALAM,FIFUNS) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION FIFUNS(7) DATA ZMATCH/1D-02/, SQPI/1.7724538509055160273D0/ RATM=AM/ALAM RATM2=RATM*RATM RATM3=RATM*RATM2 EXPM=FDEXP(RATM2) AM3=AM*AM*AM AM5=AM*AM*AM3 Z=RH*ALAM IF(Z.GT.ZMATCH) THEN XLAM=0.5D0*RH*ALAM XLAM2=XLAM*XLAM ELAM=FDEXP(-XLAM2) X=AM*RH ERFCM=FDERFC(RATM-XLAM) ERFCP=FDERFC(RATM+XLAM) EPX=0D0 IF(ERFCP.NE.0) EPX=FDEXP(X) EMX=FDEXP(-X) PHI0C = EXPM*(EMX*ERFCM-EPX*ERFCP)/(2D0*X) PHI0L =(EXPM*(EMX*ERFCM*(1D0+X)-EPX*ERFCP*(1D0-X))- . 4D0/SQPI*XLAM*ELAM ) / (2D0*X*X*X) PHI0T =(EXPM*(EMX*ERFCM*(1D0+X+X*X/3D0) . -EPX*ERFCP*(1D0-X+X*X/3D0)) . -8D0/SQPI*XLAM*(0.5D0+XLAM2/3D0)*ELAM) / (2D0*X*X*X) DEL1C =-ELAM/(RATM3*2D0*SQPI) DEL1L =-ELAM/(RATM2*RATM3*4D0*SQPI) DEL1T =-ELAM*XLAM2/(RATM2*RATM3*6D0*SQPI) DEL2C = 3D0*(DEL1T-DEL1L) ELSE A=RATM B=-FDERFC(A)*A*EXPM*SQPI A2=A*A A4=A2*A2 A6=A4*A2 A8=A6*A2 A10=A8*A2 Z2=Z*Z Z4=Z2*Z2 Z6=Z4*Z2 Z8=Z6*Z2 PHI0C = (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z8/5806080D0+ . (8*A6*B+8*A6-4*A4+6*A2-15)*Z6/40320D0+ . (4*A4*B+4*A4-2*A2+3)*Z4/480D0+ . (2*A2*B+2*A2-1)*Z2/12D0+B+1D0 PHI0C = PHI0C/(SQPI*A) PHI0T = (32*A10*B+32*A10-16*A8+24*A6-60*A4+210*A2-945) . *Z8/47900160D0+ . (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z6/362880D0+ . (8*A6*B+8*A6-4*A4+6*A2-15)*Z4/5040D0+ . (4*A4*B+4*A4-2*A2+3)*Z2/180D0 PHI0T = PHI0T/(SQPI*A**3) PHI0L =-(32*A10*B+32*A10-16*A8+24*A6-60*A4+210*A2-945) . *Z8/127733760D0- . (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z6/725760D0- . (8*A6*B+8*A6-4*A4+6*A2-15)*Z4/6720D0- . (4*A4*B+4*A4-2*A2+3)*Z2/120D0-(2*A2*B+2*A2-1D0)/6D0 PHI0L = PHI0L/(SQPI*A**3) DEL1C =-Z8/12288D0+Z6/768D0-Z4/64D0+Z2/8D0-0.5D0 DEL1C = DEL1C/(SQPI*A**3) DEL1T = Z8/9216D0-Z6/768D0+Z4/96D0-Z2/24D0 DEL1T = DEL1T/(SQPI*A**5) DEL1L =-Z8/24576D0+Z6/1536D0-Z4/128D0+Z2/16D0-0.25D0 DEL1L = DEL1L/(SQPI*A**5) DEL2C = 3D0*(DEL1T-DEL1L) ENDIF FIFUNS(1) = AM*PHI0C FIFUNS(2) = AM3*(PHI0C+DEL1C) FIFUNS(3) = AM5*(PHI0C+DEL1C+DEL2C) FIFUNS(4) = AM3*PHI0L FIFUNS(5) = AM5*(PHI0L+DEL1L) FIFUNS(6) = AM3*PHI0T FIFUNS(7) = AM5*(PHI0T+DEL1T) RETURN END ************************************************************************ FUNCTION FDEXP(X) IMPLICIT REAL*8(A-Z) IF(X.LE.-100D0) THEN FDEXP=0D0 ELSE FDEXP=DEXP(X) ENDIF RETURN END ************************************************************************ FUNCTION FDERFC(X) IMPLICIT REAL*8(A-Z) IF(X.GE. 10D0) THEN FDERFC=0D0 ELSEIF(X.LE.-10D0) THEN FDERFC=2D0 ELSE FDERFC=DERFC(X) ENDIF RETURN END ************************************************************************ SUBROUTINE POTFUN(RH,TYPE,ISIGN,FACISO) IMPLICIT REAL*8 (A-H,O-Z) CHARACTER TYPE*2 COMMON/POTS/ VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2, . ALVE,THV ,GV1, GRO,GOM,GFI, GRO2,GOM2,GFI2, . ALVM, FV1, FRO,FOM,FFI, FRO2,FOM2,FFI2, . ALGS,THGS,GS1, GA0,GEP,GF0, GA02,GEP2,GF02, . GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI, . FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2 COMMON/SCALIN/AMT,AMPV COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS COMMON/CHOICE/IDPAR COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4, . GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4 COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2, . AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2, . AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2 COMMON/RMAT/ A(7,13),B(7) RH2= RH*RH C* Pseudoscalar-meson potential VPVS = (FPI2*A(2,2)+FETA2*A(2,3)+FETP2*A(2,4)) / 3D0 VPVT = (FPI2*A(6,2)+FETA2*A(6,3)+FETP2*A(6,4)) C* Vector-meson potential VVC = (GRO2*A(1,6)+GOM2*A(1,7)+GFI2*A(1,8)) + . (GRO2*A(2,6)+GOM2*A(2,7)+GFI2*A(2,8)) * AMYNI/(2D0*ALF) + . (GFPRO*A(2,6)+GFPOM*A(2,7)+GFPFI*A(2,8)) / (4D0*REDM) + . (FRO2*A(3,6)+FOM2*A(3,7)+FFI2*A(3,8)) * AMYNI/4D0 VVS = ((GRO2+AMYPN*GFPRO+4D0*AMYN*FRO2)*A(2,6) + . (GOM2+AMYPN*GFPOM+4D0*AMYN*FOM2)*A(2,7) + . (GFI2+AMYPN*GFPFI+4D0*AMYN*FFI2)*A(2,8)) * AMYNI/6D0 + . (FRO2*A(3,6)+FOM2*A(3,7)+FFI2*A(3,8)) * AMYNI/12D0 VVT =-((GRO2+AMYPN*GFPRO+4D0*AMYN*FRO2)*A(6,6) + . (GOM2+AMYPN*GFPOM+4D0*AMYN*FOM2)*A(6,7) + . (GFI2+AMYPN*GFPFI+4D0*AMYN*FFI2)*A(6,8)) * AMYNI/4D0 - . (FRO2*A(7,6)+FOM2*A(7,7)+FFI2*A(7,8)) * AMYNI/8D0 VVLS =-((GRO2*(0.5D0+1D0/ALF)+AMYPN*GFPRO)*A(4,6) + . (GOM2*(0.5D0+1D0/ALF)+AMYPN*GFPOM)*A(4,7) + . (GFI2*(0.5D0+1D0/ALF)+AMYPN*GFPFI)*A(4,8)) * AMYNI - . (FRO2*A(5,6)+FOM2*A(5,7)+FFI2*A(5,8))*AMYNI*(.5D0+1D0/ALF) VVQ12 = ((GRO2+4D0*AMYPN*GFPRO+8D0*AMYPN2*FRO2)*A(6,6) + . (GOM2+4D0*AMYPN*GFPOM+8D0*AMYPN2*FOM2)*A(6,7) + . (GFI2+4D0*AMYPN*GFPFI+8D0*AMYPN2*FFI2)*A(6,8)) * . AMYNI2/16D0 * 3D0/RH2 FICV = REDM*(GRO2*A(1,6)+GOM2*A(1,7)+GFI2*A(1,8)) * . (AYPNI2+AMYNI)/2D0 FICVP =-REDM*(GRO2*A(4,6)+GOM2*A(4,7)+GFI2*A(4,8)) * . (AYPNI2+AMYNI)/2D0 * RH FICV2 = REDM*(GRO2*A(2,6)+GOM2*A(2,7)+GFI2*A(2,8)) * . (AYPNI2+AMYNI)/2D0 . + REDM*(GRO2*A(4,6)+GOM2*A(4,7)+GFI2*A(4,8)) *(AYPNI2+AMYNI) C* Scalar-meson potential VSC =-(GA02*A(1,10)+GEP2*A(1,11)+GF02*A(1,12)) + . (GA02*A(2,10)+GEP2*A(2,11)+GF02*A(2,12)) * AYPNI2/8D0 VSLS =-(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12)) * AYPNI2/4D0 VSQ12=-(GA02*A(6,10)+GEP2*A(6,11)+GF02*A(6,12)) * AMYNI2/16D0 . *3D0/RH2 FICS = REDM*(GA02*A(1,10)+GEP2*A(1,11)+GF02*A(1,12))*AMYNI/2D0 FICSP=-REDM*(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12))*AMYNI/2D0*RH FICS2= REDM*(GA02*A(2,10)+GEP2*A(2,11)+GF02*A(2,12))*AMYNI/2D0 . + REDM*(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12))*AMYNI C* Diffractive contribution XI0 = AMPOM*RH XI02 = XI0*XI0 EXI0 = 0D0 IF(XI02.LT.170.) EXI0 = FDEXP(-XI02) XI1 = AMPOMP*RH XI12 = XI1*XI1 EXI1 = 0D0 IF(XI12.LT.170.) EXI1 = FDEXP(-XI12) VDC = FPOM2 * (1D0+AMPOM2*(1.5D0-XI02)*AYPNI2/2D0) * EXI0 + . FPOMP2* (1D0+APOMP2*(1.5D0-XI12)*AYPNI2/2D0)*ISIGN * EXI1 VDLS = (FPOM2 * AMPOM2 * EXI0 + . FPOMP2* APOMP2 * EXI1*ISIGN) * AYPNI2/2D0 VDQ12= (FPOM2 * AMPOM4 * EXI0 + . FPOMP2* APOMP4 * EXI1*ISIGN) * AMYNI2/4D0 FICD =-REDM*(FPOM2*EXI0 + ISIGN*FPOMP2*EXI1) * AMYNI/2D0 FICDP = REDM*(FPOM2*EXI0*XI02 + ISIGN*FPOMP2*EXI1*XI12) * AMYNI/RH FICD2 = REDM*(FPOM2*EXI0*(1D0-2D0*XI02)*AMPOM2 + . ISIGN*FPOMP2*EXI1*(1D0-2D0*XI12)*APOMP2) * AMYNI IF(TYPE.EQ.'NP' .OR. TYPE.EQ.'PN') THEN ** Pseudoscalar: pi+ VPVS = VPVS + FPIC2/ALF*A(2,1)/3D0 VPVT = VPVT + FPIC2/ALF*A(6,1) ** Vector: rho+ VVC = VVC + GROC2*ALF*A(1,5)+GROC2*AMYNI/2D0*A(2,5)+ . ALF*(GFPROC*AMYPN+FROC2*AMYMN2)*AYPNI2/8D0*A(2,5) + . FROC2*AMYNI/4D0*A(3,5) * . (1D0+(AY2MN2**2+2D0*AMYN*AMYMN2)*AMYNI2/16D0) VVS = VVS + (GROC2+AMYPN*GFPROC+AMYPN2*FROC2)* . (AMYNI/6D0+ALF*AMYMN2*AMYNI2/16D0) * A(2,5) + . FROC2/ALF*AYPNI2/24D0*A(3,5) VVT = VVT - FROC2/ALF*AYPNI2/16D0*A(7,5) - . (GROC2+AMYPN*GFPROC+AMYPN2*FROC2)*AMYNI/4D0*A(6,5) VVLS = VVLS -((2D0-ALF/2D0)*GROC2+2D0*AY2PN2/AMYPN*GFPROC . + 2D0*AMYMN2*FROC2)*AMYNI*A(4,5) - A(5,5)* . FROC2*((2D0/ALF-0.5D0)/ALF-AMYMN2*AMYNI/8D0)*AMYNI VVQ12 = VVQ12 + ALF*(GROC2+4D0*AMYPN*GFPROC+8D0*AMYPN2*FROC2)* . A(6,5) * AMYNI2/16D0 * 3D0/RH2 FICV = FICV + REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 + . GFPROC*AMYMN2/AMYPN*AMYNI + . FROC2*(4D0/ALF-2D0*ALF*AY2PN2*AMYNI)) * A(1,5) FICVP = FICVP - REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 + . GFPROC*AMYMN2/AMYPN*AMYNI + . FROC2*(4D0/ALF-2D0*ALF*AY2PN2*AMYNI))*A(4,5)*RH FICV2 = FICV2 + REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 + . GFPROC*AMYMN2/AMYPN*AMYNI + FROC2* . (4D0/ALF-2D0*ALF*AY2PN2*AMYNI)) * (A(2,5)+2D0*A(4,5)) C Second part of vector-vector potential (same as scalar) VVC = VVC + ALF*GROC2*(A(1,13)-AMYNI/4D0*A(2,13)) VVLS = VVLS + ALF*GROC2*AMYNI/2D0*A(4,13) VVQ12= VVQ12+ ALF*GROC2*AMYNI2/16D0*A(6,13) * 3D0/RH2 FICV = FICV + ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)*A(1,13) FICVP= FICVP- ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)*A(4,13)*RH FICV2= FICV2+ ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)* . (A(2,13)+2D0*A(4,13)) ** Scalar: a0+ VSC = VSC - ALF*(GA0C2*A(1,9) - GA0C2*A(2,9)*AMYNI/4D0) VSLS = VSLS - ALF*GA0C2*A(4,9)*AMYNI/2D0 VSQ12= VSQ12- ALF*GA0C2*A(6,9)*AMYNI2/16D0 * 3D0/RH2 FICS = FICS - REDM*ALF*GA0C2*A(1,9) * (AYPNI2/4D0-AMYNI) FICSP= FICSP+ REDM*ALF*GA0C2*A(4,9) * (AYPNI2/4D0-AMYNI)*RH FICS2= FICS2- REDM*ALF*GA0C2*(AYPNI2/4D0-AMYNI)* . (A(2,9)+2D0*A(4,9)) ** Diffractive: pomeron (A2) VDC = VDC + FACISO*FPOMP2* . (1D0+APOMP2*(1.5D0-XI12)*AMYNI) * EXI1 VDLS = VDLS + FACISO*FPOMP2 * APOMP2*AMYNI * EXI1 VDQ12= VDQ12+ FACISO*FPOMP2 * APOMP4*AMYNI2/4D0 * EXI1 FICD = FICD + REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1 FICDP= FICDP- REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1 . * 2D0*XI12/RH FICD2= FICD2- REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1 * . APOMP2*(2D0-4D0*XI12) ENDIF VC = VSC + VVC + VDC VSS = VPVS + VVS VT = VPVT + VVT VLS = VSLS + VVLS + VDLS VLSA = 0D0 VQ12 = VSQ12 + VVQ12 + VDQ12 FIC = FICS + FICV + FICD FICP = FICSP + FICVP+ FICDP FICPP= FICS2 + FICV2+ FICD2 RETURN END