!--------------------------------------------------------------------- ! simple calling routine, just to check meson parameters etc: ! call HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS) ! SP: NCHAN=1, LN NCHAN=2, LP: NCHAN=3 ! NBASE=1: SU(2) BASIS, NBASE=2: PARTICLE BASIS !--------------------------------------------------------------------- c subroutine dummy ! example of calling program IMPLICIT REAL*8(A-H,O-Z) COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL, . FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL, . VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS, . FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS, . VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS, . FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS, . VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR, . FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR c* . ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN COMMON/POTPRT/VPRT(12,3,3) ! PRT=PARTICLE do 1 i=1,10 xfm = 0.1d0*i call HNPOT16(xfm,0,0,3,1,0) ! Lp 1s0, isospin basis, noprint c call HNPOT16(xfm,0,0,3,1,1) ! Lp 1s0, isospin basis, print c call HNPOT16(xfm,0,0,3,2,1) ! Lp 1s0, particle basis c call HNPOT16(xfm,0,1,3,1,1) ! Lp 3s1 1 write(6,11) xfm,vcll,vsigll,vtenll,vsoll,vso2ll 11 format(' xfm=',f8.3,' vcll=',d12.5,' vsigll=',d12.5, .' vtenll=',d12.5,' vsoll=',d12.5,' vso2ll=',d12.5) write(*,*) do 2 i=1,10 xfm = 0.1d0*i call HNPOT16(xfm,0,0,3,1,1) ! Lp 1s0, isospin basis 2 write(6,21) xfm,fill,dfill,fisll,dfisll 21 format(' xfm=',f8.3,' fill=',d12.5,' dfill =',d12.5, .' fisll =',d12.5,' dfisll=',d12.5) stop end C ******************************************************************* C ******************************************************************* C SUBROUTINE HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS) ! this version C ******************************************************************* C 2011, AUGUST: A LA BBPROGS.MARIUS11.CSB C AXIAL MESONS, D1 <-> OMEGA(783), E1 <-> PHI(1020) C ------------------------------------------------------------------- C 2009, AUGUST: REFINED TREATMENT QUARK-CORE EFFECTS IN DIFRAC C ------------------------------------------------------------------- C 2008: POSIBILITY: NSU3F = 0 (SU3F-BREAKING), = 1 (SU3F-SYMMETRY) !! C SETTING: VIA DATA STATEMENT IN THIS ROUTINE! C ******************************************************************* C NOTICE: ORGANIZATION COMMON/POT/ SIMILAR AS FOR NSC89 PROGRAM ! C ******************************************************************* c 2009: csb: nchan=1-> icsb=0, nchan=2-> icsb=-1, nchan=3-> icsb=+1 c version: nchan=1 -> Sigma(+)-proton c nchan=2 -> Lambda -neutron c nchan=3 -> Lambda -proton c note: sigma(-)-proton, not proper threshold treatment!!! c-------------------------------------------------------------------- c version with green transformation facility!! c IGREEN = 0: output the model-potentials, unmodified ! c c IGREEN = 1: green transformation -> modified potentials C ******************************************************************* C C HYPERON - NUCLEON POTENTIAL PROGRAM : C C Model-options: C ********************************************************************* C * ESC04: OSAKA-VERSION DECEMBER 2004 * C * * C * IMODEL = 1 : Hard-Core MODEL PRD15 = YN-model D * C * IMODEL = 2 : Hard-Core MODEL PRD20 = YN-model F * C * * C * IMODEL = 3 : Soft-Core MODEL NSC97f= YN-model * C * IMODEL = 4 : Soft-Core MODEL NSC97e= YN-model * C * * C * IMODEL = 6 : Soft-Core MODEL ESC04A= NN+YN-model, paper II * C * IMODEL = 7 : Soft-Core MODEL ESC04B= NN+YN-model, paper II * C * IMODEL = 8 : Soft-Core MODEL ESC04C= NN+YN-model, paper II * C * IMODEL = 9 : Soft-Core MODEL ESC04D= NN+YN-model, paper II * C * IMODEL =10-13 : Soft-Core MODEL ESC06D= NN+YN-model * C * IMODEL =14,15 : Soft-Core MODEL ESC07D= NN+YN-model * C * IMODEL =16-17 : Soft-Core MODEL ESC08 = NN+YN-model * C * C * IMODEL =18 : Soft-Core MODEL ESC08 = definite version 2 nov. 2010* C ********************************************************************* C C IN THIS VERSION ZERO'S IN FORM FACTORS ARE OPTIONAL ! C C ------------------------------------------------------------------------- CC CC THE POTENTIALS ARE TO BE USED IN THE MULTICHANNEL SCHRODINGER CC _ 1 CC [ 1/(2 mu )*d(i,j)*LAPL - V (r) + -(LAPL*phi (r) + phi (r)*LAPL) CC i ij 2 ij ij CC 2 _ CC + (k /2*mu )*d(i,j) ] * psi (r) = 0 . CC i j CC CC here phi = FI/(MRED) in program. LAPL = laplacian operator. CC CC EQUATION LIKE NR.36 IN PR.D17,1978, CC !! except for definition phi !! The adaption is made C ------------------------------------------------------------------- CC IN COMMON/POT/: FI, FIS are defined as the phi(r) in CC EQUATION NR.35 in PRD17, 1978, which differs from the phi(r) cc above in the Schrodinger eq.!!! C ******************************************************************* C C !! POTENTIALS FROM INDIVIDUAL MESONS CAN BE OBTAINED BY C CHANGING DATA OF COMMON/INMES/ IN BLOCKDATA SUBPROGRAM !! C C INPUT : C X = YN-DISTANCE IN PION-COMPTON WAVELENGTH C NCHAN = 1 : SIGMA(+)-PROTON C = 2 : LAMBDA-NEUTRON C = 3 : LAMBDA-PROTON C C NBASE = 1 : POTENTIALS ONLY CALCULATED ON THE ISOSPIN-BASIS C = 2 : POTENTIALS ALSO CALCULATED ON THE PARTICLE-BASIS C C NS = 0 : NOPRINT C = 1 : RESTRICTED PRINTING C = 2 : EXTENSIVE PRINTING. THE PROGRAM PRINTS X, C AND THE TOTAL POTENTIALS ON THE ISOSPIN-BASIS C [ VCLL,VSIGLL,VTENLL,VSOLL,VSO2LL,FILL,DFILL,DDFILL ] C ISPIN=1/2 [ VCSS,VSIGSS,VTENSS,VSOSS,VSO2SS,FISS,DFISS,DDFISS ] C [ VCLS,VSIGLS,VTENLS,VSOLS,VSO2LS,FILS,DFILS,DDFILS ] C C ISPIN=3/2 [ VCDR,VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR ] C C AND FOR NBASE=2 ALSO THE POTENTIALS ON THE C PARTICLE BASIS C C NS = 3 : EXTRA PRINTING : THE PROGRAM PRINTS ALSO C THE POTENTIALS ON THE ISOSPIN-BASIS PER MESON-TYPE C C LINT = ORBITAL ANGULAR MOMENTUM YN-CHANNEL C C JSPIN= TOTAL SPIN YN-CHANNEL C C HERE: AKS(I) ARE PUT TO ZERO, RELEVANT IN CASE OF NADIA=1 C C C END INPUT DESCRIPTION. ******************************************** C C OUTPUT: NIJMEGEN-SOFTCORE HYPERON-NUCLEON POTENTIALS C C LITERATURE NIJMEGEN OBE-MODEL : PHYS.REV. D17,P.768,1978 (NN) C : FONTEFRAUD CONF. ,1987 (YN) C : PHYS.REV.,TO BE SUBMITTED(YN) C C AD NBASE=1 : C THE POTENTIALS ON THE ISOSPIN-BASIS ARE COMMUNICATED TO THE C CALLING PROGRAM VIA c COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL, c . FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL, c . VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS, c . FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS, c . VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS, c . FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS, c . VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR, c . FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR c* . ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN C C HERE NOMENCLATURE : C C VC = CENTRAL POTENTIAL , VSIG = SPIN-SPIN POTENTIAL , C VTEN = TENSOR ,, , VSO = SPIN-ORBIT ,, , C VASO = ASYMM. LS ,, , VSO2 = QUADRATIC SPIN-ORBIT. C FI = MRED*PHI, DFI = MRED*PHI', DDFI = MRED*PHI'', C FIS = MRED*PHIS, MRED*DFIS = MRED*PHIS', DDFIS = MRED*PHIS'', C C PHI , PHI', PHI'', AND PHIS , PHIS', PHIS'' C APPEAR IN THE SCHRODINGER EQUATION DUE C TO THE Q**2-DEPENDENCE OF THE POTENTIALS (SEE PR.D17,EQ.36), C NOTE HOWEVER THAT WE ADAPTED THE DEFINITION OF FI TO THE C MULTI-CHANNEL CASE (SEE BELOW FOR THE DESCRIPTION) !!!! C C NOTE THAT WE DID INCLUDE THE ASO-POTENTIALS. THEY ARE, C IN THE PRESENT MODEL, UNIMPORTANT TO FIT THE LOW ENERGY YN-DATA, C HOWEVER THEY ARE IMPORTANT IN HYPERNUCLEI AND NUCLEAR MATTER. C C LL = LAMBDA-LAMBDA MATRIX ELEMENT ) C LS = LAMBDA-SIGMA ,, ,, ) I=1/2 C SS = SIGMA -SIGMA ,, ,, ) C DR = SIGMA -SIGMA ,, ,, I=3/2 C C AD NBASE=2 : C THE POTENTIALS ON THE PARTICLE-BASIS ARE COMMUNICATED TO THE C CALLING PROGRAM C I) FOR NCHAN=2 AND 3 VIA : C COMMON/POTPRT/VPRT(12,3,3) PRT=PARTICLE C C HERE NOMENCLATURE : C VPRT(1,*,*) = CENTRAL POTENTIAL , VPRT(2,*,*) = SPIN-SPIN POTENTIAL C VPRT(3,*,*) = TENSOR ,, , VPRT(4,*,*) = SPIN-ORBIT ,, C VPRT(5,*,*) = ASYMM. LS ,, , VPRT(6,*,*) = QUADRATIC SPIN-ORBIT C VPRT(7,*,*) = PHI , VPRT(8,*,*) = PHI' , C VPRT(9,*,*) = PHI'', C VPRT(10,*,*)= PHIS , VPRT(11,*,*)= PHIS' , C VPRT(12,*,*)= PHIS''. C C NCHAN=2 LABELS CHANNELS : C LAMBDA-NEUTRON=1, SIGMA(0)-NEUTRON=2, SIGMA(-)-PROTON=3 C NCHAN=3 LABELS CHANNELS : C LAMBDA-PROTON =1, SIGMA(+)-NEUTRON=2, SIGMA(0)-PROTON=3 C C II) FOR NCHAN=1 (SIGMA(+)-PROTON CHANNEL) VIA C COMMON/POT/, NAMELY THROUGH THE POTENTIALS C VCDR,VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR . C C C C NOTE THAT IN THE NSC/ESC-MODEL C 1) FOR YN WE DO THE GREEN TRANSF. ON THE ISOSPIN BASIS C 2) FOR YN AND ISPIN=1/2 THE GREEN TRANSFORMATION HAS C TO BE DONE NUMERICALLY (2-CHANNEL PROBLEM) C C C END OUTPUT DESCRIPTION. ******************************************* C C UNITS : XFM IN FM, X IN PIM**-1, USED PIM=138.041 MEV C VC,VSIG,VTEN,VSO,VSO2 IN MEV**+1 C FI IN MEV**-1 , DFI IN MEV**0 , DDFI IN MEV**+1 C C ****************************************************************** C Parameters: Organization DEC.2007 C ****************************************************************** C C PAR( 1,I)= XS G1 FD1 FV1 GS1 GA2 FA1 GSPAIR C PAR( 2,I)= XT ALP ALVD ALVV GS* PSID ALPA GVPAIR C PAR( 3,I)= X1P GETAP GOM FOM GEPS GPOM FE1 FVPAIR C PAR( 4,I)= X3P27 PIONC AM1RO ARO AMD 1.0 THA GAPAIR C PAR( 5,I)= XHIGL PION0 AM2RO BRO AM1SI ASI GT1 HAPAIR C PAR( 6,I)= PROTON ETA AMOM ELPHI AM2SI BSI GEFF GPPAIR C PAR( 7,I)= NEUTRN AMX0 AMFI PSIS1 AM1ST 1.0 FT1 HOPAIR C PAR( 8,I)= ALM27 ALMP1 ALMV1 PSIS8 ALMS1 AMA2 FEFF GEPAIR C PAR( 9,I)= ALM8S ALMP0 ALMV0 THS1 ALMS0 AMPOM ALMAX GPIET C PAR(10,I)= ALM10 THPS THV THS2 AMEPS THD SONV GPIETP C PAR(11,I)= ALM8A THPE THRO THDE GAMEP AHYPC SONPV ALPAPR C PAR(12,I)= ALM10S APV FDNP1 FDNN1 GEPS2 FPOMH SONSC ALSCPR C PAR(13,I)= ALM1 HFPI HFD1 HFV1 ALS2 GPOMH SONVPR ALVDPR C PAR(14,I)= --- FCHPI HALVD HALVV GDEL2 AMPOMH SONPPR ALVVPR C PAR(15,I)= RSCAL HFETP HGOM HFOM ALS GPOPP SONSPR GPIPOM C PAR(16,I)= FACYN ALMKA ALMKS ALMKP AMSCK AMKSS FB1 GTENPR C PAR(17,I)= FACYY FNNPI --- --- AMFI51 FALS ALFBX FTENPR C PAR(18,I)= --- FFA1 --- --- GPPS2 FDEL FB9 GPSPR C PAR(19,I)= --- ALFFX GONP1 GONN1 FI51 FS* SONVA GPIROV C PAR(20,I)= --- FFE1 GSNP1 GSNN1 UPOM FEPS ALTV GPIOMV C HERE : PHYSICAL COUPLINGS, EXCEPT FOR C THE SU3-SINGLET COUPLINGS GPS1 AND FD1 C C ****************************************************************** C C ALM27 = ALAM IRREP 27 , ALAM10 = ALM IRREP 10 C ALM8S = ALAM IRREP 27+8S , ALM8A = ALAM IRREP 10*+8A C C PAR(7,1)= ALAM IS CURRENT FORM FACTOR MASS SET IN OBEPOT C EQUAL TO ALAM** OF THE PARTICULAR CHANNEL C C PARAMETERS FOR MODEL D AND F : C PAR(1-3,1)=XS,XT,XP : HARDCORE PARAMETERS ( 0 IN NSC-MODEL ) C PAR(4-6,1)=X3P27,X3P8,XHIGHL: HARDCORE PARAMETERS ( 0 IN NSC-MODEL C C G1,G6,G9 : PION-,ETA-,ETA'-COUPLING CONSTANT C FD1,ALVD,FD9 : VECTOR MESON G-TYPE COUPLING PARAMETERS C FV1,FV6,FV9 : VECTOR MESON F-TYPE COUPLING CONSTANTS C GS1,GS6,GS9 : SCALAR MESON COUPLING CONSTANTS C GPOM,GA2 : (POMERON+F+F')-,A2-COUPLING CONSTANT C THPS,THV,THS : PSEUDOSCALAR-,VECTOR-,SCALAR-MESON MIXING ANGLES C ARO,AM1RO,BRO,AM2RO : BROAD RHO-MESON PARAMETERS (SEE P.R.D17) C ASI,AM1SI,BSI,AM2SI : ,, EPS- ,, ,,, ,, C AMD,AMSST : DELTA-,S(975)-MESON MASS C ALAM : FORMFACTOR MASS C C ALMNN ALMLL ALMSS ALMLS ALMLK AMKSS ALMSK : F.F. PER VERTEX C IN NSC SET IN OBEPOT TO APPROPRIATE VALUES. C C PIM = PION MASS C c ******************************************************************* C BEGIN MAIN PROGRAM ************************************************ C ******************************************************************* SUBROUTINE HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS) C** § SUBROUTINE HNPOT16(X,LINT,JSPIN,NCHAN,NBASE,NS) C ******************************************************************* IMPLICIT REAL*8(A-H,O-Z) REAL*8 MPROT,MNEUT,MLAMB,MSIGP,MSIGN,MSIGM COMMON/PRMTRS/ PAR(20,8) COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2 COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4) COMMON/FRMFAC/ALM(7) COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALAMK,ALMKS,ALMKAP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/ALLAX/ FA(11),FFA(11),FB(11),ALMAX COMMON/COUPL/F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB . ,CORTPS,CORTV,CORTA,CORTB COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL, . FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL, . VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS, . FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS, . VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS, . FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS, . VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR, . FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR c* . ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN COMMON/POTPRT/VPRT(12,3,3) ! PRT=PARTICLE COMMON/PIMAS/PIM0 C---------------------------------------------------------------------- common/pmed/facmv,facms,facmvh,facmsh C---------------------------------------------------------------------- DIMENSION VI(12,4),BM(3,3),BMP(3,3) EQUIVALENCE (VI(1,1),VCLL) DIMENSION TRANS(3,3),TRAND(3,3) CHARACTER AMODEL(18)*9,SYS(3)*16,TYPV(12)*16 DATA SYS/'SIGMA(+)-PROTON','LAMBDA-NEUTRON','LAMBDA-PROTON'/ DATA TYPV/'CENTRAL','SPIN-SPIN','TENSOR','SPIN-ORBIT', . 'ASYMM SPIN-ORBIT','QUADR SPIN-ORBIT', . 'PHIC-FUNCTION','DPHIC-FUNCTION','DDPHIC-FUNCTION', . 'PHIS-FUNCTION','DPHIS-FUNCTION','DDPHIS-FUNCTION'/ DATA N2/6/,ICALL/0/,NCHNH/-10/,LINTH/-10/,JSPINH/-10/,BM/9*0.D0/ DATA MPROT/938.27231D0/,MNEUT/939.56563D0/,MLAMB/1115.63D0/, . MSIGP/1189.37D0/ ,MSIGN/1192.47D0/ ,MSIGM/1197.35D0/ c CHARACTER * 4 INPS(4),INVCT(5),INSC(5),INDIF(4) DATA AMODEL/' MODEL-D ',' MODEL-F ',' NSC89 ', . ' NSC97f ',' NSC97e ', . ' ESC04A ',' ESC04B ',' ESC04C ',' ESC04D ', . ' ESC06D ',' ESC06Dp ', . ' NILS06D1',' NILS06D3', . ' NILS07D ',' NILS07Dp', . ' ESC08a ',' ESC08b ', . ' ESC08c '/ C---------------------------------------------------------------------- DATA XS/0.D0/,XT/0.D0/,X1P/0.D0/,X3P27/0.D0/,X3P8S/0.D0/, . XHIGHL/0.D0/ C---------------------------------------------------------------------- C EXACT FLAVOR-SYMMETRY NO=0/YES=1: DATA NSU3F/0/ c DATA NSU3F/1/ C---------------------------------------------------------------------- C INCLUSION NON-LOCAL TENSOR/SPIN-SPIN POTENTIALS: DATA CORSPS/1D0/,CORSV/0D0/,CORSA/0D0/,CORSB/1D0/, . CORTPS/0D0/,CORTV/0D0/,CORTA/0D0/,CORTB/0D0/ C---------------------------------------------------------------------- SAVE ICALL,NLOC,ICSB C---------------------------------------------------------------------- X = XFM*138.041D0/197.327053D0 ! FM -> PIM^{-1} C---------------------------------------------------------------------- C FIXED: IMODEL=18 IGREEN=0 C---------------------------------------------------------------------- IF(NCHAN.EQ.1) ICSB= 0 IF(NCHAN.EQ.2) ICSB=-1 IF(NCHAN.EQ.3) ICSB=+1 IF(NSU3F.EQ.1) ICSB= 0 C---------------------------------------------------------------------- C---------------------------------------------------------------------- C NOTE: in YNOOM: CORRECTION TO PI-OM-PAIR only for imodel.gt.13!! C---------------------------------------------------------------------- IF(ICALL.GT.0.and.IMODEL.EQ.IMODL) GOTO 100 IF(NS.NE.0) .WRITE(*,333) IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS 333 FORMAT(' HNPOT16:IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS=', .8(I2,2X)) C---------------------------------------------------------------------- c write(*,*) c .'HNPOT16:IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS=', c .IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS IMODL = IMODEL C Defining model parameters: CALL MODPARS(IMODEL) C SPECIAL SETTINGS: IF(IGRTST.EQ.0) IGREEN=0 IF(NCHAN.EQ.1) IDAM=0 IF(IMODEL.LE.4.OR.IMODEL.GE.10) IDAM=0 ! check this IF(ICALL.EQ.0.and.NS.NE.0) THEN WRITE(*,*) '====================================================== .========' WRITE(N2,334) IMODEL,AMODEL(IMODEL),INRS,IRET,IDAM,IGERST,NSU3F, .IPSC,IVCT,ISCL,IDIF,IAXI,ITEN, .ITPS,IPAIR,IPIBE,IPSBE, .IZPS,IZVC,IZSC,IZAX,IZTEN, .IPV,IGM,INA,IOFF,NADIA,IRET,IGREEN 334 FORMAT(/,' ***** MODEL INFORMATION: IMODEL=',I2, .' MODEL=',A9,' *****',//, .' ***** VERSION: BBPROGS.MARIUS11.CSB *****',//, .' INRS =',I2,' IRET =',I2,' IDAM =',I2, .' IGERST=',I2,' NSU3F=',I2,//, .' IPSC =',I2,' IVCT =',I2,' ISCL =',I2,' IDIF =',I2, .' IAXI =',I2,' ITEN =',I2,/, .' ITPS =',I2,' IPAIR=',I2,' IPIBE=',I2,' IPSBE =',I2,/, .' IZPS =',I2,' IZVC =',I2,' IZSC =',I2,' IZAX =',I2, .' IZTEN=',I2,//, .' IPV =',I2,' IGM =',I2,' INA =',I2,' IOFF =',I2, .' NADIA=',I2,//,' *** IRET=',I2,' IGREEN=',I2,' ***',/) WRITE(*,*) '====================================================== .========' C ****************************************************************** WRITE(N2,*) WRITE(N2,*) ' NON-LOCAL TENSOR-SPINSPIN PARAMETERS:' WRITE(N2,91) CORSPS,CORSV,CORSA,CORSB,COTPS,CORV,CORTA,CORTV 91 FORMAT(' CORSPS=',F4.1,' CORSV=',F4.1, .' CORSA=',F4.1,' CORSB=',F4.1,/, .' CORTPS=',F4.1,' CORTV=',F4.1,' CORTA=',F4.1,' CORTB=',F4.1, .//,72('*'),//) C ****************************************************************** ENDIF c----------------------------------------------------------------------- C SETTING THE MESON-PARAMETERS c----------------------------------------------------------------------- c esc08-models: c if(imodel.eq.18) open(9,file='parbbsc.15dec2012') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.nophil.marius') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.ESC08c.best13') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.ESC08c.best13p3') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.30nov2013') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.best14june') ! ESC08c c if(imodel.eq.18) open(9,file='parbbsc.best14june.b') ! ESC08c cr if(imodel.eq.18) open(9,file='parbbsc.best16') ! ESC08c, april16 cr see call escpar16 below cy WRITE(*,*) '------------------------------------------------------ cy .--------' cy write(*,*) ' HNPOT16: PARAMETERS imod=18: parbbsc.best16' cy WRITE(*,*) '------------------------------------------------------ cy .--------' c----------------------------------------------------------------------- IF(IGREEN.NE.0) THEN WRITE(*,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++ .++++++++' WRITE(*,*) ' !!! WARNING: IGREEN=',IGREEN, . ' GREEN TRANSFORMATION, OKAY???? ' WRITE(*,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++ .++++++++' ENDIF IMODL = IMODEL IF(IMODEL.LE.2) NLOC=0 IF(IMODEL.GE.3) NLOC=1 AKS(1) = 0.D0 AKS(2) = 0.D0 AKS(3) = 0.D0 AM(1) = 938.2592D0 PIM = 138.041D0 AMPI = 138.041D0 AME = 548.8D0 AMK = 495.8D0 BMK = 453.4D0 AMX = 957.5D0 AMFI = 1019.5D0 AMOM = 783.9D0 AMKS = 892.6D0 BMKS = 869.1D0 PIM0 = PIM C------------------------------------------------------------- IF(NSU3F.EQ.1) THEN AGMO=DSQRT((2*AMK**2+PIM**2)/3D0) ! GM-O M0 = 410 MeV AGMO= 400D0 AMPI = AGMO AMK = AGMO BMK = AGMO AME = AGMO AMX = AGMO AGMOV=DSQRT((2*AMKS**2+AMRO**2)/3D0) ! GM-O M0 = 885 MeV AGMOV= 800D0 AMKS = AGMOV BMKS = AGMOV AMFI = AGMOV AMOM = AGMOV ENDIF C------------------------------------------------------------- c* IF(NS.EQ.1) THEN cy WRITE(6,99) cy WRITE(6,599) cy WRITE(N2,10) AMODEL(IMODEL) 10 FORMAT('0 THE PARAMETERS MODEL=',A9,/) c* ENDIF C------------------------------------------------------------- cr THIS VERSION: PARAMETERS ARE INTERNAL VIA CALL ESCPAR16: CALL ESCPAR16(NS) C------------------------------------------------------------- cr DO 21 I=1,20 cr READ(9,*) (PAR(I,J),J=1,8) cr WRITE(6,22) I,(PAR(I,J),J=1,4) cr WRITE(6,22) I,(PAR(I,J),J=5,8) cr 21 WRITE(6,*) 21 continue REWIND 9 22 FORMAT(' I=',I2,4(D15.7,2X)) cr WRITE(6,99) 99 FORMAT(72('-')) C------------------------------------------------------------- C IF(IMODEL.LE.2) THEN XS =PAR(1,1) XT =PAR(2,1) X1P =PAR(3,1) X3P27=PAR(4,1) X3P8S=PAR(5,1) XHIGHL=X3P27 ENDIF C------------------------------------------------------------- C C TWO POLE APPROXIMATION UNSTABLE MESONS C ARO =PAR(4,4) AM1RO=PAR(4,3) BRO =PAR(5,4) AM2RO=PAR(5,3) IF(IGERST.EQ.0) THEN ASI =PAR(5,6) AM1SI=PAR(5,5) BSI =PAR(6,6) AM2SI=PAR(6,5) ENDIF C BRYAN AND GERSTEN TWO-POLE PARAMETRIZATION BROAD EPSILON: IF(IGERST.EQ.1) THEN CALL GERSTPAR PAR(5,6) = ASI PAR(5,5) = AM1SI PAR(6,6) = BSI PAR(6,5) = AM2SI ENDIF AMD =PAR(4,5) AMSST=PAR(7,5) c* AMSCK=PAR(12,5) AMSCK=PAR(16,5) C------------------------------------------------------------- C EXACT SU3-FLAVOR SYMMETRY: IF(NSU3F.EQ.1) THEN ARO = 1.D0 BRO = 0.D0 AM1RO = 800.D0 AM2RO = 800.D0 AMOM = 800.D0 AMFI = 800.D0 AMKS = 800.D0 BMKS = 800.D0 ASI = 1.D0 BSI = 0.D0 AM1SI = 800.D0 AM2SI = 800.D0 AMD = 800.D0 AMSST = 800.D0 AMSCK = 800.D0 ENDIF C C DIFFRACTIVE MASSES C AMA2 =PAR(8,6) AMPOM=PAR(9,6) AMF2 =AMPOM c* AMKSS=PAR(8,6) AMKSS=PAR(16,6) AHYPC = PAR(11,6) C ------------------------------------------------------------------* C NUCLEAR MEDIUM EFFECTS ON MESON MASSES: SE BELOW C ------------------------------------------------------------------* c write(*,*) 'program at 1' c ICALL=1 100 IF(NCHNH.EQ.NCHAN.AND.LINTH.EQ.LINT.AND.JSPINH.EQ.JSPIN) GOTO 200 NCHNH=NCHAN LINTH=LINT JSPINH=JSPIN C ******************************************************************* C C FORM FACTOR MASSES : C C ******************************************************************* C MODELS HC-D, HC-F: IF(IMODEL.LE.2) THEN ALAM = 10000.D0 c* ALAM = 2000.D0 ALM(1) = ALAM ALM1 = ALAM ALM27 = ALAM ALM8S = ALAM ALM8A = ALAM ALM10 = ALAM ALM10S= ALAM ALAMK = ALAM ALMKAP= ALAM IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,201) .ALM1,ALM27,ALM8S,ALM10,ALM8A,ALM10S,ALMKAP 201 FORMAT(/,' ALM1 =',F9.3,' ALM27 =',F9.3,' ALM8S =',F9.3, . /,' ALM10 =',F9.3,' ALM8A =',F9.3,' ALM10S=',F9.3, . /,' ALMKAP=',F9.1,//) ENDIF C ******************************************************************* C MODELS PRC40: IF(IMODEL.EQ.3) THEN ALM1 =PAR(8,1) ALM27=PAR(8,1) ALM8S=PAR(9,1) ALM10=PAR(10,1) ALM8A=PAR(11,1) ALM10S=PAR(12,1) IF(NCHAN.NE.1 .AND. NCHAN.NE.4) ALM10=ALM10S IUSPIN=JSPIN+LINT+1 IF(MOD(IUSPIN,2).EQ.0) THEN ALAM1=ALM8A ALAM3=ALM10 ENDIF IF(MOD(IUSPIN,2).EQ.1) THEN ALAM1=ALM8S ALAM3=ALM27 ENDIF IF(ALAMK.EQ.0.D0) ALAMK=ALM27 IF(ALMKS.EQ.0.D0) ALMKS=ALM27 IF(ALMKAP.EQ.0.D0) ALMKAP=ALM27 C THE FOLLOWING GOOD FOR ALL LINT'S : C IF(NCHAN.EQ.1.AND.MOD(IUSPIN,2).EQ.0) ALAM=ALM10 C IF(NCHAN.EQ.1.AND.MOD(IUSPIN,2).EQ.1) ALAM=ALM27 C THE FOLLOWING ONLY GOOD FOR LINT=0 : C IF(NCHAN.EQ.1.AND.JSPIN.EQ.1) ALAM=ALM10 C IF(NCHAN.EQ.1.AND.JSPIN.EQ.0) ALAM=ALM27 IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,202) .ALM1,ALM27,ALM8S,ALM10,ALM8A,ALM10S 202 FORMAT(/,' ALM1 =',F9.3,' ALM27 =',F9.3,' ALM8S =',F9.3, . /,' ALM10 =',F9.3,' ALM8A =',F9.3,' ALM10S=',F9.3,//) C C FOR THIS VERSION OF THE SOFTCORE OBE-MODEL: C DO 5 I=1,5 ALM(I)=ALAM1 IF(I.GT.2) GOTO 5 ALM(I+6)=ALAM3 5 CONTINUE ENDIF C ******************************************************************* C SOFT-CORE 97-OBE-MODELs, and ESC-MODEL: IF(IMODEL.GE.4) THEN ALMP8 = PAR(8,2) ALMV8 = PAR(8,3) ALMS8 = PAR(8,5) ALMP1 = PAR(9,2) ALMV1 = PAR(9,3) ALMS1 = PAR(9,5) ALAMK = PAR(16,2) ALMKS = PAR(16,3) ALMKAP= PAR(16,4) ALMAX = PAR(9,7) IF(ALAMK.EQ.0.D0) ALAMK=ALMP8 IF(ALMKS.EQ.0.D0) ALMKS=ALMV8 IF(ALMKAP.EQ.0.D0) ALMKAP=ALMS8 IF(ALMAX.EQ.0.D0) ALMAX=ALMP8 ENDIF C ------------------------------------------------------------------- C MEDIUM EFFECTS FORM FACTORS: C not yet implemented in this program!! C ------------------------------------------------------------------- C EXACT SU3-FLAVOR SYMMETRY: IF(NSU3F.EQ.1) THEN ALMP1 = ALMP8 ALMV1 = ALMV8 ALMS1 = ALMS8 ALMKA = ALMP8 ALMKS = ALMV8 ALMKP = ALMS8 ENDIF C------------------------------------------------------------- IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,204) ALMP8,ALMV8,ALMS8,ALMP1, . ALMV1,ALMS1,ALAMK,ALMKS,ALMKAP,ALMAX 204 FORMAT(/,' ALMP8 =',F9.3,' ALMV8 =',F9.3,' ALMS8 =',F9.3, . /,' ALMP1 =',F9.3,' ALMV1 =',F9.3,' ALMS1 =',F9.3, . /,' ALAMK =',F9.3,' ALMKS =',F9.3,' ALMKAP=',F9.1, . /,' ALMAX =',F9.3,//) cc ENDIF C ******************************************************************* IF(NSU3F.EQ.1) THEN MPROT = MLAMB MNEUT = MLAMB MSIGP = MLAMB MSIGM = MLAMB MSIGN = MLAMB ENDIF C ------------------------------------------------------------------- c* ICALL=1 GOTO(1,2,3),NCHAN 1 AMY(1)=MSIGP AMY(2)=MSIGP AMY(3)=MSIGP AM(1) =MPROT AM(2) =MPROT AM(3) =MPROT GOTO 4 2 AMY(1)=MLAMB AMY(2)=MSIGN AMY(3)=MSIGM AM(1) =MNEUT AM(2) =MNEUT AM(3) =MPROT GOTO 4 3 AMY(1)=MLAMB AMY(2)=MSIGP AMY(3)=MSIGN AM(1) =MPROT AM(2) =MNEUT AM(3) =MPROT 4 CONTINUE C MEDIUM EFFECTS ON THE BARYON MASSES: C Yamamoto: M*(Lambda) < M(Lambda), M*(Sigma) > M(Sigma) !?? FSTAR = 1D0 IF(FSTAR.NE.1D0) THEN c* FSTAR = 0.6D0 ! Ter Haar DO 13 KK=1,3 AM(KK) = FSTAR * AM(KK) 13 AMY(KK) = FSTAR * AMY(KK) WRITE(6,*) ' HNPOT16: MEDIUM EFFECT MASSES FSTAR=',FSTAR ENDIF DO 12 I=1,3 REDM(I)=AM(I)*AMY(I)/(AM(I)+AMY(I)) 12 TEM(I) =2*REDM(I)/(PIM**2) REDMM = (REDM(1)+REDM(2)+REDM(3))/3.D0 CC CC adaption to multi-channel S.E. as described in comments above : CC AMLN=DSQRT(AMY(1)*AM(1)) AMSN=DSQRT(AMY(2)*AM(1)) AMH =0.5D0*(AMY(1)+AMY(2)) AMSS=0.5D0*(AMY(2)+AMY(3)) c** AMLS=DSQRT(AMH*AM(1)) AMNN=(AM(1)+AM(2)+AM(3))/3.D0 AMLS=DSQRT(AMH*AMNN) C 200 CALL WRLDCOP2(NCHAN,LINT,JSPIN,ICSB,NS) c write(*,*) 'program at 2' MAN = MOD(LINT+JSPIN+1,2) IF(MAN.EQ.1) P=+1.D0 IF(MAN.EQ.0) P=-1.D0 c** P = (-1.D0)**(LINT+JSPIN) C C NUCLEAR MEDIUM EFFECTS ON MESON MASSES: SEE ABOVE c* FACMV = 1D0 c* FACMS = 1D0 c* facmv = 0.85d0 c** CALL PMEDIUM(FACMV,FACMS) C IF(IGREEN.EQ.0) .CALL VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) IF(IGREEN.EQ.1) .CALL POTGR(X,PIM,P,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) C C RESTORATION MESON MASSES: c* FACMVI= 1d0/FACMV c* FACMSI= 1d0/FACMS c* CALL PMEDIUM(FACMVI,FACMSI) C c write(*,*) 'program at 3' IF(NBASE.EQ.1) GOTO 1000 C IF(NS.GE.1.AND.ICALL.EQ.0) PRINT 14,SYS(NCHAN),JSPIN,LINT 14 FORMAT(//,1X,A13,'-POTENTIALS ON THE PARTICLE-BASIS : JSPIN=',I2, . ' LINT=',I2,//) IF(NCHAN.EQ.1) THEN IF(ICALL.EQ.0.and.NS.NE.0) PRINT 15 15 FORMAT(1X,' : SEE POTENTIALS ON THE ISOSPIN BASIS') GOTO 1000 ENDIF C --------------------------------------------------------------------- C WRITING THE POTENTIALS: C NOMENCLATURE : C VPRT(1,*,*) = CENTRAL POTENTIAL , VPRT(2,*,*) = SPIN-SPIN POTENTIAL C VPRT(3,*,*) = TENSOR ,, , VPRT(4,*,*) = SPIN-ORBIT ,, C VPRT(5,*,*) = ASYMM. LS ,, , VPRT(6,*,*) = QUADRATIC SPIN-ORBIT, C VPRT(7,*,*) = PHI , VPRT(8,*,*) = PHI' , C VPRT(9,*,*) = PHI'' , VPRT(10,*,*)= PHIS C VPRT(11,*,*)= PHIS' , VPRT(12,*,*)= PHIS''. C DO 301 I=1,12 BM(1,1)=VI(I,1) BM(2,2)=VI(I,2) BM(1,2)=VI(I,3) BM(3,3)=VI(I,4) BM(2,1)=BM(1,2) bm(2,3)=0D0 bm(3,2)=0D0 IF(NCHAN.EQ.2) CALL TRANLN(TRANS,TRAND) IF(NCHAN.EQ.3) CALL TRANLP(TRANS,TRAND) C TRANSFORMATION FROM ISOSPIN-BASE TO PARTICLE-BASE: DO 302 I1=1,3 DO 302 J1=1,3 II=I1 JJ=J1 IF(I1.EQ.3) II=2 IF(J1.EQ.3) JJ=2 302 BMP (I1,J1)=TRANS(I1,J1)*BM(II,JJ) + TRAND(I1,J1)*BM(3,3) DO 303 II=1,3 DO 303 JJ=1,3 303 VPRT(I,II,JJ)=BMP(II,JJ) C IF(NS.GE.3) THEN IF(I.EQ.1) THEN WRITE(N2,98) WRITE(N2,*) ' POTENTIALS ON THE PARTICLE BASIS:' ENDIF WRITE(N2,332) X,TYPV(I),(VPRT(I,1,JJ),JJ=1,3), . (VPRT(I,2,JJ),JJ=1,3),(VPRT(I,3,JJ),JJ=1,3) IF(I.EQ.12) WRITE(N2,98) ENDIF 301 CONTINUE 332 FORMAT(/,1X,' X=',F10.4,' PIM-1 ',2X,A16,2X,3(D12.5,3X),/, . 41X,3(D12.5,3X),/,41X,3(D12.5,3X)) 98 FORMAT(85('=')) C --------------------------------------------------------------------- C 1000 ICALL=1 c write(*,*) 'program at 4' C C ------------------------------------------------------------------ 599 FORMAT(72('*')/,'C'/, a'C ESC-PARAMETERS : PARAMETER-MATRIX'/,'C'/, b'C PAR( 1,I)= XS G1 FD1 FV1 GS1 GA2 FA1 .GSPAIR',/, c'C PAR( 2,I)= XT ALP ALVD ALVV GS* PSID ALPA .GVPAIR',/, d'C PAR( 3,I)= X1P GETAP GOM FOM GEPS GPOM FE1 .FVPAIR',/, e'C PAR( 4,I)= X3P27 PIONC AM1RO ARO AMD 1.0 THA .GPIRO1',/, f'C PAR( 5,I)= XHIGL PION0 AM2RO BRO AM1SI ASI GT1 .GPIRO0',/, g'C PAR( 6,I)= PROTON ETA AMOM ELPHI AM2SI BSI GEFF .GPISI ',/, h'C PAR( 7,I)= NEUTRN AMX0 AMFI PSIS1 AM1ST 1.0 FT1 .HOPAIR',/, i'C PAR( 8,I)= ALM27 ALMP1 ALMV1 PSIS8 ALMS1 AMA2 FEFF .GSISI ',/, j'C PAR( 9,I)= ALM8S ALMP0 ALMV0 THS1 ALMS0 AMPOM ALMAX .GPIET',/, k'C PAR(10,I)= ALM10 THPS THV THS2 AMEPS THD SONV .GPIETP',/, l'C PAR(11,I)= ALM8A THPE THRO THDE GAMEP AHYPC SONPV .ALPAPR',/, m'C PAR(12,I)= FACNA APV FDNP1 FDNN1 GEPS2 FPOMH SONSC .ALSCPR',/, n'C PAR(13,I)= ANG51 HFPS1 HFD1 HFV1 ALS2 GPOMH SONVPR .ALVDPR',/, o'C PAR(14,I)= SON{1} FCHPI HALVD HALVV GDEL2 AMPOMH SONPPR .ALVVPR',/, p'C PAR(15,I)= RSCAL HFETP HGOM HFOM ALS GPOPP SONSPR .GPIPOM',/, q'C PAR(16,I)= FACYN ALMKA ALMKS ALMKP AMSCK AMKSS FB1 .GTENPR',/, r'C PAR(17,I)= GAMSCK FNNPI ASCK BSCK AMFI51 FALS ALFBX .FTENPR',/, s'C PAR(18,I)= AM1SCK FFA1 --- AM2SCK GPPS2 FDEL FB9 .GPSPR ',/, t'C PAR(19,I)= ALPBPR ALFFX GONP1 GONN1 FI51 FS* SONVA .GPIROV',/, u'C PAR(20,I)= AKMAX FFE1 GSNP1 GSNN1 UPOM FEPS --- .GPIOMV',/,'C',/,72('-'),/ ) C----------------------------------------------------------------- RETURN END C *************************************************************** SUBROUTINE MODPARS(IMODEL) C *************************************************************** C iopt = 4: onebos and twomes parameters set in ynmain C imodel = 1: Hard-core OBE-model-D (PRD15) ! YN-model C imodel = 2: Hard-core OBE-model-F (PRD20) ! YN-model C imodel = 3: Soft-core OBE-model (PRC40) ! YN-model C imodel = 4: Soft-core OBE-model NSC97f ! YN-model C imodel = 5: Soft-core OBE-model NSC97e ! YN-model C imodel = 6: Soft-core ESC-model ESC04A !TRUE NN+YN-model C imodel = 7: Soft-core ESC-model ESC04B !TRUE NN+YN-model C imodel = 8: Soft-core ESC-model ESC04C !TRUE NN+YN-model C imodel = 9: Soft-core ESC-model ESC04D !TRUE NN+YN-model C imodel =10: Soft-core ESC-model ESC06D !TRUE NN+YN-model C imodel =11: Soft-core ESC-model ESC06D !TRUE NN+YN-model C imodel =12: Soft-core ESC-model NILS06D1 !TRUE NN+YN-model C imodel =13: Soft-core ESC-model NILS06D3 !TRUE NN+YN-model C imodel =14: Soft-core ESC-model NILS07D !TRUE NN+YN-model C imodel =15: Soft-core ESC-model NILS07Dp !TRUE NN+YN-model C imodel =16: Soft-core ESC-model ESC04D.07odd!TRUE NN+YN-model C imodel =17: Soft-core ESC-model ESC08A !TRUE NN+YN-model C imodel =18: Soft-core ESC-model ESC08B !TRUE NN+YN-model C imodel =18: Soft-core ESC-model ESC08C !TRUE NN+YN-model C *************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ONEBOS/IOBE(7) COMMON/TWOMES/ITME(4) COMMON/ZEROS/IZERO(5) COMMON/PAROOM/APV,ISPEC(5) DIMENSION INFO(24,18) C in row 'imodel' INFO contains the model-parameters: C INFO: ipsc,ivct,iscl,idif,iaxi,iten, C ipair,itps,ipibe,ipsbe, C ipv,igm,ina,ioff,nadia, inrs,idam,igerst,igrtst C izps,izvc,izsc,izax,izten DATA INFO/1,1,1,0,0,0, 0,0,0,0, 0,0,0,0,0, 1,0,0,0, 0,0,0,0,0, ! 1 . 1,1,1,0,0,0, 0,0,0,0, 1,1,0,0,0, 1,0,0,0, 0,0,0,0,0, ! 2 . 1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0, ! 3 . 1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0, ! 4 . 1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0, ! 5 . 1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0, ! 6 . 1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0, ! 7 . 1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0, ! 8 . 1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0, ! 9 . 2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0, !10 . 2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0, !11 . 2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1, !12 . 2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1, !13 . 2,2,2,1,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1, !14 . 2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1, !15 . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1, !16 . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1, !17 . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !18 cc . 0,0,0,3,0,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !18 c . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !18 c** . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !18 ccc . 1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !17 ccc . 0,0,2,0,0,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/ !15test c** . 2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1, !14 cccc . 2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/ !15 c** . 0,0,0,0,0,1, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/ !12 c** . 0,0,0,0,2,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/ !12 c** . 2,2,2,1,1,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0, !10 c** . 2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/ !12 c* IF(IOPT.NE.4.AND.IOPT.NE.5.AND.IOPT.NE.6) THEN DO 1 KK=1,6 1 IOBE (KK) = INFO(KK ,IMODEL) DO 2 KK=1,4 2 ITME (KK) = INFO(KK+6 ,IMODEL) c* ENDIF DO 3 KK=1,5 3 ISPEC(KK) = INFO(KK+10,IMODEL) INRS = INFO(16 ,IMODEL) IDAM = INFO(17 ,IMODEL) IGERST = INFO(18 ,IMODEL) IGRTST = INFO(19 ,IMODEL) C ZEROS IN FORM FACTOR: DO 4 KK=1,5 4 IZERO(KK) = INFO(KK+19,IMODEL) RETURN END C ******************************************************************* SUBROUTINE PMEDIUM(FACMV,FACMS) C ******************************************************************* C POSSIBILITY INCLUSION NUCLEAR-MEDIUM EFFECTS ON MESON MASSES C LITERATURE: A.DF. JACKSON, Ann.Rev.Nucl.Sci. 33: 105-141 (1983) C MSIGMA(RHO_N) = MEPS*[ 1 - ALF*RHO_N + BET*RHO_N^5/3] C ------------------------------------------------------------------- IMPLICIT REAL*8(A-H,O-Z) COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4) DATA RHON/0.18D0/, ALFN/0.5D0/ c* DATA FACMV/1D0/,FACMS/1D0/ DATA MEDCALL/0/ IF(MEDCALL.GT.0) RETURN cc IF(MEDIUM.EQ.1) THEN C MEDIUM FACTORS: c* facmv = 0.85d0 c* facms = 0.85d0 cc FACMV = 1.D0-ALFN*RHON cc FACMS = 1.D0-ALFN*RHON C CHANGE IN VECTOR MESON MASSES: AM1RO = AM1RO*FACMV AM2RO = AM2RO*FACMV AMKS = AMKS *FACMV BMKS = BMKS *FACMV AMOM = AMOM *FACMV AMFI = AMFI *FACMV C HEAVY VECTOR MASSES: DO 11 KK=1,4 11 HAMVC(KK) = HAMVC(KK)*FACMV C CHANGE IN SCALAR MESON MASSES: AMD = AMD *FACMS AMSCK = AMSCK*FACMS AM1SI = AM1SI*FACMS AM2SI = AM2SI*FACMS AMSST = AMSST*FACMS AM2ST = AM2ST*FACMS C HEAVY SCALAR MASSES: DO 12 KK=1,4 12 HAMSC(KK) = HAMSC(KK)*FACMS cc ENDIF c* MEDCALL = MEDCALL + 1 cc WRITE(6,*) ' IN PMEDIUM: FACMV=',FACMV, cc .' FACMS=',FACMS,' ** MEDCALL=',MEDCALL RETURN END C ********************************************************************** subroutine escpar16(ns) C ********************************************************************** implicit real*8(a-h,o-z) common/prmtrs/par(20,8) dimension paresc16(8,20) character potname(1)*8 data potname/'ESC08c16'/ C ********************************************************************** C ESC-parameters : C ********************************************************************** C PAR( 1,I)= XS F1 FD1 FV1 GDEL GA2 FA1 GSPAIR C PAR( 2,I)= XT ALP ALVD ALVV GS* PSID ALPA GVPAIR C PAR( 3,I)= X1P FX0 GOM FOM GEPS GPOM FE1 FVPAIR C PAR( 4,I)= X3P27 PIONC AM1RO ARO AMD 1.0 THA GPIRO1 C PAR( 5,I)= CSLE PION0 AM2RO BRO AM1SI ASI GT1 GPIRO0 C PAR( 6,I)= PROTON ETA AMOM ELPHI AM2SI BSI GEFF GPISI C PAR( 7,I)= NEUTRN AMX0 AMFI PSIS1 AM1ST 1.0 FT1 HOPAIR C PAR( 8,I)= ALM27 ALMP8 ALMV8 PSIS8 ALMS8 AMA2 FEFF GSISI C PAR( 9,I)= ALM8S ALMP1 ALMV1 THS2 ALMS1 AMPOM ALMAX GPIET C PAR(10,I)= ALM10 THPS THV THS1 AMEPS THD SONV GPIETP C PAR(11,I)= ALM8A THPE THRO THDE GAMEP AHYPC SONPV ALPAPR C PAR(12,I)= FACNA APV FDNP1 FDPP1 GEPS2 FHPOM SONSC ALSCPR C PAR(13,I)= --- HFPS1 HFD1 HFV1 ALS2 GHPOM SONVPR ALVDPR C PAR(14,I)= SON(1) FCHPI HALVD HALVV --- AMPOMH SONPPR ALVVPR C PAR(15,I)= RSCAL HFETP HGOMD HFOMV ALS GPOPPH SONSPR GPIPOM C PAR(16,I)= FACYN ALMKA ALMKS ALMKP AMSCK AMKSSH FB1 GTENPR C PAR(17,I)= GAMSCK FNNPI ASCK BSCK AMFI51 FALS ALFBX FTENPR C PAR(18,I)= AM1SCK FFA1 GOMETA AM2SCK GPPS2 FDEL FB9 GPSPR C PAR(19,I)= --- ALFFX GONP1 GONN1 FI51 FS* SONVA GPIROV C PAR(20,I)= AKMAX FFE1 GSNP1 GSNN1 UPOM FEPS --- GPIOMV C ********************************************************************** C Soft-core model ESC08c, parbbsc.best16 DATA PARESC16/ A .000000000000000D+00, .268739630566707D+00, .634276647640713D+00, 2 .383071425426434D+01, 3 .635117390573632D+00,-.294576790000000D-10,-.816770798498021D+00, 4-.380908010000000D-10, B .000000000000000D+00, .365000000000000D+00, .100000000000000D+01, 2 .472498073766573D+00, 3-.838936300000000D+00, .000000000000000D+00, .329581455726579D+00, 4 .341310362965063D-01, C .000000000000000D+00, .251888683720332D+00, .336914849996356D+01, 2-.768271131972376D+00, 3 .440499499151728D+01, .332674289587370D+01,-.768739327855443D+00, 4-.249337865026942D+00, D .000000000000000D+00, .139570000000000D+03, .647435800000000D+03, 2 .190675900000000D+00, 3 .962000000000000D+03, .100000000000000D+01, .500000000000000D+02, 4 .743829264708528D+00, E .500000000000000D-01, .134960000000000D+03, .898174100000000D+03, 2 .796489500000000D+00, 3 .496397963027437D+03, .217807195795809D+00, .000000000000000D+00, 4 .000000000000000D+00, F .938259300000000D+03, .548800050000000D+03, .783899900000000D+03, 2-.279545880000000D+02, 3 .136559411299000D+04, .782192804204191D+00, .000000000000000D+00, 4-.438383378828360D-01, G .939552700000000D+03, .957500000000000D+03, .101950000000000D+04, 2 .000000000000000D+00, 3 .993000000000000D+03, .100000000000000D+01, .000000000000000D+00, 4-.817710798346652D-02, H .964524200000000D+03, .102941770301647D+04, .688404457838911D+03, 2 .000000000000000D+00, 3 .893525915831090D+03, .307809600000000D+03, .000000000000000D+00, 4 .482785590000000D-10, I .100000000000000D+01, .102941770301647D+04, .771322309873320D+03, 2 .352600000000000D+02, 3 .113609933385847D+04, .223122299428729D+03, .107656083400411D+04, 4-.173520396031822D+00, J .300000000000000D+01,-.130000000000000D+02, .387000000000000D+02, 2 .352600000000000D+02, 3 .760000000000000D+03, .000000000000000D+00, .100000000000000D+01, 4 .000000000000000D+00, K .000000000000000D+00, .570000000000000D+00,-.285000000000000D+01, 2 .171000000000000D+01, 3 .640000000000000D+03, .000000000000000D+00, .100000000000000D+01, 4 .400000000000000D+00, L .000000000000000D+00, .100000000000000D+01, .584139959279144D+00, 2 .632954838029737D+00, 3 .000000000000000D+00,-.415563334435476D+01, .100000000000000D+01, 4 .100000000000000D+01, M .000000000000000D+00, .000000000000000D+00, .000000000000000D+00, 2 .000000000000000D+00, 3 .000000000000000D+00, .435747052275295D+01, .100000000000000D+01, 4 .100000000000000D+01, N .000000000000000D+00, .000000000000000D+00, .000000000000000D+00, a .000000000000000D+00, b .000000000000000D+00, .270480960439385D+03, .100000000000000D+01, c .400000000000000D+00, O .100000000000000D+01, .000000000000000D+00, .000000000000000D+00, a .000000000000000D+00, b .100000000000000D+01, .460450260000000D+01, .100000000000000D+01, c .456285030000000D-10, P .100000000000000D+01, .000000000000000D+00, .000000000000000D+00, a .000000000000000D+00, b .816000000000000D+03, .000000000000000D+00,-.197451123564073D+00, c .000000000000000D+00, Q .000000000000000D+00, .000000000000000D+00, .100000000000000D+01, a .000000000000000D+00, b .000000000000000D+00, .100000000000000D+01, .400000000000000D+00, c .000000000000000D+00, R .816000000000000D+03, .258491030080958D+01, .000000000000000D+00, 2 .145373457988075D+04, 3 .000000000000000D+00, .000000000000000D+00,-.758754557938523D-01, 4 .000000000000000D+00, S .400000000000000D+00, .000000000000000D+00, .000000000000000D+00, 2 .000000000000000D+00, 3 .297000000000000D+00, .000000000000000D+00, .100000000000000D+01, 4 .000000000000000D+00, T .000000000000000D+00,-.544806138335060D+00, .000000000000000D+00, 2 .000000000000000D+00, 3 .939000000000000D+03, .000000000000000D+00, .000000000000000D+00, 4 .000000000000000D+00/ C ********************************************************************** save do 1 i=1,20 do 1 j=1,8 par(i,j) = paresc16(j,i) 1 continue if(ns.ge.1) then write(6,599) write(6,2) potname(1) 2 format(/,' ESCPAR16 -> PARAMETERS: ',A8,/) do 3 i=1,20 write(6,4) i,(par(i,j),j=1,4),(par(i,j),j=5,8) 3 continue 4 format(1x,'i=',i2,4(d15.7,2x),/,5x,4(d15.7,2x)) endif C ------------------------------------------------------------------ 599 FORMAT(72('*')/,'C'/, a'C ESC-PARAMETERS : PARAMETER-MATRIX'/,'C'/, b'C PAR( 1,I)= XS G1 FD1 FV1 GS1 GA2 FA1 .GSPAIR',/, c'C PAR( 2,I)= XT ALP ALVD ALVV GS* PSID ALPA .GVPAIR',/, d'C PAR( 3,I)= X1P GETAP GOM FOM GEPS GPOM FE1 .FVPAIR',/, e'C PAR( 4,I)= X3P27 PIONC AM1RO ARO AMD 1.0 THA .GPIRO1',/, f'C PAR( 5,I)= XHIGL PION0 AM2RO BRO AM1SI ASI GT1 .GPIRO0',/, g'C PAR( 6,I)= PROTON ETA AMOM ELPHI AM2SI BSI GEFF .GPISI ',/, h'C PAR( 7,I)= NEUTRN AMX0 AMFI PSIS1 AM1ST 1.0 FT1 .HOPAIR',/, i'C PAR( 8,I)= ALM27 ALMP1 ALMV1 PSIS8 ALMS1 AMA2 FEFF .GSISI ',/, j'C PAR( 9,I)= ALM8S ALMP0 ALMV0 THS1 ALMS0 AMPOM ALMAX .GPIET',/, k'C PAR(10,I)= ALM10 THPS THV THS2 AMEPS THD SONV .GPIETP',/, l'C PAR(11,I)= ALM8A THPE THRO THDE GAMEP AHYPC SONPV .ALPAPR',/, m'C PAR(12,I)= FACNA APV FDNP1 FDNN1 GEPS2 FPOMH SONSC .ALSCPR',/, n'C PAR(13,I)= ANG51 HFPS1 HFD1 HFV1 ALS2 GPOMH SONVPR .ALVDPR',/, o'C PAR(14,I)= SON{1} FCHPI HALVD HALVV GDEL2 AMPOMH SONPPR .ALVVPR',/, p'C PAR(15,I)= RSCAL HFETP HGOM HFOM ALS GPOPP SONSPR .GPIPOM',/, q'C PAR(16,I)= FACYN ALMKA ALMKS ALMKP AMSCK AMKSS FB1 .GTENPR',/, r'C PAR(17,I)= GAMSCK FNNPI ASCK BSCK AMFI51 FALS ALFBX .FTENPR',/, s'C PAR(18,I)= AM1SCK FFA1 --- AM2SCK GPPS2 FDEL FB9 .GPSPR ',/, t'C PAR(19,I)= ALPBPR ALFFX GONP1 GONN1 FI51 FS* SONVA .GPIROV',/, u'C PAR(20,I)= AKMAX FFE1 GSNP1 GSNN1 UPOM FEPS --- .GPIOMV',/,'C',/,72('-'),/ ) C----------------------------------------------------------------- return end C *************************************************************** C *************************************************************** * BLOCK DATA YNBLK C *************************************************************** c COMMON/INMES/INPS,INVCT,INSC,INDIF,INAX,INTEN c CHARACTER*4 INPS(4) /'YES','YES','YES','YES'/ c CHARACTER*4 INVCT(4)/'YES','YES','YES','YES'/ c CHARACTER*4 INSC(4) /'YES','YES','YES','YES'/ c CHARACTER*4 INDIF(4)/'YES','YES','YES','YES'/ c CHARACTER*4 INAX(4) /'NO ','NO ','NO ','NO '/ C CHARACTER*4 INPS(4) /'NO ','NO ','NO ','NO '/ C CHARACTER*4 INVCT(4)/'NO ','NO ','NO ','NO '/ C CHARACTER*4 INSC(4) /'NO ','NO ','NO ','NO '/ C CHARACTER*4 INDIF(4)/'NO ','NO ','NO ','NO '/ C CHARACTER*4 INTEN(4)/'NO ','NO ','NO ','NO '/ c END C *************************************************************** SUBROUTINE WRLDCOP2(NCHAN,LINT,JSPIN,ICSB,NS) C ****************************************************** C version september 2000: version with 2 scalar nonets C C ioptsc = 2: C 1) su3-nonet : eps(760), del(962), S*(993), kappa(900) C 2) su3-nonet : f0(1370), a0(1450), f0(1580), k**(1430) C note: modern notation: eps9760)=f0(760), del(962)=a0(9800, S*(993)=f0(975) C used notations: f0(1370)=eps2, a0(1450)=del2, f091580)=S2, K**(1430)=kappa2 C ****************************************************************** C Parameters: Organization DEC.2004 C ****************************************************************** C C OBE-PARAMETERS ETC.: C C PAR( 1,I)= XS G1 FD1 FV1 GS1 GA2 FA1 GSPAIR C PAR( 2,I)= XT ALP ALVD ALVV GS* PSID ALPA GVPAIR C PAR( 3,I)= X1P GETAP GOM FOM GEPS GPOM FE1 FVPAIR C PAR( 4,I)= X3P27 PIONC AM1RO ARO AMD 1.0 THA GAPAIR C PAR( 5,I)= XHIGL PION0 AM2RO BRO AM1SI ASI GT1 HAPAIR C PAR( 6,I)= PROTON ETA AMOM ELPHI AM2SI BSI GEFF GPPAIR C PAR( 7,I)= NEUTRN AMX0 AMFI PSIS1 AM1ST 1.0 FT1 HOPAIR C PAR( 8,I)= ALM27 ALMP1 ALMV1 PSIS8 ALMS1 AMA2 FEFF GEPAIR C PAR( 9,I)= ALM8S ALMP0 ALMV0 THS1 ALMS0 AMPOM ALMAX GPIET C PAR(10,I)= ALM10 THPS THV THS2 AMEPS THD SONV GPIETP C PAR(11,I)= ALM8A THPE THRO THDE GAMEP AHYPC SONPV ALPAPR C PAR(12,I)= ALM10S APV FDNP1 FDNN1 GEPS2 FPOMH SONSC ALSCPR C PAR(13,I)= ALM1 HFPI HFD1 HFV1 ALS2 GPOMH SONVPR ALVDPR C PAR(14,I)= --- FCHPI HALVD HALVV GDEL2 AMPOMH SONPPR ALVVPR C PAR(15,I)= RSCAL HFETP HGOM HFOM ALS GPOPP SONSPR GPIPOM C PAR(16,I)= FACYN ALMKA ALMKS ALMKP AMSCK AMKSS FB1 GTENPR C PAR(17,I)= FACYY --- --- --- --- FALS ALFBX FTENPR C PAR(18,I)= --- FFA1 --- --- GPPS2 FDEL FB9 GPSPR C PAR(19,I)= --- ALFFX --- --- FI51 FS* SONVA GPIROV C PAR(20,I)= AKMAX FFE1 --- --- UPOM FEPS --- GPIOMV C HERE : PHYSICAL COUPLINGS, EXCEPT FOR C THE SU3-SINGLET COUPLINGS GPS1 AND FD1 C C ****************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2 COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA COMMON/INMES/INPS,INVCT,INSC,INDIF,INAX,INTEN CHARACTER*4 INPS(4),INVCT(4),INSC(4),INDIF(4),INAX(4),INTEN(4) COMMON/PRMTRS/PAR(20,8) COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALAMK,ALMKS,ALMKAP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/ALLAX/ FA(11),FFA(11),FB(11),ALMAX c COMMON/MIXING/THPS,THV,THS,THD COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPAX COMMON/ALLSC2/ELPHI,PSIS1,PSIS8,THSD1,THSD2, . GSA(11),GSB(11),IOPTSC COMMON/ALLSC3/FS COMMON/HVY/HFPS(11),GT(11),FT(11),HFD(11),HFV(11) COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GAPAIR,HAPAIR,GPPAIR,HOPAIR . ,GEPAIR,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION F(11),G(11),FD(11),FV(11),GS(11),FS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)), .(GS1,GS(1)),(FS1,FS(1)),(GD1,GD(1)) C DATA SR2/1.4142136D0/,SR3/1.732051D0/, , AMPRO/938.2796D0/,N2/6/,IEXDB/0/,IEXD/0/, . ALVVH/0.D0/,INIT/0/,ICALL/0/,I3P0/1/ C C C F AND G PSEUDOSCALAR C FD VECTOR DIRECT = ELECTRIC C FV VECTOR DERIVATIVE = MAGNETIC C USED INDEXING OF THE COUPLINGS : C 1 =NNP NNRO NNDEL NNA2 C 2 =SSP SSRO SSDEL SSA2 C 3 =LSP LSRO LSDEL LSA2 C 4 =LNK LNKS LNKAP LNK** C 5 =SNK SNKS SNKAP SNK** C 6 =NNE NNOM NNEPS NNPOM C 7 =LLE LLOM LLEPS LLPOM C 8 =SSE SSOM SSEPS SSPOM C 9 =NNX NNFI NNS* NNF2 C 10=LLX LLFI LLS* LLF2 C 11=SSX SSFI SSS* SSF2 C C NNX STANDS FOR NNETA' ETC. C F AND G PSEUDOSCALAR C FD VECTOR DIRECT COUPLING C FV VECTOR DERIVATIVE COUPLING C c fstar = 0.6d0 c if(icall.eq.0) ampro = ampro*fstar c* APV = PAR(15,2) APV = PAR(12,2) c write(*,*) 'WARNING: APV = 0 !!!!!!!!!!!!!' c apv = 0d0 SONV = PAR(10,7) SONPV = PAR(11,7) SONSC = PAR(12,7) IF(SONPV.EQ.0.D0) SONPV=1.D0 IF(SONV.EQ.0.D0) SONV=SONPV IF(SONSC.EQ.0.D0) SONSC=SONPV IF(I3P0.EQ.1) THEN c* SONPV= SONV SONSC= SONV SONVA= SONV ENDIF IF(ICALL.EQ.0.and.NS.NE.0) THEN WRITE(*,*) ' NOTICE: *************************************' WRITE(*,*) ' I3P0=',I3P0,' SONVP.NE.SONV=SONSC=SONVA' c** WRITE(*,*) ' I3P0=',I3P0,' SONVP.EQ.SONV=SONSC=SONVA' WRITE(*,*) ' NOTICE: *************************************' ENDIF C C SETTING VALUE EXCHANGE-OPERATOR P C MAN=MOD(LINT+JSPIN+1,2) P=1.D0 IF(MAN.EQ.0) P=-P C 12 PI=DACOS(-1.D0) CONV=PI/180.D0 RSCAL=DSQRT(PAR(15,1)) IF(IMODEL.LE.2) THEN G1 =PAR(1,2)*RSCAL G9 =PAR(3,2)*RSCAL ENDIF IF(IMODEL.GE.3) THEN F1 =PAR(1,2)*RSCAL F9 =PAR(3,2)*RSCAL ENDIF ALP =PAR(2,2) THPS=PAR(10,2) FD1 =PAR(1,3)*RSCAL ALVD=PAR(2,3) GOM =PAR(3,3)*RSCAL THV =PAR(10,3) FV1 =PAR(1,4)*RSCAL ALVV=PAR(2,4) FOM =PAR(3,4)*RSCAL GDEL=PAR(1,5)*RSCAL GSST=PAR(2,5)*RSCAL GEPS=PAR(3,5)*RSCAL THS =PAR(10,4) C * in this version only the 1-nonet model implemented: C two-nonet model parameters: ELPHI = PAR(6,4) PSIS1 = PAR(7,4) PSIS8 = PAR(8,4) THS1 = PAR(9,4) THS2 = PAR(10,4) GA2 =PAR(1,6)*RSCAL GPOM =PAR(3,6)*RSCAL PSID =PAR(2,6) THD =PAR(10,6) AHYPC= PAR(11,6) FA1 = PAR(1,7)*RSCAL FE1 = PAR(3,7)*RSCAL THA = PAR(4,7) ALPAX= PAR(2,7) IF(ALPAX.EQ.0.D0) ALPAX =ALP SON = PAR(11,7) C EXACT FLAVOR-SYMMETRY: IF(NSU3F.EQ.1) THEN AHYPC= 0.D0 THPS = 0.D0 THV = 0.D0 THS = 0.D0 THD = 0.D0 THA = 0.D0 ENDIF C THPSD=THPS THVD =THV THSD =THS THDD =THD THAD =THA PSIDD=PSID THPS=THPS*CONV THV =THV *CONV THS =THS *CONV THD =THD *CONV THA =THA *CONV PSID=PSID*CONV ELPHI = ELPHI*CONV PSIS1 = PSIS1*CONV PSIS8 = PSIS8*CONV THS1 = THS1 *CONV THS2 = THS2 *CONV C C SU3 FOR 1) PV-COUPLINGS PS-SCALAR MESONS C 2) PAULI-COUPLINGS VECTOR MESONS C********************************************************************* C C PSEUDOSCALAR COUPLING CONSTANTS C C********************************************************************* IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) IF(IMODEL.LE.2) THEN F1 =PIM*G1/(2.*AM(1)) GX0= G9 FX0=PIM*G9/(2.*AM(1)) ENDIF IF(IMODEL.GT.2) THEN G1=2*AM(1)*F1/PIM FX0 = F9 GX0=2*AM(1)*F9/PIM ENDIF COST=DCOS(THPS) SINT=DSIN(THPS) F9 = (FX0-SINT*(4*ALP-1.D0)*F1/SR3)/COST G9 = (GX0-SINT*(4*ALP-1.D0)*G1/SR3)/COST IF(IPV.EQ.0) CALL SU3(G,ALP) IF(IPV.EQ.1) CALL SU3(F,ALP) c IF(NS.GE.1) WRITE(N2,450) G9,F9,ALP,THPSD,IPV,APV,SONPV IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,450) G9,F9,ALP,THPSD,IPV,APV,SONPV 450 FORMAT(' PS-SCALAR SINGLET COUPLING G9= ',F12.6,' F9=', .F12.6,/,24X,' ALP=',F7.3,' THETA =',F12.6,' IPV=',I2, ./,24X,' APV=',F7.3,' SONPV= ',F7.2,/) C SU(3)-SYMMETRY BREAKING: c IF(SONPV.NE.1.D0) THEN c IF(IPV.EQ.0) CALL SU3SB(G,SONPV,1) c IF(IPV.EQ.1) CALL SU3SB(F,SONPV,1) c ENDIF IF(SONPV.NE.1D0) CALL SU3SB03(G,ALP,SONPV) IF(SONPV.NE.1D0) CALL SU3SB03(F,ALP,SONPV) C C ETA - X0 MIXING C C MIND DIFFERENCE IN POSITION WITH VECTOR AND SCALAR MESONS C 700 IF(IPV.EQ.1) THEN DO 701 JO=6,8 JS=JO+3 WOV=F(JO) WSV=F(JS) F(JS)= COST*WSV+SINT*WOV 701 F(JO)=-SINT*WSV+COST*WOV G1 =2*AM(1)*F1/PIM G2 =2*AMY(2)*F2/PIM G3 =2*AMH*F3/PIM G4 =2*AMLN*F4/PIM G5 =2*AMSN*F5/PIM G6 =2*AM(1)*F6/PIM G7 =2*AMY(1)*F7/PIM G8 =2*AMY(2)*F8/PIM G9 =2*AM(1)*F9/PIM G10=2*AMY(1)*F10/PIM G11=2*AMY(3)*F11/PIM ENDIF IF(IPV.EQ.0) THEN DO 702 JO=6,8 JS=JO+3 WOV=G(JO) WSV=G(JS) G(JS)= COST*WSV+SINT*WOV 702 G(JO)=-SINT*WSV+COST*WOV F1 =G1*PIM/(2*AM(1)) F2 =G2*PIM/(2*AMY(2)) F3 =G3*PIM/(2*AMH) F4 =G4*PIM/(2*AMLN) F5 =G5*PIM/(2*AMSN) F6 =G6*PIM/(2*AM(1)) F7 =G7*PIM/(2*AMY(1)) F8 =G8*PIM/(2*AMY(2)) F9 =G9*PIM/(2*AM(1)) F10=G10*PIM/(2*AMY(1)) F11=G11*PIM/(2*AMY(3)) ENDIF C C USED IN OBE-PROGRAMS (SCSP ETC.) TO INCLUDE MASS FACTORS IN C POTS: (OLD WAY OF HELDER!, HAS GIVEN CONFUSION IN THE PAST!) c F2=PIM*G2/(2.*AMY(2)) c F3=PIM*G3/(2.*AMH) c F4=AMK*G4/(2.*AMLN) c F5=AMK*G5/(2.*AMSN) c F6=AME*G6/(2.0*AM(1)) c F7=AME*G7/(2.*AMY(1)) c F8=AME*G8/(2.*AMY(2)) c F9=AMX*G9/(2.0*AM(1)) c F10=AMX*G10/(2.0*AMY(1)) c F11=AMX*G11/(2.0*AMY(3)) C C !! IN THIS VERSION: WE INCLUDE THESE IN ROUTINE PSSCAL!! C SELECTION PSEUDO-SCALAR CONTRIBUTIONS CALL SELECT(F,INPS) CALL SELECT(G,INPS) C********************************************************************* C C COUPLING CONSTANTS FOR VECTOR MESON POTENTIALS C C********************************************************************* IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) IF(NCHAN.EQ.1.AND.PAR(20,7).NE.0D0) FD1=PAR(20,7) FD(9)=GOM FV(9)=FOM COST=DCOS(THV) SINT=DSIN(THV) IF(IGM.EQ.0) THEN FD9 = (GOM-SINT*(4*ALVD-1.D0)*FD1/SR3)/COST FV9 = (FOM-SINT*(4*ALVV-1.D0)*FV1/SR3)/COST ENDIF IF(IGM.EQ.1) THEN FD9 = (GOM-SINT*(4*ALVD-1.D0)*FD1/SR3)/COST FV9 = (GOM+FOM-SINT*(4*ALVV-1.D0)*(FD1+FV1)/SR3)/COST ENDIF CALL SU3(FD,ALVD) CALL SU3(FV,ALVV) c IF(NS.GE.1) WRITE(N2,550) FD9,FV9,ALVD,ALVV,THVD,IGM IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,550) FD9,FV9,ALVD,ALVV,THVD,IGM,INRS,SONV 550 FORMAT(' VECTOR SINGLET COUPLINGS FD9= ',F12.6,' FV9=', .F12.6,/,24X,' ALVD=',F12.6,' ALVV=',F12.6,' THETA=',F12.6, ./,24X,' IGM=',I2,' INRS=',I2,' SONV=',F7.2,//) C SU(3)-SYMMETRY BREAKING: c IF(SONV.NE.1.D0) CALL SU3SB(FD,SONV,2) c IF(SONV.NE.1.D0) CALL SU3SB(FV,SONV,2) IF(SONPV.NE.1D0) CALL SU3SB03(FD,ALVD,SONV) IF(SONPV.NE.1D0) CALL SU3SB03(FV,ALVV,SONV) ALVVH=ALVV INIT=1 DO 5 JO=6,8 JS=JO+3 WOV=FV(JO) WOD=FD(JO) WSV=FV(JS) WSD=FD(JS) FV(JO)= COST*WSV+SINT*WOV FD(JO)= COST*WSD+SINT*WOD FV(JS)=-SINT*WSV+COST*WOV FD(JS)=-SINT*WSD+COST*WOD 5 CONTINUE IF (IGM.EQ.0) GO TO 711 DO 712 I=1,11 712 FV(I)=FV(I)-FD(I) 711 CONTINUE C SELECTION VECTOR MESON CONTRIBUTIONS CALL SELECT(FD,INVCT) CALL SELECT(FV,INVCT) C********************************************************************* C C SCALAR COUPLING CONSTANTS C C********************************************************************* IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) 501 FORMAT(72('-')) C PRESERVATION INPUT NN-COUPLINGS: GDELLD = GDEL GEPSLD = GEPS GSSTLD = GSST IF(ISCL.EQ.1) IOPTSC=1 IF(ISCL.EQ.2) IOPTSC=2 GDEL2 = PAR(14,5)*RSCAL GEPS2 = PAR(12,5)*RSCAL GSST2 = 0.D0 C SEPARATION TWO NONETS: DEL(962) AND DEL2(1450) NN-COUPLINGS: c GDELI = GDEL c GDELI2= 0.D0 c PSIS8D= PSIS8/CONV c CALL CNSTR97(PSIS8D,GDELI,GDELI2,GDEL,GDEL2,2) C REDEFINITION EPS(760) AND GEPS(1370) NN-COUPLINGS: c GEPSI = GEPS c GEPS2I= GEPS2 c ELPHI2= PSIS1/CONV c CALL CNSTR97(ELPHI2,GEPSI,GEPS2I,GEPS,GEPS2,5) C REDEFINITION EPS(760) AND S(993) NN-COUPLINGS: GEPSI = GEPS GSSTI = GSST ELPHID= ELPHI/CONV CALL CNSTR97(ELPHID,GEPSI,GSSTI,GEPS,GSST,1) C REDEFINITION EPS(1370) AND S(1580) NN-COUPLINGS: c GEPSI = GEPS2 c GSSTI = GSST2 c ELPHI2= PSIS1/CONV c CALL CNSTR97(ELPHI2,GEPSI,GSSTI,GEPS2,GSST2,3) C--------------------------------------------------------------------- C FIRST SCALAR NONET: GS1=GDEL COST=DCOS(THS) SINT=DSIN(THS) C** SU3-assignments 'bare' mesons: C warning: check consistency with SCALAR !! C** S* similar to PHI(1020): GS9 = COST*GEPS-SINT*GSST GS6 = SINT*GEPS+COST*GSST ALS = PAR(15,5) C ABANDOING CONSTRAINT: ALS=ALS(THS1): IF(PAR(15,5).NE.0.D0) THEN GS(9)= (GEPS-SINT*(4*ALS-1.D0)*GS(1)/SR3)/COST GSST = -SINT*GS(9)+COST*(4*ALS-1.D0)*GS(1)/SR3 ENDIF IF(ALS.EQ.0.D0.AND.GS1.NE.0.D0) .ALS = 0.25D0*(SR3*GS6/GS1+1.D0) IF(ALS.EQ.0.AND.DABS(GS1).LT.1.D-06) ALS = 0.25D0 CALL SU3(GS,ALS) C SU(3)-SYMMETRY BREAKING: c IF(SONSC.NE.1.D0) CALL SU3SB(GS,SONSC,3) IF(SONSC.NE.1D0) CALL SU3SB03(GS,ALS,SONSC) C---------------------------------------------------------------- C DERIVATIVE COUPLINGS: FALS = PAR(17,6) IF(FALS.EQ.0D0) FALS=ALS FS(1)= PAR(18,6)*RSCAL FSST = PAR(19,6)*RSCAL FEPS = PAR(20,6)*RSCAL FS9 =COST*FEPS-SINT*FSST FS6 =SINT*FEPS+COST*FSST CALL SU3(FS,FALS) IF(SONSC.NE.1.D0) CALL SU3SB03(FS,FALS,SONSC) C---------------------------------------------------------------- THSD =THS/CONV IF(ICALL.EQ.0.and.NS.NE.0) THEN WRITE(N2,500) IOPTSC,GS9,GS6,GDEL,GEPS,GSST,ALS,THSD,SONSC . ,FS9,FS6,FS1,FEPS,FSST,FALS 500 FORMAT(' 1rst SCALAR NONET SU3{1}: IOPTSC=',I2,' GS9 =',F9.5, .' GS6 =',F9.5,/,22X,' GDEL=',F9.5, .' GEPS=',F9.5,' GSST=',F9.5,/,22X,' ALS =',F9.3,' THS =',F9.3, .' SONSC=',F6.2,//, .' 1rst DERIVATIVE COUPLING :',11X,' FS9 =',F9.5, .' FS6 =',F9.5,/,22X,' GDEL=',F9.5, .' FEPS=',F9.5,' FSST=',F9.5,' FALS=',F9.3,/) c WRITE(N2,511) GEPS,GEPLL,GEPSS c511 FORMAT(' SCALAR SINGLET SU3{1}: GEPS =',F9.5, c .' GEPLL=',F9.5,' GEPSS=',F9.5,/) IF(PAR(13,1).NE.0.D0) WRITE(N2,521) 521 FORMAT(25X,' ALS-THS CONSTRAINT ABANDNED',/) ENDIF DO 55 JO=6,8 JS=JO+3 WOS=GS(JO) WSS=GS(JO+3) GS(JO)= COST*WSS+SINT*WOS GS(JS)=-SINT*WSS+COST*WOS WOS=FS(JO) WSS=FS(JO+3) FS(JO)= COST*WSS+SINT*WOS 55 FS(JS)=-SINT*WSS+COST*WOS C SU3-NONET COUPLINGS STORED IN GSB(KK): DO 56 KK=1,11 56 GSB(KK) = GS(KK) C RESTORATION INPUT NN-COUPLINGS: GDEL = GDELLD GEPS = GEPSLD GSST = GSSTLD C ------------------------------------------------------------------ C PPNP, Vol.12: DOVER AND GAL NUMBERS: c IF(ICALL.EQ.0.and.NS.NE.0) THEN c WRITE(6,531) c 531 FORMAT(/,72('-'),/, c .' DOVER AND GAL NUMBERS (PPNP, VOL.12), EQN.(2.40):') c RLNLS = (2D0/3d0)*(GS(7)/GS(6))*(1D0+(FD(7)/GS(7))*(FD(6)/GS(6))* c .(3D0+4*FV(7)/FD(7)))/(1D0+(FD(6)/GS(6))**2*(3D0+4*FV(6)/FD(6))) c RSNLS = (2D0/3d0)*(GS(8)/GS(6))*(1D0+(FD(8)/GS(8))*(FD(6)/GS(6))* c .(3D0+4*FV(8)/FD(8)))/(1D0+(FD(6)/GS(6))**2*(3D0+4*FV(6)/FD(6))) c WRITE(6,532) RLNLS,RSNLS c 532 FORMAT(' LN: V_SO(LN)/V_SO(NN)=',F4.2,' SN: V_SO(SN)/V_SO(NN)=', c .F6.2) c WRITE(6,501) c ENDIF C ------------------------------------------------------------------ C SECOND SCALAR NONET: GSA(1)=GDEL2 ALS2 = PAR(13,5) IF(ALS2.EQ.0.D0) ALS2 = ALS THS2 = PAR(9,4)*CONV IF(THS2.EQ.0.D0) THS2 = THS THSD2 = THS2/CONV COST=DCOS(THS2) SINT=DSIN(THS2) C** SU3-assignments 'bare' mesons: C warning: check consistency with SCALAR !! C** S* similar to PHI(1020): c new july 2006: GSA(9) = (GEPS2-SINT*(4*ALS2-1.D0)*GSA(1)/SR3)/COST GSST2 = -SINT*GSA(9)+COST*(4*ALS2-1.D0)*GSA(1)/SR3 GSA(9) = COST*GEPS2-SINT*GSST2 GSA(6) = SINT*GEPS2+COST*GSST2 CALL SU3(GSA,ALS2) IF(ICALL.EQ.0.and.NS.NE.0) THEN THSD1 = THS1/CONV WRITE(N2,511) IOPTSC,GSA(9),GEPS2,ALS2,THSD1 511 FORMAT(' 2nd SCALAR NONET SU3{1}: IOPTSC=',I2,' GS9= ',F9.5, .' GEPS2=',F9.5,/,22X,' ALS2=',F9.3,' THS1=',F9.3) ENDIF DO 57 JO=6,8 JS=JO+3 WOS=GSA(JO) WSS=GSA(JS) GSA(JO)= COST*WSS+SINT*WOS 57 GSA(JS)=-SINT*WSS+COST*WOS C SELECTION SCALAR MESON CONTRIBUTIONS CALL SELECT(GSA,INSC) C--------------------------------------------------------------------- IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,512) IGERST,PAR(10,5),PAR(11,5),ASI,AM1SI,BSI,AM2SI 512 FORMAT(/,72('-'),/,' TREATMENT BROAD EPSILON: IGERST=',I2, .' AMEPS=',F9.3,' GAMEP=',F9.3,//,2X,' ASI=',F9.5,' AM1SI=',F12.5, .' BSI=',F9.5,' AM2SI=',F12.5,/) C********************************************************************* C C POMERON-TYPE OF COUPLINGS C C********************************************************************* C VERSION SEPTEMBER 2004 C********************************************************************* IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) IF(GA2.EQ.0D0) THEN PSID = 0D0 DO 113 KK=1,11 113 GDA(KK) = 0D0 ENDIF GPOM1 = GPOM*DCOS(PSID) GPOMP = GPOM*DSIN(PSID) GD(1) = 0D0 GD(9) = GPOM1 CALL SU3(GD,ALVD) PSIDD=PSID/CONV C------------------------------------------------------------------- C ODDERON PARAMETERS: GPOMH = PAR(13,6) FPOMH = PAR(12,6) AMPOMH= PAR(14,6) C------------------------------------------------------------------- IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,400) GPOM,GPOM1,PSIDD .,GPOMH,FPOMH,AMPOMH 400 FORMAT(' POMERON SINGLET COUPLING GPOM = ',F9.5, ,' GPOM1 =',F9.5,' PSID=',F9.3,/, .' NOTICE: FLAVOR DEPENDENCE!! ', .' GPOMH=',F9.5,' FPOMH=',F9.5,' AMPOMH=',F9.3,/) C------------------------------------------------------------------- c flavor dependent couplings: if(ahypc.ne.0d0) then c gd(10) = gd(10)*amy(1)/am(1) c gd(11) = gd(11)*amy(2)/am(1) cc gd(10) = gd(10)*am(1)/amy(1) cc gd(11) = gd(11)*am(2)/amy(1) gd(10) = gd(10)*(1d0+ahypc*(amy(1)/am(1)-1d0)) gd(11) = gd(11)*(1d0+ahypc*(amy(2)/am(1)-1d0)) endif IF(GA2.NE.0D0) THEN GDA(1) = GA2 ALD=ALVD SOND = SONV THD =THV THDD=THD/CONV SINT=DSIN(THD) COST=DCOS(THD) GDA(9) = (GPOMP-SINT*(4*ALD-1D0)*GDA(1)/SR3)/COST IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,401) GDA(1),GDA(9),ALD,THDD,PSIDD,AHYPC 401 FORMAT(' DIFFRACTIVE NONET GDA1 = ',F9.5,' GDA9=',F9.5, .' ALPHA =',F9.3,/,24X,' THETA =',F12.6,' PSID=',F10.4, .' AHYPC=',F10.4,/) CALL SU3(GDA,ALD) IF(SOND.NE.1D0) CALL SU3SB03(GDA,ALD,SOND) DO 65 JO=6,8 JS=JO+3 WOD=GDA(JO) WSD=GDA(JS) GDA(JO)= COST*WSD+SINT*WOD 65 GDA(JS)=-SINT*WSD+COST*WOD ENDIF C FLAVOR INDEPENDENCE : MASS-FACTORS c IF(AHYPC.EQ.0.D0) GOTO 64 c GD2=GD2*AMPRO/AMSS c GD3=GD3*AMPRO/DSQRT(AMSS*AMY(1)) c GD4=GD4*AMPRO/DSQRT(AMLN*AM(1) ) c GD5=GD5*AMPRO/AMLS c GD7=GD7*AMPRO/AMY(1) c GD8=GD8*AMPRO/AMSS c GD10=GD10*AMPRO/AMY(1) c GD11=GD11*AMPRO/AMSS c 64 CONTINUE C--------------------------------------------------------------------- C VERSION JULY 2007: C--------------------------------------------------------------------- IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,403) PAR(14,6),PAR(13,6) 403 FORMAT(' HARD-POMERON SINGLET AMPOMH = ',F9.5,' GPOMH=',F9.5,/) C--------------------------------------------------------------------- C SELECTION DIFFRACTIVE CONTRIBUTIONS CALL SELECT(GD,INDIF) IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) C********************************************************************* C C AXIAL COUPLING CONSTANTS C C********************************************************************* IF(IAXI.EQ.0) THEN FA1 = 0D0 FE1 = 0D0 ENDIF FA(1) = FA1 ALMAX = PAR(9,7) COST = DCOS(THA) SINT = DSIN(THA) FA(9) = (FE1-SINT*(4*ALPAX-1.D0)*FA1/SR3)/COST CALL SU3(FA,ALPAX) IF(SONVA.NE.1D0) CALL SU3SB03(FA,ALPAX,SONVA) IF(ICALL.EQ.0.and.NS.NE.0) THEN THAD = THA/CONV WRITE(N2,514) FA(1),FA(9),ALPAX,THAD,ALMAX 514 FORMAT(' AXIAL NONET SU3{1}: FA1 =',F9.5,' FA9=',F9.5, ./,20X,' ALPAX=',F9.3,' THA=',F9.3,' ALMAX=',F10.3) ENDIF DO 75 JO=6,8 JS=JO+3 WOS=FA(JO) WSS=FA(JS) FA(JO)= COST*WSS+SINT*WOS 75 FA(JS)=-SINT*WSS+COST*WOS C SELECTION AXIAL MESON CONTRIBUTIONS CALL SELECT(FA,INAX) C********************************************************************* C AXIAL DERIVATIVE COUPLING CONSTANTS C FFA(1)= PAR(18,2) FFE1 = PAR(20,2) ALFFX = PAR(19,2) IF(ALFFX.EQ.0D0) ALFFX=ALPAX COST = DCOS(THA) SINT = DSIN(THA) FFA(9) = (FFE1-SINT*(4*ALFFX-1.D0)*FFA(1)/SR3)/COST CALL SU3(FFA,ALFFX) IF(ICALL.EQ.0.and.NS.NE.0) THEN THAD = THA/CONV WRITE(N2,803) FFA(1),FFA(9),ALFFX,THAD 803 FORMAT(' AXIAL NONET SU3{1}: FFA1 =',F9.5,' FFA9=',F9.5, ./,22X,' ALFFX=',F9.3,' THA=',F9.3) ENDIF DO 89 JO=6,8 JS=JO+3 WOS=FFA(JO) WSS=FFA(JS) FFA(JO)= COST*WSS+SINT*WOS 89 FFA(JS)=-SINT*WSS+COST*WOS C SELECTION AXIAL MESON CONTRIBUTIONS CALL SELECT(FFA,INAX) C********************************************************************* IF(IAXI.EQ.0.OR.IAXI.EQ.1) THEN FB(1) = 0D0 FB9 = 0D0 ENDIF IF(IAXI.NE.0.AND.IEXDB.EQ.0) THEN FB(1) = PAR(16,7) FB9 = PAR(18,7) ENDIF IF(IAXI.NE.0.AND.IEXDB.EQ.1) THEN SRB = 10D0*AMPRO**2 FEXD = 1D0/DSQRT(SRB/AMPRO**2) FB(1) = FEXD* F1*2*AMPRO/PIM *RSCAL FB9 = FEXD* FX0*2*AMPRO/PIM *RSCAL ENDIF ALFBX = PAR(17,7) IF(ALFBX.EQ.0D0) ALFBX = ALP c THB = THPS THB = PAR(4,7)*CONV THB = 35.260D0*CONV COST = DCOS(THB) SINT = DSIN(THB) FB(9) = (FB9-SINT*(4*ALFBX-1.D0)*FB(1)/SR3)/COST CALL SU3(FB,ALFBX) IF(SONPV.NE.1D0) CALL SU3SB03(FB,ALFBX,SONVP) THBD = THB/CONV IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,516) FB(1),FB(9),ALFBX,THBD 516 FORMAT(' B-AXIAL NONET SU3{1}: FB1 =',F9.5,' FB9=',F9.5, ./,20X,' ALFBX=',F9.3,' THB=',F9.3,/) DO 85 JO=6,8 JS=JO+3 WOS=FB(JO) WSS=FB(JS) FB(JO)= COST*WSS+SINT*WOS 85 FB(JS)=-SINT*WSS+COST*WOS C SELECTION AXIAL MESON CONTRIBUTIONS CALL SELECT(FB,INAX) C********************************************************************* C********************************************************************* C C TENSOR MESON COUPLINGS C C********************************************************************* IF(ITEN.EQ.0) THEN GT(1) = 0D0 FT(1) = 0D0 GEFF = 0D0 FEFF = 0D0 ENDIF IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501) THT = THV c* ALTD = ALVD c* ALTV = ALVV ALTD = 0.D0 ALTV = PAR(20,7) IF(ALTV.EQ.0D0) ALTV = ALVV IF(ITEN.NE.0) THEN GT(1)= PAR(5,7) GEFF = PAR(6,7) FT(1)= PAR(7,7) FEFF = PAR(8,7) c vector-meson values: c gt(1)= par(1,3) c ft(1)= par(1,4) c geff = gom c feff = fom c* altd = 0d0 ENDIF COST=DCOS(THT) SINT=DSIN(THT) GT(9) = (GEFF-SINT*(4*ALTD-1.D0)*GT(1)/SR3)/COST FT(9) = (FEFF-SINT*(4*ALTV-1.D0)*FT(1)/SR3)/COST CALL SU3(GT,ALTD) CALL SU3(FT,ALTV) IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,900) GT(9),FT(9),ALTD,ALTV, .THT/CONV 900 FORMAT(' TENSOR SINGLET COUPLINGS GT9= ',F12.6,' FT9=', .F12.6,/,24X,' ALTD=',F12.6,' ALTV=',F12.6,' THETA=',F12.6,//) C SU(3)-SYMMETRY BREAKING: c IF(SONV.NE.1.D0) CALL SU3SB(GT,SONV,2) c IF(SONV.NE.1.D0) CALL SU3SB(FT,SONV,2) DO 95 JO=6,8 JS=JO+3 WOV=FT(JO) WOD=GT(JO) WSV=FT(JS) WSD=GT(JS) FT(JO)= COST*WSV+SINT*WOV GT(JO)= COST*WSD+SINT*WOD FT(JS)=-SINT*WSV+COST*WOV GT(JS)=-SINT*WSD+COST*WOD 95 CONTINUE C SELECTION TENSOR MESON CONTRIBUTIONS CALL SELECT(GT,INTEN) CALL SELECT(FT,INTEN) C ****************************************************************** C C HEAVY PSEUDO-SCALARS C C ****************************************************************** c IF(IEXD.EQ.0) THEN HFPS(1) = PAR(13,2)*RSCAL HFETP = PAR(15,2)*RSCAL c ENDIF ALPH = ALP THPH = THPS SINT=DSIN(THPH) COST=DCOS(THPH) THPHD = THPH/CONV HFPS(9)=(HFETP-SINT*(4*ALPH-1.D0)*HFPS(1)/SR3)/COST CALL SU3(HFPS,ALPH) cc IF(SONPV.NE.1.D0) CALL SU3SB(HFPS,SONPV,1) IF(SONPV.NE.1.D0) CALL SU3SB03(HFPS,ALPH,SONPV) IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,821) HFPS(9),FEXD,IEXD,ALPH,THPHD 821 FORMAT(72('*'),/,' H-PS MESONS SU3{1}: HFPS9=',F9.5,' FEXD=', .F9.3,' IEXD=',I3,/,22X,' ALPH=',F9.3,' THPH=',F9.3,/) C DO 87 JO=6,8 JS=JO+3 WOP=HFPS(JO) WSP=HFPS(JS) HFPS(JS)= COST*WSP+SINT*WOP 87 HFPS(JO)=-SINT*WSP+COST*WOP C SELECTION H-PSEUDOSCALAR MESON CONTRIBUTIONS CALL SELECT(HFPS,INPS) C ****************************************************************** C C HEAVY VECTOR COUPLING CONSTANTS C C ****************************************************************** c IF(IEXD.EQ.0) THEN HFD(1)=PAR(13,3)*RSCAL HALVD =PAR(14,3)*RSCAL HGOM =PAR(15,3)*RSCAL HFV(1)=PAR(13,4)*RSCAL HALVV =PAR(14,4)*RSCAL HFOM =PAR(15,4)*RSCAL RTOV =0.D0 c ENDIF THHV = THV COST =COS(THHV) SINT =SIN(THHV) HFD(9) =(HGOM-SINT*(4*ALVD-1.D0)*HFD(1)/SR3)/COST HFV(9) =(HFOM-SINT*(4*ALVV-1.D0)*HFV(1)/SR3)/COST CALL SU3(HFD,ALVD) CALL SU3(HFV,ALVV) cc IF(SONV.NE.1.D0) CALL SU3SB(HFD,SONV,2) cc IF(SONV.NE.1.D0) CALL SU3SB(HFV,SONV,2) IF(SONV.NE.1.D0) CALL SU3SB03(HFD,ALVD,SONV) IF(SONV.NE.1.D0) CALL SU3SB03(HFV,ALVV,SONV) IF(ICALL.EQ.0.and.NS.NE.0) .WRITE(N2,850) HFD(9),HFV(9),INRS,ALVD,ALVV,THVD,RTOV,IEXD 850 FORMAT(72('*'),/,' HEAVY VMESONS SU3{1}: HFD9=',F9.5,' HFV9=' .,F9.5,' INRS=',I3,/,22X,' ALVD=',F9.3,' ALVV=',F9.3, .' THHV=',F9.3,/,22X,' RTOV=',F9.3,' IEXD=',I3,/) C DO 861 JO=6,8 JS=JO+3 WOD=HFD(JO) WSD=HFD(JS) WOV=HFV(JO) WSV=HFV(JS) HFD(JO)= COST*WSD+SINT*WOD HFD(JS)=-SINT*WSD+COST*WOD HFV(JO)= COST*WSV+SINT*WOV 861 HFV(JS)=-SINT*WSV+COST*WOV C SELECTION H-VECTOR MESON CONTRIBUTIONS CALL SELECT(HFD,INVCT) CALL SELECT(HFV,INVCT) C C********************************************************************* C C********************************************************************* IF(ICALL.EQ.0.and.NS.NE.0) THEN WRITE(N2,501) WRITE(N2,93) G,F,FD,FV,GSB,GSA,FS,GD,GDA,FA,FFA,FB, . GT,FT,HFPS,HFD,HFV ENDIF 93 FORMAT(/,' COUPLING CONSTANTS : ',//, . 7x,' nnp ',' ssp ',' slp ',' lnk ',' snk ',/, . 7x,' nne ',' lle ',' sse ',' nnx ',' llx ', . ' ssx ',//, 1 ' gps =',5f8.4,/,7x,6f8.4,//,' fps =',5f8.4,/,7x,6f8.4,//, 2 ' fd =',5f8.4,/,7x,6f8.4,//,' fv =',5f8.4,/,7x,6f8.4,//, 3 ' gsb =',5f8.4,/,7x,6f8.4,//,' gsa =',5f8.4,/,7x,6f8.4,//, 4 ' fs =',5f8.4,/,7x,6f8.4,//, 5 ' gd =',5f8.4,/,7x,6f8.4,//,' gda =',5f8.4,/,7x,6f8.4,//, 6 ' fa =',5f8.4,/,7x,6f8.4,//,' ffa =',5f8.4,/,7x,6f8.4,//, 7 ' fb =',5f8.4,/,7x,6f8.4,//, 8 ' gt =',5f8.4,/,7x,6f8.4,//,' ft =',5f8.4,/,7x,6f8.4,//, 9 ' hfps =',5f8.4,/,7x,6f8.4,//, x ' hfd =',5f8.4,/,7x,6f8.4,//,' hfv =',5f8.4,/,7x,6f8.4,//) C********************************************************************* C C PAIR COUPLINGS C C********************************************************************* IF(IPAIR.NE.0) THEN GSPAIR = PAR(1,8)*RSCAL GVPAIR = PAR(2,8)*RSCAL FVPAIR = PAR(3,8)*RSCAL GAPAIR = PAR(4,8)*RSCAL HAPAIR = PAR(5,8)*RSCAL GPPAIR = PAR(6,8)*RSCAL HOPAIR = PAR(7,8)*RSCAL GEPAIR = PAR(8,8)*RSCAL GPIET = PAR(9,8)*RSCAL GPIETP = PAR(10,8)*RSCAL GPIPOM = PAR(15,8)*RSCAL C GSPAIR = 0.D0 C GVPAIR = 0.D0 C FVPAIR = 0.D0 C GAPAIR = 0.D0 C HAPAIR = 0.D0 C GPPAIR = 0.D0 C HOPAIR = 0.D0 C GEPAIR = 0.D0 C GPIET = 0.D0 C GPIETP = 0.D0 ALPVPR = ALP c ALVDPR = ALVD c ALVVPR = ALVV c ALSCPR = ALS ALVDPR = PAR(13,8) ALVVPR = PAR(14,8) ALSCPR = PAR(12,8) ALPAPR = PAR(11,8) c* ALPAPR = ALPAX CALL YNPRCOP(ICSB,NSU3F) ENDIF ICALL = 1 RETURN END C *************************************************************** SUBROUTINE SELECT(F,INMES) C *************************************************************** C CHECKING CONTRIBUTIONS INDIVIDUAL MESONS C*********************************************************************** C USED INDEXING OF THE COUPLINGS : C 1 =NNP NNRO NNDEL NNA2 C 2 =SSP SSRO SSDEL SSA2 C 3 =LSP LSRO LSDEL LSA2 C 4 =LNK LNKS LNKAP LNK** C 5 =SNK SNKS SNKAP SNK** C 6 =NNE NNOM NNEPS NNPOM C 7 =LLE LLOM LLEPS LLPOM C 8 =SSE SSOM SSEPS SSPOM C 9 =NNX NNFI NNS* NNF2 C 10=LLX LLFI LLS* LLF2 C 11=SSX SSFI SSS* SSF2 C C *************************************************************** C NNX STANDS FOR NNETA' ETC. C *************************************************************** IMPLICIT REAL*8(A-H,O-Z) CHARACTER * 4 INMES(4) DIMENSION F(11) IF(INMES(1).EQ.'NO ') THEN F(1) = 0.D0 F(2) = 0.D0 F(3) = 0.D0 ENDIF IF(INMES(2).EQ.'NO ') THEN F(6) = 0.D0 F(7) = 0.D0 F(8) = 0.D0 ENDIF IF(INMES(3).EQ.'NO ') THEN F(9) = 0.D0 F(10) = 0.D0 F(11) = 0.D0 ENDIF IF(INMES(4).EQ.'NO ') THEN F(4) = 0.D0 F(5) = 0.D0 ENDIF RETURN END C *************************************************************** SUBROUTINE SU3(F,ALP) C *************************************************************** IMPLICIT REAL*8(A-H,O-Z) DIMENSION F(11) DATA SR3/1.732051D0/ FF = F(1) F(2) =2*FF*ALP F(3) =2*FF*(1.D0-ALP)/SR3 F(4) = -FF*(1.D0+2*ALP)/SR3 F(5) = FF*(1.D0-2*ALP) F(6) = FF*(4*ALP-1.D0)/SR3 F(7) = -F(3) F(8) = F(3) F(10)= F(9) F(11)= F(9) RETURN END C ********************************************************************** SUBROUTINE SU3SB(F,SONA,MTYP) C ********************************************************************** C MTYP=1: PSEUDO-SCALAR, MTYP=2: VECTOR, MTYP=3: SCALAR,DIFRAC C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) DIMENSION F(11),MEX(3) DATA MEX/1,1,0/,ICALL/0/ IW = MEX(MTYP) c** SON = SONA*SONA SON = DABS(SONA) F(4) = F(4) - F(4)*(1.D0-SON) F(5) = F(5) - F(5)*(1.D0-SON) IF(IW.EQ.1) THEN F(7) = F(7) F(8) = F(8) - F(8)*(1.D0-SON*SON)/3.D0 F(10)= F(10)- F(9)*(1.D0-SON*SON) F(11)= F(11)+ F(9)*(1.D0-SON*SON)/3.D0 ENDIF IF(IW.EQ.0) THEN F(7) = F(7) + F(1)*(1.D0-SON*SON)*2/DSQRT(3.D0) F(8) = F(8) + F(1)*(1.D0-SON*SON)*2/DSQRT(3.D0) F(10)= F(10)- F(9)*(1.D0-SON*SON)/3.D0 F(11)= F(11)- F(9)*(1.D0-SON*SON)/3.D0 ENDIF IF(ICALL.EQ.0) THEN WRITE(*,99) WRITE(*,*) ' SU3SB: IW(PV)=',MEX(1),' IW(VCT)=',MEX(2), .' IW(SCL)=',MEX(3) WRITE(*,99) 99 FORMAT(/,72('-'),/) ICALL=1 ENDIF RETURN END C ********************************************************************** cc SUBROUTINE SU3SB(F,SON) C ********************************************************************** cc IMPLICIT REAL*8(A-H,O-Z) cc DIMENSION F(11) cc F(4) = F(4) - F(4)*(1.D0-SON) cc F(5) = F(5) - F(5)*(1.D0-SON) cc F(7) = F(7) cc F(8) = F(8) - F(8)*(1.D0-SON*SON)/3.D0 cc F(10)= F(10)- F(9)*(1.D0-SON*SON) cc F(11)= F(11)+ F(9)*(1.D0-SON*SON)/3.D0 cc RETURN cc END C *************************************************************** c SUBROUTINE SU3SB(F,SON) C *************************************************************** c IMPLICIT REAL*8(A-H,O-Z) c DIMENSION F(11) c DATA SR2/1.414213562D0/,SR3/1.732051D0/ c F(4) = F(4)-F(4)*(1.D0-SON) c F(5) = F(5)-F(5)*(1.D0-SON) c DELSB= F(1) * (1.D0-SON*SON)*SR2/SR3 c F(7) = F(7) + SR2*DELSB c F(8) = F(8) + SR2*DELSB c F(10)= F(10)- DELSB c F(11)= F(11)- DELSB c RETURN c END C ***************************************************************** SUBROUTINE VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) C ***************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2 COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALAMK,ALMKS,ALMKAP COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL, . FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL, . VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS, . FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS, . VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS, . FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS, . VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR, . FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR c* . ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN COMMON/POTF/VCAA(4),VSIGAA(4),VTENAA(4),VSOAA(4), . VSO2AA(4),VASOAA(4),VNNAA(4), . FIAA(4),DFIAA(4), . FISAA(4),DFISAA(4), . FITAA(4),DFITAA(4) COMMON/DDPOTF/DDFIAA(4),DDFSAA(4) COMMON/POTESC/VCESC(4),VSESC(4),VTESC(4),VOESC(4),VAESC(4) COMMON/PNNESC/ESCCNN,ESCSNN,ESCTNN,ESCONN CHARACTER * 16 SYS(3) CHARACTER *4 TYPM(10),TYPV(8),CHAN(4),TYPV2(8) DATA SYS/'SIGMA(+)-PROTON','LAMBDA-NEUTRON','LAMBDA-PROTON'/ DATA TYPM/'PSSC','VCTR','SCAL','DIFR','AXIA','TENS', .'PSPS','PAIR','PIBE','PSBE'/, CHAN/'LL','SS','LS','DR'/, . TYPV/' VC ','VSIG','VTEN',' VSO','VASO',' FI ',' FIS','DDFI'/, . TYPV2/' VC ','VSIG','VTEN',' FI ',' FIS','DFI ','DFIS','DDFI'/ DATA ZERO/0.D0/,N2/6/,ICALL/0/,ICALLS/0/,ICALLT/0/,I51/0/ C ICALL=ICALL+1 IF(JSPIN.EQ.0) ICALLS=ICALLS+1 IF(JSPIN.EQ.1) ICALLT=ICALLT+1 IF(ICALL.EQ.1.AND.NS.GE.1) PRINT 13,SYS(NCHAN),JSPIN,LINT 13 FORMAT(//,1X,A13,'-POTENTIALS ON THE ISOSPIN-BASIS : JSPIN=',I2, . ' LINT=',I2,//) NIPI=1 IF(NCHAN.EQ.1) NIPI=4 IF(NCHAN.NE.1) LC=1 IF(NCHAN.EQ.1) LC=3 PX = (-1D0)**LINT C PX = -1D0 ! for comparison with ynrmp10.f ICSB2 = 0 C C INITIALIZATION POTENTIALS C CALL VSET C C-----BEGIN 25-LOOP ----------------------------- DO 25 II=1,10 * DO 25 II=1,4 C DO 24 IP=1,4 VCAA(IP) =ZERO VSIGAA(IP)=ZERO VTENAA(IP)=ZERO VSOAA(IP) =ZERO VSO2AA(IP)=ZERO VASOAA(IP)=ZERO FIAA(IP) =ZERO DFIAA(IP) =ZERO DDFIAA(IP)=ZERO FISAA(IP) =ZERO DFISAA(IP)=ZERO DDFSAA(IP)=ZERO FITAA(IP) =ZERO DFITAA(IP)=ZERO c* DDFITA(IP)=ZERO VCESC(IP) = ZERO VSESC(IP) = ZERO VTESC(IP) = ZERO VOESC(IP) = ZERO VAESC(IP) = ZERO 24 VNNAA(IP) = ZERO esccnn = zero escsnn = zero esctnn = zero esconn = zero escann = zero C GOTO(26,27,28,29,291,292,15,16,17,18),II c GOTO(26,27,28,29),II 26 IF(IPSC.NE.0) CALL PSSCAL(X,ICSB,NLOC,LC) IF(IPSC.EQ.2) CALL PSSCA2(X,ICSB,NLOC,P,PX) c 26 IF(IPSC.EQ.1) CALL PSSCAL3(X,NADIA,ICSB,NLOC,NCHAN) GOTO 30 27 IF(IVCT.NE.0) CALL VECTOR(X,ICSB,NLOC,LC) IF(IVCT.EQ.2) CALL VECTOR2(X,ICSB,NLOC,P,PX) c 27 IF(IVCT.EQ.1) CALL VECTOR3(X,NADIA,ICSB,NLOC,NCHAN) GOTO 30 28 IF(ISCL.NE.0) CALL SCALAR(X,ICSB,NLOC,LC) IF(ISCL.EQ.2) CALL SCALAR2(X,ICSB,NLOC,LC) c 28 IF(ISCL.EQ.1) CALL SCALAR3(X,NADIA,ICSB,NLOC,NCHAN) GOTO 30 29 IF(IDIF.NE.0) THEN IF(P.EQ.+1D0) I51 =1 ! A LA YNRMP10.F IF(P.EQ.-1D0) I51 =0 ! A LA YNRMP10.F CALL DIFRAC(X,ICSB,NLOC,LC,I51) ENDIF GOTO 30 291 IF(IAXI.GE.1) CALL AXIAL(X,ICSB,NLOC,LC,P,PX) IF(IAXI.EQ.2) CALL AXIALU(X,ICSB,NLOC,P,PX) GOTO 30 292 IF(ITEN.EQ.1) CALL TENSOR(X,ICSB,NLOC,P,PX) GOTO 30 15 IF(ITPS.EQ.1) CALL YNPSPS(X,INA,IPV,IOFF,ICSB2,APV) GOTO 40 16 IF(IPAIR.EQ.1) CALL YNPAIR(X,INA,IPV,ICSB2,APV) GOTO 40 17 IF(IPIBE.EQ.1) CALL YNPIBE(X,INA,IPV,IOFF,APV) GOTO 40 18 IF(IPSBE.EQ.1) CALL YNPSBE(X,INA,IPV,IOFF,APV) GOTO 40 30 IF(MOD(ICALL,5).EQ.1) THEN IF(NS.EQ.3) THEN IF(II.LE.6) THEN c IF(ICALL.EQ.1) WRITE(N2,311) TYPM(II),X,(TYPV(KK),KK=1,7) WRITE(N2,311) TYPM(II),X,(TYPV(KK),KK=1,7) 311 FORMAT(/,A4,' X=',F7.4,' PIM-1',' POTENTIALS:',/, . /,6X,7(3X,A4,3X),/) DO 31 IP=NIPI,4 31 WRITE(N2,32) CHAN(IP),VCAA(IP), VSIGAA(IP),VTENAA(IP), . VSOAA(IP),VASOAA(IP),FIAA(IP),FISAA(IP) c . VSOAA(IP),VSO2AA(IP),FIAA(IP),DFIAA(IP),DDFIAA(IP) 32 FORMAT(1X,A4,2X,7(D9.3,1X),/) ENDIF ENDIF ENDIF 40 IF(MOD(ICALL,5).EQ.1) THEN IF(NS.EQ.3) THEN IF(II.GE.7) THEN c IF(ICALL.EQ.1) WRITE(N2,411) TYPM(II),X,(TYPV(KK),KK=1,4) WRITE(N2,411) TYPM(II),X,(TYPV(KK),KK=1,5) 411 FORMAT(/,A4,' X=',F7.4,' PIM-1',' POTENTIALS:',/, . /,6X,5(3X,A4,3X),/) DO 41 IP=NIPI,4 41 IF(MOD(ICALL,5).EQ.1) .WRITE(N2,42) CHAN(IP),VCESC(IP), VSESC(IP),VTESC(IP), . VOESC(IP),VAESC(IP) 42 FORMAT(1X,A4,2X,5(D9.3,1X),/) ENDIF ENDIF ENDIF C VCNN = VCNN + VNNAA(1) VSIGNN = VSIGNN + VNNAA(2) VTENNN = VTENNN + VNNAA(3) VSONN = VSONN + VNNAA(4) IF(IPAIR.EQ.1) THEN VCNN = VCNN + ESCCNN VSIGNN = VSIGNN + ESCSNN VTENNN = VTENNN + ESCTNN VSONN = VSONN + ESCONN ENDIF IF(NCHAN.EQ.1) GOTO 33 VCLL =VCLL + VCAA(1) + VCESC(1) VSIGLL=VSIGLL + VSIGAA(1) + VSESC(1) VTENLL=VTENLL + VTENAA(1) + VTESC(1) VSOLL =VSOLL + VSOAA(1) + VOESC(1) VSO2LL=VSO2LL + VSO2AA(1) VASOLL=VASOLL + VASOAA(1) + VAESC(1) VCLS =VCLS + VCAA(3) + VCESC(3) VSIGLS=VSIGLS + VSIGAA(3) + VSESC(3) VTENLS=VTENLS + VTENAA(3) + VTESC(3) VSOLS =VSOLS + VSOAA(3) + VOESC(3) VSO2LS=VSO2LS + VSO2AA(3) VASOLS=VASOLS + VASOAA(3) VCSS =VCSS + VCAA(2) + VCESC(2) VSIGSS=VSIGSS + VSIGAA(2) + VSESC(2) VTENSS=VTENSS + VTENAA(2) + VTESC(2) VSOSS =VSOSS + VSOAA(2) + VOESC(2) VSO2SS=VSO2SS + VSO2AA(2) VASOSS=VASOSS + VASOAA(2) + VAESC(2) FILL =FILL + FIAA(1) FILS =FILS + FIAA(3) FISS =FISS + FIAA(2) DFILL =DFILL + DFIAA(1) DFILS =DFILS + DFIAA(3) DFISS =DFISS + DFIAA(2) DDFILL=DDFILL + DDFIAA(1) DDFILS=DDFILS + DDFIAA(3) DDFISS=DDFISS + DDFIAA(2) FISLL =FISLL + FISAA(1) FISLS =FISLS + FISAA(3) FISSS =FISSS + FISAA(2) DFISLL =DFISLL + DFISAA(1) DFISLS =DFISLS + DFISAA(3) DFISSS =DFISSS + DFISAA(2) DDFSLL=DDFSLL + DDFSAA(1) DDFSLS=DDFSLS + DDFSAA(3) DDFSSS=DDFSSS + DDFSAA(2) 33 VCDR =VCDR + VCAA(4) + VCESC(4) VSIGDR=VSIGDR + VSIGAA(4) + VSESC(4) VTENDR=VTENDR + VTENAA(4) + VTESC(4) VSODR =VSODR + VSOAA(4) + VOESC(4) VSO2DR=VSO2DR + VSO2AA(4) VASODR=VASODR + VASOAA(4) + VAESC(4) FIDR =FIDR + FIAA(4) DFIDR =DFIDR + DFIAA(4) DDFIDR=DDFIDR + DDFIAA(4) FISDR =FISDR + FISAA(4) DFISDR =DFISDR + DFISAA(4) 20 DDFSDR=DDFSDR + DDFSAA(4) 25 CONTINUE C-----END 25-LOOP -------------------------------------------- IF(NS.EQ.3) THEN ! BEGIN NS.EQ.3 IF((JSPIN.EQ.0.AND.MOD(ICALLS,5).EQ.1).or. .(JSPIN.EQ.1.AND.MOD(ICALLT,5).EQ.1)) THEN IF(JSPIN.EQ.0) WRITE(*,99) 99 FORMAT(72('-')) c* IF(MOD(ICALL,2).EQ.1) THEN IF(NS.GE.2) THEN XFM = X*197.327053D0/PIM WRITE(N2,312) XFM,JSPIN,LINT,(TYPV(KK),KK=1,7) c* WRITE(N2,312) XFM,JSPIN,LINT,(TYPV2(KK),KK=1,7) 312 FORMAT(/,' XFM=',F7.4,' FM',' JSPIN=',I2,' LINT=',I2, .' TOTAL POTENTIALS:',/, /,6X,7(4X,A4,5X),/) IF(NCHAN.NE.1) THEN WRITE(N2,51) VCLL, VSIGLL,VTENLL,VSOLL,VASOLL,FILL,FISLL WRITE(N2,52) VCSS, VSIGSS,VTENSS,VSOSS,VASOSS,FISS,FISSS WRITE(N2,53) VCLS, VSIGLS,VTENLS,VSOLS,VASOLS,FILS,FISLS WRITE(N2,54) VCDR, VSIGDR,VTENDR,VSODR,VASODR,FIDR,FISDR cc WRITE(N2,51) VCLL, VSIGLL,VTENLL,FILL,FISLL,DFILL,DFISLL cc WRITE(N2,52) VCSS, VSIGSS,VTENSS,FISS,FISSS,DFISS,DFISSS cc WRITE(N2,53) VCLS, VSIGLS,VTENLS,FILS,FISLS,DFILS,DFISLS cc WRITE(N2,54) VCDR, VSIGDR,VTENDR,FIDR,FISDR,DFIDR,DFISDR ELSE c WRITE(N2,55) VCDR, VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR WRITE(N2,55) VCDR, VSIGDR,VTENDR,VSODR,VASODR,FIDR,FISDR cc WRITE(N2,55) VCDR, VSIGDR,VTENDR,FIDR,FISDR,DFIDR,DFISDR ENDIF ENDIF ENDIF ENDIF ! END NS.EQ.3 51 FORMAT(1X,' LL :',7(D12.5,1X),/) 52 FORMAT(1X,' SS :',7(D12.5,1X),/) 53 FORMAT(1X,' LS :',7(D12.5,1X),/) 54 FORMAT(1X,' DR :',7(D12.5,1X),/) 55 FORMAT(1X,' DR :',7(D12.5,1X),/) C RETURN END C********************************************************************** C SUBROUTINE VSET C C********************************************************************** IMPLICIT REAL *8(A-H,O-Z) COMMON/POT/V(48) c* COMMON/POT/V(53) DATA ZERO/0.D0/ C DO 24 IP=1,48 c* DO 24 IP=1,53 24 V(IP) = ZERO RETURN END C ************************************************************* SUBROUTINE CNSTR97(ELPHID,GEPS,GSST,GEPSNW,GSSTNW,NCASE) C ************************************************************* C ADAPTED FOR THE VERSION WITH 2 SCALAR NONETS !! (SEPT. 2000) C ------------------------------------------------------------- IMPLICIT REAL*8(A-H,O-Z) COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK DATA SR2/1.4142136D0/,SR3/1.732051D0/,PIM/138.041D0/ DATA NS/0/,AMEPS2/1370.D0/,AMD2/1450.D0/,AMSST2/1580.D0/ CC C COMPUTATION ALTERNATIVE GEPS,GSST FROM THE ELLIPTIC CONSTRAINT: C VOLUME INTEGRAL VNN CONSTANT: C PRINT 200 C 200 FORMAT(/,' ELLIPTIC CONSTRAINT= PRESERVING VOL.INT NN:',/) PI =DACOS(-1.D0) ELPHI=PI*ELPHID/180.D0 COSFI=DCOS(ELPHI) SINFI=DSIN(ELPHI) IF(NCASE.EQ.1) THEN BMSI =ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2 BMSST=(PIM/AMSST)**2 CF = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2) ENDIF IF(NCASE.EQ.2) THEN BMSI =(PIM/AMD)**2 BMSST=(PIM/AMD2)**2 CF = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2) ENDIF IF(NCASE.EQ.3) THEN BMSI =(PIM/AMEPS2)**2 BMSST=(PIM/AMSST2)**2 CF = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2) ENDIF IF(NCASE.EQ.5) THEN BMSI =ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2 BMSST=(PIM/AMEPS2)**2 CF = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2) ENDIF C STANDARD ELLIPSE PARAMETERS, X^2/A^2 + Y^2/B^2 = : AA = 1.D0/DSQRT(BMSI) BB = 1.D0/DSQRT(BMSST) XX = GEPS/CF YY = GSST/CF C POLAR COORDINATES, (ELPHI,RR): EPSI2 = 1.D0-(BB/AA)**2 RR = BB/DSQRT(1.D0-EPSI2*COSFI**2) GEPSNW= CF*RR*COSFI GSSTNW= CF*RR*SINFI IF(NS.EQ.1) THEN C COMPUTATION ELPHI0: CORRESPONDS TO INPUT GEPS,GSST: ARG = GSST/GEPS IF(ARG.GE.0) ELPHI0=DATAN(ARG)*180.D0/PI C IF(ARG.LT.0) ELPHI0=360.D0+DATAN(ARG)*180.D0/PI IF(ARG.LT.0) ELPHI0=DATAN(ARG)*180.D0/PI IF(GSST.LT.0.D0.AND.GEPS.LT.0.D0) .ELPHI0=ELPHI0 - 180.D0 IF(NCASE.EQ.1) .PRINT 111, ELPHID,GEPSNW,GSSTNW,ELPHI0 111 FORMAT(' IN CNSTR97: ELPHID=',F8.3,' GEPSNW=',D12.5, .' GSSTNW=',D12.5,/,12X,' ELPHI0=',D12.5,/) IF(NCASE.EQ.2) .PRINT 112, ELPHID,GEPSNW,GSSTNW,ELPHI0 112 FORMAT(' IN CNSTR97: PSIS8D=',F8.3,' GDELNW=',D12.5, .' GDEL2NW=',D12.5,/,12X,' PSIS80=',D12.5,/) IF(NCASE.EQ.3) .PRINT 113, ELPHID,GEPSNW,GSSTNW,ELPHI0 113 FORMAT(' IN CNSTR97: PSIS1D=',F8.3,' GEPS2NW=',D12.5, .' GSST2NW=',D12.5,/,12X,' PSIS10=',D12.5,/) IF(NCASE.EQ.5) .PRINT 115, ELPHID,GEPSNW,GSSTNW,ELPHI0 115 FORMAT(' IN CNSTR97: PSIS1D=',F8.3,' GEPSNW=',D12.5, .' GEPS2NW=',D12.5,/,12X,' PSIS10=',D12.5,/) ENDIF RETURN END C ************************************************************** SUBROUTINE TRANLP(TRANS,TRAND) C ************************************************************** C LAMBDA-PROTON SYSTEM VERSION IMPLICIT REAL*8(A-H,O-Z) DIMENSION TRANS(3,3),TRAND(3,3) DATA SR2/1.4142136D0/,SR3/1.732051D0/ SR2 = DSQRT(2.D0) SR3 = DSQRT(3.D0) TRANS(1,1)=1.0D0 TRANS(1,2)=SR2/SR3 TRANS(2,1)=SR2/SR3 TRANS(1,3)=-1.D0/SR3 TRANS(3,1)=-1.D0/SR3 TRANS(2,2)=2.D0/3 TRANS(2,3)=-SR2/3 TRANS(3,2)=-SR2/3 TRANS(3,3)=1.D0/3 C TRAND(1,1)=0.D0 TRAND(1,2)=0.D0 TRAND(2,1)=0.D0 TRAND(1,3)=0.D0 TRAND(3,1)=0.D0 TRAND(2,2)=1.D0/3 TRAND(2,3)=SR2/3 TRAND(3,2)=SR2/3 TRAND(3,3)=2.D0/3 RETURN END C ************************************************************** SUBROUTINE TRANLN(TRANS,TRAND) C ************************************************************** C LAMBDA-NEUTRON SYSTEM VERSION IMPLICIT REAL*8(A-H,O-Z) DIMENSION TRANS(3,3),TRAND(3,3) DATA SR2/1.4142136D0/,SR3/1.732051D0/ SR2 = DSQRT(2.D0) SR3 = DSQRT(3.D0) TRANS(1,1)=1.0D0 TRANS(1,2)=1.D0/SR3 TRANS(2,1)=1.D0/SR3 TRANS(1,3)=-SR2/SR3 TRANS(3,1)=-SR2/SR3 TRANS(2,2)=1.D0/3 TRANS(2,3)=-SR2/3 TRANS(3,2)=-SR2/3 TRANS(3,3)=2.D0/3 C TRAND(1,1)=0.D0 TRAND(1,2)=0.D0 TRAND(2,1)=0.D0 TRAND(1,3)=0.D0 TRAND(3,1)=0.D0 TRAND(2,2)=2.D0/3 TRAND(2,3)=SR2/3 TRAND(3,2)=SR2/3 TRAND(3,3)=1.D0/3 RETURN END C ********************************************************************** SUBROUTINE GERSTPAR C ********************************************************************** C COMPUTES TWO-POLE APPRXIMATION PARAMETERS FOR EPSILON-MESON, C USING THE Bryan-Gersten FORMULAS, PHYS.REV. D6 (1972) 341 C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/PRMTRS/PAR(20,8) AME = PAR(10,5) GAME = PAR(11,5) PIM2 = PIM*PIM AME2 = AME*AME AM32 = AME2*(DSQRT(AME2+4*PIM2)-2*PIM) AM32 = 4*PIM*AM32/(AME2+8*PIM2-4*PIM*DSQRT(AME2+4*PIM2)) GAM = GAME*AME/DSQRT(AME2-4*PIM2) X = (AME2+2*PIM*GAM)*AM32 Y = AME2+AM32*(1.D0+0.25D0*GAM/PIM)+2*PIM*GAM Y = 0.5D0*Y AM12 = Y-DSQRT(Y*Y-X) AM22 = Y+DSQRT(Y*Y-X) ASI = (AM12-AM32)/(AM12-AM22) BSI = 1.D0-ASI AM1SI= DSQRT(AM12) AM2SI= DSQRT(AM22) RETURN END C ********************************************************************** SUBROUTINE FRMINIT C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0, . ALMKA,ALMKS,ALMKP COMMON/PRMTRS/ PAR(20,8) C COMMON FORM FACTOR FOR PS, VECT, AND SCALA RESPECTIVELY: ALMP0 = ALMP1 ALMV0 = ALMV1 ALMS0 = ALMS1 C PUTTING THINGS IN PARAMETER MATRIX: PAR(9,2)=ALMP0 PAR(9,3)=ALMV0 PAR(9,5)=ALMS0 RETURN END C***** *********************************************** SUBROUTINE DCOFUN(XA,AMES,ALAM,CK,F,DF,DDF,D3F) C***** *********************************************** C COMPUTATION FOURIER TRANSFORM WITH FINITE CK C USING SERIES EXPANSION C XA: UNITS PION WAVE-LENGTH C---------------------------------------------------------------------- C DF0 = DPHI_C^0(R) = INT_K^INFTY ( PHI_C^0-INTEGRAND) C C DF1 = (D/DXA) DF0, DF2 = (D/DXA)^2 DF0, DF3 = (D/DXA)^3 DF0 C---------------------------------------------------------------------- C OPTIONS COMPUTATION: C IASYMP=0: VIA RECURRENCE RELATIONS + PADE ! VERY SUCCESFUL! C IASYMP=1: VIA ESTIMATION INTEGRALS ! REASONABLE C---------------------------------------------------------------------- IMPLICIT REAL*8 (A-H,O-Z) PARAMETER( EPS=1.D-04, MAXIT=20) DATA ICALL/0/,PIM/138.041D0/,AMF/197.32D0/,IASYMP/0/ SAVE PI,SRPI,SR2 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C IF(ICALL.EQ.0) THEN PI = DACOS(-1.D0) SRPI=DSQRT(PI) SR2 =DSQRT(2.D0) ULAM = 10*ALAM ENDIF RATK = CK/ALAM RATM = AMES/ALAM RATP = ALAM/PIM X= (AMES/PIM)*XA XLAM=XA*ALAM/PIM XLAM2=XLAM*XLAM EX = FDEXP(X) EXPM = FDEXP(RATM*RATM) DERFCM = FDERFC(-0.5D0*XLAM+RATM) DERFCP = FDERFC(+0.5D0*XLAM+RATM) ELAM0 = 0.25D0*SRPI*FDEXP(-0.25D0*XLAM2) c-------------------------------------------------------------- c I1(n) and I2(n) recursion-method c-------------------------------------------------------------- c write(*,*) ' recursion I1(n) and I2(n): xa=',xa,' xfm=',xa*amf/pim c scaling: scale=1.d0 fack = 1.d0 funck0 =0.d0 funck1 =0.d0 funck2 =0.d0 funck3 =0.d0 if(iasymp.eq.0) then ai1mn=0.d0 ai1n = 0.25d0*pi*expm*fderfc(-0.5d0*xlam+ratm) ai2mn=0.d0 ai2n = 0.25d0*pi*expm*fderfc(+0.5d0*xlam+ratm) elam1= -0.5d0*dsqrt(pi)*fdexp(-0.25D0*xlam*xlam+x)/xlam elam2= +0.5d0*dsqrt(pi)*fdexp(-0.25D0*xlam*xlam-x)/xlam endif if(iasymp.eq.0) then NSTART=1 NSTEP =1 endif if(iasymp.ge.1) then NSTART=2 NSTEP =2 endif c** DO 100 n=1,2*MAXIT ! IF: IASYMP=0 c** DO 100 n=2,2*MAXIT,2 ! IF: IASYMP=1 DO 100 n=NSTART,2*MAXIT,NSTEP c-------------------------------------------------------------- c recurrence relation method: ! VERY SUCCESFUL !! c-------------------------------------------------------------- if(iasymp.eq.0) then elam1 = elam1*xlam elam2 = elam2*xlam ai1pl = elam1 + 2*ratm*ai1n + 2*(n-1)*ai1mn ai2pl = elam2 - 2*ratm*ai2n + 2*(n-1)*ai2mn cfn = fdexp(-x)*ai1pl - fdexp(+x)*ai2pl ai1mn = ai1n ai1n = ai1pl ai2mn = ai2n ai2n = ai2pl as1n = ai1pl as2n = ai2pl endif c-------------------------------------------------------------- c asymptotic function: ! LESS SUCCESFUL !! c-------------------------------------------------------------- if(iasymp.eq.1) then expmh= fdexp(0.5d0*ratm*ratm) psi1 = (0.25d0*pi/dsqrt(2.d0))*expmh* .fderfc(-xlam/sr2+ratm/sr2-dsqrt(1d0*n)) ! I_1: -infty - x0 psi2 = (0.25d0*pi/dsqrt(2.d0))*expmh* .fderfc(+xlam/sr2+ratm/sr2-dsqrt(1d0*n)) ! I_2: x0 - infty c computation integrals: expn = dexp(-0.5d0*n-ratm*dsqrt(2d0*n))*(2*n)**(0.5d0*n) as1n = (-1d0)**n*psi1*expn as2n = psi2*expn cfn= fdexp(-x)*as1n-fdexp(+x)*as2n endif c-------------------------------------------------------------- c das1n = +ratp*elam0*xlam**n c das2n = -das1n c d2as1n = +ratp**2*elam0*xlam**(n-1)* c . ( (ratm-0.5d0*xlam)*xlam+n) c d2as2n = +ratp**2*elam0*xlam**(n-1)* c . ( (ratm+0.5d0*xlam)*xlam-n) dcfn= -(ames/pim)*(fdexp(-x)*as1n+fdexp(+x)*as2n) . +2*ratp*elam0*xlam**n d2cfn= +(ames/pim)**2*cfn +2*xlam**(n-1)* . ratp**2*elam0*(-0.5d0*xlam**2+n) d3cfn= -(ames/pim)**3*(fdexp(-x)*as1n+fdexp(+x)*as2n) . +2*xlam**(n-2)*ratp**3*elam0*(0.25d0*xlam**4 . -0.5d0*(2*n+1)*xlam**2+n*(n-1)) c--------------------------------------------------------------- c if(icall.le.2.or.icall.eq.50.or.icall.eq.99) then c if(k.eq.1) write(*,*) ' xa=',xa,' xlam=',xlam c write(*,700) as1n,das1n,d2as1n c 700 format(' as1n =',d9.2,' das1n=',d9.2,' d2as1n=',d9.2, c . ' as2n =',d9.2,' das2n=',d9.2,' d2as2n=',d9.2) c endif c-------------------------------------------------------------- if(mod(n,2).eq.0) then k=n/2 fack = 4*k*fack fct1F1 = HYP1F1(DFLOAT(-K+1),1.5D0,RATK**2) dfunck = fct1F1*cfn/fack d1funck = fct1F1*dcfn/fack d2funck = fct1F1*d2cfn/fack d3funck = fct1F1*d3cfn/fack funck0 = funck0 + dfunck funck1 = funck1 + d1funck funck2 = funck2 + d2funck funck3 = funck3 + d3funck c if(icall.le.2.or.icall.eq.50.or.icall.eq.99) then c if(k.eq.1) write(*,*) 'xfm=',x*amf/pim,' xlam=',xlam c write(*,20) k,dfunck,d1funck,d2funck, fct1F1 c 20 format(' k=',i3,' dfunck=',d10.3,' d1funck=',d10.3, c .' d2funck=',d10.3 ,' fct1F1=',d10.3) c endif endif c-------------------------------------------------------------- 100 IF(DABS(DFUNCK/FUNCK0).LT.EPS) GOTO 200 c** WRITE(*,*) ' COFUN: XA=',XA,' ACCURACY NOT REACHED !!' 200 FUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK0 DFUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK1 DDFUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK2 D3FUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK3 C A LA SUBROUTINE FFUN2: X1 = 1D0/XA X2 = X1*X1 X3 = X1*X2 X4 = X2*X2 VKUA = (ALAM/PIM)*FDEXP(-0.25D0*XLAM2)/(2*SRPI) DVKUA = -0.5D0*(ALAM/PIM)**2*XA*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) FIA = F0(EXPM,EX,DERFCM,DERFCP,XA) HIA = H0(EXPM,EX,DERFCM,DERFCP,XA) DFIA = -(FIA-2*VKUA)*X1 - (AMES/PIM)*HIA DHIA = -(AMES/PIM)*FIA - HIA*X1 DDFIA = -(DFIA-2*DVKUA)*X1 +(FIA-2*VKUA)*X2 -(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 F = (0.D0-FDERFC(RATK))*FIA + (2/PI)*FUNCO*X1 DF = (0.D0-FDERFC(RATK))*DFIA + (2/PI)*DFUNCO*X1 . -(2/PI)*FUNCO*X2 DDF = (0.D0-FDERFC(RATK))*DDFIA + (2/PI)*DDFUNCO*X1 . -(4/PI)*DFUNCO*X2 + (4/PI)*FUNCO*X3 D3F = (0.D0-FDERFC(RATK))*D3FIA + (2/PI)*D3FUNCO*X1 . -(6/PI)*DDFUNCO*X2 + (12/PI)*DFUNCO*X3 . -(12/PI)*FUNCO*X4 GOTO 400 c-------------------------------------------------------------- C PADE prediction/correction: C not inplemented. c-------------------------------------------------------------- 400 ICALL = ICALL + 1 RETURN END C************************************************************** FUNCTION HYP1F1(A,C,Z) C************************************************************** C COMPUTATION HYPERGEOMETRICAL SERIES 1F1(A,C;Z) C************************************************************** IMPLICIT REAL*8(A-H,O-Z) FAC=1.D0 TEMP=FAC AA=A CC=C DO 11 N=1,1000 FAC=FAC*AA/CC FAC=FAC*Z/N SERIES=TEMP+FAC IF(SERIES.EQ.TEMP) GOTO 12 TEMP=SERIES AA=AA+1.D0 CC=CC+1.D0 11 CONTINUE STOP 'CONVERGENCE FAILURE IN HYP1F1' 12 HYP1F1 = SERIES RETURN END C ********************************************************************** SUBROUTINE DKBFUN(KIND,X,AM1,AM2,ALM1,ALM2,DAM,FUN) C ********************************************************************** C C FOR DOUBLE STRANGENESS-EXCHANGE IN NUCLEON-NUCLEON C (KAON-KAON, KAON-KSTAR, KAON-KAPPA, KAON-K**) C ?? IT IS UNDERSTOOD THAT AM1=AMK, SO INDEX 1 REFERS TO THE KAON. C C COMPUTES THE FOURIER TRANSFORMS FOR THE ADIABATIC DENOMINATOR: C C 1 D [ A 1 C D_{//} = - --------- -- [ --------------- --------- C 2 OM1 OM2 DA [ (OM1+A) (OM2+A) OM1 + OM2 C C 1 1 ] C + --------- --------- ] = -D_{X} C (OM1 + A) (OM2 + A) ] C C ,WHICH COINCIDES WITH D_{//} FOR A=0 -> COMPATIBLE WITH PHBFUN!, C FOR VARIOUS COMBINATIONS OF DERIVATIVES. C C KIND = 1: KAON-VECTOR-, KIND = 2: KAON-SCALAR-, C KIND = 3: KAON-PSSCALAR-, KIND = 4: KAON-POMERON-EXCHANGE, C KIND = 5: NOT ALLOWED , KIND = 6: KAON-AXIAL -EXCHANGE. C C SCHEMATICALLY: C KAON-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT1 C FUN(4) = OPAEMO1 FUN(5) = OPAMMC FUN(6) = OPAMMS C FUN(7) = OPAMMT FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 C FUN(10)= OPAEMO2 FUN(11)= OCREES FUN(12)= OCREET C KAON-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT FUN(3) = OSCO C KAON-PSSCALAR EXCHANGE: C FUN(1) = OPSC FUN(2) = OPSS FUN(3) = OPST C DIFRAC-DIFRAC EXCHANGE: C FUN(1) = ODFC FUN(2) = ODFO C KAON-AXIAL EXCHANGE: C FUN(1) = OAXC FUN(2) = OAXS FUN(3) = OAXT C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA IPV/1/,YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ DATA AMPRO/938.2796D0/ SAVE XX,WW C C ACCORDING TO THE PAPER I, TABLE II AND APPENDIX A,B, C DEFINITION STATEMENT OPERATORS: C !! (NOTICE: G-FUNTIONS REFER TO KAON, F-FUNCTIONS TO MESONS.) C C 1) KAON-VECTOR EXCHANGE: OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)= . 2*FF*(2*D1G/XH+D2G)/3.D0 c .+( 4*D1F*(D3G+2*D2G/XH-2*D1G/XH/XH) c .+(2*D1F/XH+D2F)*(2*D1G/XH+D2G) )*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0 OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)= . -2*FF*(D1G/XH-D2G)/3.D0 c .+( 4*D1F*(D3G- D2G/XH+ D1G/XH/XH) c .+(2*D1F/XH+D2F)*(D2G-D1G/XH) )*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(D2F*D2G-D1F*D1G/XH/XH)*(PIM/AMPRO)**2/6.D0 OCREES(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)= .OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH) c .+FF*(D4G+4*D3G/XH)*(PIM/AMPRO)**2/3.D0 OCREET(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)= .OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH) c .+FF*(D4G+D3G/XH-6*D2G/XH**2+6*D1G/XH**3)*(PIM/AMPRO)**2/3.D0 OPAEMT(D1F,D1G,D2G,XH)= 2*D1F*(D1G/XH-D2G)/XH OPAEMO(D1F,D1G,XH)= 4*D1F*D1G/XH/XH OPEMS2(D1F,D2F,D1G,D2G,XH)= (2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0 OPEMT2(D1F,D2F,D1G,D2G,XH)= (D1F/XH-D2F)*(D1G/XH-D2G)/3.D0 OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH OPAMMC(D1F,D2F,D1G,D2G,XH)= .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH OPAMMS(D1F,D2F,D1G,D2G,XH)= .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0 OPAMMT(D1F,D2F,D1G,D2G,XH)= .+(D2F+D1F/XH)*(D2G-D1G/XH)/3.D0-1*(D2F-D1F/XH)*D1G/XH/3.D0 .-1*(D2G-D1G/XH)*D1F/XH/3.D0 C2,4) KAON-SCALAR EXCHANGE: OSCS(FF,D1F,D2F,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0 c . +(2*D1F/XH+D2F)*(2*D1G/XH+D2G)*(PIM/AMPRO)**2/6.D0 c . -(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0 OSCT(FF,D1F,D2F,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0 c . +(D1F/XH-D2F)*(D1G/XH-D2G)*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(D1F*D1G/XH/XH-D2F*D2G)*(PIM/AMPRO)**2/6.D0 OSCO(D1F,D1G,XH)= 0.D0 c . +(D1F*D1G/XH/XH)*(PIM/AMPRO)**2 C 3) KAON-PSEUDO-SCALAR EXCHANGE: OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G) OPSS(D1F,D2F,D1G,D2G,XH)=+4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0 OPST(D1F,D2F,D1G,D2G,XH)=-2*( (D2F-D1F/XH)*D1G/XH + . (D2G-D1G/XH)*D1F/XH )/3.D0 C 4) DIFRAC-DIFRAC EXCHANGE: ODFC(FF,D1F,D2F,GG,D1G,D2G,XH)= 2*FF*GG c . -0.5D0*(PIM/AMPRO)**2 c . *((D2F+2*D1F/XH)*GG+FF*(D2G+2*D1G/XH)-2*D1F*D1G) ODFO(FF,D1F,GG,D1G,XH)= 0.D0 c . -(D1F*GG+FF*D1G)/XH*(PIM/AMPRO)**2 C 5) KAON-AXIAL EXCHANGE: OAXC(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G) OAXS(FF,D1G,D2G,XH)= +2*FF*(2*D1G/XH+D2G)*2/3.D0 OAXT(FF,D1G,D2G,XH)= -2*FF*( -D1G/XH+D2G)/3.D0 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC AA = DAM/PIM AA2 = AA*AA X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 X4 = X1*X3 CC RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 DDVKU1=-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1) D3VKU1=-0.5D0*(ALM1/PIM)**2*(2*DVKU1+X*DDVKU1) RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,12 105 FUN(IFUN) = 0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*1.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) FDISP = FDISP1*FDISP2 C IF(KIND.NE.5) THEN AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM DDHIM =-(AM/PIM)*DFIM -DHIM*X1 +HIM*X2 D3FIM =-(DDFIM-2*DDVKU1)*X1+2*(DFIM-2*DVKU1)*X2 . -2*(FIM-2*VKU1)*X3-(AM/PIM)*DDHIM D3HIM =-(AM/PIM)*DDFIM -DDHIM*X1 +2*DHIM*X2-2*HIM*X3 D4FIM =-(D3FIM-2*D3VKU1)*X1+3*(DDFIM-2*DDVKU1)*X2 . -6*(DFIM-2*DVKU1)*X3+6*(FIM-2*VKU1)*X4-(AM/PIM)*D3HIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM D3FIM1 = D3FIM D4FIM1 = D4FIM ENDIF C IF(KIND.LT.4.OR.KIND.GE.6) THEN AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM ENDIF IF(KIND.EQ.4.OR.KIND.EQ.5) THEN XA =X*AM2/PIM FIA =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA) DFIA = -2*(AM2/PIM)*XA*FIA DDFIA = -2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM) FIM2= FIA DFIM2= DFIA DDFIM2= DDFIA ENDIF C WGHT= GEW*(AA2-Y*Y)/(AA2+Y*Y)**2 C IF(KIND.EQ.1) THEN FUN(1) = FUN(1) + WGHT*FDISP* . OPAEES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X) FUN(2) = FUN(2) + WGHT*FDISP* . OPAEET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X) FUN(11) = FUN(11) + WGHT*FDISP* . OCREES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X) FUN(12) = FUN(12) + WGHT*FDISP* . OCREET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X) FUN(3) = FUN(3) + WGHT*FDISP* . OPAEMT(DFIM2,DFIM1,DDFIM1,X) FUN(4) = FUN(4) + WGHT*FDISP* . OPAEMO(DFIM2,DFIM1,X) FUN(5) = FUN(5) + WGHT*FDISP* . OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(6) = FUN(6) + WGHT*FDISP* . OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(7) = FUN(7) + WGHT*FDISP* . OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(8) = FUN(8) + WGHT*FDISP* . OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(9) = FUN(9) + WGHT*FDISP* . OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(10) = FUN(10) + WGHT*FDISP* . OPEMO2(DFIM2,DFIM1,X) ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1) + WGHT* . FDISP*OSCS(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(2) = FUN(2) + WGHT* . FDISP*OSCT(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(3) = FUN(3) + WGHT* . FDISP*OSCO(DFIM2,DFIM1,X) ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1) + WGHT* . FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(2) = FUN(2) + WGHT* . FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X) FUN(3) = FUN(3) + WGHT* . FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X) ENDIF C C IF(KIND.EQ.5) THEN: NOT ALLOWED! C IF(KIND.EQ.6) THEN FUN(1) = FUN(1) + WGHT* . FDISP*OAXC(FIM2,DFIM1,DDFIM1,X) FUN(2) = FUN(2) + WGHT* . FDISP*OAXS(FIM2,DFIM1,DDFIM1,X) FUN(3) = FUN(3) + WGHT* . FDISP*OAXT(FIM2,DFIM1,DDFIM1,X) ENDIF C 110 CONTINUE 100 CONTINUE CC C PRINT 99, KIND,X,AM1,AM2,ALM1,ALM2,(FUN(II),II=1,12) C99 FORMAT(/,' IN DKBFUN: KIND=',I2,' X=',F10.3,/, C .' AM1,AM2=',2(F10.3,3X),' ALM1,ALM2=',2(F10.3,3X),/, C . /,' IN DKBFUN: FUN(II)=',/,5(D10.3,3X),/) CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE DKBOOM(ITYP,X,AM1,AM2,ALM1,ALM2,DAM) C ********************************************************************** C C FOR DOUBLE STRANGENESS EXCHANGE (KK, K-KSTAR, K-KAPPA, K-K**) C COMPUTATION 1/M-CONTRIBUTIONS FOR TWO-MESON EXCHANGE C NOTE: PARTICLE 1 IS THE KAON! C C ITYP=1: PS-PS, ITYP=2: PS-VCT, ITYP=3: PS-SCA, ITYP=4: PS-DIF C WARNING: ITYP=5 NOT YET IMPLEMENTED! C ********************************************************************* C C NON-ADIABATIC DENOMINATOR (A LA EQ. (5.1)): C 1 D^2 [ A 1 C D(//)^(1)= --------- ---- [ --------------- --------- C 4 OM1 OM2 DA^2 [ (OM1+A) (OM2+A) OM1 + OM2 C C 1 1 ] C + --------- --------- ] = - D(X)^(1)/2 C (OM1 + A) (OM2 + A) ] C --------------------------------------------------------------------- C C PV-VERTEX CORRECTION DENOMINATOR (A LA EQ. (5.6)): C 1 [ 2A ] C D(PV)^(1)= ------------------- [ 1 + --------- ] C 2 (OM1+A)^2 (OM2+A)^2 [ OM1 + OM2 ] C C WHICH COINCIDE WITH FUNCTIONS COMPUTED BY FOOM FOR A-> 0! C C A = DAM/PIM = HYPERON-NUCLEON MASS DIFFERENCE C C WE COMPUTE IN THIS ROUTINE: C C 1) ITYPE=1 (PS-PS): C 1A FNONC: -F.T. (K1.K2)^3 D//^(1) C FNONS: -F.T. (K1.K2) SIG1.(K1XK2) SIG2.(K1XK2) D(//)^(1) C FNONT: -F.T. (K1.K2) SIG1.(K1XK2) SIG2.(K1XK2) D(//)^(1) C FNONO: +F.T. (K1.K2) i*(SIG1+SIG2).(K1XK2) Q.(K1-K2) D(//)^(1) C 1B FPVC : +F.T. (K1.K2) (K1^2+K2^2) D(PV)^(1) C FPVO : +F.T. i*(SIG1+SIG2).[QX ......] D(PV)^(1) C C 2) ITYPE=2,3,4 (PS-VCT,PS-SCAL,PS-DIFF): C 2A FNONS,FNONT: +F.T. (K1.K2) SIG1.K1 SIG2.K1 D(//)^(1) C 2B FPVS ,FPVT : -F.T. (SIG1.K1 SIG2.K2+SIG1.K2 SIG2.K1) D(PV)^(1) C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO DIMENSION XX(20),WW(20),YB(3) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/ SAVE XX,WW,AA,AA2 C C CONSTRUCTION BASE FUNCTIONS FOR PS-PS-EXCHANGE: C C ITYP=1: FNONC1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = +0.5D0*( . 6*(D2F-D1F/XH)*(D2G-D1G/XH)/XH/XH+D3F*D3G) FNONS1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = -(1.D0/3.D0)*( . (D2F-D1F/XH-XH*D3F)*(D2G-D1G/XH-XH*D3G)/XH/XH-D3F*D3G) FNONT1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = +(2.D0/3.D0)*( . (D2F-D1F/XH-XH*D3F/4)*(D2G-D1G/XH-XH*D3G/4)/XH/XH . -D3F*D3G/16.D0) FNONO1(D1F,D2F,D1G,D2G,XH) = -2* . (D2F-D1F/XH)*(D2G-D1G/XH)/XH/XH FPVC1(D1F,D2F,D3F,D1G,XH) = . (-2*D1F/XH/XH+2*D2F/XH+D3F)*D1G FPVO1(D1F,D2F,D1G,D2G,XH) = . 2*(D1F*D2G+D2F*D1G)/XH+4*D1F*D1G/XH/XH C ITYP=2,3,4: FNONS2(D1F,D2F,D3F,D1G,XH) = +(1.D0/6.D0)* . (D3F+2*D2F/XH-2*D1F/XH/XH)*D1G FNONT2(D1F,D2F,D3F,D1G,XH) = +(1.D0/6.D0)* . (D3F- D2F/XH+ D1F/XH/XH)*D1G FPVS2(D1F,D1G,XH) = +D1F*D1G/3.D0 FPVT2(D1F,D1G,XH) = +D1F*D1G/3.D0 C ITYP=5: FNONC5(D1F,D1G,XH) = +0.5D0*D1F*D1G C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) AA =DAM/PIM IF(ICALL.EQ.0) THEN AA2 =AA*AA CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 CC RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 DDVKU1=-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1) RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 DDVKU2=-0.5D0*(ALM2/PIM)**2*(VKU2+X*DVKU2) C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C FNONC=0.D0 FNONS=0.D0 FNONT=0.D0 FNONO=0.D0 FPVC =0.D0 FPVS =0.D0 FPVT =0.D0 FPVO =0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) FDISP = FDISP1*FDISP2 GEW = GEW*FDISP C AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2 D3FIM =+(DFIM-2* DVKU1)*X2-2*(FIM-2* VKU1)*X3-(AM/PIM)*DDHIM . -(DDFIM-2*DDVKU1)*X1+ (DFIM-2*DVKU1)*X2 FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM D3FIM1 = D3FIM C AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2 D3FIM =+(DFIM-2* DVKU2)*X2-2*(FIM-2* VKU2)*X3-(AM/PIM)*DDHIM . -(DDFIM-2*DDVKU2)*X1+ (DFIM-2*DVKU2)*X2 FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM D3FIM2 = D3FIM C C NON-ADIABATIC INTEGRALS: WGHT= GEW*AA*(AA2-3*Y**2)/(Y*Y+AA2)**3 IF(ITYP.EQ.1) THEN FNONC = FNONC + WGHT* . FNONC1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X) FNONS = FNONS + WGHT* . FNONS1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X) FNONT = FNONT + WGHT* . FNONT1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X) FNONO = FNONO + WGHT* . FNONO1(DFIM1,DDFIM1,DFIM2,DDFIM2,X) ENDIF IF(ITYP.GE.2 .AND. ITYP.LE.4) THEN FNONS = FNONS + WGHT* . FNONS2(DFIM1,DDFIM1,D3FIM1,DFIM2,X) FNONT = FNONT + WGHT* . FNONT2(DFIM1,DDFIM1,D3FIM1,DFIM2,X) ENDIF IF(ITYP.EQ.5) THEN FNONC = FNONC + WGHT*FNONC5(DFIM1,DFIM2,X) ENDIF C PV-VERTEX CORRECTION INTEGRALS: WGHT= GEW*2*AA*Y**2/(Y*Y+AA2)**2 IF(ITYP.EQ.1) THEN FPVC = FPVC + WGHT*( . FPVC1(DFIM1,DDFIM1,D3FIM1,DFIM2,X) + . FPVC1(DFIM2,DDFIM2,D3FIM2,DFIM1,X) ) FPVO = FPVO + WGHT* . FPVO1(DFIM1,DDFIM1,DFIM2,DDFIM2,X) ENDIF IF(ITYP.GE.2 .AND. ITYP.LE.4) THEN FPVS = FPVS + WGHT*FPVS2(DFIM1,DFIM2,X) FPVT = FPVT + WGHT*FPVT2(DFIM1,DFIM2,X) ENDIF C 110 CONTINUE 100 CONTINUE CC 10000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE YNFUN2(KIND,X,AM1,AM2,ALM1,ALM2,DAMB,IYEX,FUN) C C THIS ROUTINE IS FOR THE CASE OF ONE(!) MESON CARRYING STRANGENESS, C THIS IS EITHER MESON1(IYEX=1) OR MESON2(IYEX=2). C VERSION: 23 FEBRUARI, 1996 C ********************************************************************** C C THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN ; YNPSBE.FORTRAN C IT IS UNDERSTOOD THAT INDEX 1 REFERS TO THE PS-EXCHANGE (PION ETC. C C COMPUTES THE FOURIER TRANSFORMS OF D, WHERE C C 1 | 1 1 | 1 C 2*D = ---------- | --------- + --------- |. ----- C 2 OM1.OM2 | OM1+OM2-A OM1+OM2+A | OM1^2 C C 1 (OM2^2 + A^2) 1 C + ----- ---------------. ----- , D_{//}=-D_{X} = D C OM2 (OM2^2 + A^2)^2 OM1^2 C C FOR VARIOUS COMBINATIONS OF DERIVATIVES. C C NOTICE: THIS CORRESPONDS TO YNFUN(....) FOR THE LIMIT DAM=0.D0! C C KIND = 1: PION-VECTOR-, KIND = 2: PION-SCALAR-, C KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE. C C SCHEMATICALLY: C PION-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT1 C FUN(4) = OPAEMO FUN(5) = OPAMMC FUN(6) = OPAMMS C FUN(7) = OPAMMT FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 C FUN(10)= OPAEMO2 FUN(11)= OCREES FUN(12)= OCREET C PION-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C PION-PSSCALAR EXCHANGE: C FUN(1) = OPSC FUN(2) = OPSS FUN(3) = OPST C !! NOTE: simplest def. of functions here, no k^2/M^2-terms! C in OPAEES etc. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Y) IMPLICIT COMPLEX*16 (Z) *** COMPLEX*16 CDSQRT,DREAL,DIMAG *** COMMON/MASSES/PIM,AMNC(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) DIMENSION XX(20),WW(20),YB(3),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/ DATA PIM/138.041D0/,AMPRO/938.2796D0/ DATA ZI/(0.D0,1.D0)/ SAVE XX,WW,DAM C C ACCORDING TO THE PAPER APPENDIX B, C DEFINITION STATEMENT OPERATORS: C C 1) PION-VECTOR EXCHANGE: OPAEES(FF,D1G,D2G,XH)= 2*FF*(2*D1G/XH+D2G)/3.D0 OPAEET(FF,D1G,D2G,XH)= -2*FF*(D1G/XH-D2G)/3.D0 OCREES(FF,D1G,D2G,XH)= .OPAEES(FF,D1G,D2G,XH) OCREET(FF,D1G,D2G,XH)= .OPAEET(FF,D1G,D2G,XH) OPAEMT(D1F,D1G,D2G,XH)= 2*D1F*(D1G/XH-D2G)/XH OPAEMO(D1F,D1G,XH)= 4*D1F*D1G/XH/XH OPEMS2(D1F,D2F,D1G,D2G,XH)=(2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0 OPEMT2(D1F,D2F,D1G,D2G,XH)=(D1F/XH-D2F)*(D1G/XH-D2G)/3.D0 OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH OPAMMC(D1F,D2F,D1G,D2G,XH)= .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH OPAMMS(D1F,D2F,D1G,D2G,XH)= .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0 OPAMMT(D1F,D2F,D1G,D2G,XH)= .-(D1F/XH+D2F)*(D1G/XH-D2G)/3.D0+2*(D1F/XH-D2F)*D1G/XH/3.D0 C 2) PION-SCALAR EXCHANGE: OSCS(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0 OSCT(FF,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0 OSCO(D1F,D1G,XH)= 0.D0 C 3) PION-PSEUDO-SCALAR EXCHANGE: OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G) OPSS(D1F,D2F,D1G,D2G,XH)= 4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0 OPST(D1F,D2F,D1G,D2G,XH)= 2*( (D1F/XH-D2F)*D1G/XH + . (D1G/XH-D2G)*D1F/XH )/3.D0 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) ZF0(ZERATH,ZEXH,ZEMH,ZEPH,XH)=ZERATH*(ZEMH/ZEXH-ZEPH*ZEXH)/(2*XH) ZH0(ZERATH,ZEXH,ZEMH,ZEPH,XH)=ZERATH*(ZEMH/ZEXH+ZEPH*ZEXH)/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) DAM = DAMB/PIM ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 CC DAMB1 = DAM*(2-IYEX) DAMB2 = DAM*(IYEX-1) IF(IYEX.EQ.1) FDISA=FDEXP(DAMB**2/ALM1**2) IF(IYEX.EQ.2) FDISA=FDEXP(DAMB**2/ALM2**2) RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 BM1 = DSQRT(AM1**2-DAMB1**2) XA =X*BM1/PIM RATA =BM1/ALM1 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM1 +RATA) EPA =FDERFC( XLM1 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU1)*X1-(BM1/PIM)*HIA DHIA =-(BM1/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(BM1/PIM)*DHIA FI1= FIA DFI1= DFIA DDFI1= DDFIA IF(KIND.NE.4) THEN BM2 = DSQRT(AM2**2-DAMB2**2) XA =X*BM2/PIM RATA =BM2/ALM2 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM2 +RATA) EPA =FDERFC( XLM2 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU2)*X1-(BM2/PIM)*HIA DHIA =-(BM2/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(BM2/PIM)*DHIA DDHIA =-(BM2/PIM)*DFIA-DHIA*X1+HIA*X2 C D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(BM2/PIM)*DDHIA C . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 C D3HIA =-(BM2/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3 F4A = 0.5D0*(PIM/BM2)*X*HIA DF4A = 0.5D0*(PIM/BM2)*(HIA+X*DHIA) DDF4A = 0.5D0*(PIM/BM2)*(2*DHIA+X*DDHIA) C D3F4A = 0.5D0*(PIM/BM2)*(3*DDHIA+X*D3HIA) ENDIF IF(KIND.EQ.4) THEN XA =X*AM2/PIM FIA =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA) DFIA = -2*(AM2/PIM)*XA*FIA DDFIA = -2*(AM2/PIM)*(XA*DFIA + DFIA*AM2/PIM) C D3FIA = -2*(AM2/PIM)*(XA*DDFIA + 2*DFIA*AM2/PIM) RATD = 0.5D0*PIM/AM2 F4A = FIA*RATD**2 DF4A = DFIA*RATD**2 DDF4A= DDFIA*RATD**2 C D3F4A= D3FIA*RATD**2 ENDIF FI2= FIA DFI2= DFIA DDFI2= DDFIA FI42= F4A DFI42= DF4A DDFI42= DDF4A C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,12 105 FUN(IFUN) = 0.D0 IF(KIND.EQ.1) THEN FUN(1) = 2*DAM*OPAEES(FI42,DFI1,DDFI1,X)*FDISA FUN(11)= 2*DAM*OCREES(FI42,DFI1,DDFI1,X)*FDISA FUN(2) = 2*DAM*OPAEET(FI42,DFI1,DDFI1,X)*FDISA FUN(12)= 2*DAM*OCREET(FI42,DFI1,DDFI1,X)*FDISA FUN(3) = 2*DAM*OPAEMT(DFI42,DFI1,DDFI1,X)*FDISA FUN(4) = 2*DAM*OPAEMO(DFI42,DFI1,X)*FDISA FUN(5) = 2*DAM*OPAMMC(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(6) = 2*DAM*OPAMMS(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(7) = 2*DAM*OPAMMT(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(8) = 2*DAM*OPEMS2(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(9) = 2*DAM*OPEMT2(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(10)= 2*DAM*OPEMO2(DFI42,DFI1,X)*FDISA ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = 2*DAM*OSCS(FI42,DFI1,DDFI1,X)*FDISA FUN(2) = 2*DAM*OSCT(FI42,DFI1,DDFI1,X)*FDISA ENDIF C IF(KIND.EQ.3) THEN FUN(1) = 2*DAM*OPSC(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(2) = 2*DAM*OPSS(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA FUN(3) = 2*DAM*OPST(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA ENDIF DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*1.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) FDISP = FDISP1*FDISP2 ZDISP1= CDEXP(2*ZI*Y*DAM*RATP1**2)*FDISP1*FDEXP((DAM*RATP1)**2) ZDISP2= CDEXP(2*ZI*Y*DAM*RATP2**2)*FDISP2*FDEXP((DAM*RATP2)**2) C C FIRST MESON: C REAL MESON MASS: AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM C COMPLEX MESON MASS: IF(IYEX.EQ.1) THEN ZAM=PIM*CDSQRT((BM1/PIM)**2+Y*Y+2*ZI*DAM*Y) ZXM=ZAM*X/PIM ZRATM =ZAM/ALM1 ZERATM=ZDEXP(ZRATM*ZRATM) ZEXM =ZDEXP(ZXM) ZEMM =ZDERFC(-XLM1+ZRATM) ZEPM =ZDERFC( XLM1+ZRATM) ZFIM = ZF0(ZERATM,ZEXM,ZEMM,ZEPM,X ) ZHIM = ZH0(ZERATM,ZEXM,ZEMM,ZEPM,X ) ZDFIM =-(ZFIM-2*VKU1)*X1-(ZAM/PIM)*ZHIM ZDHIM =-(ZAM/PIM)*ZFIM-ZHIM*X1 ZDDFIM =-(ZDFIM-2*DVKU1)*X1+(ZFIM-2*VKU1)*X2-(ZAM/PIM)*ZDHIM ENDIF C END FIRST MESON C C SECOND MESON: IF(KIND.NE.4) THEN C REAL MESON MASS: AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM C COMPLEX MESON MASS: IF(IYEX.EQ.2) THEN ZAM=PIM*CDSQRT((BM2/PIM)**2+Y*Y+2*ZI*DAM*Y) ZXM=ZAM*X/PIM ZRATM =ZAM/ALM2 ZERATM=ZDEXP(ZRATM*ZRATM) ZEXM =ZDEXP(ZXM) ZEMM =ZDERFC(-XLM2+ZRATM) ZEPM =ZDERFC( XLM2+ZRATM) ZFIM = ZF0(ZERATM,ZEXM,ZEMM,ZEPM,X ) ZHIM = ZH0(ZERATM,ZEXM,ZEMM,ZEPM,X ) ZDFIM =-(ZFIM-2*VKU2)*X1-(ZAM/PIM)*ZHIM ZDHIM =-(ZAM/PIM)*ZFIM-ZHIM*X1 ZDDFIM =-(ZDFIM-2*DVKU2)*X1+(ZFIM-2*VKU2)*X2-(ZAM/PIM)*ZDHIM ENDIF ENDIF IF(KIND.EQ.4) THEN FIM = FI2 DFIM = DFI2 DDFIM = DDFI2 IF(IYEX.EQ.2) THEN ZFIM = FI2 ZDFIM = DFI2 ZDDFIM = DDFI2 ENDIF ENDIF FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM C END SECOND MESON IF(IYEX.EQ.2) THEN C FOR THE FIRST CONTRIBUTION: GEW1 = 0.5D0*GEW/Y**2 GIM1 = (FI1-FDISP1*FIM1) DGIM1 = (DFI1-FDISP1*DFIM1) DDGIM1 = (DDFI1-FDISP1*DDFIM1) GIM2 = 2*DREAL(ZDISP2*ZFIM) DGIM2 = 2*DREAL(ZDISP2*ZDFIM) DDGIM2 = 2*DREAL(ZDISP2*ZDDFIM) C FOR THE SECOND CONTRIBUTION: GEW2 = ((Y*Y-DAM*DAM)/(Y*Y+DAM*DAM)**2)*GEW DFIM1 = DFI1 DDFIM1 = DDFI1 FIM2 = (FDISA*FI2-FDISP2*FIM2) DFIM2 = (FDISA*DFI2-FDISP2*DFIM2) DDFIM2 = (FDISA*DDFI2-FDISP2*DDFIM2) ENDIF IF(IYEX.EQ.1) THEN C FOR THE FIRST CONTRIBUTION: GEW1 = 0.5D0*GEW/Y**2 GIM2 = (FI2-FDISP2*FIM2) DGIM2 = (DFI2-FDISP2*DFIM2) DDGIM2 = (DDFI2-FDISP2*DDFIM2) GIM1 = 2*DREAL(ZDISP1*ZFIM) DGIM1 = 2*DREAL(ZDISP1*ZDFIM) DDGIM1 = 2*DREAL(ZDISP1*ZDDFIM) C FOR THE SECOND CONTRIBUTION: GEW2 = ((Y*Y-DAM*DAM)/(Y*Y+DAM*DAM)**2)*GEW DFIM1 = (FDISA*DFI1-FDISP1*DFIM1) DDFIM1 = (FDISA*DDFI1-FDISP1*DDFIM1) FIM2 = FI2 DFIM2 = DFI2 DDFIM2 = DDFI2 ENDIF C IF(KIND.EQ.1) THEN FUN(1) = FUN(1) + GEW2*OPAEES(FIM2,DFIM1,DDFIM1,X) . + GEW1*OPAEES(GIM2,DGIM1,DDGIM1,X) FUN(11) = FUN(11) + GEW2*OCREES(FIM2,DFIM1,DDFIM1,X) . + GEW1*OCREES(GIM2,DGIM1,DDGIM1,X) FUN(2) = FUN(2) + GEW2*OPAEET(FIM2,DFIM1,DDFIM1,X) . + GEW1*OPAEET(GIM2,DGIM1,DDGIM1,X) FUN(12) = FUN(12) + GEW2*OCREET(FIM2,DFIM1,DDFIM1,X) . + GEW1*OCREET(GIM2,DGIM1,DDGIM1,X) FUN(3) = FUN(3) + GEW2*OPAEMT(DFIM2,DFIM1,DDFIM1,X) . + GEW1*OPAEMT(DGIM2,DGIM1,DDGIM1,X) FUN(4) = FUN(4) + GEW2*OPAEMO(DFIM2,DFIM1,X) . + GEW1*OPAEMO(DGIM2,DGIM1,X) FUN(5) = FUN(5) + GEW2*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPAMMC(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(6) = FUN(6) + GEW2*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPAMMS(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(7) = FUN(7) + GEW2*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPAMMT(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(8) = FUN(8) + GEW2*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPEMS2(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(9) = FUN(9) + GEW2*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPEMT2(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(10) = FUN(10) + GEW2*OPEMO2(DFIM2,DFIM1,X) . + GEW1*OPEMO2(DGIM2,DGIM1,X) ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1) + GEW2*OSCS(FIM2,DFIM1,DDFIM1,X) . + GEW1*OSCS(GIM2,DGIM1,DDGIM1,X) FUN(2) = FUN(2) + GEW2*OSCT(FIM2,DFIM1,DDFIM1,X) . + GEW1*OSCT(GIM2,DGIM1,DDGIM1,X) ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1) + GEW2*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPSC(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(2) = FUN(2) + GEW2*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPSS(DGIM2,DDGIM2,DGIM1,DDGIM1,X) FUN(3) = FUN(3) + GEW2*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X) . + GEW1*OPST(DGIM2,DDGIM2,DGIM1,DDGIM1,X) ENDIF C 110 CONTINUE 100 CONTINUE C C CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1) C IF(IMETH.EQ.0) THEN YMAX = YB(NINT+1) YFAC2 = YMAX/(YMAX**2+DAM**2)*FDISA IF(KIND.EQ.1) THEN FUN(1) = FUN(1)+(1.D0/PI)*OPAEES(FI2,DFI1,DDFI1,X)*YFAC2 FUN(11)= FUN(11)+(1.D0/PI)*OCREES(FI2,DFI1,DDFI1,X)*YFAC2 FUN(2) = FUN(2)+(1.D0/PI)*OPAEET(FI2,DFI1,DDFI1,X)*YFAC2 FUN(12)= FUN(2)+(1.D0/PI)*OCREET(FI2,DFI1,DDFI1,X)*YFAC2 FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)*YFAC2 FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)*YFAC2 FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)*YFAC2 ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1)+(1.D0/PI)*OSCS(FI2,DFI1,DDFI1,X)*YFAC2 FUN(2) = FUN(2)+(1.D0/PI)*OSCT(FI2,DFI1,DDFI1,X)*YFAC2 ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2 ENDIF ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE YNFUN3(ITYPE,KIND,X,AM1,AM2,ALM1,ALM2,DAMB,FUN) C C THIS ROUTINE IS FOR THE CASE OF TWO(!) MESONS CARRYING STRANGENESS, C FUNCTIONS FOR KAON-KAON EXCHANGE ETC. , AM1=AM2= AMK= KAON MASS C VERSION: 23 FEBRUARI, 1996 C ********************************************************************** C C THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN.C C IT IS UNDERSTOOD THAT AM1=PIM, SO INDEX 1 REFERS TO THE PION. C NOTICE: IN THIS ROUTINE ITYPE=1 (PLANAR) AND ITYPE=2(CROSSED) C C COMPUTES THE FOURIER TRANSFORMS OF D_{X} AND D_{//}, WHERE C C 1) ITYPE=2: KAON-KAON EXCHANGE (CROSSED): C C 1 1 C -2* D_{X} = + -------- ---------------------- . C OM1.OM2 (OM1^2-A^2)(OM2^2-A^2) C C | 1 | C X |(OM1+OM2) - (OM1.OM2+A^2) --------- | C | OM1 + OM2 | C C 2) ITYPE=1: KAON-KAON EXCHANGE (PLANAR): C C 2 A^2 | 1 C 2* D_{//}= ---------------------- . | -------------- C (OM1^2-A^2)(OM2^2-A^2) | OM2(OM2^2-A^2) C C 1 1 | C + -------------- + ------------------| - 2* D_{X} C OM1(OM1^2-A^2) OM1.OM2(OM1 + OM2)| C C FOR VARIOUS COMBINATIONS OF DERIVATIVES. C C NOTICE: THE SAME AS YNFUN IN THE LIMIT DAM=0.D0 ! C C KIND = 1: PION-VECTOR-, KIND = 2: PION-SCALAR-, C KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE. C C SCHEMATICALLY: C PION-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT1 C FUN(4) = OPAEMO FUN(5) = OPAMMC FUN(6) = OPAMMS C FUN(7) = OPAMMT FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 C FUN(10)= OPAEMO2 FUN(11)= OCREES FUN(12)= OCREET C PION-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C PION-PSSCALAR EXCHANGE: C FUN(1) = OPSC FUN(2) = OPSS FUN(3) = OPST C !! NOTE: simplest def. of functions here, no k^2/M^2-terms! C in OPAEES etc. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) *** COMMON/MASSES/PIM,AMNC(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) DIMENSION XX(20),WW(20),YB(3),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/ DATA PIM/138.041D0/,AMPRO/938.2796D0/ SAVE XX,WW,DAM C C ACCORDING TO THE PAPER APPENDIX B, C DEFINITION STATEMENT OPERATORS: C C 1) PION-VECTOR EXCHANGE: OPAEES(FF,D1G,D2G,XH)= 2*FF*(2*D1G/XH+D2G)/3.D0 OPAEET(FF,D1G,D2G,XH)= -2*FF*(D1G/XH-D2G)/3.D0 OCREES(FF,D1G,D2G,XH)= .OPAEES(FF,D1G,D2G,XH) OCREET(FF,D1G,D2G,XH)= .OPAEET(FF,D1G,D2G,XH) OPAEMT(D1F,D1G,D2G,XH)= 2*D1F*(D1G/XH-D2G)/XH OPAEMO(D1F,D1G,XH)= 4*D1F*D1G/XH/XH OPEMS2(D1F,D2F,D1G,D2G,XH)=(2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0 OPEMT2(D1F,D2F,D1G,D2G,XH)=(D1F/XH-D2F)*(D1G/XH-D2G)/3.D0 OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH OPAMMC(D1F,D2F,D1G,D2G,XH)= .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH OPAMMS(D1F,D2F,D1G,D2G,XH)= .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0 OPAMMT(D1F,D2F,D1G,D2G,XH)= .-(D1F/XH+D2F)*(D1G/XH-D2G)/3.D0+2*(D1F/XH-D2F)*D1G/XH/3.D0 C 2) PION-SCALAR EXCHANGE: OSCS(FF,D1G,D2G,XH)= +FF*(2*D1G/XH+D2G)/3.D0 OSCT(FF,D1G,D2G,XH)= -FF*(D1G/XH-D2G)/3.D0 OSCO(D1F,D1G,XH)= 0.D0 C 3) PION-PSEUDO-SCALAR EXCHANGE: OPSC(D1F,D2F,D1G,D2G,XH)= (2*D1F*D1G/XH/XH+D2F*D2G) OPSS(D1F,D2F,D1G,D2G,XH)= 2*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0 OPST(D1F,D2F,D1G,D2G,XH)= 1*( (D1F/XH-D2F)*D1G/XH + . (D1G/XH-D2G)*D1F/XH )/3.D0 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) DAM = DAMB/PIM ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 CC RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 BM1 = DSQRT(AM1**2-DAMB**2) XA =X*BM1/PIM RATA =BM1/ALM1 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM1 +RATA) EPA =FDERFC( XLM1 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU1)*X1-(BM1/PIM)*HIA DHIA =-(BM1/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(BM1/PIM)*DHIA DDHIA =-(BM1/PIM)*DFIA-DHIA*X1+HIA*X2 C D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(BM1/PIM)*DDHIA C . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 C D3HIA =-(BM1/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3 F4A = 0.5D0*(PIM/BM1)*X*HIA DF4A = 0.5D0*(PIM/BM1)*(HIA+X*DHIA) DDF4A = 0.5D0*(PIM/BM1)*(2*DHIA+X*DDHIA) C D3F4A = 0.5D0*(PIM/BM1)*(3*DDHIA+X*D3HIA) FI1= FIA DFI1= DFIA DDFI1= DDFIA FI41= F4A DFI41= DF4A DDFI41= DDF4A IF(KIND.NE.4) THEN BM2 = DSQRT(AM2**2-DAMB**2) XA =X*BM2/PIM RATA =BM2/ALM2 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM2 +RATA) EPA =FDERFC( XLM2 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU2)*X1-(BM2/PIM)*HIA DHIA =-(BM2/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(BM2/PIM)*DHIA DDHIA =-(BM2/PIM)*DFIA-DHIA*X1+HIA*X2 F4A = 0.5D0*(PIM/BM2)*X*HIA DF4A = 0.5D0*(PIM/BM2)*(HIA+X*DHIA) DDF4A = 0.5D0*(PIM/BM2)*(2*DHIA+X*DDHIA) ENDIF IF(KIND.EQ.4) THEN XA =X*AM2/PIM FIA =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA) DFIA = -2*(AM2/PIM)*XA*FIA DDFIA = -2*(AM2/PIM)*(XA*DFIA + DFIA*AM2/PIM) C D3FIA = -2*(AM2/PIM)*(XA*DDFIA + 2*DFIA*AM2/PIM) RATD = 0.5D0*PIM/AM2 F4A = FIA*RATD**2 DF4A = DFIA*RATD**2 DDF4A= DDFIA*RATD**2 C D3F4A= D3FIA*RATD**2 ENDIF FI2= FIA DFI2= DFIA DDFI2= DDFIA FI42= F4A DFI42= DF4A DDFI42= DDF4A C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,12 105 FUN(IFUN) = 0.D0 FDISA=FDEXP(+DAM**2*RATP1**2)*FDEXP(+DAM**2*RATP2**2) IF(ITYPE.EQ.1) THEN IF(KIND.EQ.1) THEN FUN(1) = 1*DAM*(OPAEES(FI42,DFI1,DDFI1,X) . +OPAEES(FI2,DFI41,DDFI41,X))*FDISA FUN(11) = 1*DAM*(OCREES(FI42,DFI1,DDFI1,X) . +OCREES(FI2,DFI41,DDFI41,X))*FDISA FUN(2) = 1*DAM*(OPAEET(FI42,DFI1,DDFI1,X) . +OPAEET(FI2,DFI41,DDFI41,X))*FDISA FUN(12) = 1*DAM*(OCREET(FI42,DFI1,DDFI1,X) . +OCREET(FI2,DFI41,DDFI41,X))*FDISA FUN(3) = 1*DAM*(OPAEMT(DFI42,DFI1,DDFI1,X) . +OPAEMT(DFI2,DFI41,DDFI41,X))*FDISA FUN(4) = 1*DAM*(OPAEMO(DFI42,DFI1,X) . +OPAEMO(DFI2,DFI41,X))*FDISA FUN(5) = 1*DAM*(OPAMMC(DFI42,DDFI42,DFI1,DDFI1,X) . +OPAMMC(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(6) = 1*DAM*(OPAMMS(DFI42,DDFI42,DFI1,DDFI1,X) . +OPAMMS(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(7) = 1*DAM*(OPAMMT(DFI42,DDFI42,DFI1,DDFI1,X) . +OPAMMT(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(8) = 1*DAM*(OPEMS2(DFI42,DDFI42,DFI1,DDFI1,X) . +OPEMS2(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(9) = 1*DAM*(OPEMT2(DFI42,DDFI42,DFI1,DDFI1,X) . +OPEMT2(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(10) = 1*DAM*(OPEMO2(DFI42,DFI1,X) . +OPEMO2(DFI2,DFI41,X))*FDISA ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = 1*DAM*(OSCS(FI42,DFI1,DDFI1,X) . +OSCS(FI2,DFI41,DDFI41,X))*FDISA FUN(2) = 1*DAM*(OSCT(FI42,DFI1,DDFI1,X) . +OSCT(FI2,DFI41,DDFI41,X))*FDISA ENDIF C IF(KIND.EQ.3) THEN FUN(1) = 1*DAM*(OPSC(DFI42,DDFI42,DFI1,DDFI1,X) . +OPSC(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(2) = 1*DAM*(OPSS(DFI42,DDFI42,DFI1,DDFI1,X) . +OPSS(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA FUN(3) = 1*DAM*(OPST(DFI42,DDFI42,DFI1,DDFI1,X) . +OPST(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA ENDIF ENDIF DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*1.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) FDISP = FDISP1*FDISP2 C AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM C IF(KIND.NE.4) THEN AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM ENDIF IF(KIND.EQ.4) THEN FIM = FI2 DFIM = DFI2 DDFIM = DDFI2 ENDIF FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM IF(ITYPE.EQ.1) GEWH = GEW*(Y**2+3*DAM**2)/(Y**2+DAM**2)**2 IF(ITYPE.EQ.2) GEWH = +GEW/(Y**2+DAM**2) C IF(KIND.EQ.1) THEN FUN(1) = FUN(1) + GEWH*(FDISA*OPAEES(FI2,DFI1,DDFI1,X) . -FDISP*OPAEES(FIM2,DFIM1,DDFIM1,X)) FUN(11) = FUN(11) + GEWH*(FDISA*OCREES(FI2,DFI1,DDFI1,X) . -FDISP*OCREES(FIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEWH*(FDISA*OPAEET(FI2,DFI1,DDFI1,X) . -FDISP*OPAEET(FIM2,DFIM1,DDFIM1,X)) FUN(12) = FUN(12) + GEWH*(FDISA*OCREET(FI2,DFI1,DDFI1,X) . -FDISP*OCREET(FIM2,DFIM1,DDFIM1,X)) FUN(3) = FUN(3) + GEWH*(FDISA*OPAEMT(DFI2,DFI1,DDFI1,X) . -FDISP*OPAEMT(DFIM2,DFIM1,DDFIM1,X)) FUN(4) = FUN(4) + GEWH*(FDISA*OPAEMO(DFI2,DFI1,X) . -FDISP*OPAEMO(DFIM2,DFIM1,X)) FUN(5) = FUN(5) + GEWH*(FDISA*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(6) = FUN(6) + GEWH*(FDISA*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(7) = FUN(7) + GEWH*(FDISA*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(8) = FUN(8) + GEWH*(FDISA*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(9) = FUN(9) + GEWH*(FDISA*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(10) = FUN(10) + GEWH*(FDISA*OPEMO2(DFI2,DFI1,X) . -FDISP*OPEMO2(DFIM2,DFIM1,X)) ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1) + GEWH*(FDISA*OSCS(FI2,DFI1,DDFI1,X) . -FDISP*OSCS(FIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEWH*(FDISA*OSCT(FI2,DFI1,DDFI1,X) . -FDISP*OSCT(FIM2,DFIM1,DDFIM1,X)) ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1) + GEWH*(FDISA*OPSC(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEWH*(FDISA*OPSS(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(3) = FUN(3) + GEWH*(FDISA*OPST(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) ENDIF C 110 CONTINUE 100 CONTINUE C C CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1) C IF(IMETH.EQ.0) THEN YMAX = YB(NINT+1) IF(DAM.EQ.0.D0) YFACH = 1.D0/YMAX IF(DAM.NE.0.D0) THEN IF(ITYPE.EQ.1) YFACH=+(PI-2*DATAN(YMAX/DAM))/DAM . -YMAX/(YMAX**2+DAM**2) IF(ITYPE.EQ.2) YFACH=+(PI/2.D0-DATAN(YMAX/DAM))/DAM ENDIF YFACH = FDISA*YFACH IF(KIND.EQ.1) THEN FUN(1) = FUN(1)+(1.D0/PI)*OPAEES(FI2,DFI1,DDFI1,X)*YFACH FUN(11)= FUN(11)+(1.D0/PI)*OCREES(FI2,DFI1,DDFI1,X)*YFACH FUN(2) = FUN(2)+(1.D0/PI)*OPAEET(FI2,DFI1,DDFI1,X)*YFACH FUN(12)= FUN(12)+(1.D0/PI)*OCREET(FI2,DFI1,DDFI1,X)*YFACH FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)*YFACH FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)*YFACH FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)*YFACH ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1)+(1.D0/PI)*OSCS(FI2,DFI1,DDFI1,X)*YFACH FUN(2) = FUN(2)+(1.D0/PI)*OSCT(FI2,DFI1,DDFI1,X)*YFACH ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH ENDIF ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C************************************************************** FUNCTION ZDERFC(ZP) C************************************************************** IMPLICIT REAL*8 (A-H,O-Y) COMPLEX*16 ZP,Z,IMA,ZDERFC,ZDEXP,Z2,WIZ INTEGER CAPN,NU,N,NP1 REAL*8 H,H2,LAMBDA,R1,R2,S,S1,S2,T1,T2,C,REZ,IMZ,X,Y LOGICAL B DATA IMA/(0D0,1D0)/ X =DREAL(IMA*ZP) Y =DIMAG(IMA*ZP) C FIRST QUADRANT: IF(X .GE.0.D0 .AND. Y .GE.0.D0) THEN ICASE = 1 ENDIF C SECOND QUADRANT: IF(X .LT.0.D0 .AND. Y .GE.0.D0) THEN ICASE = 2 X = -X ENDIF C THIRD QUADRANT: IF(X .LT.0.D0 .AND. Y .LT.0.D0) THEN ICASE = 3 X = -X Y = -Y ENDIF C FOURTH QUADRANT: IF(X .GE.0.D0 .AND. Y .LT.0.D0) THEN ICASE = 4 Y = -Y ENDIF Z = X + IMA*Y C SO: Z= X + IY ALWAYS IN FIRST QUADRANT -> APPLICATION C GAUTSCHI ALGORITHM ** ** Ref. W. Gautschi, Algorithm 363, Communications of the ** ACM Vol. 12 (1969) 635. ** B =.FALSE. COEF = 1.12837916709551D0 C IF (X.LE.-4D0) GOTO 2 IF ((Y.LT.4.29D0).AND.(X.LT.5.33D0)) THEN S = (1D0-Y/4.29D0)*DSQRT(1D0-X*X/28.41D0) H = 1.6 * S H2 = 2*H CAPN = 6 + 23*S LAMBDA = H2**CAPN NU = 9 + 21*S ELSE H = 0 CAPN = 0 NU = 8 ENDIF ** lambda = 0 covers the underflow case when h > 0 is very small B = (H.EQ.0.OR.LAMBDA.EQ.0) R1 = 0D0 R2 = 0D0 S1 = 0D0 S2 = 0D0 DO 100 N =NU,0,-1 NP1 = N + 1 T1 = Y + H +NP1*R1 T2 = X - NP1*R2 C = 0.5D0/(T1*T1+T2*T2) R1=C*T1 R2=C*T2 IF (H.GT.0.AND.N.LE.CAPN) THEN T1 = LAMBDA+S1 S1 = R1*T1-R2*S2 S2=R2*T1+R1*S2 LAMBDA=LAMBDA/H2 ENDIF 100 CONTINUE IF (Y.EQ.0) THEN XX = -X*X REZ = FDEXP(XX) ELSE IF (B) REZ = COEF *R1 IF (.NOT.B) REZ = COEF*S1 ENDIF IF (B) IMZ = COEF*R2 IF (.NOT.B) IMZ = COEF*S2 IF(ICASE.EQ.1) THEN WIZ = REZ + IMA*IMZ ZDERFC = ZDEXP(-ZP*ZP)*WIZ ENDIF IF(ICASE.EQ.2) THEN WIZ = REZ - IMA*IMZ ZDERFC = ZDEXP(-ZP*ZP)*WIZ ENDIF IF(ICASE.EQ.3) THEN ZDERFC = 2.D0 - (REZ + IMA*IMZ) * ZDEXP(-ZP*ZP) ENDIF IF(ICASE.EQ.4) THEN ZDERFC = 2.D0 - (REZ - IMA*IMZ) * ZDEXP(-ZP*ZP) ENDIF RETURN C 1 ZDERFC=DCMPLX(0D0) C RETURN C 2 ZDERFC=DCMPLX(2D0) C RETURN END C************************************************************** FUNCTION ZDEXP(Z) C************************************************************** IMPLICIT REAL*8(A-Y) COMPLEX*16 ZDEXP,IMA,Z IMA=(0D0,1D0) X =DREAL(Z) Y =DIMAG(Z) ZDEXP = FDEXP(X)*(DCOS(Y)+IMA*DSIN(Y)) RETURN END C ********************************************************************** C ESCROMP2.F: ESCROMP1.F UPDATED TO INCLUDE ANTI-SYMMETRIC C SPIN-ORBIT FOR PS-VECTOR C ********************************************************************** SUBROUTINE YNPSPS(X,INA,IPV,IOFF,NCSB,APV) C ********************************************************************** C * C * DATE: JANUARY, 1995, UPDATED DECEMBER 1996 (REORGANIZED VECTORS) C C version: january 1997, used in latest TOKYO version! C C * YN-POTENTIALS FROM DOUBLE PSEUDO-SCALAR EXCHANGE C * C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET C * C ********************************************************************** C CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN): C C IKIND=3, PSSCALAR-PSSCALAR EXCHANGE: C FUN(1) = OPSC FUN(2) = OPSS FUN(3) = OPST C ********************************************************************** C C INCLUDED IN ENERGY DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT. C INCLUDED IN COUPLING-COMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/MODEL/IXXX(8),NSU3F COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD, .ALPA COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK C COMMON/OOM/ INA,IPV,IOFF COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/PSBE/ .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4) DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) CHARACTER *4 NTYPM(4) DATA NTYPM/'PI ','KA ','ETA ','ETAP'/ C DIMENSION FUN(12),FUNX(12) C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA IPIPI/1/,IPIET/1/,IPIETP/1/,IPIKA/1/,IKAKA/1/, . IETA2/1/,IETKA/1/,IETETP/1/,IETPKA/1/,IETAP2/1/ DATA N3/27/,FACT/70.D0/,DAM/230.D0/,ICALL/0/,ISFAC/1/,NSCHR/0/ .,POLD/-12345.D0/,ISU3/0/,ICSB/0/ SAVE FACT,DAM pim=pim0 if(nsu3f.eq.1) then call su3sym(pim,amn,ampro,amro,ameps) dam = 0d0 isu3= 1 endif C CALL ERRSET(208,256,-1,1) C 12 IF(ICALL.EQ.0) THEN FACT = PIM0/2.D0 IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 * ICSB = NCSB IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,ICSB 52 FORMAT(//,' IN YNPSPS: INA, IPV, IOFF=',3I3,' ICSB=',I2,//) IF(NSCHR.NE.0) PRINT 53, ALMP1,ALMP8,PIM,AMK,AME,AMX,DAM,APV 53 FORMAT(/,' IN YNPSPS: ALMP1=',D10.3,' ALMP8=',D10.3,/, . 11X,' PIM, AMK, AME, AMX =',4(F10.3,2X),/, . 11X,' DAM =',F10.3,' APV=',F12.5,/) * ICALL=1 ENDIF if(pold.ne.p) then icall=0 pold=p nschr=1 endif C C XI-COUPLINGS: F12 = F1*(4*ALP-1.D0)/SR3 F13 = -F1 C C CONSTRUCTION OF THE POTENTIALS C C DO 1 I=2,NMAX C X = XA(I) VCNN =0.D0 VSNN =0.D0 VTNN =0.D0 VCLL =0.D0 VCLS =0.D0 VCSS =0.D0 VCDR =0.D0 VSLL =0.D0 VSLS =0.D0 VSSS =0.D0 VSDR =0.D0 VTLL =0.D0 VTLS =0.D0 VTSS =0.D0 VTDR =0.D0 VOLL =0.D0 VOLS =0.D0 VOSS =0.D0 VODR =0.D0 DO 25 NCHAN=1,5 DO 25 IPTYP=1,5 DO 25 IPSI=1,4 DO 25 IPSJ=1,4 25 VPSPS(NCHAN,IPTYP,IPSI,IPSJ)=0.D0 IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) .CALL OMPSPS(X,INA,IPV,IOFF,ALP,APV) if(icall.eq.20.and.nschr.eq.1) then c** for check su3-symmetry: ** write(N3,*) 'from YNPSPS: CALL OMPSPS TURNED OFF!!' write(N3,*) 'from OMPSPS: x=',x write(N3,*) 'vcll,vsll=',vcll,vsll write(N3,*) 'vcls,vsls=',vcls,vsls write(N3,*) 'vcss,vsss=',vcss,vsss write(N3,*) 'vcdr,vsdr=',vcdr,vsdr endif C PION-PION EXCHANGE POTENTIALS: IF(IPIPI.EQ.1) THEN C PARALLEL: CPANN = 1*(3-2*ISFAC)*F1**2*F1**2 CPALL = 1*3*F1*F1*F3*F3 CPALS = 1*2*SR3*F1*F1*F3*F2 CPASS = 1*F1*F1*(3*F3*F3+4*F2*F2) CPADR = +1*F1*F1*F2*F2 C CROSSED: CCRNN = 1*(3+2*ISFAC)*F1**2*F1**2 CCRLL = 1*3*F1*F1*F3*F3 CCRLS = -1*2*SR3*F1*F1*F3*F2 CCRSS = -1*F1*F1*F3*F3 CCRDR = 1*F1*F1*(2*F3*F3+3*F2*F2) * CALL YNFUN(3,X,PIM,PIM,ALMP8,ALMP8,FUN) CALL YNFUN(3,X,AMPI,AMPI,ALMP8,ALMP8,FUN) VPSPS(1,1,1,1) = VPSPS(1,1,1,1) + FACT*( CPANN-CCRNN )*FUN(1) VPSPS(2,1,1,1) = VPSPS(2,1,1,1) + FACT*( CPALL-CCRLL )*FUN(1) VPSPS(3,1,1,1) = VPSPS(3,1,1,1) + FACT*( CPALS-CCRLS )*FUN(1) VPSPS(4,1,1,1) = VPSPS(4,1,1,1) + FACT*( CPASS-CCRSS )*FUN(1) VPSPS(5,1,1,1) = VPSPS(5,1,1,1) + FACT*( CPADR-CCRDR )*FUN(1) VPSPS(1,2,1,1) = VPSPS(1,2,1,1) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(2,2,1,1) = VPSPS(2,2,1,1) - FACT*( CPALL+CCRLL )*FUN(2) VPSPS(3,2,1,1) = VPSPS(3,2,1,1) - FACT*( CPALS+CCRLS )*FUN(2) VPSPS(4,2,1,1) = VPSPS(4,2,1,1) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,1,1) = VPSPS(5,2,1,1) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,1,1) = VPSPS(1,3,1,1) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(2,3,1,1) = VPSPS(2,3,1,1) - FACT*( CPALL+CCRLL )*FUN(3) VPSPS(3,3,1,1) = VPSPS(3,3,1,1) - FACT*( CPALS+CCRLS )*FUN(3) VPSPS(4,3,1,1) = VPSPS(4,3,1,1) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,1,1) = VPSPS(5,3,1,1) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END PION-PION C PION-ETA EXCHANGE POTENTIALS: IF(IPIET.EQ.1) THEN C PARALLEL: CPANN = +2*F1**2*F6**2*ISFAC * CPALL = -0.0271D0*ICSB*2*F1*F3*F6*F7 CPALL = 0D0 CPALS = -SR3*F1*F6*F3*(F8+F7) CPASS = -4*F1*F6*F2*F8 CPADR = +2*F1*F6*F2*F8 C CROSSED: CCRNN = +2*F1**2*F6**2*ISFAC * CCRLL = -0.0271D0*ICSB*2*F1*F3*F6*F7 CCRLL = 0D0 CCRLS = -SR3*F1*F6*F3*(F8+F7) CCRSS = -4*F1*F6*F2*F8 CCRDR = +2*F1*F6*F2*F8 * CALL YNFUN(3,X,PIM,AME,ALMP8,ALMP8,FUN) CALL YNFUN(3,X,AMPI,AME,ALMP8,ALMP8,FUN) VPSPS(1,2,1,3) = VPSPS(1,2,1,3) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(3,2,1,3) = VPSPS(3,2,1,3) - FACT*( CPALS+CCRLS )*FUN(2) VPSPS(4,2,1,3) = VPSPS(4,2,1,3) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,1,3) = VPSPS(5,2,1,3) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,1,3) = VPSPS(1,3,1,3) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(3,3,1,3) = VPSPS(3,3,1,3) - FACT*( CPALS+CCRLS )*FUN(3) VPSPS(4,3,1,3) = VPSPS(4,3,1,3) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,1,3) = VPSPS(5,3,1,3) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END PION-ETA C PION-ETA' EXCHANGE POTENTIALS: IF(IPIETP.EQ.1) THEN C PARALLEL: CPANN = +2*F1**2*F9**2*ISFAC * CPALL = -0.0271D0*ICSB*2*F1*F3*F9*F10 CPALL = 0D0 CPALS = -SR3*F1*F9*F3*(F11+F10) CPASS = -4*F1*F9*F2*F11 CPADR = +2*F1*F9*F2*F11 C CROSSED: CCRNN = +2*F1**2*F9**2*ISFAC * CCRLL = -0.0271D0*ICSB*2*F1*F3*F9*F10 CCRLL = 0D0 CCRLS = -SR3*F1*F9*F3*(F11+F10) CCRSS = -4*F1*F9*F2*F11 CCRDR = +2*F1*F9*F2*F11 * CALL YNFUN(3,X,PIM,AMX,ALMP8,ALMP1,FUN) CALL YNFUN(3,X,AMPI,AMX,ALMP8,ALMP1,FUN) VPSPS(1,2,1,4) = VPSPS(1,2,1,4) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(3,2,1,4) = VPSPS(3,2,1,4) - FACT*( CPALS+CCRLS )*FUN(2) VPSPS(4,2,1,4) = VPSPS(4,2,1,4) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,1,4) = VPSPS(5,2,1,4) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,1,4) = VPSPS(1,3,1,4) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(3,3,1,4) = VPSPS(3,3,1,4) - FACT*( CPALS+CCRLS )*FUN(3) VPSPS(4,3,1,4) = VPSPS(4,3,1,4) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,1,4) = VPSPS(5,3,1,4) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END PION-ETA' C PION-KAON EXCHANGE POTENTIALS: IF(IPIKA.EQ.1) THEN C PARALLEL: CPALL = 6*F1*F4*F3*F5 * -0.0271D0*ICSB*F1*F3*F4**2*6 CPALS = -SR3*F1*F3*(F4**2-F5**2) . +2*SR3*F1*F2*F4*F5 CPASS = F1*F5*(6*F3*F4+4*F2*F5) CPADR = +4*F1*F2*F5**2 C CROSSED: CCRLL = 3*(F1*F1*F4**2+F3*F3*F5**2) * -0.0271D0*ICSB*F1*F3*F4**2*3 CCRLS = SR3*F4*F5*(F1**2-F3**2) . +2*SR3*F2*F3*F5**2 CCRSS = 5*F1**2*F5**2+F3**2*F4**2 . +4*F2*F3*F4*F5 CCRDR = 2*F1**2*F5**2+F3**2*F4**2 . +3*F2**2*F5**2-2*F2*F3*F4*F5 * CALL YNFUN(3,X,PIM,AMK,ALMP8,ALMKA,FUN) CALL YNFUN(3,X,AMPI,AMK,ALMP8,ALMKA,FUN) c CALL YNFUN2(3,X,PIM,AMK,ALMP8,ALMKA,DAM,2,FUN) VPSPS(2,1,1,2) = VPSPS(2,1,1,2) + FACT*(CPALL-CCRLL)*FUN(1)*P VPSPS(3,1,1,2) = VPSPS(3,1,1,2) + FACT*(CPALS-CCRLS)*FUN(1)*P VPSPS(4,1,1,2) = VPSPS(4,1,1,2) + FACT*(CPASS-CCRSS)*FUN(1)*P VPSPS(5,1,1,2) = VPSPS(5,1,1,2) + FACT*(CPADR-CCRDR)*FUN(1)*P VPSPS(2,2,1,2) = VPSPS(2,2,1,2) - FACT*(CPALL+CCRLL)*FUN(2)*P VPSPS(3,2,1,2) = VPSPS(3,2,1,2) - FACT*(CPALS+CCRLS)*FUN(2)*P VPSPS(4,2,1,2) = VPSPS(4,2,1,2) - FACT*(CPASS+CCRSS)*FUN(2)*P VPSPS(5,2,1,2) = VPSPS(5,2,1,2) - FACT*(CPADR+CCRDR)*FUN(2)*P VPSPS(2,3,1,2) = VPSPS(2,3,1,2) - FACT*(CPALL+CCRLL)*FUN(3)*P VPSPS(3,3,1,2) = VPSPS(3,3,1,2) - FACT*(CPALS+CCRLS)*FUN(3)*P VPSPS(4,3,1,2) = VPSPS(4,3,1,2) - FACT*(CPASS+CCRSS)*FUN(3)*P VPSPS(5,3,1,2) = VPSPS(5,3,1,2) - FACT*(CPADR+CCRDR)*FUN(3)*P ENDIF C END PION-KAON C KAON-KAON EXCHANGE POTENTIALS: IF(IKAKA.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 1*(F4**2+3*F5**2)*F4**2 CPALS = 1*SR3*(F5**2-F4**2)*F4*F5 CPASS = 1*(3*F4**2+F5**2)*F5**2 CPADR = 1*4*F5**4 C CROSSED: CCRNN = 1*((F4**2+3*F5**2)**2+ISFAC*(F4**2-F5**2)**2)/2.D0 CCRLL = +1*(F4**2*F12**2+3*F5**2*F12**2) CCRLS = 1*SR3*(F4*F4-F5*F5)*F13*F12 CCRSS = +1*(-F4**2+5*F5**2)*F13**2 CCRDR = +1*2*(F4**2+1*F5**2)*F13**2 CALL YNFUN(3,X,AMK,AMK,ALMKA,ALMKA,FUN) CALL YNFUN(3,X,AMK,AMK,ALMKA,ALMKA,FUNX) cc CALL DKBFUN(3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) cc CALL DKBFUN(3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUNX) * CALL YNFUN3(1,3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) * CALL YNFUN3(2,3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUNX) VPSPS(1,1,2,2)=VPSPS(1,1,2,2)+FACT*(CPANN*FUN(1)-CCRNN*FUNX(1)) VPSPS(2,1,2,2)=VPSPS(2,1,2,2)+FACT*(CPALL*FUN(1)-CCRLL*FUNX(1)) VPSPS(3,1,2,2)=VPSPS(3,1,2,2)+FACT*(CPALS*FUN(1)-CCRLS*FUNX(1)) VPSPS(4,1,2,2)=VPSPS(4,1,2,2)+FACT*(CPASS*FUN(1)-CCRSS*FUNX(1)) VPSPS(5,1,2,2)=VPSPS(5,1,2,2)+FACT*(CPADR*FUN(1)-CCRDR*FUNX(1)) VPSPS(1,2,2,2)=VPSPS(1,2,2,2)-FACT*(CPANN*FUN(2)+CCRNN*FUNX(2)) VPSPS(2,2,2,2)=VPSPS(2,2,2,2)-FACT*(CPALL*FUN(2)+CCRLL*FUNX(2)) VPSPS(3,2,2,2)=VPSPS(3,2,2,2)-FACT*(CPALS*FUN(2)+CCRLS*FUNX(2)) VPSPS(4,2,2,2)=VPSPS(4,2,2,2)-FACT*(CPASS*FUN(2)+CCRSS*FUNX(2)) VPSPS(5,2,2,2)=VPSPS(5,2,2,2)-FACT*(CPADR*FUN(2)+CCRDR*FUNX(2)) VPSPS(1,3,2,2)=VPSPS(1,3,2,2)-FACT*(CPANN*FUN(3)+CCRNN*FUNX(3)) VPSPS(2,3,2,2)=VPSPS(2,3,2,2)-FACT*(CPALL*FUN(3)+CCRLL*FUNX(3)) VPSPS(3,3,2,2)=VPSPS(3,3,2,2)-FACT*(CPALS*FUN(3)+CCRLS*FUNX(3)) VPSPS(4,3,2,2)=VPSPS(4,3,2,2)-FACT*(CPASS*FUN(3)+CCRSS*FUNX(3)) VPSPS(5,3,2,2)=VPSPS(5,3,2,2)-FACT*(CPADR*FUN(3)+CCRDR*FUNX(3)) ENDIF C END KAON-KAON C ETA-ETA EXCHANGE POTENTIALS: IF(IETA2.EQ.1) THEN C PARALLEL: CPANN = 1*F6**2*F6**2 CPALL = 1*F6**2*F7**2 CPASS = 1*F6**2*F8**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = 1*F6**2*F7**2 CCRSS = 1*F6**2*F8**2 CCRDR = CCRSS CALL YNFUN(3,X,AME,AME,ALMP8,ALMP8,FUN) VPSPS(1,2,3,3) = VPSPS(1,2,3,3) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(2,2,3,3) = VPSPS(2,2,3,3) - FACT*( CPALL+CCRLL )*FUN(2) VPSPS(4,2,3,3) = VPSPS(4,2,3,3) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,3,3) = VPSPS(5,2,3,3) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,3,3) = VPSPS(1,3,3,3) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(2,3,3,3) = VPSPS(2,3,3,3) - FACT*( CPALL+CCRLL )*FUN(3) VPSPS(4,3,3,3) = VPSPS(4,3,3,3) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,3,3) = VPSPS(5,3,3,3) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END ETA-ETA C ETA-KAON EXCHANGE POTENTIALS: IF(IETKA.EQ.1) THEN C PARALLEL: CPALL = 2*F6*F7*F4**2 CPALS = -SR3*F6*(F7+F8)*F4*F5 CPASS = -2*F6*F8*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (F6**2+F7**2)*F4**2 CCRLS = -SR3*(F6**2+F7*F8)*F4*F5 CCRSS = -1*(F6**2+F8**2)*F5**2 CCRDR = -2*CCRSS CALL YNFUN(3,X,AME,AMK,ALMP8,ALMKA,FUN) ** CALL YNFUN2(3,X,AME,AMK,ALMP8,ALMKA,DAM,2,FUN) VPSPS(2,1,2,3) = VPSPS(2,1,2,3) + FACT*(CPALL-CCRLL)*FUN(1)*P VPSPS(3,1,2,3) = VPSPS(3,1,2,3) + FACT*(CPALS-CCRLS)*FUN(1)*P VPSPS(4,1,2,3) = VPSPS(4,1,2,3) + FACT*(CPASS-CCRSS)*FUN(1)*P VPSPS(5,1,2,3) = VPSPS(5,1,2,3) + FACT*(CPADR-CCRDR)*FUN(1)*P VPSPS(2,2,2,3) = VPSPS(2,2,2,3) - FACT*(CPALL+CCRLL)*FUN(2)*P VPSPS(3,2,2,3) = VPSPS(3,2,2,3) - FACT*(CPALS+CCRLS)*FUN(2)*P VPSPS(4,2,2,3) = VPSPS(4,2,2,3) - FACT*(CPASS+CCRSS)*FUN(2)*P VPSPS(5,2,2,3) = VPSPS(5,2,2,3) - FACT*(CPADR+CCRDR)*FUN(2)*P VPSPS(2,3,2,3) = VPSPS(2,3,2,3) - FACT*(CPALL+CCRLL)*FUN(3)*P VPSPS(3,3,2,3) = VPSPS(3,3,2,3) - FACT*(CPALS+CCRLS)*FUN(3)*P VPSPS(4,3,2,3) = VPSPS(4,3,2,3) - FACT*(CPASS+CCRSS)*FUN(3)*P VPSPS(5,3,2,3) = VPSPS(5,3,2,3) - FACT*(CPADR+CCRDR)*FUN(3)*P ENDIF C END ETA-KAON C ETA-ETA' EXCHANGE POTENTIALS: IF(IETETP.EQ.1) THEN C PARALLEL: CPANN = 2*F6**2*F9**2 CPALL = 2*F6*F9*F7*F10 CPASS = 2*F6*F9*F8*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = 2*F6*F9*F7*F10 CCRSS = 2*F6*F9*F8*F11 CCRDR = CCRSS CALL YNFUN(3,X,AME,AMX,ALMP8,ALMP1,FUN) VPSPS(1,2,3,4) = VPSPS(1,2,3,4) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(2,2,3,4) = VPSPS(2,2,3,4) - FACT*( CPALL+CCRLL )*FUN(2) VPSPS(4,2,3,4) = VPSPS(4,2,3,4) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,3,4) = VPSPS(5,2,3,4) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,3,4) = VPSPS(1,3,3,4) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(2,3,3,4) = VPSPS(2,3,3,4) - FACT*( CPALL+CCRLL )*FUN(3) VPSPS(4,3,3,4) = VPSPS(4,3,3,4) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,3,4) = VPSPS(5,3,3,4) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END ETA-ETA' C ETA'-KAON EXCHANGE POTENTIALS: IF(IETPKA.EQ.1) THEN C PARALLEL: CPALL = 2*F9*F10*F4**2 CPALS = -SR3*F9*(F10+F11)*F4*F5 CPASS = -2*F9*F11*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (F9**2+F10**2)*F4**2 CCRLS = -SR3*(F9**2+F10*F11)*F4*F5 CCRSS = -1*(F9**2+F11**2)*F5**2 CCRDR = -2*CCRSS CALL YNFUN(3,X,AMX,AMK,ALMP1,ALMKA,FUN) ** CALL YNFUN2(3,X,AMX,AMK,ALMP1,ALMKA,DAM,2,FUN) VPSPS(2,1,2,4) = VPSPS(2,1,2,4) + FACT*(CPALL-CCRLL)*FUN(1)*P VPSPS(3,1,2,4) = VPSPS(3,1,2,4) + FACT*(CPALS-CCRLS)*FUN(1)*P VPSPS(4,1,2,4) = VPSPS(4,1,2,4) + FACT*(CPASS-CCRSS)*FUN(1)*P VPSPS(5,1,2,4) = VPSPS(5,1,2,4) + FACT*(CPADR-CCRDR)*FUN(1)*P VPSPS(2,2,2,4) = VPSPS(2,2,2,4) - FACT*(CPALL+CCRLL)*FUN(2)*P VPSPS(3,2,2,4) = VPSPS(3,2,2,4) - FACT*(CPALS+CCRLS)*FUN(2)*P VPSPS(4,2,2,4) = VPSPS(4,2,2,4) - FACT*(CPASS+CCRSS)*FUN(2)*P VPSPS(5,2,2,4) = VPSPS(5,2,2,4) - FACT*(CPADR+CCRDR)*FUN(2)*P VPSPS(2,3,2,4) = VPSPS(2,3,2,4) - FACT*(CPALL+CCRLL)*FUN(3)*P VPSPS(3,3,2,4) = VPSPS(3,3,2,4) - FACT*(CPALS+CCRLS)*FUN(3)*P VPSPS(4,3,2,4) = VPSPS(4,3,2,4) - FACT*(CPASS+CCRSS)*FUN(3)*P VPSPS(5,3,2,4) = VPSPS(5,3,2,4) - FACT*(CPADR+CCRDR)*FUN(3)*P ENDIF C END ETAP-KAON C ETA'-ETA' EXCHANGE POTENTIALS: IF(IETAP2.EQ.1) THEN C PARALLEL: CPANN = 1*F9**2*F9**2 CPALL = 1*F9**2*F10**2 CPASS = 1*F9**2*F11**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = 1*F9**2*F10**2 CCRSS = 1*F9**2*F11**2 CCRDR = CCRSS CALL YNFUN(3,X,AMX,AMX,ALMP1,ALMP1,FUN) VPSPS(1,2,4,4) = VPSPS(1,2,4,4) - FACT*( CPANN+CCRNN )*FUN(2) VPSPS(2,2,4,4) = VPSPS(2,2,4,4) - FACT*( CPALL+CCRLL )*FUN(2) VPSPS(4,2,4,4) = VPSPS(4,2,4,4) - FACT*( CPASS+CCRSS )*FUN(2) VPSPS(5,2,4,4) = VPSPS(5,2,4,4) - FACT*( CPADR+CCRDR )*FUN(2) VPSPS(1,3,4,4) = VPSPS(1,3,4,4) - FACT*( CPANN+CCRNN )*FUN(3) VPSPS(2,3,4,4) = VPSPS(2,3,4,4) - FACT*( CPALL+CCRLL )*FUN(3) VPSPS(4,3,4,4) = VPSPS(4,3,4,4) - FACT*( CPASS+CCRSS )*FUN(3) VPSPS(5,3,4,4) = VPSPS(5,3,4,4) - FACT*( CPADR+CCRDR )*FUN(3) ENDIF C END ETA'-ETA' C TOTAL CONTRIBUTION: DO 30 IMES=1,4 DO 30 IPS=1,IMES VCNN = VCNN + VPSPS(1,1,IPS,IMES) VCLL = VCLL + VPSPS(2,1,IPS,IMES) VCLS = VCLS + VPSPS(3,1,IPS,IMES) VCSS = VCSS + VPSPS(4,1,IPS,IMES) VCDR = VCDR + VPSPS(5,1,IPS,IMES) VSNN = VSNN + VPSPS(1,2,IPS,IMES) VSLL = VSLL + VPSPS(2,2,IPS,IMES) VSLS = VSLS + VPSPS(3,2,IPS,IMES) VSSS = VSSS + VPSPS(4,2,IPS,IMES) VSDR = VSDR + VPSPS(5,2,IPS,IMES) VTNN = VTNN + VPSPS(1,3,IPS,IMES) VTLL = VTLL + VPSPS(2,3,IPS,IMES) VTLS = VTLS + VPSPS(3,3,IPS,IMES) VTSS = VTSS + VPSPS(4,3,IPS,IMES) VTDR = VTDR + VPSPS(5,3,IPS,IMES) 30 CONTINUE * if(icall.eq.0.and.nschr.eq.1) then if(icall.eq.20.and.nschr.eq.1) then call writetm(1,x,p) write(N3,*)'*****************************************************' write(N3,*) 'YNPSPS total contributions: x=',x write(N3,*) 'vcll,vsll=',vcll,vsll write(N3,*) 'vcls,vsls=',vcls,vsls write(N3,*) 'vcss,vsss=',vcss,vsss write(N3,*) 'vcdr,vsdr=',vcdr,vsdr write(N3,*)'*****************************************************' endif C END PSEUDO-SCALAR MESONS C 1 CONTINUE ICALL=ICALL+1 1000 CALL ERRSET(208,256,1,1) RETURN C END YNPSPS ROUTINE *************************************************** END C C FOR ROUTINE PIHBE: *********************************************** BLOCK DATA XX IMPLICIT REAL*8(A-H,O-Z) COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC COMMON/TREATD/IPIA2,IPIPOM,IPIKSS DATA IPIRO/1/,IPIOM/1/,IPIPH/1/,IPIKS/1/ DATA IPIDE/1/,IPIEP/1/,IPIST/1/,IPIKSC/1/ DATA IPIA2/1/,IPIPOM/1/,IPIKSS/1/ END C ********************************************************************** SUBROUTINE YNPIBE(X,INA,IPV,IOFF,APV) C ********************************************************************** C * C * DATE: JANUARY, 1995 C C * PION-MESON EXCHANGE YN-POTENTIALS (MESON= VECTOR, SCALAR, DIFFR.) C * C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS C * FROM: PI-EPSILON, PI-POMERON C C PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET C VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET C SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET C C STORAGE INDIDUAL CONTRIBUTIONS TO THE POTENTIALS: C VPSVC(NCHAN,TYPE,IPS,IVC): PS-VECTOR POTENTIALS, C NCHAN=1,2,3,4,5: NN,LL,LS,SS,DR; TYPE=1,2,3,4,5: VC,VSIG,VTEN,VSO,VASO C IPS =1,2,3,4: PI,K,ETA,ETAP; IVC=1,2,3,4: RHO,K*,OMEGA,PHI C ISC =1,2,3,4: DE,KAP,EPS,S*; IDF=1,2,3,4: A2,K**,POM,POMP C VPSSC and VPSDF ANALOGOUSLY C VPSSC and VPSDF ANALOGOUSLY C * C ********************************************************************** C CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN): C C IKIND=1, PION-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT FUN(4) = OPAEMO C FUN(5) = OPAMMC FUN(6) = OPAMMS FUN(7) = OPAMMT C IKIND=2, PION-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C IKIND=4, PION-DIFFRACTIVE EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C ********************************************************************** C C INCLUDED IN ENERGY-DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT,FACT2 C INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/POTNN /VCNN,VSNN,VTNN,VONN COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK * COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) * COMMON/ALLAX/FA1,FA9,ALPA c COMMON/OOM/ INA,IPV,IOFF COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) C DIMENSION FUN(12),FUNH(12),AMSIG(2),ASIG(2) COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC COMMON/TREATD/IPIA2,IPIPOM,IPIKSS COMMON/PSBE/ .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4) common/cpsbe/papssc(5,4,4,4),crpssc(5,4,4,4) CHARACTER *4 NTYPM(4,4) DATA NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','OM ','PHI ', .'DE ','KAP ','EPS ','S* ','A2 ','K** ','POM ','POMP'/ C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,DAM/230.D0/ * DATA AMPRO/1138.2796D0/,AMRO/760.D0/,AMEPS/760.D0/ DATA N3/27/,ICALL/0/,FACT/70.D0/,FACT2/0.D0/,ISFAC/1/,NSCHR/0/ SAVE FACT,FACT2,FACT3 pim=pim0 * pim=500.d0 C CALL ERRSET(208,256,-1,1) C 12 IF(ICALL.EQ.0) THEN FACT = PIM0/2.D0 * FACT2= 0.25D0*FACT*(PIM0/AMPRO)**2 * FACT3= 0.5D0*FACT2 FACT2= 0.5D0*FACT*(PIM0/AMPRO)**2 FACT3= 0.5D0*FACT2 IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 PRINT 52, INA,IPV,IOFF,IPIRO,IPIOM,IPIPH,IPIKS, . IPIDE,IPIEP,IPIST,IPIKSC,IPIA2,IPIPOM,IPIKSS 52 FORMAT(//,' IN YNPIBE: INA,IPV,IOFF=',3I3,//, . 11X,' IPIRO,IPIOM,IPIPH,IPIKS=',4I2,//, . 11X,' IPIDE,IPIEP,IPIST,IPIKSC=',4I2,//, . 11X,' IPIA2,IPIPOM,IPIKSS=',3I2,//) PRINT 53, ALMP1,ALMV1,ALMS1,ALMP8,ALMV8,ALMS8,PIM,DAM 53 FORMAT(/,' IN YNPIBE: ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=', . D10.3,/,11X,' ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',D10.3,/, . 11X,' PIM =',F10.3,' DAM =',F10.3,/) * ICALL=1 ENDIF C C CONSTRUCTION OF THE POTENTIALS C C DO 1 I=2,NMAX C X = XA(I) VCNN =0.D0 VSNN =0.D0 VCLL =0.D0 VCLS =0.D0 VCSS =0.D0 VCDR =0.D0 VSLL =0.D0 VSLS =0.D0 VSSS =0.D0 VSDR =0.D0 VTLL =0.D0 VTLS =0.D0 VTSS =0.D0 VTDR =0.D0 VOLL =0.D0 VOLS =0.D0 VOSS =0.D0 VODR =0.D0 VALL =0.D0 VALS =0.D0 VASS =0.D0 VADR =0.D0 DO 25 NCHAN=1,5 DO 25 IVTYP=1,5 DO 25 IPSI=1,4 DO 25 IMES=1,4 if(ivtyp.le.4) then papssc(nchan,ivtyp,ipsi,imes)=0.d0 crpssc(nchan,ivtyp,ipsi,imes)=0.d0 endif VPSVC(NCHAN,IVTYP,IPSI,IMES)=0.D0 VPSSC(NCHAN,IVTYP,IPSI,IMES)=0.D0 25 VPSDF(NCHAN,IVTYP,IPSI,IMES)=0.D0 C 1/M-CORRECTIONS: IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) .CALL OMPIBE(X,INA,IPV,IOFF,APV) c if(icall.eq.0.and.nschr.eq.1) then c write(N3,*) 'in OMPIBE: x=',x c write(N3,*) 'vcll,vsll=',vcll,vsll c write(N3,*) 'vcls,vsls=',vcls,vsls c write(N3,*) 'vcss,vsss=',vcss,vsss c write(N3,*) 'vcdr,vsdr=',vcdr,vsdr c endif C A) PION-VECTOR-MESON POTENTIALS: ****************************** C C PI-RHO: IF(IPIRO.EQ.1) THEN C EE-CONTRIBUTIONS: C PARALLEL: CPANN = 2*(3.D0-2.D0*ISFAC)*F1**2*FD1**2 CPALL = 6*F1*FD1*F3*FD3 CPALS = +2*SR3*F1*FD1*(F3*FD2+F2*FD3) CPASS = 2*F1*FD1*(3*F3*FD3+4*F2*FD2) CPADR = 2*F1*FD1*F2*FD2 C CROSSED: CCRNN = 2*(3.D0+2.D0*ISFAC)*F1**2*FD1**2 CCRLL = 6*F1*FD1*F3*FD3 CCRLS = -2*SR3*F1*FD1*(F3*FD2+F2*FD3) CCRSS = -2*F1*FD1*F3*FD3 CCRDR = 2*F1*FD1*(2*F3*FD3+3*F2*FD2) DO 710 LL=1,12 710 FUN(LL)=0.D0 DO 711 KK=1,2 * CALL YNFUN(1,X,PIM,AMVEC(KK),ALMP8,ALMV8,FUNH) CALL YNFUN(1,X,AMPI,AMVEC(KK),ALMP8,ALMV8,FUNH) DO 711 LL=1,12 711 FUN(LL)=FUN(LL)+AVEC(KK)*FUNH(LL) * CALL YNFUN(1,X,PIM,AMRO,ALMP8,ALMV8,FUN) * CALL YNFUN(1,X,AMPI,AMRO,ALMP8,ALMV8,FUN) VPSVC(1,2,1,1)= .VPSVC(1,2,1,1) + FACT*( CPANN*FUN(1) - CCRNN*FUN(11) ) VPSVC(2,2,1,1)= .VPSVC(2,2,1,1) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11) ) VPSVC(3,2,1,1)= .VPSVC(3,2,1,1) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11) ) VPSVC(4,2,1,1)= .VPSVC(4,2,1,1) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11) ) VPSVC(5,2,1,1)= .VPSVC(5,2,1,1) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11) ) VPSVC(1,3,1,1)= .VPSVC(1,3,1,1) + FACT*( CPANN*FUN(2) - CCRNN*FUN(12) ) VPSVC(2,3,1,1)= .VPSVC(2,3,1,1) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12) ) VPSVC(3,3,1,1)= .VPSVC(3,3,1,1) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12) ) VPSVC(4,3,1,1)= .VPSVC(4,3,1,1) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12) ) VPSVC(5,3,1,1)= .VPSVC(5,3,1,1) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12) ) C 1/M^2-TERMS: FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*(3.D0-2.D0*ISFAC)*F1**2*FVE1**2 CPALL = 6*F1*FVE1*F3*FVE3 CPALS = +2*SR3*F1*FVE1*(F3*FVE2+F2*FVE3) CPASS = 2*F1*FVE1*(3*F3*FVE3+4*F2*FVE2) CPADR = 2*F1*FVE1*F2*FVE2 C CROSSED: CCRNN = 2*(3.D0+2.D0*ISFAC)*F1**2*FVE1**2 CCRLL = 6*F1*FVE1*F3*FVE3 CCRLS = -2*SR3*F1*FVE1*(F3*FVE2+F2*FVE3) CCRSS = -2*F1*FVE1*F3*FVE3 CCRDR = 2*F1*FVE1*(2*F3*FVE3+3*F2*FVE2) * CALL YNFUN(1,X,PIM,AMRO,ALMP8,ALMV8,FUN) VPSVC(1,1,1,1)=VPSVC(1,1,1,1)+FACT2*( CPANN-CCRNN)*FUN(5) VPSVC(2,1,1,1)=VPSVC(2,1,1,1)+FACT2*( CPALL-CCRLL)*FUN(5) VPSVC(3,1,1,1)=VPSVC(3,1,1,1)+FACT2*( CPALS-CCRLS)*FUN(5) VPSVC(4,1,1,1)=VPSVC(4,1,1,1)+FACT2*( CPASS-CCRSS)*FUN(5) VPSVC(5,1,1,1)=VPSVC(5,1,1,1)+FACT2*( CPADR-CCRDR)*FUN(5) VPSVC(1,2,1,1)=VPSVC(1,2,1,1)+FACT2*( CPANN+CCRNN)*FUN(6) VPSVC(2,2,1,1)=VPSVC(2,2,1,1)+FACT2*( CPALL+CCRLL)*FUN(6) VPSVC(3,2,1,1)=VPSVC(3,2,1,1)+FACT2*( CPALS+CCRLS)*FUN(6) VPSVC(4,2,1,1)=VPSVC(4,2,1,1)+FACT2*( CPASS+CCRSS)*FUN(6) VPSVC(5,2,1,1)=VPSVC(5,2,1,1)+FACT2*( CPADR+CCRDR)*FUN(6) VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT2*( CPANN+CCRNN)*FUN(7) VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT2*( CPALL+CCRLL)*FUN(7) VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT2*( CPALS+CCRLS)*FUN(7) VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT2*( CPASS+CCRSS)*FUN(7) VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT2*( CPADR+CCRDR)*FUN(7) C EM-CONTRIBUTIONS: DO 31 ME=1,2 C EM,2-CONTRIBUTION: IF(ME.EQ.1) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 ENDIF IF(ME.EQ.2) THEN FVE1 = FD1+2*FV1 FVE2 = FD2+2*FV2 FVE3 = FD3+2*FV3 ENDIF C PARALLEL: CPANN = 2*(3.D0-2.D0*ISFAC)*F1**2*(2*FD1*FVE1) CPALL = 6*F1*F3*(FD1*FVE3+FVE1*FD3) CPALS = +2*SR3*F1*FD1*(F3*FVE2+F2*FVE3) . +2*SR3*F1*FVE1*(F3*FD2+F2*FD3) CPASS = 2*F1*FD1*(3*F3*FVE3+4*F2*FVE2) . +2*F1*FVE1*(3*F3*FD3+4*F2*FD2) CPADR = 2*F1*F2*(FD1*FVE2+FVE1*FD2) CPALLM = 6*F1*F3*(FD1*FVE3-FVE1*FD3) C CROSSED: CCRNN = 2*(3.D0+2.D0*ISFAC)*F1**2*(2*FD1*FVE1) CCRLL = 6*F1*F3*(FD1*FVE3+FVE1*FD3) CCRLS = -2*SR3*F1*FD1*(F3*FVE2+F2*FVE3) . -2*SR3*F1*FVE1*(F3*FD2+F2*FD3) CCRSS = -2*F1*F3*(FD1*FVE3+FVE1*FD3) CCRDR = 2*F1*FD1*(2*F3*FVE3+3*F2*FVE2) . +2*F1*FVE1*(2*F3*FD3+3*F2*FD2) CCRLLM = 6*F1*F3*(FD1*FVE3-FVE1*FD3) ** write(*,*) ' YNPIBE: cpall =',cpall ,' ccrll =',ccrll ** write(*,*) ' YNPIBE: cpallm=',cpallm,' ccrllm=',ccrllm IF(ME.EQ.1) THEN VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT3*(CPANN+CCRNN)*FUN(3) VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT3*(CPALL+CCRLL)*FUN(3) VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT3*(CPALS+CCRLS)*FUN(3) VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT3*(CPASS+CCRSS)*FUN(3) VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT3*(CPADR+CCRDR)*FUN(3) VPSVC(1,4,1,1)=VPSVC(1,4,1,1)+FACT3*(CPANN-CCRNN)*FUN(4) VPSVC(2,4,1,1)=VPSVC(2,4,1,1)+FACT3*(CPALL-CCRLL)*FUN(4) VPSVC(3,4,1,1)=VPSVC(3,4,1,1)+FACT3*(CPALS-CCRLS)*FUN(4) VPSVC(4,4,1,1)=VPSVC(4,4,1,1)+FACT3*(CPASS-CCRSS)*FUN(4) VPSVC(5,4,1,1)=VPSVC(5,4,1,1)+FACT3*(CPADR-CCRDR)*FUN(4) VPSVC(2,5,1,1)=VPSVC(2,5,1,1)-FACT3*(CPALLM-CCRLLM)*FUN(4) ENDIF IF(ME.EQ.2) THEN VPSVC(1,2,1,1)=VPSVC(1,2,1,1)+FACT3*(CPANN-CCRNN)*FUN(8) VPSVC(2,2,1,1)=VPSVC(2,2,1,1)+FACT3*(CPALL-CCRLL)*FUN(8) VPSVC(3,2,1,1)=VPSVC(3,2,1,1)+FACT3*(CPALS-CCRLS)*FUN(8) VPSVC(4,2,1,1)=VPSVC(4,2,1,1)+FACT3*(CPASS-CCRSS)*FUN(8) VPSVC(5,2,1,1)=VPSVC(5,2,1,1)+FACT3*(CPADR-CCRDR)*FUN(8) VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT3*(CPANN-CCRNN)*FUN(9) VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT3*(CPALL-CCRLL)*FUN(9) VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT3*(CPALS-CCRLS)*FUN(9) VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT3*(CPASS-CCRSS)*FUN(9) VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT3*(CPADR-CCRDR)*FUN(9) VPSVC(1,4,1,1)=VPSVC(1,4,1,1)+FACT3*(CPANN-CCRNN)*FUN(10) VPSVC(2,4,1,1)=VPSVC(2,4,1,1)+FACT3*(CPALL-CCRLL)*FUN(10) VPSVC(3,4,1,1)=VPSVC(3,4,1,1)+FACT3*(CPALS-CCRLS)*FUN(10) VPSVC(4,4,1,1)=VPSVC(4,4,1,1)+FACT3*(CPASS-CCRSS)*FUN(10) VPSVC(5,4,1,1)=VPSVC(5,4,1,1)+FACT3*(CPADR-CCRDR)*FUN(10) VPSVC(2,5,1,1)=VPSVC(2,5,1,1)-FACT3*(CPALLM-CCRLLM)*FUN(10) ENDIF write(*,*) 'pi-ro: me=',me,' vpsvc(2,4,1,1)=',vpsvc(2,4,1,1) .,' vpsvc(2,5,1,1)=',vpsvc(2,5,1,1) 31 CONTINUE ENDIF C END PION-RHO C C PION-OMEGA EXCHANGE POTENTIALS: C PI-OMEGA IF(IPIOM.EQ.1) THEN C 1/M^2-TERMS: FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*ISFAC*F1**2*FVE6**2 CPALS = -SR3*F1*FVE6*F3*(FVE7+FVE8) CPASS = -4*F1*FVE6*F2*FVE8 CPADR = +2*F1*FVE6*F2*FVE8 C CROSSED: CCRNN = CPANN CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR * CALL YNFUN(1,X,PIM,AMOM,ALMP8,ALMV1,FUN) CALL YNFUN(1,X,AMPI,AMOM,ALMP8,ALMV1,FUN) VPSVC(1,2,1,3)=VPSVC(1,2,1,3)+FACT2*( CPANN+CCRNN)*FUN(6) VPSVC(3,2,1,3)=VPSVC(3,2,1,3)+FACT2*( CPALS+CCRLS)*FUN(6) VPSVC(4,2,1,3)=VPSVC(4,2,1,3)+FACT2*( CPASS+CCRSS)*FUN(6) VPSVC(5,2,1,3)=VPSVC(5,2,1,3)+FACT2*( CPADR+CCRDR)*FUN(6) VPSVC(1,3,1,3)=VPSVC(1,3,1,3)+FACT2*( CPANN+CCRNN)*FUN(7) VPSVC(3,3,1,3)=VPSVC(3,3,1,3)+FACT2*( CPALS+CCRLS)*FUN(7) VPSVC(4,3,1,3)=VPSVC(4,3,1,3)+FACT2*( CPASS+CCRSS)*FUN(7) VPSVC(5,3,1,3)=VPSVC(5,3,1,3)+FACT2*( CPADR+CCRDR)*FUN(7) C EM-CONTRIBUTION: C PARALLEL: CPANN = 4*ISFAC*F1**2*FD6*FVE6 CPALS = -SR3*F1*FVE6*F3*(FD8+FD7) . -SR3*F1*(FD6)*F3*(FVE7+FVE8) CPASS = -4*F1*FVE6*F2*(FD8) . -4*F1*(FD6)*F2*FVE8 CPADR = +2*F1*FVE6*F2*(FD8) . +2*F1*(FD6)*F2*FVE8 C CROSSED: CCRNN = CPANN CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR VPSVC(1,3,1,3)=VPSVC(1,3,1,3)+FACT3*(CPANN+CCRNN)*FUN(3) VPSVC(3,3,1,3)=VPSVC(3,3,1,3)+FACT3*(CPALS+CCRLS)*FUN(3) VPSVC(4,3,1,3)=VPSVC(4,3,1,3)+FACT3*(CPASS+CCRSS)*FUN(3) VPSVC(5,3,1,3)=VPSVC(5,3,1,3)+FACT3*(CPADR+CCRDR)*FUN(3) ENDIF C END PION-OMEGA C PION-PHI EXCHANGE POTENTIALS: IF(IPIPH.EQ.1) THEN C 1/M^2-TERMS: FVE9 = FD9+FV9 FVE10 = FD10+FV10 FVE11 = FD11+FV11 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*ISFAC*F1**2*FVE9**2 CPALS = -SR3*F1*FVE9*F3*(FVE10+FVE11) CPASS = -4*F1*FVE9*F2*FVE11 CPADR = +2*F1*FVE9*F2*FVE11 C CROSSED: CCRNN = CPANN CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR * CALL YNFUN(1,X,PIM,AMFI,ALMP8,ALMV8,FUN) CALL YNFUN(1,X,AMPI,AMFI,ALMP8,ALMV8,FUN) VPSVC(1,2,1,4)=VPSVC(1,2,1,4)+FACT2*( CPANN+CCRNN)*FUN(6) VPSVC(3,2,1,4)=VPSVC(3,2,1,4)+FACT2*( CPALS+CCRLS)*FUN(6) VPSVC(4,2,1,4)=VPSVC(4,2,1,4)+FACT2*( CPASS+CCRSS)*FUN(6) VPSVC(5,2,1,4)=VPSVC(5,2,1,4)+FACT2*( CPADR+CCRDR)*FUN(6) VPSVC(1,3,1,4)=VPSVC(1,3,1,4)+FACT2*( CPANN+CCRNN)*FUN(7) VPSVC(3,3,1,4)=VPSVC(3,3,1,4)+FACT2*( CPALS+CCRLS)*FUN(7) VPSVC(4,3,1,4)=VPSVC(4,3,1,4)+FACT2*( CPASS+CCRSS)*FUN(7) VPSVC(5,3,1,4)=VPSVC(5,3,1,4)+FACT2*( CPADR+CCRDR)*FUN(7) C EM-CONTRIBUTION: C PARALLEL: CPANN = 4*ISFAC*F1**2*FD9*FVE9 CPALS = -SR3*F1*FVE9*F3*(FD11+FD10) . -SR3*F1*(FD9)*F3*(FVE10+FVE11) CPASS = -4*F1*FVE9*F2*(FD11) . -4*F1*(FD9)*F2*FVE11 CPADR = +2*F1*FVE9*F2*(FD11) . +2*F1*(FD9)*F2*FVE11 C CROSSED: CCRNN = CPANN CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR VPSVC(1,3,1,4)=VPSVC(1,3,1,4)+FACT3*( CPANN+CCRNN)*FUN(3) VPSVC(3,3,1,4)=VPSVC(3,3,1,4)+FACT3*( CPALS+CCRLS)*FUN(3) VPSVC(4,3,1,4)=VPSVC(4,3,1,4)+FACT3*( CPASS+CCRSS)*FUN(3) VPSVC(5,3,1,4)=VPSVC(5,3,1,4)+FACT3*( CPADR+CCRDR)*FUN(3) ENDIF C END PION-PHI C PION-KSTAR EXCHANGE POTENTIALS: IF(IPIKS.EQ.1) THEN C EE-CONTRIBUTION: C PARALLEL: CPALL = 6*F1*FD4*F3*FD5 CPALS = -SR3*F1*F3*(FD4**2-FD5**2) . +2*SR3*F1*F2*FD4*FD5 CPASS = F1*FD5*(6*F3*FD4+4*F2*FD5) CPADR = +4*F1*F2*FD5**2 C CROSSED: CCRLL = 3*(F1*F1*FD4**2+F3*F3*FD5**2) CCRLS = SR3*(F1**2-F3**2)*FD4*FD5 . +2*SR3*F2*F3*FD5**2 CCRSS = 5*F1**2*FD5**2+F3*F3*FD4**2 . +4*F2*F3*FD4*FD5 CCRDR = 2*F1**2*FD5**2+F3**2*FD4**2 . +3*F2**2*FD5**2-2*F2*F3*FD4*FD5 * CALL YNFUN(1,X,PIM,AMKS,ALMP8,ALMKS,FUN) CALL YNFUN(1,X,AMPI,AMKS,ALMP8,ALMKS,FUN) ** CALL YNFUN2(1,X,PIM,AMKS,ALMP8,ALMKS,DAM,2,FUN) VPSVC(2,2,1,2)= .VPSVC(2,2,1,2) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11) )*P VPSVC(3,2,1,2)= .VPSVC(3,2,1,2) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11) )*P VPSVC(4,2,1,2)= .VPSVC(4,2,1,2) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11) )*P VPSVC(5,2,1,2)= .VPSVC(5,2,1,2) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11) )*P VPSVC(2,3,1,2)= .VPSVC(2,3,1,2) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12) )*P VPSVC(3,3,1,2)= .VPSVC(3,3,1,2) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12) )*P VPSVC(4,3,1,2)= .VPSVC(4,3,1,2) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12) )*P VPSVC(5,3,1,2)= .VPSVC(5,3,1,2) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12) )*P C 1/M^2-TERMS: FVE4 = FD4+FV4 FVE5 = FD5+FV5 C MM-CONTRIBUTION: C PARALLEL: CPALL = 6*F1*FVE4*F3*FVE5 CPALS = -SR3*F1*F3*(FVE4**2-FVE5**2) . +2*SR3*F1*F2*FVE4*FVE5 CPASS = F1*FVE5*(6*F3*FVE4+4*F2*FVE5) CPADR = +4*F1*F2*FVE5**2 C CROSSED: CCRLL = 3*(F1*F1*FVE4**2+F3*F3*FVE5**2) CCRLS = SR3*(F1**2-F3**2)*FVE4*FVE5 . +2*SR3*F2*F3*FVE5**2 CCRSS = 5*F1**2*FVE5**2+F3**2*FVE4**2 . +4*F2*F3*FVE4*FVE5 CCRDR = 2*F1**2*FVE5**2+F3**2*FVE4**2 . +3*F2**2*FVE5**2-2*F2*F3*FVE4*FVE5 * CALL YNFUN(1,X,PIM,AMKS,ALMP8,ALMKS,FUN) CALL YNFUN(1,X,AMPI,AMKS,ALMP8,ALMKS,FUN) ** CALL YNFUN2(1,X,PIM,AMKS,ALMP8,ALMKS,DAM,2,FUN) VPSVC(2,1,1,2)=VPSVC(2,1,1,2)+FACT2*(CPALL-CCRLL)*FUN(5)*P VPSVC(3,1,1,2)=VPSVC(3,1,1,2)+FACT2*(CPALS-CCRLS)*FUN(5)*P VPSVC(4,1,1,2)=VPSVC(4,1,1,2)+FACT2*(CPASS-CCRSS)*FUN(5)*P VPSVC(5,1,1,2)=VPSVC(5,1,1,2)+FACT2*(CPADR-CCRDR)*FUN(5)*P VPSVC(2,2,1,2)=VPSVC(2,2,1,2)+FACT2*(CPALL+CCRLL)*FUN(6)*P VPSVC(3,2,1,2)=VPSVC(3,2,1,2)+FACT2*(CPALS+CCRLS)*FUN(6)*P VPSVC(4,2,1,2)=VPSVC(4,2,1,2)+FACT2*(CPASS+CCRSS)*FUN(6)*P VPSVC(5,2,1,2)=VPSVC(5,2,1,2)+FACT2*(CPADR+CCRDR)*FUN(6)*P VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT2*(CPALL+CCRLL)*FUN(7)*P VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT2*(CPALS+CCRLS)*FUN(7)*P VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT2*(CPASS+CCRSS)*FUN(7)*P VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT2*(CPADR+CCRDR)*FUN(7)*P C EM-CONTRIBUTIONS: DO 32 ME=1,2 C EM,2-CONTRIBUTION: IF(ME.EQ.2) THEN FVE4 = FD4+2*FV4 FVE5 = FD5+2*FV5 ENDIF C PARALLEL: CPALL = 6*F1*FVE4*F3*FD5 +6*F1*FD4*F3*FVE5 CPALS = -SR3*F1*F3*(FD4*FVE4-FD5*FVE5)*2 . +2*SR3*F1*F2*(FD4*FVE5+FVE4*FD5) CPASS = F1*FD5*(6*F3*FVE4+4*F2*FVE5) . +F1*FVE5*(6*F3*FD4+4*F2*FD5) CPADR = +4*F1*F2*FD5*FVE5*2 CPALLM = 6*F1*FVE4*F3*FD5 -6*F1*FD4*F3*FVE5 C CROSSED: CCRLL = 3*(F1*F1*FD4*FVE4+F3*F3*FD5*FVE5)*2 CCRLS = SR3*(F1**2-F3**2)*(FD4*FVE5+FVE4*FD5) . +2*SR3*F2*F3*FD5*FVE5*2 CCRSS = 5*F1**2*FD5*FVE5*2+F3**2*FD4*FVE4*2 . +4*F2*F3*(FD4*FVE5+FD5*FVE4) CCRDR = 2*F1**2*FD5*FVE5*2+F3**2*FD4*FVE4*2 . +3*F2**2*FD5*FVE5*2-2*F2*F3*(FD4*FVE5+FD5*FVE4) CCRLLM = 3*(F1*F1*FD4*FVE4-F3*F3*FD5*FVE5)*2 IF(ME.EQ.1) THEN VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT3*(CPALL+CCRLL)*FUN(3)*P VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT3*(CPALS+CCRLS)*FUN(3)*P VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT3*(CPASS+CCRSS)*FUN(3)*P VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT3*(CPADR+CCRDR)*FUN(3)*P VPSVC(2,4,1,2)=VPSVC(2,4,1,2)+FACT3*(CPALL-CCRLL)*FUN(4)*P VPSVC(3,4,1,2)=VPSVC(3,4,1,2)+FACT3*(CPALS-CCRLS)*FUN(4)*P VPSVC(4,4,1,2)=VPSVC(4,4,1,2)+FACT3*(CPASS-CCRSS)*FUN(4)*P VPSVC(5,4,1,2)=VPSVC(5,4,1,2)+FACT3*(CPADR-CCRDR)*FUN(4)*P VPSVC(2,5,1,2)=VPSVC(2,5,1,2)-FACT3*(CPALLM-CCRLLM)*FUN(4)*P ENDIF IF(ME.EQ.2) THEN VPSVC(2,2,1,2)=VPSVC(2,2,1,2)+FACT3*(CPALL-CCRLL)*FUN(8)*P VPSVC(3,2,1,2)=VPSVC(3,2,1,2)+FACT3*(CPALS-CCRLS)*FUN(8)*P VPSVC(4,2,1,2)=VPSVC(4,2,1,2)+FACT3*(CPASS-CCRSS)*FUN(8)*P VPSVC(5,2,1,2)=VPSVC(5,2,1,2)+FACT3*(CPADR-CCRDR)*FUN(8)*P VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT3*(CPALL-CCRLL)*FUN(9)*P VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT3*(CPALS-CCRLS)*FUN(9)*P VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT3*(CPASS-CCRSS)*FUN(9)*P VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT3*(CPADR-CCRDR)*FUN(9)*P VPSVC(2,4,1,2)=VPSVC(2,4,1,2)+FACT3*(CPALL-CCRLL)*FUN(10)*P VPSVC(3,4,1,2)=VPSVC(3,4,1,2)+FACT3*(CPALS-CCRLS)*FUN(10)*P VPSVC(4,4,1,2)=VPSVC(4,4,1,2)+FACT3*(CPASS-CCRSS)*FUN(10)*P VPSVC(5,4,1,2)=VPSVC(5,4,1,2)+FACT3*(CPADR-CCRDR)*FUN(10)*P VPSVC(2,5,1,2)=VPSVC(2,5,1,2)-FACT3*(CPALLM-CCRLLM)*FUN(10)*P ENDIF write(*,*) 'pi K^*: me=',me,' vpsvc(2,4,1,2)=',vpsvc(2,4,1,1) .,' vpsvc(2,5,1,2)=',vpsvc(2,5,1,1) 32 CONTINUE ENDIF C END PION-KSTAR c if(icall.eq.0.and.nschr.eq.1) call writetm(2,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(2,x,p) C END VECTOR MESONS C C B) PION-SCALAR MESONS: ***************************************** C C PION-DELTA EXCHANGE POTENTIALS: RATOSA = 0.5D0*(AMN**2-AMLN**2)/AMN/AMLN ratosa=0d0 IF(IPIDE.EQ.1) THEN C PARALLEL: CPANN = 2*(3.D0-2.D0*ISFAC)*F1**2*GS1**2 CPALL = 6*F1*GS1*F3*GS3 CPALS = +2*SR3*F1*GS1*(F3*GS2+F2*GS3) CPASS = 2*F1*GS1*(3*F3*GS3+4*F2*GS2) CPADR = 2*F1*GS1*F2*GS2 C CROSSED: CCRNN = 2*(3.D0+2.D0*ISFAC)*F1**2*GS1**2 CCRLL = 6*F1*GS1*F3*GS3 CCRLS = -2*SR3*F1*GS1*(F3*GS2+F2*GS3) CCRSS = -2*F1*GS1*F3*GS3 CCRDR = 2*F1*GS1*(2*F3*GS3+3*F2*GS2) papssc(1,1,1,1)=cpann crpssc(1,1,1,1)=ccrnn papssc(5,1,1,1)=cpadr crpssc(5,1,1,1)=ccrdr papssc(2,1,1,1)=cpall crpssc(2,1,1,1)=ccrll papssc(3,1,1,1)=cpals crpssc(3,1,1,1)=ccrls papssc(4,1,1,1)=cpass crpssc(4,1,1,1)=ccrss * CALL YNFUN(2,X,PIM,AMD,ALMP8,ALMS8,FUN) CALL YNFUN(2,X,AMPI,AMD,ALMP8,ALMS8,FUN) VPSSC(1,2,1,1)=VPSSC(1,2,1,1)+FACT*( CPANN-CCRNN)*FUN(1) VPSSC(2,2,1,1)=VPSSC(2,2,1,1)+FACT*( CPALL-CCRLL)*FUN(1) VPSSC(3,2,1,1)=VPSSC(3,2,1,1)+FACT*( CPALS-CCRLS)*FUN(1) VPSSC(4,2,1,1)=VPSSC(4,2,1,1)+FACT*( CPASS-CCRSS)*FUN(1) VPSSC(5,2,1,1)=VPSSC(5,2,1,1)+FACT*( CPADR-CCRDR)*FUN(1) VPSSC(1,3,1,1)=VPSSC(1,3,1,1)+FACT*( CPANN-CCRNN)*FUN(2) VPSSC(2,3,1,1)=VPSSC(2,3,1,1)+FACT*( CPALL-CCRLL)*FUN(2) VPSSC(3,3,1,1)=VPSSC(3,3,1,1)+FACT*( CPALS-CCRLS)*FUN(2) VPSSC(4,3,1,1)=VPSSC(4,3,1,1)+FACT*( CPASS-CCRSS)*FUN(2) VPSSC(5,3,1,1)=VPSSC(5,3,1,1)+FACT*( CPADR-CCRDR)*FUN(2) VPSSC(1,4,1,1)=VPSSC(1,4,1,1)+FACT*( CPANN-CCRNN)*FUN(3) VPSSC(2,4,1,1)=VPSSC(2,4,1,1)+FACT*( CPALL-CCRLL)*FUN(3) VPSSC(3,4,1,1)=VPSSC(3,4,1,1)+FACT*( CPALS-CCRLS)*FUN(3) VPSSC(4,4,1,1)=VPSSC(4,4,1,1)+FACT*( CPASS-CCRSS)*FUN(3) VPSSC(5,4,1,1)=VPSSC(5,4,1,1)+FACT*( CPADR-CCRDR)*FUN(3) VPSSC(2,5,1,1)=VPSSC(2,5,1,1)+FACT*( CPALL-CCRLL)*FUN(3) .*RATOSA write(*,*) 'pi-a0',' vpsvc(2,4,1,1)=',vpsvc(2,4,1,1) .,' vpsvc(2,5,1,1)=',vpsvc(2,5,1,1) ENDIF C END PION-DELTA C PION-EPSILON1 EXCHANGE POTENTIALS: NO ADIABATIC CONTRIBUTIONS C PION-SSTAR EXCHANGE POTENTIALS: NO ADIABATIC CONTRIBUTIONS C PION-KAPPA EXCHANGE POTENTIALS: IF(IPIKSC.EQ.1) THEN C PARALLEL: CPALL = 6*F1*GS4*F3*GS5 CPALS = -SR3*F1*F3*(GS4**2-GS5**2) . +2*SR3*F1*F2*GS4*GS5 CPASS = F1*GS5*(6*F3*GS4+4*F2*GS5) CPADR = +4*F1*F2*GS5**2 C CROSSED: CCRLL = 3*(F1*F1*GS4**2+F3*F3*GS5**2) CCRLS = SR3*(F1**2-F3**2)*GS4*GS5 . +2*SR3*F2*F3*GS5**2 CCRSS = 5*F1**2*GS5**2+F3*F3*GS4**2 . +4*F2*F3*GS4*GS5 CCRDR = 2*F1**2*GS5**2+F3**2*GS4**2 . +3*F2**2*GS5**2-2*F2*F3*GS4*GS5 papssc(5,1,1,2)=cpadr crpssc(5,1,1,2)=ccrdr papssc(2,1,1,2)=cpall crpssc(2,1,1,2)=ccrll papssc(3,1,1,2)=cpals crpssc(3,1,1,2)=ccrls papssc(4,1,1,2)=cpass crpssc(4,1,1,2)=ccrss * CALL YNFUN(2,X,PIM,AMSCK,ALMP8,ALMS8,FUN) CALL YNFUN(2,X,AMPI,AMSCK,ALMP8,ALMS8,FUN) ** CALL YNFUN2(2,X,PIM,AMSCK,ALMP8,ALMS8,DAM,2,FUN) VPSSC(2,2,1,2)=VPSSC(2,2,1,2)+FACT*(CPALL-CCRLL)*FUN(1)*P VPSSC(3,2,1,2)=VPSSC(3,2,1,2)+FACT*(CPALS-CCRLS)*FUN(1)*P VPSSC(4,2,1,2)=VPSSC(4,2,1,2)+FACT*(CPASS-CCRSS)*FUN(1)*P VPSSC(5,2,1,2)=VPSSC(5,2,1,2)+FACT*(CPADR-CCRDR)*FUN(1)*P VPSSC(2,3,1,2)=VPSSC(2,3,1,2)+FACT*(CPALL-CCRLL)*FUN(2)*P VPSSC(3,3,1,2)=VPSSC(3,3,1,2)+FACT*(CPALS-CCRLS)*FUN(2)*P VPSSC(4,3,1,2)=VPSSC(4,3,1,2)+FACT*(CPASS-CCRSS)*FUN(2)*P VPSSC(5,3,1,2)=VPSSC(5,3,1,2)+FACT*(CPADR-CCRDR)*FUN(2)*P C toegevoegd may 2006: VPSSC(1,4,1,2)=VPSSC(1,4,1,2)+FACT*( CPANN-CCRNN)*FUN(3) VPSSC(2,4,1,2)=VPSSC(2,4,1,2)+FACT*( CPALL-CCRLL)*FUN(3) VPSSC(3,4,1,2)=VPSSC(3,4,1,2)+FACT*( CPALS-CCRLS)*FUN(3) VPSSC(4,4,1,2)=VPSSC(4,4,1,2)+FACT*( CPASS-CCRSS)*FUN(3) VPSSC(5,4,1,2)=VPSSC(5,4,1,2)+FACT*( CPADR-CCRDR)*FUN(3) VPSSC(2,5,1,2)=VPSSC(2,5,1,2)+FACT*( CPALL-CCRLL)*FUN(3) .*RATOSA write(*,*) 'pi-kap ',' vpsvc(2,4,1,2)=',vpsvc(2,4,1,2) .,' vpsvc(2,5,1,2)=',vpsvc(2,5,1,2) ENDIF C END PION-KAPPA c if(icall.eq.0.and.nschr.eq.1) call writetm(3,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(3,x,p) C END SCALAR MESONS C C D) BEGIN DIFFRACTIVE CONTRIBUTIONS ******************* C C PION-A2 EXCHANGE POTENTIALS: IF(IPIA2.EQ.1) THEN C PARALLEL: CPANN = 2*(3.D0-2.D0*ISFAC)*F1**2*GD1**2 CPALL = 6*F1*GD1*F3*GD3 CPALS = +2*SR3*F1*GD1*(F3*GD2+F2*GD3) CPASS = 2*F1*GD1*(3*F3*GD3+4*F2*GD2) CPADR = 2*F1*GD1*F2*GD2 C CROSSED: CCRNN = 2*(3.D0+2.D0*ISFAC)*F1**2*GD1**2 CCRLL = 6*F1*GD1*F3*GD3 CCRLS = -2*SR3*F1*GD1*(F3*GD2+F2*GD3) CCRSS = -2*F1*GD1*F3*GD3 CCRDR = 2*F1*GD1*(2*F3*GD3+3*F2*GD2) * CALL YNFUN(4,X,PIM,AMPOM,ALMP8,AMPRO,FUN) CALL YNFUN(4,X,AMPI,AMPOM,ALMP8,AMPRO,FUN) VPSDF(1,2,1,1)=VPSDF(1,2,1,1)-FACT*(CPANN-CCRNN)*FUN(1) VPSDF(2,2,1,1)=VPSDF(2,2,1,1)-FACT*(CPALL-CCRLL)*FUN(1) VPSDF(3,2,1,1)=VPSDF(3,2,1,1)-FACT*(CPALS-CCRLS)*FUN(1) VPSDF(4,2,1,1)=VPSDF(4,2,1,1)-FACT*(CPASS-CCRSS)*FUN(1) VPSDF(5,2,1,1)=VPSDF(5,2,1,1)-FACT*(CPADR-CCRDR)*FUN(1) VPSDF(1,3,1,1)=VPSDF(1,3,1,1)-FACT*(CPANN-CCRNN)*FUN(2) VPSDF(2,3,1,1)=VPSDF(2,3,1,1)-FACT*(CPALL-CCRLL)*FUN(2) VPSDF(3,3,1,1)=VPSDF(3,3,1,1)-FACT*(CPALS-CCRLS)*FUN(2) VPSDF(4,3,1,1)=VPSDF(4,3,1,1)-FACT*(CPASS-CCRSS)*FUN(2) VPSDF(5,3,1,1)=VPSDF(5,3,1,1)-FACT*(CPADR-CCRDR)*FUN(2) ENDIF C END PION-A2 C PION-POMERON: NO ADIABATIC CONTRIBUTIONS C PION-K** EXCHANGE POTENTIALS: IF(IPIKSS.EQ.1) THEN C PARALLEL: CPALL = 6*F1*GD4*F3*GD5 CPALS = -SR3*F1*F3*(GD4**2-GD5**2) . +2*SR3*F1*F2*GD4*GD5 CPASS = F1*GD5*(6*F3*GD4+4*F2*GD5) CPADR = +4*F1*F2*GD5**2 C CROSSED: CCRLL = 3*(F1*F1*GD4**2+F3*F3*GD5**2) CCRLS = SR3*(F1**2-F3**2)*GD4*GD5 . +2*SR3*F2*F3*GD5**2 CCRSS = 5*F1**2*GD5**2+F3*F3*GD4**2 . +4*F2*F3*GD4*GD5 CCRDR = 2*F1**2*GD5**2+F3**2*GD4**2 . +3*F2**2*GD5**2-2*F2*F3*GD4*GD5 * CALL YNFUN(4,X,PIM,AMPOM,ALMP8,AMPRO,FUN) CALL YNFUN(4,X,AMPI,AMPOM,ALMP8,AMPRO,FUN) ** CALL YNFUN2(4,X,PIM,AMPOM,ALMP8,AMPRO,DAM,2,FUN) VPSDF(2,2,1,2)=VPSDF(2,2,1,2)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,1,2)=VPSDF(3,2,1,2)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,1,2)=VPSDF(4,2,1,2)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,1,2)=VPSDF(5,2,1,2)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,1,2)=VPSDF(2,3,1,2)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,1,2)=VPSDF(3,3,1,2)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,1,2)=VPSDF(4,3,1,2)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,1,2)=VPSDF(5,3,1,2)-FACT*(CPADR-CCRDR)*FUN(2)*P ENDIF C END PION-K** 30 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writetm(4,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(4,x,p) C END DIFFRACTIVE CONTRIBUTIONS C 1 CONTINUE 1000 CALL ERRSET(208,256,1,1) ICALL = ICALL + 1 RETURN C END YNPIBE ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE YNPSBE(X,INA,IPV,IOFF,APV) C ********************************************************************** C * C * DATE: FEBRUARY 1995 , YNPSBE = COMPLEMENT YNPIBE C C * KAON-MESON AND ETA(P)-MESON EXCHANGE YN-POTENTIALS C * (MESON= VECTOR, SCALAR, DIFFR.) C * C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS C * FROM: PI-EPSILON, PI-POMERON C C PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET C VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET C SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET C * C ********************************************************************** C CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN): C C KIND=1, PSEUDOSCALAR-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT FUN(4) = OPAEMO C FUN(5) = OPAMMC FUN(6) = OPAMMS FUN(7) = OPAMMT C KIND=2, PSEUDOSCALAR-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C KIND=4, PSEUDOSCALAR-DIFFRACTIVE EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT C ********************************************************************** C C INCLUDED IN ENERGY-DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT,FACT2 C INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKAP COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD, .ALPA COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS * COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) * COMMON/ALLAX/FA1,FA9,ALPAX * COMMON/OOM/ INA,IPV,IOFF C DIMENSION FUN(12),FUNX(12),AMSIG(2),ASIG(2),AMVEC(2),AVEC(2) COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) COMMON/PSBE/ .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4) CHARACTER *4 NTYPM(4,4) DATA NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','OM ','PHI ', .'DE ','KAP ','EPS ','S* ','A2 ','K** ','POM ','POMP'/ C DATA IKARO/1/,IKAOM/1/,IKAPH/1/,IKAKS/1/,IKADE/1/,IKAEP/1/, . IKAST/1/,IKAKSC/1/,IKAA2/1/,IKAPOM/1/,IKAKSS/1/, . IETKSC/1/,IETPKP/1/,IETAKS/1/,IETPKS/1/,IEPEP/0/ C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,DAM/230.D0/ * DATA AMPRO/1138.2796D0/,AMRO/760.D0/,AMEPS/760.D0/ DATA N3/27/,ICALL/0/,ISFAC/1/,NSCHR/1/ SAVE AMN,FACT,FACT2,FACT3,ISFLL,ISFLS,ISFSS C CALL ERRSET(208,256,-1,1) C pim=pim0 * pim=500.d0 IF(ICALL.EQ.0) THEN AMN = AMPRO FACT = PIM0/2.D0 * FACT2= 0.25D0*FACT*(PIM0/AMN)**2 * FACT3=0.5D0*FACT2 FACT2= 0.5D0*FACT*(PIM0/AMN)**2 FACT3= 0.5D0*FACT2 IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 ISFLL=(1+ISFAC)/2 ISFLS=(3-ISFAC) ISFSS=(9+ISFAC)/2 PRINT 52, INA,IPV,IOFF,IKARO,IKAOM,IKAPH,IKAKS, . IKADE,IKAEP,IKAST,IKAKSC,IKAA2,IKAPOM,IKAKSS, . IETKSC,IETPKP,IETAKS,IETPKS 52 FORMAT(//,' IN YNPSBE: INA,IPV,IOFF=',3I3,//, . 11X,' IKARO,IKAOM,IKAPH,IKAKS=',4I2,//, . 11X,' IKADE,IKAEP,IKAST,IKAKSC=',4I2,//, . 11X,' IPIA2,IPIPOM,IPIKSS=',3I2,//, . 11X,' IETKSC,IETPKP,IETAKS,IETPKS=',4I2,//) PRINT 53, ALMP1,ALMV1,ALMS1,ALMP8,ALMV8,ALMS8,PIM,DAM 53 FORMAT(/,' IN YNPSBE: ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=', . D10.3,/,11X,' ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',D10.3,/, . 11X,' PIM =',F10.3,' DAM =',F10.3,/) ** ICALL=1 ENDIF C XI-COUPLINGS: XF12 = F1*(4*ALP-1.D0)/SR3 XF13 = -F1 XFD12= FD1*(4*ALVD-1.D0)/SR3 XFD13= -FD1 XFV12= FV1*(4*ALVV-1.D0)/SR3 XFV13= -FV1 XGS12= GS1*(4*ALS-1.D0)/SR3 XGS13= -GS1 XGD12= GD1*(4*ALD-1.D0)/SR3 XGD13= -GD1 C C CONSTRUCTION OF THE POTENTIALS C * DO 1 I=2,NMAX * X = XA(I) c VCNN =0.D0 c VSNN =0.D0 c VCLL =0.D0 c VCLS =0.D0 c VCSS =0.D0 c VCDR =0.D0 c VSLL =0.D0 c VSLS =0.D0 c VSSS =0.D0 c VSDR =0.D0 c VTLL =0.D0 c VTLS =0.D0 c VTSS =0.D0 c VTDR =0.D0 c VOLL =0.D0 c VOLS =0.D0 c VOSS =0.D0 c VODR =0.D0 c VALL =0.D0 c VALS =0.D0 c VASS =0.D0 c VADR =0.D0 C 1/M-CORRECTIONS: IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) .CALL OMPSBE(X,INA,IPV,IOFF,APV) IF(INA.EQ.1.AND.IEPEP.NE.0) CALL OMSCDF(X,INA) C A) PSEUDO-SCALAR-VECTOR-MESON POTENTIALS: ********************** C DO 100 II=1,12 IF(II.LE.4) M=2 IF(II.GE.5.and.II.LE.8) M=3 IF(II.GE.9.and.II.LE.12) M=4 DO 101 IVV=1,4 GOTO(1,2,3,4,5,6,7,8,9,10,11,12), II C KA-RHO: 1 N = 1 PEX= P CALL YNFUN(1,X,AMK,AMRO,ALMKA,ALMV8,FUN) ** CALL YNFUN2(1,X,AMK,AMRO,ALMKA,ALMV8,DAM,1,FUN) C EE-TERMS: IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 6*FD1*FD3*F4*F5 CPALS = +2*SR3*FD1*FD2*F4*F5-SR3*FD1*FD3*(F4**2-F5**2) CPASS = 6*FD1*FD3*F4*F5+4*FD1*FD2*F5**2 CPADR = 4*FD1*FD2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(FD1**2*F4**2+FD3**2*F5**2) CCRLS = SR3*(FD1**2*F4*F5-FD3**2*F4*F5+2*FD2*FD3*F5**2) CCRSS = 5*FD1**2*F5**2+FD3**2*F4**2+4*FD2*FD3*F4*F5 CCRDR = 2*FD1**2*F5**2+FD3**2*F4**2 . +3*FD2**2*F5**2-2*FD2*FD3*F4*F5 ENDIF IF(IVV.EQ.2) THEN C 1/M^2-TERMS: FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 6*FVE1*FVE3*F4*F5 CPALS = +2*SR3*FVE1*FVE2*F4*F5-SR3*FVE1*FVE3*(F4**2-F5**2) CPASS = 6*FVE1*FVE3*F4*F5+4*FVE1*FVE2*F5**2 CPADR = 4*FVE1*FVE2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(FVE1**2*F4**2+FVE3**2*F5**2) CCRLS = SR3*(FVE1**2*F4*F5-FVE3**2*F4*F5+2*FVE2*FVE3*F5**2) CCRSS = 5*FVE1**2*F5**2+FVE3**2*F4**2+4*FVE2*FVE3*F4*F5 CCRDR = 2*FVE1**2*F5**2+FVE3**2*F4**2+ . 3*FVE2**2*F5**2-2*FVE2*FVE3*F4*F5 ENDIF C EM-CONTRIBUTIONS: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 ENDIF IF(IVV.EQ.4) THEN FVE1 = FD1+2*FV1 FVE2 = FD2+2*FV2 FVE3 = FD3+2*FV3 ENDIF C PARALLEL: CPANN = 0.D0 CPALL = 6*(FVE1*FD3+FD1*FVE3)*F4*F5 CPALS = +2*SR3*FVE1*FD2*F4*F5-SR3*FVE1*FD3*(F4**2-F5**2) . +2*SR3*FVE2*FD1*F4*F5-SR3*FVE3*FD1*(F4**2-F5**2) CPASS = 6*FVE1*FD3*F4*F5+4*FVE1*FD2*F5**2 . +6*FVE3*FD1*F4*F5+4*FVE2*FD1*F5**2 CPADR = 4*(FVE1*FD2+FVE2*FD1)*F5**2 CPALLM = 6*(FVE1*FD3-FD1*FVE3)*F4*F5 C CROSSED: CCRNN = 0.D0 CCRLL = 6*(FVE1*FD1*F4**2+FVE3*FD3*F5**2) CCRLS = SR3*(FVE1*FD1*F4*F5-FVE3*FD3*F4*F5+2*FVE2*FD3*F5**2) . +SR3*(FVE1*FD1*F4*F5-FVE3*FD3*F4*F5+2*FVE3*FD2*F5**2) CCRSS = 5*FVE1*FD1*F5**2+FVE3*FD3*F4**2+4*FVE2*FD3*F4*F5 . +5*FVE1*FD1*F5**2+FVE3*FD3*F4**2+4*FVE3*FD2*F4*F5 CCRDR = (2*FVE1*FD1*F5**2+FVE3*FD3*F4**2)*2 . +6*FVE2*FD2*F5**2-2*(FVE2*FD3+FVE3*FD2)*F4*F5 CCRLLM = 6*(FVE1*FD1*F4**2-FVE3*FD3*F5**2) ENDIF GOTO 102 C END KAON-RHO C C KAON-OMEGA EXCHANGE POTENTIALS: 3 N = 3 PEX= P CALL YNFUN(1,X,AMK,AMOM,ALMKA,ALMV1,FUN) ** CALL YNFUN2(1,X,AMK,AMOM,ALMKA,ALMV1,DAM,1,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*FD6*FD7*F4**2 CPALS = -SR3*FD6*(FD7+FD8)*F4*F5 CPASS = -2*FD6*FD8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FD6**2+FD7**2)*F4**2 CCRLS = -SR3*(FD6**2+FD7*FD8)*F4*F5 CCRSS = -(FD6**2+FD8**2)*F5**2 CCRDR = -2*CCRSS ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 2*FVE6*FVE7*F4**2 CPALS = -SR3*FVE6*(FVE7+FVE8)*F4*F5 CPASS = -2*FVE6*FVE8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FVE6**2+FVE7**2)*F4**2 CCRLS = -SR3*(FVE6**2+FVE7*FVE8)*F4*F5 CCRSS = -(FVE6**2+FVE8**2)*F5**2 CCRDR = -2*CCRSS ENDIF C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 ENDIF IF(IVV.EQ.4) THEN FVE6 = FD6+2*FV6 FVE7 = FD7+2*FV7 FVE8 = FD8+2*FV8 ENDIF c PARALLEL: CPANN = 0.D0 CPALL = 2*(FVE6*FD7+FVE7*FD6)*F4**2 CPALS = -SR3*FVE6*(FD7+FD8)*F4*F5 . -SR3*FD6*(FVE7+FVE8)*F4*F5 CPASS = -2*(FVE6*FD8+FVE8*FD6)*F5**2 CPADR = -2*CPASS CPALLM = 2*(FVE6*FD7-FVE7*FD6)*F4**2 C CROSSED: CCRNN = 0.D0 CCRLL = 2*(FVE6*FD6+FVE7*FD7)*F4**2 CCRLS = -SR3*(2*FVE6*FD6+FVE7*FD8+FVE8*FD7)*F4*F5 CCRSS = -2*(FVE6*FD6+FVE8*FD8)*F5**2 CCRDR = -2*CCRSS CCRLLM = 2*(FVE6*FD6-FVE7*FD7)*F4**2 ENDIF GOTO 102 C END KAON-OMEGA C KAON-PHI EXCHANGE POTENTIALS: 4 N = 4 PEX= P CALL YNFUN(1,X,AMK,AMFI,ALMKA,ALMV8,FUN) ** CALL YNFUN2(1,X,AMK,AMFI,ALMKA,ALMV8,DAM,1,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*FD9*FD10*F4**2 CPALS = -SR3*FD9*(FD10+FD11)*F4*F5 CPASS = -2*FD9*FD11*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FD9**2+FD10**2)*F4**2 CCRLS = -SR3*(FD9**2+FD10*FD11)*F4*F5 CCRSS = -(FD9**2+FD11**2)*F5**2 CCRDR = -2*CCRSS ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 2*FVE9*FVE10*F4**2 CPALS = -SR3*FVE9*(FVE10+FVE11)*F4*F5 CPASS = -2*FVE9*FVE11*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FVE9**2+FVE10**2)*F4**2 CCRLS = -SR3*(FVE9**2+FVE10*FVE11)*F4*F5 CCRSS = -(FVE9**2+FVE11**2)*F5**2 CCRDR = -2*CCRSS ENDIF C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 ENDIF IF(IVV.EQ.4) THEN FVE9 = FD9+2*FV9 FVE10= FD10+2*FV10 FVE11= FD11+2*FV11 ENDIF C PARALLEL: CPANN = 0.D0 CPALL = 2*(FVE9*FD10+FVE10*FD9)*F4**2 CPALS = -SR3*FVE9*(FD10+FD11)*F4*F5 . -SR3*FD9*(FVE10+FVE11)*F4*F5 CPASS = -2*(FVE9*FD11+FVE11*FD9)*F5**2 CPADR = -2*CPASS CPALLM = 2*(FVE9*FD10-FVE10*FD9)*F4**2 C CROSSED: CCRNN = 0.D0 CCRLL = 2*(FVE9*FD9+FVE10*FD10)*F4**2 CCRLS = -SR3*(2*FVE9*FD9+FVE10*FD11+FVE11*FD10)*F4*F5 CCRSS = -2*(FVE9*FD9+FVE11*FD11)*F5**2 CCRDR = -2*CCRSS CCRLLM = 2*(FVE9*FD9-FVE10*FD10)*F4**2 ENDIF GOTO 102 C END KAON-PHI C KAON-KSTAR EXCHANGE POTENTIALS: 2 N = 2 PEX= 1.D0 CALL YNFUN(1,X,AMK,AMKS,ALMKA,ALMKS,FUN) * CALL YNFUN3(1,1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUN) * CALL YNFUN3(2,1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUNX) * FUN(11) = FUNX(1) * FUN(12) = FUNX(2) ** CALL DKBFUN(1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*(FD4**2*F4**2+3*FD4*FD5*F4*F5) CPALS = SR3*(FD5**2*F4*F5+FD4*FD5*F5**2 . -FD4**2*F4*F5-FD4*FD5*F4**2) CPASS = 2*(3*FD4*FD5*F4*F5+FD5**2*F5**2) CPADR = 8*FD5**2*F5**2 C CROSSED: * CCRNN = 2*(ISFLL*FD4**2*F4**2+ISFLS*FD4*FD5*F4*F5+ * . ISFSS*FD5**2*F5**2) CCRNN = (FD4*F4+3*FD5*F5)**2+ISFAC*(FD4*F4-FD5*F5)**2 CCRLL = +2*(FD4*XFD12*F4*XF12+3*FD5*XFD12*F5*XF12) CCRLS = SR3*(FD4*F4-FD5*F5)*(XFD13*XF12+XFD12*XF13) CCRSS = -2*FD4*XFD13*F4*XF13+10*FD5*XFD13*F5*XF13 CCRDR = +4*FD5*F5*XFD13*XF13 + 4*FD4*F4*XFD13*XF13 ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 FVE12= XFD12+XFV12 FVE13= XFD13+XFV13 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 2*(FVE4**2*F4**2+3*FVE4*FVE5*F4*F5) CPALS = SR3*(FVE5**2*F4*F5+FVE4*FVE5*F5**2 . -FVE4**2*F4*F5-FVE4*FVE5*F4**2) CPASS = 2*(3*FVE4*FVE5*F4*F5+FVE5**2*F5**2) CPADR = 8*FVE5**2*F5**2 C CROSSED: * CCRNN = 2*(isfll*fve4**2*f4**2+isfls*fve4*fve5*f4*f5+ * . isfss*fve5**2*f5**2) CCRNN = (FVE4*F4+3*FVE5*F5)**2+ISFAC*(FVE4*F4-FVE5*F5)**2 CCRLL = +2*(FVE4*FVE12*F4*XF12+3*FVE5*FVE12*F5*XF12) CCRLS = +SR3*(FVE4*F4-FVE5*F5)*(FVE13*XF12+FVE12*XF13) CCRSS = -2*FVE4*FVE13*F4*XF13+10*FVE5*FVE13*F5*XF13 CCRDR = +4*FVE5*FVE13*F5*XF13 +4*FVE4*F4*FVE13*XF13 ENDIF C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.4) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 FVE12= XFD12+XFV12 FVE13= XFD13+XFV13 ENDIF IF(IVV.EQ.4) THEN FVE4 = FD4+2*FV4 FVE5 = FD5+2*FV5 FVE12= XFD12+2*XFV12 FVE13= XFD13+2*XFV13 ENDIF C PARALLEL: CPANN = 0.D0 CPALL = 2*(2*FVE4*FD4*F4**2+3*(FVE4*FD5+FVE5*FD4)*F4*F5) CPALS = SR3*(2*FVE5*FD5*F4*F5+(FVE4*FD5+FD4*FVE5)*F5**2 . -2*FVE4*FD4*F4*F5-(FVE4*FD5+FVE5*FD4)*F4**2) CPASS = 2*(3*(FVE4*FD5+FD4*FVE5)*F4*F5+2*FVE5*FD5*F5**2) CPADR = 16*FVE5*FD5*F5**2 CPALLM = 2*(3*(FVE4*FD5-FVE5*FD4)*F4*F5) C CROSSED: * CCRNN = 2*(2*isfll*fve4*fd4*f4**2+isfls*(fve4*fd5+fd4*fve5)* * . f4*f5+2*isfss*fve5*fd5*f5**2) CCRNN = (FVE4*F4+3*FVE5*F5)*(FD4*F4+3*FD5*F5)*2 . +ISFAC*(FVE4*F4-FVE5*F5)*(FD4*F4-FD5*F5)*2 CCRLL = +2*(FD4*FVE12*F4*XF12+3*FD5*FVE12*F5*XF12) . +2*(FVE4*XFD12*F4*XF12+3*FVE5*XFD12*F5*XF12) CCRLS = +SR3*(FVE4*F4-FVE5*F5)*(XFD13*XF12+XFD12*XF13) . +SR3*(FD4*F4-FD5*F5)*(FVE13*XF12+FVE12*XF13) CCRSS = -2*FVE4*XFD13*F4*XF13+10*FVE5*XFD13*F5*XF13 . -2*FD4*FVE13*F4*XF13+10*FD5*FVE13*F5*XF13 CCRDR = +4*(FVE4*XFD13+FD4*FVE13)*F4*XF13 . +4*(FVE5*XFD13+FD5*FVE13)*F5*XF13 CCRLLM = +2*(FVE4*XFD12*F4*XF12-3*FVE5*XFD12*F5*XF12) ENDIF GOTO 102 C END KAON-KSTAR C ETA-RHO EXCHANGE POTENTIALS: 5 N = 1 PEX= 1.D0 CALL YNFUN(1,X,AME,AMRO,ALMP8,ALMV8,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*ISFAC*FD1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*FD1*FD3*F6*(F7+F8) CPASS = -4*FD1*FD2*F6*F8 CPADR = +2*FD1*F6*FD2*F8 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*ISFAC*FVE1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*FVE1*FVE3*F6*(F7+F8) CPASS = -4*FVE1*FVE2*F6*F8 CPADR = +2*FVE1*F6*FVE2*F8 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 ENDIF IF(IVV.EQ.4) THEN FVE1 = FD1+2*FV1 FVE2 = FD2+2*FV2 FVE3 = FD3+2*FV3 ENDIF C PARALLEL: CPANN = 4*ISFAC*FVE1*FD1*F6**2 CPALL = 0.D0 CPALS = -SR3*(FVE1*FD3+FVE3*FD1)*F6*(F7+F8) CPASS = -4*(FVE1*FD2+FVE2*FD1)*F6*F8 CPADR = +2*(FVE1*FD2+FVE2*FD1)*F6*F8 CPALLM = 0D0 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = 0D0 ENDIF GOTO 102 C ETA-KSTAR EXCHANGE POTENTIALS: 6 N = 2 PEX= P CALL YNFUN(1,X,AME,AMKS,ALMP8,ALMKS,FUN) ** CALL YNFUN2(1,X,AME,AMKS,ALMP8,ALMKS,DAM,2,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*FD4**2*F6*F7 CPALS = -SR3*FD4*FD5*F6*(F7+F8) CPASS = -2*FD5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FD4**2*(F6**2+F7**2) CCRLS = -SR3*FD4*FD5*(F6**2+F7*F8) CCRSS = -FD5**2*(F6**2+F8**2) CCRDR = -2*CCRSS ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 2*FVE4**2*F6*F7 CPALS = -SR3*FVE4*FVE5*F6*(F7+F8) CPASS = -2*FVE5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FVE4**2*(F6**2+F7**2) CCRLS = -SR3*FVE4*FVE5*(F6**2+F7*F8) CCRSS = -FVE5**2*(F6**2+F8**2) CCRDR = -2*CCRSS ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 ENDIF IF(IVV.EQ.4) THEN FVE4 = FD4+2*FV4 FVE5 = FD5+2*FV5 ENDIF C PARALLEL: CPANN = 0.D0 CPALL = 4*FVE4*FD4*F6*F7 CPALS = -SR3*(FVE4*FD5+FD4*FVE5)*F6*(F7+F8) CPASS = -4*FVE5*FD5*F6*F8 CPADR = -2*CPASS CPALLM = 0D0 C CROSSED: CCRNN = 0.D0 CCRLL = 2*FVE4*FD4*(F6**2+F7**2) CCRLS = -SR3*(FVE4*FD5+FD4*FVE5)*(F6**2+F7*F8) CCRSS = -2*FVE5*FD5*(F6**2+F8**2) CCRDR = -2*CCRSS CCRLLM = 0D0 ENDIF GOTO 102 C END ETA-KSTAR C ETA-OM EXCHANGE POTENTIALS: 7 N = 3 PEX= 1.D0 CALL YNFUN(1,X,AME,AMOM,ALMP8,ALMV1,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*FD6**2*F6**2 CPALL = 2*FD6*FD7*F6*F7 CPALS = 0.D0 CPASS = 2*FD6*FD8*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*FVE6**2*F6**2 CPALL = 2*FVE6*FVE7*F6*F7 CPALS = 0.D0 CPASS = 2*FVE6*FVE8*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 ENDIF IF(IVV.EQ.4) THEN FVE6 = FD6+2*FV6 FVE7 = FD7+2*FV7 FVE8 = FD8+2*FV8 ENDIF C PARALLEL: CPANN = 4*FVE6*FD6*F6**2 CPALL = 2*(FVE6*FD7+FVE7*FD6)*F6*F7 CPALS = 0.D0 CPASS = 2*(FVE6*FD8+FVE8*FD7)*F6*F8 CPADR = CPASS CPALLM = 2*(FVE6*FD7-FVE7*FD6)*F6*F7 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = CPALLM ENDIF GOTO 102 C ETA-PHI EXCHANGE POTENTIALS: 8 N = 4 PEX= 1.D0 CALL YNFUN(1,X,AME,AMFI,ALMP8,ALMV8,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*FD9**2*F6**2 CPALL = 2*FD9*FD10*F6*F7 CPALS = 0.D0 CPASS = 2*FD9*FD11*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*FVE9**2*F6**2 CPALL = 2*FVE9*FVE10*F6*F7 CPALS = 0.D0 CPASS = 2*FVE9*FVE11*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 ENDIF IF(IVV.EQ.4) THEN FVE9 = FD9+2*FV9 FVE10= FD10+2*FV10 FVE11= FD11+2*FV11 ENDIF C PARALLEL: CPANN = 4*FVE9*FD9*F6**2 CPALL = 2*(FVE9*FD10+FVE10*FD9)*F6*F7 CPALS = 0.D0 CPASS = 2*(FVE9*FD11+FVE11*FD9)*F6*F8 CPADR = CPASS CPALLM = 2*(FVE9*FD10-FVE10*FD9)*F6*F7 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = CPALLM ENDIF GOTO 102 C ETAP-RHO EXCHANGE POTENTIALS: 9 N = 1 PEX= 1.D0 CALL YNFUN(1,X,AMX,AMRO,ALMP1,ALMV8,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*ISFAC*FD1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*FD1*FD3*F9*(F10+F11) CPASS = -4*FD1*FD2*F9*F11 CPADR = +2*FD1*F9*FD2*F11 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*ISFAC*FVE1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*FVE1*FVE3*F9*(F11+F11) CPASS = -4*FVE1*FVE2*F9*F11 CPADR = +2*FVE1*F9*FVE2*F11 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE1 = FD1+FV1 FVE2 = FD2+FV2 FVE3 = FD3+FV3 ENDIF IF(IVV.EQ.4) THEN FVE1 = FD1+2*FV1 FVE2 = FD2+2*FV2 FVE3 = FD3+2*FV3 ENDIF C PARALLEL: CPANN = 4*ISFAC*FVE1*FD1*F9**2 CPALL = 0.D0 CPALS = -SR3*(FVE1*FD3+FVE3*FD1)*F9*(F10+F11) CPASS = -4*(FVE1*FD2+FVE2*FD1)*F9*F11 CPADR = +2*(FVE1*FD2+FVE2*FD1)*F9*F11 CPALLM = 0D0 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = 0D0 ENDIF GOTO 102 C ETAP-KSTAR EXCHANGE POTENTIALS: 10 N = 2 PEX= P CALL YNFUN(1,X,AMX,AMKS,ALMP1,ALMKS,FUN) c* CALL YNFUN2(1,X,AMX,AMKS,ALMP1,ALMKS,DAM,2,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*FD4**2*F9*F10 CPALS = -SR3*FD4*FD5*F9*(F10+F11) CPASS = -2*FD5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FD4**2*(F9**2+F10**2) CCRLS = -SR3*FD4*FD5*(F9**2+F10*F11) CCRSS = -FD5**2*(F9**2+F11**2) CCRDR = -2*CCRSS ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 C MM-CONTRIBUTION: C PARALLEL: CPANN = 0.D0 CPALL = 2*FVE4**2*F9*F10 CPALS = -SR3*FVE4*FVE5*F9*(F10+F11) CPASS = -2*FVE5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FVE4**2*(F9**2+F10**2) CCRLS = -SR3*FVE4*FVE5*(F9**2+F10*F11) CCRSS = -FVE5**2*(F9**2+F11**2) CCRDR = -2*CCRSS ENDIF C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.4) THEN FVE4 = FD4+FV4 FVE5 = FD5+FV5 ENDIF IF(IVV.EQ.4) THEN FVE4 = FD4+2*FV4 FVE5 = FD5+2*FV5 ENDIF C PARALLEL: CPANN = 0.D0 CPALL = 4*FVE4*FD4*F9*F10 CPALS = -SR3*(FVE4*FD5+FD4*FVE5)*F9*(F10+F11) CPASS = -4*FVE5*FD5*F9*F11 CPADR = -2*CPASS CPALLM = 0D0 C CROSSED: CCRNN = 0.D0 CCRLL = 2*FVE4*FD4*(F9**2+F10**2) CCRLS = -SR3*(FVE4*FD5+FD4*FVE5)*(F9**2+F10*F11) CCRSS = -2*FVE5*FD5*(F9**2+F11**2) CCRDR = -2*CCRSS CCRLLM = 0D0 ENDIF GOTO 102 C END ETAP-KSTAR C ETAP-OM EXCHANGE POTENTIALS: 11 N = 3 PEX = 1.D0 CALL YNFUN(1,X,AMX,AMOM,ALMP1,ALMV1,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*FD6**2*F9**2 CPALL = 2*FD6*FD7*F9*F10 CPALS = 0.D0 CPASS = 2*FD6*FD8*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*FVE6**2*F9**2 CPALL = 2*FVE6*FVE7*F9*F10 CPALS = 0.D0 CPASS = 2*FVE6*FVE8*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE6 = FD6+FV6 FVE7 = FD7+FV7 FVE8 = FD8+FV8 ENDIF IF(IVV.EQ.4) THEN FVE6 = FD6+2*FV6 FVE7 = FD7+2*FV7 FVE8 = FD8+2*FV8 ENDIF C PARALLEL: CPANN = 4*FVE6*FD6*F9**2 CPALL = 2*(FVE6*FD7+FVE7*FD6)*F9*F10 CPALS = 0.D0 CPASS = 2*(FVE6*FD8+FVE8*FD7)*F9*F11 CPADR = CPASS CPALLM = 2*(FVE6*FD7-FVE7*FD6)*F9*F10 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = CPALLM ENDIF GOTO 102 C ETAP-PHI EXCHANGE POTENTIALS: 12 N = 4 PEX = 1.D0 CALL YNFUN(1,X,AMX,AMFI,ALMP1,ALMV8,FUN) IF(IVV.EQ.1) THEN C PARALLEL: CPANN = 2*FD9**2*F9**2 CPALL = 2*FD9*FD10*F9*F10 CPALS = 0.D0 CPASS = 2*FD9*FD11*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C 1/M^2-TERMS: IF(IVV.EQ.2) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 C MM-CONTRIBUTION: C PARALLEL: CPANN = 2*FVE9**2*F9**2 CPALL = 2*FVE9*FVE10*F9*F10 CPALS = 0.D0 CPASS = 2*FVE9*FVE11*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR ENDIF C C EM-CONTRIBUTION: IF(IVV.GE.3) THEN IF(IVV.EQ.3) THEN FVE9 = FD9+FV9 FVE10= FD10+FV10 FVE11= FD11+FV11 ENDIF IF(IVV.EQ.4) THEN FVE9 = FD9+2*FV9 FVE10= FD10+2*FV10 FVE11= FD11+2*FV11 ENDIF C PARALLEL: CPANN = 4*FVE9*FD9*F9**2 CPALL = 2*(FVE9*FD10+FVE10*FD9)*F9*F10 CPALS = 0.D0 CPASS = 2*(FVE9*FD11+FVE11*FD9)*F9*F11 CPADR = CPASS CPALLM = 2*(FVE9*FD10-FVE10*FD9)*F9*F10 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CCRLLM = CPALLM ENDIF GOTO 102 102 IF(IVV.EQ.1) THEN VPSVC(1,2,M,N)= .VPSVC(1,2,M,N) + FACT*( CPANN*FUN(1) - CCRNN*FUN(11))*PEX VPSVC(2,2,M,N)= .VPSVC(2,2,M,N) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11))*PEX VPSVC(3,2,M,N)= .VPSVC(3,2,M,N) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11))*PEX VPSVC(4,2,M,N)= .VPSVC(4,2,M,N) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11))*PEX VPSVC(5,2,M,N)= .VPSVC(5,2,M,N) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11))*PEX VPSVC(1,3,M,N)= .VPSVC(1,3,M,N) + FACT*( CPANN*FUN(2) - CCRNN*FUN(12))*PEX VPSVC(2,3,M,N)= .VPSVC(2,3,M,N) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12))*PEX VPSVC(3,3,M,N)= .VPSVC(3,3,M,N) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12))*PEX VPSVC(4,3,M,N)= .VPSVC(4,3,M,N) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12))*PEX VPSVC(5,3,M,N)= .VPSVC(4,3,M,N) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12))*PEX ENDIF IF(IVV.EQ.2) THEN VPSVC(1,1,M,N)=VPSVC(1,1,M,N)+FACT2*(CPANN-CCRNN)*FUN(5)*PEX VPSVC(2,1,M,N)=VPSVC(2,1,M,N)+FACT2*(CPALL-CCRLL)*FUN(5)*PEX VPSVC(3,1,M,N)=VPSVC(3,1,M,N)+FACT2*(CPALS-CCRLS)*FUN(5)*PEX VPSVC(4,1,M,N)=VPSVC(4,1,M,N)+FACT2*(CPASS-CCRSS)*FUN(5)*PEX VPSVC(5,1,M,N)=VPSVC(5,1,M,N)+FACT2*(CPADR-CCRDR)*FUN(5)*PEX VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+FACT2*(CPANN+CCRNN)*FUN(6)*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+FACT2*(CPALL+CCRLL)*FUN(6)*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+FACT2*(CPALS+CCRLS)*FUN(6)*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+FACT2*(CPASS+CCRSS)*FUN(6)*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+FACT2*(CPADR+CCRDR)*FUN(6)*PEX VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT2*(CPANN+CCRNN)*FUN(7)*PEX VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT2*(CPALL+CCRLL)*FUN(7)*PEX VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT2*(CPALS+CCRLS)*FUN(7)*PEX VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT2*(CPASS+CCRSS)*FUN(7)*PEX VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT2*(CPADR+CCRDR)*FUN(7)*PEX ENDIF IF(IVV.EQ.3) THEN VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT3*(CPANN+CCRNN)*FUN(3)*PEX VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT3*(CPALL+CCRLL)*FUN(3)*PEX VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT3*(CPALS+CCRLS)*FUN(3)*PEX VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT3*(CPASS+CCRSS)*FUN(3)*PEX VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT3*(CPADR+CCRDR)*FUN(3)*PEX VPSVC(1,4,M,N)=VPSVC(1,4,M,N)+FACT3*(CPANN-CCRNN)*FUN(4)*PEX VPSVC(2,4,M,N)=VPSVC(2,4,M,N)+FACT3*(CPALL-CCRLL)*FUN(4)*PEX VPSVC(3,4,M,N)=VPSVC(3,4,M,N)+FACT3*(CPALS-CCRLS)*FUN(4)*PEX VPSVC(4,4,M,N)=VPSVC(4,4,M,N)+FACT3*(CPASS-CCRSS)*FUN(4)*PEX VPSVC(5,4,M,N)=VPSVC(5,4,M,N)+FACT3*(CPADR-CCRDR)*FUN(4)*PEX VPSVC(2,5,M,N)=VPSVC(2,5,M,N)-FACT3*(CPALLM-CCRLLM)*FUN(4)*PEX ENDIF IF(IVV.EQ.4) THEN VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+FACT3*(CPANN-CCRNN)*FUN(8)*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+FACT3*(CPALL-CCRLL)*FUN(8)*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+FACT3*(CPALS-CCRLS)*FUN(8)*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+FACT3*(CPASS-CCRSS)*FUN(8)*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+FACT3*(CPADR-CCRDR)*FUN(8)*PEX VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT3*(CPANN-CCRNN)*FUN(9)*PEX VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT3*(CPALL-CCRLL)*FUN(9)*PEX VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT3*(CPALS-CCRLS)*FUN(9)*PEX VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT3*(CPASS-CCRSS)*FUN(9)*PEX VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT3*(CPADR-CCRDR)*FUN(9)*PEX VPSVC(1,4,M,N)=VPSVC(1,4,M,N)+FACT3*(CPANN-CCRNN)*FUN(10)*PEX VPSVC(2,4,M,N)=VPSVC(2,4,M,N)+FACT3*(CPALL-CCRLL)*FUN(10)*PEX VPSVC(3,4,M,N)=VPSVC(3,4,M,N)+FACT3*(CPALS-CCRLS)*FUN(10)*PEX VPSVC(4,4,M,N)=VPSVC(4,4,M,N)+FACT3*(CPASS-CCRSS)*FUN(10)*PEX VPSVC(5,4,M,N)=VPSVC(5,4,M,N)+FACT3*(CPADR-CCRDR)*FUN(10)*PEX VPSVC(2,5,M,N)=VPSVC(2,5,M,N)-FACT3*(CPALLM-CCRLLM)*FUN(10)*PEX ENDIF write(*,*) 'm,n=',m,n,' vpsvc(2,4,m,n)=',vpsvc(2,4,m,n), .' vpsvc(2,5,m,n)=',vpsvc(2,5,m,n) 101 CONTINUE 100 CONTINUE C TOTAL CONTRIBUTIONS: DO 20 IPS=1,4 DO 20 IMES=1,4 VCNN = VCNN + VPSVC(1,1,IPS,IMES) VCLL = VCLL + VPSVC(2,1,IPS,IMES) VCLS = VCLS + VPSVC(3,1,IPS,IMES) VCSS = VCSS + VPSVC(4,1,IPS,IMES) VCDR = VCDR + VPSVC(5,1,IPS,IMES) VSNN = VSNN + VPSVC(1,2,IPS,IMES) VSLL = VSLL + VPSVC(2,2,IPS,IMES) VSLS = VSLS + VPSVC(3,2,IPS,IMES) VSSS = VSSS + VPSVC(4,2,IPS,IMES) VSDR = VSDR + VPSVC(5,2,IPS,IMES) VTNN = VTNN + VPSVC(1,3,IPS,IMES) VTLL = VTLL + VPSVC(2,3,IPS,IMES) VTLS = VTLS + VPSVC(3,3,IPS,IMES) VTSS = VTSS + VPSVC(4,3,IPS,IMES) VTDR = VTDR + VPSVC(5,3,IPS,IMES) VONN = VONN + VPSVC(1,4,IPS,IMES) VOLL = VOLL + VPSVC(2,4,IPS,IMES) VOLS = VOLS + VPSVC(3,4,IPS,IMES) VOSS = VOSS + VPSVC(4,4,IPS,IMES) VODR = VODR + VPSVC(5,4,IPS,IMES) VALL = VALL + VPSVC(2,5,IPS,IMES) ! VSOA c nog te doen: c VALS = VALS + VPSVC(3,5,IPS,IMES) ! VSOA c VASS = VASS + VPSVC(4,5,IPS,IMES) ! VSOA c VADR = VADR + VPSVC(5,5,IPS,IMES) ! VSOA 20 CONTINUE C END VECTOR MESONS c if(icall.eq.0.and.nschr.eq.1) call writetm(5,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(5,x,p) C C B) KAON-SCALAR MESONS: ***************************************** C RATOSA = 0.5D0*(AMN**2-AMLN**2)/AMN/AMLN ratosa = 0d0 C KAON-DELTA EXCHANGE POTENTIALS: IF(IKADE.EQ.1) THEN C PARALLEL: CPALL = 6*GS1*GS3*F4*F5 CPALS = +2*SR3*GS1*GS2*F4*F5-SR3*GS1*GS3*(F4**2-F5**2) CPASS = 6*GS1*GS3*F4*F5+4*GS1*GS2*F5**2 CPADR = 4*GS1*GS2*F5**2 C CROSSED: CCRLL = 3*(GS1**2*F4**2+GS3**2*F5**2) CCRLS = SR3*(GS1**2*F4*F5-GS3**2*F4*F5+2*GS2*GS3*F5**2) CCRSS = 5*GS1**2*F5**2+GS3**2*F4**2+4*GS2*GS3*F4*F5 CCRDR = 2*GS1**2*F5**2+GS3**2*F4**2 . +3*GS2**2*F5**2-2*GS2*GS3*F4*F5 CALL YNFUN(2,X,AMK,AMD,ALMKA,ALMS8,FUN) c* CALL YNFUN2(2,X,AMK,AMD,ALMKA,ALMS8,DAM,1,FUN) VPSSC(2,2,2,1)=VPSSC(2,2,2,1)+FACT*(CPALL-CCRLL)*FUN(1)*P VPSSC(3,2,2,1)=VPSSC(3,2,2,1)+FACT*(CPALS-CCRLS)*FUN(1)*P VPSSC(4,2,2,1)=VPSSC(4,2,2,1)+FACT*(CPASS-CCRSS)*FUN(1)*P VPSSC(5,2,2,1)=VPSSC(5,2,2,1)+FACT*(CPADR-CCRDR)*FUN(1)*P VPSSC(2,3,2,1)=VPSSC(2,3,2,1)+FACT*(CPALL-CCRLL)*FUN(2)*P VPSSC(3,3,2,1)=VPSSC(3,3,2,1)+FACT*(CPALS-CCRLS)*FUN(2)*P VPSSC(4,3,2,1)=VPSSC(4,3,2,1)+FACT*(CPASS-CCRSS)*FUN(2)*P VPSSC(5,3,2,1)=VPSSC(5,3,2,1)+FACT*(CPADR-CCRDR)*FUN(2)*P VPSSC(2,4,2,1)=VPSSC(2,4,2,1)+FACT*(CPALL-CCRLL)*FUN(3)*P VPSSC(3,4,2,1)=VPSSC(3,4,2,1)+FACT*(CPALS-CCRLS)*FUN(3)*P VPSSC(4,4,2,1)=VPSSC(4,4,2,1)+FACT*(CPASS-CCRSS)*FUN(3)*P VPSSC(5,4,2,1)=VPSSC(5,4,2,1)+FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END KAON-DELTA C KAON-EPSILON1 EXCHANGE POTENTIALS: IF(IKAEP.EQ.1) THEN C PARALLEL: CPALL = 2*GS6*GS7*F4**2 CPALS = -SR3*GS6*(GS7+GS8)*F4*F5 CPASS = -2*GS6*GS8*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (GS6**2+GS7**2)*F4**2 CCRLS = -SR3*(GS6**2+GS7*GS8)*F4*F5 CCRSS = -(GS6**2+GS8**2)*F5**2 CCRDR = -2*CCRSS C KAON-EPSILON1 EXCHANGE POTENTIALS: CALL YNFUN(2,X,AMK,AM1SI,ALMKA,ALMS1,FUN) c* CALL YNFUN2(2,X,AMK,AM1SI,ALMKA,ALMS1,DAM,1,FUN) VPSSC(2,2,2,3)=VPSSC(2,2,2,3)+FACT*(CPALL-CCRLL)*FUN(1)*ASI*P VPSSC(3,2,2,3)=VPSSC(3,2,2,3)+FACT*(CPALS-CCRLS)*FUN(1)*ASI*P VPSSC(4,2,2,3)=VPSSC(4,2,2,3)+FACT*(CPASS-CCRSS)*FUN(1)*ASI*P VPSSC(5,2,2,3)=VPSSC(5,2,2,3)+FACT*(CPADR-CCRDR)*FUN(1)*ASI*P VPSSC(2,3,2,3)=VPSSC(2,3,2,3)+FACT*(CPALL-CCRLL)*FUN(2)*ASI*P VPSSC(3,3,2,3)=VPSSC(3,3,2,3)+FACT*(CPALS-CCRLS)*FUN(2)*ASI*P VPSSC(4,3,2,3)=VPSSC(4,3,2,3)+FACT*(CPASS-CCRSS)*FUN(2)*ASI*P VPSSC(5,3,2,3)=VPSSC(5,3,2,3)+FACT*(CPADR-CCRDR)*FUN(2)*ASI*P VPSSC(2,4,2,3)=VPSSC(2,4,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*ASI*P VPSSC(3,4,2,3)=VPSSC(3,4,2,3)+FACT*(CPALS-CCRLS)*FUN(3)*ASI*P VPSSC(4,4,2,3)=VPSSC(4,4,2,3)+FACT*(CPASS-CCRSS)*FUN(3)*ASI*P VPSSC(5,4,2,3)=VPSSC(5,4,2,3)+FACT*(CPADR-CCRDR)*FUN(3)*ASI*P VPSSC(2,5,2,3)=VPSSC(2,5,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*ASI*P .*RATOSA C END KAON-EPSILON1 C KAON-EPSILON2 EXCHANGE POTENTIALS: CALL YNFUN(2,X,AMK,AM2SI,ALMKA,ALMS1,FUN) c* CALL YNFUN2(2,X,AMK,AM2SI,ALMKA,ALMS1,DAM,1,FUN) VPSSC(2,2,2,3)=VPSSC(2,2,2,3)+FACT*(CPALL-CCRLL)*FUN(1)*BSI*P VPSSC(3,2,2,3)=VPSSC(3,2,2,3)+FACT*(CPALS-CCRLS)*FUN(1)*BSI*P VPSSC(4,2,2,3)=VPSSC(4,2,2,3)+FACT*(CPASS-CCRSS)*FUN(1)*BSI*P VPSSC(5,2,2,3)=VPSSC(5,2,2,3)+FACT*(CPADR-CCRDR)*FUN(1)*BSI*P VPSSC(2,3,2,3)=VPSSC(2,3,2,3)+FACT*(CPALL-CCRLL)*FUN(2)*BSI*P VPSSC(3,3,2,3)=VPSSC(3,3,2,3)+FACT*(CPALS-CCRLS)*FUN(2)*BSI*P VPSSC(4,3,2,3)=VPSSC(4,3,2,3)+FACT*(CPASS-CCRSS)*FUN(2)*BSI*P VPSSC(5,3,2,3)=VPSSC(5,3,2,3)+FACT*(CPADR-CCRDR)*FUN(2)*BSI*P VPSSC(2,4,2,3)=VPSSC(2,4,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*BSI*P VPSSC(3,4,2,3)=VPSSC(3,4,2,3)+FACT*(CPALS-CCRLS)*FUN(3)*BSI*P VPSSC(4,4,2,3)=VPSSC(4,4,2,3)+FACT*(CPASS-CCRSS)*FUN(3)*BSI*P VPSSC(5,4,2,3)=VPSSC(5,4,2,3)+FACT*(CPADR-CCRDR)*FUN(3)*BSI*P VPSSC(2,5,2,3)=VPSSC(2,5,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*BSI*P .*RATOSA ENDIF C END KAON-EPSILON2 C END KAON-EPSILON C KAON-SSTAR EXCHANGE POTENTIALS: IF(IKAST.EQ.1) THEN C PARALLEL: CPALL = 2*GS9*GS10*F4**2 CPALS = -SR3*GS9*(GS10+GS11)*F4*F5 CPASS = -2*GS9*GS11*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (GS9**2+GS10**2)*F4**2 CCRLS = -SR3*(GS9**2+GS10*GS11)*F4*F5 CCRSS = -(GS9**2+GS11**2)*F5**2 CCRDR = -2*CCRSS CALL YNFUN(2,X,AMK,AMSST,ALMKA,ALMS8,FUN) c* CALL YNFUN2(2,X,AMK,AMSST,ALMKA,ALMS8,DAM,1,FUN) VPSSC(2,2,2,4)=VPSSC(2,2,2,4)+FACT*(CPALL-CCRLL)*FUN(1)*P VPSSC(3,2,2,4)=VPSSC(3,2,2,4)+FACT*(CPALS-CCRLS)*FUN(1)*P VPSSC(4,2,2,4)=VPSSC(4,2,2,4)+FACT*(CPASS-CCRSS)*FUN(1)*P VPSSC(5,2,2,4)=VPSSC(5,2,2,4)+FACT*(CPADR-CCRDR)*FUN(1)*P VPSSC(2,3,2,4)=VPSSC(2,3,2,4)+FACT*(CPALL-CCRLL)*FUN(2)*P VPSSC(3,3,2,4)=VPSSC(3,3,2,4)+FACT*(CPALS-CCRLS)*FUN(2)*P VPSSC(4,3,2,4)=VPSSC(4,3,2,4)+FACT*(CPASS-CCRSS)*FUN(2)*P VPSSC(5,3,2,4)=VPSSC(5,3,2,4)+FACT*(CPADR-CCRDR)*FUN(2)*P VPSSC(2,4,2,4)=VPSSC(2,4,2,4)+FACT*(CPALL-CCRLL)*FUN(3)*P VPSSC(3,4,2,4)=VPSSC(3,4,2,4)+FACT*(CPALS-CCRLS)*FUN(3)*P VPSSC(4,4,2,4)=VPSSC(4,4,2,4)+FACT*(CPASS-CCRSS)*FUN(3)*P VPSSC(5,4,2,4)=VPSSC(5,4,2,4)+FACT*(CPADR-CCRDR)*FUN(3)*P VPSSC(2,5,2,4)=VPSSC(2,5,2,4)+FACT*(CPALL-CCRLL)*FUN(3)*P .*RATOSA ENDIF C END KAON-SSTAR C KAON-KAPPA EXCHANGE POTENTIALS: IF(IKAKSC.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*(GS4**2*F4**2+3*GS4*GS5*F4*F5) CPALS = SR3*(GS5**2*F4*F5+GS4*GS5*F5**2 . -GS4**2*F4*F5-GS4*GS5*F4**2) CPASS = 2*(3*GS4*GS5*F4*F5+GS5**2*F5**2) CPADR = 8*GS5**2*F5**2 C CROSSED: c CCRNN = 2*(ISFLL*GS4**2*F4**2+ISFLS*GS4*GS5*F4*F5+ c . ISFSS*GS5**2*F5**2) CCRNN = (GS4*F4+3*GS5*F5)**2+ISFAC*(GS4*F4-GS5*F5)**2 CCRLL = +2*(GS4*XGS12*F4*XF12+3*GS5*XGS12*F5*XF12) CCRLS = +SR3*(GS4*F4-GS5*F5)*(XGS13*XF12+XGS12*XF13) CCRSS = -2*GS4*XGS13*F4*XF13+10*GS5*XGS13*F5*XF13 CCRDR = +4*GS5*XGS13*F5*XF13 +4*GS4*XGS13*F4*XF13 CALL YNFUN(2,X,AMK,AMSCK,ALMKA,ALMS8,FUN) c CALL YNFUN3(1,2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUN) c CALL YNFUN3(2,2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUNX) c FUN(11) = FUNX(1) c FUN(12) = FUNX(2) c* CALL DKBFUN(2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUN) VPSSC(1,2,2,2)=VPSSC(1,2,2,2)+FACT*(CPANN-CCRNN)*FUN(1) VPSSC(2,2,2,2)=VPSSC(2,2,2,2)+FACT*(CPALL-CCRLL)*FUN(1) VPSSC(3,2,2,2)=VPSSC(3,2,2,2)+FACT*(CPALS-CCRLS)*FUN(1) VPSSC(4,2,2,2)=VPSSC(4,2,2,2)+FACT*(CPASS-CCRSS)*FUN(1) VPSSC(5,2,2,2)=VPSSC(5,2,2,2)+FACT*(CPADR-CCRDR)*FUN(1) VPSSC(1,3,2,2)=VPSSC(1,3,2,2)+FACT*(CPANN-CCRNN)*FUN(2) VPSSC(2,3,2,2)=VPSSC(2,3,2,2)+FACT*(CPALL-CCRLL)*FUN(2) VPSSC(3,3,2,2)=VPSSC(3,3,2,2)+FACT*(CPALS-CCRLS)*FUN(2) VPSSC(4,3,2,2)=VPSSC(4,3,2,2)+FACT*(CPASS-CCRSS)*FUN(2) VPSSC(5,3,2,2)=VPSSC(5,3,2,2)+FACT*(CPADR-CCRDR)*FUN(2) VPSSC(1,4,2,2)=VPSSC(1,4,2,2)+FACT*(CPANN-CCRNN)*FUN(3) VPSSC(2,4,2,2)=VPSSC(2,4,2,2)+FACT*(CPALL-CCRLL)*FUN(3) VPSSC(3,4,2,2)=VPSSC(3,4,2,2)+FACT*(CPALS-CCRLS)*FUN(3) VPSSC(4,4,2,2)=VPSSC(4,4,2,2)+FACT*(CPASS-CCRSS)*FUN(3) VPSSC(5,4,2,2)=VPSSC(5,4,2,2)+FACT*(CPADR-CCRDR)*FUN(3) VPSSC(2,5,2,2)=VPSSC(2,5,2,4)+FACT*(CPALL-CCRLL)*FUN(3) .*RATOSA ENDIF C END KAON-KAPPA C ETA-KAPPA EXCHANGE POTENTIALS: IF(IETKSC.EQ.1) THEN C PARALLEL: CPALL = 2*GS4**2*F6*F7 CPALS = -SR3*GS4*GS5*F6*(F7+F8) CPASS = -2*GS5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRLL = GS4**2*(F6**2+F7**2) CCRLS = -SR3*GS4*GS5*(F6**2+F7*F8) CCRSS = -GS5**2*(F6**2+F8**2) CCRDR = -2*CCRSS CALL YNFUN(2,X,AME,AMSCK,ALMP8,ALMS8,FUN) c* CALL YNFUN2(2,X,AME,AMSCK,ALMP8,ALMS8,DAM,2,FUN) VPSSC(2,2,3,2)=VPSSC(2,2,3,2)+FACT*(CPALL-CCRLL)*FUN(1)*P VPSSC(3,2,3,2)=VPSSC(3,2,3,2)+FACT*(CPALS-CCRLS)*FUN(1)*P VPSSC(4,2,3,2)=VPSSC(4,2,3,2)+FACT*(CPASS-CCRSS)*FUN(1)*P VPSSC(5,2,3,2)=VPSSC(5,2,3,2)+FACT*(CPADR-CCRDR)*FUN(1)*P VPSSC(2,3,3,2)=VPSSC(2,3,3,2)+FACT*(CPALL-CCRLL)*FUN(2)*P VPSSC(3,3,3,2)=VPSSC(3,3,3,2)+FACT*(CPALS-CCRLS)*FUN(2)*P VPSSC(4,3,3,2)=VPSSC(4,3,3,2)+FACT*(CPASS-CCRSS)*FUN(2)*P VPSSC(5,3,3,2)=VPSSC(5,3,3,2)+FACT*(CPADR-CCRDR)*FUN(2)*P VPSSC(2,4,3,2)=VPSSC(2,4,3,2)+FACT*(CPALL-CCRLL)*FUN(3)*P VPSSC(3,4,3,2)=VPSSC(3,4,3,2)+FACT*(CPALS-CCRLS)*FUN(3)*P VPSSC(4,4,3,2)=VPSSC(4,4,3,2)+FACT*(CPASS-CCRSS)*FUN(3)*P VPSSC(5,4,3,2)=VPSSC(5,4,3,2)+FACT*(CPADR-CCRDR)*FUN(3)*P VPSSC(5,5,3,2)=VPSSC(5,5,3,2)+FACT*(CPADR-CCRDR)*FUN(3)*P .*RATOSA ENDIF C END ETA-KAPPA C ETAP-KAPPA EXCHANGE POTENTIALS: IF(IETPKP.EQ.1) THEN C PARALLEL: CPALL = 2*GS4**2*F9*F10 CPALS = -SR3*GS4*GS5*F9*(F10+F11) CPASS = -2*GS5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRLL = GS4**2*(F9**2+F10**2) CCRLS = -SR3*GS4*GS5*(F9**2+F10*F11) CCRSS = -GS5**2*(F9**2+F11**2) CCRDR = -2*CCRSS CALL YNFUN(2,X,AMX,AMSCK,ALMP1,ALMS8,FUN) c* CALL YNFUN2(2,X,AME,AMSCK,ALMP1,ALMS8,DAM,2,FUN) VPSSC(2,2,4,2)=VPSSC(2,2,4,2)+FACT*(CPALL-CCRLL)*FUN(1)*P VPSSC(3,2,4,2)=VPSSC(3,2,4,2)+FACT*(CPALS-CCRLS)*FUN(1)*P VPSSC(4,2,4,2)=VPSSC(4,2,4,2)+FACT*(CPASS-CCRSS)*FUN(1)*P VPSSC(5,2,4,2)=VPSSC(5,2,4,2)+FACT*(CPADR-CCRDR)*FUN(1)*P VPSSC(2,3,4,2)=VPSSC(2,3,4,2)+FACT*(CPALL-CCRLL)*FUN(2)*P VPSSC(3,3,4,2)=VPSSC(3,3,4,2)+FACT*(CPALS-CCRLS)*FUN(2)*P VPSSC(4,3,4,2)=VPSSC(4,3,4,2)+FACT*(CPASS-CCRSS)*FUN(2)*P VPSSC(5,3,4,2)=VPSSC(5,3,4,2)+FACT*(CPADR-CCRDR)*FUN(2)*P VPSSC(2,4,4,2)=VPSSC(2,4,4,2)+FACT*(CPALL-CCRLL)*FUN(3)*P VPSSC(3,4,4,2)=VPSSC(3,4,4,2)+FACT*(CPALS-CCRLS)*FUN(3)*P VPSSC(4,4,4,2)=VPSSC(4,4,4,2)+FACT*(CPASS-CCRSS)*FUN(3)*P VPSSC(5,4,4,2)=VPSSC(5,4,4,2)+FACT*(CPADR-CCRDR)*FUN(3)*P VPSSC(5,5,4,2)=VPSSC(5,5,4,2)+FACT*(CPADR-CCRDR)*FUN(3)*P .*RATOSA ENDIF C END ETAP-KAPPA C TOTAL CONTRIBUTIONS: DO 30 IPS=1,4 DO 30 IMES=1,4 VCNN = VCNN + VPSSC(1,1,IPS,IMES) VCLL = VCLL + VPSSC(2,1,IPS,IMES) VCLS = VCLS + VPSSC(3,1,IPS,IMES) VCSS = VCSS + VPSSC(4,1,IPS,IMES) VCDR = VCDR + VPSSC(5,1,IPS,IMES) VSNN = VSNN + VPSSC(1,2,IPS,IMES) VSLL = VSLL + VPSSC(2,2,IPS,IMES) VSLS = VSLS + VPSSC(3,2,IPS,IMES) VSSS = VSSS + VPSSC(4,2,IPS,IMES) VSDR = VSDR + VPSSC(5,2,IPS,IMES) VTNN = VTNN + VPSSC(1,3,IPS,IMES) VTLL = VTLL + VPSSC(2,3,IPS,IMES) VTLS = VTLS + VPSSC(3,3,IPS,IMES) VTSS = VTSS + VPSSC(4,3,IPS,IMES) VTDR = VTDR + VPSSC(5,3,IPS,IMES) C toegevoegd may 2006: VONN = VONN + VPSSC(1,4,IPS,IMES) VOLL = VOLL + VPSSC(2,4,IPS,IMES) VOLS = VOLS + VPSSC(3,4,IPS,IMES) VOSS = VOSS + VPSSC(4,4,IPS,IMES) VODR = VODR + VPSSC(5,4,IPS,IMES) VALL = VALL + VPSSC(2,5,IPS,IMES) ! VSOA c nog te doen: c VALS = VALS + VPSSC(3,5,IPS,IMES) ! VSOA c VASS = VASS + VPSSC(4,5,IPS,IMES) ! VSOA c VADR = VADR + VPSSC(5,5,IPS,IMES) ! VSOA 30 CONTINUE C END SCALAR MESONS c if(icall.eq.0.and.nschr.eq.1) call writetm(6,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(6,x,p) C C D) BEGIN DIFFRACTIVE CONTRIBUTIONS ******************* C C KAON-A2 EXCHANGE POTENTIALS: IF(IKAA2.EQ.1) THEN C PARALLEL: CPALL = 6*GD1*GD3*F4*F5 CPALS = +2*SR3*GD1*GD2*F4*F5-SR3*GD1*GD3*(F4**2-F5**2) CPASS = 6*GD1*GD3*F4*F5+4*GD1*GD2*F5**2 CPADR = 4*GD1*GD2*F5**2 C CROSSED: CCRLL = 3*(GD1**2*F4**2+GD3**2*F5**2) CCRLS = SR3*(GD1**2*F4*F5-GD3**2*F4*F5+2*GD2*GD3*F5**2) CCRSS = 5*GD1**2*F5**2+GD3**2*F4**2+4*GD2*GD3*F4*F5 CCRDR = 2*GD1**2*F5**2+GD3**2*F4**2+ . 3*GD2**2*F5**2-2*GD2*GD3*F4*F5 CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN) c* CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN) VPSDF(2,2,2,1)=VPSDF(2,2,2,1)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,2,1)=VPSDF(3,2,2,1)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,2,1)=VPSDF(4,2,2,1)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,2,1)=VPSDF(5,2,2,1)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,2,1)=VPSDF(2,3,2,1)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,2,1)=VPSDF(3,3,2,1)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,2,1)=VPSDF(4,3,2,1)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,2,1)=VPSDF(5,3,2,1)-FACT*(CPADR-CCRDR)*FUN(2)*P VPSDF(2,4,2,1)=VPSDF(2,4,2,1)-FACT*(CPALL-CCRLL)*FUN(3)*P VPSDF(3,4,2,1)=VPSDF(3,4,2,1)-FACT*(CPALS-CCRLS)*FUN(3)*P VPSDF(4,4,2,1)=VPSDF(4,4,2,1)-FACT*(CPASS-CCRSS)*FUN(3)*P VPSDF(5,4,2,1)=VPSDF(5,4,2,1)-FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END KAON-A2 C KAON-POMERON: IF(IKAPOM.EQ.1) THEN C PARALLEL: CPALL = 2*GD6*GD7*F4**2 CPALS = -SR3*GD6*(GD7+GD8)*F4*F5 CPASS = -2*GD6*GD8*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (GD6**2+GD7**2)*F4**2 CCRLS = -SR3*(GD6**2+GD7*GD8)*F4*F5 CCRSS = -(GD6**2+GD8**2)*F5**2 CCRDR = -2*CCRSS CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN) c* CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN) VPSDF(2,2,2,3)=VPSDF(2,2,2,3)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,2,3)=VPSDF(3,2,2,3)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,2,3)=VPSDF(4,2,2,3)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,2,3)=VPSDF(5,2,2,3)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,2,3)=VPSDF(2,3,2,3)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,2,3)=VPSDF(3,3,2,3)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,2,3)=VPSDF(4,3,2,3)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,2,3)=VPSDF(5,3,2,3)-FACT*(CPADR-CCRDR)*FUN(2)*P VPSDF(2,4,2,3)=VPSDF(2,4,2,3)-FACT*(CPALL-CCRLL)*FUN(3)*P VPSDF(3,4,2,3)=VPSDF(3,4,2,3)-FACT*(CPALS-CCRLS)*FUN(3)*P VPSDF(4,4,2,3)=VPSDF(4,4,2,3)-FACT*(CPASS-CCRSS)*FUN(3)*P VPSDF(5,4,2,3)=VPSDF(5,4,2,3)-FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END KAON-POMERON C KAON-POMP EXCHANGE POTENTIALS: IF(IKAPOM.EQ.1) THEN C PARALLEL: CPALL = 2*GD9*GD10*F4**2 CPALS = -SR3*GD9*(GD10+GD11)*F4*F5 CPASS = -2*GD9*GD11*F5**2 CPADR = -2*CPASS C CROSSED: CCRLL = (GD9**2+GD10**2)*F4**2 CCRLS = -SR3*(GD9**2+GD10*GD11)*F4*F5 CCRSS = -(GD9**2+GD11**2)*F5**2 CCRDR = -2*CCRSS CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN) c* CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN) VPSDF(2,2,2,4)=VPSDF(2,2,2,4)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,2,4)=VPSDF(3,2,2,4)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,2,4)=VPSDF(4,2,2,4)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,2,4)=VPSDF(5,2,2,4)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,2,4)=VPSDF(2,3,2,4)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,2,4)=VPSDF(3,3,2,4)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,2,4)=VPSDF(4,3,2,4)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,2,4)=VPSDF(5,3,2,4)-FACT*(CPADR-CCRDR)*FUN(2)*P VPSDF(2,4,2,4)=VPSDF(2,4,2,4)-FACT*(CPALL-CCRLL)*FUN(3)*P VPSDF(3,4,2,4)=VPSDF(3,4,2,4)-FACT*(CPALS-CCRLS)*FUN(3)*P VPSDF(4,4,2,4)=VPSDF(4,4,2,4)-FACT*(CPASS-CCRSS)*FUN(3)*P VPSDF(5,4,2,4)=VPSDF(5,4,2,4)-FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END KAON-POMP C KAON-K** EXCHANGE POTENTIALS: IF(IKAKSS.EQ.1) THEN C PARALLEL: CPANN = 0.D0 CPALL = 2*(GD4**2*F4**2+3*GD4*GD5*F4*F5) CPALS = SR3*(GD5**2*F4*F5+GD4*GD5*F5**2 . -GD4**2*F4*F5-GD4*GD5*F4**2) CPASS = 2*(3*GD4*GD5*F4*F5+GD5**2*F5**2) CPADR = 8*GD5**2*F5**2 C CROSSED: CCRNN = 2*(ISFLL*GD4**2*F4**2+ISFLS*GD5*GD4*F4*F5+ . ISFSS*GD5**2*F5**2) CCRLL = +2*(GD4*XGD12*F4*XF12+3*GD5*XGD12*F5*XF12) CCRLS = +SR3*(GD4*F4-GD5*F5)*(XGD13*XF12+XGD12*XF13) CCRSS = -2*GD4*XGD13*F4*XF13+10*GD5*XGD13*F5*XF13 CCRDR = +4*GD5*XGD13*F5*XF13 + 4*GD4*XGD13*F4*XF13 CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN) c CALL YNFUN3(1,4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUN) c CALL YNFUN3(2,4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUNX) c FUN(11) = FUNX(1) c FUN(12) = FUNX(2) c* CALL DKBFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUN) VPSDF(1,2,2,2)=VPSDF(1,2,2,2)-FACT*(CPANN-CCRNN)*FUN(1) VPSDF(2,2,2,2)=VPSDF(2,2,2,2)-FACT*(CPALL-CCRLL)*FUN(1) VPSDF(3,2,2,2)=VPSDF(3,2,2,2)-FACT*(CPALS-CCRLS)*FUN(1) VPSDF(4,2,2,2)=VPSDF(4,2,2,2)-FACT*(CPASS-CCRSS)*FUN(1) VPSDF(5,2,2,2)=VPSDF(5,2,2,2)-FACT*(CPADR-CCRDR)*FUN(1) VPSDF(1,3,2,2)=VPSDF(1,3,2,2)-FACT*(CPANN-CCRNN)*FUN(2) VPSDF(2,3,2,2)=VPSDF(2,3,2,2)-FACT*(CPALL-CCRLL)*FUN(2) VPSDF(3,3,2,2)=VPSDF(3,3,2,2)-FACT*(CPALS-CCRLS)*FUN(2) VPSDF(4,3,2,2)=VPSDF(4,3,2,2)-FACT*(CPASS-CCRSS)*FUN(2) VPSDF(5,3,2,2)=VPSDF(5,3,2,2)-FACT*(CPADR-CCRDR)*FUN(2) VPSDF(1,4,2,2)=VPSDF(1,4,2,2)-FACT*(CPANN-CCRNN)*FUN(3) VPSDF(2,4,2,2)=VPSDF(2,4,2,2)-FACT*(CPALL-CCRLL)*FUN(3) VPSDF(3,4,2,2)=VPSDF(3,4,2,2)-FACT*(CPALS-CCRLS)*FUN(3) VPSDF(4,4,2,2)=VPSDF(4,4,2,2)-FACT*(CPASS-CCRSS)*FUN(3) VPSDF(5,4,2,2)=VPSDF(5,4,2,2)-FACT*(CPADR-CCRDR)*FUN(3) ENDIF C END KAON-K** C ETA-K** EXCHANGE POTENTIALS: IF(IETKSC.EQ.1) THEN C PARALLEL: CPALL = 2*GD4**2*F6*F7 CPALS = -SR3*GD4*GD5*F6*(F7+F8) CPASS = -2*GD5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRLL = GD4**2*(F6**2+F7**2) CCRLS = -SR3*GD4*GD5*(F6**2+F7*F8) CCRSS = -GD5**2*(F6**2+F8**2) CCRDR = -2*CCRSS CALL YNFUN(4,X,AME,AMPOM,ALMP8,AMPRO,FUN) c* CALL YNFUN2(4,X,AME,AMPOM,ALMP8,AMPRO,DAM,2,FUN) VPSDF(2,2,3,2)=VPSDF(2,2,3,2)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,3,2)=VPSDF(3,2,3,2)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,3,2)=VPSDF(4,2,3,2)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,3,2)=VPSDF(5,2,3,2)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,3,2)=VPSDF(2,3,3,2)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,3,2)=VPSDF(3,3,3,2)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,3,2)=VPSDF(4,3,3,2)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,3,2)=VPSDF(5,3,3,2)-FACT*(CPADR-CCRDR)*FUN(2)*P VPSDF(2,4,3,2)=VPSDF(2,4,3,2)-FACT*(CPALL-CCRLL)*FUN(3)*P VPSDF(3,4,3,2)=VPSDF(3,4,3,2)-FACT*(CPALS-CCRLS)*FUN(3)*P VPSDF(4,4,3,2)=VPSDF(4,4,3,2)-FACT*(CPASS-CCRSS)*FUN(3)*P VPSDF(5,4,3,2)=VPSDF(5,4,3,2)-FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END ETA-K** C ETAP-K** EXCHANGE POTENTIALS: IF(IETPKP.EQ.1) THEN C PARALLEL: CPALL = 2*GD4**2*F9*F10 CPALS = -SR3*GD4*GD5*F9*(F10+F11) CPASS = -2*GD5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRLL = GD4**2*(F9**2+F10**2) CCRLS = -SR3*GD4*GD5*(F9**2+F10*F11) CCRSS = -GD5**2*(F9**2+F11**2) CCRDR = -2*CCRSS CALL YNFUN(4,X,AMX,AMPOM,ALMP1,AMPRO,FUN) c* CALL YNFUN2(4,X,AMX,AMPOM,ALMP1,AMPRO,DAM,2,FUN) VPSDF(2,2,4,2)=VPSDF(2,2,4,2)-FACT*(CPALL-CCRLL)*FUN(1)*P VPSDF(3,2,4,2)=VPSDF(3,2,4,2)-FACT*(CPALS-CCRLS)*FUN(1)*P VPSDF(4,2,4,2)=VPSDF(4,2,4,2)-FACT*(CPASS-CCRSS)*FUN(1)*P VPSDF(5,2,4,2)=VPSDF(5,2,4,2)-FACT*(CPADR-CCRDR)*FUN(1)*P VPSDF(2,3,4,2)=VPSDF(2,3,4,2)-FACT*(CPALL-CCRLL)*FUN(2)*P VPSDF(3,3,4,2)=VPSDF(3,3,4,2)-FACT*(CPALS-CCRLS)*FUN(2)*P VPSDF(4,3,4,2)=VPSDF(4,3,4,2)-FACT*(CPASS-CCRSS)*FUN(2)*P VPSDF(5,3,4,2)=VPSDF(5,3,4,2)-FACT*(CPADR-CCRDR)*FUN(2)*P VPSDF(2,4,4,2)=VPSDF(2,4,4,2)-FACT*(CPALL-CCRLL)*FUN(3)*P VPSDF(3,4,4,2)=VPSDF(3,4,4,2)-FACT*(CPALS-CCRLS)*FUN(3)*P VPSDF(4,4,4,2)=VPSDF(4,4,4,2)-FACT*(CPASS-CCRSS)*FUN(3)*P VPSDF(5,4,4,2)=VPSDF(5,4,4,2)-FACT*(CPADR-CCRDR)*FUN(3)*P ENDIF C END ETAP-K** C TOTAL CONTRIBUTIONS: DO 40 IPS=1,4 DO 40 IMES=1,4 VCNN = VCNN + VPSDF(1,1,IPS,IMES) VCLL = VCLL + VPSDF(2,1,IPS,IMES) VCLS = VCLS + VPSDF(3,1,IPS,IMES) VCSS = VCSS + VPSDF(4,1,IPS,IMES) VCDR = VCDR + VPSDF(5,1,IPS,IMES) VSNN = VSNN + VPSDF(1,2,IPS,IMES) VSLL = VSLL + VPSDF(2,2,IPS,IMES) VSLS = VSLS + VPSDF(3,2,IPS,IMES) VSSS = VSSS + VPSDF(4,2,IPS,IMES) VSDR = VSDR + VPSDF(5,2,IPS,IMES) VTNN = VTNN + VPSDF(1,3,IPS,IMES) VTLL = VTLL + VPSDF(2,3,IPS,IMES) VTLS = VTLS + VPSDF(3,3,IPS,IMES) VTSS = VTSS + VPSDF(4,3,IPS,IMES) VTDR = VTDR + VPSDF(5,3,IPS,IMES) 40 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writetm(7,x,p) if(icall.eq.20.and.nschr.eq.1) call writetm(7,x,p) C END DIFFRACTIVE CONTRIBUTIONS c 1 CONTINUE c if(icall.eq.0.and.nschr.eq.1) then if(icall.eq.20.and.nschr.eq.1) then write(N3,*)'*****************************************************' write(N3,*) 'YNPIBE+YNPSBE total contributions: x=',x write(N3,*) 'vcll,vsll=',vcll,vsll write(N3,*) 'vcls,vsls=',vcls,vsls write(N3,*) 'vcss,vsss=',vcss,vsss write(N3,*) 'vcdr,vsdr=',vcdr,vsdr write(N3,*)'*****************************************************' endif ICALL=ICALL+1 1000 CALL ERRSET(208,256,1,1) RETURN C END YNPSBE ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE WRITETM(NNCASE,X,P) C ********************************************************************** C C NCASE = 1: PSEUDO-PSEUDO-SCALAR POTENTIALS, C NCASE = 2: PSEUDO-SCALAR-VECTOR POTENTIALS, C NCASE = 3: PSEUDO-SCALAR-SCALAR POTENTIALS, C NCASE = 4: PSEUDO-SCALAR-DIFFR. POTENTIALS. C IMPLICIT REAL*8(A-H,O-Z) COMMON/PSBE/ VPSBE(5,5,4,4,4) CHARACTER *4 NTYPM(4,4) DATA N3/27/,NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','OM ','PHI ', .'DE ','KAP ','EPS ','S* ','A2 ','K** ','POM ','POMP'/ C if(nncase.le.4) ncase=nncase if(nncase.ge.5) ncase=nncase-3 write(N3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' write(N3,*)'*****************************************************' if(nncase.eq.1) write(N3,*) ' YNPSPS: CENTRAL POTENTIALS: x=',x if(nncase.ge.2.and.nncase.le.4) . write(N3,*) ' YNPIBE: CENTRAL POTENTIALS: x=',x if(nncase.ge.5) write(N3,*) ' YNPSBE: CENTRAL POTENTIALS: x=',x write(N3,*)'*****************************************************' write(N3,110) (NTYPM(KK,NCASE),KK=1,4) 110 format(10x,4(3x,a4,5x)) write(N3,*)'-----------------------------------------------------' DO 111 II=1,4 111 write(N3,112) NTYPM(II,1),(VPSBE(1,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 113 II=1,4 113 write(N3,114) NTYPM(II,1),(VPSBE(5,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 123 II=1,4 123 write(N3,124) NTYPM(II,1),(VPSBE(2,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 125 II=1,4 125 write(N3,126) NTYPM(II,1),(VPSBE(3,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 127 II=1,4 127 write(N3,128) NTYPM(II,1),(VPSBE(4,1,II,KK,NCASE),KK=1,4) call prsu3tm(1,ncase,x,p,n3) write(N3,*)'*****************************************************' if(nncase.eq.1) write(N3,*) ' YNPSPS: SPIN-SPIN POTENTIALS: x=',x if(nncase.ge.2.and.nncase.le.4) . write(N3,*) ' YNPIBE: SPIN-SPIN POTENTIALS: x=',x if(nncase.ge.5) write(N3,*) ' YNPSBE: SPIN-SPIN POTENTIALS: x=',x write(N3,*)'*****************************************************' write(N3,115) (NTYPM(KK,NCASE),KK=1,4) 115 format(10x,4(3x,a4,5x)) write(N3,*)'-----------------------------------------------------' DO 116 II=1,4 116 write(N3,112) NTYPM(II,1),(VPSBE(1,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 118 II=1,4 118 write(N3,114) NTYPM(II,1),(VPSBE(5,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 120 II=1,4 120 write(N3,124) NTYPM(II,1),(VPSBE(2,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 129 II=1,4 129 write(N3,126) NTYPM(II,1),(VPSBE(3,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 131 II=1,4 131 write(N3,128) NTYPM(II,1),(VPSBE(4,2,II,KK,NCASE),KK=1,4) write(N3,*)'*****************************************************' call prsu3tm(2,ncase,x,p,n3) RETURN 112 FORMAT(1x,'NN: ',A4,4(F10.2,2X)) 114 FORMAT(1x,'DR: ',A4,4(F10.2,2X)) 124 FORMAT(1x,'LL: ',A4,4(F10.2,2X)) 126 FORMAT(1x,'LS: ',A4,4(F10.2,2X)) 128 FORMAT(1x,'SS: ',A4,4(F10.2,2X)) C END WRITETM ROUTINE ************************************************** END C ********************************************************************** SUBROUTINE YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN) C ********************************************************************** C C VERSION: AUGUST 1996 ( 1/M^2-TERMS FROM IOFF=1 INCLUDED) C THIS VERSION IS, EXCEPT FOR A FACTOR 2, IDENTICAL C TO PHBFUN USED IN NN! C THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN.C C IT IS UNDERSTOOD THAT AM1=PIM, SO INDEX 1 REFERS TO THE PION. C C COMPUTES THE FOURIER TRANSFORMS OF C C 1 [ 1 1 1 ] C 1*D^(0)(//)= ------------- [ --- + --- - ----------- ] ---> C OM1^2 OM2^2 [ OM1 OM2 (OM1 + OM2) ] C C YNFUN = (1/PI) INT_{0}^{\INFTY} (D LAM/ LAM**2) C C [ 1 1 1 ] C X [ ------------ - ---------------- ---------------- ] C [ (OM1.OM2)^{2} (OM1^{2}+LAM^{2}) (OM2^{2}+LAM^{2})] C C FOR VARIOUS THE COMBINATIONS OF DERIVATIVES CORRESPONDING TO C THE OPERATORS O_{i} GIVEN IN TABLE II, PAPER I. C C KIND = 1: PION-VECTOR-, KIND = 2: PION-SCALAR-, C KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE, C KIND = 5: SCAL-DIFRAC- , KIND = 6: PION-AXIAL -EXCHANGE, C KIND = 7: VECTOR-VECTOR C C SCHEMATICALLY: C PION-VECTOR EXCHANGE: C FUN(1) = OPAEES FUN(2) = OPAEET FUN(3) = OPAEMT1 C FUN(4) = OPAEMO1 FUN(5) = OPAMMC FUN(6) = OPAMMS C FUN(7) = OPAMMT FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 C FUN(10)= OPAEMO2 FUN(11)= OCREES FUN(12)= OCREET C PION-SCALAR EXCHANGE: C FUN(1) = OSCS FUN(2) = OSCT FUN(3) = OSCO C PION-PSSCALAR EXCHANGE: C FUN(1) = OPSC FUN(2) = OPSS FUN(3) = OPST C DIFRAC-DIFRAC EXCHANGE: C FUN(1) = ODFC FUN(2) = ODFO C PION-AXIAL EXCHANGE: C FUN(1) = OAXC FUN(2) = OAXS FUN(3) = OAXT C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA IPV/1/,YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ DATA AMPRO/938.2796D0/ SAVE XX,WW,XBEGIN C C ACCORDING TO THE PAPER I, TABLE II AND APPENDIX A,B, C APPROXIMATION: Q^2+K^2/4 = 0 C DEFINITION STATEMENT OPERATORS: C (NOTICE: G-FUNTIONS REFER TO PION, F-FUNCTIONS TO MESONS.) C C 1) PION-VECTOR EXCHANGE: OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)= . 2*FF*(2*D1G/XH+D2G)/3.D0 c .+(4*D1F*(D3G+2*D2G/XH-2*D1G/XH/XH) c .+(2*D1F/XH+D2F)*(2*D1G/XH+D2G) )*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0 OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)= . -2*FF*(D1G/XH-D2G)/3.D0 c .+(4*D1F*(D3G- D2G/XH+ D1G/XH/XH) c .+(2*D1F/XH+D2F)*(D2G-D1G/XH) )*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(D2F*D2G-D1F*D1G/XH/XH)*(PIM/AMPRO)**2/6.D0 OCREES(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)= .OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH) c .+FF*(D4G+4*D3G/XH)*(PIM/AMPRO)**2/3.D0 OCREET(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)= .OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH) c .+FF*(D4G+D3G/XH-6*D2G/XH**2+6*D1G/XH**3)*(PIM/AMPRO)**2/3.D0 OPAEMT(D1F,D1G,D2G,XH)= 2*D1F*(D1G/XH-D2G)/XH OPAEMO(D1F,D1G,XH)= 4*D1F*D1G/XH/XH OPEMS2(D1F,D2F,D1G,D2G,XH)= (2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0 OPEMT2(D1F,D2F,D1G,D2G,XH)= (D1F/XH-D2F)*(D1G/XH-D2G)/3.D0 OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH OPAMMC(D1F,D2F,D1G,D2G,XH)= .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH OPAMMS(D1F,D2F,D1G,D2G,XH)= .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0 OPAMMT(D1F,D2F,D1G,D2G,XH)= .+(D2F+D1F/XH)*(D2G-D1G/XH)/3.D0-1*(D2F-D1F/XH)*D1G/XH/3.D0 .-1*(D2G-D1G/XH)*D1F/XH/3.D0 C 2) PION-SCALAR EXCHANGE: OSCS(FF,D1F,D2F,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0 c . +(2*D1F/XH+D2F)*(2*D1G/XH+D2G)*(PIM/AMPRO)**2/6.D0 c . -(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0 OSCT(FF,D1F,D2F,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0 c . +(D1F/XH-D2F)*(D1G/XH-D2G)*(PIM/AMPRO)**2/6.D0 c . +(1-2*IPV)*(D1F*D1G/XH/XH-D2F*D2G)*(PIM/AMPRO)**2/6.D0 OSCO(D1F,D1G,XH)= 0.D0 c . +(D1F*D1G/XH/XH)*(PIM/AMPRO)**2 C 3) PION-PSEUDO-SCALAR EXCHANGE: OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G) OPSS(D1F,D2F,D1G,D2G,XH)=+4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0 OPST(D1F,D2F,D1G,D2G,XH)=+2*( (D1F/XH-D2F)*D1G/XH + . (D1G/XH-D2G)*D1F/XH )/3.D0 C 4) DIFRAC-DIFRAC EXCHANGE: ODFC(FF,D1F,D2F,GG,D1G,D2G,XH)= 2*FF*GG -0.5D0*(PIM/AMPRO)**2 . *((D2F+2*D1F/XH)*GG+FF*(D2G+2*D1G/XH)-2*D1F*D1G) ODFO(FF,D1F,GG,D1G,XH)= 0.D0 c . -(D1F*GG+FF*D1G)/XH*(PIM/AMPRO)**2 C 5) PION-AXIAL EXCHANGE: OAXC(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G) OAXS(FF,D1G,D2G,XH)= +2*FF*(2*D1G/XH+D2G)*2/3.D0 OAXT(FF,D1G,D2G,XH)= -2*FF*( -D1G/XH+D2G)/3.D0 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN XBEGIN=X CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 X4 = X1*X3 CC RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1 =-0.5D0*(ALM1/PIM)**2*X*VKU1 DDVKU1 =-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1) D3VKU1 =-0.5D0*(ALM1/PIM)**2*(2*DVKU1+X*DDVKU1) RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 IF(KIND.NE.5) THEN XA =X*AM1/PIM RATA =AM1/ALM1 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM1 +RATA) EPA =FDERFC( XLM1 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA DHIA =-(AM1/PIM)*FIA -HIA*X1 DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA DDHIA =-(AM1/PIM)*DFIA -DHIA*X1 +HIA*X2 D3FIA =-(DDFIA-2*DDVKU1)*X1+2*(DFIA-2*DVKU1)*X2 . -2*(FIA-2*VKU1)*X3-(AM1/PIM)*DDHIA D3HIA =-(AM1/PIM)*DDFIA -DDHIA*X1 +2*DHIA*X2-2*HIA*X3 D4FIA =-(D3FIA-2*D3VKU1)*X1+3*(DDFIA-2*DDVKU1)*X2 . -6*(DFIA-2*DVKU1)*X3+6*(FIA-2*VKU1)*X4-(AM1/PIM)*D3HIA FI1= FIA DFI1= DFIA DDFI1= DDFIA D3FI1= D3FIA D4FI1= D4FIA ENDIF IF(KIND.EQ.5) THEN XA =X*AM1/PIM FI1 =(4.D0/SRPI)*(AM1/PIM)*(AM1/AMPRO)**2*FDEXP(-XA*XA) DFI1 = -2*(AM1/PIM)*XA*FI1 DDFI1 = -2*(AM1/PIM)*(XA*DFI1 + FI1*AM1/PIM) ENDIF IF(KIND.LT.4.OR.KIND.GE.6) THEN XA =X*AM2/PIM RATA =AM2/ALM2 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM2 +RATA) EPA =FDERFC( XLM2 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU2)*X1-(AM2/PIM)*HIA DHIA =-(AM2/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(AM2/PIM)*DHIA ENDIF IF(KIND.EQ.4.OR.KIND.EQ.5) THEN XA =X*AM2/PIM FIA =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA) DFIA = -2*(AM2/PIM)*XA*FIA DDFIA = -2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM) ENDIF FI2= FIA DFI2= DFIA DDFI2= DDFIA C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,12 105 FUN(IFUN) = 0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*1.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI ENDIF c IF(Y.GT.50.D0) GOTO 110 IF(Y.GT.90.D0) GOTO 110 GEW = GEW/(Y*Y) C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) FDISP = FDISP1*FDISP2 C IF(KIND.NE.5) THEN AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM DDHIM =-(AM/PIM)*DFIM -DHIM*X1 +HIM*X2 D3FIM =-(DDFIM-2*DDVKU1)*X1+2*(DFIM-2*DVKU1)*X2 . -2*(FIM-2*VKU1)*X3-(AM/PIM)*DDHIM D3HIM =-(AM/PIM)*DDFIM -DDHIM*X1 +2*DHIM*X2-2*HIM*X3 D4FIM =-(D3FIM-2*D3VKU1)*X1+3*(DDFIM-2*DDVKU1)*X2 . -6*(DFIM-2*DVKU1)*X3+6*(FIM-2*VKU1)*X4-(AM/PIM)*D3HIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM D3FIM1 = D3FIM D4FIM1 = D4FIM ENDIF IF(KIND.EQ.5) THEN FIM1= FI1 DFIM1= DFI1 DDFIM1= DDFI1 ENDIF C IF(KIND.LT.4.OR.KIND.GE.6) THEN AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM ENDIF IF(KIND.EQ.4.OR.KIND.EQ.5) THEN FIM2= FI2 DFIM2= DFI2 DDFIM2= DDFI2 ENDIF C IF(KIND.EQ.1) THEN FUN(1) = FUN(1) + GEW*( . OPAEES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X) . -FDISP*OPAEES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X)) FUN(2) = FUN(2) + GEW*( . OPAEET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X) . -FDISP*OPAEET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X)) FUN(11) = FUN(11) + GEW*( . OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP* . OCREES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X)) FUN(12) = FUN(12) + GEW*( . OCREET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP* . OCREET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X)) FUN(3) = FUN(3) + GEW*(OPAEMT(DFI2,DFI1,DDFI1,X) . -FDISP*OPAEMT(DFIM2,DFIM1,DDFIM1,X)) FUN(4) = FUN(4) + GEW*(OPAEMO(DFI2,DFI1,X) . -FDISP*OPAEMO(DFIM2,DFIM1,X)) FUN(5) = FUN(5) + GEW*(OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(6) = FUN(6) + GEW*(OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(7) = FUN(7) + GEW*(OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(8) = FUN(8) + GEW*(OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(9) = FUN(9) + GEW*(OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(10) = FUN(10) + GEW*(OPEMO2(DFI2,DFI1,X) . -FDISP*OPEMO2(DFIM2,DFIM1,X)) ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1) + GEW*(OSCS(FI2,DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OSCS(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEW*(OSCT(FI2,DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OSCT(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(3) = FUN(3) + GEW*(OSCO(DFI2,DFI1,X) . -FDISP*OSCO(DFIM2,DFIM1,X)) ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1) + GEW*(OPSC(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEW*(OPSS(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) FUN(3) = FUN(3) + GEW*(OPST(DFI2,DDFI2,DFI1,DDFI1,X) . -FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X)) ENDIF C IF(KIND.EQ.5) THEN FUN(1) = FUN(1) + GEW*(ODFC(FI2,DFI2,DDFI2,FI1,DFI1,DDFI1,X) . -FDISP*ODFC(FIM2,DFIM2,DDFIM2,FIM1,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEW*(ODFO(FI2,DFI2,FI1,DFI1,X) . -FDISP*ODFO(FIM2,DFIM2,FIM1,DFIM1,X)) ENDIF C IF(KIND.EQ.6) THEN FUN(1) = FUN(1) + GEW*(OAXC(FI2,DFI1,DDFI1,X) . -FDISP*OAXC(FIM2,DFIM1,DDFIM1,X)) FUN(2) = FUN(2) + GEW*(OAXS(FI2,DFI1,DDFI1,X) . -FDISP*OAXS(FIM2,DFIM1,DDFIM1,X)) FUN(3) = FUN(3) + GEW*(OAXT(FI2,DFI1,DDFI1,X) . -FDISP*OAXT(FIM2,DFIM1,DDFIM1,X)) ENDIF C IF(KIND.EQ.7) THEN FUN(1) = FUN(1) + GEW*(FI2*FI1-FDISP*FIM2*FIM1) ENDIF C 110 CONTINUE 100 CONTINUE C C CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1) C IF(IMETH.EQ.0) THEN YMAX = YB(NINT+1) IF(KIND.EQ.1) THEN FUN(1) = FUN(1)+ .(1.D0/PI)*OPAEES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)/YMAX FUN(2) = FUN(2)+ .(1.D0/PI)*OPAEET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)/YMAX FUN(11)= FUN(11)+(1.D0/PI)* .OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FIM1,X)/YMAX FUN(12)= FUN(12)+(1.D0/PI)* .OCREET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FIM1,X)/YMAX FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)/YMAX FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)/YMAX FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)/YMAX ENDIF C IF(KIND.EQ.2.OR.KIND.EQ.4) THEN FUN(1) = FUN(1)+ .(1.D0/PI)*OSCS(FI2,DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(2) = FUN(2)+ .(1.D0/PI)*OSCT(FI2,DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(3) = FUN(3)+ (1.D0/PI)*OSCO(DFI2,DFI1,X)/YMAX ENDIF C IF(KIND.EQ.3) THEN FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX ENDIF C IF(KIND.EQ.5) THEN FUN(1) = FUN(1)+ .(1.D0/PI)*ODFC(FI2,DFI2,DDFI2,FI1,DFI1,DDFI1,X)/YMAX FUN(2) = FUN(2)+(1.D0/PI)*ODFO(FI2,DFI2,FI1,DFI1,X)/YMAX ENDIF C IF(KIND.EQ.6) THEN FUN(1) = FUN(1)+(1.D0/PI)*OAXC(FI2,DFI1,DDFI1,X)/YMAX FUN(2) = FUN(2)+(1.D0/PI)*OAXS(FI2,DFI1,DDFI1,X)/YMAX FUN(3) = FUN(3)+(1.D0/PI)*OAXT(FI2,DFI1,DDFI1,X)/YMAX ENDIF C IF(KIND.EQ.7) THEN FUN(1) = FUN(1)+(1.D0/PI)*FI2*FI1/YMAX ENDIF ENDIF CC c PRINT 99, KIND,X,AM1,AM2,ALM1,ALM2,(FUN(II),II=1,12) c99 FORMAT(/,' IN YNFUN: KIND=',I2,' X=',F10.3,/, c .' AM1,AM2=',2(F10.3,3X),' ALM1,ALM2=',2(F10.3,3X),/, c . /,' IN YNFUN: FUN(II)=',/,5(D10.3,3X),/) CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE FFUN(N,X,AMES,ALAM,F,DF,DDF,D3F) C ********************************************************************** C C 1 C FOURIER TRANSFORM OF F(OMEGA)= ---------- C OMEGA^{N} C FOR N=0,1,2,3,4 C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ SAVE XX,WW C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN FFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 CC RATP =PIM/ALAM XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI) DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA) IF(N.EQ.0) THEN F = (ALAM/PIM)**2*VKUA DF = (ALAM/PIM)**2*DVKUA DDF = (ALAM/PIM)**2*DDVKUA D3F = (ALAM/PIM)**2*D3VKUA RETURN ENDIF IF(N.NE.1) THEN XA =X*AMES/PIM RATA =AMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA DHIA =-(AMES/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 F = FIA DF = DFIA DDF = DDFIA D3F = D3FIA IF(N.EQ.2) RETURN ENDIF IF(N.EQ.4) THEN D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3 F = 0.5D0*(AMES/PIM)*X*HIA DF = 0.5D0*(AMES/PIM)*(HIA+X*DHIA) DDF = 0.5D0*(AMES/PIM)*(2*DHIA+X*DDHIA) D3F = 0.5D0*(AMES/PIM)*(3*DDHIA+X*D3HIA) RETURN ENDIF C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C IF(N.EQ.1.OR.N.EQ.3) THEN GG =0.D0 DGG =0.D0 DDGG =0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF IF(Y.GE.50.D0) GOTO 110 IF(N.EQ.3) GEW = GEW/Y**2 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP =FDEXP(-Y*Y*RATP*RATP) C AM=PIM*DSQRT((AMES/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALAM ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLAM+RATM) EPM =FDERFC( XLAM+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKUA)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKUA)*X1+(FIM-2*VKUA)*X2-(AM/PIM)*DHIM IF(N.EQ.1) THEN GG = GG + GEW*FIM* FDISP DGG = DGG + GEW*DFIM* FDISP DDGG = DDGG + GEW*DDFIM* FDISP ENDIF IF(N.EQ.3) THEN GG = GG + GEW*(FIA-FIM* FDISP) DGG = DGG + GEW*(DFIA-DFIM* FDISP) DDGG = DDGG + GEW*(DDFIA-DDFIM* FDISP) ENDIF C 110 CONTINUE 100 CONTINUE C F = GG DF = DGG DDF = DDGG ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE FFUNZ(N,X,AMES,AMZ,ALAM,F,DF,DDF,D3F) C ********************************************************************** C 1-K^2/MZ^2) C ZERO: FOURIER F(OMEGA)= ---------- = (1+M^2/MZ^2) PHI_C^(0) C OMEGA^{2} C C - (M/MZ)^2 (LAMBDA/M)^3 EXP[-1/4 LAMBDA^2 R^2] C C C FOR N=1,2,3 C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ SAVE XX,WW C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) c IF(IMETH.EQ.1) NINT=1 IF(IMETH.LE.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN GFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 CC RATP =PIM/ALAM XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI) DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA) VKUM =(ALAM/AMES)**3*FDEXP(-XLAM2)/(2*SRPI) DVKUM=-0.5D0*(ALAM/PIM)**2*X*VKUM DDVKUM=-0.5D0*(ALAM/PIM)**2*(X*DVKUM+VKUM) D3VKUM=-0.5D0*(ALAM/PIM)**2*(X*DDVKUM+2*DVKUM) IF(N.EQ.0) THEN F = (ALAM/PIM)**2*VKUA DF = (ALAM/PIM)**2*DVKUA DDF = (ALAM/PIM)**2*DDVKUA D3F = (ALAM/PIM)**2*D3VKUA RETURN ENDIF IF(N.NE.1) THEN XA =X*AMES/PIM RATA =AMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA DHIA =-(AMES/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 C WITH ZERO: FZERO = (AMES/AMZ)**2 FIA = (1.D0+FZERO)*FIA - FZERO*VKUM*AMES/PIM DFIA = (1.D0+FZERO)*DFIA - FZERO*DVKUM*AMES/PIM DDFIA = (1.D0+FZERO)*DDFIA - FZERO*DDVKUM*AMES/PIM D3FIA = (1.D0+FZERO)*D3FIA - FZERO*D3VKUM*AMES/PIM IF(N.EQ.2) THEN F = FIA DF = DFIA DDF = DDFIA D3F = D3FIA RETURN ENDIF ENDIF C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C IF(N.EQ.1.OR.N.EQ.3) THEN GG =0.D0 DGG =0.D0 DDGG =0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 IF(N.EQ.3) GEW = GEW/Y**2 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP =FDEXP(-Y*Y*RATP*RATP) C AM=PIM*DSQRT((AMES/PIM)**2+Y*Y) FZEROM=(AM/AMZ)**2 VKUM =(ALAM/AM)**3*FDEXP(-XLAM2)/(2*SRPI) DVKUM=-0.5D0*(ALAM/PIM)**2*X*VKUM DDVKUM=-0.5D0*(ALAM/PIM)**2*(X*DVKUM+VKUM) D3VKUM=-0.5D0*(ALAM/PIM)**2*(X*DDVKUM+2*DVKUM) XM=AM*X/PIM RATM =AM/ALAM ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLAM+RATM) EPM =FDERFC( XLAM+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKUA)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKUA)*X1+(FIM-2*VKUA)*X2-(AM/PIM)*DHIM FIM = (1.D0+FZEROM)*FIM - FZEROM*VKUM*AM/PIM DFIM = (1.D0+FZEROM)*DFIM - FZEROM*DVKUM*AM/PIM DDFIM = (1.D0+FZEROM)*DDFIM - FZEROM*DDVKUM*AM/PIM IF(N.EQ.1) THEN GG = GG + GEW*FIM* FDISP DGG = DGG + GEW*DFIM* FDISP DDGG = DDGG + GEW*DDFIM* FDISP ENDIF IF(N.EQ.3) THEN GG = GG + GEW*(FIA-FIM* FDISP) DGG = DGG + GEW*(DFIA-DFIM* FDISP) DDGG = DDGG + GEW*(DDFIA-DDFIM* FDISP) ENDIF C 110 CONTINUE 100 CONTINUE C F = GG DF = DGG DDF = DDGG ENDIF CC RETURN END C ********************************************************************** SUBROUTINE HFUN(N,X,AM1,AM2,ALM1,ALM2,DAM,FUN) C ********************************************************************** C C FOURIER TRANSFORM OF C 1 1 C H_{N,M}(A,OM1,OM2) = ------------------ --------------- C OM1^{N} OM2^{N} (OM1+A) (OM2+A) C 1 C X --------- C (OM1+OM2) C FOR N = -1,0,1,2 C C SCHEMATICALLY: C FUN(1) = F*G, FUN(2) = DF*G, FUN(3) = F*DG, C FUN(4) = DF*DG, FUN(5) = DDF*G, FUN(6) = F*DDG, C FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ SAVE XX,WW,AA,AA2 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN AA =DAM/PIM AA2 =AA*AA CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 CC RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 IF(N.EQ.2) THEN XA =X*AM1/PIM RATA =AM1/ALM1 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM1 +RATA) EPA =FDERFC( XLM1 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA DHIA =-(AM1/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA FI1= FIA DFI1= DFIA DDFI1= DDFIA XA =X*AM2/PIM RATA =AM2/ALM2 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM2 +RATA) EPA =FDERFC( XLM2 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU2)*X1-(AM2/PIM)*HIA DHIA =-(AM2/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(AM2/PIM)*DHIA FI2= FIA DFI2= DFIA DDFI2= DDFIA ENDIF C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,9 FUN(IFUN) = 0.D0 105 HH(IFUN) = 0.D0 GG1 =0.D0 DGG1 =0.D0 DDGG1=0.D0 GG2 =0.D0 DGG2 =0.D0 DDGG2=0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) C AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM C AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM C IF(N.EQ.-1) THEN WGHTH= GEW*Y*Y * FDISP1*FDISP2 FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 IF(AA.NE.0.D0) THEN WGHT= WGHTH/(Y*Y+AA2) HH(1) = HH(1) + WGHT*FIM1*FIM2 HH(2) = HH(2) + WGHT*DFIM1*FIM2 HH(3) = HH(3) + WGHT*FIM1*DFIM2 HH(4) = HH(4) + WGHT*DFIM1*DFIM2 HH(5) = HH(5) + WGHT*DDFIM1*FIM2 HH(6) = HH(6) + WGHT*FIM1*DDFIM2 HH(7) = HH(7) + WGHT*DDFIM1*DFIM2 HH(8) = HH(8) + WGHT*DFIM1*DDFIM2 HH(9) = HH(9) + WGHT*DDFIM1*DDFIM2 WGHT= GEW*Y*Y/(Y*Y+AA2) GG1 = GG1 + WGHT*FIM1* FDISP1 DGG1 = DGG1 + WGHT*DFIM1* FDISP1 DDGG1 = DDGG1+ WGHT*DDFIM1* FDISP1 GG2 = GG2 + WGHT*FIM2* FDISP2 DGG2 = DGG2 + WGHT*DFIM2* FDISP2 DDGG2 = DDGG2+ WGHT*DDFIM1* FDISP2 ENDIF ENDIF C IF(N.EQ.0) THEN WGHTH= GEW*Y*Y/(Y*Y+AA2) * FDISP1*FDISP2 FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 ENDIF IF(N.EQ.1.AND.AA.NE.0.D0) THEN WGHTH= GEW*FDISP1*FDISP2/(Y*Y+AA2) FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 WGHT= AA/(Y*Y+AA2) GG1 = GG1 + GEW*WGHT*FIM1* FDISP1 DGG1 = DGG1 + GEW*WGHT*DFIM1* FDISP1 DDGG1 = DDGG1+ GEW*WGHT*DDFIM1* FDISP1 GG2 = GG2 + GEW*WGHT*FIM2* FDISP2 DGG2 = DGG2 + GEW*WGHT*DFIM2* FDISP2 DDGG2 = DDGG2+ GEW*WGHT*DDFIM1* FDISP2 ENDIF IF(N.EQ.1.AND.AA.EQ.0.D0) THEN WGHTH= 1.D0/Y**2 FUN(1) = FUN(1) + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(2) = FUN(2) + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(3) = FUN(3) + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(4) = FUN(4) + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(5) = FUN(5) + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(6) = FUN(6) + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2) FUN(7) = FUN(7) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DFI2-DFIM2*FDISP2) FUN(8) = FUN(8) + WGHTH*(DFI1-DFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) FUN(9) = FUN(9) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) ENDIF IF(N.EQ.2) THEN WGHTH= GEW/(Y*Y+AA2)/Y**2 FUN(1) = FUN(1) + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(2) = FUN(2) + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(3) = FUN(3) + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(4) = FUN(4) + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(5) = FUN(5) + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(6) = FUN(6) + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2) FUN(7) = FUN(7) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DFI2-DFIM2*FDISP2) FUN(8) = FUN(8) + WGHTH*(DFI1-DFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) FUN(9) = FUN(9) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) ENDIF C 110 CONTINUE 100 CONTINUE IF(N.EQ.-1.AND.AA.NE.0.D0) THEN FUN(1) = FUN(1) - AA*GG1*GG2 -AA2*HH(1) FUN(2) = FUN(2) - AA*DGG1*GG2 -AA2*HH(2) FUN(3) = FUN(3) - AA*GG1*DGG2 -AA2*HH(3) FUN(4) = FUN(4) - AA*DGG1*DGG2 -AA2*HH(4) FUN(5) = FUN(5) - AA*DDGG1*GG2 -AA2*HH(5) FUN(6) = FUN(6) - AA*GG1*DDGG2 -AA2*HH(6) FUN(7) = FUN(7) - AA*DDGG1*DGG2 -AA2*HH(7) FUN(8) = FUN(8) - AA*DGG1*DDGG2 -AA2*HH(8) FUN(9) = FUN(9) - AA*DDGG1*DDGG2-AA2*HH(9) ENDIF IF(N.EQ.1.AND.AA.NE.0.D0) THEN FUN(1) = FUN(1) - GG1*GG2/AA FUN(2) = FUN(2) - DGG1*GG2/AA FUN(3) = FUN(3) - GG1*DGG2/AA FUN(4) = FUN(4) - DGG1*DGG2/AA FUN(5) = FUN(5) - DDGG1*GG2/AA FUN(6) = FUN(6) - GG1*DDGG2/AA FUN(7) = FUN(7) - DDGG1*DGG2/AA FUN(8) = FUN(8) - DGG1*DDGG2/AA FUN(9) = FUN(9) - DDGG1*DDGG2/AA ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE HDIF(N,X,AM1,AM2,ALM1,DAM,FUN) C ********************************************************************** C C SECOND EXCHANGE IS DIFFRACTIVE: (ONLY READY FOR N=0) C FOURIER TRANSFORM OF C 1 1 C H_{N,M}(A,OM1,OM2) = ------------------ --------------- C OM1^{N} OM2^{N} (OM1+A) (OM2+A) C 1 C X --------- C (OM1+OM2) C FOR N = -1,0,1,2 C C SCHEMATICALLY: C FUN(1) = F*G, FUN(2) = DF*G, FUN(3) = F*DG, C FUN(4) = DF*DG, FUN(5) = DDF*G, FUN(6) = F*DDG, C FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(12) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ DATA AMPRO/938.2796D0/ SAVE XX,WW,AA,AA2 C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) IF(ICALL.EQ.0) THEN AA =DAM/PIM AA2 =AA*AA CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN HFUN: IMETH=',I2,' NPNT=',I2,//) ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 CC C DIFFRACTIVE: XA =X*AM2/PIM FIA =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA) DFIA =-2*(AM2/PIM)*XA*FIA DDFIA =-2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM) FI2= FIA DFI2= DFIA DDFI2= DDFIA RATP1=PIM/ALM1 XLM1 =0.5D0*X*ALM1/PIM XLM12=XLM1*XLM1 VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI) DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1 C DIFFRACTIVE: ALM2 = 2*AM2 RATP2=PIM/ALM2 XLM2 =0.5D0*X*ALM2/PIM XLM22=XLM2*XLM2 VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI) DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2 IF(N.EQ.2) THEN XA =X*AM1/PIM RATA =AM1/ALM1 ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLM1 +RATA) EPA =FDERFC( XLM1 +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA DHIA =-(AM1/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA FI1= FIA DFI1= DFIA DDFI1= DDFIA ENDIF C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C DO 105 IFUN=1,9 FUN(IFUN) = 0.D0 105 HH(IFUN) = 0.D0 GG1 =0.D0 DGG1 =0.D0 DDGG1=0.D0 GG2 =0.D0 DGG2 =0.D0 DDGG2=0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) C AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM C FIM2 = FI2 DFIM2 = DFI2 DDFIM2 = DDFI2 C IF(N.EQ.-1) THEN WGHTH= GEW*Y*Y * FDISP1*FDISP2 FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 IF(AA.NE.0.D0) THEN WGHT= WGHTH/(Y*Y+AA2) HH(1) = HH(1) + WGHT*FIM1*FIM2 HH(2) = HH(2) + WGHT*DFIM1*FIM2 HH(3) = HH(3) + WGHT*FIM1*DFIM2 HH(4) = HH(4) + WGHT*DFIM1*DFIM2 HH(5) = HH(5) + WGHT*DDFIM1*FIM2 HH(6) = HH(6) + WGHT*FIM1*DDFIM2 HH(7) = HH(7) + WGHT*DDFIM1*DFIM2 HH(8) = HH(8) + WGHT*DFIM1*DDFIM2 HH(9) = HH(9) + WGHT*DDFIM1*DDFIM2 WGHT= GEW*Y*Y/(Y*Y+AA2) GG1 = GG1 + WGHT*FIM1* FDISP1 DGG1 = DGG1 + WGHT*DFIM1* FDISP1 DDGG1 = DDGG1+ WGHT*DDFIM1* FDISP1 GG2 = GG2 + WGHT*FIM2* FDISP2 DGG2 = DGG2 + WGHT*DFIM2* FDISP2 DDGG2 = DDGG2+ WGHT*DDFIM1* FDISP2 ENDIF ENDIF C IF(N.EQ.0) THEN WGHTH= GEW*Y*Y/(Y*Y+AA2) * FDISP1*FDISP2 FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 ENDIF IF(N.EQ.1.AND.AA.NE.0.D0) THEN WGHTH= GEW*FDISP1*FDISP2/(Y*Y+AA2) FUN(1) = FUN(1) + WGHTH*FIM1*FIM2 FUN(2) = FUN(2) + WGHTH*DFIM1*FIM2 FUN(3) = FUN(3) + WGHTH*FIM1*DFIM2 FUN(4) = FUN(4) + WGHTH*DFIM1*DFIM2 FUN(5) = FUN(5) + WGHTH*DDFIM1*FIM2 FUN(6) = FUN(6) + WGHTH*FIM1*DDFIM2 FUN(7) = FUN(7) + WGHTH*DDFIM1*DFIM2 FUN(8) = FUN(8) + WGHTH*DFIM1*DDFIM2 FUN(9) = FUN(9) + WGHTH*DDFIM1*DDFIM2 WGHT= AA/(Y*Y+AA2) GG1 = GG1 + GEW*WGHT*FIM1* FDISP1 DGG1 = DGG1 + GEW*WGHT*DFIM1* FDISP1 DDGG1 = DDGG1+ GEW*WGHT*DDFIM1* FDISP1 GG2 = GG2 + GEW*WGHT*FIM2* FDISP2 DGG2 = DGG2 + GEW*WGHT*DFIM2* FDISP2 DDGG2 = DDGG2+ GEW*WGHT*DDFIM1* FDISP2 ENDIF IF(N.EQ.1.AND.AA.EQ.0.D0) THEN WGHTH= 1.D0/Y**2 FUN(1) = FUN(1) + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(2) = FUN(2) + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(3) = FUN(3) + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(4) = FUN(4) + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(5) = FUN(5) + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(6) = FUN(6) + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2) FUN(7) = FUN(7) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DFI2-DFIM2*FDISP2) FUN(8) = FUN(8) + WGHTH*(DFI1-DFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) FUN(9) = FUN(9) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) ENDIF IF(N.EQ.2) THEN WGHTH= GEW/(Y*Y+AA2)/Y**2 FUN(1) = FUN(1) + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(2) = FUN(2) + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(3) = FUN(3) + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(4) = FUN(4) + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2) FUN(5) = FUN(5) + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2) FUN(6) = FUN(6) + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2) FUN(7) = FUN(7) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DFI2-DFIM2*FDISP2) FUN(8) = FUN(8) + WGHTH*(DFI1-DFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) FUN(9) = FUN(9) + WGHTH*(DDFI1-DDFIM1*FDISP1) . *(DDFI2-DDFIM2*FDISP2) ENDIF C 110 CONTINUE 100 CONTINUE IF(N.EQ.-1.AND.AA.NE.0.D0) THEN FUN(1) = FUN(1) - AA*GG1*GG2 -AA2*HH(1) FUN(2) = FUN(2) - AA*DGG1*GG2 -AA2*HH(2) FUN(3) = FUN(3) - AA*GG1*DGG2 -AA2*HH(3) FUN(4) = FUN(4) - AA*DGG1*DGG2 -AA2*HH(4) FUN(5) = FUN(5) - AA*DDGG1*GG2 -AA2*HH(5) FUN(6) = FUN(6) - AA*GG1*DDGG2 -AA2*HH(6) FUN(7) = FUN(7) - AA*DDGG1*DGG2 -AA2*HH(7) FUN(8) = FUN(8) - AA*DGG1*DDGG2 -AA2*HH(8) FUN(9) = FUN(9) - AA*DDGG1*DDGG2-AA2*HH(9) ENDIF IF(N.EQ.1.AND.AA.NE.0.D0) THEN FUN(1) = FUN(1) - GG1*GG2/AA FUN(2) = FUN(2) - DGG1*GG2/AA FUN(3) = FUN(3) - GG1*DGG2/AA FUN(4) = FUN(4) - DGG1*DGG2/AA FUN(5) = FUN(5) - DDGG1*GG2/AA FUN(6) = FUN(6) - GG1*DDGG2/AA FUN(7) = FUN(7) - DDGG1*DGG2/AA FUN(8) = FUN(8) - DGG1*DDGG2/AA FUN(9) = FUN(9) - DDGG1*DDGG2/AA ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE PRSU3TM(IV,NCASE,X,P,N3) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PSBE/ VPR(5,5,4,4,4) DIMENSION VTOT(5) C SUMMED CONTRIBUTIONS: DO 120 ICHAN=1,5 VTOT(ICHAN)=0.D0 DO 120 M=1,4 DO 120 N=1,4 120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE) if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/, . ' VCLS=',F10.2,3x,' VCSS=',F10.2,/) if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/, . ' VSLS=',F10.2,3x,' VSSS=',F10.2,/) C CONTRIBUTIONS TO SU(3)-POTENTIALS: if(p.eq.1.d0) then V27a = VTOT(1) V27b = VTOT(5) V27c = (9*VTOT(2)-VTOT(4))/8.D0 c V8Sa = 10*VTOT(2)-9*VTOT(5) V8Sa = VTOT(2)+3*VTOT(3) V8Sb = (10*VTOT(4)-VTOT(5))/9.D0 V8Sc = (9*VTOT(4)-VTOT(2))/8.D0 VLSa = (-3*V27b+3*V8Sa)/10.D0 VLSb = (-3*V27b+3*V8Sb)/10.D0 VLSc = (-3*V27c+3*V8Sc)/10.D0 write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc 123 format(' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/, . ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/, . ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2,/) endif if(p.eq.-1.d0) then V10nn= VTOT(1) V10 = VTOT(5) V10sa= VTOT(2)+VTOT(3) V10sb= VTOT(4)+VTOT(3) V8Aa = VTOT(2)-VTOT(3) V8Ab = VTOT(4)-VTOT(3) write(N3,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10 124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,3x,' V10nn=',F10.2,/, . ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10 =',F10.2,/) endif RETURN END C********************************************************************** SUBROUTINE POTGR(XCALL,PIM,P,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) C********************************************************************** C GREEN TRANSFORMATION FOR POTENTIALS ON SU(2)-BASIS C FOR AKS(I)=0 C---------------------------------------------------------------------- IMPLICIT REAL*8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL, . FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL, . VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS, . FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS, . VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS, . FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS, . VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR, . FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR c* . ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN COMMON/STPS/H,NMAX,NSTPD,KSTPD(5),NMIN DIMENSION XA(300),TGRA(3,3,300),TGRPA(3,3,300) DIMENSION PHI(3,3),DPHI(3,3),TGR(3,3),TGRP(3,3), . AB(3,3),PHIO(3,3),DPHIO(3,3),TGINT(3,3,3),TGPINT(3,3,3) DATA ICALL/0/,PHI/9*0.D0/,DPHI/9*0.D0/,AB/9*0.D0/ SAVE XA,TGRA,TGRAP C---------------------------------------------------------------------- C GENERATION GREEN TRANSFORMATIONS FOR THE POINT XA(I): IF(ICALL.EQ.0) THEN CALL XVALS(XA) C FOR SUBROUTINE GREEN : REVERSAL LOOP VARIABLE : C DO 4 II=2,NMAX C I=NMAX+2-II X=XA(I) CALL VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) C C GREEN TRANSFORMATION MATRICES : TGR,TGRP,GRPP : C c IF(XA(I).GE.0.35D0) THEN PHI(1,1)=1.D0+2*FILL PHI(1,2)=2*FILS PHI(2,2)=1.D0+2*FISS PHI(2,1)=PHI(1,2) PHI(3,3)=1.D0+2*FIDR DPHI(1,1)=2*DFILL/PIM DPHI(1,2)=2*DFILS/PIM DPHI(2,2)=2*DFISS/PIM DPHI(2,1)=DPHI(1,2) DPHI(3,3)=2*DFIDR/PIM C C INPUT : PHI-,DPHI-MATRIX ON THE ISOSPIN BASIS C IF(X.LT.0.7D0) CALL GRNTST(X,PHI,DPHI,IRET) CALL GREEN (1,II,X,PHI,DPHI,TGR,TGRP,PHIO,DPHIO) C C OUTPUT: TGR,TGRP: ON SU(2)-BASIS C DO 14 KK=1,3 DO 14 LL=1,3 TGRA(KK,LL,I) = TGR(KK,LL) 14 TGRPA(KK,LL,I) = TGRP(KK,LL) 4 CONTINUE ENDIF C---------------------------------------------------------------------- C C GREEN'S TRANSFORMATION C IVAL = NMAX IIMIN=1 IIMAX=NMAX DO 10 I=1,NMAX 10 IF(XCALL.GE.XA(I).AND.XCALL.LE.XA(I+1)) IVAL=I C C GENERATION GREEN TRANSFORMATION MATRICES BY INTERPOLATION: C NMAX1 = NMAX-1 IF(IVAL.LT.NMAX1) THEN DO 11 KK=1,3 DO 11 LL=1,3 DO 11 II=1,3 TGINT(KK,LL,II)=TGRA(KK,LL,IVAL+II-1) TGPINT(KK,LL,II)=TGRPA(KK,LL,IVAL+II-1) 11 CONTINUE CALL INTPOL3(XCALL,IVAL,NMAX,XA,TGINT,TGR) CALL INTPOL3(XCALL,IVAL,NMAX,XA,TGPINT,TGRP) ENDIF IF(IVAL.EQ.NMAX) THEN DO 12 KK=1,3 DO 12 LL=1,3 TGR(KK,LL) = 0.D0 TGRP(KK,LL) = 0.D0 12 IF(KK.EQ.LL) TGR(KK,LL)=1.D0 ENDIF c write(*,*) 'at 3, grnpack: ival=',ival,' xcall=',xcall c write(*,*) 'grnpack: tgr=',tgr c write(*,*) 'grnpack: tgrp=',tgrp CALL VMATP(XCALL,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS) PHI(1,1)=1.D0+2*FILL PHI(1,2)=2*FILS PHI(2,2)=1.D0+2*FISS PHI(2,1)=PHI(1,2) PHI(3,3)=1.D0+2*FIDR DPHI(1,1)=2*DFILL/PIM DPHI(1,2)=2*DFILS/PIM DPHI(2,2)=2*DFISS/PIM DPHI(2,1)=DPHI(1,2) DPHI(3,3)=2*DFIDR/PIM C C GREEN TRANSFORMATION CENTRAL POTENTIAL: AB(1,1 )= VCLL AB(1,2 )= VCLS AB(2,2 )= VCSS AB(3,3 )= VCDR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VCLL = AB(1,1 ) VCLS = AB(1,2 ) VCSS = AB(2,2 ) VCDR = AB(3,3 ) C GREEN TRANSFORMATION SPIN-SPIN POTENTIAL: AB(1,1 )= VSIGLL AB(1,2 )= VSIGLS AB(2,2 )= VSIGSS AB(3,3 )= VSIGDR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VSIGLL = AB(1,1 ) VSIGLS = AB(1,2 ) VSIGSS = AB(2,2 ) VSIGDR = AB(3,3 ) C GREEN TRANSFORMATION TENSOR POTENTIAL: AB(1,1 )= VTENLL AB(1,2 )= VTENLS AB(2,2 )= VTENSS AB(3,3 )= VTENDR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VTENLL = AB(1,1 ) VTENLS = AB(1,2 ) VTENSS = AB(2,2 ) VTENDR = AB(3,3 ) C GREEN TRANSFORMATION SPIN-ORBIT POTENTIAL: AB(1,1 )= VSOLL AB(1,2 )= VSOLS AB(2,2 )= VSOSS AB(3,3 )= VSODR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VSOLL = AB(1,1 ) VSOLS = AB(1,2 ) VSOSS = AB(2,2 ) VSODR = AB(3,3 ) C GREEN TRANSFORMATION QUADRATIC SPIN-ORBIT POTENTIAL: AB(1,1 )= VSO2LL AB(1,2 )= VSO2LS AB(2,2 )= VSO2SS AB(3,3 )= VSO2DR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VSO2LL = AB(1,1 ) VSO2LS = AB(1,2 ) VSO2SS = AB(2,2 ) VSO2DR = AB(3,3 ) C GREEN TRANSFORMATION ANTI-SYMMETRIC SPIN-ORBIT POTENTIAL: AB(1,1 )= VSOALL AB(1,2 )= VSOALS AB(2,2 )= VSOASS AB(3,3 )= VSOADR AB(2,1 )= AB(1,2 ) CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP) VASOLL = AB(1,1 ) VASOLS = AB(1,2 ) VASOSS = AB(2,2 ) VASODR = AB(3,3 ) C ICALL = 1 RETURN END c ******************************************************************* subroutine xvals(xa) c ******************************************************************* implicit real*8(a-h,o-z) dimension xa(300) common /stps/h,nmax,nstpd,kstpd(5),nmin dimension kstps(5) c data hi/0.5d-02/,nmaxi/300/,nstps/4/,kstps/50,150,250,300,0/ data hi/0.3d-01/,nmaxi/100/,nstps/2/,kstps/20,40,100,0,0/ data x0/0.d0/ h=hi nmax=nmaxi nstpd=nstps do 10 ii=1,5 10 kstpd(ii)=kstps(ii) xa(1) = x0 do 7 i=2,nmax hh=h do 71 ii=1,nstpd 71 if(i.gt.kstpd(ii)) hh=2*hh 7 xa(i) = xa(i-1)+hh c write(*,*) 'xvals: xa=',xa return end C ******************************************************************* SUBROUTINE GRNTRN(XA,AB,PHI,PHIP,TGR,TGRP) C ******************************************************************* c c CALLED BY POTGR FOR CONSTRUCTION POT'S -MATRIX AFTER GREEN-TRANSF. c c NOTE THAT HERE : PHI = M-MATRIX=1 + 2 * PHI ETC. C ******************************************************************* IMPLICIT REAL*8(A-H,O-Z) DIMENSION AB(3,3),TGR(3,3),TGRP(3,3), , PHI(3,3),PHIP(3,3),AI(3,3), , PHITGR(3,3),PHITGM(3,3),PHPTGP(3,3),ABTGR(3,3) DATA AI/1.D0,0.D0,0.D0,0.D0,1.D0,0.D0,0.D0,0.D0,1.D0/ N=3 NN=N/3 C PRINT 51 C DO 50 KK=1,N C 50 PRINT 61, (AB(KK,LL),LL=1,N) C 51 FORMAT(' ENTERING GRNTRN : ') C DO 2000 I=1,3 C2000 PRINT 2001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3) C2001 FORMAT(/,' GRNTRN PHI=',3(D12.5,2X),' PHIP=',3(D12.5,2X)) C DO 3000 I=1,3 C3000 PRINT 3001, (TGR(I,J),J=1,3),(TGRP(I,J),J=1,3) C3001 FORMAT(/,' GRNTRN TGR=',3(D12.5,2X),' TGRP=',3(D12.5,2X)) C4000 CONTINUE C DO 1 I=1,3 DO 1 IA=1,NN IIA=NN*(I-1)+IA DO 2 J=1,3 DO 2 JB=1,NN JJB=NN*(J-1)+JB PHITGR(IIA,JJB)=0.D0 PHPTGP(IIA,JJB)=0.D0 DO 11 K=1,3 PHITGR(IIA,JJB)=PHITGR(IIA,JJB)+PHI(I,K)*TGR(K,J)*AI(IA,JB) 11 PHPTGP(IIA,JJB)=PHPTGP(IIA,JJB)+PHIP(I,K)*TGRP(K,J)*AI(IA,JB) 2 CONTINUE 1 CONTINUE C DO 3 I=1,3 DO 3 IA=1,NN IIA=NN*(I-1)+IA DO 4 J=1,3 DO 4 JB=1,NN JJB=NN*(J-1)+JB ABTGR (IIA,JJB)=0.D0 DO 41 K=1,3 DO 41 KC=1,NN KKC=NN*(K-1)+KC 41 ABTGR(IIA,JJB)=ABTGR(IIA,JJB)+AB(IIA,KKC)*TGR(K,J)*AI(KC,JB) 4 CONTINUE 3 CONTINUE C DO 5 I=1,3 DO 5 J=1,3 PHITGM(I,J)=0.D0 5 PHITGM(I,I)=1.D0 CALL INVER3(PHITGM,PHITGR) C DO 6 I=1,N DO 6 J=1,N AB(I,J)=0.D0 DO 7 K=1,N 7 AB(I,J)=AB(I,J) + + 0.5D0*PHITGM(I,K) * PHPTGP(K,J) 6 CONTINUE DO 8 I=1,N DO 8 J=1,N DO 9 K=1,N 9 AB(I,J)=AB(I,J)+ + PHITGM(I,K) * ABTGR(K,J) 8 CONTINUE C PRINT 62 C DO 60 KK=1,N C 60 PRINT 61, (AB(KK,LL),LL=1,N) C 61 FORMAT(' GRNTRN AB=',6(D12.5,5X)) C 62 FORMAT(' LEAVING GRNTRN : ') RETURN END C ************************************************************** SUBROUTINE GREEN (ICH,INDX,X,BM,BMP,T,TP,BMO,BMPO) c CALLED BY : c AMATLP/AMATLN FOR CONSTRUCTION OF GREEN-TRANSFORMATION C ************************************************************** C * THIS VERSION (2) SOLVES THE DIFFERENTIAL EQUATION : * * 2 * BM * TP + BMP * T= 0 * * STARTING FROM X=XMAX AND GOING INSIDE TOWARDS X=0 * * FIRST CALLS SHOULD HAVE INDX=2 ,3 ,4 , ... * CORRESPONDING TO X=XA(NMAX),XA(NMAX-1),XA(NMAX-2), ... * * IN CALLING PROGRAM X=XA(IX), IX=NMAX+2-INDX, INDX=2,NMAX * * ICH=1 : LAMBDA-PROTON SYSTEM * ICH=2 : LAMBDA-NEUTRON SYSTEM * C C T : GREEN-TRANSFORMATION MATRIX ON THE PARTICLE BASIS C TI : ,, ,, ,, ,, ,, ISOSPIN ,, C C INPUT : BM = COEFFICIENT MATRIX OF U'' (ISOSPIN=1/2) C BMP = ,, ,, OF U' ( ,, ) C BM(3,3) = COEFFICIENT MATRIX OF U'' (ISOSPIN=3/2) C BMP(3,3)= ,, ,, OF U' ( ,, ) C C OUTPUT : T AND TP=DT/DX C C ************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/STPS/H,NMAX,NSTPD,KSTPD(5),NMIN DIMENSION BM(3,3),BMP(3,3),BMO(3,3),BMPO(3,3) DIMENSION T(3,3),TP(3,3),TI(3,3),TIP(3,3,7), , AI(3,3),TRANS(3,3),TRAND(3,3), , A(3,3),AINV(3,3),BMINV(3,3),TIT(3,3) DATA ICALL/0/,AI/1.D0,0.D0,0.D0, 0.D0,1.D0,0.D0, 0.D0,0.D0,1.D0/ DATA TI/9*0.D0/,TIP/63*0.D0/,BMINV/9*0.D0/,ONE/1.D0/,SGNLD/1.D0/ DATA A /9*0.D0/,AINV/9*0.D0/,TIT/9*0.D0/,ITEST/0/ SAVE TRANS,TRAND,TI,TIP C IF(INDX.GT.7) GOTO 50 IF(ICALL.EQ.0.AND.ICH.EQ.1) CALL TRANLP(TRANS,TRAND) IF(ICALL.EQ.0.AND.ICH.EQ.2) CALL TRANLN(TRANS,TRAND) ICALL=1 C C DEFINITION : T= UNIT MATRIX AT X=XA(NMAX),.....,XA(NMAX-6) C DO 10 K=1,6 KKK=7-K DO 10 I=1,3 DO 10 J=1,3 10 TIP(I,J,KKK+1)=TIP(I,J,KKK) DET=BM(1,1)*BM(2,2)-BM(1,2)*BM(2,1) SGNLD=DSIGN(ONE,DET) BMINV(1,1)=BM(2,2)/DET BMINV(2,2)=BM(1,1)/DET BMINV(1,2)=-BM(1,2)/DET BMINV(2,1)=-BM(2,1)/DET BMINV(3,3)=1.D0/BM(3,3) CALL MULTM(BMINV,BMP,1) DO 11 I=1,2 DO 11 J=1,2 11 TI(I,J)=AI(I,J) C DO 12 I=1,2 DO 12 J=1,2 TIP(I,J,1)=0.D0 DO 13 K=1,2 13 TIP(I,J,1)=TIP(I,J,1)-0.5D0*BMINV(I,K)*TI(K,J) 12 CONTINUE C TI(3,3)=1.0D0/DSQRT(BM(3,3)) TIP(3,3,1)=-0.5D0*TI(3,3)**3*BMP(3,3) GOTO 100 C 50 ID=0 HH=H IX=NMAX+2-INDX DO 500 II=1,NSTPD IF(IX.EQ.(KSTPD(II)-1)) ID=1 500 IF(IX.GT.KSTPD(II)) HH=2.D0*HH IF(ID.NE.1) GOTO 510 C C ADAPTIONS AFTER HALVING THE STEPSIZE : INTERPOLATION C CALL INTPOL(IX,TIP,HH,7) C 510 DET=BM(1,1)*BM(2,2)-BM(1,2)*BM(2,1) SGNNW=DSIGN(ONE,DET) IF(SGNNW.NE.SGNLD) PRINT 512, DET 512 FORMAT(/,' GREEN, WARNING: SIGN CHANGE IN DETERMINANT BM=',D12.5) BMINV(1,1)=BM(2,2)/DET BMINV(2,2)=BM(1,1)/DET BMINV(1,2)=-BM(1,2)/DET BMINV(2,1)=-BM(2,1)/DET BMINV(3,3)=1.D0/BM(3,3) CALL MULTM(BMINV,BMP,1) IF(ITEST.EQ.0) GOTO 35 DO 39 I=1,3 DO 38 J=1,3 38 A(I,J)=0.5D0*BMINV(I,J) 39 IF(ITEST.NE.0) PRINT 37,(A(I,J),J=1,3) 37 FORMAT(/,' DT/DY=A * T , A =',3(D12.5,2X)) DETA=(A(1,1)*A(2,2)-A(1,2)*A(2,1))*A(3,3) VALU1=A(1,1)+A(2,2)+DSQRT((A(1,1)-A(2,2))**2+4*A(1,2)*A(2,1)) VALU2=A(1,1)+A(2,2)-DSQRT((A(1,1)-A(2,2))**2+4*A(1,2)*A(2,1)) IF(ITEST.NE.0) PRINT 36, DETA,VALU1,VALU2,A(3,3) 36 FORMAT(/,' DETERMINANT A =',D12.5,' EIGENVALUES : VALU1= ',D12.5, , ' VALU2= ',D12.5,' VALU3= ',D12.5,/) C 35 DO 51 I=1,3 DO 51 J=1,3 AINV(I,J)=AI(I,J) 51 A(I,J)=AI(I,J)-251.D0*HH*BMINV(I,J)/1440.D0 DET=A(1,1)*A(2,2)-A(1,2)*A(2,1) AINV(1,1)=A(2,2)/DET AINV(2,2)=A(1,1)/DET AINV(1,2)=-A(1,2)/DET AINV(2,1)=-A(2,1)/DET DO 52 I=1,2 DO 52 J=1,2 52 TI(I,J)=TI(I,J)-HH*(646.D0*TIP(I,J,1)-264.D0*TIP(I,J,2)+ 2 106.D0*TIP(I,J,3)- 19.D0*TIP(I,J,4))/720.D0 TI(3,3)=1.0D0/DSQRT(BM(3,3)) CALL MULTM(AINV,TI,2) C KK=6 DO 53 K=1,KK KKK=KK-K+1 DO 53 I=1,3 DO 53 J=1,3 53 TIP(I,J,KKK+1)=TIP(I,J,KKK) DO 54 I=1,2 DO 54 J=1,2 TIP(I,J,1)=0.D0 DO 54 K=1,2 54 TIP(I,J,1)=TIP(I,J,1)- - 0.5D0*BMINV(I,K)*TI(K,J) C TIP(3,3,1)=-0.5D0*TI(3,3)**3*BMP(3,3) C 100 DO 101 I=1,3 DO 101 J=1,3 II=I JJ=J IF(I.EQ.3) II=2 IF(J.EQ.3) JJ=2 C PARTICLE BASIS: BMO (I,J)=TRANS(I,J)*BM (II,JJ) +TRAND(I,J)*BM (3,3) BMPO(I,J)=TRANS(I,J)*BMP (II,JJ) +TRAND(I,J)*BMP(3,3) c T (I,J)=TRANS(I,J)*TI (II,JJ) +TRAND(I,J)*TI(3,3) c TP (I,J)=TRANS(I,J)*TIP (II,JJ,1)+TRAND(I,J)*TIP(3,3,1) C SU(2)-BASIS: T (I,J)= TI (I,J) TP (I,J)= TIP (I,J,1) 101 CONTINUE C DO 3000 I=1,3 C3000 PRINT 3001 , (T (I,J),J=1,3) C3001 FORMAT(/,' GREEN TGR=',3(D12.5,3X)) C DO 4000 I=1,3 C4000 PRINT 4001 , (TP (I,J),J=1,3) C4001 FORMAT(/,' GREEN TGRP=',3(D12.5,3X)) C IF(ITEST.EQ.0) RETURN DO 6000 I=1,3 6000 PRINT 6001 , (TI(I,J),J=1,3),(TIP(I,J,1),J=1,3) 6001 FORMAT(/,' GREEN TI =',3(D12.5,3X),' TIP =',3(D12.5,3X)) C ADIA1=(BM(1,1)-1.D0)/2.D0 ADIA2=(BM(2,2)-1.D0)/2.D0 AOFF=BM(1,2)/2.D0 A33=(BM(3,3)-1.D0)/2.D0 T11=1.D0/DSQRT(1.D0+2.D0*(ADIA1-AOFF)) T22=1.D0/DSQRT(1.D0+2.D0*(ADIA2+AOFF)) GOTO (401,402),ITEST 401 TIT(1,1)=T11 TIT(2,2)=T22 TIT(1,2)=0.D0 TIT(2,1)=0.D0 GOTO 400 402 TIT(1,1)=(T22+T11)/2.D0 TIT(1,2)=(T22-T11)/2.D0 TIT(2,2)=TIT(1,1) TIT(2,1)=TIT(1,2) 400 TIT(3,3)=1.D0/DSQRT(1.D0+2*A33) DO 7000 I=1,3 7000 PRINT 7001 , (TIT(I,J),J=1,3),ITEST 7001 FORMAT(/,' GREEN TIT =',3(D12.5,3X),' ITEST=',I3) C RETURN END C ************************************************************** SUBROUTINE INVER3(A,B) IMPLICIT REAL*8(A-H,O-Z) C ****************************************************************** C C OUTPUT : MATRIX B**(-1) * A (STORED IN LOCATIONS OF: A) C DIMENSION A(3,3),B(3,3) N=3 D=1.0D0 DO 4 K=1,N DIV=B(K,K) D=D*DIV DO 1 J=1,N 1 A(K,J)=A(K,J)/DIV DO 2 J=K,N 2 B(K,J)=B(K,J)/DIV DO 4 I=1,N IF(I.EQ.K) GO TO 4 DET=B(I,K) DO 3 J=K,N 3 B(I,J)=B(I,J)-DET*B(K,J) DO 8 J=1,N 8 A(I,J)=A(I,J)-DET*A(K,J) 4 CONTINUE DS=D IF(DABS(DS).LT.0.1D-15) PRINT 5,D 5 FORMAT(1X,' DETERMINANT INVER3 = ',D25.16) RETURN END C ****************************************************************** SUBROUTINE MULTM(A,B,IS) IMPLICIT REAL*8(A-H,O-Z) C ****************************************************************** C C OUTPUT IS=1 : A * B ( STORED IN LOCATIONS OF MATRIX: A ) C =2 : A * B ( STORED IN LOCATIONS OF MATRIX: B ) C DIMENSION A(3,3),B(3,3),C(6,6) N=3 DO 1 I=1,N DO 1 J=1,N C(I,J)=0.D0 DO 2 K=1,N 2 C(I,J)=C(I,J)+A(I,K)*B(K,J) 1 CONTINUE DO 3 I=1,N DO 3 J=1,N IF(IS.EQ.1) THEN A(I,J)=C(I,J) ELSE B(I,J)=C(I,J) ENDIF 3 CONTINUE RETURN END C ************************************************************** SUBROUTINE INTPOL(IXA,TIP,H,N) C ************************************************************** C INTERPOLATION AT STEPHALVING POINTS IMPLICIT REAL*8(A-H,O-Z) DIMENSION TIP(3,3,7),X(7),Y(7),C(7),A(7,7),B(7,7) IF(N.NE.7) GOTO 100 DO 1 I=1,N 1 X(I)=(I-1)*2*H C DO 2 I=1,3 DO 2 J=1,3 c DO 3 K=1,N 3 Y(K)=TIP(I,J,K) C C POLYNOMIAL CONSTRUCTION C DO 10 K=1,N DO 10 L=1,N A(K,L)=0.D0 B(K,L)=0.D0 A(K,K)=1.D0 10 B(K,K)=1.D0 DO 20 K=1,N XL=1.D0 DO 21 L=1,N A(K,L)=XL 21 XL=X(K)*XL 20 CONTINUE CALL INVER7(B,A,N) DO 40 K=1,N C(K)=0.D0 DO 40 L=1,N 40 C(K)=C(K)+B(K,L)*Y(L) C INTERPOLATION TIP(I,J,7)=TIP(I,J,4) TIP(I,J,5)=TIP(I,J,3) TIP(I,J,3)=TIP(I,J,2) C XK2=1.D0 XK4=1.D0 XK6=1.D0 TIP(I,J,2)=0.D0 TIP(I,J,4)=0.D0 TIP(I,J,6)=0.D0 DO 60 K=1,N TIP(I,J,2)=TIP(I,J,2)+C(K)*XK2 TIP(I,J,4)=TIP(I,J,4)+C(K)*XK4 TIP(I,J,6)=TIP(I,J,6)+C(K)*XK6 XK2=XK2*H XK4=3*XK4*H 60 XK6=5*XK6*H C C PRINT RESULTS INTERPOLATION C C PRINT 29, IXA,H,I,J C 29 FORMAT(//,' IN INTPOL : IXA=',I4,' H=',D12.5,' I=',I1,' J=',I1,/) C PRINT 30, (TIP(I,J,K),K=1,7) C 30 FORMAT(/,' TIP(I,J,K)=',7(D12.5,3X),/) C 2 CONTINUE RETURN 100 PRINT 101, N 101 FORMAT(/,' STOP OCCURRED IN SUBROUTINE INTPOL! REASON :',/, 2 ' ONLY INTERPOLATION WITH N=7 IS ALLOWED',/,' N=',I3) STOP END C ****************************************************************** SUBROUTINE INVER7(A,B,N) IMPLICIT REAL*8(A-H,O-Z) C ****************************************************************** C C OUTPUT : MATRIX B**(-1) * A (STORED IN LOCATIONS OF: A) C DIMENSION A(7,7),B(7,7) IF(N.NE.7) WRITE(*,*) 'WARNING: IN INVER7 N=',N C N=7 : this statement not accepted by g77! D=1.D0 DO 4 K=1,N DIV=B(K,K) D=D*DIV DO 1 J=1,N 1 A(K,J)=A(K,J)/DIV DO 2 J=K,N 2 B(K,J)=B(K,J)/DIV DO 4 I=1,N IF(I.EQ.K) GO TO 4 DET=B(I,K) DO 3 J=K,N 3 B(I,J)=B(I,J)-DET*B(K,J) DO 8 J=1,N 8 A(I,J)=A(I,J)-DET*A(K,J) 4 CONTINUE DS=D c IF(DABS(DS).LT.0.1D-15) PRINT 5,D c 5 FORMAT(1X,' DETERMINANT INVER7 = ',D25.16) RETURN END C ******************************************************************* SUBROUTINE GRNTST(XA,PHI,PHIP,IRET) c c CALLED BY AMATLN FOR CHECKING EIGENVALUES c c NOTE THAT HERE : PHI = M-MATRIX=1 + 2 * PHI ETC. C ******************************************************************* IMPLICIT REAL*8(A-H,O-Z) DIMENSION PHI(3,3),PHIP(3,3),AI(3,3), . PHI2(2,2),PHIP2(2,2),PHI2D(2,2),PHIDH(2,2) DIMENSION O(2,2),OMIN(2,2),U1(2),U2(2) DATA AI/1.D0,0.D0,0.D0,0.D0,1.D0,0.D0,0.D0,0.D0,1.D0/ DATA EPS/1.D-16/,PHI2D/4*0.D0/,PHIDH/4*0.D0/ c DATA PHIH/5.D0/,PHIL/ 0.2D0/,DPHIH/10.D0/,DPHIL/-10.D0/ DATA PHIH/5.D0/,PHIL/ 1.0D0/,DPHIH/10.D0/,DPHIL/-10.D0/ c PRINT 51, XA c 51 FORMAT(72('*'),/,' ENTERING GRNTST : XA=',F10.3) c DO 2000 I=1,3 c2000 PRINT 2001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3) c2001 FORMAT(/,' GRNTST PHI=',3(D9.3,1X),' PHIP=',3(D9.3,1X)) C DO 1 I=1,2 DO 1 J=1,2 PHI2(I,J) = PHI(I,J) c PHIP2(I,J) = PHIP(I,J) 1 CONTINUE C C DIAGONALIZATION PHI2: C A = PHI(1,1) D = PHI(2,2) C = PHI(1,2) C C DECOMPOSITION PHI2-MATRIX: (A+D)/2 + C \SIGMAX + (A-D)/2 \SIGMA3 C =(A+D)/2 + ROOT*\SIGMA\CDOT\NVECTOR C ROOT = DSQRT(C**2+0.25D0*(A-D)**2) IF(ROOT.LT.EPS) RETURN IF(C.NE.0.D0) THEN C C EIGENVALUES: C ALMD1 = 0.5D0*(A+D)+ROOT ALMD2 = 0.5D0*(A+D)-ROOT ENX= C/ROOT ENZ= 0.5D0*(A-D)/ROOT C EIGENVECTORS: ROOTP = 1.D0/DSQRT(2*(1.D0+ENZ)) U1(1) = (1.D0+ENZ)*ROOTP U1(2) = ENX*ROOTP ROOTM = 1.D0/DSQRT(2*(1.D0-ENZ)) U2(1) = (1.D0-ENZ)*ROOTM U2(2) = -ENX*ROOTM C C DIAGONALIZING TRANSFORMATION: C DO 2 J=1,2 O(1,J) = U1(J) O(2,J) = U2(J) OMIN(J,1)= U1(J) OMIN(J,2)= U2(J) 2 CONTINUE ENDIF IF(C.EQ.0.D0) THEN ALMD1 = A ALMD2 = D DO 20 I=1,2 DO 20 J=1,2 O(I,J) = AI(I,J) OMIN(I,J)= AI(I,J) 20 CONTINUE ENDIF DETPH2=ALMD1*ALMD2 DETPHI=DETPH2*PHI(3,3) c PRINT 3001, ALMD1,ALMD2 c3001 FORMAT(/,' GRNTST EIGENVALUES: ALMD1=',D9.3,' ALMD2=',D9.3,/) c PRINT 3002, DETPH2,DETPHI c3002 FORMAT(/,' GRNTST DETERMINANT: DETPH2=',D9.3,' DETPHI=',D9.3,/) c DO 3000 I=1,2 c3000 PRINT 3003, (O(I,J),J=1,2),(OMIN(I,J),J=1,2) c3003 FORMAT(/,' GRNTST O =',2(D9.3,1X),' OMIN=',2(D9.3,1X)) C TEST EIGENVALUES BEFORE GREEN TRANSFORMATION: ITEST = 0 IF(IRET.EQ.0) THEN IF(ALMD1.GT.PHIH) ALMD1=PHIH IF(ALMD2.GT.PHIH) ALMD2=PHIH ENDIF IF(ALMD1.LT.PHIL) ALMD1=PHIL IF(ALMD2.LT.PHIL) ALMD2=PHIL IF(ALMD1.EQ.PHIH.OR.ALMD1.EQ.PHIL) ITEST=1 IF(ALMD2.EQ.PHIH.OR.ALMD2.EQ.PHIL) ITEST=1 IF(ITEST.EQ.0) GOTO 7000 PHI2D(1,1) = ALMD1 PHI2D(2,2) = ALMD2 C CHECK: PHI2D = PHIDH DO 3 I=1,2 DO 3 J=1,2 PHIDH(I,J) = 0.D0 DO 4 K=1,2 DO 4 L=1,2 4 PHIDH(I,J) = PHIDH(I,J) + O(I,K)*PHI2(K,L)*OMIN(L,J) 3 CONTINUE c DO 4000 I=1,2 c4000 PRINT 4001, (PHI2D(I,J),J=1,2),(PHIDH(I,J),J=1,2) c4001 FORMAT(/,' GRNTST PHI2D=',2(D9.3,1X),' PHIDH=',2(D9.3,1X)) C C BACK TRANSFORMATION: C DO 5 I=1,2 DO 5 J=1,2 PHI2(I,J) = 0.D0 DO 6 K=1,2 DO 6 L=1,2 6 PHI2(I,J) = PHI2(I,J) + OMIN(I,K)*PHI2D(K,L)*O(L,J) PHI (I,J) = PHI2(I,J) 5 CONTINUE 7000 IF(PHI(3,3).GT.PHIH) PHI(3,3)=PHIH IF(PHI(3,3).LT.PHIL) PHI(3,3)=PHIL IF(PHI(3,3).EQ.PHIH.OR.PHI(3,3).EQ.PHIL) ITEST=1 IF(ITEST.EQ.0) RETURN DO 7 I=1,2 DO 7 J=1,2 7 PHI(I,J) = PHI2(I,J) c5010 DO 5000 I=1,3 c5000 PRINT 5001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3) c5001 FORMAT(/,' GRNTST PHI=',3(D9.3,1X),' PHIP=',3(D9.3,1X)) c PRINT 62 c 62 FORMAT(' LEAVING GRNTST . ') RETURN END c ******************************************************************* subroutine intpol3(xcall,i,nmax,xa,grpot,cnpot) c ******************************************************************* implicit real*8(a-h,o-z) dimension xa(300),grpot(3,3,3),tm(2,2),fun(2) dimension cnpot(3,3) data method/2/,nch/3/ x = xcall if(xcall.eq.xa(nmax)) x=xa(nmax-2) if(x.lt.xa(1).or.x.gt.xa(nmax)) then write(*,*) ' x-value out of range for Green transf. !!' return endif do 15 ll=1,nch do 15 kk=1,ll c ******************************************************************* c two-point interpolation: f=ay+b if(method.eq.1) then cnpot(kk,ll) = grpot(kk,ll,1) + (x-xa(i))* . (grpot(kk,ll,2)-grpot(kk,ll,1))/ . (xa(i+1)-xa(i)) endif c ******************************************************************* c three-point interpolation: f=ay**2+by+c if(method.eq.2) then cc = grpot(kk,ll,1) y2 = xa(i+2)-xa(i) y1 = xa(i+1)-xa(i) det = (y2-y1)*y1*y2 tm(1,1) = y1/det tm(2,2) = y2**2/det tm(1,2) = -y2/det tm(2,1) = -y1**2/det fun(1) = grpot(kk,ll,3)-cc fun(2) = grpot(kk,ll,2)-cc aa=0.d0 bb=0.d0 do 21 kkk=1,2 aa = aa + tm(1,kkk)*fun(kkk) bb = bb + tm(2,kkk)*fun(kkk) 21 continue y = x-xa(i) cnpot(kk,ll) = aa*y**2+bb*y+cc endif c ******************************************************************* 15 continue do 25 kk=1,nch do 25 ll=1,kk if(kk.ne.ll) .cnpot(kk,ll) = cnpot(ll,kk) 25 continue return end ********************************************************************** C UPDATED VERSION 2012: C AXIAL gecorrigeerd -> +2*GFALL*GFAC1*FTLL0 etc. (NOV 2012) C--------------------------------------------------------------------- C UPDATED VERSION: AUGUST 2011, SEE AXIAL AND AXIALU C UPDATED VERSION: NOVEMBER 2010: SECOND DERIVATIVES FI, FIS FUNCTIONS! C VERSION: JUNE 2009: A LA LPPROGS.02/HVYPOT.YN09.f C CHANGES W.R.T. PREVIOUS VERSION: SEE ROUTINE AXIAL! ********************************************************************** BLOCK DATA HAMS IMPLICIT REAL *8(A-H,O-Z) COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4) DATA HAMPS/1300.D0,1280.D0,1430.D0,1460.D0/ DATA HAMVC/1450.D0,1420.D0,1680.D0,1410.D0/ DATA HAMSC/1450.D0,1370.D0,1580.D0,1430.D0/ END ********************************************************************** C c* SUBROUTINE PSSCA2(NMAX,NLOC,ICSB,P) SUBROUTINE PSSCA2(XA,ICSB,NLOC,P,PX) C C********************************************************************** C C HEAVY PS-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F c* COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF COMMON/HVY/HF(11),GT(11),FT(11),FD(11),FV(11) COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c* COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR , . VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR , . VTENLL ,VTENSS ,VTENLS ,VTENDR , . VSOLL ,VSOSS ,VSOLS ,VSODR , . VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR , . VASOLL ,VASOSS ,VASOLS ,VASODR , . VNNC ,VNNSIG ,VNNTEN ,VNNSO , . FILL ,FISS ,FILS ,FIDR , . DFILL ,DFISS ,DFILS ,DFIDR , . FISLL ,FISSS ,FISLS ,FISDR , . DFISLL ,DFISSS ,DFISLS ,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR , . DFITLL ,DFITSS ,DFITLS ,DFITDR DIMENSION AMPS(5) DATA AMP2,AME2,AMX2,AMK2/1300.D0,1280.D0,1430.D0,1460.D0/ DATA SR3/1.732051D0/,SRPI/1.772454D0/,ICALL/0/ C C NOTE : PION2(IN=1),ETA2 (IN=2),ETAP2(IN=3),KAON2(IN=4) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C C IF(ICALL.EQ.0.AND.NSU3F.EQ.1) THEN AME2 = AMP2 AMX2 = AMP2 AMK2 = AMP2 ICALL= 1 ENDIF DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GPLL = 0.D0 GPSS= -2. *HF(1)*HF(2)*(AMP2/PIM)**2 GPLS= -SR3*HF(1)*HF(3)*(AMP2/PIM)**2 GPDR= HF(1)*HF(2)*(AMP2/PIM)**2 AMPS(1)=AMP2 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1052 GPLL= HF(6)*HF(7)*(AME2/PIM)**2 GPSS= HF(6)*HF(8)*(AME2/PIM)**2 GPLS= 0. GPDR= HF(6)*HF(8)*(AME2/PIM)**2 AMPS(2)=AME2 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1053 GPLL= HF(9)*HF(10)*(AMX2/PIM)**2 GPSS= HF(9)*HF(11)*(AMX2/PIM)**2 GPLS= 0. GPDR= HF(9)*HF(11)*(AMX2/PIM)**2 AMPS(3)=AMX2 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP1 GOTO 1056 1054 GPLL= HF(4)*HF(4)*P*(AMK2/PIM)**2 GPSS= -HF(5)*HF(5)*P*(AMK2/PIM)**2 GPLS= -SR3*HF(4)*HF(5)*P*(AMK2/PIM)**2 GPDR= 2*HF(5)*HF(5)*P*(AMK2/PIM)**2 AMPS(4)=AMK2 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMKA GOTO 1056 C 1056 ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMPS(IN)/ALM1 RATM2=AMPS(IN)/ALM2 RATM3=AMPS(IN)/ALM3 FAC1=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(1)) FAC2=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(2)) FAC3=AMPS(IN)*AMPS(IN)/(AM(1)*AMH) C c* DO 104 I=2,NMAX c* X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMPS(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMPS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMPS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMPS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN) FTENLL = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN) FSOLL = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN) FTENSS = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS(IN) FSOSS = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS(IN) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN) FTENLS = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS(IN) FSOLS = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS(IN) C FCLL1 = FCLL0 - VKULL*AMPS(IN) FCSS1 = FCSS0 - VKUSS*AMPS(IN) FCLS1 = FCLS0 - VKULS*AMPS(IN) C VSIGLL = VSIGLL + GPLL*FCLL1/3.D0 VTENLL = VTENLL + GPLL*FTENLL VSIGDR = VSIGDR + GPDR*FCSS1/3.D0 VTENDR = VTENDR + GPDR*FTENSS VSIGSS = VSIGSS + GPSS*FCSS1/3.D0 VTENSS = VTENSS + GPSS*FTENSS VSIGLS = VSIGLS + GPLS*FCLS1/3.D0 VTENLS = VTENLS + GPLS*FTENLS C------------------------------------------------------------ C BROWN, DOWNS AND IDDINGS TERMS: C HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.4) THEN c PX = -1D0 VASOLL = VASOLL - PX*GPLL*FSOLL* . 4*(AMY(1)-AM(1))/(AMY(1)+AM(1)) VASOSS = VASOSS - PX*GPSS*FSOSS* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) VASOLS = VASOLS - PX*GPLS*FSOLS* . 4*(AMY(3)-AM(3))/(AMY(3)+AM(3)) VASODR = VASODR - PX*GPDR*FSODR* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) ENDIF C 104 CONTINUE C 1040 CONTINUE C RETURN END C********************************************************************** C ** SUBROUTINE VECTOR2(NMAX,NLOC,ICSB,P) SUBROUTINE VECTOR2(XA,ICSB,NLOC,P,PX) C C********************************************************************** C C HEAVY VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F c* COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF COMMON/HVY/HFPS(11),GT(11),FT(11),FD(11),FV(11) COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4) COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c* COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR , . VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR , . VTENLL ,VTENSS ,VTENLS ,VTENDR , . VSOLL ,VSOSS ,VSOLS ,VSODR , . VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR , . VASOLL ,VASOSS ,VASOLS ,VASODR , . VNNC ,VNNSIG ,VNNTEN ,VNNSO , . FILL ,FISS ,FILS ,FIDR , . DFILL ,DFISS ,DFILS ,DFIDR , . FISLL ,FISSS ,FISLS ,FISDR , . DFISLL ,DFISSS ,DFISLS ,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR , . DFITLL ,DFITSS ,DFITLS ,DFITDR DIMENSION AMVC(4),FVC(4),XM1(3),XM2(3) c DATA AMVC/1450.D0,1420.D0,1680.D0,1410.D0/ DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/ . ,FMNL/1.D0/,ICALL/0/ C C NOTE : RHO'(IN=1),OME'(IN=2),PHI'(IN=3),KSTAR'(IN=4) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) C IF(ICALL.EQ.0.AND.NSU3F.EQ.1) THEN HAMVC(2)= HAMVC(1) HAMVC(3)= HAMVC(1) HAMVC(4)= HAMVC(1) ICALL= 1 ENDIF c* AMKS = AMVC(4) AMKS = HAMVC(4) PROSLL=-(AM(1)-AMY(1))*(AMY(1)-AM(1))/AMKS/AMKS PROSLS=-(AM(1)-AMY(1))*(AMY(2)-AM(1))/AMKS/AMKS PROSSS=-(AM(1)-AMY(2))*(AMY(2)-AM(1))/AMKS/AMKS C DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GDLL = 0.D0 GDFLL= 0.D0 GFDLL= 0.D0 GFLL = 0.D0 GDSS = -2*FD(1)*FD(2) GDFSS= -2*FD(1)*FV(2) GFDSS= -2*FV(1)*FD(2) GFSS = -2*FV(1)*FV(2) GDLS = -FD(1)*FD(3)*SR3 GDFLS= -FD(1)*FV(3)*SR3 GFDLS= -FV(1)*FD(3)*SR3 GFLS = -FV(1)*FV(3)*SR3 GDDR = FD(1)*FD(2) GDFDR= FD(1)*FV(2) GFDDR= FV(1)*FD(2) GFDR = FV(1)*FV(2) AMVC(1) = HAMVC(1) IF(IN.EQ.1) THEN XM1(1)=AM(1) XM1(2)=AM(1) XM1(3)=AM(1) XM2(1)=AMY(1) XM2(2)=AMY(2) XM2(3)=AMH ENDIF GOTO 1056 1052 GDLL = FD(6)*FD(7) GDFLL= FD(6)*FV(7) GFDLL= FV(6)*FD(7) GFLL = FV(6)*FV(7) GDSS = FD(6)*FD(8) GDFSS= FD(6)*FV(8) GFDSS= FV(6)*FD(8) GFSS = FV(6)*FV(8) GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS AMVC(2) = HAMVC(2) GOTO 1056 1053 GDLL = FD(9)*FD(10) GDFLL= FD(9)*FV(10) GFDLL= FV(9)*FD(10) GFLL = FV(9)*FV(10) GDSS = FD(9)*FD(11) GDFSS= FD(9)*FV(11) GFDSS= FV(9)*FD(11) GFSS = FV(9)*FV(11) GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS AMVC(3) = HAMVC(3) GOTO 1056 1054 GDLL = FD(4)*FD(4)*P GDFLL= FD(4)*FV(4)*P GFDLL= FV(4)*FD(4)*P GFLL = FV(4)*FV(4)*P GDSS = -FD(5)*FD(5)*P GDFSS= -FD(5)*FV(5)*P GFDSS= -FV(5)*FD(5)*P GFSS = -FV(5)*FV(5)*P GDLS = -FD(4)*FD(5)*P*SR3 GDFLS= -FD(4)*FV(5)*P*SR3 GFDLS= -FV(4)*FD(5)*P*SR3 GFLS = -FV(4)*FV(5)*P*SR3 GDDR = -2*GDSS GDFDR= -2*GDFSS GFDDR= -2*GFDSS GFDR = -2*GFSS AMVC(4) = HAMVC(4) C CASE IN=4: XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMLS XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMLS C 1056 FVC(IN) = 1.D0 IF(IMODEL.EQ.1) ALAM=ALMOBE IF(IMODEL.GE.2) THEN ALAM = ALMV8 IF(IN.EQ.3) ALAM=ALMV1 IF(IN.EQ.4) ALAM=ALMKS ENDIF ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMVC(IN)/ALM1 RATM2=AMVC(IN)/ALM2 RATM3=AMVC(IN)/ALM3 FAC0=AMVC(IN)*AMVC(IN)/AMPRO/AMPRO FAC1=AMVC(IN)*AMVC(IN)/(XM1(1)*XM2(1)) FAC2=AMVC(IN)*AMVC(IN)/(XM1(2)*XM2(2)) FAC3=AMVC(IN)*AMVC(IN)/(XM1(3)*XM2(3)) FFAC1 = XM2(1)/XM1(1)-XM1(1)/XM2(1) FFAC2 = XM2(2)/XM1(2)-XM1(2)/XM2(2) FFAC3 = XM2(3)/XM1(3)-XM1(3)/XM2(3) AMVC2 = AMVC(IN)**2 C CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM1(1)+GDFLL/XM2(1))*AMVC(IN)**2 . /(4.*AMPRO) CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM1(2)+GDFSS/XM2(2))*AMVC(IN)**2 . /(4.*AMPRO) CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM1(3)+GDFLS/XM2(3))*AMVC(IN)**2 . /(4.*AMPRO) CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM1(2)+GDFDR/XM2(2))*AMVC(IN)**2 . /(4.*AMPRO) CSLL1= GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1)+GFLL*XM1(1)*XM2(1)/AMPRO) . /AMPRO CSSS1= GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2)+GFSS*XM1(2)*XM2(2)/AMPRO) . /AMPRO CSLS1= GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3)+GFLS*XM1(3)*XM2(3)/AMPRO) . /AMPRO CSDR1= GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2)+GFDR*XM1(2)*XM2(2)/AMPRO) . /AMPRO CTLL0= CSLL1 CTSS0= CSSS1 CTLS0= CSLS1 CTDR0= CSDR1 COLL0= 1.5D0*GDLL+(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO COSS0= 1.5D0*GDSS+(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO COLS0= 1.5D0*GDLS+(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO CODR0= 1.5D0*GDDR+(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO CALL0= .GDLL*FFAC1/4D0-(GFDLL-GDFLL)*DSQRT(XM1(1)*XM2(1))/AMPRO CASS0= .GDSS*FFAC2/4D0-(GFDSS-GDFSS)*DSQRT(XM1(2)*XM2(2))/AMPRO CALS0= .GDLS*FFAC3/4D0-(GFDLS-GDFLS)*DSQRT(XM1(3)*XM2(3))/AMPRO CADR0= .GDDR*FFAC2/4D0-(GFDDR-GDFDR)*DSQRT(XM1(2)*XM2(2))/AMPRO CALL1= GFLL*FFAC1*AMVC2/(16*AMPRO*AMPRO) CASS1= GFSS*FFAC2*AMVC2/(16*AMPRO*AMPRO) CALS1= GFLS*FFAC3*AMVC2/(16*AMPRO*AMPRO) CADR1= GFDR*FFAC2*AMVC2/(16*AMPRO*AMPRO) C BROWN, DOWNS AND IDDINGS TERM: C HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.5) THEN c PX = -1D0 CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2* . (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1)) CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2* . (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3)) CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) ENDIF CO2LL= GDLL+4*(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO + + 8*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO CO2SS= GDSS+4*(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO + + 8*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO CO2LS= GDLS+4*(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO + + 8*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO CO2DR= GDDR+4*(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO + + 8*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO C ** DO 104 I=2,NMAX ** X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMVC(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMVC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMVC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMVC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENLL = FVC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOLL = FVC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2LL = 3*FTENLL/(X*X) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENSS = FVC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOSS = FVC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2SS = 3*FTENLL/(X*X) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENLS = FVC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOLS = FVC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2LS = 3*FTENLL/(X*X) C FCLL1 = FCLL0 - FVC(IN)*VKULL*AMVC(IN) FCSS1 = FCSS0 - FVC(IN)*VKUSS*AMVC(IN) FCLS1 = FCLS0 - FVC(IN)*VKULS*AMVC(IN) FCLL2 = FCLL1+ . FVC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMVC(IN)/RATM1/RATM1 FCSS2 = FCSS1+ . FVC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMVC(IN)/RATM2/RATM2 FCLS2 = FCLS1+ . FVC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMVC(IN)/RATM3/RATM3 FTLL1 = FTENLL - FVC(IN)*XLAM1*XLAM1*VKULL*AMVC(IN) . / (3*RATM1*RATM1) FTSS1 = FTENSS - FVC(IN)*XLAM2*XLAM2*VKUSS*AMVC(IN) . / (3*RATM2*RATM2) FTLS1 = FTENLS - FVC(IN)*XLAM3*XLAM3*VKULS*AMVC(IN) . / (3*RATM3*RATM3) FOLL1 = FSOLL - FVC(IN)*VKULL*AMVC(IN) . / (2*RATM1*RATM1) FOSS1 = FSOSS - FVC(IN)*VKUSS*AMVC(IN) . / (2*RATM2*RATM2) FOLS1 = FSOLS - FVC(IN)*VKULS*AMVC(IN) . / (2*RATM3*RATM3) C VCLL = VCLL + GDLL*FCLL0 + CCLL1*FCLL1 + . GFLL*FAC0*FAC1*FCLL2/16.D0 . + (1-INRS)*FAC1*(GDLL*FAC1/64.D0+(GDFLL . +GFDLL)*DSQRT(FAC0*FAC1)/16.D0)*FCLL2 VCSS = VCSS + GDSS*FCSS0 + CCSS1*FCSS1 + . GFSS*FAC0*FAC2*FCSS2/16.D0 . + (1-INRS)*FAC2*(GDSS*FAC2/64.D0+(GDFSS . +GFDSS)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2 VCLS = VCLS + GDLS*FCLS0 + CCLS1*FCLS1 + . GFLS*FAC0*FAC3*FCLS2/16.D0 . + (1-INRS)*FAC3*(GDLS*FAC3/64.D0+(GDFLS . +GFDLS)*DSQRT(FAC0*FAC3)/16.D0)*FCLS2 VCDR = VCDR + GDDR*FCSS0 + CCDR1*FCSS1 + . GFDR*FAC0*FAC2*FCSS2/16.D0 . + (1-INRS)*FAC2*(GDDR*FAC2/64.D0+(GDFDR . +GFDDR)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2 C VSIGLL = VSIGLL + (CSLL1*FCLL1 + INRS*GFLL*FAC0*FCLL2/8.D0) . * FAC1/6.D0 VSIGSS = VSIGSS + (CSSS1*FCSS1 + INRS*GFSS*FAC0*FCSS2/8.D0) . * FAC2/6.D0 VSIGLS = VSIGLS + (CSLS1*FCLS1 + INRS*GFLS*FAC0*FCLS2/8.D0) . * FAC3/6.D0 VSIGDR = VSIGDR + (CSDR1*FCSS1 + INRS*GFDR*FAC0*FCSS2/8.D0) . * FAC2/6.D0 C VTENLL = VTENLL - (CTLL0*FTENLL + INRS*GFLL*FAC0*FTLL1/8.D0) . * FAC1/4.D0 VTENSS = VTENSS - (CTSS0*FTENSS + INRS*GFSS*FAC0*FTSS1/8.D0) . * FAC2/4.D0 VTENLS = VTENLS - (CTLS0*FTENLS + INRS*GFLS*FAC0*FTSS1/8.D0) . * FAC3/4.D0 VTENDR = VTENDR - (CTDR0*FTENSS + INRS*GFDR*FAC0*FTSS1/8.D0) . * FAC2/4.D0 C VSOLL = VSOLL - (COLL0*FSOLL + GFLL*FAC0*FOLL1*3/8.D0) . * FAC1 VSOSS = VSOSS - (COSS0*FSOSS + GFSS*FAC0*FOSS1*3/8.D0) . * FAC2 VSOLS = VSOLS - (COLS0*FSOLS + GFLS*FAC0*FOLS1*3/8.D0) . * FAC3 VSODR = VSODR - (CODR0*FSOSS + GFDR*FAC0*FOSS1*3/8.D0) . * FAC2 C VASOLL= VASOLL - (CALL0*FSOLL-CALL1*FOLL1)*FAC1 VASOSS= VASOSS - (CASS0*FSOSS-CASS1*FOSS1)*FAC2 VASOLS= VASOLS - (CALS0*FSOLS-CALS1*FOLS1)*FAC3 VASODR= VASODR - (CADR0*FSOSS-CADR1*FOSS1)*FAC2 C VSO2LL = VSO2LL + CO2LL*FSO2LL*FAC1*FAC1/16.D0 VSO2SS = VSO2SS + CO2SS*FSO2SS*FAC2*FAC2/16.D0 VSO2LS = VSO2LS + CO2LS*FSO2LS*FAC3*FAC3/16.D0 VSO2DR = VSO2DR + CO2DR*FSO2SS*FAC2*FAC2/16.D0 IF(IN.NE.4) GOTO 105 C C K-STAR : CONTRIBUTION SECOND TERM IN VECTOR MESON PROPAGATOR C VCLL = VCLL - GDLL*PROSLL*FCLL0*(1.D0-FAC1/4.D0) VCSS = VCSS - GDSS*PROSSS*FCSS0*(1.D0-FAC2/4.D0) VCLS = VCLS - GDLS*PROSLS*FCLS0*(1.D0-FAC3/4.D0) VCDR = VCDR - GDDR*PROSSS*FCSS0*(1.D0-FAC2/4.D0) C VSOLL = VSOLL - GDLL*PROSLL*FSOLL*FAC1/2.D0 VSOSS = VSOSS - GDSS*PROSSS*FSOSS*FAC2/2.D0 VSOLS = VSOLS - GDLS*PROSLS*FSOLS*FAC3/2.D0 VSODR = VSODR - GDDR*PROSSS*FSOSS*FAC2/2.D0 C VASOLL = VASOLL - GDLL*PROSLL*FSOLL*FFAC1*FAC1/4.D0 VASOSS = VASOSS - GDSS*PROSSS*FSOSS*FFAC2*FAC2/4.D0 VASOLS = VASOLS - GDLS*PROSLS*FSOLS*FFAC3*FAC3/4.D0 VASODR = VASODR - GDDR*PROSSS*FSOSS*FFAC2*FAC2/4.D0 C VSO2LL = VSO2LL - GDLL*PROSLL*FSO2LL*FAC1*FAC1/16.D0 VSO2SS = VSO2SS - GDSS*PROSSS*FSO2SS*FAC2*FAC2/16.D0 VSO2LS = VSO2LS - GDLS*PROSLS*FSO2LS*FAC3*FAC3/16.D0 VSO2DR = VSO2DR - GDDR*PROSSS*FSO2SS*FAC2*FAC2/16.D0 C 105 IF(NLOC.EQ.0) GOTO 104 FILL = FILL + 1.5D0*REDMM*GDLL*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + 1.5D0*REDMM*GDSS*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + 1.5D0*REDMM*GDLS*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + 1.5D0*REDMM*GDDR*FCSS0/(XM1(2)*XM2(2)) C DFILL =DFILL -1.5D0*REDMM*GDLL*FSOLL*X*FAC1/AMVC(IN) DFISS =DFISS -1.5D0*REDMM*GDSS*FSOSS*X*FAC2/AMVC(IN) DFILS =DFILS -1.5D0*REDMM*GDLS*FSOLS*X*FAC3/AMVC(IN) DFIDR =DFIDR -1.5D0*REDMM*GDDR*FSOSS*X*FAC2/AMVC(IN) C 104 CONTINUE C c print spin-orbit potentials: * write(*,*) ' VECTOR2: x=',xa,' IN=',in,' vsoll=',vsoll, * .' vasoll=',vasoll 1040 CONTINUE C RETURN END c--------------------------------------------------------------------- c version: november 2012: C********************************************************************** ** SUBROUTINE AXIAL(NMAX,NLOC,ICSB,P) SUBROUTINE AXIAL(XA,ICSB,NLOC,LC,P,PX) C C********************************************************************** C VERSION JUNE 2009: C 1) WITH CORRECT B-FIELD FORMALISM POTENTIALS!! C 2) WITH RKS91-TREATMENT QUADRATIC-SPIN-ORBIT C 3) DIRECT (FA) AND DERIVATIVE (FFA) COUPLINGS C 4) THREE OPTIONS: IBLFD=1: LTA-METHOD C IBFLD=2: OM-METHOD, IBFLD=3: NLT-METHOD C********************************************************************** C DIRECT (FA) AND DERIVATIVE (FFA) COUPLINGS C********************************************************************** C C AXIAL MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C C------------------------------------------------------------------------ C IN MOMENTUM SPACE AXIAL-EXCHANGE: C------------------------------------------------------------------------ C C FIRST TERM PROPAGATOR: C 1. LOCAL-TENSOR-APPROXIMATION (LTA): C V_A^(1) = -GA2*[[(1+(Q2+K2/4)/(6M'M)](SIGMA1.SIGMA2)+ C +(2/M'M)[(SIGMA1.Q)(SIGMA2.Q)-Q2(SIGMA1.SIGMA2)/3] C -(1/4M'M)[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3] C +(i/4M'M)(SIGMA1+SIGMA2).QXK ]]/(K2+MA2) C------------------------------------------------------------------------ C 2. USED OKUBO-MARSHAK IDENTITY TO ELIMINATE (SIGMA1.Q)(SIGMA2.Q)-TERM: C V_A^(1) => -GA2*[ {1-K2/(6M'M)+5(Q2+K2/4)/(6M'M)}(SIGMA1.SIGMA2)+ C -(1/4M'M){-1+8(Q2+K2/4)}[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3] C +(i/4M'M)(SIGMA1+SIGMA2).QXK -2/(M'M)(SIGMA1.QxK)(SIGMA2.QxK)/K2 ] C /(K2+MA2) C------------------------------------------------------------------------ C 3. NLT-METHOD RKS91 FOR EVALUATION OF (SIGMA1.Q)(SIGMA2.Q)-TERM: C V_A^(1) => -GA2*[ {1-2K2/(3M'M)+3(Q2+K2/4)/(2M'M)}(SIGMA1.SIGMA2)+ C +(1/4M'M){-1+8(Q2+K2/4)}[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3] C +(i/4M'M)(SIGMA1+SIGMA2).QXK -2/(M'M)(SIGMA1.QxK)(SIGMA2.QxK)/K2 ] C /(K2+MA2) C -GA2*[(2/M'M){[SIGMA1.QXK][SIGMA2.QXK].H(K2)-V(K,Q)}] C********************************************************************** C C NOTE : A1(1270)(IN=1),D=F1(1285)(IN=2),E=F1(1420)(IN=3) C C COUPLING: A LA CHIRAL LAGR., SEE STOKS & RIJKEN (NUCL.PHYS. A613 (1997)) C C PROPAGATOR OPTIONS: A) PROCA,IBFLD=0, B) B-FIELD FORMALISM, IBFLD=1,2,3 C---------------------------------------------------------------------- C IN THIS VERSION PROCA-PROPAGATOR NOT INCLUDED -> ONLY IBFLD=1,2,3 !! C********************************************************************** IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX COMMON/AMSAX/AMA1,AMD1,AME1,AMK1 COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK * COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR , . VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR , . VTENLL ,VTENSS ,VTENLS ,VTENDR , . VSOLL ,VSOSS ,VSOLS ,VSODR , . VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR , . VASOLL ,VASOSS ,VASOLS ,VASODR , . VNNC ,VNNSIG ,VNNTEN ,VNNSO , . FILL ,FISS ,FILS ,FIDR , . DFILL ,DFISS ,DFILS ,DFIDR , . FISLL ,FISSS ,FISLS ,FISDR , . DFISLL ,DFISSS ,DFISLS ,DFISDR , . FITLL ,FITSS ,FITLS ,FITDR , . DFITLL ,DFITSS ,DFITLS ,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS, DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS, DDFSDR DIMENSION AMAX(4) DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/ c DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1273.D0/ !11-version DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1400.D0/ !16-version DATA IBFLD/3/,ICALL/0/,FZERO/0.D0/,AMCRA/750.D0/ DATA CFSIG/0.D0/,CFTEN/0.D0/,CFFIS/0.D0/ DATA NS/0/ C ------------------------------------------------------------------ C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C ------------------------------------------------------------------ C IF(ICALL.EQ.0) THEN IF(IBFLD.EQ.1.and.NS.NE.0) .WRITE(*,*) ' AXIALYN.NLT: LTA-TREATMENT, IBFLD=',IBFLD IF(IBFLD.EQ.2.and.NS.NE.0) .WRITE(*,*) ' AXIALYN.NLT: OM-TREATMENT, IBFLD=',IBFLD IF(IBFLD.EQ.3.and.NS.NE.0) .WRITE(*,*) ' AXIALYN.NLT: NLT-TREATMENT, IBFLD=',IBFLD c WRITE(*,*) ' AXIALYN.NLT: IGRAZ=',IGRAZ IF(IBFLD.LE.1) THEN CFSIG= 1.D0 CFTEN=-0.75D0 CFFIS= 1.D0 ENDIF IF(IBFLD.EQ.2) THEN CFSIG= 1.D0 CFTEN=+0.25D0 CFFIS= 5.D0 ENDIF IF(IBFLD.EQ.3) THEN CFSIG= 4.D0 CFTEN=+0.25D0 CFFIS= 9.D0 ENDIF C --------------------------------------------------------------------- IF(NSU3F.EQ.1) THEN AMD1 = AMA1 AME1 = AMA1 AMK1 = AMA1 ENDIF ICALL=1 ENDIF C --------------------------------------------------------------------- c write(*,*) 'IN AXIAL.08: FFA=0!' c do 1672 kk=1,11 c1672 ffa(kk)=0.d0 DIV1 =1.D0/(AM(1)*AMY(1)) DIV2 =1.D0/(AM(1)*AMY(2)) DIV3 =1.D0/(AM(1)*AMH ) C RATIO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT: SOALL = 0.5D0*(AMNN/AMLN-AMLN/AMNN) SOALS = 0.5D0*(AMNN/AMH -AMH /AMNN) SOASS = 0.5D0*(AMNN/AMSN-AMSN/AMNN) DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GALL= 0.D0 GASS= -2*FA(1)*FA(2) GALS= -SR3*FA(1)*FA(3) GADR= FA(1)*FA(2) FFALL= 0.D0 FFASS= -2*FFA(1)*FFA(2) FFALS= -SR3*FFA(1)*FFA(3) FFADR= FFA(1)*FFA(2) GFALL= 0.D0 GFASS= -2*(FA(1)*FFA(2)+FFA(1)*FA(2)) GFALS= -SR3*(FA(1)*FFA(3)+FFA(1)*FA(3)) GFADR= FA(1)*FFA(2)+FFA(1)*FA(2) AMAX(1)=AMA1 GOTO 1055 1052 GALL= FA(6)*FA(7) GASS= FA(6)*FA(8) GALS= 0.D0 GADR= FA(6)*FA(8) FFALL= FFA(6)*FFA(7) FFASS= FFA(6)*FFA(8) FFALS= 0.D0 FFADR= FFA(6)*FFA(8) GFALL= FA(6)*FFA(7)+FFA(6)*FA(7) GFASS= FA(6)*FFA(8)+FFA(6)*FA(8) GFALS= 0.D0 GFADR= FA(6)*FFA(8)+FFA(6)*FA(8) AMAX(2)=AMD1 ! AUGUST 2011 GOTO 1055 1053 GALL= FA(9)*FA(10) GASS= FA(9)*FA(11) GALS= 0.D0 GADR= FA(9)*FA(11) FFALL= FFA(9)*FFA(10) FFASS= FFA(9)*FFA(11) FFALS= 0.D0 FFADR= FFA(9)*FFA(11) GFALL= FA(9)*FFA(10)+FFA(9)*FA(10) GFASS= FA(9)*FFA(11)+FFA(9)*FA(11) GFALS= 0.D0 GFADR= FA(9)*FFA(11)+FFA(9)*FA(11) AMAX(3)=AME1 ! AUGUST 2011 GOTO 1055 1054 GALL= FA(4)*FA(4)*P GASS= -FA(5)*FA(5)*P GALS= -SR3*FA(4)*FA(5)*P GADR= 2*FA(5)*FA(5)*P FFALL= FFA(4)*FFA(4)*P FFASS= -FFA(5)*FFA(5)*P FFALS= -SR3*FFA(4)*FFA(5)*P FFADR= 2*FFA(5)*FFA(5)*P GFALL= (FA(4)*FFA(4)+FFA(4)*FA(4))*P GFASS= -(FA(5)*FFA(5)+FFA(5)*FA(5))*P GFALS= -SR3*(FA(4)*FFA(5)+FFA(4)*FA(5))*P GFADR= 2*(FA(5)*FFA(5)+FFA(5)*FA(5))*P AMAX(4)=AMK1 C 1055 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMAX IF(ALAM.EQ.0.D0) ALAM=ALMP8 IF(IN.EQ.2.AND.ALMAX.EQ.0.D0) ALAM=ALMP1 IF(IN.EQ.4.AND.ALMAX.EQ.0.D0) ALAM=ALMKA ENDIF AMAX2=AMAX(IN)*AMAX(IN) ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMAX(IN)/ALM1 RATM2=AMAX(IN)/ALM2 RATM3=AMAX(IN)/ALM3 FAC1 =AMAX(IN)**2/(AM(1)*AMY(1)) FAC2 =AMAX(IN)**2/(AM(1)*AMY(2)) FAC3 =AMAX(IN)**2/(AM(1)*AMH ) IF(IZAX.NE.0) FZERO = (AMAX(IN)/AMCRA)**2 C FOR DERIVATIVE TERMS: FFAC1 = AMAX(IN)**4/(4*AM(1)*AMY(1)*AMPRO**2) FFAC2 = AMAX(IN)**4/(4*AM(1)*AMY(2)*AMPRO**2) FFAC3 = AMAX(IN)**4/(4*AM(1)*AMH*AMPRO**2) GFAC1 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMY(1))*AMPRO) GFAC2 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMY(2))*AMPRO) GFAC3 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMH)*AMPRO) C c* DO 104 I=2,NMAX c* X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMAX(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLL0 = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLL1 = FCLL0 - VKULL*AMAX(IN) DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM DFCLL1 = DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN) DFTLL0 = DFCLL1/3.D0-3*FTLL0*PIM/XA FTLL1 = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTSS0 = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FCSS1 = FCSS0 - VKUSS*AMAX(IN) DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM DFCSS1 = DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN) DFTSS0 = DFCSS1/3.D0-3*FTSS0*PIM/XA FTSS1 = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLS0 = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLS1 = FCLS0 - VKULS*AMAX(IN) DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM DFCLS1 = DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN) DFTLS0 = DFCLS1/3.D0-3*FTLS0*PIM/XA FTLS1 = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3) c IF(IZAX.NE.0) THEN FCLL2 = FCLL1 + (1.5D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/RATM1/RATM1 DFCLL2 = DFCLL1 -ALM1*XLAM1*(2.5D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/RATM1/RATM1 FTLL1 = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1) DFTLL1 = DFTLL0- ALM1*XLAM1*(1D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/(3*RATM1*RATM1) FSOLL1 = FSOLL0 - 0.5D0*(ALM1/AMAX(IN))**2*VKULL*AMAX(IN) FCSS2 = FCSS1 + (1.5D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/RATM2/RATM2 DFCSS2 = DFCSS1 -ALM2*XLAM2*(2.5D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/RATM2/RATM2 FTSS1 = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2) DFTSS1 = DFTSS0- ALM2*XLAM2*(1D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/(3*RATM2*RATM2) FSOSS1 = FSOSS0 - 0.5D0*(ALM2/AMAX(IN))**2*VKUSS*AMAX(IN) FCLS2 = FCLS1 + (1.5D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/RATM3/RATM3 DFCLS2 = DFCLS1 -ALM3*XLAM3*(2.5D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/RATM3/RATM3 FTLS1 = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3) DFTLS1 = DFTLS0- ALM3*XLAM3*(1D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/(3*RATM3*RATM3) FSOLS1 = FSOLS0 - 0.5D0*(ALM3/AMAX(IN))**2*VKULS*AMAX(IN) FO2LS1 = -3*FTLS0/(X*X) C* NO K^4-TERMS: c IF(IZAX.NE.2) THEN FCLL2 = 0D0 FCSS2 = 0D0 FCLS2 = 0D0 DFCLL2 = 0D0 DFCSS2 = 0D0 DFCLS2 = 0D0 FTLL1 = 0D0 FTSS1 = 0D0 FTLS1 = 0D0 DFTLL1 = 0D0 DFTSS1 = 0D0 DFTLS1 = 0D0 C* NO FITEN! c ENDIF C FOR LTA,OM,NLT: NO Q12 and NON-LOCAL S12: FO2LL0 = 0.D0 FO2LS0 = 0.D0 FO2SS0 = 0.D0 FO2LL1 = 0.D0 FO2LS1 = 0.D0 FO2SS1 = 0.D0 c ENDIF C--------------------------------------------------------------- C C FIRST TERM AXIAL PROPAGATOR: C C--------------------------------------------------------------- VSIGLL = VSIGLL - GALL*(FCLL0+FAC1*FCLL1*CFSIG/6D0) VSIGSS = VSIGSS - GASS*(FCSS0+FAC2*FCSS1*CFSIG/6D0) VSIGLS = VSIGLS - GALS*(FCLS0+FAC3*FCLS1*CFSIG/6D0) VSIGDR = VSIGDR - GADR*(FCSS0+FAC2*FCSS1*CFSIG/6D0) VTENLL = VTENLL + CFTEN *GALL*FAC1 *FTLL0 VTENSS = VTENSS + CFTEN *GASS*FAC2 *FTSS0 VTENLS = VTENLS + CFTEN *GALS*FAC3 *FTLS0 VTENDR = VTENDR + CFTEN *GADR*FAC2 *FTSS0 VSOLL = VSOLL - 0.5D0*GALL*FAC1 *FSOLL0 VSOSS = VSOSS - 0.5D0*GASS*FAC2 *FSOSS0 VSOLS = VSOLS - 0.5D0*GALS*FAC3 *FSOLS0 VSODR = VSODR - 0.5D0*GADR*FAC2 *FSOSS0 VSO2LL = VSO2LL + 2.0D0*GALL*FAC1 *FO2LL0 VSO2SS = VSO2SS + 2.0D0*GASS*FAC2 *FO2SS0 VSO2LS = VSO2LS + 2.0D0*GALS*FAC3 *FO2LS0 VSO2DR = VSO2DR + 2.0D0*GADR*FAC2 *FO2SS0 c------------------------------------------------------------- c check sign vasoll etc. ! c VASOLL = VASOLL + 0.5D0*GALL*FAC1 *FSOLL0 c . *SOALL VASOLL = VASOLL - 0.5D0*GALL*FAC1 *FSOLL0 . *SOALL VASOSS = VASOSS - 0.5D0*GASS*FAC2 *FSOSS0 . *SOASS VASOLS = VASOLS - 0.5D0*GALS*FAC3 *FSOLS0 . *SOALS VASODR = VASODR - 0.5D0*GADR*FAC2 *FSOSS0 . *SOASS C--------------------------------------------------------------- C BROWN, DOWNS AND IDDINGS TERM: C HERE, INSTEAD OF P, WE HAVE P_x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.4) THEN c PX = -1D0 VASOLL = VASOLL - PX*GALL*FAC1 *FSOLL0 . *SOALL VASOSS = VASOSS - PX*GASS*FAC2 *FSOSS0 . *SOASS VASOLS = VASOLS - PX*GALS*FAC3 *FSOLS0 . *SOALS VASODR = VASODR - PX*GADR*FAC2 *FSOSS0 . *SOASS ENDIF C--------------------------------------------------------------- FISLL = FISLL - CFFIS*GALL*FCLL0*DIV1*REDM(1)/6.D0 FISSS = FISSS - CFFIS*GASS*FCSS0*DIV2*REDM(2)/6.D0 FISLS = FISLS - CFFIS*GALS*FCLS0*DIV3*REDM(3)/6.D0 FISDR = FISDR - CFFIS*GADR*FCSS0*DIV2*REDM(2)/6.D0 DFISLL = DFISLL - CFFIS*GALL*DFCLL0*DIV1*REDM(1)/6.D0 DFISSS = DFISSS - CFFIS*GASS*DFCSS0*DIV2*REDM(2)/6.D0 DFISLS = DFISLS - CFFIS*GALS*DFCLS0*DIV3*REDM(3)/6.D0 DFISDR = DFISDR - CFFIS*GADR*DFCSS0*DIV2*REDM(2)/6.D0 DDFSLL = DDFSLL - CFFIS*GALL*AMAX2*(FCLL1+2*FSOLL0)* . DIV1*REDM(1)/6.D0 DDFSSS = DDFSSS - CFFIS*GASS*AMAX2*(FCSS1+2*FSOSS0)* . DIV2*REDM(2)/6.D0 DDFSLS = DDFSLS - CFFIS*GALS*AMAX2*(FCLS1+2*FSOLS0)* . DIV3*REDM(3)/6.D0 DDFSDR = DDFSDR - CFFIS*GADR*AMAX2*(FCSS1+2*FSOSS0)* . DIV2*REDM(2)/6.D0 C--------------------------------------------------------------- IF(IZAX.NE.0) THEN VSIGLL = VSIGLL - FZERO*GALL*(FCLL1+FAC1*FCLL2*CFSIG/6D0) VSIGSS = VSIGSS - FZERO*GASS*(FCSS1+FAC2*FCSS2*CFSIG/6D0) VSIGLS = VSIGLS - FZERO*GALS*(FCLS1+FAC3*FCLS2*CFSIG/6D0) VSIGDR = VSIGDR - FZERO*GADR*(FCSS1+FAC2*FCSS2*CFSIG/6D0) VTENLL = VTENLL + CFTEN *FZERO*GALL*FAC1 *FTLL1 VTENSS = VTENSS + CFTEN *FZERO*GASS*FAC2 *FTSS1 VTENLS = VTENLS + CFTEN *FZERO*GALS*FAC3 *FTLS1 VTENDR = VTENDR + CFTEN *FZERO*GADR*FAC2 *FTSS1 VSOLL = VSOLL - 0.5D0*FZERO*GALL*FAC1 *FSOLL1 VSOSS = VSOSS - 0.5D0*FZERO*GASS*FAC2 *FSOSS1 VSOLS = VSOLS - 0.5D0*FZERO*GALS*FAC3 *FSOLS1 VSODR = VSODR - 0.5D0*FZERO*GADR*FAC2 *FSOSS1 VSO2LL = VSO2LL + 2.0D0*FZERO*GALL*FAC1 *FO2LL1 VSO2SS = VSO2SS + 2.0D0*FZERO*GASS*FAC2 *FO2SS1 VSO2LS = VSO2LS + 2.0D0*FZERO*GALS*FAC3 *FO2LS1 VSO2DR = VSO2DR + 2.0D0*FZERO*GADR*FAC2 *FO2SS1 VASOLL = VASOLL - 0.5D0*FZERO*GALL*FAC1 *FSOLL1 . *SOALL VASOSS = VASOSS - 0.5D0*FZERO*GASS*FAC2 *FSOSS1 . *SOASS VASOLS = VASOLS - 0.5D0*FZERO*GALS*FAC3 *FSOLS1 . *SOALS VASODR = VASODR - 0.5D0*FZERO*GADR*FAC2 *FSOSS1 . *SOASS c------------------------------------------------------------- C BROWN, DOWNS AND IDDINGS TERM: C HERE, INSTEAD OF P, WE HAVE P_x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.4) THEN c PX = -1D0 VASOLL = VASOLL - PX*FZERO*GALL*FAC1 *FSOLL1 . *SOALL VASOSS = VASOSS - PX*FZERO*GASS*FAC2 *FSOSS1 . *SOASS VASOLS = VASOLS - PX*FZERO*GALS*FAC3 *FSOLS1 . *SOALS VASODR = VASODR - PX*FZERO*GADR*FAC2 *FSOSS1 . *SOASS ENDIF c------------------------------------------------------------- c IF(IZAX.EQ.2) THEN ! inconsistent with bbprogs.aug12.csb FISLL = FISLL - FZERO*GALL*FCLL1*DIV1*REDM(1)*CFFIS/6.D0 FISSS = FISSS - FZERO*GASS*FCSS1*DIV2*REDM(2)*CFFIS/6.D0 FISLS = FISLS - FZERO*GALS*FCLS1*DIV3*REDM(3)*CFFIS/6.D0 FISDR = FISDR - FZERO*GADR*FCSS1*DIV2*REDM(2)*CFFIS/6.D0 DFISLL = DFISLL- FZERO*GALL*DFCLL1*DIV1*REDM(1)*CFFIS/6.D0 DFISSS = DFISSS- FZERO*GASS*DFCSS1*DIV2*REDM(2)*CFFIS/6.D0 DFISLS = DFISLS- FZERO*GALS*DFCLS1*DIV3*REDM(3)*CFFIS/6.D0 DFISDR = DFISDR- FZERO*GADR*DFCSS1*DIV2*REDM(2)*CFFIS/6.D0 DDFSLL = DDFSLL- FZERO*GALL*AMAX2*(FCLL2+2*FSOLL1)* . DIV1*REDM(1)*CFFIS/6.D0 DDFSSS = DDFSSS- FZERO*GASS*AMAX2*(FCSS2+2*FSOSS1)* . DIV2*REDM(2)*CFFIS/6.D0 DDFSLS = DDFSLS- FZERO*GALS*AMAX2*(FCLS2+2*FSOLS1)* . DIV3*REDM(3)*CFFIS/6.D0 DDFSDR = DDFSDR- FZERO*GADR*AMAX2*(FCSS2+2*FSOSS1)* . DIV2*REDM(2)*CFFIS/6.D0 c ENDIF ENDIF C--------------------------------------------------------------- C C SECOND TERM AXIAL PROPAGATOR: C C--------------------------------------------------------------- IF(IBFLD.EQ.0) THEN C--------------------------------------------------------------- VSIGLL = VSIGLL + GALL*FCLL1/3 VSIGSS = VSIGSS + GASS*FCSS1/3 VSIGLS = VSIGLS + GALS*FCLS1/3 VSIGDR = VSIGDR + GADR*FCSS1/3 VTENLL = VTENLL + GALL*FTLL0 VTENSS = VTENSS + GASS*FTSS0 VTENLS = VTENLS + GALS*FTLS0 VTENDR = VTENDR + GADR*FTSS0 FISLL = FISLL - GALL*REDM(1)*FCLL1*DIV1/6.D0 FISSS = FISSS - GASS*REDM(2)*FCSS1*DIV2/6.D0 FISLS = FISLS - GALS*REDM(3)*FCLS1*DIV3/6.D0 FISDR = FISDR - GADR*REDM(2)*FCSS1*DIV2/6.D0 DFISLL = DFISLL - GALL*REDM(1)*DFCLL1*DIV1/6.D0 DFISSS = DFISSS - GASS*REDM(2)*DFCSS1*DIV2/6.D0 DFISLS = DFISLS - GALS*REDM(3)*DFCLS1*DIV3/6.D0 DFISDR = DFISDR - GADR*REDM(2)*DFCSS1*DIV2/6.D0 c FITEN = FITEN - GAX2*REDM*FT0 *DIV/2.D0 c DFITEN = DFITEN - GAX2*REDM*DFT0*DIV/2.D0 c------------------------------------------------------------ IF(IZAX.NE.0) THEN VSIGLL = VSIGLL + FZERO*GALL*FCLL2/3D0 VSIGSS = VSIGSS + FZERO*GASS*FCSS2/3D0 VSIGLS = VSIGLS + FZERO*GALS*FCLS2/3D0 VSIGDR = VSIGDR + FZERO*GADR*FCSS2/3D0 VTENLL = VTENLL + FZERO*GALL*FTLL1 VTENSS = VTENSS + FZERO*GASS*FTSS1 VTENLS = VTENLS + FZERO*GALS*FTLS1 VTENDR = VTENDR + FZERO*GADR*FTSS1 c---------------------------------------------------------------- c IF(IZAX.EQ.2) THEN FISLL = FISLL - FZERO*GALL*REDM(1)*FCLL2*DIV1/6.D0 FISSS = FISSS - FZERO*GASS*REDM(2)*FCSS2*DIV2/6.D0 FISLS = FISLS - FZERO*GALS*REDM(3)*FCLS2*DIV3/6.D0 FISDR = FISDR - FZERO*GADR*REDM(2)*FCSS2*DIV2/6.D0 DFISLL = DFISLL - FZERO*GALL*REDM(1)*DFCLL2*DIV1/6.D0 DFISSS = DFISSS - FZERO*GASS*REDM(2)*DFCSS2*DIV2/6.D0 DFISLS = DFISLS - FZERO*GALS*REDM(3)*DFCLS2*DIV3/6.D0 DFISDR = DFISDR - FZERO*GADR*REDM(2)*DFCSS2*DIV2/6.D0 c ENDIF C--------------------------------------------------------------- ENDIF ! END IZAX.NE.0 C--------------------------------------------------------------- ENDIF ! END IBFLD.EQ.0 C--------------------------------------------------------------- C--------------------------------------------------------------- IF(IBFLD.GE.1) THEN C--------------------------------------------------------------- C FEYNMAN-GAUGE: ALPHA_R=1: FC2B1 = 0.D0 FT2B0 = 0.D0 FC2B2 = 0.D0 FT2B1 = 0.D0 DFC2B1 = 0.D0 DFC2B2 = 0.D0 DDFC2B1 = 0.D0 DDFC2B2 = 0.D0 C--------------------------------------------------------------- VSIGLL = VSIGLL + GALL*FC2B1/3 VSIGSS = VSIGSS + GASS*FC2B1/3 VSIGLS = VSIGLS + GALS*FC2B1/3 VSIGDR = VSIGDR + GADR*FC2B1/3 VTENLL = VTENLL + GALL*FT2B0 VTENSS = VTENSS + GASS*FT2B0 VTENLS = VTENLS + GALS*FT2B0 VTENDR = VTENDR + GADR*FT2B0 FISLL = FISLL - GALL*REDM(1)*FC2B1*DIV1/6.D0 FISSS = FISSS - GASS*REDM(2)*FC2B1*DIV2/6.D0 FISLS = FISLS - GALS*REDM(3)*FC2B1*DIV3/6.D0 FISDR = FISDR - GADR*REDM(2)*FC2B1*DIV2/6.D0 DFISLL = DFISLL - GALL*REDM(1)*DFC2B1*DIV1/6.D0 DFISSS = DFISSS - GASS*REDM(2)*DFC2B1*DIV2/6.D0 DFISLS = DFISLS - GALS*REDM(3)*DFC2B1*DIV3/6.D0 DFISDR = DFISDR - GADR*REDM(2)*DFC2B1*DIV2/6.D0 c FITEN = FITEN - GAX2*REDM*FT2B1*DIV/4.D0 c DFITEN = DFITEN - GAX2*REDM*DFT2B1*DIV/4.D0 DDFSLL = DDFSLL - GALL*REDM(1)*DDFC2B1*DIV1/6.D0 DDFSSS = DDFSSS - GASS*REDM(2)*DDFC2B1*DIV2/6.D0 DDFSLS = DDFSLS - GALS*REDM(3)*DDFC2B1*DIV3/6.D0 DDFSDR = DDFSDR - GADR*REDM(2)*DDFC2B1*DIV2/6.D0 IF(IZAX.NE.0) THEN VSIGLL = VSIGLL + FZERO*GALL*FC2B2/3 VSIGSS = VSIGSS + FZERO*GASS*FC2B2/3 VSIGLS = VSIGLS + FZERO*GALS*FC2B2/3 VSIGDR = VSIGDR + FZERO*GADR*FC2B2/3 VTENLL = VTENLL + FZERO*GALL*FT2B1 VTENSS = VTENSS + FZERO*GASS*FT2B1 VTENLS = VTENLS + FZERO*GALS*FT2B1 VTENDR = VTENDR + FZERO*GADR*FT2B1 c IF(IZAX.EQ.2) THEN FISLL = FISLL - FZERO*GALL*REDM(1)*FC2B2*DIV1/6.D0 FISSS = FISSS - FZERO*GASS*REDM(2)*FC2B2*DIV2/6.D0 FISLS = FISLS - FZERO*GALS*REDM(3)*FC2B2*DIV3/6.D0 FISDR = FISDR - FZERO*GADR*REDM(2)*FC2B2*DIV2/6.D0 DFISLL = DFISLL - FZERO*GALL*REDM(1)*DFC2B2*DIV1/6.D0 DFISSS = DFISSS - FZERO*GASS*REDM(2)*DFC2B2*DIV2/6.D0 DFISLS = DFISLS - FZERO*GALS*REDM(3)*DFC2B2*DIV3/6.D0 DFISDR = DFISDR - FZERO*GADR*REDM(2)*DFC2B2*DIV2/6.D0 DSDFSLL = DSDFSLL - FZERO*GALL*REDM(1)*DDFC2B2*DIV1/6.D0 DSDFSSS = DSDFSSS - FZERO*GASS*REDM(2)*DDFC2B2*DIV2/6.D0 DSDFSLS = DSDFSLS - FZERO*GALS*REDM(3)*DDFC2B2*DIV3/6.D0 DSDFSDR = DSDFSDR - FZERO*GADR*REDM(2)*DDFC2B2*DIV2/6.D0 c ENDIF ! IZAXI.EQ.2 ENDIF ! IZAXI.NE.0 C--------------------------------------------------------------- ENDIF ! END IBFLF.EQ.1 C--------------------------------------------------------------- C--------------------------------------------------------------- C C DERIVATIVE COUPLINGS: -> GAUSSIAN CONTRIBUTIONS: C C--------------------------------------------------------------- C GAUSSIAN CONTRIBUTIONS: IF(IBFLD.EQ.0) THEN C--------------------------------------------------------------- C ASSUMED: ALM1=ALM2=ALM3: UPSS0 = VKULL*AMAX(IN) UPSS1 = (1.D0-2*XLAM1**2/3D0)*UPSS0 UPSS2 = (15.D0-20*XLAM1**2+4*XLAM1**4)*UPSS0/3D0 UPST0 = +2*XLAM1**2*UPSS0/3.D0 UPST1 = +2*XLAM1**2*(7D0-2*XLAM1**2)*UPSS0/3.D0 VSIGLL= VSIGLL + FFALL*FFAC1*UPSS2 + GFALL*GFAC1*UPSS1 VSIGLS= VSIGLS + FFALS*FFAC3*UPSS2 + GFALS*GFAC3*UPSS1 VSIGSS= VSIGSS + FFASS*FFAC2*UPSS2 + GFASS*GFAC2*UPSS1 VSIGDR= VSIGDR + FFADR*FFAC2*UPSS2 + GFADR*GFAC2*UPSS1 VTENLL= VTENLL - FFALL*FFAC1*UPST1 - GFALL*GFAC1*UPST0 VTENLS= VTENLS - FFALS*FFAC3*UPST1 - GFALS*GFAC3*UPST0 VTENSS= VTENSS - FFASS*FFAC2*UPST1 - GFASS*GFAC2*UPST0 VTENDR= VTENDR - FFADR*FFAC2*UPST1 - GFADR*GFAC2*UPST0 C--------------------------------------------------------------- ENDIF C--------------------------------------------------------------- C gecorrigeerd -> +1*GFALL*GFAC1*FTLL0 etc. (NOV 2012) C FEYNMAN-GAUGE: ALPHA_R=1 -> m_A' = m_A: IF(IBFLD.GE.1) THEN VSIGLL= VSIGLL-(FFALL*FFAC1*FCLL2+1*GFALL*GFAC1*FCLL1)/3D0 VSIGLS= VSIGLS-(FFALS*FFAC3*FCLS2+1*GFALS*GFAC3*FCLS1)/3D0 VSIGSS= VSIGSS-(FFASS*FFAC2*FCSS2+1*GFASS*GFAC2*FCSS1)/3D0 VSIGDR= VSIGDR-(FFADR*FFAC2*FCSS2+1*GFADR*GFAC2*FCSS1)/3D0 VTENLL= VTENLL-(FFALL*FFAC1*FTLL1+1*GFALL*GFAC1*FTLL0) VTENLS= VTENLS-(FFALS*FFAC3*FTLS1+1*GFALS*GFAC3*FTLS0) VTENSS= VTENSS-(FFASS*FFAC2*FTSS1+1*GFASS*GFAC2*FTSS0) VTENDR= VTENDR-(FFADR*FFAC2*FTSS1+1*GFADR*GFAC2*FTSS0) ENDIF C--------------------------------------------------------------- C 104 CONTINUE 1040 CONTINUE C RETURN END C********************************************************************** C c* SUBROUTINE AXIALU(NMAX,NLOC,ICSB,P) SUBROUTINE AXIALU(XA,ICSB,NLOC,P,PX) C C********************************************************************** C C AXIAL MESONS (UNNATURAL PARITY) POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST, . IFRMF,NSU3F COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR , . VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR , . VTENLL ,VTENSS ,VTENLS ,VTENDR , . VSOLL ,VSOSS ,VSOLS ,VSODR , . VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR , . VASOLL ,VASOSS ,VASOLS ,VASODR , . VNNC ,VNNSIG ,VNNTEN ,VNNSO , . FILL ,FISS ,FILS ,FIDR , . DFILL ,DFISS ,DFILS ,DFIDR , . FISLL ,FISSS ,FISLS ,FISDR , . DFISLL ,DFISSS ,DFISLS ,DFISDR , . FITLL ,FITSS ,FITLS ,FITDR , . DFITLL ,DFITSS ,DFITLS ,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS, DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS, DDFSDR DIMENSION AMAX(4) DATA SR3/1.732051D0/,SRPI/1.7724538509D0/,IPV/1/,ICALl/0/ DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1170.D0,1380.D0,1273.D0/ c DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1380.D0,1170D0,1400.D0/ C C NOTE : B1(IN=1),H11 (IN=2),H11'(IN=3),K1B(IN=4) C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C IF(ICALL.EQ.0.and.NSU3F.EQ.1) THEN AMH1 = AMB1 AMH2 = AMB1 AMK1 = AMB1 ICALL=1 ENDIF C DIV1 =1.D0/(AM(1)*AMY(1)) DIV2 =1.D0/(AM(1)*AMY(2)) DIV3 =1.D0/(AM(1)*AMH ) DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GALL= 0.D0 GASS= -2*FB(1)*FB(2) GALS= -SR3*FB(1)*FB(3) GADR= FB(1)*FB(2) AMAX(1)=AMB1 GOTO 1055 1052 GALL= FB(6)*FB(7) GASS= FB(6)*FB(8) GALS= 0.D0 GADR= FB(6)*FB(8) AMAX(2)=AMH1 GOTO 1055 1053 GALL= FB(9)*FB(10) GASS= FB(9)*FB(11) GALS= 0.D0 GADR= FB(9)*FB(11) AMAX(3)=AMH2 GOTO 1055 1054 GALL= FB(4)*FB(4)*P GASS= -FB(5)*FB(5)*P GALS= -SR3*FB(4)*FB(5)*P GADR= 2*FB(5)*FB(5)*P AMAX(4)=AMK1 C 1055 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMP8 IF(IN.EQ.2) ALAM=ALMP1 IF(IN.EQ.4) ALAM=ALMKA ENDIF AMAX2=AMAX(IN)*AMAX(IN) C ALM1 = ALAM ALM2 = ALAM ALM3 = ALAM RATM1=AMAX(IN)/ALM1 RATM2=AMAX(IN)/ALM2 RATM3=AMAX(IN)/ALM3 c FAC1=AMAX(IN)**2/(4*AM(1)*AMY(1)) c FAC2=AMAX(IN)**2/(4*AM(1)*AMY(2)) c FAC3=AMAX(IN)**2/(4*AM(1)*AMH ) C SCALING COUPLING WITH PIM: FAC1=AMAX(IN)**2/(PIM*PIM) FAC2=AMAX(IN)**2/(PIM*PIM) FAC3=AMAX(IN)**2/(PIM*PIM) C c* DO 104 I=2,NMAX c* X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMAX(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLL0 = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLL1 = FCLL0 - VKULL*AMAX(IN) FCLL2 = FCLL1 + (1.5D0-XLAM1*XLAM1)*VKULL*AMAX(IN)/RATM1**2 FSOLL1 = FSOLL0 - 0.5D0*VKULL*AMAX(IN)/RATM1**2 c* DFCLL0 = -X*FSOLL0 DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM DFCLL1 = DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN) ! MARCH 2009 DFTLL0 = DFCLL1/3.D0-3*FTLL0*PIM/XA C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTSS0 = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FCSS1 = FCSS0 - VKUSS*AMAX(IN) FCSS2 = FCSS1 + (1.5D0-XLAM2*XLAM2)*VKUSS*AMAX(IN)/RATM2**2 FSOSS1 = FSOSS0 - 0.5D0*VKUSS*AMAX(IN)/RATM2**2 c* DFCSS0 = -X*FSOSS0 DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM DFCSS1 = DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN) ! MARCH 2009 DFTSS0 = DFCSS1/3.D0-3*FTSS0*PIM/XA C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLS0 = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLS1 = FCLS0 - VKULS*AMAX(IN) FCLS2 = FCLS1 + (1.5D0-XLAM3*XLAM3)*VKULS*AMAX(IN)/RATM3**2 FSOLS1 = FSOLS0 - 0.5D0*VKULS*AMAX(IN)/RATM3**2 c* DFCLS0 = -X*FSOLS0 DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM DFCLS1 = DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN) ! MARCH 2009 DFTLS0 = DFCLS1/3.D0-3*FTLS0*PIM/XA C 1041 VSIGLL = VSIGLL - GALL*FAC1*FCLL1/3.D0 VSIGSS = VSIGSS - GASS*FAC2*FCSS1/3.D0 VSIGLS = VSIGLS - GALS*FAC3*FCLS1/3.D0 VSIGDR = VSIGDR - GADR*FAC2*FCSS1/3.D0 VTENLL = VTENLL - GALL*FAC1*FTLL0 VTENSS = VTENSS - GASS*FAC2*FTSS0 VTENLS = VTENLS - GALS*FAC3*FTLS0 VTENDR = VTENDR - GADR*FAC2*FTSS0 C------------------------------------------------------------ C BROWN, DOWNS AND IDDINGS TERMS: C HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.4) THEN c PX = -1D0 VASOLL = VASOLL + PX*GALL*FAC1*FSOLL0* . 4*(AMY(1)-AM(1))/(AMY(1)+AM(1)) VASOSS = VASOSS + PX*GASS*FAC2*FSOSS0* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) VASOLS = VASOLS + PX*GALS*FAC3*FSOLS0* . 4*(AMY(3)-AM(3))/(AMY(3)+AM(3)) VASODR = VASODR + PX*GADR*FAC2*FSOSS0* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) ENDIF C------------------------------------------------------------ IF(NLOC.EQ.0) GO TO 104 FISLL = FISLL - GALL*FAC1*REDMM*FCLL1 *DIV1/2.D0 FISSS = FISSS - GASS*FAC2*REDMM*FCSS1 *DIV2/2.D0 FISLS = FISLS - GALS*FAC3*REDMM*FCLS1 *DIV3/2.D0 FISDR = FISDR - GADR*FAC2*REDMM*FCSS1 *DIV2/2.D0 DFISLL= DFISLL - GALL*FAC1*REDMM*DFCLL1*DIV1/2.D0 DFISSS= DFISSS - GASS*FAC2*REDMM*DFCSS1*DIV2/2.D0 DFISLS= DFISLS - GALS*FAC3*REDMM*DFCLS1*DIV3/2.D0 DFISDR= DFISDR - GADR*FAC2*REDMM*DFCSS1*DIV2/2.D0 DDFSLL= DDFSLL - GALL*FAC1*REDMM*AMAX2*(FCLL2+2*FSOLL1)* . DIV1/2.D0 DDFSSS= DDFSSS - GASS*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)* . DIV2/2.D0 DDFSLS= DDFSLS - GALS*FAC3*REDMM*AMAX2*(FCLS2+2*FSOLS1)* . DIV3/2.D0 DDFSDR= DDFSDR - GADR*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)* . DIV2/2.D0 c FITLL = FITLL - GALL*FAC1*REDMM*FTLL0 *DIV1/2.D0 c DFITLL= DFITLL - GALL*FAC1*REDMM*DFTLL0*DIV1/2.D0 C 104 CONTINUE c print spin-orbit potentials: c write(*,*) ' AXIALB : x=',xa,' IN=',in,' vsoll=',vsoll, c .' vasoll=',vasoll,' p=',p C 1040 CONTINUE C RETURN END C********************************************************************** C c* SUBROUTINE TENSOR(NMAX,NLOC,ICSB,P) SUBROUTINE TENSOR(XA,ICSB,NLOC,P,PX) C C********************************************************************** C C TENSOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C VERSION: 13 SEPTEMBER 2006: WITH ZERO IN FORM FACTOR C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F c* COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/HVY/HFPS(11),GT(11),FT(11),FD(11),FV(11) COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c* COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR , . VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR , . VTENLL ,VTENSS ,VTENLS ,VTENDR , . VSOLL ,VSOSS ,VSOLS ,VSODR , . VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR , . VASOLL ,VASOSS ,VASOLS ,VASODR , . VNNC ,VNNSIG ,VNNTEN ,VNNSO , . FILL ,FISS ,FILS ,FIDR , . DFILL ,DFISS ,DFILS ,DFIDR , . FISLL ,FISSS ,FISLS ,FISDR , . DFISLL ,DFISSS ,DFISLS ,DFISDR , . FITLL ,FITSS ,FITLS ,FITDR , . DFITLL ,DFITSS ,DFITLS ,DFITDR DIMENSION AMTS(4),FTS(4),XM1(3),XM2(3) DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/ DATA AMTS/1310.4D0,1272.9D0,1520.4D0,1430.D0/,AMCRS/750D0/ data icall/0/ C C NOTE : A2(1320),F(1270),FP(1525),K*(1430): IN=1,2,3,4 RESP. C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) C C ANTI-SYMMETRIC SPIN-ORBIT MASS DIFFERENCE FACTOR: SOALL = 0.5D0*(AMNN/AMLN-AMLN/AMNN) SOALS = 0.5D0*(AMNN/AMH -AMH /AMNN) SOASS = 0.5D0*(AMNN/AMSN-AMSN/AMNN) C DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GDLL = 0.D0 GDFLL= 0.D0 GFDLL= 0.D0 GFLL = 0.D0 GDSS = -2*GT(1)*GT(2) GDFSS= -2*GT(1)*FT(2) GFDSS= -2*FT(1)*GT(2) GFSS = -2*FT(1)*FT(2) GDLS = -GT(1)*GT(3)*SR3 GDFLS= -GT(1)*FT(3)*SR3 GFDLS= -FT(1)*GT(3)*SR3 GFLS = -FT(1)*FT(3)*SR3 GDDR = GT(1)*GT(2) GDFDR= GT(1)*FT(2) GFDDR= FT(1)*GT(2) GFDR = FT(1)*FT(2) XM1(1)=AM(1) XM1(2)=AM(1) XM1(3)=AM(1) XM2(1)=AMY(1) XM2(2)=AMY(1) XM2(3)=AMH GOTO 1055 1052 GDLL = GT(6)*GT(7) GDFLL= GT(6)*FT(7) GFDLL= FT(6)*GT(7) GFLL = FT(6)*FT(7) GDSS = GT(6)*GT(8) GDFSS= GT(6)*FT(8) GFDSS= FT(6)*GT(8) GFSS = FT(6)*FT(8) GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS GOTO 1055 1053 GDLL = GT(9)*GT(10) GDFLL= GT(9)*FT(10) GFDLL= FT(9)*GT(10) GFLL = FT(9)*FT(10) GDSS = GT(9)*GT(11) GDFSS= GT(9)*FT(11) GFDSS= FT(9)*GT(11) GFSS = FT(9)*FT(11) GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS GOTO 1055 1054 GDLL = GT(4)*GT(4)*P GDFLL= GT(4)*FT(4)*P GFDLL= FT(4)*GT(4)*P GFLL = FT(4)*FT(4)*P GDSS = -GT(5)*GT(5)*P GDFSS= -GT(5)*FT(5)*P GFDSS= -FT(5)*GT(5)*P GFSS = -FT(5)*FT(5)*P GDLS = -GT(4)*GT(5)*P*SR3 GDFLS= -GT(4)*FT(5)*P*SR3 GFDLS= -FT(4)*GT(5)*P*SR3 GFLS = -FT(4)*FT(5)*P*SR3 GDDR = -2*GDSS GDFDR= -2*GDFSS GFDDR= -2*GFDSS GFDR = -2*GFSS XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMLS XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMLS C 1055 FTS(IN) = 1.D0 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMV8 IF(IN.EQ.2) ALAM = ALMV1 IF(IN.EQ.4) ALAM = ALMKS ENDIF c alam = 600d0 c if(icall.eq.0) write(*,*) ' TENSOR: alam=600!' c icall=1 ALM1 = ALAM ALM2 = ALAM ALM3 = ALAM RATM1=AMTS(IN)/ALM1 RATM2=AMTS(IN)/ALM2 RATM3=AMTS(IN)/ALM3 FAC0=AMTS(IN)*AMTS(IN)/AMPRO/AMPRO FAC1=AMTS(IN)*AMTS(IN)/(XM1(1)*XM2(1)) FAC2=AMTS(IN)*AMTS(IN)/(XM1(2)*XM2(2)) FAC3=AMTS(IN)*AMTS(IN)/(XM1(3)*XM2(3)) C c CCNN1=-FAC1*(5*GDNN/6.D0+(GFDNN+GDFNN)*DSQRT(XM1*XM2) c . /6.D0/AMPRO) c? CCLL1=-FAC1*5*GDLL/6.D0-(GFDLL/XM1(1)+GDFLL/XM2(1)) c? . *AMTS(IN)**2/(6.D0*AMPRO) c? CCSS1=-FAC2*5*GDSS/6.D0-(GFDSS/XM1(2)+GDFSS/XM2(2)) c? . *AMTS(IN)**2/(6.D0*AMPRO) c? CCLS1=-FAC3*5*GDLS/6.D0-(GFDLS/XM1(3)+GDFLS/XM2(3)) c? . *AMTS(IN)**2/(6.D0*AMPRO) c? CCDR1=-FAC2*5*GDDR/6.D0-(GFDDR/XM1(2)+GDFDR/XM2(2)) c? . *AMTS(IN)**2/(6.D0*AMPRO) c CCNN1=-FAC1*(2*GDNN/3.D0+(GFDNN+GDFNN)*DSQRT(XM1*XM2) c . /6.D0/AMPRO) CCLL1=-FAC1*2*GDLL/3.D0-(GFDLL/XM1(1)+GDFLL/XM2(1)) . *AMTS(IN)**2/(6.D0*AMPRO) CCSS1=-FAC2*2*GDSS/3.D0-(GFDSS/XM1(2)+GDFSS/XM2(2)) . *AMTS(IN)**2/(6.D0*AMPRO) CCLS1=-FAC3*2*GDLS/3.D0-(GFDLS/XM1(3)+GDFLS/XM2(3)) . *AMTS(IN)**2/(6.D0*AMPRO) CCDR1=-FAC2*2*GDDR/3.D0-(GFDDR/XM1(2)+GDFDR/XM2(2)) . *AMTS(IN)**2/(6.D0*AMPRO) c CSNN1=-FAC1*(GDNN*AMPRO+GFDNN*XM1+GDFNN*XM2+GFNN*XM1*XM2/AMPRO) c . /AMPRO/12.D0 CSLL1=-FAC1*(GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1))/AMPRO . +GFLL*XM1(1)*XM2(1)/AMPRO**2)/12.D0 CSSS1=-FAC2*(GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2))/AMPRO . +GFSS*XM1(2)*XM2(2)/AMPRO**2)/12.D0 CSLS1=-FAC3*(GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3))/AMPRO . +GFLS*XM1(3)*XM2(3)/AMPRO**2)/12.D0 CSDR1=-FAC2*(GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2))/AMPRO . +GFDR*XM1(2)*XM2(2)/AMPRO**2)/12.D0 c CTNN0=-1.50D0*CSNN1 CTLL0=-1.50D0*CSLL1 CTSS0=-1.50D0*CSSS1 CTLS0=-1.50D0*CSLS1 CTDR0=-1.50D0*CSDR1 c CONN0= FAC1*(5*GDNN/3.D0+(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO ) COLL0= FAC1*(5*GDLL/3.D0+(GDFLL*XM2(1)+GFDLL*XM1(1))/AMPRO ) COSS0= FAC2*(5*GDSS/3.D0+(GDFSS*XM2(2)+GFDSS*XM1(2))/AMPRO ) COLS0= FAC3*(5*GDLS/3.D0+(GDFLS*XM2(3)+GFDLS*XM1(3))/AMPRO ) CODR0= FAC2*(5*GDDR/3.D0+(GDFDR*XM2(2)+GFDDR*XM1(2))/AMPRO ) CALL0= FAC1*( GDLL*SOALL/4.D0 . -(GDFLL-GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO ) CASS0= FAC1*( GDSS*SOASS/4.D0 . -(GDFSS-GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO ) CALS0= FAC1*( GDLS*SOALS/4.D0 . -(GDFLS-GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO ) CADR0= FAC1*( GDDR*SOASS/4.D0 . -(GDFDR-GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO ) C BROWN, DOWNS AND IDDINGS TERM: COPIED FROM VECTOR CASE (CHECK!!) C HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 -> IF(IN.EQ.4) THEN c PX = -1D0 CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2* . (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1)) CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2* . (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3)) CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) ENDIF c CO2NN=-FAC1**2*(7*GDNN/6.D0+2*(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO c + +3*GFNN*XM1*XM2/AMPRO/AMPRO)/4.D0 CO2LL=-FAC1**2*(7*GDLL/6.D0+2*(GDFLL*XM2(1)+GFDLL*XM1(1))/AMPRO + +3*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO)/4.D0 CO2SS=-FAC2**2*(7*GDSS/6.D0+2*(GDFSS*XM2(2)+GFDSS*XM1(2))/AMPRO + +3*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO)/4.D0 CO2LS=-FAC3**2*(7*GDLS/6.D0+2*(GDFLS*XM2(3)+GFDLS*XM1(3))/AMPRO + +3*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO)/4.D0 CO2DR=-FAC2**2*(7*GDDR/6.D0+2*(GDFDR*XM2(2)+GFDDR*XM1(2))/AMPRO + +3*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO)/4.D0 c FINN0=-(11*GDNN/3.D0) FILL0=-(11*GDLL/3.D0) FISS0=-(11*GDSS/3.D0) FILS0=-(11*GDLS/3.D0) FIDR0=-(11*GDDR/3.D0) C c* DO 104 I=2,NMAX c* X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMTS(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMTS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMTS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMTS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN) FTENLL=FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN) FSOLL =FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN) FSO2LL= 3*FTENLL/(X*X) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN) FTENSS=FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMTS(IN) FSOSS =FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMTS(IN) FSO2SS= 3*FTENSS/(X*X) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN) FTENLS=FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMTS(IN) FSOLS =FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMTS(IN) FSO2LS= 3*FTENLS/(X*X) C FCLL1= FCLL0 - VKULL*AMTS(IN) FCLL2= FCLL1 + (1.5D0-XLAM1*XLAM1)*VKULL*AMTS(IN)/RATM1**2 FTLL1= FTENLL - XLAM1*XLAM1*VKULL*AMTS(IN)/(3*RATM1*RATM1) FOLL1= FSOLL - VKULL*AMTS(IN)/(2*RATM1*RATM1) c** FO2LL1= 3*FTLL1/(X*X) C FCSS1= FCSS0 - VKUSS*AMTS(IN) FCSS2= FCSS1 + (1.5D0-XLAM2*XLAM2)*VKUSS*AMTS(IN)/RATM2**2 FTSS1= FTENSS - XLAM2*XLAM2*VKUSS*AMTS(IN)/(3*RATM2*RATM2) FOSS1= FSOSS - VKUSS*AMTS(IN)/(2*RATM2*RATM2) FO2SS1= 3*FTSS1/(X*X) C FCLS1= FCLS0 - VKULS*AMTS(IN) FCLS2= FCLS1 + (1.5D0-XLAM3*XLAM3)*VKULS*AMTS(IN)/RATM3**2 FTLS1= FTENLS - XLAM3*XLAM3*VKULS*AMTS(IN)/(3*RATM3*RATM3) FOLS1= FSOLS - VKULS*AMTS(IN)/(2*RATM3*RATM3) FO2LS1= 3*FTLS1/(X*X) C--------------------------------------------------------------- C NO K^4-TERMS: FCLL2 = 0D0 FCLS2 = 0D0 FCSS2 = 0D0 C--------------------------------------------------------------- C VCLL = VCLL - 2*GDLL*FCLL0/3.D0 + CCLL1*FCLL1 . -GFLL*FAC0*FAC1*FCLL2/96.D0 VCSS = VCSS - 2*GDSS*FCSS0/3.D0 + CCSS1*FCSS1 . -GFSS*FAC0*FAC2*FCSS2/96.D0 VCLS = VCLS - 2*GDLS*FCLS0/3.D0 + CCLS1*FCLS1 . -GFLS*FAC0*FAC3*FCLS2/96.D0 VCDR = VCDR - 2*GDDR*FCSS0/3.D0 + CCDR1*FCSS1 . -GFDR*FAC0*FAC2*FCSS2/96.D0 VSIGLL = VSIGLL + CSLL1*FCLL1 . -INRS*GFLL*FAC0*FCLL2*FAC1/96.D0 VSIGSS = VSIGSS + CSSS1*FCSS1 . -INRS*GFSS*FAC0*FCSS2*FAC2/96.D0 VSIGLS = VSIGLS + CSLS1*FCLS1 . -INRS*GFLS*FAC0*FCLS2*FAC3/96.D0 VSIGDR = VSIGDR + CSDR1*FCSS1 . -INRS*GFDR*FAC0*FCSS2*FAC2/96.D0 VTENLL = VTENLL + CTLL0*FTENLL . +INRS*GFLL*FAC0*FTLL1*FAC1/64.D0 VTENSS = VTENSS + CTSS0*FTENSS . +INRS*GFSS*FAC0*FTSS1*FAC2/64.D0 VTENLS = VTENLS + CTLS0*FTENLS . +INRS*GFLS*FAC0*FTLS1*FAC3/64.D0 VTENDR = VTENDR + CTDR0*FTENSS . +INRS*GFDR*FAC0*FTSS1*FAC2/64.D0 VSOLL = VSOLL + COLL0*FSOLL . +3*GFLL*FAC0*FOLL1*FAC1/16.D0 VSOSS = VSOSS + COSS0*FSOSS . +3*GFSS*FAC0*FOSS1*FAC2/16.D0 VSOLS = VSOLS + COLS0*FSOLS . +3*GFLS*FAC0*FOLS1*FAC3/16.D0 VSODR = VSODR + CODR0*FSOSS . +3*GFDR*FAC0*FOSS1*FAC2/16.D0 VASOLL = VASOLL + CALL0*FSOLL VASOSS = VASOSS + CASS0*FSOSS VASOLS = VASOLS + CALS0*FSOLS VASODR = VASODR + CADR0*FSOSS VSO2LL = VSO2LL + CO2LL*FSO2LL VSO2SS = VSO2SS + CO2SS*FSO2SS VSO2LS = VSO2LS + CO2LS*FSO2LS VSO2DR = VSO2DR + CO2DR*FSO2SS C C K*(1430): K_{MU}K_{NU}-TERMS IN TENSOR MESON PROPAGATOR: C c SUPPOSED CAN BE NEGLECTED C C-------------------------------------------------------------- C IF(NLOC.NE.0) THEN FILL = FILL + REDMM*FILL0*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + REDMM*FISS0*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + REDMM*FILS0*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + REDMM*FIDR0*FCSS0/(XM1(2)*XM2(2)) C DFILL = DFILL - REDMM*FILL0*FSOLL*X*FAC1/AMTS(IN) DFISS = DFISS - REDMM*FISS0*FSOSS*X*FAC2/AMTS(IN) DFILS = DFILS - REDMM*FILS0*FSOLS*X*FAC3/AMTS(IN) DFIDR = DFIDR - REDMM*FIDR0*FSOSS*X*FAC2/AMTS(IN) ENDIF C-------------------------------------------------------------- C ZERO IN FORM-FACTOR: IF(IZTEN.NE.0) THEN FZERO = (AMTS(IN)/AMCRS)**2 VCLL= VCLL - FZERO*(2*GDLL*FCLL1/3.D0+CCLL1*FCLL2) VCSS= VCSS - FZERO*(2*GDSS*FCSS1/3.D0+CCSS1*FCSS2) VCLS= VCLS - FZERO*(2*GDLS*FCLS1/3.D0+CCLS1*FCLS2) VCDR= VCDR - FZERO*(2*GDDR*FCSS1/3.D0+CCDR1*FCSS2) VSIGLL = VSIGLL + FZERO*CSLL1*FCLL2 VSIGSS = VSIGSS + FZERO*CSSS1*FCSS2 VSIGLS = VSIGLS + FZERO*CSLS1*FCLS2 VSIGDR = VSIGDR + FZERO*CSDR1*FCSS2 VTENLL = VTENLL + FZERO*CTLL0*FTLL1 VTENSS = VTENSS + FZERO*CTSS0*FTSS1 VTENLS = VTENLS + FZERO*CTLS0*FTLS1 VTENDR = VTENDR + FZERO*CTDR0*FTSS1 VSOLL = VSOLL + FZERO*COLL0*FOLL1 VSOSS = VSOSS + FZERO*COSS0*FOSS1 VSOLS = VSOLS + FZERO*COLS0*FOLS1 VSODR = VSODR + FZERO*CODR0*FOSS1 VASOLL = VASOLL + FZERO*CALL0*FOLL1 VASOSS = VASOSS + FZERO*CASS0*FOSS1 VASOLS = VASOLS + FZERO*CALS0*FOLS1 VASODR = VASODR + FZERO*CADR0*FOSS1 c* VSO2LL = VSO2LL + FZERO*CO2LL*FO2LL1 c* VSO2SS = VSO2SS + FZERO*CO2SS*FO2SS1 c* VSO2LS = VSO2LS + FZERO*CO2LS*FO2LS1 c* VSO2DR = VSO2DR + FZERO*CO2DR*FO2SS1 c* IF(NLOC.NE.0) THEN c* FILL = FILL + FZERO*REDMM*FILL0*FCLL1/(XM1(1)*XM2(1)) c* FISS = FISS + FZERO*REDMM*FISS0*FCSS1/(XM1(2)*XM2(2)) c* FILS = FILS + FZERO*REDMM*FILS0*FCLS1/(XM1(3)*XM2(3)) c* FIDR = FIDR + FZERO*REDMM*FIDR0*FCSS1/(XM1(2)*XM2(2)) C c* DFILL= DFILL- FZERO*REDMM*FILL0*FOLL1*FAC1/AMTS(IN) c* DFISS= DFISS- FZERO*REDMM*FISS0*FOSS1*X*FAC2/AMTS(IN) c* DFILS= DFILS- FZERO*REDMM*FILS0*FOLS1*X*FAC3/AMTS(IN) c* DFIDR= DFIDR- FZERO*REDMM*FIDR0*FOSS1*X*FAC2/AMTS(IN) c* ENDIF ENDIF C-------------------------------------------------------------- C-------------------------------------------------------------- c print spin-orbit potentials: c write(*,*) ' TENSOR : x=',xa,' IN=',in,' vsoll=',vsoll, c .' vasoll=',vasoll 104 CONTINUE C 1040 CONTINUE C RETURN END C*********************************************************************** C C PROGRAM: OBE00.F C C updated december 2000, from YNRMP2k2.f , introducing mass C differences in meson propagators in the OBE-potentials, C according to Macke-Klein C C updated june 2004, from obe00.f, introducing a zero in AXIAL-EXCH. C updated oct 2004, introducing diffractive singlet+nonet C updated jan 2007, for dealing with very heavy meson masses C ********************************************************************* C ********************************************************************* C SUBROUTINE BIGMASS(XA,AMES,ALAM,FICN,FITN,FILS) C C********************************************************************** IMPLICIT REAL *8(A-H,O-Z) COMMON/PIMAS/PIM DATA SRPI/1.772454D0/ CC XLAM = 0.5D0*XA*ALAM/PIM XLAM2= XLAM*XLAM ELAM = FDEXP(-XLAM2) FICN = (ALAM/AMES)**3*ELAM/(2*SRPI) FITN = (ALAM/AMES)**5*XLAM2*ELAM/(6*SRPI) FILS = (ALAM/AMES)**5*ELAM/(4*SRPI) FIC1 = -(ALAM/AMES)**5*(3D0-2*XLAM2)*ELAM/(4*SRPI) RETURN END C ********************************************************************* C SUBROUTINE PSSCAL(XA,ICSB,NLOC,LC) C C********************************************************************** C updated december 2000, from YNRMP2k2.f , introducing mass C differences in meson propagators in the OBE-potentials, C according to Macke-Klein C---------------------------------------------------------------------- C C PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB . ,CORTPS,CORTV,CORTA,CORTB DIMENSION F(11),AMPS(5) EQUIVALENCE (F1,F(1)) DATA SR3/1.732051D0/,SRPI/1.772454D0/ DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/ c** DATA DAMLN/0.D0/,DAMSN/0.D0/,DAMSL/0.D0/ DATA ICALL/0/ DATA NAPION/1/,AMCRP/750.D0/ C C NOTE : PION(IN=1),ETA (IN=2),ETAP(IN=3),KAON(IN=4) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C------------------------------------------------------------------ C THE POTENTIAL FUNCTIONS C c FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) c FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH c . *(1.D0+XH)-EXH*EP*(1.D0-XH)-4.D0*XLAMH*EXLAM/ERATH/SRPI) c . /(2.D0*XH*XH*XH) c FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH c . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) c . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ c . 1.7724538509D0)/(2.D00*XH*XH*XH) C------------------------------------------------------------------ C DIV1 = 1D0/AMLN**2 DIV2 = 1D0/AMSN**2 DIV3 = 1D0/AMLS**2 SR3 = DSQRT(3.D0) SRPI= DSQRT(DACOS(-1.D0)) IF(LC.EQ.1) SIGN= 1.D0 IF(LC.NE.1) SIGN=-1.D0 DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GPLL = -0.0271D0*ICSB*F1*F3 GPSS= -2*F1*F2 GPLS= -SR3*F1*F3 GPDR= F1*F2 AMPS(1)=AMPI GPLL = GPLL*(AMPS(1)/PIM)**0 GPSS = GPSS*(AMPS(1)/PIM)**0 GPLS = GPLS*(AMPS(1)/PIM)**0 GPDR = GPDR*(AMPS(1)/PIM)**0 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1052 GPLL= F6*F7*(AME/PIM)**0 GPSS= F6*F8*(AME/PIM)**0 GPLS= 0.D0 GPDR= F6*F8*(AME/PIM)**0 AMPS(2)=AME IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1053 GPLL= F9*F10*(AMX/PIM)**0 GPSS= F9*F11*(AMX/PIM)**0 GPLS= 0.D0 GPDR= F9*F11*(AMX/PIM)**0 AMPS(3)=AMX IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP1 GOTO 1056 1054 GPLL= F4*F4*P*(BMK/PIM)**0 GPSS= -F5*F5*P*(BMK/PIM)**0 GPLS= -SR3*F4*F5*P*(BMK/PIM)**0 GPDR= 2*F5*F5*P*(BMK/PIM)**0 AMPS(4)=BMK IF(IMODEL.EQ.1) ALAM=ALMOBE IF(IMODEL.GE.2) ALAM=ALMKA GOTO 1056 C 1056 ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMPS(IN)/ALM1 RATM2=AMPS(IN)/ALM2 RATM3=AMPS(IN)/ALM3 FAC1=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(1)) FAC2=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(2)) FAC3=AMPS(IN)*AMPS(IN)/(AM(1)*AMH) C AMES = AMPS(IN) c DO 104 I=2,NMAX c X = XA(I) CALL FUNPS2(2,XA,AMES,ALM1,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO) FCLL0 = PIM*FC0 FCLL1 = PIM*FC1 FTENLL = PIM*FTEN FSOLL = PIM*FSO DFCLL1 = PIM**2*DFC1 DFTENLL= PIM**2*DFTEN C CALL FUNPS2(2,XA,AMES,ALM2,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO) FCSS0 = PIM*FC0 FCSS1 = PIM*FC1 FTENSS = PIM*FTEN FSOSS = PIM*FSO DFCSS1 = PIM**2*DFC1 DFTENSS= PIM**2*DFTEN C CALL FUNPS2(2,XA,AMES,ALM3,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO) FCLS0 = PIM*FC0 FCLS1 = PIM*FC1 FTENLS = PIM*FTEN FSOLS = PIM*FSO DFCLS1 = PIM**2*DFC1 DFTENLS= PIM**2*DFTEN C C------------------------------------------------------------ C THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS: IF(IDAM.NE.0.AND.IN.NE.4) THEN CALL YMKFUN(XA,AMPS(IN),ALAM,SIGN,IDAM*DAMSL, .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1) C------------------------------------------------------------ IF(LC.EQ.1) THEN FCSS1 = AMPS(IN)*FXC1 FTENSS = AMPS(IN)*FXTEN ENDIF IF(LC.NE.1) THEN FCLL1 = AMPS(IN)*FXC1 FTENLL = AMPS(IN)*FXTEN ENDIF FCLS1 = 0.5D0*(FCLS1 + AMPS(IN)*FXC1 ) FTENLS = 0.5D0*(FTENLS+ AMPS(IN)*FXTEN) ENDIF C------------------------------------------------------------ C VSIGLL = VSIGLL + GPLL*FCLL1/3.D0 VTENLL = VTENLL + GPLL*FTENLL VSIGDR = VSIGDR + GPDR*FCSS1/3.D0 VTENDR = VTENDR + GPDR*FTENSS VSIGSS = VSIGSS + GPSS*FCSS1/3.D0 VTENSS = VTENSS + GPSS*FTENSS VSIGLS = VSIGLS + GPLS*FCLS1/3.D0 VTENLS = VTENLS + GPLS*FTENLS C----------------------------------------------------------------- C C NONLOCAL TERMS PSEUDOSCALAR MESONS: C C----------------------------------------------------------------- IF(NAPION.EQ.1) THEN C----------------------------------------------------------------- C GRAZ 1978: c corrps= 1.d0 FISLL = FISLL -corsps*REDM(1)*GPLL*FCLL1*DIV1/6D0 FITLL = FITLL -cortps*REDM(1)*GPLL*FTENLL*DIV1/2D0 DFISLL= DFISLL -corsps*REDM(1)*GPLL*DFCLL1*DIV1/6D0 DFITLL= DFITLL -cortps*REDM(1)*GPLL*DFTENLL*DIV1/2D0 FISSS = FISSS -corsps*REDM(2)*GPSS*FCSS1*DIV2/6D0 FITSS = FITSS -cortps*REDM(2)*GPSS*FTENSS*DIV2/2D0 DFISSS= DFISSS -corsps*REDM(2)*GPSS*DFCSS1*DIV2/6D0 DFITSS= DFITSS -cortps*REDM(2)*GPSS*DFTENSS*DIV2/2D0 FISLS = FISLS -corsps*REDMM *GPLS*FCLS1*DIV3/6D0 FITLS = FITLS -cortps*REDMM *GPLS*FTENLS*DIV3/2D0 DFISLS= DFISLS -corsps*REDMM *GPLS*FCLS1*DIV3/6D0 DFITLS= DFITLS -cortps*REDMM *GPLS*DFCLS1*DIV3/6D0 FISDR = FISDR -corsps*REDMM *GPDR*FCLS1*DIV2/6D0 FITDR = FITDR -cortps*REDMM *GPDR*FTENLS*DIV2/2D0 DFISDR= DFISDR -corsps*REDMM *GPDR*FCLS1*DIV2/6D0 DFITDR= DFITDR -cortps*REDMM *GPDR*DFCLS1*DIV2/6D0 C END GRAZ 1978. ENDIF C----------------------------------------------------------------- C------------------------------------------------------------ C BROWN, DOWNS AND IDDINGS TERM: IF(IN.EQ.4) THEN C HERE INSTEAD OF P, WE MUST TAKE P_x=SPACE-EXCHANGE: L=1 -> -1: c PX = -1D0 VASOLL = VASOLL - PX*GPLL*FSOLL* . 4*(AMY(1)-AM(1))/(AMY(1)+AM(1)) VASOSS = VASOSS - PX*GPSS*FSOSS* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) VASOLS = VASOLS - PX*GPLS*FSOLS* . 4*(AMY(3)-AM(3))/(AMY(3)+AM(3)) VASODR = VASODR - PX*GPDR*FSOSS* . 4*(AMY(2)-AM(2))/(AMY(2)+AM(2)) ENDIF C C------------------------------------------------------------ C ZERO IN FORM-FACTOR: IF(IZPS.EQ.1) THEN FZERO = (AMPS(IN)/AMCRP)**2 FC2 = FCLL1 + (1.5D0-XLAM1*XLAM1) . * VKULL*AMPS(IN)/RATM1/RATM1 FT1 = FTENLL - XLAM1*XLAM1 * VKULL*AMPS(IN) . /(3*RATM1*RATM1) VSIGLL = VSIGLL + FZERO*GPLL*FC2/3.D0 VTENLL = VTENLL + FZERO*GPLL*FT1 VSIGDR = VSIGDR + FZERO*GPDR*FC2/3.D0 VTENDR = VTENDR + FZERO*GPDR*FT1 VSIGSS = VSIGSS + FZERO*GPSS*FC2/3.D0 VTENSS = VTENSS + FZERO*GPSS*FT1 VSIGLS = VSIGLS + FZERO*GPLS*FC2/3.D0 VTENLS = VTENLS + FZERO*GPLS*FT1 ENDIF C 104 CONTINUE C 1040 CONTINUE C ICALL = 1 RETURN END C********************************************************************** C SUBROUTINE VECTOR(XA,ICSB,NLOC,LC) C C********************************************************************** C updated december 2000, from YNRMP2k2.f , introducing mass C differences in meson propagators in the OBE-potentials, C according to Macke-Klein C---------------------------------------------------------------------- C C VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION FD(11),FV(11) DIMENSION AMVC(5),FVC(5),XM1(3),XM2(3) EQUIVALENCE (FD1,FD(1)),(FV1,FV(1)) DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/ DATA SR3/1.732050808D0/,SRPI/1.77245385D0/,AMPRO/938.2796D0/ .,FMNL/1.D0/,AMCRV/750.D0/ C C NOTE : RHO1(IN=1),RHO2(IN=2),OME(IN=3),PHI(IN=4),KSTAR(IN=5) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C------------------------------------------------------------------- C NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> HYPERONS ! C : INDEX 2,4 -> NUCLEONS ! C------------------------------------------------------------------- C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) C IF(LC.EQ.1) SIGN= 1.D0 IF(LC.NE.1) SIGN=-1.D0 C PROSLL=-(AM(1)-AMY(1))*(AMY(1)-AM(1))/AMKS/AMKS PROSSS=-(AMNN -AMSS )*(AMSS -AMNN )/AMKS/AMKS PROSLS=-(AMNN -AMY(1))*(AMSS -AM(1))/AMKS/AMKS C IF(IRET.EQ.1) THEN WKIN1 = PIM**2*AKS(1)/(2*REDM(1)) WKIN2 = PIM**2*AKS(3)/(2*REDM(3)) WKIN3 = 0.5D0*(WKIN1+WKIN2) ENDIF C DO 1040 IN=1,5 IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMSS c** XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) ENDIF GOTO(1051,1051,1053,1054,1055),IN 1051 GDLL = -0.0271D0*ICSB*FD1*FD3 GDFLL= -0.0271D0*ICSB*FD1*FV3 GFDLL= -0.0271D0*ICSB*FV1*FD3 GFLL = -0.0271D0*ICSB*FV1*FV3 GDSS = -2*FD1*FD2 GDFSS= -2*FD1*FV2 GFDSS= -2*FV1*FD2 GFSS = -2*FV1*FV2 GDLS = -FD1*FD3*SR3 GDFLS= -FD1*FV3*SR3 GFDLS= -FV1*FD3*SR3 GFLS = -FV1*FV3*SR3 GDDR = FD1*FD2 GDFDR= FD1*FV2 GFDDR= FV1*FD2 GFDR = FV1*FV2 IF(IN.EQ.1) THEN FVC(1)=ARO AMVC(1)=AM1RO ELSE FVC(2)=BRO AMVC(2)=AM2RO ENDIF GOTO 1056 1053 GDLL = FD6*FD7 GDFLL= FD6*FV7 GFDLL= FV6*FD7 GFLL = FV6*FV7 GDSS = FD6*FD8 GDFSS= FD6*FV8 GFDSS= FV6*FD8 GFSS = FV6*FV8 GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS FVC(3)=1.D0 AMVC(3)=AMOM GOTO 1056 1054 GDLL = FD9*FD10 GDFLL= FD9*FV10 GFDLL= FV9*FD10 GFLL = FV9*FV10 GDSS = FD9*FD11 GDFSS= FD9*FV11 GFDSS= FV9*FD11 GFSS = FV9*FV11 GDLS = 0.D0 GDFLS= 0.D0 GFDLS= 0.D0 GFLS = 0.D0 GDDR = GDSS GDFDR= GDFSS GFDDR= GFDSS GFDR = GFSS FVC(4)=1.D0 AMVC(4)=AMFI GOTO 1056 1055 GDLL = FD4*FD4*P GDFLL= FD4*FV4*P GFDLL= FV4*FD4*P GFLL = FV4*FV4*P GDSS = -FD5*FD5*P GDFSS= -FD5*FV5*P GFDSS= -FV5*FD5*P GFSS = -FV5*FV5*P GDLS = -FD4*FD5*P*SR3 GDFLS= -FD4*FV5*P*SR3 GFDLS= -FV4*FD5*P*SR3 GFLS = -FV4*FV5*P*SR3 GDDR = -2*GDSS GDFDR= -2*GDFSS GFDDR= -2*GFDSS GFDR = -2*GFSS FVC(5)=1.D0 AMVC(5)=BMKS C CASE IN=5: XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMSN c** XM1(3)=(AMSN+AMLS)/2.D0 XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMSN c** XM2(3)=(AMSN+AMLS)/2.D0 C 1056 AMVC2 = AMVC(IN)*AMVC(IN) IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMV8 IF(IN.EQ.3) ALAM=ALMV1 IF(IN.EQ.5) ALAM=ALMKS ENDIF ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMVC(IN)/ALM1 RATM2=AMVC(IN)/ALM2 RATM3=AMVC(IN)/ALM3 FAC0=AMVC(IN)*AMVC(IN)/AMPRO/AMPRO FAC1=AMVC(IN)*AMVC(IN)/(XM1(1)*XM2(1)) FAC2=AMVC(IN)*AMVC(IN)/(XM1(2)*XM2(2)) FAC3=AMVC(IN)*AMVC(IN)/(XM1(3)*XM2(3)) FFAC1 = XM2(1)/XM1(1)-XM1(1)/XM2(1) FFAC2 = XM2(2)/XM1(2)-XM1(2)/XM2(2) FFAC3 = XM2(3)/XM1(3)-XM1(3)/XM2(3) C c 23/4/2001: wrong: c CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM1(1)+GDFLL/XM2(1))*AMVC(IN)**2 c . /(4.*AMPRO) c CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM1(2)+GDFSS/XM2(2))*AMVC(IN)**2 c . /(4.*AMPRO) c CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM1(3)+GDFLS/XM2(3))*AMVC(IN)**2 c . /(4.*AMPRO) c CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM1(2)+GDFDR/XM2(2))*AMVC(IN)**2 c . /(4.*AMPRO) c CSLL1= GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1)+GFLL*XM1(1)*XM2(1)/AMPRO) c . /AMPRO c CSSS1= GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2)+GFSS*XM1(2)*XM2(2)/AMPRO) c . /AMPRO c CSLS1= GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3)+GFLS*XM1(3)*XM2(3)/AMPRO) c . /AMPRO c CSDR1= GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2)+GFDR*XM1(2)*XM2(2)/AMPRO) c . /AMPRO c 23/4/2001: mass goes wth f-coupling: f13 -> 1/M_Y,f24 -> 1/M_N: CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM2(1)+GDFLL/XM1(1))*AMVC2 . /(4.*AMPRO) CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM2(2)+GDFSS/XM1(2))*AMVC2 . /(4.*AMPRO) CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM2(3)+GDFLS/XM1(3))*AMVC2 . /(4.*AMPRO) CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM2(2)+GDFDR/XM1(2))*AMVC2 . /(4.*AMPRO) c 23/4/2001: mass goes wth f-coupling: f13 -> 1/M_Y,f24 -> 1/M_N: CSLL1= GDLL+(GFDLL*XM2(1)+GDFLL*XM1(1)+GFLL*XM1(1)*XM2(1)/AMPRO) . /AMPRO CSSS1= GDSS+(GFDSS*XM2(2)+GDFSS*XM1(2)+GFSS*XM1(2)*XM2(2)/AMPRO) . /AMPRO CSLS1= GDLS+(GFDLS*XM2(3)+GDFLS*XM1(3)+GFLS*XM1(3)*XM2(3)/AMPRO) . /AMPRO CSDR1= GDDR+(GFDDR*XM2(2)+GDFDR*XM1(2)+GFDR*XM1(2)*XM2(2)/AMPRO) . /AMPRO CTLL0= CSLL1 CTSS0= CSSS1 CTLS0= CSLS1 CTDR0= CSDR1 COLL0= 1.5D0*GDLL+(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO COSS0= 1.5D0*GDSS+(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO COLS0= 1.5D0*GDLS+(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO CODR0= 1.5D0*GDDR+(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO CALL0= .GDLL*FFAC1/4D0-(GFDLL-GDFLL)*DSQRT(XM1(1)*XM2(1))/AMPRO CASS0= .GDSS*FFAC2/4D0-(GFDSS-GDFSS)*DSQRT(XM1(2)*XM2(2))/AMPRO CALS0= .GDLS*FFAC3/4D0-(GFDLS-GDFLS)*DSQRT(XM1(3)*XM2(3))/AMPRO CADR0= .GDDR*FFAC2/4D0-(GFDDR-GDFDR)*DSQRT(XM1(2)*XM2(2))/AMPRO CALL1= GFLL*FFAC1*AMVC2/(16*AMPRO*AMPRO) CASS1= GFSS*FFAC2*AMVC2/(16*AMPRO*AMPRO) CALS1= GFLS*FFAC3*AMVC2/(16*AMPRO*AMPRO) CADR1= GFDR*FFAC2*AMVC2/(16*AMPRO*AMPRO) C BROWN, DOWNS AND IDDINGS TERM: IF(IN.EQ.5) THEN C HERE INSTEAD OF P, WE MUST TAKE P_x=SPACE-EXCHANGE: L=1 -> -1: c PX = -1D0 CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2* . (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1)) CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2* . (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3)) CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2* . (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2)) ENDIF CO2LL= GDLL+4*(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO + + 8*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO CO2SS= GDSS+4*(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO + + 8*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO CO2LS= GDLS+4*(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO + + 8*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO CO2DR= GDDR+4*(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO + + 8*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO C c DO 104 I=2,NMAX c X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMVC(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMVC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMVC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMVC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENLL = FVC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOLL = FVC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2LL = 3*FTENLL/(X*X) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENSS = FVC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOSS = FVC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2SS = 3*FTENSS/(X*X) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN) FTENLS = FVC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN) FSOLS = FVC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN) FSO2LS = 3*FTENLS/(X*X) C FCLL1 = FCLL0 - FVC(IN)*VKULL*AMVC(IN) FCSS1 = FCSS0 - FVC(IN)*VKUSS*AMVC(IN) FCLS1 = FCLS0 - FVC(IN)*VKULS*AMVC(IN) FCLL2 = FCLL1+ . FVC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMVC(IN)/RATM1/RATM1 FCSS2 = FCSS1+ . FVC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMVC(IN)/RATM2/RATM2 FCLS2 = FCLS1+ . FVC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMVC(IN)/RATM3/RATM3 FTLL1 = FTENLL - FVC(IN)*XLAM1*XLAM1*VKULL*AMVC(IN) . / (3*RATM1*RATM1) FTSS1 = FTENSS - FVC(IN)*XLAM2*XLAM2*VKUSS*AMVC(IN) . / (3*RATM2*RATM2) FTLS1 = FTENLS - FVC(IN)*XLAM3*XLAM3*VKULS*AMVC(IN) . / (3*RATM3*RATM3) FOLL1 = FSOLL - FVC(IN)*VKULL*AMVC(IN) . / (2*RATM1*RATM1) FOSS1 = FSOSS - FVC(IN)*VKUSS*AMVC(IN) . / (2*RATM2*RATM2) FOLS1 = FSOLS - FVC(IN)*VKULS*AMVC(IN) . / (2*RATM3*RATM3) C C------------------------------------------------------------ C THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS: c** IF(IN.NE.5) THEN IF(IDAM.NE.0.AND.IN.NE.5) THEN CALL YMKFUN(XA,AMVC(IN),ALAM,SIGN,IDAM*DAMSL, .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1) FXSO2 = 3*FXTEN/(X*X) C------------------------------------------------------------ IF(LC.EQ.1) THEN FCSS0 = FVC(IN)*AMVC(IN)*FXC0 FTENSS= FVC(IN)*AMVC(IN)*FXTEN FSOSS = FVC(IN)*AMVC(IN)*FXSO FSO2SS= FVC(IN)*AMVC(IN)*FXSO2 FCSS1 = FVC(IN)*AMVC(IN)*FXC1 FCSS2 = FVC(IN)*AMVC(IN)*FXC2 FTSS1 = FVC(IN)*AMVC(IN)*FXTEN1 FOSS1 = FVC(IN)*AMVC(IN)*FXSO1 ENDIF IF(LC.NE.1) THEN FCLL0 = FVC(IN)*AMVC(IN)*FXC0 FTENLL= FVC(IN)*AMVC(IN)*FXTEN FSOLL = FVC(IN)*AMVC(IN)*FXSO FSO2LL= FVC(IN)*AMVC(IN)*FXSO2 FCLL1 = FVC(IN)*AMVC(IN)*FXC1 FCLL2 = FVC(IN)*AMVC(IN)*FXC2 FTLL1 = FVC(IN)*AMVC(IN)*FXTEN1 FOLL1 = FVC(IN)*AMVC(IN)*FXSO1 ENDIF FCLS0 = 0.5D0*(FCLS0 + FVC(IN)*AMVC(IN)*FXC0 ) FTENLS = 0.5D0*(FTENLS + FVC(IN)*AMVC(IN)*FXTEN) FSOLS = 0.5D0*(FSOLS + FVC(IN)*AMVC(IN)*FXSO ) FSO2LS = 0.5D0*(FSO2LS + FVC(IN)*AMVC(IN)*FXSO2) FCLS1 = 0.5D0*(FCLS1 + FVC(IN)*AMVC(IN)*FXC1 ) FCLS2 = 0.5D0*(FCLS2 + FVC(IN)*AMVC(IN)*FXC2 ) FTLS1 = 0.5D0*(FTLS1 + FVC(IN)*AMVC(IN)*FXTEN1) FOLS1 = 0.5D0*(FOLS1 + FVC(IN)*AMVC(IN)*FXSO1) ENDIF C------------------------------------------------------------ C VCLL = VCLL + GDLL*FCLL0 + CCLL1*FCLL1 + . GFLL*FAC0*FAC1*FCLL2/16.D0 . + (1-INRS)*FAC1*(GDLL*FAC1/64.D0+(GDFLL . +GFDLL)*DSQRT(FAC0*FAC1)/16.D0)*FCLL2 VCSS = VCSS + GDSS*FCSS0 + CCSS1*FCSS1 + . GFSS*FAC0*FAC2*FCSS2/16.D0 . + (1-INRS)*FAC2*(GDSS*FAC2/64.D0+(GDFSS . +GFDSS)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2 VCLS = VCLS + GDLS*FCLS0 + CCLS1*FCLS1 + . GFLS*FAC0*FAC3*FCLS2/16.D0 . + (1-INRS)*FAC3*(GDLS*FAC3/64.D0+(GDFLS . +GFDLS)*DSQRT(FAC0*FAC3)/16.D0)*FCLS2 VCDR = VCDR + GDDR*FCSS0 + CCDR1*FCSS1 + . GFDR*FAC0*FAC2*FCSS2/16.D0 . + (1-INRS)*FAC2*(GDDR*FAC2/64.D0+(GDFDR . +GFDDR)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2 C VSIGLL= VSIGLL + (CSLL1*FCLL1 + INRS*GFLL*FAC0*FCLL2/8.D0) . * FAC1/6.D0 VSIGSS= VSIGSS + (CSSS1*FCSS1 + INRS*GFSS*FAC0*FCSS2/8.D0) . * FAC2/6.D0 VSIGLS= VSIGLS + (CSLS1*FCLS1 + INRS*GFLS*FAC0*FCLS2/8.D0) . * FAC3/6.D0 VSIGDR= VSIGDR + (CSDR1*FCSS1 + INRS*GFDR*FAC0*FCSS2/8.D0) . * FAC2/6.D0 C VTENLL= VTENLL - (CTLL0*FTENLL + INRS*GFLL*FAC0*FTLL1/8.D0) . * FAC1/4.D0 VTENSS= VTENSS - (CTSS0*FTENSS + INRS*GFSS*FAC0*FTSS1/8.D0) . * FAC2/4.D0 VTENLS= VTENLS - (CTLS0*FTENLS + INRS*GFLS*FAC0*FTSS1/8.D0) . * FAC3/4.D0 VTENDR= VTENDR - (CTDR0*FTENSS + INRS*GFDR*FAC0*FTSS1/8.D0) . * FAC2/4.D0 C VSOLL = VSOLL - (COLL0*FSOLL + GFLL*FAC0*FOLL1*3/8.D0) . * FAC1 VSOSS = VSOSS - (COSS0*FSOSS + GFSS*FAC0*FOSS1*3/8.D0) . * FAC2 VSOLS = VSOLS - (COLS0*FSOLS + GFLS*FAC0*FOLS1*3/8.D0) . * FAC3 VSODR = VSODR - (CODR0*FSOSS + GFDR*FAC0*FOSS1*3/8.D0) . * FAC2 c if(icall.eq.0.and.in.eq.5) then c write(*,*) 'vector: in=',in,' amvc=',amvc(in),' coll0=',coll0 c .,' alm1=',alm1,' fac1=',fac1 c write(*,*) ' in=',in,' xa=',xa,' fsoll=',fsoll,' vsoll=',vsoll c write(*,*) 'fvc=',fvc(in),' ex,x,xlam1,derfcm,derfcp,elam=', c . ex,x,xlam1,derfcm,derfcp,elam c endif C VASOLL= VASOLL - (CALL0*FSOLL-CALL1*FOLL1)*FAC1 VASOSS= VASOSS - (CASS0*FSOSS-CASS1*FOSS1)*FAC2 VASOLS= VASOLS - (CALS0*FSOLS-CALS1*FOLS1)*FAC3 VASODR= VASODR - (CADR0*FSOSS-CADR1*FOSS1)*FAC2 C VSO2LL= VSO2LL + CO2LL*FSO2LL*FAC1*FAC1/16.D0 VSO2SS= VSO2SS + CO2SS*FSO2SS*FAC2*FAC2/16.D0 VSO2LS= VSO2LS + CO2LS*FSO2LS*FAC3*FAC3/16.D0 VSO2DR= VSO2DR + CO2DR*FSO2SS*FAC2*FAC2/16.D0 C IF(IN.NE.5) GOTO 105 C K-STAR: CONTRIBUTION SECOND TERM IN VECTOR PROPAGATOR C VCLL = VCLL - GDLL*PROSLL*(FCLL0-0.25D0*FAC1*FCLL1) VCSS = VCSS - GDSS*PROSSS*(FCSS0-0.25D0*FAC2*FCSS1) VCLS = VCLS - GDLS*PROSLS*(FCLS0-0.25D0*FAC3*FCLS1) VCDR = VCDR - GDDR*PROSSS*(FCSS0-0.25D0*FAC2*FCSS1) C VSOLL = VSOLL - GDLL*PROSLL*FSOLL*FAC1/2.D0 VSOSS = VSOSS - GDSS*PROSSS*FSOSS*FAC2/2.D0 VSOLS = VSOLS - GDLS*PROSLS*FSOLS*FAC3/2.D0 VSODR = VSODR - GDDR*PROSSS*FSOSS*FAC2/2.D0 C VASOLL = VASOLL - GDLL*PROSLL*FSOLL*FFAC1*FAC1/4.D0 VASOSS = VASOSS - GDSS*PROSSS*FSOSS*FFAC2*FAC2/4.D0 VASOLS = VASOLS - GDLS*PROSLS*FSOLS*FFAC3*FAC3/4.D0 VASODR = VASODR - GDDR*PROSSS*FSOSS*FFAC2*FAC2/4.D0 C VSO2LL = VSO2LL - GDLL*PROSLL*FSO2LL*FAC1*FAC1/16.D0 VSO2SS = VSO2SS - GDSS*PROSSS*FSO2SS*FAC2*FAC2/16.D0 VSO2LS = VSO2LS - GDLS*PROSLS*FSO2LS*FAC3*FAC3/16.D0 VSO2DR = VSO2DR - GDDR*PROSSS*FSO2SS*FAC2*FAC2/16.D0 C IF(NLOC.NE.0) THEN FILL = FILL + 0.5D0*GDLL*PROSLL*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + 0.5D0*GDSS*PROSSS*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + 0.5D0*GDLS*PROSLS*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + 0.5D0*GDDR*PROSSS*FCSS0/(XM1(2)*XM2(2)) DFILL= DFILL - 0.5D0*GDLL*PROSLL*FSOLL*X*REDM(1)/ . (AMVC(IN)*XM1(1)*XM2(1)) DFISS= DFISS - 0.5D0*GDSS*PROSSS*FSOSS*X*REDM(2)/ . (AMVC(IN)*XM1(2)*XM2(2)) DFILS= DFILS - 0.5D0*GDLS*PROSLS*FSOLS*X*REDM(3)/ . (AMVC(IN)*XM1(3)*XM2(3)) DFIDR= DFIDR - 0.5D0*GDLS*PROSSS*FSOSS*X*REDM(2)/ . (AMVC(IN)*XM1(2)*XM2(2)) DDFILL= DDFILL + 0.5D0*GDLL*PROSLL*(3*FTENLL-FSOLL) . *REDM(1)*AMVC(IN)**2/(XM1(1)*XM2(1)) DDFISS= DDFISS + 0.5D0*GDSS*PROSSS*(3*FTENSS-FSOSS) . *REDM(2)*AMVC(IN)**2/(XM1(2)*XM2(2)) DDFILS= DDFILS + 0.5D0*GDLS*PROSLS*(3*FTENLS-FSOLS) . *REDM(3)*AMVC(IN)**2/(XM1(3)*XM2(3)) DDFIDR= DDFIDR + 0.5D0*GDDR*PROSSS*(3*FTENSS-FSOSS) . *REDM(2)*AMVC(IN)**2/(XM1(2)*XM2(2)) ENDIF C C AUGUST 1998 ADDITIONS: C BEGIN RETARDATION IF(IRET.EQ.1) THEN CALL FFUN(3,XA,AMVC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3) VCLL = VCLL - GDLL*PROSLL*WKIN1*VARFI0 VCSS = VCSS - GDSS*PROSSS*WKIN2*VARFI0 VCLS = VCLS - GDLS*PROSLS*WKIN3*VARFI0 VCDR = VCDR - GDDR*PROSSS*WKIN2*VARFI0 C FILL = FILL + 0.5D0*GDLL*PROSLL*VARFI0 FISS = FISS + 0.5D0*GDSS*PROSSS*VARFI0 FILS = FILS + 0.5D0*GDLS*PROSLS*VARFI0 FIDR = FIDR + 0.5D0*GDDR*PROSSS*VARFI0 C DFILL = DFILL + 0.5D0*GDLL*PROSLL*VARFI1*PIM DFISS = DFISS + 0.5D0*GDSS*PROSSS*VARFI1*PIM DFILS = DFILS + 0.5D0*GDLS*PROSLS*VARFI1*PIM DFIDR = DFIDR + 0.5D0*GDDR*PROSSS*VARFI1*PIM ENDIF C END RETARDATION C 105 IF(NLOC.EQ.0) GOTO 106 FILL = FILL + 1.5D0*REDMM*GDLL*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + 1.5D0*REDMM*GDSS*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + 1.5D0*REDMM*GDLS*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + 1.5D0*REDMM*GDDR*FCSS0/(XM1(2)*XM2(2)) C DFILL=DFILL-1.5D0*REDMM*GDLL*FSOLL*X*FAC1/AMVC(IN) DFISS=DFISS-1.5D0*REDMM*GDSS*FSOSS*X*FAC2/AMVC(IN) DFILS=DFILS-1.5D0*REDMM*GDLS*FSOLS*X*FAC3/AMVC(IN) DFIDR=DFIDR-1.5D0*REDMM*GDDR*FSOSS*X*FAC2/AMVC(IN) C DDFILL=DDFILL+1.5D0*REDMM*GDLL*(FCLL1+2*FSOLL)*FAC1 ! NOVEMBER 2010 DDFISS=DDFISS+1.5D0*REDMM*GDSS*(FCSS1+2*FSOSS)*FAC2 DDFILS=DDFILS+1.5D0*REDMM*GDLS*(FCLS1+2*FSOLS)*FAC3 DDFIDR=DDFIDR+1.5D0*REDMM*GDDR*(FCSS1+2*FSOSS)*FAC2 C C------------------------------------------------------------ C AUGUST 1998 ADDITIONS: C BEGIN RETARDATION IF(IRET.EQ.1) THEN CALL FFUN(3,XA,AMVC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3) VCLL = VCLL + GDLL*WKIN1*VARFI0 VCSS = VCSS + GDSS*WKIN2*VARFI0 VCLS = VCLS + GDLS*WKIN3*VARFI0 VCDR = VCDR + GDDR*WKIN2*VARFI0 C FILL = FILL - 0.5D0*GDLL*VARFI0 FISS = FISS - 0.5D0*GDSS*VARFI0 FILS = FILS - 0.5D0*GDLS*VARFI0 FIDR = FIDR - 0.5D0*GDDR*VARFI0 C DFILL = DFILL - 0.5D0*GDLL*VARFI1*PIM DFISS = DFISS - 0.5D0*GDSS*VARFI1*PIM DFILS = DFILS - 0.5D0*GDLS*VARFI1*PIM DFIDR = DFIDR - 0.5D0*GDDR*VARFI1*PIM ENDIF C END RETARDATION C------------------------------------------------------------ C BEGIN ZERO IN FORM-FACTOR: 106 IF(IZVC.EQ.1) THEN FZERO = (AMVC(IN)/AMCRV)**2 FC3 = FCLL2 - FVC(IN)*(3.75D0-5*XLAM1**2+XLAM1**4) . * VKULL*AMVC(IN)/(RATM1**4) FT2 = FTLL1 - FVC(IN)*(-7.D0+2*XLAM1**2)*XLAM1**2*VKULL . * AMVC(IN)/(6*RATM1**4) FO2 = FOLL1 + FVC(IN)*(2.5D0-XLAM1**2)*VKULL*AMVC(IN) . / (2*RATM1**4) FO21 = 3*FTLL1/(X*X) VCLL = VCLL + FZERO*(GDLL*FCLL1+CCLL1*FCLL2+ . GFLL*FAC0*FAC1*FC3/16.D0) VCSS = VCSS + FZERO*(GDSS*FCSS1+CCSS1*FCSS2+ . GFSS*FAC0*FAC1*FC3/16.D0) VCLS = VCLS + FZERO*(GDLS*FCLS1+CCLS1*FCLS2+ . GFLS*FAC0*FAC1*FC3/16.D0) VCDR = VCDR + FZERO*(GDLL*FCSS1+CCDR1*FCSS2+ . GFDR*FAC0*FAC1*FC3/16.D0) VSIGLL= VSIGLL + FZERO*(CSLL1*FCLL2+GFLL*FAC0*FC3/8.D0) . * FAC1/6.D0 VSIGSS= VSIGSS + FZERO*(CSSS1*FCSS2+GFSS*FAC0*FC3/8.D0) . * FAC1/6.D0 VSIGLS= VSIGLS + FZERO*(CSLS1*FCLS2+GFLS*FAC0*FC3/8.D0) . * FAC1/6.D0 VSIGDR= VSIGDR + FZERO*(CSDR1*FCSS2+GFDR*FAC0*FC3/8.D0) . * FAC1/6.D0 VTENLL= VTENLL - FZERO*(CTLL0*FTLL1+GFLL*FAC0*FT2/8.D0) . * FAC1/4.D0 VTENSS= VTENSS - FZERO*(CTSS0*FTSS1+GFSS*FAC0*FT2/8.D0) . * FAC1/4.D0 VTENLS= VTENLS - FZERO*(CTLS0*FTLS1+GFLS*FAC0*FT2/8.D0) . * FAC1/4.D0 VTENDR= VTENDR - FZERO*(CTDR0*FTSS1+GFDR*FAC0*FT2/8.D0) . * FAC1/4.D0 VSOLL = VSOLL - FZERO*(COLL0*FOLL1+GFLL*FAC0*FO2*3/8.D0) . * FAC1 VSOSS = VSOSS - FZERO*(COSS0*FOSS1+GFSS*FAC0*FO2*3/8.D0) . * FAC1 VSOLS = VSOLS - FZERO*(COLS0*FOLS1+GFLS*FAC0*FO2*3/8.D0) . * FAC1 VSODR = VSODR - FZERO*(CODR0*FOSS1+GFDR*FAC0*FO2*3/8.D0) . * FAC1 VASOLL= VASOLL - FZERO*(CALL0*FOLL1-CALL1*FO2)*FAC1 VASOSS= VASOSS - FZERO*(CASS0*FOSS1-CASS1*FO2)*FAC2 VASOLS= VASOLS - FZERO*(CALS0*FOLS1-CALS1*FO2)*FAC3 VASODR= VASODR - FZERO*(CADR0*FOSS1-CADR1*FO2)*FAC2 VSO2LL= VSO2LL + FZERO* CO2LL*FO21*FAC1*FAC1/16.D0 VSO2SS= VSO2SS + FZERO* CO2SS*FO21*FAC2*FAC2/16.D0 VSO2LS= VSO2LS + FZERO* CO2LS*FO21*FAC3*FAC3/16.D0 VSO2DR= VSO2DR + FZERO* CO2DR*FO21*FAC2*FAC2/16.D0 IF(NLOC.NE.0) THEN FILL = FILL + FZERO*1.5D0*REDMM*GDLL*FCLL1/(XM1(1)*XM2(1)) FISS = FISS + FZERO*1.5D0*REDMM*GDSS*FCSS1/(XM1(1)*XM2(1)) FILS = FILS + FZERO*1.5D0*REDMM*GDLS*FCLS1/(XM1(1)*XM2(1)) FIDR = FIDR + FZERO*1.5D0*REDMM*GDDR*FCSS1/(XM1(1)*XM2(1)) DFILL = DFILL - FZERO*1.5D0*REDMM*GDLL*FOLL1*X*FAC1/AMVC(IN) DFISS = DFISS - FZERO*1.5D0*REDMM*GDSS*FOSS1*X*FAC2/AMVC(IN) DFILS = DFILS - FZERO*1.5D0*REDMM*GDLS*FOLS1*X*FAC3/AMVC(IN) DFIDR = DFIDR - FZERO*1.5D0*REDMM*GDDR*FOSS1*X*FAC2/AMVC(IN) C DDFILL=DDFILL + FZERO*1.5D0*REDMM*GDLL*(FCLL2+2*FOLL1)*FAC1 ! NOVEMBER 2010 DDFISS=DDFISS + FZERO*1.5D0*REDMM*GDSS*(FCSS2+2*FOSS1)*FAC2 DDFILS=DDFILS + FZERO*1.5D0*REDMM*GDLS*(FCLS2+2*FOLS1)*FAC3 DDFIDR=DDFIDR + FZERO*1.5D0*REDMM*GDDR*(FCSS2+2*FOSS1)*FAC2 ENDIF IF(IN.NE.5) GOTO 104 C K-STAR: CONTRIBUTION SECOND TERM IN VECTOR PROPAGATOR C VCLL = VCLL - FZERO*GDLL*PROSLL*(FCLL1-0.25D0*FAC1*FCLL2) VCSS = VCSS - FZERO*GDSS*PROSSS*(FCSS1-0.25D0*FAC2*FCSS2) VCLS = VCLS - FZERO*GDLS*PROSLS*(FCLS1-0.25D0*FAC3*FCLS2) VCDR = VCDR - FZERO*GDDR*PROSSS*(FCSS1-0.25D0*FAC2*FCSS2) VSOLL = VSOLL - FZERO*GDLL*PROSLL*FOLL1*FAC1/2.D0 VSOSS = VSOSS - FZERO*GDSS*PROSSS*FOSS1*FAC2/2.D0 VSOLS = VSOLS - FZERO*GDLS*PROSLS*FOLS1*FAC3/2.D0 VSODR = VSODR - FZERO*GDDR*PROSSS*FOSS1*FAC2/2.D0 VASOLL = VASOLL - FZERO*GDLL*PROSLL*FOLL1*FFAC1*FAC1/4.D0 VASOSS = VASOSS - FZERO*GDSS*PROSSS*FOSS1*FFAC1*FAC2/4.D0 VASOLS = VASOLS - FZERO*GDLS*PROSLS*FOLS1*FFAC1*FAC3/4.D0 VASODR = VASODR - FZERO*GDDR*PROSSS*FOSS1*FFAC1*FAC2/4.D0 VSO2LL = VSO2LL - FZERO*GDLL*PROSLL*FO21*FAC1*FAC1/16.D0 VSO2SS = VSO2SS - FZERO*GDSS*PROSSS*FO21*FAC2*FAC2/16.D0 VSO2LS = VSO2LS - FZERO*GDLS*PROSLS*FO21*FAC3*FAC3/16.D0 VSO2DR = VSO2DR - FZERO*GDDR*PROSDR*FO21*FAC2*FAC2/16.D0 IF(NLOC.NE.0) THEN FILL = FILL + FZERO* 0.5D0*GDLL*PROSLL*FCLL1/(XM1(1)*XM2(1)) FISS = FISS + FZERO* 0.5D0*GDSS*PROSSS*FCSS1/(XM1(2)*XM2(2)) FILS = FILS + FZERO* 0.5D0*GDLS*PROSLS*FCLS1/(XM1(3)*XM2(3)) FIDR = FIDR + FZERO* 0.5D0*GDDR*PROSSS*FCSS1/(XM1(2)*XM2(2)) DFILL= DFILL - FZERO*0.5D0*GDLL*PROSLL*FOLL1*X*REDM(1)/ . (AMVC(IN)*XM1(1)*XM2(1)) DFISS= DFISS - FZERO*0.5D0*GDSS*PROSSS*FOSS1*X*REDM(2)/ . (AMVC(IN)*XM1(2)*XM2(2)) DFILS= DFILS - FZERO*0.5D0*GDLS*PROSLS*FOLS1*X*REDM(3)/ . (AMVC(IN)*XM1(3)*XM2(3)) DFIDR= DFIDR - FZERO*0.5D0*GDDR*PROSSS*FOSS1*X*REDM(2)/ . (AMVC(IN)*XM1(2)*XM2(2)) ENDIF ENDIF C END ZERO IN FORM-FACTOR. C------------------------------------------------------------ 104 CONTINUE C c print spin-orbit potentials LL: c if(in.eq.1) write(*,*) c if(in.eq.1) write(*,*) c .'in=1,2 <-> rho, in=3 <-> omega, in=4 <-> phi, in=5 <-> K*:' c write(*,*) ' VECTOR : x=',xa,' IN=',in,' vsoll=',vsoll, c .' vasoll=',vasoll 1040 CONTINUE C icall = 1 RETURN END C********************************************************************** C c* SUBROUTINE SCALAR(LC,NMAX,NLOC,ICSB) SUBROUTINE SCALAR(XA,ICSB,NLOC,LC) C C********************************************************************** C C VERSION FEBRUARY 07: DIRECT AND DERIVATIVE COUPLING SCALARS C VERSION AUGUST 2000: FIRST SU3-NONET, ASSIGNMENTS CHOOSEN: C EPS=f0(760), DEL=A0(962), S*=f0(993), KAPPA=K0(900) C********************************************************************** C updated december 2000, from YNRMP2k2.f , introducing mass C differences in meson propagators in the OBE-potentials, C according to Macke-Klein C---------------------------------------------------------------------- C C SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/ALLSC3/FS1,FS2,FS3,FS4,FS5,FS6,FS7,FS8,FS9,FS10,FS11 COMMON/ALLSC2/XALLSC2(5),GSA(11),GSB(11),IOPTSC DIMENSION GS(11),FS(11),AMSC(6),FSC(6),XM1(3),XM2(3) EQUIVALENCE (GS1,GS(1)),(FS1,FS(1)) EQUIVALENCE (GSA1,GSA(1)) DATA SR3/1.732051D0/,SRPI/1.772453851D0/,FMNL/1.D0/ DATA AMCRS/750.D0/,DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/ .,AMPRO/938.2796D0/ C C NOTE : DELTA(IN=1),EPS1(IN=2),EPS2(IN=3),SSTAR(IN=4),KAPPA(IN=5) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C------------------------------------------------------------------- C NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS ! C : INDEX 2,4 -> HYPERONS ! C------------------------------------------------------------------- C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) C C c SKAP = FS(1)/GS(1)/AMPRO c SKAP2= SKAP*SKAP RAMLN= DAMLN/AMPRO RAMSN= DAMSN/AMPRO RAMSL= DAMSL/AMPRO IF(LC.EQ.1) SIGN= 1.D0 IF(LC.NE.1) SIGN=-1.D0 IF(IRET.EQ.1) THEN WKIN1 = PIM**2*AKS(1)/(2*REDM(1)) WKIN2 = PIM**2*AKS(3)/(2*REDM(3)) WKIN3 = 0.5D0*(WKIN1+WKIN2) ENDIF DO 1040 IN=1,5 c IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) c ENDIF DGSLL = 0D0 DGSLS = 0D0 DGSSS = 0D0 DGSDR = 0D0 GOTO(1051,1052,1053,1054,1055),IN 1051 GSLL = -0.0271D0*ICSB*GS1*GS3 GSSS= -2*GS1*GS2 GSLS= -SR3*GS1*GS3 c GSLS= -SR3*(GS1*GS3-SIGN*RAMSL*GS1*FS3) GSDR= GS1*GS2 DGSLS= +SR3*SIGN*RAMSL*GS1*FS3 FSC(1)=1.D0 AMSC(1)=AMD GOTO 1056 1052 GSLL= GS6*GS7 GSSS= GS6*GS8 GSLS= 0.D0 GSDR= GS6*GS8 FSC(2)=ASI AMSC(2)=AM1SI GOTO 1056 1053 GSLL= GS6*GS7 GSSS= GS6*GS8 GSLS= 0.D0 GSDR= GS6*GS8 FSC(3)=BSI AMSC(3)=AM2SI GOTO 1056 1054 GSLL= GS9*GS10 GSSS= GS9*GS11 GSLS= 0.D0 GSDR= GS9*GS11 FSC(4)=1.D0 AMSC(4)=AMSST GOTO 1056 c*1055 GSLL= GS4*GS4*P*(1D0+SKAP2*DAMLN**2) c* GSSS= -GS5*GS5*P*(1D0+SKAP2*DAMSN**2) c* GSLS= -SR3*GS4*GS5*P*(1D0-SIGN*SKAP*DAMSL+SKAP2*DAMSN*DAMLN) c* GSDR= 2*GS5*GS5*P*(1D0+SKAP2*DAMSN**2) c1055 GSLL= (GS4*GS4+FS4*FS4*RAMLN**2)*P c GSSS= (GS5*GS5+FS5*FS5*RAMSN**2)*P c GSLS= -SR3*(GS4*GS5-SIGN*GS4*FS5*RAMSN+SIGN*GS5*FS4*RAMLN c . +FS4*FS5*RAMSN*RAMLN)*P c GSDR= 2*(GS5*GS5+FS5*FS5*RAMSN**2)*P 1055 GSLL= GS4*GS4*P GSSS= -GS5*GS5*P GSLS= -SR3*GS4*GS5*P GSDR= 2*GS5*GS5*P DGSLL= FS4*FS4*RAMLN**2*P DGSSS= FS5*FS5*RAMSN**2*P DGSLS= -SR3*(-SIGN*GS4*FS5*RAMSN+SIGN*GS5*FS4*RAMLN . +FS4*FS5*RAMSN*RAMLN)*P DGSDR= 2*FS5*FS5*RAMSN**2*P XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMLN c** XM1(3)=AMSN c** XM1(3)=(AMSN+AMLS)/2.D0 XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMSN c** XM2(3)=(AMSN+AMLS)/2.D0 c** XM2(3)=AMLS FSC(5)=1.D0 AMSC(5)=AMSCK C 1056 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMS8 IF(IN.EQ.2.OR.IN.EQ.3) ALAM=ALMS1 IF(IN.EQ.5) ALAM=ALMKP ENDIF ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMSC(IN)/ALM1 RATM2=AMSC(IN)/ALM2 RATM3=AMSC(IN)/ALM3 AMSC2=AMSC(IN)**2 AMSC3=AMSC(IN)**3 AMSC5=AMSC(IN)**5 FAC1=AMSC(IN)*AMSC(IN)/(XM1(1)*XM2(1)) FAC2=AMSC(IN)*AMSC(IN)/(XM1(2)*XM2(2)) FAC3=AMSC(IN)*AMSC(IN)/(XM1(3)*XM2(3)) FFAC1 = (1.D0/XM1(1)**2-1.D0/XM2(1)**2) FFAC2 = (1.D0/XM1(2)**2-1.D0/XM2(2)**2) FFAC3 = (1.D0/XM1(3)**2-1.D0/XM2(3)**2) C c DO 104 I=2,NMAX c X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMSC(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMSC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMSC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOLL = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC3 FSO2LL = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOSS = FSC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC3 FSO2SS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOLS = FSC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC3 FSO2LS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C FCLL1 = FCLL0 - FSC(IN)*VKULL*AMSC(IN) FCSS1 = FCSS0 - FSC(IN)*VKUSS*AMSC(IN) FCLS1 = FCLS0 - FSC(IN)*VKULS*AMSC(IN) FOLL1 = FSOLL -0.5D0*FSC(IN)*VKULL*AMSC3/RATM1**2 FOSS1 = FSOSS -0.5D0*FSC(IN)*VKUSS*AMSC3/RATM2**2 FOLS1 = FSOLS -0.5D0*FSC(IN)*VKULS*AMSC3/RATM3**2 C FCLL2 = FCLL1+ . FSC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMSC(IN)/RATM1/RATM1 FCSS2 = FCSS1+ . FSC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMSC(IN)/RATM2/RATM2 FCLS2 = FCLS1+ . FSC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMSC(IN)/RATM3/RATM3 c FCLL2 = 0.D0 c FCSS2 = 0.D0 c FCLS2 = 0.D0 C------------------------------------------------------------ C THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS: IF(IDAM.NE.0.AND.IN.NE.5) THEN CALL YMKFUN(XA,AMSC(IN),ALAM,SIGN,IDAM*DAMSL, .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1) FXSO2 = 3*FXTEN/(X*X) C------------------------------------------------------------ IF(LC.EQ.1) THEN FCSS0 = FSC(IN)*AMSC(IN)*FXC0 FCSS1 = FSC(IN)*AMSC(IN)*FXC1 FSOSS = FSC(IN)*AMSC3*FXSO FSO2SS= FSC(IN)*AMSC5*FXSO2 ENDIF IF(LC.NE.1) THEN FCLL0 = FSC(IN)*AMSC(IN)*FXC0 FCLL1 = FSC(IN)*AMSC(IN)*FXC1 FSOLL = FSC(IN)*AMSC3*FXSO FSO2LL= FSC(IN)*AMSC5*FXSO2 ENDIF FCLS0 = 0.5D0*(FCLS0 + FSC(IN)*AMSC(IN)*FXC0 ) FCLS1 = 0.5D0*(FCLS1 + FSC(IN)*AMSC(IN)*FXC1 ) FSOLS = 0.5D0*(FSOLS + FSC(IN)*AMSC3*FXSO ) FSO2LS = 0.5D0*(FSO2LS + FSC(IN)*AMSC5*FXSO2) ENDIF C-------------------------------------------------------------------- C CONTRIBUTION DERIVATIVE COUPLING: c IF(I.EQ.2) THEN GSLL = GSLL + DGSLL GSLS = GSLS + DGSLS GSSS = GSSS + DGSSS GSDR = GSDR + DGSDR c ENDIF C-------------------------------------------------------------------- C VCLL = VCLL - GSLL*(FCLL0-0.25D0*FAC1*FCLL1) VCSS = VCSS - GSSS*(FCSS0-0.25D0*FAC2*FCSS1) VCLS = VCLS - GSLS*(FCLS0-0.25D0*FAC3*FCLS1) VCDR = VCDR - GSDR*(FCSS0-0.25D0*FAC2*FCSS1) C VSOLL = VSOLL - 0.5D0*GSLL*FSOLL/(XM1(1)*XM2(1)) VSOSS = VSOSS - 0.5D0*GSSS*FSOSS/(XM1(2)*XM2(2)) VSOLS = VSOLS - 0.5D0*GSLS*FSOLS/(XM1(3)*XM2(3)) VSODR = VSODR - 0.5D0*GSDR*FSOSS/(XM1(2)*XM2(2)) C VASOLL = VASOLL - GSLL*FSOLL*FFAC1/4.D0 VASOSS = VASOSS - GSSS*FSOSS*FFAC2/4.D0 VASOLS = VASOLS - GSLS*FSOLS*FFAC3/4.D0 VASODR = VASODR - GSDR*FSOSS*FFAC2/4.D0 C VSO2LL= VSO2LL - GSLL*FSO2LL/(4*XM1(1)*XM2(1))**2 VSO2SS= VSO2SS - GSSS*FSO2SS/(4*XM1(2)*XM2(2))**2 VSO2LS= VSO2LS - GSLS*FSO2LS/(4*XM1(3)*XM2(3))**2 VSO2DR= VSO2DR - GSDR*FSO2SS/(4*XM1(2)*XM2(2))**2 C-------------------------------------------------------------------- IF(NLOC.NE.0) THEN FILL = FILL + 0.5D0*REDMM*GSLL*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + 0.5D0*REDMM*GSSS*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + 0.5D0*REDMM*GSLS*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + 0.5D0*REDMM*GSDR*FCSS0/(XM1(2)*XM2(2)) C DFILL=DFILL-0.5*REDMM*GSLL*FSOLL*X/(AMSC(IN)*XM1(1)*XM2(1)) DFISS=DFISS-0.5*REDMM*GSSS*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2)) DFILS=DFILS-0.5*REDMM*GSLS*FSOLS*X/(AMSC(IN)*XM1(3)*XM2(3)) DFIDR=DFIDR-0.5*REDMM*GSDR*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2)) C DDFILL=DDFILL+0.5*REDMM*GSLL*(FCLL1*AMSC2+2*FSOLL)/ ! NOVEMBER 2010 . (XM1(1)*XM2(1)) DDFISS=DDFISS+0.5*REDMM*GSSS*(FCSS1*AMSC2+2*FSOSS)/ . (XM1(2)*XM2(2)) DDFILS=DDFILS+0.5*REDMM*GSLS*(FCLS1*AMSC2+2*FSOLS)/ . (XM1(3)*XM2(3)) DDFIDR=DDFIDR+0.5*REDMM*GSDR*(FCSS1*AMSC2+2*FSOSS)/ . (XM1(2)*XM2(2)) ENDIF C-------------------------------------------------------------------- C ZERO IN FORM FACTOR: IF(IZSC.NE.0) THEN C-------------------------------------------------------------------- C NO CONTRIBUTION DERIVATIVE COUPLING: c* IF(I.EQ.2) THEN c* GSLL = GSLL - DGSLL c* GSLS = GSLS - DGSLS c* GSSS = GSSS - DGSSS c* GSDR = GSDR - DGSDR c* ENDIF C-------------------------------------------------------------------- FZERO = (AMSC(IN)/AMCRS)**2 FC2 = FCLL1 + FSC(IN)*(1.5D0-XLAM1*XLAM1) . * VKULL*AMSC(IN)/RATM1/RATM1 FO1 = FSOLL - FSC(IN)*(VKULL/(2*RATM1*RATM1)) . *AMSC3 FO21 = FSO2LL- FSC(IN)*VKULL/(4*RATM1**4)*AMSC5 VCLL = VCLL - FZERO*GSLL*(FCLL1-0.25D0*FAC1*FC2) VCSS = VCSS - FZERO*GSSS*(FCSS1-0.25D0*FAC2*FC2) VCLS = VCLS - FZERO*GSLS*(FCLS1-0.25D0*FAC3*FC2) VCDR = VCDR - FZERO*GSDR*(FCSS1-0.25D0*FAC2*FC2) c VSOLL = VSOLL - FZERO*0.5D0*GSLL*FO1 c VSOSS = VSOSS - FZERO*0.5D0*GSSS*FO1 c VSOLS = VSOLS - FZERO*0.5D0*GSLS*FO1 c VSODR = VSODR - FZERO*0.5D0*GSDR*FO1 VSOLL = VSOLL - FZERO*0.5D0*GSLL*FO1/(XM1(1)*XM2(1)) VSOSS = VSOSS - FZERO*0.5D0*GSSS*FO1/(XM1(2)*XM2(2)) VSOLS = VSOLS - FZERO*0.5D0*GSLS*FO1/(XM1(3)*XM2(3)) VSODR = VSODR - FZERO*0.5D0*GSDR*FO1/(XM1(2)*XM2(2)) C VASOLL = VASOLL - FZERO*GSLL*FO1*FFAC1/4.D0 VASOSS = VASOSS - FZERO*GSSS*FO1*FFAC2/4.D0 VASOLS = VASOLS - FZERO*GSLS*FO1*FFAC3/4.D0 VASODR = VASODR - FZERO*GSDR*FO1*FFAC2/4.D0 c VSO2LL= VSO2LL - FZERO*GSLL*FO21/16.D0 c VSO2SS= VSO2SS - FZERO*GSSS*FO21/16.D0 c VSO2LS= VSO2LS - FZERO*GSLS*FO21/16.D0 c VSO2DR= VSO2DR - FZERO*GSDR*FO21/16.D0 VSO2LL= VSO2LL - FZERO*GSLL*FO21/(4*XM1(1)*XM2(1))**2 VSO2SS= VSO2SS - FZERO*GSSS*FO21/(4*XM1(2)*XM2(2))**2 VSO2LS= VSO2LS - FZERO*GSLS*FO21/(4*XM1(3)*XM2(3))**2 VSO2DR= VSO2DR - FZERO*GSDR*FO21/(4*XM1(2)*XM2(2))**2 IF(NLOC.NE.0.AND.IZSC.EQ.2) THEN c* IF(NLOC.NE.0.AND.IZSC.LT.0) THEN FILL = FILL + FZERO*0.5D0*REDMM*GSLL*FCLL1/(XM1(1)*XM2(1)) FISS = FISS + FZERO*0.5D0*REDMM*GSSS*FCSS1/(XM1(2)*XM2(2)) FILS = FILS + FZERO*0.5D0*REDMM*GSLS*FCLS1/(XM1(3)*XM2(3)) FIDR = FIDR + FZERO*0.5D0*REDMM*GSDR*FCSS1/(XM1(2)*XM2(2)) DFILL=DFILL - FZERO*0.5*REDMM*GSLL*FOLL1*X/ . (AMSC(IN)*XM1(1)*XM2(1)) DFISS=DFISS - FZERO*0.5*REDMM*GSSS*FOSS1*X/ . (AMSC(IN)*XM1(2)*XM2(2)) DFILS=DFILS - FZERO*0.5*REDMM*GSLS*FOLS1*X/ . (AMSC(IN)*XM1(3)*XM2(3)) DFIDR=DFIDR - FZERO*0.5*REDMM*GSDR*FOSS1*X/ . (AMSC(IN)*XM1(2)*XM2(2)) C DDFILL=DDFILL+FZERO*0.5D0*REDMM*GSLL*(FCLL2*AMSC2+2*FOLL1)/ ! NOVEMBER 2010 . (XM1(1)*XM2(1)) DDFISS=DDFISS+FZERO*0.5D0*REDMM*GSSS*(FCSS2*AMSC2+2*FOSS1)/ . (XM1(2)*XM2(2)) DDFILS=DDFILS+FZERO*0.5D0*REDMM*GSLS*(FCLS2*AMSC2+2*FOLS1)/ . (XM1(3)*XM2(3)) DDFIDR=DDFIDR+FZERO*0.5D0*REDMM*GSDR*(FCSS2*AMSC2+2*FOSS1)/ . (XM1(2)*XM2(2)) ENDIF ENDIF C-------------------------------------------------------------------- C C AUGUST 1998 ADDITIONS: C BEGIN RETARDATION IF(IRET.EQ.1) THEN CALL FFUN(3,XA,AMSC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3) VCLL = VCLL - GSLL*WKIN1*VARFI0 VCSS = VCSS - GSSS*WKIN2*VARFI0 VCLS = VCLS - GSLS*WKIN3*VARFI0 VCDR = VCDR - GSDR*WKIN2*VARFI0 C FILL = FILL + 0.5D0*GSLL*VARFI0 FISS = FISS + 0.5D0*GSSS*VARFI0 FILS = FILS + 0.5D0*GSLS*VARFI0 FIDR = FIDR + 0.5D0*GSDR*VARFI0 C DFILL = DFILL + 0.5D0*GSLL*VARFI1*PIM DFISS = DFISS + 0.5D0*GSSS*VARFI1*PIM DFILS = DFILS + 0.5D0*GSLS*VARFI1*PIM DFIDR = DFIDR + 0.5D0*GSDR*VARFI1*PIM ENDIF C END RETARDATION 104 CONTINUE C 1040 CONTINUE C RETURN END C********************************************************************** C c* SUBROUTINE SCALARH(LC,NMAX,NLOC,ICSB) SUBROUTINE SCALAR2(XA,ICSB,NLOC,LC) C C********************************************************************** C C VERSION AUGUST 2000: SECOND SU3-NONET, ASSIGNMENTS CHOOSEN: C DEL2=A0(1450), EPS2=F0(1370), S*2=f0(1580), KAPPA2=K*(1430) C********************************************************************** C updated december 2000, from YNRMP2k2.f , introducing mass C differences in meson propagators in the OBE-potentials, C according to Macke-Klein C---------------------------------------------------------------------- C C SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION GSA(11),AMSC(4),FSC(4),XM1(3),XM2(3) COMMON/ALLSC2/XALLSC2(5), .GSA1,GSA2,GSA3,GSA4,GSA5,GSA6,GSA7,GSA8,GSA9,GSA10,GSA11, .GSB1,GSB2,GSB3,GSB4,GSB5,GSB6,GSB7,GSB8,GSB9,GSB10,GSB11, .IOPTSC EQUIVALENCE (GSA1,GSA(1)) DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/ DATA AMDEL2/1450.D0/,AMEPS2/1370.D0/,AMST2/1580.D0/, . AMSCK2/1430.D0/ DATA AMCRS/750.D0/,DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/ C C NOTE : DELTA2(IN=1),EPS2(IN=2),SSTAR2(IN=3),KAPPA2(IN=4) C EPS(1300)(IN=6) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C------------------------------------------------------------------- C NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS ! C : INDEX 2,4 -> HYPERONS ! C------------------------------------------------------------------- C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) C C IF(LC.EQ.1) SIGN= 1.D0 IF(LC.NE.1) SIGN=-1.D0 IF(IRET.EQ.1) THEN WKIN1 = PIM**2*AKS(1)/(2*REDM(1)) WKIN2 = PIM**2*AKS(3)/(2*REDM(3)) WKIN3 = 0.5D0*(WKIN1+WKIN2) ENDIF DO 1040 IN=1,4 IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) ENDIF GOTO(1051,1052,1053,1054),IN 1051 GSLL = 0.D0 GSSS= -2*GSA1*GSA2 GSLS= -SR3*GSA1*GSA3 GSDR= GSA1*GSA2 FSC(1)=1.D0 AMSC(1)=AMDEL2 GOTO 1055 1052 GSLL= GSA6*GSA7 GSSS= GSA6*GSA8 GSLS= 0.D0 GSDR= GSA6*GSA8 FSC(2)=1.D0 AMSC(2)=AMEPS2 GOTO 1055 1053 GSLL= GSA9*GSA10 GSSS= GSA9*GSA11 GSLS= 0.D0 GSDR= GSA9*GSA11 FSC(3)=1.D0 AMSC(3)=AMST2 GOTO 1055 1054 GSLL= GSA4*GSA4*P GSSS= -GSA5*GSA5*P GSLS= -SR3*GSA4*GSA5*P GSDR= 2*GSA5*GSA5*P XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMSN XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMSN FSC(4)=1.D0 AMSC(4)=AMSCK2 C 1055 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMS8 IF(IN.EQ.2.OR.IN.EQ.3) ALAM=ALMS1 IF(IN.EQ.5) ALAM=ALMKP IF(IN.EQ.6) ALAM=ALMS1 ENDIF ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMSC(IN)/ALM1 RATM2=AMSC(IN)/ALM2 RATM3=AMSC(IN)/ALM3 AMSC3=AMSC(IN)**3 AMSC5=AMSC(IN)**5 FAC1=AMSC(IN)*AMSC(IN)/(XM1(1)*XM2(1)) FAC2=AMSC(IN)*AMSC(IN)/(XM1(2)*XM2(2)) FAC3=AMSC(IN)*AMSC(IN)/(XM1(3)*XM2(3)) FFAC1 = (1.D0/XM1(1)**2-1.D0/XM2(1)**2) FFAC2 = (1.D0/XM1(2)**2-1.D0/XM2(2)**2) FFAC3 = (1.D0/XM1(3)**2-1.D0/XM2(3)**2) C c DO 104 I=2,NMAX c X = XA(I) X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMSC(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMSC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMSC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOLL = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC3 FSO2LL = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOSS = FSC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC3 FSO2SS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN) FSOLS = FSC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC3 FSO2LS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC5/ / (X*X) C FCLL1 = FCLL0 - FSC(IN)*VKULL*AMSC(IN) FCSS1 = FCSS0 - FSC(IN)*VKUSS*AMSC(IN) FCLS1 = FCLS0 - FSC(IN)*VKULS*AMSC(IN) C VCLL = VCLL - GSLL*(FCLL0-0.25D0*FAC1*FCLL1) VCSS = VCSS - GSSS*(FCSS0-0.25D0*FAC2*FCSS1) VCLS = VCLS - GSLS*(FCLS0-0.25D0*FAC3*FCLS1) VCDR = VCDR - GSDR*(FCSS0-0.25D0*FAC2*FCSS1) C VSOLL = VSOLL - 0.5D0*GSLL*FSOLL/(XM1(1)*XM2(1)) VSOSS = VSOSS - 0.5D0*GSSS*FSOSS/(XM1(2)*XM2(2)) VSOLS = VSOLS - 0.5D0*GSLS*FSOLS/(XM1(3)*XM2(3)) VSODR = VSODR - 0.5D0*GSDR*FSOSS/(XM1(2)*XM2(2)) C VASOLL = VASOLL - GSLL*FSOLL*FFAC1/4.D0 VASOSS = VASOSS - GSSS*FSOSS*FFAC2/4.D0 VASOLS = VASOLS - GSLS*FSOLS*FFAC3/4.D0 VASODR = VASODR - GSDR*FSOSS*FFAC2/4.D0 C VSO2LL= VSO2LL - GSLL*FSO2LL/(4*XM1(1)*XM2(1))**2 VSO2SS= VSO2SS - GSSS*FSO2SS/(4*XM1(2)*XM2(2))**2 VSO2LS= VSO2LS - GSLS*FSO2LS/(4*XM1(3)*XM2(3))**2 VSO2DR= VSO2DR - GSDR*FSO2SS/(4*XM1(2)*XM2(2))**2 C C------------------------------------------------------------ C THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS: IF(IN.NE.5) THEN CALL YMKFUN(XA,AMSC(IN),ALAM,SIGN,IDAM*DAMSL, .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1) FXSO2 = 3*FXTEN/(X*X) C------------------------------------------------------------ IF(LC.EQ.1) THEN FCSS0 = FSC(IN)*AMSC(IN)*FXC0 FCSS1 = FSC(IN)*AMSC(IN)*FXC1 FSOSS = FSC(IN)*AMSC3*FXSO FSO2SS= FSC(IN)*AMSC5*FXSO2 ENDIF IF(LC.NE.1) THEN FCLL0 = FSC(IN)*AMSC(IN)*FXC0 FCLL1 = FSC(IN)*AMSC(IN)*FXC1 FSOLL = FSC(IN)*AMSC3*FXSO FSO2LL= FSC(IN)*AMSC5*FXSO2 ENDIF FCLS0 = 0.5D0*(FCLS0 + FSC(IN)*AMSC(IN)*FXC0 ) FCLS1 = 0.5D0*(FCLS1 + FSC(IN)*AMSC(IN)*FXC1 ) FSOLS = 0.5D0*(FSOLS + FSC(IN)*AMSC3*FXSO ) FSO2LS = 0.5D0*(FSO2LS + FSC(IN)*AMSC5*FXSO2) ENDIF C------------------------------------------------------------ C IF(NLOC.NE.0) THEN FILL = FILL + 0.5D0*REDMM*GSLL*FCLL0/(XM1(1)*XM2(1)) FISS = FISS + 0.5D0*REDMM*GSSS*FCSS0/(XM1(2)*XM2(2)) FILS = FILS + 0.5D0*REDMM*GSLS*FCLS0/(XM1(3)*XM2(3)) FIDR = FIDR + 0.5D0*REDMM*GSDR*FCSS0/(XM1(2)*XM2(2)) C DFILL=DFILL-0.5*REDMM*GSLL*FSOLL*X/(AMSC(IN)*XM1(1)*XM2(1)) DFISS=DFISS-0.5*REDMM*GSSS*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2)) DFILS=DFILS-0.5*REDMM*GSLS*FSOLS*X/(AMSC(IN)*XM1(3)*XM2(3)) DFIDR=DFIDR-0.5*REDMM*GSDR*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2)) ENDIF C-------------------------------------------------------------------- C ZERO IN FORM FACTOR: IF(IZSC.NE.0) THEN c* IF(IABS(IZSC).EQ.2) THEN FZERO = (AMSC(IN)/AMCRS)**2 FC2 = FCLL1 + FSC(IN)*(1.5D0-XLAM1*XLAM1) . * VKULL*AMSC(IN)/RATM1/RATM1 FO1 = FSOLL - FSC(IN)*(VKULL/(2*RATM1*RATM1)) . *AMSC3 FO21 = FSO2LL- FSC(IN)*VKULL/(4*RATM1**4)*AMSC5 VCLL = VCLL - FZERO*GSLL*(FCLL1-0.25D0*FAC1*FC2) VCSS = VCSS - FZERO*GSSS*(FCSS1-0.25D0*FAC2*FC2) VCLS = VCLS - FZERO*GSLS*(FCLS1-0.25D0*FAC3*FC2) VCDR = VCDR - FZERO*GSDR*(FCSS1-0.25D0*FAC2*FC2) c VSOLL = VSOLL - FZERO*0.5D0*GSLL*FO1 c VSOSS = VSOSS - FZERO*0.5D0*GSSS*FO1 c VSOLS = VSOLS - FZERO*0.5D0*GSLS*FO1 c VSODR = VSODR - FZERO*0.5D0*GSDR*FO1 VSOLL = VSOLL - FZERO*0.5D0*GSLL*FO1/(XM1(1)*XM2(1)) VSOSS = VSOSS - FZERO*0.5D0*GSSS*FO1/(XM1(2)*XM2(2)) VSOLS = VSOLS - FZERO*0.5D0*GSLS*FO1/(XM1(3)*XM2(3)) VSODR = VSODR - FZERO*0.5D0*GSDR*FO1/(XM1(2)*XM2(2)) C VASOLL= VASOLL - FZERO*GSLL*FO1*FFAC1/4.D0 VASOSS= VASOSS - FZERO*GSSS*FO1*FFAC2/4.D0 VASOLS= VASOLS - FZERO*GSLS*FO1*FFAC3/4.D0 VASODR= VASODR - FZERO*GSDR*FO1*FFAC2/4.D0 c VSO2LL= VSO2LL - FZERO*GSLL*FO21/16.D0 c VSO2SS= VSO2SS - FZERO*GSSS*FO21/16.D0 c VSO2LS= VSO2LS - FZERO*GSLS*FO21/16.D0 c VSO2DR= VSO2DR - FZERO*GSDR*FO21/16.D0 VSO2LL= VSO2LL - FZERO*GSLL*FO21/(4*XM1(1)*XM2(1))**2 VSO2SS= VSO2SS - FZERO*GSSS*FO21/(4*XM1(2)*XM2(2))**2 VSO2LS= VSO2LS - FZERO*GSLS*FO21/(4*XM1(3)*XM2(3))**2 VSO2DR= VSO2DR - FZERO*GSDR*FO21/(4*XM1(2)*XM2(2))**2 c* IF(NLOC.NE.0.AND.IZSC.EQ.-2) THEN IF(NLOC.NE.0.AND.IZSC.EQ.2) THEN FILL = FILL + FZERO*0.5D0*REDMM*GSLL*FCLL1/(XM1(1)*XM2(1)) FISS = FISS + FZERO*0.5D0*REDMM*GSSS*FCSS1/(XM1(2)*XM2(2)) FILS = FILS + FZERO*0.5D0*REDMM*GSLS*FCLS1/(XM1(3)*XM2(3)) FIDR = FIDR + FZERO*0.5D0*REDMM*GSDR*FCSS1/(XM1(2)*XM2(2)) DFILL=DFILL - FZERO*0.5*REDMM*GSLL*FO1*X/ . (AMSC(IN)*XM1(1)*XM2(1)) DFISS=DFISS - FZERO*0.5*REDMM*GSSS*FO1*X/ . (AMSC(IN)*XM1(2)*XM2(2)) DFILS=DFILS - FZERO*0.5*REDMM*GSLS*FO1*X/ . (AMSC(IN)*XM1(3)*XM2(3)) DFIDR=DFIDR - FZERO*0.5*REDMM*GSDR*FO1*X/ . (AMSC(IN)*XM1(2)*XM2(2)) ENDIF ENDIF C-------------------------------------------------------------------- C C AUGUST 1998 ADDITIONS: C BEGIN RETARDATION IF(IRET.EQ.1) THEN CALL FFUN(3,XA,AMSC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3) VCLL = VCLL - GSLL*WKIN1*VARFI0 VCSS = VCSS - GSSS*WKIN2*VARFI0 VCLS = VCLS - GSLS*WKIN3*VARFI0 VCDR = VCDR - GSDR*WKIN2*VARFI0 FILL = FILL + 0.5D0*GSLL*VARFI0 FISS = FISS + 0.5D0*GSSS*VARFI0 FILS = FILS + 0.5D0*GSLS*VARFI0 FIDR = FIDR + 0.5D0*GSDR*VARFI0 C DFILL = DFILL + 0.5D0*GSLL*VARFI1*PIM DFISS = DFISS + 0.5D0*GSSS*VARFI1*PIM DFILS = DFILS + 0.5D0*GSLS*VARFI1*PIM DFIDR = DFIDR + 0.5D0*GSDR*VARFI1*PIM ENDIF C END RETARDATION 104 CONTINUE C 1040 CONTINUE C RETURN END C********************************************************************** C SUBROUTINE DIFRAC(XA,ICSB,NLOC,LC,I51) C C********************************************************************** C VERSION AUGUST 2009: REFINED TREATMENT QUARK-CORE EFFECTS C VERSION OCTOBER 2004: SU3-SINGLET POMERON + SU3-NONET (A2, F2, FP2, K2) C********************************************************************** C C "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL*8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c COMMON/AMAT/XA(300),A(9,6,300) COMMON/PRMTRS/PAR(20,8) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX c* DIMENSION GD(11),AMDF(5),FDC(5),XM1(3),XM2(3) c* EQUIVALENCE (GD1,GD(1)) DIMENSION AMDF(6),FDC(6),XM1(3),XM2(3) DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/ . AMPRO/938.2796D0/,ICALL/0/,NATSCAL/0/ C C NOTE : POM(IN=1),A2(IN=2),F2(IN=3),POMP(IN=4),K**(IN=5) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C------------------------------------------------------------------- C NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS ! C : INDEX 2,4 -> HYPERONS ! C------------------------------------------------------------------- C IF(IRET.EQ.1) THEN WKIN1 = PIM**2*AKS(1)/(2*REDM(1)) WKIN2 = PIM**2*AKS(3)/(2*REDM(3)) WKIN3 = 0.5D0*(WKIN1+WKIN2) ENDIF C------------------------------------------------------------------------- C OLD: C QUARK-CLUSTER PAULI-REPULSION: c FLL51 = 1.D0+1D0/8D0*PAR(19,5) ! NEW TREATMENT FI51 MARIUS c IF(I51.EQ.1) THEN c FSS51 = 1.D0+9D0/8D0*PAR(19,5) ! NEW TREATMENT FI51 MARIUS c FDR51= 1D0 c ENDIF c IF(I51.EQ.0) THEN c FDR51 = 1.D0+PAR(19,5) c FSS51 = 1.D0+1D0/8D0*PAR(19,5) ! NEW TREATMENT FI51 MARIUS c ENDIF C------------------------------------------------------------------------- C QUARK-CLUSTER PAULI-REPULSION: C-----BBPROGS.AUG12.CSB/LPPROGS.02/YNRMP10.F------------------------------- FI51 = PAR(19,5) AMFI51= PAR(17,5) IF(AMFI51.EQ.0D0) AMFI51=AMPOM C FLL51 = (1.D0+1D0/8D0)*FI51 ! NEW TREATMENT FI51 MARIUS IF(I51.EQ.1) THEN FSS51 = (1.D0+9D0/8D0)*FI51 ! NEW TREATMENT FI51 MARIUS FDR51= 1.D0*FI51 ENDIF IF(I51.EQ.0) THEN FDR51 = 2.D0*FI51 FSS51 = (1.D0+1D0/8D0)*FI51 ! NEW TREATMENT FI51 MARIUS ENDIF c if(icall.eq.0) write(*,*) 'difrac:: I51=',I51,' FDR51=',FDR51, c .' P=',P C------------------------------------------------------------------------- DO 1040 IN=1,6 IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) ENDIF GOTO(1050,1051,1052,1053,1054,1055),IN 1050 GDLL = GD9*GD10 GDSS= GD9*GD11 GDLS= 0D0 GDDR= GD9*GD11 FDC(IN)=1.D0 AMDF(IN)=AMFI51 C QUARK-CLUSTER-MODEL PAULI-REPULSION: GDLL= FLL51*GDLL ! NEW TREATMENT FI51 MARIUS GDSS= FSS51*GDSS GDDR= FDR51*GDDR GOTO 1056 1051 GDLL = GD9*GD10*(1D0-FI51) GDSS= GD9*GD11*(1D0-FI51) GDLS= 0D0 GDDR= GD9*GD11*(1D0-FI51) FDC(IN)=1.D0 AMDF(IN)=AMPOM GOTO 1056 1052 GDLL = -0.0271D0*ICSB*GDA(1)*GDA(3) GDSS= -2.*GDA(1)*GDA(2) GDLS= -SR3*GDA(1)*GDA(3) GDDR= GDA(1)*GDA(2) FDC(IN)=1.D0 AMDF(IN)=AMA2 GOTO 1056 1053 GDLL= GDA(6)*GDA(7) GDSS= GDA(6)*GDA(8) GDLS= 0.D0 GDDR= GDA(6)*GDA(8) FDC(IN)=1.D0 AMDF(IN)=AMPOM GOTO 1056 1054 GDLL= GDA(9)*GDA(10) GDSS= GDA(9)*GDA(11) GDLS= 0.D0 GDDR= GDA(9)*GDA(11) FDC(IN)=1.D0 AMDF(IN)=AMF2 GOTO 1056 1055 GDLL= GDA(4)*GDA(4)*P GDSS= -GDA(5)*GDA(5)*P GDLS= -SR3*GDA(4)*GDA(5)*P GDDR= 2*GDA(5)*GDA(5)*P XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMSN XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMSN FDC(IN)=1.D0 AMDF(IN)=AMKSS C 1056 AMDF2=AMDF(IN)*AMDF(IN) FAC1=AMDF2/(XM1(1)*XM2(1)) FAC2=AMDF2/(XM1(2)*XM2(2)) FAC3=AMDF2/(XM1(3)*XM2(3)) FFAC1 = AMDF2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2) FFAC2 = AMDF2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2) FFAC3 = AMDF2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2) FAC12=FAC1*FAC1 FAC22=FAC2*FAC2 FAC32=FAC3*FAC3 c universal scaling: IF(NATSCAL.EQ.0) THEN c if(icall.eq.0) write(*,*) 'obe.oct08, difrac: universal scaling' FLLDF=4*GDLL*AMDF2/(SRPI*AMPRO**2) FSSDF=4*GDSS*AMDF2/(SRPI*AMPRO**2) FLSDF=4*GDLS*AMDF2/(SRPI*AMPRO**2) FDRDF=4*GDDR*AMDF2/(SRPI*AMPRO**2) ENDIF c natural scaling: IF(NATSCAL.EQ.1) THEN c if(icall.eq.0) write(*,*) 'obe.oct08, difrac: natural scaling' FLLDF=4*GDLL*AMDF2/(SRPI*XM1(1)*XM2(1)) FSSDF=4*GDSS*AMDF2/(SRPI*XM1(2)*XM2(2)) FLSDF=4*GDLS*AMDF2/(SRPI*XM1(3)*XM2(3)) FDRDF=4*GDDR*AMDF2/(SRPI*XM1(2)*XM2(2)) ENDIF c if(icall.eq.0.and.in.le.2) then c write(*,*) ' DIFRAC : IN=',in,' I51=',i51,' FI51',fi51, c .' gddr=',gddr c endif C c DO 104 I=2,NMAX c X =(AMDF(IN)/PIM)*XA(I) X =(AMDF(IN)/PIM)*XA X2=X*X VGSSX=AMDF(IN)*FDEXP(-X2) FCLL=1.D0+0.5D0*FAC1*(3.D0-2*X2) FCSS=1.D0+0.5D0*FAC2*(3.D0-2*X2) FCLS=1.D0+0.5D0*FAC3*(3.D0-2*X2) FCDR=1.D0+0.5D0*FAC2*(3.D0-2*X2) C VCLL = VCLL + FLLDF*FCLL*VGSSX VCSS = VCSS + FSSDF*FCSS*VGSSX VCLS = VCLS + FLSDF*FCLS*VGSSX VCDR = VCDR + FDRDF*FCDR*VGSSX C VSOLL = VSOLL + FAC1*FLLDF*VGSSX VSOSS = VSOSS + FAC2*FSSDF*VGSSX VSOLS = VSOLS + FAC3*FLSDF*VGSSX VSODR = VSODR + FAC2*FDRDF*VGSSX C VASOLL = VASOLL + FFAC1*FLLDF*VGSSX/4.D0 VASOSS = VASOSS + FFAC2*FSSDF*VGSSX/4.D0 VASOLS = VASOLS + FFAC3*FLSDF*VGSSX/4.D0 VASODR = VASODR + FFAC2*FDRDF*VGSSX/4.D0 C VSO2LL= VSO2LL + FAC12*FLLDF*VGSSX/4 VSO2SS= VSO2SS + FAC22*FSSDF*VGSSX/4 VSO2LS= VSO2LS + FAC32*FLSDF*VGSSX/4 VSO2DR= VSO2DR + FAC22*FDRDF*VGSSX/4 C IF(NLOC.EQ.0) GOTO 104 FILL = FILL - 0.5D0*REDMM*FLLDF*VGSSX/(XM1(1)*XM2(1)) FISS = FISS - 0.5D0*REDMM*FSSDF*VGSSX/(XM1(2)*XM2(2)) FILS = FILS - 0.5D0*REDMM*FLSDF*VGSSX/(XM1(3)*XM2(3)) FIDR = FIDR - 0.5D0*REDMM*FDRDF*VGSSX/(XM1(2)*XM2(2)) C DFILL = DFILL+ 2*0.5D0*REDMM*FLLDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMY(1)) DFISS = DFISS+ 2*0.5D0*REDMM*FSSDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMSS) DFILS = DFILS+ 2*0.5D0*REDMM*FLSDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMH) DFIDR = DFIDR+ 2*0.5D0*REDMM*FDRDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMSS) C DDFILL = DDFILL+ 2*0.5D0*REDMM*FLLDF*(1D0-2*X*X)*VGSSX*FAC1 ! NOVEMBER 2010 DDFISS = DDFISS+ 2*0.5D0*REDMM*FSSDF*(1D0-2*X*X)*VGSSX*FAC2 DDFILS = DDFILS+ 2*0.5D0*REDMM*FLSDF*(1D0-2*X*X)*VGSSX*FAC3 DDFIDR = DDFIDR+ 2*0.5D0*REDMM*FDRDF*(1D0-2*X*X)*VGSSX*FAC2 C C AUGUST 1998 ADDITIONS: C BEGIN RETARDATION IF(IRET.EQ.1) THEN VARFI0 = FDEXP(-X2) VARFI1 = -2*X*VARFI0 VCLL = VCLL + FLLDF*WKIN1*VARFI0 VCSS = VCSS + FSSDF*WKIN2*VARFI0 VCLS = VCLS + FLSDF*WKIN3*VARFI0 VCDR = VCDR + FDRDF*WKIN2*VARFI0 C FILL = FILL - 0.5D0*FLLDF*VARFI0 FISS = FISS - 0.5D0*FSSDF*VARFI0 FILS = FILS - 0.5D0*FLSDF*VARFI0 FIDR = FIDR - 0.5D0*FDRDF*VARFI0 C DFILL = DFILL - 2*0.5D0*FLLDF*VARFI1*PIM DFISS = DFISS - 2*0.5D0*FSSDF*VARFI1*PIM DFILS = DFILS - 2*0.5D0*FLSDF*VARFI1*PIM DFIDR = DFIDR - 2*0.5D0*FDRDF*VARFI1*PIM ENDIF C END RETARDATION C 104 CONTINUE c c print spin-orbit potentials LL: c write(*,*) ' DIFRAC : x=',xa,' IN=',in,' vsoll=',vsoll, c .' vasoll=',vasoll c if(icall.eq.0) then c write(*,*) ' DIFRAC : x=',xa,' IN=',in,' vcll',vcll, c .' vcss=',vcss,' vcls=',vcls c write(*,*) ' DIFRAC : gdll=',gdll c endif 1040 CONTINUE C C JULY 2007: HEAVY (HARD) POMERON: CALL HDIFRAC(XA,NLOC,NATSCAL,ICSB,I51,PX) C RETURN END ************************************************************************ C SUBROUTINE HDIFRAC(XA,NLOC,NATSCAL,ICSB,I51,PX) C C********************************************************************** C VERSION MAY 2007: HEAVY(HARD) POMERON = SU3-SINGLET C********************************************************************** C C "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL*8(A-H,O-Z) COMMON/PRMTRS/PAR(20,8) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2 c* COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c* COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR DIMENSION AMDF(5),FDC(5),XM1(3),XM2(3) DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/ . AMPRO/938.2796D0/,AMPOMH/600D0/,ICALL/0/,NS/0/ DATA AKAP1/0D0/,AKAP2/0D0/ C------------------------------------------------------------------- C C NOTE : IDIF =1 -> NORMAL (HEAVY) POMERON C IDIF =2 -> VOLUME INT=0 (HEAVY) POMERON C IDIF =3 -> COMPLETE ODDERON: P=C=-1 C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C NOTE : FOR SIGMA-NUCLEON INTERACTION: C I=1/2,1S0: I51 = 1 -> QCM PREDICTS STRONG PAULI REPULSION C I=1/2,3S1: I51 = 0 -> QCM REPULSION APPROX. A LA POMERON ETC. C------------------------------------------------------------------- C NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS ! C : INDEX 2,4 -> HYPERONS ! C------------------------------------------------------------------- C C IF(IDIF.EQ.1) RETURN ! MARCH 2009 c* RSCAL = DSQRT(PAR(15,1)) RSCAL = 1D0 ! APRIL 2009 AMPOMH= PAR(14,6) GHPOM = PAR(13,6)*RSCAL FHPOM = PAR(12,6)*RSCAL IF(FHPOM.EQ.0D0) FHPOM = -GHPOM GHPOM2= GHPOM*GHPOM FHPOM2= FHPOM*FHPOM IF(PAR(13,6).LT.0D0) GHPOM2=-GHPOM2 DO 1040 IN=1,1 IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) ENDIF 1051 GDLL= GHPOM2 GDSS= GHPOM2 GDLS= 0.D0 GDDR= GHPOM2 FDLL= 0.D0 FDSS= 0.D0 FDLS= 0.D0 FDDR= 0.D0 IF(IDIF.EQ.3) THEN FDLL= FHPOM2 FDSS= FHPOM2 FDLS= 0D0 FDDR= FHPOM2 ENDIF IF(GHPOM.NE.0D0) THEN AKAP1= FHPOM/GHPOM AKAP2= FHPOM/GHPOM ENDIF C moved to DIFRAC: C QUARK-CLUSTER-MODEL (QCM): c GDSS= FSS51*GDSS c FDSS= FSS51*FDSS c GDDR= FDR51*GDDR c FDDR= FDR51*FDDR FDC(1)=1.D0 AMDF(1)=AMPOMH GOTO 1056 C 1056 AMDF2=AMDF(IN)*AMDF(IN) FAC1=AMDF2/(XM1(1)*XM2(1)) FAC2=AMDF2/(XM1(2)*XM2(2)) FAC3=AMDF2/(XM1(3)*XM2(3)) FAC0=AMDF2/AMPRO/AMPRO FFAC1 = AMDF2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2) FFAC2 = AMDF2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2) FFAC3 = AMDF2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2) FAC12=FAC1*FAC1 FAC22=FAC2*FAC2 FAC32=FAC3*FAC3 c universal scaling: IF(NATSCAL.EQ.0) THEN if(icall.eq.0.and.ns.ne.0) write(*,*) .'obe.oct08, difrac: universal scaling' FLLDF=4*GDLL*AMDF2/(SRPI*AMPRO**2) FSSDF=4*GDSS*AMDF2/(SRPI*AMPRO**2) FLSDF=4*GDLS*AMDF2/(SRPI*AMPRO**2) FDRDF=4*GDDR*AMDF2/(SRPI*AMPRO**2) ENDIF c natural scaling: IF(NATSCAL.EQ.1) THEN if(icall.eq.0.and.ns.ne.0) write(*,*) .'obe.oct08, difrac: natural scaling' FLLDF=4*GDLL*AMDF2/(SRPI*XM1(1)*XM2(1)) FSSDF=4*GDSS*AMDF2/(SRPI*XM1(2)*XM2(2)) FLSDF=4*GDLS*AMDF2/(SRPI*XM1(3)*XM2(3)) FDRDF=4*GDDR*AMDF2/(SRPI*XM1(2)*XM2(2)) ENDIF ICALL=1 C FOR IDIF=3: RATXM1 = DSQRT(XM1(1)*XM2(1))/AMPRO CLLC= 1D0 CLLS= (1D0+AKAP1*RATXM1)*(1D0+AKAP2*RATXM1) CLLT= CLLS CLLO= (3D0+(AKAP1+AKAP2)*RATXM1) CLLQ= (1D0+4*(AKAP1+AKAP2)*RATXM1+8*AKAP1*AKAP2*RATXM1**2) C c* DO 104 I=2,NMAX X =(AMDF(IN)/PIM)*XA X2=X*X VGSSX=AMDF(IN)*FDEXP(-X2) IF(IDIF.EQ.1) THEN FCLL=1.D0+0.5D0*FAC1*(3.D0-2*X2) FCSS=1.D0+0.5D0*FAC2*(3.D0-2*X2) FCLS=1.D0+0.5D0*FAC3*(3.D0-2*X2) FCDR=1.D0+0.5D0*FAC2*(3.D0-2*X2) C VCLL = VCLL + FLLDF*FCLL*VGSSX VCSS = VCSS + FSSDF*FCSS*VGSSX VCLS = VCLS + FLSDF*FCLS*VGSSX VCDR = VCDR + FDRDF*FCDR*VGSSX C VSOLL = VSOLL + FAC1*FLLDF*VGSSX VSOSS = VSOSS + FAC2*FSSDF*VGSSX VSOLS = VSOLS + FAC3*FLSDF*VGSSX VSODR = VSODR + FAC2*FDRDF*VGSSX C VASOLL = VASOLL + FFAC1*FLLDF*VGSSX/4.D0 VASOSS = VASOSS + FFAC2*FSSDF*VGSSX/4.D0 VASOLS = VASOLS + FFAC3*FLSDF*VGSSX/4.D0 VASODR = VASODR + FFAC2*FDRDF*VGSSX/4.D0 C VSO2LL= VSO2LL + FAC12*FLLDF*VGSSX/4 VSO2SS= VSO2SS + FAC22*FSSDF*VGSSX/4 VSO2LS= VSO2LS + FAC32*FLSDF*VGSSX/4 VSO2DR= VSO2DR + FAC22*FDRDF*VGSSX/4 C IF(NLOC.EQ.0) GOTO 104 FILL = FILL - 0.5D0*REDMM*FLLDF*VGSSX/(XM1(1)*XM2(1)) FISS = FISS - 0.5D0*REDMM*FSSDF*VGSSX/(XM1(2)*XM2(2)) FILS = FILS - 0.5D0*REDMM*FLSDF*VGSSX/(XM1(3)*XM2(3)) FIDR = FIDR - 0.5D0*REDMM*FDRDF*VGSSX/(XM1(2)*XM2(2)) C DFILL = DFILL + REDMM*FLLDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMY(1)) DFISS = DFISS + REDMM*FSSDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMSS) DFILS = DFILS + REDMM*FLSDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMH) DFIDR = DFIDR + REDMM*FDRDF*AMDF(IN)*X*VGSSX . /(AM(1)*AMSS) DDFILL = DDFILL + REDMM*FLLDF*(1D0-2*X*X)*VGSSX*FAC1 DDFISS = DDFISS + REDMM*FSSDF*(1D0-2*X*X)*VGSSX*FAC2 DDFILS = DDFILS + REDMM*FLSDF*(1D0-2*X*X)*VGSSX*FAC3 DDFIDR = DDFIDR + REDMM*FDRDF*(1D0-2*X*X)*VGSSX*FAC2 ENDIF C C------------------------------------------------------------------ C ODDERON: P=C=-1 C------------------------------------------------------------------ IF(IDIF.EQ.2) THEN FCLL1=FAC1*(3.D0-2*X2) FCSS1=FAC2*(3.D0-2*X2) FCLS1=FAC3*(3.D0-2*X2) FCDR1=FAC2*(3.D0-2*X2) C VCLL = VCLL + FLLDF*FCLL1*VGSSX VCSS = VCSS + FSSDF*FCSS1*VGSSX VCLS = VCLS + FLSDF*FCLS1*VGSSX VCDR = VCDR + FDRDF*FCDR1*VGSSX ENDIF C------------------------------------------------------------------ C ADDITIONS AUGUST 29, 2007/AMENDED IN MARCH 2009: C------------------------------------------------------------------ IF(IDIF.EQ.3) THEN FCLL1=FAC0*(3.D0-2*X2) FCSS1=FAC0*(3.D0-2*X2) FCLS1=FAC0*(3.D0-2*X2) FCDR1=FAC0*(3.D0-2*X2) FCLL2=FAC0*(15D0-20*X2+4*X2*X2) FCSS2=FAC0*(15D0-20*X2+4*X2*X2) FCLS2=FAC0*(15D0-20*X2+4*X2*X2) FCDR2=FAC0*(15D0-20*X2+4*X2*X2) FCLL2= 0.D0 ! NO K^4-TERMS, APRIL 2209 FCSS2= 0.D0 ! NO K^4-TERMS, APRIL 2209 FCLS2= 0.D0 ! NO K^4-TERMS, APRIL 2209 FCDR2= 0.D0 ! NO K^4-TERMS, APRIL 2209 FTLL1=FAC0*X2*(7D0-2*X2) FTSS1=FAC0*X2*(7D0-2*X2) FTLS1=FAC0*X2*(7D0-2*X2) FTDR1=FAC0*X2*(7D0-2*X2) FOLL1=FAC0*(5D0-2*X2) FOSS1=FAC0*(5D0-2*X2) FOLS1=FAC0*(5D0-2*X2) FODR1=FAC0*(5D0-2*X2) FO2LL1=FAC0*(7D0-2*X2) FO2SS1=FAC0*(7D0-2*X2) FO2LS1=FAC0*(7D0-2*X2) FO2DR1=FAC0*(7D0-2*X2) DFCLL1 = -2*AMDF(IN)*X*FOLL1 ! FEB2009 DFCSS1 = -2*AMDF(IN)*X*FOSS1 ! FEB2009 DFCLS1 = -2*AMDF(IN)*X*FOLS1 ! FEB2009 DFCDR1 = -2*AMDF(IN)*X*FODR1 ! FEB2009 C VCLL = VCLL + FLLDF*CLLC*FCLL1*VGSSX*2D0 . - FLLDF*CLLC*FCLL2*VGSSX*FAC1*2D0 ! FEB2009 VCSS = VCSS + FSSDF*CLLC*FCSS1*VGSSX*2D0 . - FSSDF*CLLC*FCSS2*VGSSX*FAC2*2D0 ! FEB2009 VCLS = VCLS + FLSDF*CLLC*FCLS1*VGSSX*2D0 . - FLSDF*CLLC*FCLS2*VGSSX*FAC3*2D0 ! FEB2009 VCDR = VCDR + FDRDF*CLLC*FCDR1*VGSSX*2D0 . - FDRDF*CLLC*FCDR2*VGSSX*FAC2*2D0 ! FEB2009 C VSIGLL = VSIGLL - FLLDF*CLLS*FCLL2*VGSSX*FAC1*2/3D0 VSIGSS = VSIGSS - FSSDF*CLLS*FCSS2*VGSSX*FAC2*2/3D0 VSIGLS = VSIGLS - FLSDF*CLLS*FCLS2*VGSSX*FAC3*2/3D0 VSIGDR = VSIGDR - FDRDF*CLLS*FCDR2*VGSSX*FAC2*2/3D0 C VTENLL = VTENLL - FLLDF*CLLT*FTLL1*VGSSX*FAC1*2/3D0 VTENSS = VTENSS - FSSDF*CLLT*FTSS1*VGSSX*FAC2*2/3D0 VTENLS = VTENLS - FLSDF*CLLT*FTLS1*VGSSX*FAC3*2/3D0 VTENDR = VTENDR - FDRDF*CLLT*FTDR1*VGSSX*FAC2*2/3D0 C VSOLL = VSOLL - FLLDF*CLLO*FOLL1*VGSSX*FAC1*2D0 VSOSS = VSOSS - FSSDF*CLLO*FOSS1*VGSSX*FAC2*2D0 VSOLS = VSOLS - FLSDF*CLLO*FOLS1*VGSSX*FAC3*2D0 VSODR = VSODR - FDRDF*CLLO*FODR1*VGSSX*FAC2*2D0 C c* geen extra factor zoals cllo ? etc. VASOLL = VASOLL -FFAC1*FLLDF*FOLL1*VGSSX VASOSS = VASOSS -FFAC2*FSSDF*FOSS1*VGSSX VASOLS = VASOLS -FFAC3*FLSDF*FOLS1*VGSSX VASODR = VASODR -FFAC2*FDRDF*FODR1*VGSSX C VSO2LL = VSO2LL +FLLDF*CLLQ*FO2LL1*VGSSX*FAC1**2/2D0 VSO2SS = VSO2SS +FSSDF*CLLQ*FO2SS1*VGSSX*FAC2**2/2D0 VSO2LS = VSO2LS +FLSDF*CLLQ*FO2LS1*VGSSX*FAC3**2/2D0 VSO2DR = VSO2DR +FDRDF*CLLQ*FO2DR1*VGSSX*FAC2**2/2D0 C NON-LOCAL ADDITIONS FEB2009: IF(NLOC.NE.0) THEN FILL = FILL +4*0.75D0*REDMM*FCLL1*VGSSX/(XM1(1)*XM2(1)) .*FLLDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb FISS = FISS +4*0.75D0*REDMM*FCSS1*VGSSX/(XM1(2)*XM2(2)) .*FSSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb FILS = FILS +4*0.75D0*REDMM*FCLS1*VGSSX/(XM1(3)*XM2(3)) .*FLSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb FIDR = FIDR +4*0.75D0*REDMM*FCDR1*VGSSX/(XM1(2)*XM2(2)) .*FDRDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb C DFILL = DFILL +4*0.75D0*REDMM*DFCLL1*VGSSX/(XM1(1)*XM2(1)) .*FLLDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb DFISS = DFISS +4*0.75D0*REDMM*DFCSS1*VGSSX/(XM1(2)*XM2(2)) .*FSSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb DFILS = DFILS +4*0.75D0*REDMM*DFCLS1*VGSSX/(XM1(3)*XM2(3)) .*FLSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb DFIDR = DFIDR +4*0.75D0*REDMM*DFCDR1*VGSSX/(XM1(2)*XM2(2)) .*FDRDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb FCLL2 = FAC0*(5D0-16*X2+4*X2*X2) DDFILL = DDFILL -8*0.75D0*REDMM*FCLL2*VGSSX*FAC1*FLLDF ! NOVEMBER 2010 DDFISS = DDFISS -8*0.75D0*REDMM*FCLL2*VGSSX*FAC2*FSSDF ! NOVEMBER 2010 DDFILS = DDFILS -8*0.75D0*REDMM*FCLL2*VGSSX*FAC3*FLSDF ! NOVEMBER 2010 DDFIDR = DDFIDR -8*0.75D0*REDMM*FCLL2*VGSSX*FAC2*FDRDF ! NOVEMBER 2010 ENDIF ENDIF ! END IDIF.EQ.3 C 104 CONTINUE C 1040 CONTINUE C RETURN END C ************************************************************** SUBROUTINE AXIAL1(XA,NLOC,ICSB,LC,P,PX) C SUBROUTINE AXIAL1(NMAX,NLOC,ICSB,P,PX) C********************************************************************** C C AXIAL MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C C IN MOMENTUM SPACE AXIAL-EXCHANGE: C C FIRST TERM PROPAGATOR: C V_A^(1) = -GA2*[[(1+(Q2+K2/4)/(6M'M)](SIGMA1.SIGMA2)+ C +(2/M'M)[(SIGMA1.Q)(SIGMA2.Q)-Q2(SIGMA1.SIGMA2)/3] C -(1/4M'M)[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3] C +(i/4M'M)(SIGMA1+SIGMA2).QXK ]]/(K2+MA2) C C APPROXIMATION: FROM Q-TENSOR TERM: ONLY LOCAL CONTRIBUTION KEPT! C ------------------------------------------------ C C NOTE : A1(1270)(IN=1),D=F1(1285)(IN=2),E=F1(1420)(IN=3) C C ONLY PSEUDO-VECTOR COUPLING INCLUDED ! C C PROPAGATOR OPTIONS: A) PROCA,IBFLD=0, B) B-FIELD FORMALISM, IBFLD=1 C********************************************************************** C C THE POTENTIAL FUNCTIONS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR DIMENSION AMAX(4),XM1(3),XM2(3) DATA SR3/1.732051D0/,SRPI/1.772454D0/ DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1273.D0/ DATA IBFLD/0/,ICALL/0/,FZERO/0.D0/,AMCRA/750.D0/ FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C IF(ICALL.EQ.0) THEN IF(NS.NE.0) WRITE(*,*) ' AXIAL.02: IBFLD=',IBFLD ICALL=1 ENDIF C DIV1 =1.D0/(AM(1)*AMY(1)) DIV2 =1.D0/(AM(1)*AMY(2)) DIV3 =1.D0/(AM(1)*AMH ) DO 1040 IN=1,4 IF(IN.EQ.1) THEN XM1(1)=AMY(1) XM1(2)=AMSS XM1(3)=AMH XM2(1)=AM(1) XM2(2)=AMNN XM2(3)=AM(1) ENDIF GOTO(1051,1052,1053,1054),IN 1051 GALL= 0.D0 GASS= -2*FA(1)*FA(2) GALS= -SR3*FA(1)*FA(3) GADR= FA(1)*FA(2) AMAX(1)=AMA1 GOTO 1055 1052 GALL= FA(6)*FA(7) GASS= FA(6)*FA(8) GALS= 0.D0 GADR= FA(6)*FA(8) AMAX(2)=AME1 GOTO 1055 1053 GALL= FA(9)*FA(10) GASS= FA(9)*FA(11) GALS= 0.D0 GADR= FA(9)*FA(11) AMAX(3)=AMD1 GOTO 1055 1054 GALL= FA(4)*FA(4)*P GASS= -FA(5)*FA(5)*P GALS= -SR3*FA(4)*FA(5)*P GADR= 2*FA(5)*FA(5)*P AMAX(4)=AMK1 XM1(1)=AMLN XM1(2)=AMSN XM1(3)=AMSN XM2(1)=AMLN XM2(2)=AMSN XM2(3)=AMSN C 1055 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMAX IF(ALAM.EQ.0.D0) ALAM=ALMP8 IF(IN.EQ.2.AND.ALAM.EQ.0.D0) ALAM=ALMP1 IF(IN.EQ.4.AND.ALAM.EQ.0.D0) ALAM=ALMKA ENDIF ALM1=ALAM ALM2=ALAM ALM3=ALAM AMAX2=AMAX(IN)*AMAX(IN) RATM1=AMAX(IN)/ALM1 RATM2=AMAX(IN)/ALM2 RATM3=AMAX(IN)/ALM3 FAC1 =AMAX(IN)**2/(AM(1)*AMY(1)) FAC2 =AMAX(IN)**2/(AM(1)*AMY(2)) FAC3 =AMAX(IN)**2/(AM(1)*AMH ) FFAC1 = AMAX2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2) FFAC2 = AMAX2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2) FFAC3 = AMAX2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2) IF(IZAX.NE.0) FZERO = (AMAX(IN)/AMCRA)**2 C C DO 104 I=2,NMAX XLAM1=0.5D0*XA*ALM1/PIM XLAM2=0.5D0*XA*ALM2/PIM XLAM3=0.5D0*XA*ALM3/PIM X =(AMAX(IN)/PIM)*XA EX=FDEXP(X) VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLL0 = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLL1 = FCLL0 - VKULL*AMAX(IN) DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM DFCLL1 = DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN) DFTLL0 = DFCLL1/3.D0-3*FTLL0*PIM/XA C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTSS0 = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FCSS1 = FCSS0 - VKUSS*AMAX(IN) DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM DFCSS1 = DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN) DFTSS0 = DFCSS1/3.D0-3*FTSS0*PIM/XA C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLS0 = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLS1 = FCLS0 - VKULS*AMAX(IN) DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM DFCLS1 = DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN) DFTLS0 = DFCLS1/3.D0-3*FTLS0*PIM/XA IF(IZAX.NE.0) THEN FCLL2 = FCLL1 + (1.5D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/RATM1/RATM1 DFCLL2 = DFCLL1 -ALM1*XLAM1*(2.5D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/RATM1/RATM1 FTLL1 = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1) DFTLL1 = DFTLL0- ALM1*XLAM1*(1D0-XLAM1*XLAM1) . * VKULL*AMAX(IN)/(3*RATM1*RATM1) FSOLL1 = FSOLL0 - 0.5D0*(ALM1/AMAX(IN))**2*VKULL*AMAX(IN) FCSS2 = FCSS1 + (1.5D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/RATM2/RATM2 DFCSS2 = DFCSS1 -ALM2*XLAM2*(2.5D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/RATM2/RATM2 FTSS1 = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2) DFTSS1 = DFTSS0- ALM2*XLAM2*(1D0-XLAM2*XLAM2) . * VKUSS*AMAX(IN)/(3*RATM2*RATM2) FSOSS1 = FSOSS0 - 0.5D0*(ALM2/AMAX(IN))**2*VKUSS*AMAX(IN) FCLS2 = FCLS1 + (1.5D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/RATM3/RATM3 DFCLS2 = DFCLS1 -ALM3*XLAM3*(2.5D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/RATM3/RATM3 FTLS1 = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3) DFTLS1 = DFTLS0- ALM3*XLAM3*(1D0-XLAM3*XLAM3) . * VKULS*AMAX(IN)/(3*RATM3*RATM3) FSOLS1 = FSOLS0 - 0.5D0*(ALM3/AMAX(IN))**2*VKULS*AMAX(IN) C* neglecting k^4-terms: fcll2 = 0d0 fcss2 = 0d0 fcls2 = 0d0 dfcll2 = 0d0 dfcss2 = 0d0 dfcls2 = 0d0 ENDIF C--------------------------------------------------------------- C C FIRST TERM AXIAL PROPAGATOR: C C--------------------------------------------------------------- VSIGLL = VSIGLL - GALL*FCLL0 VSIGSS = VSIGSS - GASS*FCSS0 VSIGLS = VSIGLS - GALS*FCLS0 VSIGDR = VSIGDR - GADR*FCSS0 VTENLL = VTENLL - 0.75D0*GALL*FAC1 *FTLL0 VTENSS = VTENSS - 0.75D0*GASS*FAC2 *FTSS0 VTENLS = VTENLS - 0.75D0*GALS*FAC3 *FTLS0 VTENDR = VTENDR - 0.75D0*GADR*FAC2 *FTSS0 VSOLL = VSOLL - 0.5D0*GALL*FAC1 *FSOLL0 VSOSS = VSOSS - 0.5D0*GASS*FAC2 *FSOSS0 VSOLS = VSOLS - 0.5D0*GALS*FAC3 *FSOLS0 VSODR = VSODR - 0.5D0*GADR*FAC2 *FSOSS0 VASOLL = VASOLL + 0.25D0*GALL*FSOLL0*FFAC1 VASOSS = VASOSS + 0.25D0*GASS*FSOSS0*FFAC2 VASOLS = VASOLS + 0.25D0*GALS*FSOLS0*FFAC3 VASODR = VASODR + 0.25D0*GADR*FSOSS0*FFAC2 FISLL = FISLL - GALL*FCLL0*DIV1*REDM(1)/6.D0 FISSS = FISSS - GASS*FCSS0*DIV2*REDM(2)/6.D0 FISLS = FISLS - GALS*FCLS0*DIV3*REDM(3)/6.D0 FISDR = FISDR - GADR*FCSS0*DIV2*REDM(2)/6.D0 DFISLL = DFISLL - GALL*DFCLL0*DIV1*REDM(1)/6.D0 DFISSS = DFISSS - GASS*DFCSS0*DIV2*REDM(2)/6.D0 DFISLS = DFISLS - GALS*DFCLS0*DIV3*REDM(3)/6.D0 DFISDR = DFISDR - GADR*DFCSS0*DIV2*REDM(2)/6.D0 DDFSLL = DDFSLL - GALL*AMAX2*(FCLL1+2*FSOLL0)*DIV1*REDM(1)/6.D0 DDFSSS = DDFSSS - GASS*AMAX2*(FCSS1+2*FSOSS0)*DIV2*REDM(2)/6.D0 DDFSLS = DDFSLS - GALS*AMAX2*(FCLS1+2*FSOLS0)*DIV3*REDM(3)/6.D0 DDFSDR = DDFSDR - GADR*AMAX2*(FCSS1+2*FSOSS0)*DIV2*REDM(2)/6.D0 IF(IZAX.NE.0) THEN VSIGLL = VSIGLL - FZERO*GALL*(FCLL1 + 2*FAC1*FCLL2/3D0) VSIGSS = VSIGSS - FZERO*GASS*(FCSS1 + 2*FAC2*FCSS2/3D0) VSIGLS = VSIGLS - FZERO*GALS*(FCLS1 + 2*FAC3*FCLS2/3D0) VSIGDR = VSIGDR - FZERO*GADR*(FCSS1 + 2*FAC2*FCSS2/3D0) VTENLL = VTENLL + 0.25D0*FZERO*GALL*FAC1 *FTLL1 VTENSS = VTENSS + 0.25D0*FZERO*GASS*FAC2 *FTSS1 VTENLS = VTENLS + 0.25D0*FZERO*GALS*FAC3 *FTLS1 VTENDR = VTENDR + 0.25D0*FZERO*GADR*FAC2 *FTSS1 VSOLL = VSOLL - 0.5D0*FZERO*GALL*FAC1 *FSOLL1 VSOSS = VSOSS - 0.5D0*FZERO*GASS*FAC2 *FSOSS1 VSOLS = VSOLS - 0.5D0*FZERO*GALS*FAC3 *FSOLS1 VSODR = VSODR - 0.5D0*FZERO*GADR*FAC2 *FSOSS1 FISLL = FISLL - FZERO*3*GALL*FCLL1*DIV1*REDM(1)/2.D0 FISSS = FISSS - FZERO*3*GASS*FCSS1*DIV2*REDM(2)/2.D0 FISLS = FISLS - FZERO*3*GALS*FCLS1*DIV3*REDM(3)/2.D0 FISDR = FISDR - FZERO*3*GADR*FCSS1*DIV2*REDM(2)/2.D0 DFISLL = DFISLL - FZERO*3*GALL*DFCLL1*DIV1*REDM(1)/2.D0 DFISSS = DFISSS - FZERO*3*GASS*DFCSS1*DIV2*REDM(2)/2.D0 DFISLS = DFISLS - FZERO*3*GALS*DFCLS1*DIV3*REDM(3)/2.D0 DFISDR = DFISDR - FZERO*3*GADR*DFCSS1*DIV2*REDM(2)/2.D0 DDFSLL = DDFSLL - FZERO*GALL*AMAX2*(FCLL2+2*FSOLL1)* . DIV1*REDM(1)/6.D0 DDFSSS = DDFSSS - FZERO*GASS*AMAX2*(FCSS2+2*FSOSS1)* . DIV2*REDM(2)/6.D0 DDFSLS = DDFSLS - FZERO*GALS*AMAX2*(FCLS2+2*FSOLS1)* . DIV3*REDM(3)/6.D0 DDFSDR = DDFSDR - FZERO*GADR*AMAX2*(FCSS2+2*FSOSS1)* . DIV2*REDM(2)/6.D0 ENDIF C--------------------------------------------------------------- C C SECOND TERM AXIAL PROPAGATOR: C C--------------------------------------------------------------- IF(IBFLD.EQ.0) THEN C--------------------------------------------------------------- VSIGLL = VSIGLL + GALL*FCLL1/3 VSIGSS = VSIGSS + GASS*FCSS1/3 VSIGLS = VSIGLS + GALS*FCLS1/3 VSIGDR = VSIGDR + GADR*FCSS1/3 VTENLL = VTENLL + GALL*FTLL0 VTENSS = VTENSS + GASS*FTSS0 VTENLS = VTENLS + GALS*FTLS0 VTENDR = VTENDR + GADR*FTSS0 FISLL = FISLL - GALL*REDM(1)*FCLL1*DIV1/6.D0 FISSS = FISSS - GASS*REDM(2)*FCSS1*DIV2/6.D0 FISLS = FISLS - GALS*REDM(3)*FCLS1*DIV3/6.D0 FISDR = FISDR - GADR*REDM(2)*FCSS1*DIV2/6.D0 DFISLL = DFISLL - GALL*REDM(1)*DFCLL1*DIV1/6.D0 DFISSS = DFISSS - GASS*REDM(2)*DFCSS1*DIV2/6.D0 DFISLS = DFISLS - GALS*REDM(3)*DFCLS1*DIV3/6.D0 DFISDR = DFISDR - GADR*REDM(2)*DFCSS1*DIV2/6.D0 c FITEN = FITEN - GAX2*REDM*FT0 *DIV/2.D0 c DFITEN = DFITEN - GAX2*REDM*DFT0*DIV/2.D0 IF(IZAX.NE.0) THEN VSIGLL = VSIGLL + FZERO*GALL*FCLL2/3D0 VSIGSS = VSIGSS + FZERO*GASS*FCSS2/3D0 VSIGLS = VSIGLS + FZERO*GALS*FCLS2/3D0 VSIGDR = VSIGDR + FZERO*GADR*FCSS2/3D0 VTENLL = VTENLL + FZERO*GALL*FTLL1 VTENSS = VTENSS + FZERO*GASS*FTSS1 VTENLS = VTENLS + FZERO*GALS*FTLS1 VTENDR = VTENDR + FZERO*GADR*FTSS1 FISLL = FISLL - FZERO*GALL*REDM(1)*FCLL2*DIV1/6.D0 FISSS = FISSS - FZERO*GASS*REDM(2)*FCSS2*DIV2/6.D0 FISLS = FISLS - FZERO*GALS*REDM(3)*FCLS2*DIV3/6.D0 FISDR = FISDR - FZERO*GADR*REDM(2)*FCSS2*DIV2/6.D0 DFISLL = DFISLL - FZERO*GALL*REDM(1)*DFCLL2*DIV1/6.D0 DFISSS = DFISSS - FZERO*GASS*REDM(2)*DFCSS2*DIV2/6.D0 DFISLS = DFISLS - FZERO*GALS*REDM(3)*DFCLS2*DIV3/6.D0 DFISDR = DFISDR - FZERO*GADR*REDM(2)*DFCSS2*DIV2/6.D0 ENDIF ENDIF C--------------------------------------------------------------- IF(IBFLD.EQ.1) THEN write(*,*)'warning:in axial.02: ibfld=1: not yet implemented' return ENDIF C--------------------------------------------------------------- C C GAUSSIAN CONTRIBUTION (ANN.PHYS. 208, EQN. (7.16)): C C--------------------------------------------------------------- c UPSC0 = VKULL*AMAX(IN) c UPSC1 = -(1.5D0-XLAM1**2)*UPSC0 c UPST0 = + XLAM1**2*UPSC0/3.D0 c DUPSC0= -ALM1*XLAM1*UPSC0/PIM c FIC1 = -VKULL*AMAX(IN) c DFIC1= -ALM1*XLAM1*FIC1/PIM c VSIGLL(I) = VSIGLL(I) + 5*GALL*UPSC1*ALM1**2*DIV1/12.D0 c VTENLL(I) = VTENLL(I) - GALL*UPST0*ALM1**2*DIV1/4.D0 c FISLL(I) = FISLL(I) - GALL*REDM(1)*(UPSC0-FIC1/3.D0)*DIV1 c DFISLL(I) = DFISLL(I) - GALL*REDM(1)*(DUPSC0-DFIC1/3.D0)*DIV1 C c UPSC0 = VKULS*AMAX(IN) c UPSC1 = -(1.5D0-XLAM3**2)*UPSC0 c UPST0 = + XLAM3**2*UPSC0/3.D0 c DUPSC0= -ALM3*XLAM3*UPSC0/PIM c FIC1 = -VKULS*AMAX(IN) c DFIC1= -ALM3*XLAM3*FIC1/PIM c VSIGLS(I) = VSIGLS(I) + 5*GALS*UPSC1*ALM3**2*DIV3/12.D0 c VTENLS(I) = VTENLS(I) - GALS*UPST0*ALM3**2*DIV3/4.D0 c FISLS(I) = FISLS(I) - GALS*REDM(3)*(UPSC0-FIC1/3.D0)*DIV3 c DFISLS(I) = DFISLS(I) - GALS*REDM(3)*(DUPSC0-DFIC1/3.D0)*DIV3 C c UPSC0 = VKUSS*AMAX(IN) c UPSC1 = -(1.5D0-XLAM2**2)*UPSC0 c UPST0 = + XLAM2**2*UPSC0/3.D0 c DUPSC0= -ALM2*XLAM2*UPSC0/PIM c FIC1 = -VKUSS*AMAX(IN) c DFIC1= -ALM2*XLAM2*FIC1/PIM c VSIGSS(I) = VSIGSS(I) + 5*GASS*UPSC1*ALM2**2*DIV2/12.D0 c VTENSS(I) = VTENSS(I) - GASS*UPST0*ALM2**2*DIV2/4.D0 c FISSS(I) = FISSS(I) - GASS*REDM(2)*(UPSC0-FIC1/3.D0)*DIV2 c DFISSS(I) = DFISSS(I) - GASS*REDM(2)*(DUPSC0-DFIC1/3.D0)*DIV2 c VSIGDR(I) = VSIGDR(I) + 5*GADR*UPSC1*ALM2**2*DIV2/12.D0 c VTENDR(I) = VTENDR(I) - GADR*UPST0*ALM2**2*DIV2/4.D0 c FISDR(I) = FISDR(I) - GADR*REDM(2)*(UPSC0-FIC1/3.D0)*DIV2 c DFISDR(I) = DFISDR(I) - GADR*REDM(2)*(DUPSC0-DFIC1/3.D0)*DIV2 104 CONTINUE 1040 CONTINUE c fiss = 0.d0 c dfiss=0.d0 c fiten=0.d0 c dfiten=0.d0 C RETURN END C********************************************************************** C SUBROUTINE AXIALU1(XA,NLOC,ICSB,LC,P,PX) C C********************************************************************** C C AXIAL MESONS (UNNATURAL PARITY) POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR, . DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR DIMENSION AMAX(4) DATA SR3/1.732051D0/,SRPI/1.7724538509D0/,IPV/1/ DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1170.D0,1380.D0,1273.D0/ C C NOTE : B1(IN=1),H11 (IN=2),H11'(IN=3),K1B(IN=4) C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C DIV1 =1.D0/(AM(1)*AMY(1)) DIV2 =1.D0/(AM(1)*AMY(2)) DIV3 =1.D0/(AM(1)*AMH ) DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GALL= 0.D0 GASS= -2*FB(1)*FB(2) GALS= -SR3*FB(1)*FB(3) GADR= FB(1)*FB(2) AMAX(1)=AMB1 GOTO 1055 1052 GALL= FB(6)*FB(7) GASS= FB(6)*FB(8) GALS= 0.D0 GADR= FB(6)*FB(8) AMAX(2)=AMH1 GOTO 1055 1053 GALL= FB(9)*FB(10) GASS= FB(9)*FB(11) GALS= 0.D0 GADR= FB(9)*FB(11) AMAX(3)=AMH2 GOTO 1055 1054 GALL= FB(4)*FB(4)*P GASS= -FB(5)*FB(5)*P GALS= -SR3*FB(4)*FB(5)*P GADR= 2*FB(5)*FB(5)*P AMAX(4)=AMK1 C 1055 IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) THEN ALAM = ALMP8 IF(IN.EQ.2) ALAM=ALMP1 IF(IN.EQ.4) ALAM=ALMKA ENDIF C ALM1 = ALAM ALM2 = ALAM ALM3 = ALAM RATM1=AMAX(IN)/ALM1 RATM2=AMAX(IN)/ALM2 RATM3=AMAX(IN)/ALM3 FAC1=AMAX(IN)**2/(4*AM(1)*AMY(1)) FAC2=AMAX(IN)**2/(4*AM(1)*AMY(2)) FAC3=AMAX(IN)**2/(4*AM(1)*AMH ) AMAX2=AMAX(IN)*AMAX(IN) C C DO 104 I=2,NMAX X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMAX(IN)/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLL0 = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLL1 = FCLL0 - VKULL*AMAX(IN) FCLL2 = FCLL1 + (1.5D0-XLAM1**2)*VKULL*AMAX(IN)/RATM1**2 c* DFCLL0 = -X*FSOLL0 DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM DFCLL1 = DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN) ! MARCH 2009 DFTLL0 = DFCLL1/3.D0-3*FTLL0*PIM/XA FSOLL1 = FSOLL0-0.5D0*VKULL*(ALM1/AMAX(IN))**2*AMAX(IN) C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTSS0 = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN) FCSS1 = FCSS0 - VKUSS*AMAX(IN) FCSS2 = FCSS1 + (1.5D0-XLAM2**2)*VKUSS*AMAX(IN)/RATM2**2 c* DFCSS0 = -X*FSOSS0 DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM DFCSS1 = DFCSS0 + ALM1*XLAM1*VKUSS*AMAX(IN) ! MARCH 2009 DFTSS0 = DFCSS1/3.D0-3*FTSS0*PIM/XA FSOSS1 = FSOSS0-0.5D0*VKUSS*(ALM2/AMAX(IN))**2*AMAX(IN) C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN) FTLS0 = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN) FCLS1 = FCLS0 - VKULS*AMAX(IN) FCLS2 = FCLS1 + (1.5D0-XLAM3**2)*VKULS*AMAX(IN)/RATM3**2 c* DFCLS0 = -X*FSOLS0 DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM DFCLS1 = DFCLS0 + ALM1*XLAM1*VKULS*AMAX(IN) ! MARCH 2009 DFTLS0 = DFCLS1/3.D0-3*FTLS0*PIM/XA FSOLS1 = FSOLS0-0.5D0*VKULS*(ALM2/AMAX(IN))**2*AMAX(IN) C 1041 VSIGLL = VSIGLL - GALL*FAC1*FCLL1/3.D0 VSIGSS = VSIGSS - GASS*FAC2*FCSS1/3.D0 VSIGLS = VSIGLS - GALS*FAC3*FCLS1/3.D0 VSIGDR = VSIGDR - GADR*FAC2*FCSS1/3.D0 VTENLL = VTENLL - GALL*FAC1*FTLL0 VTENSS = VTENSS - GASS*FAC2*FTSS0 VTENLS = VTENLS - GALS*FAC3*FTLS0 VTENDR = VTENDR - GADR*FAC2*FTSS0 IF(NLOC.EQ.0) GO TO 104 FISLL = FISLL + GALL*FAC1*REDMM*FCLL1 *DIV1/6.D0 FISSS = FISSS + GASS*FAC2*REDMM*FCSS1 *DIV2/6.D0 FISLS = FISLS + GALS*FAC3*REDMM*FCLS1 *DIV3/6.D0 FISDR = FISDR + GADR*FAC2*REDMM*FCSS1 *DIV2/6.D0 DFISLL = DFISLL+ GALL*FAC1*REDMM*DFCLL1*DIV1/6.D0 DFISSS = DFISSS+ GASS*FAC2*REDMM*DFCSS1*DIV2/6.D0 DFISLS = DFISLS+ GALS*FAC3*REDMM*DFCLS1*DIV3/6.D0 DFISDR = DFISDR+ GADR*FAC2*REDMM*DFCSS1*DIV2/6.D0 DDFSLL = DDFSLL+ GALL*FAC1*REDMM*AMAX2*(FCLL2+2*FSOLL1)* . DIV1/6.D0 DDFSSS = DDFSSS+ GASS*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)* . DIV2/6.D0 DDFSLS = DDFSLS+ GALS*FAC3*REDMM*AMAX2*(FCLS2+2*FSOLS1)* . DIV3/6.D0 DDFSDR = DDFSDR+ GADR*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)* . DIV2/6.D0 c FITLL = FITLL + GALL*FAC1*REDMM*FTLL0 *DIV1/2.D0 c DFITLL = DFITLL+ GALL*FAC1*REDMM*DFTLL0*DIV1/2.D0 C 104 CONTINUE C 1040 CONTINUE C RETURN END C ********************************************************************* C SUBROUTINE PSSCAL02(XA,ICSB,NLOC,LC) C C********************************************************************** C updated august 2002, from PSSCAL98.F + YNRMP00.f , introducing GRAZ terms. C---------------------------------------------------------------------- C C PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS C IMPLICIT REAL *8(A-H,O-Z) COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST, . IFRMF,NSU3F COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP c COMMON/AMAT/XA(300),A(9,6,300) COMMON/POTF/VCLL ,VCSS ,VCLS ,VCDR, . VSIGLL,VSIGSS,VSIGLS,VSIGDR, . VTENLL,VTENSS,VTENLS,VTENDR, . VSOLL ,VSOSS ,VSOLS ,VSODR, . VSO2LL,VSO2SS,VSO2LS,VSO2DR, . VASOLL,VASOSS,VASOLS,VASODR, . VCNN ,VSIGNN,VTENNN,VSONN , . FILL ,FISS ,FILS ,FIDR, . DFILL ,DFISS ,DFILS ,DFIDR, . FISLL ,FISSS ,FISLS ,FISDR, . DFISLL,DFISSS,DFISLS,DFISDR, . FITLL ,FITSS ,FITLS ,FITDR, . DFITLL,DFITSS,DFITLS,DFITDR COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX DIMENSION F(11),AMPS(5) EQUIVALENCE (F1,F(1)) DATA SR3/1.732051D0/,SRPI/1.772454D0/ DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/ c** DATA DAMLN/0.D0/,DAMSN/0.D0/,DAMSL/0.D0/ DATA PIMC/138.041D0/,ICALL/0/ data napion/1/ C C NOTE : PION(IN=1),ETA (IN=2),ETAP(IN=3),KAON(IN=4) C C NOTE : INDEX 1 , 2 , 3 C REFERS TO LN -> LN, SN -> SN, LN -> SN REACTION C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.D0*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D0+XH+XH*XH/3.D0)-EXH*EP*(1.D0-XH+XH*XH/3.D0) . -8.D0*XLAMH*(0.5D0+XLAMH*XLAMH/3.D0)*EXLAM/ERATH/ . SRPI)/(2.D0*XH*XH*XH) FH0(ERATH,EXH,XH,EMH,EPH)=ERATH*(EMH/EXH+EXH*EPH)/(2*XH) C C SR3 = DSQRT(3.D0) SRPI= DSQRT(DACOS(-1.D0)) IF(LC.EQ.1) SIGN= 1.D0 IF(LC.NE.1) SIGN=-1.D0 DIV1 =1.D0/(AM(1)*AMY(1)) DIV2 =1.D0/(AM(1)*AMY(2)) DIV3 =1.D0/(AM(1)*AMH ) DO 1040 IN=1,4 GOTO(1051,1052,1053,1054),IN 1051 GPLL = -0.0271D0*ICSB*F1*F3 GPSS= -2*F1*F2 GPLS= -SR3*F1*F3 GPDR= F1*F2 AMPS(1)=PIM IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1052 GPLL= F6*F7 GPSS= F6*F8 GPLS= 0.D0 GPDR= F6*F8 AMPS(2)=AME IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP8 GOTO 1056 1053 GPLL= F9*F10 GPSS= F9*F11 GPLS= 0.D0 GPDR= F9*F11 AMPS(3)=AMX IF(IMODEL.LE.3) ALAM=ALMOBE IF(IMODEL.GE.4) ALAM=ALMP1 GOTO 1056 1054 GPLL= F4*F4*P GPSS= -F5*F5*P GPLS= -SR3*F4*F5*P GPDR= 2*F5*F5*P AMPS(4)=BMK IF(IMODEL.EQ.1) ALAM=ALMOBE IF(IMODEL.GE.2) ALAM=ALMKA GOTO 1056 C 1056 FACPS=(AMPS(IN)/PIMC)**2 ALM1=ALAM ALM2=ALAM ALM3=ALAM C c DO 104 I=2,NMAX c X = XA(I) XLAM1=0.5D0*XA*ALM1/PIM XLAM2=0.5D0*XA*ALM2/PIM XLAM3=0.5D0*XA*ALM3/PIM VKULL=(ALM1/AMPS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMPS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMPS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) X =XA*(AMPS(IN)/PIM) EX=FDEXP(X) C RATM1=AMPS(IN)/ALM1 EXPM1=DEXP(RATM1*RATM1) ELAM1=FDEXP(-XLAM1*XLAM1) DERFCM1=FDERFC(-XLAM1+RATM1) DERFCP1=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM1,EX,X,DERFCM1,DERFCP1)*AMPS(IN) FTENLL = FF3(EXPM1,EX,X,XLAM1,DERFCM1,DERFCP1,ELAM1)*AMPS(IN) C RATM2=AMPS(IN)/ALM2 EXPM2=DEXP(RATM2*RATM2) ELAM2=FDEXP(-XLAM2*XLAM2) DERFCM2=FDERFC(-XLAM2+RATM2) DERFCP2=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM2,EX,X,DERFCM2,DERFCP2)*AMPS(IN) FTENSS = FF3(EXPM2,EX,X,XLAM2,DERFCM2,DERFCP2,ELAM2)*AMPS(IN) C RATM3=AMPS(IN)/ALM3 EXPM3=DEXP(RATM3*RATM3) ELAM3=FDEXP(-XLAM3*XLAM3) DERFCM3=FDERFC(-XLAM3+RATM3) DERFCP3=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM3,EX,X,DERFCM3,DERFCP3)*AMPS(IN) FTENLS = FF3(EXPM3,EX,X,XLAM3,DERFCM3,DERFCP3,ELAM3)*AMPS(IN) C FCLL1 = FCLL0 - VKULL*AMPS(IN) FCSS1 = FCSS0 - VKUSS*AMPS(IN) FCLS1 = FCLS0 - VKULS*AMPS(IN) C C------------------------------------------------------------ C THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS: IF(IDAM.NE.0.AND.IN.NE.4) THEN CALL YMKFUN(XA,AMPS(IN),ALAM,SIGN,IDAM*DAMSL, .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1) IF(LC.EQ.1) THEN FCSS1 = AMPS(IN)*FXC1 FTENSS = AMPS(IN)*FXTEN ENDIF IF(LC.NE.1) THEN FCLL1 = AMPS(IN)*FXC1 FTENLL= AMPS(IN)*FXTEN ENDIF FCLS1 = 0.5D0*(FCLS1 + AMPS(IN)*FXC1 ) FTENLS = 0.5D0*(FTENLS+ AMPS(IN)*FXTEN) ENDIF C------------------------------------------------------------ C VSIGLL = VSIGLL + FACPS*GPLL*FCLL1/3.D0 VTENLL = VTENLL + FACPS*GPLL*FTENLL VSIGDR = VSIGDR + FACPS*GPDR*FCSS1/3.D0 VTENDR = VTENDR + FACPS*GPDR*FTENSS VSIGSS = VSIGSS + FACPS*GPSS*FCSS1/3.D0 VTENSS = VTENSS + FACPS*GPSS*FTENSS VSIGLS = VSIGLS + FACPS*GPLS*FCLS1/3.D0 VTENLS = VTENLS + FACPS*GPLS*FTENLS C----------------------------------------------------------------- C C NONLOCAL TERMS PSEUDOSCALAR MESONS: C C------------------------------------------------------------ IF(NAPION.EQ.1) THEN C------------------------------------------------------------ C GRAZ 1978: CC X = XA X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 AMES=AMPS(IN) VKU1 =(ALM1/AMPS(IN))*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKU2 =(ALM2/AMPS(IN))*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKU3 =(ALM3/AMPS(IN))*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) DVKU1 =-0.5D0*(ALM1/PIM)**2*X*VKU1 DDVKU1=-0.5D0*(ALM1/PIM)**2*(X*DVKU1+VKU1) D3VKU1=-0.5D0*(ALM1/PIM)**2*(X*DDVKU1+2*DVKU1) DVKU2 =-0.5D0*(ALM2/PIM)**2*X*VKU2 DDVKU2=-0.5D0*(ALM2/PIM)**2*(X*DVKU2+VKU2) D3VKU2=-0.5D0*(ALM2/PIM)**2*(X*DDVKU2+2*DVKU2) DVKU3 =-0.5D0*(ALM3/PIM)**2*X*VKU3 DDVKU3=-0.5D0*(ALM3/PIM)**2*(X*DVKU3+VKU3) D3VKU3=-0.5D0*(ALM3/PIM)**2*(X*DDVKU3+2*DVKU3) C FI1 = FF0(EXPM1,EX,X,DERFCM1,DERFCP1) HI1 = FH0(EXPM1,EX,X,DERFCM1,DERFCP1) DFI1 =-(FI1 -2*VKU1)*X1-(AMES/PIM)*HI1 DHI1 =-(AMES/PIM)*FI1 -HI1 *X1 DDFI1 =-(DFI1-2*DVKU1)*X1+(FI1-2*VKU1)*X2-(AMES/PIM)*DHI1 DDHI1 =-(AMES/PIM)*DFI1-DHI1*X1+HI1*X2 D3FI1 =-(DDFI1-2*DDVKU1)*X1+(DFI1-2*DVKU1)*X2-(AMES/PIM)*DDHI1 . +(DFI1-2*DVKU1)*X2-2*(FI1-2*VKU1)*X3 FC11 = (DDFI1+2*DFI1*X1) FT01 = (DDFI1-DFI1*X1)/3.D0 DFC11 = (D3FI1+2*DDFI1*X1-2*DFI1*X2) DFT01 = (D3FI1-DDFI1*X1+DFI1*X2)/3.D0 C FI2 = FF0(EXPM2,EX,X,DERFCM2,DERFCP2) HI2 = FH0(EXPM2,EX,X,DERFCM2,DERFCP2) DFI2 =-(FI2 -2*VKU2)*X1-(AMES/PIM)*HI2 DHI2 =-(AMES/PIM)*FI2 -HI2 *X1 DDFI2 =-(DFI2-2*DVKU2)*X1+(FI2-2*VKU2)*X2-(AMES/PIM)*DHI2 DDHI2 =-(AMES/PIM)*DFI2-DHI2*X1+HI2*X2 D3FI2 =-(DDFI2-2*DDVKU2)*X1+(DFI2-2*DVKU2)*X2-(AMES/PIM)*DDHI2 . +(DFI2-2*DVKU2)*X2-2*(FI2-2*VKU2)*X3 FC12 = (DDFI2+2*DFI2*X1) FT02 = (DDFI2-DFI2*X1)/3.D0 DFC12 = (D3FI2+2*DDFI2*X1-2*DFI2*X2) DFT02 = (D3FI2-DDFI2*X1+DFI2*X2)/3.D0 C FI3 = FF0(EXPM3,EX,X,DERFCM3,DERFCP3) HI3 = FH0(EXPM3,EX,X,DERFCM3,DERFCP3) DFI3 =-(FI3 -2*VKU3)*X1-(AMES/PIM)*HI3 DHI3 =-(AMES/PIM)*FI3 -HI3 *X1 DDFI3 =-(DFI3-2*DVKU3)*X1+(FI3-2*VKU3)*X2-(AMES/PIM)*DHI3 DDHI3 =-(AMES/PIM)*DFI3-DHI3*X1+HI3*X2 D3FI3 =-(DDFI3-2*DDVKU3)*X1+(DFI3-2*DVKU3)*X2-(AMES/PIM)*DDHI3 . +(DFI3-2*DVKU3)*X2-2*(FI3-2*VKU3)*X3 FC13 = (DDFI3+2*DFI3*X1) FT03 = (DDFI3-DFI3*X1)/3.D0 DFC13 = (D3FI3+2*DDFI3*X1-2*DFI3*X2) DFT03 = (D3FI3-DDFI3*X1+DFI3*X2)/3.D0 FISLL = FISLL -corsps*REDM(1)*GPLL*FC11*DIV1*PIM/6.D0 FITLL = FITLL -cortps*REDM(1)*GPLL*FT11*DIV1*PIM/2.D0 FISSS = FISSS -corsps*REDM(2)*GPSS*FC12*DIV2*PIM/6.D0 FITSS = FITSS -cortps*REDM(2)*GPSS*FT12*DIV2*PIM/2.D0 FISLS = FISLS -corsps*REDM(3)*GPLS*FC13*DIV3*PIM/6.D0 FITLS = FITLS -cortps*REDM(3)*GPLS*FCT3*DIV3*PIM/2.D0 FISDR = FISDR -corsps*REDM(2)*GPDR*FC12*DIV2*PIM/6.D0 FITDR = FITDR -cortps*REDM(2)*GPDR*FT12*DIV2*PIM/2.D0 DFISLL= DFISLL -corsps*REDM(1)*GPLL*DFC11*DIV1*PIM**2/6.D0 DFITLL= DFITLL -cortps*REDM(1)*GPLL*DFT11*DIV1*PIM**2/2.D0 DFISSS= DFISSS -corsps*REDM(2)*GPSS*DFC12*DIV2*PIM**2/6.D0 DFITSS= DFITSS -cortps*REDM(2)*GPSS*DFT12*DIV2*PIM**2/2.D0 DFISLS= DFISLS -corsps*REDM(3)*GPLS*DFC13*DIV3*PIM**2/6.D0 DFITLS= DFITLS -cortps*REDM(3)*GPLS*DFT13*DIV3*PIM**2/2.D0 DFISDR= DFISDR -corsps*REDM(2)*GPDR*DFC12*DIV2*PIM**2/6.D0 DFITDR= DFITDR -cortps*REDM(2)*GPDR*DFT12*DIV2*PIM**2/2.D0 if(x.lt.0.2d0) then write(*,*) 'psscal02: xa=',xa write(*,*) 'fi1,dfi1,ddfi1,d3fi1=',fi1,dfi1,ddfi1,d3fi1 write(*,*) 'hi1,dhi1,ddhi1,fisll=',hi1,dhi1,ddhi1,fisll endif c FITLL = FITLL -0.5D0*REDM(1)*GPLL*FT01*DIV1*PIM c FITSS = FITSS -0.5D0*REDM(2)*GPSS*FT02*DIV2*PIM c FITLS = FITLS -0.5D0*REDM(3)*GPLS*FT03*DIV3*PIM c FITDR = FITDR -0.5D0*REDM(2)*GPDR*FT02*DIV2*PIM c DFITLL= DFITLL -0.5D0*REDM(1)*GPLL*DFT01*DIV1*PIM**2 c DFITSS= DFITSS -0.5D0*REDM(2)*GPSS*DFT02*DIV2*PIM**2 c DFITLS= DFITLS -0.5D0*REDM(3)*GPLS*DFT03*DIV3*PIM**2 c DFITDR= DFITDR -0.5D0*REDM(2)*GPDR*DFT02*DIV2*PIM**2 C END GRAZ 1978. ENDIF C----------------------------------------------------------------- C c 104 CONTINUE C 1040 CONTINUE C ICALL = 1 RETURN END C ********************************************************************* C SUBROUTINE PLFORM(XA,UMAS,ALAM) C C********************************************************************** C september 2002: Pagnamenta-Licht Form-factor function: C from extra monopole factor U^2/(k^2+U^2) in g^2. C---------------------------------------------------------------------- IMPLICIT REAL *8(A-H,O-Z) COMMON/UFUNC/FCLL0,FCLS0,FCSS0,FCLL1,FCLS1,FCSS1, .UCLl2,UCLS2,UCSS2 COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN DATA PIM/138.041D0/,SR3/1.732051D0/,SRPI/1.772454D0/ C C THE POTENTIAL FUNCTIONS C FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH) FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI) . /(2.D00*XH*XH*XH) FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH . *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00) . -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/ . 1.7724538509D0)/(2.D00*XH*XH*XH) C AMPS= UMAS ALM1=ALAM ALM2=ALAM ALM3=ALAM RATM1=AMPS/ALM1 RATM2=AMPS/ALM2 RATM3=AMPS/ALM3 c FAC1=AMPS*AMPS/(AM(1)*AMY(1)) c FAC2=AMPS*AMPS/(AM(1)*AMY(2)) c FAC3=AMPS*AMPS/(AM(1)*AMH) C X = XA XLAM1=0.5D0*X*ALM1/PIM XLAM2=0.5D0*X*ALM2/PIM XLAM3=0.5D0*X*ALM3/PIM X =(AMPS/PIM)*X EX=FDEXP(X) VKULL=(ALM1/AMPS)**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI) VKUSS=(ALM2/AMPS)**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI) VKULS=(ALM3/AMPS)**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI) C EXPM=DEXP(RATM1*RATM1) ELAM=FDEXP(-XLAM1*XLAM1) DERFCM=FDERFC(-XLAM1+RATM1) DERFCP=FDERFC( XLAM1+RATM1) FCLL0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS FTENLL = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS C EXPM=DEXP(RATM2*RATM2) ELAM=FDEXP(-XLAM2*XLAM2) DERFCM=FDERFC(-XLAM2+RATM2) DERFCP=FDERFC( XLAM2+RATM2) FCSS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS FTENSS = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS C EXPM=DEXP(RATM3*RATM3) ELAM=FDEXP(-XLAM3*XLAM3) DERFCM=FDERFC(-XLAM3+RATM3) DERFCP=FDERFC( XLAM3+RATM3) FCLS0 = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS FTENLS = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS C FCLL1 = FCLL0 - VKULL*AMPS FCSS1 = FCSS0 - VKUSS*AMPS FCLS1 = FCLS0 - VKULS*AMPS C FCLL2 = FCLL1+(1.5D0-XLAM1*XLAM1)*VKULL*AMPS/RATM1/RATM1 FCSS2 = FCSS1+(1.5D0-XLAM2*XLAM2)*VKUSS*AMPS/RATM2/RATM2 FCLS2 = FCLS1+(1.5D0-XLAM3*XLAM3)*VKULS*AMPS/RATM3/RATM3 RETURN END C ********************************************************************** SUBROUTINE SU3SB03(F,ALP,SON) C ********************************************************************** C VERSION SEPTEMBER 2003 C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) DIMENSION F(11) C ---------------------------------------------------------------------- c f(9)=0d0 C SU3 SYMMETRIC COUPLINGS: CALL SU3(F,ALP) C ---------------------------------------------------------------------- C SU3 SYMMETRY BREAKING I=1/2 STATES: F(4) = F(4) - F(4)*(1.D0-SON) F(5) = F(5) - F(5)*(1.D0-SON) C ---------------------------------------------------------------------- C SU3 SYMMETRY BREAKING I=0 STATES: C ROTATION TO IDEAL MIXED STATES: COST = DSQRT(2.D0/3.D0) SINT = DSQRT(1.D0/3.D0) C NUCLEON COUPLINGS: FNNU = COST*F(9)+SINT*F(6) FNNS =-SINT*F(9)+COST*F(6) FNNS = FNNS- FNNS*(1.D0-SON*SON) C BACK ROTATION TO SU3 SINGLET AND OCTET STATES: F(9)= COST*FNNU -SINT*FNNS F(6)= SINT*FNNU +COST*FNNS C LAMBDA COUPLINGS: FLLU = COST*F(10)+SINT*F(7) FLLS =-SINT*F(10)+COST*F(7) FLLS = FLLS- FLLS*(1.D0-SON*SON) C BACK ROTATION TO SU3 SINGLET AND OCTET STATES: F(10)= COST*FLLU -SINT*FLLS F(7) = SINT*FLLU +COST*FLLS C SIGMA COUPLINGS: FSSU = COST*F(11)+SINT*F(8) FSSS =-SINT*F(11)+COST*F(8) FSSS = FSSS- FSSS*(1.D0-SON*SON) C BACK ROTATION TO SU3 SINGLET AND OCTET STATES: F(11)= COST*FSSU -SINT*FSSS F(8) = SINT*FSSU +COST*FSSS RETURN END C*********************************************************************** FUNCTION FDEXP(X) C*********************************************************************** IMPLICIT REAL*8 (A-H,O-Z) IF(X.LE.-170.D00) GOTO 1 IF(X.GT.+170.D00) GOTO 2 FDEXP=DEXP(X) RETURN 1 FDEXP=0.0D00 RETURN 2 FDEXP=1.0D 60 RETURN END C*********************************************************************** SUBROUTINE GAUSS(N,X,W,NT) C*********************************************************************** IMPLICIT REAL*8 (A-H,O-Z) DIMENSION WGAUS1(30), WGAUS2(30), WGAUSS(60), X(20), W(20) c EQUIVALENCE (WGAUS1(1),WGAUSS(1)), (WGAUS2(1),WGAUSS(31)) C C THIS ROUTINE CALCULATES THE WEIGHT-FACTORS AND ARGUMENT-DISTRIBUTIONS C FOR A GAUSSIAN-INTEGRATION IN THE INTERVAL -1.0 TO +1.0. WHEN N IS C NOT EQUAL TO 4,8,12,16 OR 20, A WARNING WILL BE GIVEN AND THE C WEIGHT-FACTORS AND DISTRIBUTIONS WILL BE THOSE OF A TWO POINT-SIMPS. C WHEN NT=1 ,ONE GETS A N-POINTS GAUSS C WHEN NT=2 ,ONE GETS A N-POINTS GAUSS ON THE INTERVAL -1,0 C AND A N-POINTS GAUSS ON 0,+1 C IF (MOD(N,4).NE.0) GO TO 2 C C THE ABSCISSAS AND WEIGHTS FOR GAUSSIAN INTEGRATION. C N=4,8,12,16,20 ONLY. C DATA WGAUS1 1/.339981043584856D0, .652145154862546D0, * .861136311594053D0, .347854845137454D0, * .183434642495650D0, .362683783378362D0, * .525532409916329D0, .313706645877887D0, * .796666477413627D0, .222381034453374D0, * .960289856497536D0, .101228536290376D0, * .125233408511469D0, .249147045813403D0, * .367831498998180D0, .233492536538355D0, * .587317954286617D0, .203167426723066D0, * .769902674194305D0, .160078328543346D0, * .904117256370475D0, .106939325995318D0, * .981560634246719D0, .047175336386512D0, * .0950125098376374D0, .1894506104550685D0, * .2816035507792589D0, .1826034150449236D0, * .4580167776572274D0, .1691565193950025D0/ DATA WGAUS2 / * .6178762444026437D0, .1495959888165767D0, * .7554044083550030D0, .1246289712555339D0, * .8656312023878317D0, .0951585116824928D0, * .9445750230732326D0, .0622535239386479D0, * .9894009349916499D0, .0271524594117541D0, * .0765265211334973D0, .1527533871307259D0, * .2277858511416451D0, .1491729864726037D0, * .3737060887154196D0, .1420961093183821D0, * .5108670019508271D0, .1316886384491766D0, * .6360536807265150D0, .1181945319615184D0, * .7463319064601508D0, .1019301198172404D0, * .8391169718222188D0, .0832767415767047D0, * .9122344282513259D0, .0626720483341091D0, * .9639719272779138D0, .0406014298003869D0, * .9931285991850949D0, .0176140071391521D0/ do 100 kk=1,30 wgauss(kk) = wgaus1(kk) 100 wgauss(kk+30) = wgaus2(kk) K=N/4-1 INIT=2*K*(K+1)+1 M=N/2 DO 1 I=1,M J=INIT-2+I*2 X(M+I)=WGAUSS(J) X(M+1-I)=-WGAUSS(J) W(M+I)=WGAUSS(J+1) 1 W(M+1-I)=WGAUSS(J+1) IF (NT.EQ.1) RETURN DO 10 I=1,N X(N+I)=(X(I)+1.0)/2. X(I)=(X(I)-1.0)/2. W(N+I)=W(I)/2. 10 W(I)=W(N+I) RETURN C C SIMPSON'S RULE : ONLY ODD N C 2 H=2.0/(N-1.0) X(1)=-1.0 W(1)=H/3.0 W23=(2.0*H)/3.0 W43=2.0*W23 NN=(N-1)/2 DO 3 I=1,NN J=2*I X(J)=X(J-1)+H W(J)=W43 X(J+1)=X(J)+H 3 W(J+1)=W23 X(N)=1.0 W(N)=W(1) RETURN END C*********************************************************************** FUNCTION FDERFC(X) C*********************************************************************** c Ref: W.J. Cody, Mathematics of Computation, 22 (1969) 631. IMPLICIT REAL*8(A-H,O-Z) REAL*8 P1(0:3),Q1(0:3),P2(0:7),Q2(0:7),P3(0:4),Q3(0:4) REAL*8 XPOWER(0:7) DATA PI/3.1415926535897932384626433832795028D0/ DATA P1/ 2.42667 95523 05318 D+2, . 2.19792 61618 29415 D+1, . 6.99638 34886 19136 D+0, . -3.56098 43701 81538 D-2 / DATA Q1/ 2.15058 87586 98612 D+2, . 9.11649 05404 51490 D+1, . 1.50827 97630 40779 D+1, . 1.00000 00000 00000 D+0 / DATA P2/ 3.00459 26102 01616 D+2, . 4.51918 95371 18729 D+2, . 3.39320 81673 43437 D+2, . 1.52989 28504 69404 D+2, . 4.31622 27222 05674 D+1, . 7.21175 82508 83094 D+0, . 5.64195 51747 89740 D-1, . -1.36864 85738 27167 D-7 / DATA Q2/ 3.00459 26095 69833 D+2, . 7.90950 92532 78980 D+2, . 9.31354 09485 06096 D+2, . 6.38980 26446 56312 D+2, . 2.77585 44474 39876 D+2, . 7.70001 52935 22947 D+1, . 1.27827 27319 62942 D+1, . 1.00000 00000 00000 D+0 / DATA P3/-2.99610 70770 35422 D-3, . -4.94730 91062 32507 D-2, . -2.26956 59353 96869 D-1, . -2.78661 30860 96478 D-1, . -2.23192 45973 41847 D-2 / DATA Q3/ 1.06209 23052 84679 D-2, . 1.91308 92610 78298 D-1, . 1.05167 51070 67932 D+0, . 1.98733 20181 71353 D+0, . 1.00000 00000 00000 D+0 / Y = DABS(X) IF(Y.LE.0.46875D0) THEN A=P1(0) B=Q1(0) XPOWER(0)=1.D0 DO J=1,3 XPOWER(J)=XPOWER(J-1)*Y*Y A=A+P1(J)*XPOWER(J) B=B+Q1(J)*XPOWER(J) ENDDO FDERFC=1.D0-Y*A/B ELSEIF(Y.LE.4.D0) THEN A=P2(0) B=Q2(0) XPOWER(0)=1.D0 DO J=1,7 XPOWER(J)=XPOWER(J-1)*Y A=A+P2(J)*XPOWER(J) B=B+Q2(J)*XPOWER(J) ENDDO FDERFC=DEXP(-Y*Y)*A/B ELSEIF(Y.LE.10.D0) THEN A=P3(0) B=Q3(0) XPOWER(0)=1.D0 DO J=1,4 XPOWER(J)=XPOWER(J-1)/(Y*Y) A=A+P3(J)*XPOWER(J) B=B+Q3(J)*XPOWER(J) ENDDO FDERFC=DEXP(-Y*Y)/Y*(1.D0/DSQRT(PI)+A/B*XPOWER(1)) ELSE FDERFC=0.D0 ENDIF IF(X.LT.0.D0) FDERFC=2.D0-FDERFC RETURN END subroutine errset(i,j,k,l) integer i,j,k,l return end ************************************************************************ subroutine gausss(n,x,w,nt) C* The abcissas and weights for Gaussian integration, C* N=4,8,12,16,20,32,48 only: implicit real*8 (a-h,o-z) dimension wgauss(61), weulra(32),weulrb(48) dimension x(*),w(*) data wgauss 1/.33998104358486,.65214515486255,.86113631159405,.34785484513745 *,.18343464249565,.36268378337836,.52553240991633,.31370664587789 *,.79666647741362,.22238103445337,.96028985649753,.10122853629038 *,.12523340851147,.24914704581340,.36783149899818,.23349253653835 *,.58731795428661,.20316742672307,.76990267419430,.16007832854335 *,.90411725637048,.10693932599532,.98156063424672,.04717533638651 *,.09501250983764,.18945061045507,.28160355077926,.18260341504492 *,.45801677765722,.16915651939500,.61787624440264,.14959598881658 *,.75540440835500,.12462897125553,.86563120238783,.09515851168249 *,.94457502307323,.06225352393865,.98940093499165,.02715245941175 *,.07652652113350,.15275338713072,.22778585114164,.14917298647260 *,.37370608871542,.14209610931838,.51086700195082,.13168863844918 *,.63605368072652,.11819453196152,.74633190646015,.10193011981724 *,.83911697182222,.08327674157670,.91223442825132,.06267204833411 *,.96397192727791,.04060142980039,.99312859918509,.01761400713915 *,.00/ C 32 POINTS: data weulra 1/.04830766568774,.09654008851473,.14447196158280,.09563872007927 *,.23928736225214,.09384439908080,.33186860228213,.09117387869576 *,.42135127613064,.08765209300440,.50689990893223,.08331192422695 *,.58771575724076,.07819389578707,.66304426693022,.07234579410885 *,.73218211874029,.06582222277636,.79448379596794,.05868409347854 *,.84936761373257,.05099805926238,.89632115576605,.04283589802223 *,.93490607593774,.03427386291302,.96476225558751,.02539206530926 *,.98561151154527,.01627439473091,.99726386184948,.00701861000947 */ C 48 POINTS: data weulrb 1/.03238017096287,.06473769681268,.09700469920946,.06446616443595 *,.16122235606889,.06392423858465,.22476379039469,.06311419228625 *,.28736248735546,.06203942315989,.34875588629216,.06070443916589 *,.40868648199071,.05911483969840,.46690290475096,.05727729210040 *,.52316097472223,.05519950369998,.57722472608397,.05289018948519 *,.62886739677651,.05035903555385,.67787237963266,.04761665849249 *,.72403413092381,.04467456085669,.76715903251574,.04154508294346 *,.80706620402944,.03824135106583,.84358826162439,.03477722256477 *,.87657202027425,.03116722783280,.90587913671557,.02742650970836 *,.93138669070655,.02357076083932,.95298770316043,.01961616045736 *,.97059159254625,.01557931572294,.98412458372283,.01147723457923 *,.99353017226635,.00732755390128,.99877100725243,.00315334605231 */ if(mod(n,4).ne.0) then C* Simpson's rule: only odd N h=2d0/(n+1d0) x(1)=-1d0+h w23=2d0*h/3d0 w43=2d0*w23 w(1)=w43 nn=(n-1)/2 do 10 i=1,nn j=2*i x(j)=x(j-1)+h x(j+1)=x(j)+h w(j)=w23 w(j+1)=w43 10 continue return endif if(n.le.20) then k=n/4-1 init=2*k*(k+1)+1 m=n/2 do 1 i=1,m j=init-2+i*2 x(m+i)=wgauss(j) x(m+1-i)=-wgauss(j) w(m+i)=wgauss(j+1) w(m+1-i)=wgauss(j+1) 1 continue endif if(n.eq.32) then m=n/2 do 2 i=1,m j=2*i-1 x(m+i)=weulra(j) x(m+1-i)=-weulra(j) w(m+i)=weulra(j+1) w(m+1-i)=weulra(j+1) 2 continue endif if(n.eq.48) then m=n/2 do 3 i=1,m j=2*i-1 x(m+i)=weulrb(j) x(m+1-i)=-weulrb(j) w(m+i)=weulrb(j+1) w(m+1-i)=weulrb(j+1) 3 continue endif if(nt.eq.1) return do 5 i=1,n x(n+i)=(x(i)+1d0)/2d0 x(i)=(x(i)-1d0)/2d0 w(n+i)=w(i)/2d0 w(i)=w(n+i) 5 continue return end ************************************************************************ subroutine chebsv(nogp,xx,ww) implicit real*8 (a-h,o-z) parameter( mxgp=96) dimension xx(*),ww(*) dimension b(mxgp+2,mxgp+2),x(mxgp+2),t(mxgp+2) data ichck/0/, pi/3.14159265358979323846d0/ n1=nogp+2 n=n1-1 nm1=n-1 C* Generation Chebyshev points do 1 k=1,n1 1 x(k)=-dcos((k-1)*pi/n) do 4 i=1,n1 argi=dacos(x(i)) do 5 k=1,n1 5 t(k)=dcos((k-1)*argi) do 4 j=1,n1 argj=dacos(x(j)) b(j,i)=0d0 do 6 k=2,nm1 tkj=dcos((k-1)*argj) 6 b(j,i)=b(j,i)+0.5d0*tkj*(t(k-1)-t(k+1))/(k-1) tnm1=dcos((n-1)*argj) b(j,i)=b(j,i)+tnm1*0.5d0*(t(n-1)-0.5d0*t(n+1))/(n-1) tn=dcos(n*argj) b(j,i)=b(j,i)+tn*0.5d0*t(n)/n tn1=dcos((n+1)*argj) b(j,i)=b(j,i)+tn1*0.25d0*t(n+1)/(n+1) t0=0.5d0-0.25d0*t(2)-0.5d0*(-1)**n*t(n+1)/(n*n-1) do 7 k=2,nm1 7 t0=t0-(-1)**k*t(k+1)/(k*k-1) b(j,i)=b(j,i)+t0 b(j,i)=b(j,i)*2d0/n if(i.eq.1 .or. i.eq.n1) b(j,i)=b(j,i)/2d0 4 continue do 41 i1=1,nogp xx(i1)=x(i1+1) 41 ww(i1)=b(n1,i1+1) return end C ********************************************************************** SUBROUTINE YMKFUN(X,AMES,ALAM,SIGN,DAM,FC0,FC1,FC2, . FT0,FT1,FO0,FO1) C ********************************************************************** C C YUKAWA-MACKE-KLEIN PROPAGATOR: C 1 1 C FOURIER TRANSFORM OF F(OMEGA)= ----- -------------- C OMEGA (OMEGA +/- DAM) C IN THE FORM OF THE PHI^N_{C,T,SO}-FUNCTIONS DEFINED IN PRD17,PRC40 C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1991). C C VERSION: PHI-FUNCTIONS A LA PRD17 AND PRC40 !! C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) DIMENSION XX(96),WW(96),YB(3) c** COMMON/PIMAS/PIM DATA PIM/138.031D0/ DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/,NS/0/ c DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/ DATA PCUT/5.0D0/,PMAX/20/,IKIND/-1/,NPNT/32/,IQUADR/1/ c** DATA PCUT/5.0D0/,PMAX/40/,IKIND/+2/,NPNT/20/,IQUADR/1/ c** DATA PCUT/5.0D0/,PMAX/20/,IKIND/+3/,NPNT/32/,IQUADR/1/ SAVE XX,WW C --------------------------------------------------------------- C C POTENTIAL FUNTIONS DEFINITION C C------------------------------------------------------------------- F0(ERATH,EXH,EM,EP,XH)=ERATH*(EM/EXH-EXH*EP)/(2.D0*XH) F1(ERATH,EXH,EM,EP,EXLAM,XH,XLAMH)=ERATH*(EM/EXH . *(1.D0+XH)-EXH*EP*(1.D0-XH)-4.D0*XLAMH*EXLAM/ERATH/SRPI) . /(2.D0*XH*XH*XH) F3(ERATH,EXH,EM,EP,EXLAM,XH,XLAMH)=ERATH*(EM/EXH . *(1.D0+XH+XH*XH/3.D0)-EXH*EP*(1.D0-XH+XH*XH/3.D0) . -8.D0*XLAMH*(0.5D0+XLAMH*XLAMH/3.D0)*EXLAM/ERATH/SRPI) . /(2.D0*XH*XH*XH) C C------------------------------------------------------------------- c IF(ICALL.EQ.0) THEN c CALL GAUSS(NPNT,XX,WW,1) c IF(IMETH.EQ.1) NINT=1 C PRINT 52, IMETH,NPNT C52 FORMAT(//,' IN FFUN: IMETH=',I2,' NPNT=',I2,//) C PI = DACOS(-1.D0) C SRPI= DSQRT(PI) c** ICALL=1 c ENDIF C --------------------------------------------------------------- IF(ICALL.EQ.0) THEN C GENERATION INTEGRATION POINTS: IF(NS.NE.0) PRINT 1, NPNT,IKIND,PCUT,PMAX,IQUADR 1 FORMAT(/,' YMKFUN METHOD PARAMETERS ARE: NPNT=',I2, .' IKIND=',I2,' PCUT=',F10.3,' PMAX=',F10.3,' IQUADR=',I2,/) CALL GRID(XX,WW,NPNT,0.D0,PCUT,PMAX,IKIND,IQUADR) PI = DACOS(-1.D0) SRPI= DSQRT(PI) ICALL=1 ENDIF C --------------------------------------------------------------- CC AA = DAM/PIM CC XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM EXLAM=FDEXP(-XLAM2) RATP = PIM/ALAM C------------------------------------------------------------------- IF(SIGN.EQ.-1.D0.OR.DAM.EQ.0.D0) THEN FDISAA= DEXP(AA*AA/ALAM/ALAM) BMES = DSQRT(AMES**2-DAM**2) BMES1= BMES/PIM BMES3=(BMES/PIM)**3 BMES5=(BMES/PIM)**5 VKUA =(ALAM/BMES)**3*FDEXP(-XLAM2)/(2*SRPI) XA =X*BMES/PIM RATA =BMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,XA) FIAT =F3(ERATA,EXA ,EMA ,EPA ,EXLAM, XA, XLAM) FIAO =F1(ERATA,EXA ,EMA ,EPA ,EXLAM, XA, XLAM) c FIAO2=3*FIAT/(XA*XA) C FIA1 = FIA - VKUA FIA2 = FIA1 + (1.5D0-XLAM*XLAM)*VKUA/RATA/RATA FIAT1= FIAT - XLAM*XLAM*VKUA/(3*RATA*RATA) FIAO1= FIAO - VKUA/(2*RATA*RATA) C------------------------------------------------------------------- C IF(DAM.EQ.0.D0) THEN FC0 = FIA FC1 = FIA1 FC2 = FIA2 FT0 = FIAT FT1 = FIAT1 FO0 = FIAO FO1 = FIAO1 RETURN ENDIF C FIB = FIA*FDISAA*BMES1 FIB1 = FIA1*FDISAA*BMES3 FIB2 = FIA2*FDISAA*BMES5 FIBT = FIAT*FDISAA*BMES3 FIBT1= FIAT1*FDISAA*BMES5 FIBO = FIAO*FDISAA*BMES3 FIBO1= FIAO1*FDISAA*BMES5 ENDIF C --------------------------------------------------------------- C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C if(icall.eq.0) test1=0.d0 GG =0.D0 GG1 =0.D0 GG2 =0.D0 GGT =0.D0 GGO =0.D0 GGT1 =0.D0 GGO1 =0.D0 C --------------------------------------------------------------- C USING GAUSS DIRECTLY: c DO 100 INT=1,NINT c ABM=0.5D0*(YB(INT+1)-YB(INT)) c ABP=0.5D0*(YB(INT+1)+YB(INT)) c DO 110 IY=1,NPNT c IF(IMETH.EQ.0) THEN c Y=ABM*XX(IY)+ABP c GEW=WW(IY)*ABM*2.D0/PI c ENDIF c IF(IMETH.EQ.1) THEN c Y=(1.D0+XX(IY))/(1.D0-XX(IY)) c GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI c ENDIF c IF(Y.GE.50.D0) GOTO 110 C --------------------------------------------------------------- C USING GRID: DO 110 IY=1,NPNT Y = XX(IY) GEW = (2.D0/PI)*WW(IY) C --------------------------------------------------------------- GEW = GEW*AA/(Y**2+AA**2) C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP =FDEXP(-Y*Y*RATP*RATP) C AM=PIM*DSQRT((AMES/PIM)**2+Y*Y) AM1 = AM/PIM AM3 = (AM/PIM)**3 AM5 = (AM/PIM)**5 VKUM =(ALAM/AM)**3*FDEXP(-XLAM2)/(2*SRPI) XM=AM*X/PIM RATM =AM/ALAM ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLAM+RATM) EPM =FDERFC( XLAM+RATM) FIM =F0(ERATM,EXM ,EMM ,EPM ,XM) FIMT =F3(ERATM,EXM ,EMM ,EPM ,EXLAM, XM, XLAM) FIMO =F1(ERATM,EXM ,EMM ,EPM ,EXLAM, XM, XLAM) c FIMO2=3*FIAT/(XM*XM) C FIM1 = FIM - VKUM FIM2 = FIM1 + (1.5D0-XLAM*XLAM)*VKUM/RATM/RATM FIMT1= FIMT - XLAM*XLAM*VKUM/(3*RATM*RATM) FIMO1= FIMO - VKUM/(2*RATM*RATM) C IF(SIGN.EQ.1.D0) THEN GG = GG + GEW*FIM *FDISP*AM1 GG1 = GG1 + GEW*FIM1 *FDISP*AM3 GG2 = GG2 + GEW*FIM2 *FDISP*AM5 GGT = GGT + GEW*FIMT *FDISP*AM3 GGO = GGO + GEW*FIMO *FDISP*AM3 GGT1 = GGT1 + GEW*FIMT1*FDISP*AM5 GGO1 = GGO1 + GEW*FIMO1*FDISP*AM5 ENDIF IF(SIGN.EQ.-1.D0) THEN GG = GG + GEW*(2*FIB- FIM *FDISP*AM1) GG1 = GG1 + GEW*(2*FIB1-FIM1*FDISP*AM3) GG2 = GG2 + GEW*(2*FIB2-FIM2*FDISP*AM5) GGT = GGT + GEW*(2*FIBT-FIMT*FDISP*AM3) GGO = GGO + GEW*(2*FIBO-FIMO*FDISP*AM3) GGT1 = GGT1 + GEW*(2*FIBT1-FIMT1*FDISP*AM5) GGO1 = GGO1 + GEW*(2*FIBO1-FIMO1*FDISP*AM5) ENDIF C 110 CONTINUE c100 CONTINUE C --------------------------------------------------------------- C C PHI-FUNCTIONS A LA PRD17 ANDPRC40: FC0 = (PIM/AMES)**1*GG FC1 = (PIM/AMES)**3*GG1 FC2 = (PIM/AMES)**5*GG2 FT0 = (PIM/AMES)**3*GGT FT1 = (PIM/AMES)**5*GGT1 FO0 = (PIM/AMES)**3*GGO FO1 = (PIM/AMES)**5*GGO1 CC C --------------------------------------------------------------- ICALL=1 RETURN END C ********************************************************************** SUBROUTINE GRID(P,WH,NOGP,P0,PCUT,PMAX,IKIND,IQUADR) C ********************************************************************** C C GENERATING THE INTEGRATION POINTS C C----------------------------------------------------------------------- IMPLICIT REAL*8(A-H,O-Z) c* INCLUDE 'DIMPARS' c* DIMENSION P(NGAUSS),WH(NGAUSS),X(NGAUSS),W(NGAUSS) DIMENSION P(96),WH(96),X(96),W(96) DATA NS/0/ NT=1 IF (IKIND.LT.0) NT=2 IS=IABS(IKIND) NOGP=NOGP/NT IF(IQUADR.EQ.1) THEN IF(NS.EQ.1) PRINT 1007 CALL GAUSSS(NOGP,X,W,NT) ENDIF c IF(IQUADR.EQ.2) THEN c IF(NS.EQ.1) PRINT 1008 c CALL CHEBSV(NOGP,X,W) c ENDIF NOGP=NOGP*NT C----------------------------------------------------------------------- C C MAPPING BY HYPERBOLIC MAPPING: C C----------------------------------------------------------------------- C INTERVAL: P0 - INFTY: IF(IABS(IKIND).EQ.1) THEN DO 20 I=1,NOGP P(I)=PCUT*(2.D0/(1.D0-X(I))-1.D0) . -2*P0*X(I)/(1.D0-X(I)) 20 WH(I)=2*(PCUT-P0)*W(I)/(1.D0-X(I))**2 IF(NS.EQ.1) PRINT 1010 ENDIF C----------------------------------------------------------------------- C C MAPPING BY LINEAR FRACTION: C C----------------------------------------------------------------------- C INTERVAL: P0 - PMAX: IF(IABS(IKIND).EQ.2) THEN C PARAMETERS ARE AA = ( (PMAX-PCUT)*P0+(P0-PCUT)*PMAX)/(PMAX+P0-2*PCUT) DD = (P0-PMAX)/(PMAX+P0-2*PCUT) BB = PCUT*DD DO 30 I=1,NOGP P(I)=( AA*X(I)+BB )/( X(I)+DD ) 30 WH(I)= W(I)*( AA*DD-BB )/( X(I)+DD)**2 IF(NS.EQ.1) PRINT 1030 ENDIF C----------------------------------------------------------------------- C C MAPPING BY ARCTANGENT FUNCTION C C----------------------------------------------------------------------- C INTERVAL: P0 - PMAX: IF(IABS(IKIND).EQ.3) THEN PI4 = 0.25D0*DACOS(-1.D0) DO 40 I=1,NOGP AA = PI4*(X(I)+1.D0) P(I)=PCUT*DTAN(AA) CS =DCOS(AA) 40 WH(I)= PI4*PCUT*W(I)/(CS*CS) IF(NS.EQ.1) PRINT 1040 ENDIF C----------------------------------------------------------------------- C IF(NS.EQ.1) THEN WRITE(6,1009) IKIND,NOGP,P0,PCUT,PMAX,(P(I),I=1,NOGP) WRITE(6,1019) (WH(I),I=1,NOGP) ENDIF C----------------------------------------------------------------------- RETURN 1007 FORMAT (' GRID : QUADRATURE = GAUSSIAN,',/) 1008 FORMAT (' GRID : QUADRATURE = CHEBYSHEV,',/) 1009 FORMAT (' IKIND=',I2,' NOGP=',I3,' P0=',F10.3,' PCUT=', .F10.3,' PMAX=',F10.3,/,10X,' GRID POINTS :',/,4(5D14.5,/)) 1019 FORMAT (10X,' GRID WEIGHTS:',/,4(5D14.5,/)) 1010 FORMAT (' MAPPING WITH HYPERBOLA,',/) 1030 FORMAT (' MAPPING WITH LINEAR FRACTION,',/) 1040 FORMAT (' MAPPING WITH ARCTANGENT,',/) END C ********************************************************************** C VERSION DECEMBER 2009: 1. 1/M-TERMS PI-OMEGA INCLUDED !! C 2. VSIG, VTEN, VASO C 3. AXIAL 1^{++} SU3-SINGLET PAIRS C ********************************************************************** C NOTICE: IN COMMON/ALLPS/ added AMPI, w.r.t. bbprogs!! C ********************************************************************** C VERSION YNOOM.F: 15 SEPT. 1997, SU3-relations okay! C ********************************************************************** C C NOTICE: 1) FOR DOUBLE SCALAR/DIFFRACTIVE: ALD = 0.25! C 2) IN OMPAIR : COMMON/CCPR/ ! C C ********************************************************************** SUBROUTINE OMPSPS(X,INA,IPV,IOFF,ALP,APV) C ********************************************************************** C * C * DATE: AUGUST, 1995 C C * THIS ROUTINE: POTENTIALS FROM DOUBLE PSEUDO-SCALAR EXCHANGE C * CALLED BY SUBROUTINE YNPSPS C * C * 1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX C * C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET C * C ********************************************************************** C C INCLUDED IN ENERGY DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT. C INCLUDED IN COUPLING-COMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13, .XGD12,XGD13 COMMON/PSBEOM/ .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4), .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4) DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA IPIPI/1/,IPIET/1/,IPIETP/1/,IPIKA/1/,IKAKA/1/, . IETA2/1/,IETKA/1/,IETETP/1/,IETPKA/1/,IETAP2/1/ DATA FACT/70.D0/,ICALL/0/,NSCHR/0/,POLD/-123D0/ c character*6 typ(10) c data typ/'PIPI','IPIET','IPIETP','IPIKA','IKAKA', c .'IETA2','IETKA','IETETP','IETPKA','IETAP2'/ SAVE FACT,AMB,BPV c SAVE SOALL,SOALS,SOASS C CALL ERRSET(208,256,-1,1) C pim=pim0 c* pim=500.d0 IF(ICALL.EQ.0) THEN FACT = PIM0/2.D0 BPV = 2*APV-1.D0 C AVERAGE MASS: AMB = 2*AMNN*AMH/(AMNN+AMH) FACT = (PIM0/AMB)*FACT IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB,APV 52 FORMAT(//,' IN OMPSPS: INA, IPV, IOFF=',3I3,' PIM=',F7.3, . ' AMB=',F10.3,' APV=',F10.3,/) c ICALL=1 c SOALL = (AMNN-AMLN)/(AMNN+AMLN) c SOALS = (AMNN-AMH )/(AMNN+AMH ) c SOASS = (AMNN-AMSN)/(AMNN+AMSN) ENDIF if(pold.ne.p) then icall=0 pold = p nschr= 1 IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 ISFLL = (1+ISFAC)/2 ISFLS = (3-ISFAC) ISFSS = (9+ISFAC)/2 endif if(icall.eq.20.and.nschr.eq.1) then DO 250 NCHAN=1,5 DO 250 ITYPV=1,4 DO 250 M=1,4 DO 250 N=1,4 250 VPSPS(NCHAN,ITYPV,M,N)=0.D0 endif XF12=F1*(4*ALP-1.D0)/SR3 XF13=-F1 C C 1/M-CORRECTIONS: C DO 100 II=1,10 PEX = 1.D0 GOTO(10,20,30,40,50,60,70,80,90,95),II C PION-PION EXCHANGE POTENTIALS: 10 IF(IPIPI.EQ.1) THEN M = 1 N = 1 C PARALLEL: CPANN = 1*(3-2*ISFAC)*F1**2*F1**2 CPALL = 3*F1*F1*F3*F3 CPALS = 2*SR3*F1*F1*F3*F2 CPASS = F1*F1*(3*F3*F3+4*F2*F2) CPADR = +F1*F1*F2*F2 C CROSSED: CCRNN = 1*(3+2*ISFAC)*F1**2*F1**2 CCRLL = 3*F1*F1*F3*F3 CCRLS = -2*SR3*F1*F1*F3*F2 CCRSS = -F1*F1*F3*F3 CCRDR = F1*F1*(2*F3*F3+3*F2*F2) CALL FOOM(1,X,PIM,PIM,ALMP8,ALMP8) ENDIF GOTO 200 C PION-ETA EXCHANGE POTENTIALS: 20 IF(IPIET.EQ.1) THEN M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*F1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*F1*F6*F3*(F8+F7) CPASS = -4*F1*F6*F2*F8 CPADR = +2*F1*F6*F2*F8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*F6*F3*(F8+F7) CCRSS = -4*F1*F6*F2*F8 CCRDR = +2*F1*F6*F2*F8 CALL FOOM(1,X,PIM,AME,ALMP8,ALMP8) GOTO 200 ENDIF C PION-ETA' EXCHANGE POTENTIALS: 30 IF(IPIETP.EQ.1) THEN M = 1 N = 4 C PARALLEL: CPANN = 2*ISFAC*F1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*F1*F9*F3*(F11+F10) CPASS = -4*F1*F9*F2*F11 CPADR = +2*F1*F9*F2*F11 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*F9*F3*(F11+F10) CCRSS = -4*F1*F9*F2*F11 CCRDR = +2*F1*F9*F2*F11 CALL FOOM(1,X,PIM,AMX,ALMP8,ALMP1) ENDIF GOTO 200 C PION-KAON EXCHANGE POTENTIALS: 40 IF(IPIKA.EQ.1) THEN PEX = P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*F1*F4*F3*F5 CPALS = -SR3*F1*F3*(F4**2-F5**2) . +2*SR3*F1*F2*F4*F5 CPASS = F1*F5*(6*F3*F4+4*F2*F5) CPADR = +4*F1*F2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(F1*F1*F4**2+F3*F3*F5**2) CCRLS = SR3*F4*F5*(F1**2-F3**2) . +2*SR3*F2*F3*F5**2 CCRSS = 5*F1**2*F5**2+F3**2*F4**2 . +4*F2*F3*F4*F5 CCRDR = 2*F1**2*F5**2+F3**2*F4**2 . +3*F2**2*F5**2-2*F2*F3*F4*F5 CALL FOOM(1,X,PIM,AMK,ALMP8,ALMKA) ENDIF GOTO 200 C KAON-KAON EXCHANGE POTENTIALS: 50 IF(IKAKA.EQ.1) THEN M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = (F4**2+3*F5**2)*F4**2 CPALS = SR3*(F5**2-F4**2)*F4*F5 CPASS = (3*F4**2+F5**2)*F5**2 CPADR = 4*F5**4 C CROSSED: CCRNN = 1*(ISFLL*F4**2*F4**2+ISFLS*F4*F5*F4*F5+ . ISFSS*F5**2*F5**2) CCRLL = +(F4**2+3*F5**2)*XF12**2 CCRLS = +SR3*(F4**2-F5**2)*1*XF12*XF13 CCRSS = +(-F4**2+5*F5**2)*XF13**2 CCRDR = +2*XF13**2*(F4**2+F5**2) CALL FOOM(1,X,AMK,AMK,ALMKA,ALMKA) ENDIF GOTO 200 C ETA-ETA EXCHANGE POTENTIALS: 60 IF(IETA2.EQ.1) THEN PEX = 1.D0 M = 3 N = 3 C PARALLEL: CPANN = F6**2*F6**2 CPALL = F6**2*F7**2 CPALS = 0.D0 CPASS = F6**2*F8**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = F6**2*F7**2 CCRLS = 0.D0 CCRSS = F6**2*F8**2 CCRDR = CCRSS CALL FOOM(1,X,AMK,AMK,ALMKA,ALMKA) ENDIF GOTO 200 C ETA-KAON EXCHANGE POTENTIALS: 70 IF(IETKA.EQ.1) THEN PEX = P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*F6*F7*F4**2 CPALS = -SR3*F6*(F7+F8)*F4*F5 CPASS = -2*F6*F8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (F6**2+F7**2)*F4**2 CCRLS = -SR3*(F6**2+F7*F8)*F4*F5 CCRSS = -1*(F6**2+F8**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(1,X,AME,AMK,ALMP8,ALMKA) ENDIF GOTO 200 C ETA-ETA' EXCHANGE POTENTIALS: 80 IF(IETETP.EQ.1) THEN PEX = 1.D0 M = 3 N = 4 C PARALLEL: CPANN = 2*F6**2*F9**2 CPALL = 2*F6*F9*F7*F10 CPALS = 0.D0 CPASS = 2*F6*F9*F8*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = 2*F6*F9*F7*F10 CCRLS = 0.D0 CCRSS = 2*F6*F9*F8*F11 CCRDR = CCRSS CALL FOOM(1,X,AME,AMX,ALMP8,ALMP1) ENDIF GOTO 200 C ETA'-KAON EXCHANGE POTENTIALS: 90 IF(IETPKA.EQ.1) THEN PEX = P M = 2 N = 4 C PARALLEL: CPANN = 0.D0 CPALL = 2*F9*F10*F4**2 CPALS = -SR3*F9*(F10+F11)*F4*F5 CPASS = -2*F9*F11*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (F9**2+F10**2)*F4**2 CCRLS = -SR3*(F9**2+F10*F11)*F4*F5 CCRSS = -1*(F9**2+F11**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(1,X,AMX,AMK,ALMP1,ALMKA) ENDIF GOTO 200 C ETA'-ETA' EXCHANGE POTENTIALS: 95 IF(IETAP2.EQ.1) THEN PEX = 1.D0 M = 4 N = 4 C PARALLEL: CPANN = F9**2*F9**2 CPALL = F9**2*F10**2 CPALS = 0.D0 CPASS = F9**2*F11**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = F9**2*F10**2 CCRLS = 0.D0 CCRSS = F9**2*F11**2 CCRDR = CCRSS CALL FOOM(1,X,AMX,AMX,ALMP1,ALMP1) ENDIF GOTO 200 200 IF(INA.EQ.1) THEN C NON-ADIABATIC 1/M-CORRECTIONS: VCLL = VCLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX VCLS = VCLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX VCSS = VCSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX VCDR = VCDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX VSLL = VSLL + FACT*( CPALL+2*CCRLL )*FNONS*PEX VSLS = VSLS + FACT*( CPALS+2*CCRLS )*FNONS*PEX VSSS = VSSS + FACT*( CPASS+2*CCRSS )*FNONS*PEX VSDR = VSDR + FACT*( CPADR+2*CCRDR )*FNONS*PEX VTLL = VTLL + FACT*( CPALL+2*CCRLL )*FNONT*PEX VTLS = VTLS + FACT*( CPALS+2*CCRLS )*FNONT*PEX VTSS = VTSS + FACT*( CPASS+2*CCRSS )*FNONT*PEX VTDR = VTDR + FACT*( CPADR+2*CCRDR )*FNONT*PEX c new may 2006: (was forgotten before !!, but is small) c VOLL = VOLL - FACT* CPALL *FNONO*PEX c VOLS = VOLS - FACT* CPALS *FNONO*PEX c VOSS = VOSS - FACT* CPASS *FNONO*PEX c VODR = VODR - FACT* CPADR *FNONO*PEX VPSPS(1,1,M,N)=VPSPS(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX VPSPS(2,1,M,N)=VPSPS(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX VPSPS(3,1,M,N)=VPSPS(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX VPSPS(4,1,M,N)=VPSPS(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX VPSPS(5,1,M,N)=VPSPS(5,1,M,N)-FACT*(CPADR-2*CCRDR)*FNONC*PEX VPSPS(1,2,M,N)=VPSPS(1,2,M,N)+FACT*(CPANN+2*CCRNN)*FNONS*PEX VPSPS(2,2,M,N)=VPSPS(2,2,M,N)+FACT*(CPALL+2*CCRLL)*FNONS*PEX VPSPS(3,2,M,N)=VPSPS(3,2,M,N)+FACT*(CPALS+2*CCRLS)*FNONS*PEX VPSPS(4,2,M,N)=VPSPS(4,2,M,N)+FACT*(CPASS+2*CCRSS)*FNONS*PEX VPSPS(5,2,M,N)=VPSPS(5,2,M,N)+FACT*(CPADR+2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN C PV-VERTEX 1/M-CORRECTIONS: VCLL = VCLL + APV*FACT*CCRLL *FPVC*PEX VCLS = VCLS + APV*FACT*CCRLS *FPVC*PEX VCSS = VCSS + APV*FACT*CCRSS *FPVC*PEX VCDR = VCDR + APV*FACT*CCRDR *FPVC*PEX VOLL = VOLL + APV*FACT*CCRLL *FPVO*PEX VOLS = VOLS + APV*FACT*CCRLS *FPVO*PEX VOSS = VOSS + APV*FACT*CCRSS *FPVO*PEX VODR = VODR + APV*FACT*CCRDR *FPVO*PEX c new may 2006: (was forgotten before !!) c VALL = VALL + APV*FACT*CCRLL *FPVO*PEX c . *SOALL c VALS = VALS + APV*FACT*CCRLS *FPVO*PEX c . *SOALS c VASS = VASS + APV*FACT*CCRSS *FPVO*PEX c . *SOASS c VADR = VADR + APV*FACT*CCRDR *FPVO*PEX c . *SOASS VPSPS(1,1,M,N)=VPSPS(1,1,M,N)+APV*FACT*CCRNN*FPVC*PEX VPSPS(2,1,M,N)=VPSPS(2,1,M,N)+APV*FACT*CCRLL*FPVC*PEX VPSPS(3,1,M,N)=VPSPS(3,1,M,N)+APV*FACT*CCRLS*FPVC*PEX VPSPS(4,1,M,N)=VPSPS(4,1,M,N)+APV*FACT*CCRSS*FPVC*PEX VPSPS(5,1,M,N)=VPSPS(5,1,M,N)+APV*FACT*CCRDR*FPVC*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VCLL = VCLL + BPV*FACT*CPALL *FOFFC*PEX/3.D0 VCLS = VCLS + BPV*FACT*CPALS *FOFFC*PEX/3.D0 VCSS = VCSS + BPV*FACT*CPASS *FOFFC*PEX/3.D0 VCDR = VCDR + BPV*FACT*CPADR *FOFFC*PEX/3.D0 VOLL = VOLL + BPV*FACT*CPALL *FOFFO*PEX/3.D0 VOLS = VOLS + BPV*FACT*CPALS *FOFFO*PEX/3.D0 VOSS = VOSS + BPV*FACT*CPASS *FOFFO*PEX/3.D0 VODR = VODR + BPV*FACT*CPADR *FOFFO*PEX/3.D0 VPSPS(1,1,M,N)=VPSPS(1,1,M,N)+BPV*FACT*CPANN*FOFFC*PEX/3.D0 VPSPS(2,1,M,N)=VPSPS(2,1,M,N)+BPV*FACT*CPALL*FOFFC*PEX/3.D0 VPSPS(3,1,M,N)=VPSPS(3,1,M,N)+BPV*FACT*CPALS*FOFFC*PEX/3.D0 VPSPS(4,1,M,N)=VPSPS(4,1,M,N)+BPV*FACT*CPASS*FOFFC*PEX/3.D0 VPSPS(5,1,M,N)=VPSPS(5,1,M,N)+BPV*FACT*CPADR*FOFFC*PEX/3.D0 ENDIF c if(icall.eq.0) then c write(6,*) 'OMPSPS: x=',x,' ii=',ii,' ',typ(ii),' apv=',apv c write(6,*) ' cpall=',cpall,' ccrll=',ccrll,' voll=',voll c endif 100 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(1,x,p) c** if(icall.eq.20.and.nschr.eq.1) call wromtm(1,x,p) c if(icall.eq.40.and.nschr.eq.1) call wromtm(1,x,p) 1000 CALL ERRSET(208,256,1,1) ICALL=ICALL+1 RETURN C END OOPSPS ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE OMPIBE(X,INA,IPV,IOFF,APV) C ********************************************************************** C * C * DATE: AUGUST, 1995 C C * THIS ROUTINE: PI-MESON EXCHANGE YN-POTENTIALS C * CALLED BY SUBROUTINE YNPIBE C C * 1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX C * C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS C * FROM: PI-EPSILON, PI-POMERON C C * C ********************************************************************** C C INCLUDED IN ENERGY-DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT,FACT2 C INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/KAPPA/AMSCKH,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK ! BROAD KAPPA 13 AUGUSTUS 2010 COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) c COMMON/ALLAX/FA1,FA9,ALPA COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO COMMON/PSBEOM/ .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4), .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4) DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) C DIMENSION FUN(9),AMSIG(2),ASIG(2) COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC COMMON/TREATD/IPIA2,IPIPOM,IPIKSS C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/ DATA NS/0/,ICALL/0/,ISFAC/1/,FACT/70.D0/ SAVE FACT,AMB,BPV C CALL ERRSET(208,256,-1,1) C pim=pim0 c* pim=500.d0 12 IF(ICALL.EQ.0) THEN BPV = 2*APV-1.D0 FACT = PIM0/2.D0 c FACT = PIM0 c AMB = 2*AMNN*AMH/(AMNN+AMH) amb = ampro FACT = FACT*(PIM0/AMB) IF(NS.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB 52 FORMAT(//,' IN OMPIBE: INA, IPV, IOFF=',3I3,' PIM=',F7.3, . ' AMB=',F10.3,/) IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 DO 750 NCHAN=1,5 DO 750 ITYPV=1,4 DO 750 M=1,4 DO 750 N=1,4 VPSVC(NCHAN,ITYPV,M,N)=0.D0 VPSSC(NCHAN,ITYPV,M,N)=0.D0 750 VPSDF(NCHAN,ITYPV,M,N)=0.D0 c ICALL=1 ENDIF C C 1/M-CORRECTIONS: C C A) PION-VECTOR-MESON POTENTIALS: ****************************** C DO 100 II=1,4 PEX = 1.D0 GOTO(10,20,30,40),II C PI-RHO: 10 IF(IPIRO.EQ.1) THEN M = 1 N = 1 C PARALLEL: CPANN = 2*(3-2*ISFAC)*F1**2*FD1**2 CPALL = 6*F1*FD1*F3*FD3 CPALS = +2*SR3*F1*FD1*(F3*FD2+F2*FD3) CPASS = 2*F1*FD1*(3*F3*FD3+4*F2*FD2) CPADR = 2*F1*FD1*F2*FD2 C CROSSED: CCRNN = 2*(3+2*ISFAC)*F1**2*FD1**2 CCRLL = 6*F1*FD1*F3*FD3 CCRLS = -2*SR3*F1*FD1*(F3*FD2+F2*FD3) CCRSS = -2*F1*FD1*F3*FD3 CCRDR = 2*F1*FD1*(2*F3*FD3+3*F2*FD2) c CALL FOOM(2,X,PIM,AMRO,ALMP8,ALMV8) FNONSH=0.D0 FPVSH =0.D0 FOFFSH=0.D0 FNONTH=0.D0 FPVTH =0.D0 FOFFTH=0.D0 DO 710 KK=1,2 CALL FOOM(2,X,PIM,AMVEC(KK),ALMP8,ALMV8) FNONSH=FNONSH+AVEC(KK)*FNONS FPVSH =FPVSH +AVEC(KK)*FPVS FOFFSH=FOFFSH+AVEC(KK)*FOFFS FNONTH=FNONTH+AVEC(KK)*FNONT FPVTH =FPVTH +AVEC(KK)*FPVT 710 FOFFTH=FOFFTH+AVEC(KK)*FOFFT FNONS = FNONSH FPVS = FPVSH FOFFS = FOFFSH FNONT = FNONTH FPVT = FPVTH FOFFT = FOFFTH ENDIF GOTO 150 C C PION-OMEGA EXCHANGE POTENTIALS: C PI-OMEGA 20 IF(IPIOM.EQ.1) THEN M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*F1**2*FD6**2 CPALL = 0.D0 CPALS = -SR3*F1*FD6*F3*(FD7+FD8) CPASS = -4*F1*FD6*F2*FD8 CPADR = +2*F1*FD6*F2*FD8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*FD6*F3*(FD7+FD8) CCRSS = -4*F1*FD6*F2*FD8 CCRDR = +2*F1*FD6*F2*FD8 CALL FOOM(2,X,PIM,AMOM,ALMP8,ALMV1) ENDIF GOTO 150 C PION-PHI EXCHANGE POTENTIALS: 30 IF(IPIPH.EQ.1) THEN M = 1 N = 4 C PARALLEL: CPANN = 2*ISFAC*F1**2*FD9**2 CPALL = 0.D0 CPALS = -SR3*F1*FD9*F3*(FD10+FD11) CPASS = -4*F1*FD9*F2*FD11 CPADR = +2*F1*FD9*F2*FD11 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*FD9*F3*(FD10+FD11) CCRSS = -4*F1*FD9*F2*FD11 CCRDR = +2*F1*FD9*F2*FD11 CALL FOOM(2,X,PIM,AMFI,ALMP8,ALMV1) ENDIF GOTO 150 C PION-KSTAR EXCHANGE POTENTIALS: 40 IF(IPIKS.EQ.1) THEN M = 1 N = 2 PEX = P C PARALLEL: CPANN = 0.D0 CPALL = 6*F1*FD4*F3*FD5 CPALS = -SR3*F1*F3*(FD4**2-FD5**2) . +2*SR3*F1*F2*FD4*FD5 CPASS = F1*FD5*(6*F3*FD4+4*F2*FD5) CPADR = +4*F1*F2*FD5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(F1*F1*FD4**2+F3*F3*FD5**2) CCRLS = SR3*(F1**2-F3**2)*FD4*FD5 . +2*SR3*F2*F3*FD5**2 CCRSS = 5*F1**2*FD5**2+F3*F3*FD4**2 . +4*F2*F3*FD4*FD5 CCRDR = 2*F1**2*FD5**2+F3**2*FD4**2 . +3*F2**2*FD5**2-2*F2*F3*FD4*FD5 CALL FOOM(2,X,PIM,AMKS,ALMP8,ALMKS) ENDIF GOTO 150 150 IF(INA.EQ.1) THEN VSLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSVC(1,2,M,N)=VPSVC(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL + APV*FACT*( +1*CCRLL )*FPVS*PEX VSLS = VSLS + APV*FACT*( +1*CCRLS )*FPVS*PEX VSSS = VSSS + APV*FACT*( +1*CCRSS )*FPVS*PEX VSDR = VSDR + APV*FACT*( +1*CCRDR )*FPVS*PEX VTLL = VTLL + APV*FACT*( +1*CCRLL )*FPVT*PEX VTLS = VTLS + APV*FACT*( +1*CCRLS )*FPVT*PEX VTSS = VTSS + APV*FACT*( +1*CCRSS )*FPVT*PEX VTDR = VTDR + APV*FACT*( +1*CCRDR )*FPVT*PEX VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF c if(icall.eq.0.and.ii.eq.1) then c write(*,*) 'in ompibe, pi-ro: m,n=',m,n c write(*,*) 'cpann,ccrnn=',cpann,ccrnn c write(*,*) 'cpall,ccrll=',cpall,ccrll c write(*,*) 'vpsvc(1,2,m,n)=',vpsvc(1,2,m,n) c write(*,*) 'vpsvc(2,2,m,n)=',vpsvc(2,2,m,n) c write(*,*) 'vpsvc(3,2,m,n)=',vpsvc(3,2,m,n) c write(*,*) 'vpsvc(4,2,m,n)=',vpsvc(4,2,m,n) c write(*,*) 'vpsvc(5,2,m,n)=',vpsvc(5,2,m,n) c endif 100 CONTINUE C END VECTOR MESONS C C B) PION-SCALAR MESONS: ***************************************** C DO 200 II=1,6 ! BROAD KAPPA 13 AUGUSTUS 2010 PEX = 1.D0 GOTO(11,21,21,41,51,51),II ! BROAD KAPPA 13 AUGUSTUS 2010 C PION-DELTA EXCHANGE POTENTIALS: 11 IF(IPIDE.EQ.1) THEN M = 1 N = 1 C PARALLEL: CPANN = 2*(3-2*ISFAC)*F1**2*GS1**2 CPALL = 6*F1*GS1*F3*GS3 CPALS = +2*SR3*F1*GS1*(F3*GS2+F2*GS3) CPASS = 2*F1*GS1*(3*F3*GS3+4*F2*GS2) CPADR = 2*F1*GS1*F2*GS2 C CROSSED: CCRNN = 2*(3+2*ISFAC)*F1**2*GS1**2 CCRLL = 6*F1*GS1*F3*GS3 CCRLS = -2*SR3*F1*GS1*(F3*GS2+F2*GS3) CCRSS = -2*F1*GS1*F3*GS3 CCRDR = 2*F1*GS1*(2*F3*GS3+3*F2*GS2) CALL FOOM(3,X,PIM,AMD,ALMP8,ALMS8) ENDIF GOTO 250 C PION-EPSILON EXCHANGE POTENTIALS: 21 IF(IPIEP.EQ.1) THEN M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*F1**2*GS6**2 CPALL = 0.D0 CPALS = -SR3*F1*GS6*F3*(GS8+GS7) CPASS = -4*F1*GS6*F2*GS8 CPADR = +2*F1*GS6*F2*GS8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*GS6*F3*(GS8+GS7) CCRSS = -4*F1*GS6*F2*GS8 CCRDR = +2*F1*GS6*F2*GS8 IF(II.EQ.2) THEN PEX = ASI CALL FOOM(3,X,PIM,AM1SI,ALMP8,ALMS1) ELSE PEX = BSI CALL FOOM(3,X,PIM,AM2SI,ALMP8,ALMS1) ENDIF ENDIF GOTO 250 C PION-SSTAR EXCHANGE POTENTIALS: 41 IF(IPIST.EQ.1) THEN PEX = 1.D0 M = 1 N = 4 C PARALLEL: CPANN = 2*ISFAC*F1**2*GS9**2 CPALL = 0.D0 CPALS = -SR3*F1*GS9*F3*(GS11+GS10) CPASS = -4*F1*GS9*F2*GS11 CPADR = +2*F1*GS9*F2*GS11 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*GS9*F3*(GS11+GS10) CCRSS = -4*F1*GS9*F2*GS11 CCRDR = +2*F1*GS9*F2*GS11 CALL FOOM(3,X,PIM,AMSST,ALMP8,ALMS1) ENDIF GOTO 250 C PION-KAPPA EXCHANGE POTENTIALS: 51 IF(IPIKSC.EQ.1) THEN c PEX = P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*F1*GS4*F3*GS5 CPALS = -SR3*F1*F3*(GS4**2-GS5**2) . +2*SR3*F1*F2*GS4*GS5 CPASS = F1*GS5*(6*F3*GS4+4*F2*GS5) CPADR = +4*F1*F2*GS5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(F1*F1*GS4**2+F3*F3*GS5**2) CCRLS = SR3*(F1**2-F3**2)*GS4*GS5 . +2*SR3*F2*F3*GS5**2 CCRSS = 5*F1**2*GS5**2+F3*F3*GS4**2 . +4*F2*F3*GS4*GS5 CCRDR = 2*F1**2*GS5**2+F3**2*GS4**2 . +3*F2**2*GS5**2-2*F2*F3*GS4*GS5 C IF(II.EQ.5) THEN PEX = P*ASCK CALL FOOM(3,X,PIM,AM1SCK,ALMP8,ALMS8) ELSE PEX = P*BSCK CALL FOOM(3,X,PIM,AM2SCK,ALMP8,ALMS8) ENDIF C c CALL FOOM(3,X,PIM,AMSCK,ALMP8,ALMS8) ENDIF GOTO 250 250 IF(INA.EQ.1) THEN VSLL = VSLL + FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS + FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS + FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR + FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL + FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS + FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS + FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR + FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSSC(2,2,M,N)=VPSSC(2,2,M,N)+FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSSC(3,2,M,N)=VPSSC(3,2,M,N)+FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSSC(4,2,M,N)=VPSSC(4,2,M,N)+FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSSC(5,2,M,N)=VPSSC(5,2,M,N)+FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL - APV*FACT*( +1*CCRLL )*FPVS*PEX VSLS = VSLS - APV*FACT*( +1*CCRLS )*FPVS*PEX VSSS = VSSS - APV*FACT*( +1*CCRSS )*FPVS*PEX VSDR = VSDR - APV*FACT*( +1*CCRDR )*FPVS*PEX VTLL = VTLL - APV*FACT*( +1*CCRLL )*FPVT*PEX VTLS = VTLS - APV*FACT*( +1*CCRLS )*FPVT*PEX VTSS = VTSS - APV*FACT*( +1*CCRSS )*FPVT*PEX VTDR = VTDR - APV*FACT*( +1*CCRDR )*FPVT*PEX VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-APV*FACT*CCRNN*FPVS*PEX VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-APV*FACT*CCRLL*FPVS*PEX VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-APV*FACT*CCRLS*FPVS*PEX VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-APV*FACT*CCRSS*FPVS*PEX VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL - BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS - BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS - BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR - BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL - BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS - BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS - BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR - BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF 200 CONTINUE C END SCALAR MESONS C C D) BEGIN DIFFRACTIVE CONTRIBUTIONS ******************* C DO 300 II=1,3 PEX = 1.D0 GOTO(31,32,33),II C PION-A2 EXCHANGE POTENTIALS: 31 IF(IPIA2.EQ.1) THEN PEX = 1.D0 M = 1 N = 1 C PARALLEL: CPANN = 2*(3-2*ISFAC)*F1**2*GD1**2 CPALL = 6*F1*GD1*F3*GD3 CPALS = +2*SR3*F1*GD1*(F3*GD2+F2*GD3) CPASS = 2*F1*GD1*(3*F3*GD3+4*F2*GD2) CPADR = 2*F1*GD1*F2*GD2 C CROSSED: CCRNN = 2*(3+2*ISFAC)*F1**2*GD1**2 CCRLL = 6*F1*GD1*F3*GD3 CCRLS = -2*SR3*F1*GD1*(F3*GD2+F2*GD3) CCRSS = -2*F1*GD1*F3*GD3 CCRDR = 2*F1*GD1*(2*F3*GD3+3*F2*GD2) CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 C PION-POMERON: 32 IF(IPIPOM.EQ.1) THEN PEX = 1.D0 M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*F1**2*GD6**2 CPALL = 0.D0 CPALS = -SR3*F1*GD6*F3*(GD8+GD7) CPASS = -4*F1*GD6*F2*GD8 CPADR = +2*F1*GD6*F2*GD8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = -SR3*F1*GD6*F3*(GD8+GD7) CCRSS = -4*F1*GD6*F2*GD8 CCRDR = +2*F1*GD6*F2*GD8 CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 C PION-K** EXCHANGE POTENTIALS: 33 IF(IPIKSS.EQ.1) THEN PEX = P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*F1*GD4*F3*GD5 CPALS = -SR3*F1*F3*(GD4**2-GD5**2) . +2*SR3*F1*F2*GD4*GD5 CPASS = F1*GD5*(6*F3*GD4+4*F2*GD5) CPADR = +4*F1*F2*GD5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(F1*F1*GD4**2+F3*F3*GD5**2) CCRLS = SR3*(F1**2-F3**2)*GD4*GD5 . +2*SR3*F2*F3*GD5**2 CCRSS = 5*F1**2*GD5**2+F3*F3*GD4**2 . +4*F2*F3*GD4*GD5 CCRDR = 2*F1**2*GD5**2+F3**2*GD4**2 . +3*F2**2*GD5**2-2*F2*F3*GD4*GD5 CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 350 IF(INA.EQ.1) THEN VSLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSDF(2,2,M,N)=VPSDF(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSDF(3,2,M,N)=VPSDF(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSDF(4,2,M,N)=VPSDF(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSDF(5,2,M,N)=VPSDf(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL + APV*FACT*( +1*CCRLL )*FPVS*PEX VSLS = VSLS + APV*FACT*( +1*CCRLS )*FPVS*PEX VSSS = VSSS + APV*FACT*( +1*CCRSS )*FPVS*PEX VSDR = VSDR + APV*FACT*( +1*CCRDR )*FPVS*PEX VTLL = VTLL + APV*FACT*( +1*CCRLL )*FPVT*PEX VTLS = VTLS + APV*FACT*( +1*CCRLS )*FPVT*PEX VTSS = VTSS + APV*FACT*( +1*CCRSS )*FPVT*PEX VTDR = VTDR + APV*FACT*( +1*CCRDR )*FPVT*PEX VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF 300 CONTINUE C END DIFFRACTIVE CONTRIBUTIONS ICALL = 1 C 1 CONTINUE 1000 CALL ERRSET(208,256,1,1) RETURN C END OMPIBE ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE OMPSBE(X,INA,IPV,IOFF,APV) C ********************************************************************** C * C * DATE: AUGUST 1995, COMPLETED DECEMBER 96 C C THIS ROUTINE: KAON-MESON AND ETA(P)-MESON YN-POTENTIALS C +++++++ AND THE DOUBLE SCALAR/DIFFRACTIVE YN-POTENTIALS C * (MESON= VECTOR, SCALAR, DIFFR.) C * CALLED BY SUBROUTINE YNPSBE C * C * 1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROMTHE PV-VERTEX C * C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS C * FROM: PI-EPSILON, PI-POMERON C C ********************************************************************** C C INCLUDED IN ENERGY-DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT,FACT2 C INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKAP COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD, .ALPAX COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/KAPPA/AMSCKH,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK ! BROAD KAPPA 13 AUGUSTUS 2010 COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) c COMMON/ALLAX/FA1,FA9,ALPAX COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13, .XGD12,XGD13 COMMON/PSBEOM/ .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4), .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4) C DIMENSION FUN(9) COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) DATA IKARO/1/,IKAOM/1/,IKAPH/1/,IKAKS/1/,IKADE/1/,IKAEP/1/, . IKAST/1/,IKAKSC/1/,IKAA2/1/,IKAPOM/1/,IKAKSS/1/, . IETKSC/1/,IETPKP/1/,IETAKS/1/,IETPKS/1/,IEPEP/0/, . IETRHO/1/,IETOME/1/,IETPHI/1/,IETPRH/1/,IETPOM/1/,IETPPH/1/, . IETDE/1/,IETEP/1/,IETST/1/,IETPDE/1/,IETPEP/1/,IETPST/1/, . IETA2/1/,IETPO/1/,IETKD/1/,IETPA2/1/,IETPPO/1/,IETPKD/1/ C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/ DATA ICALL/0/,NSCHR/0/,ISFAC/1/,FACT/70.D0/ SAVE AMN,FACT,BPV C CALL ERRSET(208,256,-1,1) C pim=pim0 c* pim=500.d0 IF(ICALL.EQ.0) THEN BPV = 2*APV-1.D0 AMN = AMPRO FACT = PIM0/2.D0 c FACT = PIM0 AMB = 2*AMNN*AMH/(AMNN+AMH) amb=ampro FACT = FACT*(PIM0/AMB) IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 ISFLL = (1+ISFAC)/2 ISFLS = (3-ISFAC) ISFSS = (9+ISFAC)/2 IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB 52 FORMAT(//,' IN OMPSBE: INA, IPV, IOFF=',3I3,' PIM=',F7.3, . ' AMB=',F10.3,/) c ICALL=1 ENDIF C XI-COUPLINGS: XF12 = F1*(4*ALP-1.D0)/SR3 XF13 = -F1 XFD12 = FD1*(4*ALVD-1.D0)/SR3 XFD13 = -FD1 XFV12 = FV1*(4*ALVV-1.D0)/SR3 XFV13 = -FV1 XGS12 = GS1*(4*ALS-1.D0)/SR3 XGS13 = -GS1 XGD12 = GD1*(4*ALD-1.D0)/SR3 XGD13 = -GD1 C C 1/M-CORRECTIONS: C C A) PSEUDO-SCALAR-VECTOR-MESON POTENTIALS: ******************** C DO 100 II=1,12 PEX = 1.D0 GOTO(101,102,103,104,105,106,107,108,109,110,111,112), II * KA-RHO: 101 IF(IKARO.EQ.1) THEN PEX = P M = 2 N = 1 C PARALLEL: CPANN = 0.D0 CPALL = 6*FD1*FD3*F4*F5 CPALS = +2*SR3*FD1*FD2*F4*F5-SR3*FD1*FD3*(F4**2-F5**2) CPASS = 6*FD1*FD3*F4*F5+4*FD1*FD2*F5**2 CPADR = 4*FD1*FD2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(FD1**2*F4**2+FD3**2*F5**2) CCRLS = SR3*(FD1**2*F4*F5-FD3**2*F4*F5+2*FD2*FD3*F5**2) CCRSS = 5*FD1**2*F5**2+FD3**2*F4**2+4*FD2*FD3*F4*F5 CCRDR = 2*FD1**2*F5**2+FD3**2*F4**2+ . 3*FD2**2*F5**2-2*FD2*FD3*F4*F5 CALL FOOM(2,X,AMK,AMRO,ALMKA,ALMV8) ENDIF GOTO 150 C C KAON-OMEGA EXCHANGE POTENTIALS: 102 IF(IKAOM.EQ.1) THEN PEX = P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*FD6*FD7*F4**2 CPALS = -SR3*FD6*(FD7+FD8)*F4*F5 CPASS = -2*FD6*FD8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FD6**2+FD7**2)*F4**2 CCRLS = -SR3*(FD6**2+FD7*FD8)*F4*F5 CCRSS = -(FD6**2+FD8**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(2,X,AMK,AMOM,ALMKA,ALMV1) ENDIF GOTO 150 C KAON-PHI EXCHANGE POTENTIALS: 103 IF(IKAPH.EQ.1) THEN PEX = P M = 2 N = 4 C PARALLEL: CPANN = 0.D0 CPALL = 2*FD9*FD10*F4**2 CPALS = -SR3*FD9*(FD10+FD11)*F4*F5 CPASS = -2*FD9*FD11*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (FD9**2+FD10**2)*F4**2 CCRLS = -SR3*(FD9**2+FD10*FD11)*F4*F5 CCRSS = -(FD9**2+FD11**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(2,X,AMK,AMFI,ALMKA,ALMV8) ENDIF GOTO 150 C KAON-KSTAR EXCHANGE POTENTIALS: 104 IF(IKAKS.EQ.1) THEN PEX = 1.D0 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*(FD4**2*F4**2+3*FD4*FD5*F4*F5) CPALS = SR3*(FD5**2*F4*F5+FD4*FD5*F5**2 . -FD4**2*F4*F5-FD4*FD5*F4**2) CPASS = 2*(3*FD4*FD5*F4*F5+FD5**2*F5**2) CPADR = 8*FD5**2*F5**2 C CROSSED: CCRNN = 2*(ISFLL*F4**2*FD4**2+ISFLS*F4*F5*FD4*FD5+ . ISFSS*F5**2*FD5**2) CCRLL = 2*(FD4*XFD12*F4*XF12+3*FD5*XFD12*F5*XF12) CCRLS = SR3*(FD4*F4-FD5*F5)*(XFD13*XF12+XFD12*XF13) CCRSS = -2*FD4*XFD13*F4*XF13+10*FD5*XFD13*F5*XF13 CCRDR = 4*(FD5*F5*XFD13*XF13+FD4*F4*XFD13*XF13) CALL FOOM(2,X,AMK,AMKS,ALMKA,ALMKS) ENDIF GOTO 150 C ETA-RHO EXCHANGE POTENTIALS: 105 IF(IETRHO.EQ.1) THEN PEX = 1.D0 M = 3 N = 1 C PARALLEL: CPANN = 2*ISFAC*FD1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*FD1*FD3*F6*(F7+F8) CPASS = -4*FD1*FD2*F6*F8 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AME,AMRO,ALMP8,ALMV8) ENDIF GOTO 150 C ETA-KSTAR EXCHANGE POTENTIALS: 106 IF(IETAKS.EQ.1) THEN PEX = P M = 3 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*FD4**2*F6*F7 CPALS = -SR3*FD4*FD5*F6*(F7+F8) CPASS = -2*FD5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FD4**2*(F6**2+F7**2) CCRLS = -SR3*FD4*FD5*(F6**2+F7*F8) CCRSS = -FD5**2*(F6**2+F8**2) CCRDR = -2*CCRSS CALL FOOM(2,X,AME,AMKS,ALMP8,ALMKS) ENDIF GOTO 150 C ETA-OMEGA EXCHANGE POTENTIALS: 107 IF(IETOME.EQ.1) THEN PEX = 1.D0 M = 3 N = 3 C PARALLEL: CPANN = 2*FD6*FD6*F6*F6 CPALL = 2*FD6*FD7*F6*F7 CPALS = 0.D0 CPASS = 2*FD6*FD8*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AME,AMOM,ALMP8,ALMV1) ENDIF GOTO 150 C ETA-PHI EXCHANGE POTENTIALS: 108 IF(IETPHI.EQ.1) THEN PEX = 1.D0 M = 3 N = 4 C PARALLEL: CPANN = 2*FD9*FD9*F6*F6 CPALL = 2*FD9*FD10*F6*F7 CPALS = 0.D0 CPASS = 2*FD9*FD11*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AME,AMFI,ALMP8,ALMV8) ENDIF GOTO 150 C ETAP-RHO EXCHANGE POTENTIALS: 109 IF(IETPRH.EQ.1) THEN PEX = 1.D0 M = 4 N = 1 C PARALLEL: CPANN = 2*ISFAC*FD1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*FD1*FD3*F9*(F10+F11) CPASS = -4*FD1*FD2*F9*F11 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AMX,AMRO,ALMP1,ALMV8) ENDIF GOTO 150 C ETAP-KSTAR EXCHANGE POTENTIALS: 110 IF(IETPKS.EQ.1) THEN PEX = P M = 4 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*FD4**2*F9*F10 CPALS = -SR3*FD4*FD5*F9*(F10+F11) CPASS = -2*FD5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = FD4**2*(F9**2+F10**2) CCRLS = -SR3*FD4*FD5*(F9**2+F10*F11) CCRSS = -FD5**2*(F9**2+F11**2) CCRDR = -2*CCRSS CALL FOOM(2,X,AMX,AMKS,ALMP1,ALMKS) ENDIF GOTO 150 C ETAP-OMEGA EXCHANGE POTENTIALS: 111 IF(IETPOM.EQ.1) THEN PEX = 1.D0 M = 4 N = 3 C PARALLEL: CPANN = 2*FD6*FD6*F9*F9 CPALL = 2*FD6*FD7*F9*F10 CPALS = 0.D0 CPASS = 2*FD6*FD8*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AMX,AMOM,ALMP1,ALMV1) ENDIF GOTO 150 C ETAP-PHI EXCHANGE POTENTIALS: 112 IF(IETPPH.EQ.1) THEN PEX = 1.D0 M = 4 N = 4 C PARALLEL: CPANN = 2*FD9*FD9*F9*F9 CPALL = 2*FD9*FD10*F9*F10 CPALS = 0.D0 CPASS = 2*FD9*FD11*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(2,X,AMX,AMFI,ALMP1,ALMV8) ENDIF GOTO 150 150 IF(INA.EQ.1) THEN VSLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSVC(1,2,M,N)=VPSVC(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL + APV*FACT*( +1*CCRLL )*FPVS *PEX VSLS = VSLS + APV*FACT*( +1*CCRLS )*FPVS *PEX VSSS = VSSS + APV*FACT*( +1*CCRSS )*FPVS *PEX VSDR = VSDR + APV*FACT*( +1*CCRDR )*FPVS *PEX VTLL = VTLL + APV*FACT*( +1*CCRLL )*FPVT *PEX VTLS = VTLS + APV*FACT*( +1*CCRLS )*FPVT *PEX VTSS = VTSS + APV*FACT*( +1*CCRSS )*FPVT *PEX VTDR = VTDR + APV*FACT*( +1*CCRDR )*FPVT *PEX VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF 100 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(2,x,p) C END VECTOR MESONS C C B) PSEUDO-SCALAR-SCALAR MESONS: ****************************** C DO 200 II=1,3 DO 200 JJ=1,6 ! BROAD KAPPA 13 AUGUSTUS 2010 KK = 5*(II-1)+JJ GOTO(11,12,12,13,14,14,15,16,16,17,18,18,19,20,20,21,22,22),KK C KAON-DELTA EXCHANGE POTENTIALS: 11 IF(IKADE.EQ.1) THEN PEX = P M = 2 N = 1 C PARALLEL: CPANN = 0.D0 CPALL = 6*GS1*GS3*F4*F5 CPALS = +2*SR3*GS1*GS2*F4*F5-SR3*GS1*GS3*(F4**2-F5**2) CPASS = 6*GS1*GS3*F4*F5+4*GS1*GS2*F5**2 CPADR = 4*GS1*GS2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GS1**2*F4**2+GS3**2*F5**2) CCRLS = SR3*(GS1**2*F4*F5-GS3**2*F4*F5+2*GS2*GS3*F5**2) CCRSS = 5*GS1**2*F5**2+GS3**2*F4**2+4*GS2*GS3*F4*F5 CCRDR = 2*GS1**2*F5**2+GS3**2*F4**2+ . 3*GS2**2*F5**2-2*GS2*GS3*F4*F5 CALL FOOM(3,X,AMK,AMD,ALMKA,ALMS8) ENDIF GOTO 250 C KAON-EPSILON EXCHANGE POTENTIALS: 12 IF(IKAEP.EQ.1) THEN PEX = P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*GS6*GS7*F4**2 CPALS = -SR3*GS6*(GS7+GS8)*F4*F5 CPASS = -2*GS6*GS8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (GS6**2+GS7**2)*F4**2 CCRLS = -SR3*(GS6**2+GS7*GS8)*F4*F5 CCRSS = -(GS6**2+GS8**2)*F5**2 CCRDR = -2*CCRSS IF(JJ.EQ.2) THEN PEX = ASIG(1)*P CALL FOOM(3,X,AMK,AMSIG(1),ALMKA,ALMS1) ELSE PEX = ASIG(2)*P CALL FOOM(3,X,AMK,AMSIG(2),ALMKA,ALMS1) ENDIF ENDIF GOTO 250 C KAON-SSTAR EXCHANGE POTENTIALS: 13 IF(IKAST.EQ.1) THEN PEX = P M = 2 N = 4 C PARALLEL: CPANN = 0.D0 CPALL = 2*GS9*GS10*F4**2 CPALS = -SR3*GS9*(GS10+GS11)*F4*F5 CPASS = -2*GS9*GS11*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (GS9**2+GS10**2)*F4**2 CCRLS = -SR3*(GS9**2+GS10*GS11)*F4*F5 CCRSS = -(GS9**2+GS11**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(3,X,AMK,AMSST,ALMKA,ALMS1) ENDIF GOTO 250 C KAON-KAPPA EXCHANGE POTENTIALS: 14 IF(IKAKSC.EQ.1) THEN C PEX = 1.D0 ! BROAD KAPPA 13 AUGUSTUS 2010 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*(GS4**2*F4**2+3*GS4*GS5*F4*F5) CPALS = SR3*(GS5**2*F4*F5+GS4*GS5*F5**2 . -GS4**2*F4*F5-GS4*GS5*F4**2) CPASS = 2*(3*GS4*GS5*F4*F5+GS5**2*F5**2) CPADR = 8*GS5**2*F5**2 C CROSSED: CCRNN = 2*(ISFLL*F4**2*GS4**2+ISFLS*F4*F5*GS4*GS5+ . ISFSS*F5**2*GS5**2) CCRLL = 2*(GS4*XGS12*F4*XF12+3*GS5*XGS12*F5*XF12) CCRLS = SR3*(GS4*F4-GS5*F5)*(XGS13*XF12+XGS12*XF13) CCRSS = -2*GS4*XGS13*F4*XF13+10*GS5*XGS13*F5*XF13 CCRDR = 4*(GS5*F5*XGS13*XF13+GS4*F4*XGS13*XF13) C IF(JJ.EQ.5) THEN ! BROAD KAPPA 13 AUGUSTUS 2010 PEX = ASCK CALL FOOM(3,X,AMK,AM1SCK,ALMKA,ALMS8) ELSE PEX = BSCK CALL FOOM(3,X,AMK,AM2SCK,ALMKA,ALMS8) ENDIF ! BROAD KAPPA 13 AUGUSTUS 2010 C CALL FOOM(3,X,AMK,AMSCK,ALMKA,ALMS8) ENDIF GOTO 250 C ETA-DELTA EXCHANGE POTENTIALS: 15 IF(IETDE.EQ.1) THEN PEX = 1.D0 M = 3 N = 1 C PARALLEL: CPANN = 2*ISFAC*GS1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*GS1*GS3*F6*(F7+F8) CPASS = -4*GS1*GS2*F6*F8 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(3,X,AME,AMD,ALMP8,ALMS8) ENDIF GOTO 250 C ETA-EPSILON EXCHANGE POTENTIALS: 16 IF(IETEP.EQ.1) THEN PEX = 1.D0 M = 3 N = 3 C PARALLEL: CPANN = 2*GS6**2*F6**2 CPALL = 2*GS6*GS7*F6*F7 CPALS = 0.D0 CPASS = 2*GS6*GS8*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR IF(JJ.EQ.2) THEN PEX = ASIG(1) CALL FOOM(3,X,AME,AMSIG(1),ALMP8,ALMS1) ELSE PEX = ASIG(2) CALL FOOM(3,X,AME,AMSIG(2),ALMP8,ALMS1) ENDIF ENDIF GOTO 250 C ETA-SSTAR EXCHANGE POTENTIALS: 17 IF(IETST.EQ.1) THEN PEX = 1.D0 M = 3 N = 4 C PARALLEL: CPANN = 2*GS9**2*F6**2 CPALL = 2*GS9*GS10*F6*F7 CPALS = 0.D0 CPASS = 2*GS9*GS11*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR CALL FOOM(3,X,AME,AMSST,ALMP8,ALMS8) ENDIF GOTO 250 C ETA-KAPPA EXCHANGE POTENTIALS: 18 IF(IETKSC.EQ.1) THEN c PEX = P ! BROAD KAPPA 13 AUGUSTUS 2010 M = 3 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GS4**2*F6*F7 CPALS = -SR3*GS4*GS5*F6*(F7+F8) CPASS = -2*GS5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GS4**2*(F6**2+F7**2) CCRLS = -SR3*GS4*GS5*(F6**2+F7*F8) CCRSS = -GS5**2*(F6**2+F8**2) CCRDR = -2*CCRSS C IF(JJ.EQ.5) THEN ! BROAD KAPPA 13 AUGUSTUS 2010 PEX = ASCK*P CALL FOOM(3,X,AME,AM1SCK,ALMP8,ALMS8) ELSE PEX = BSCK*P CALL FOOM(3,X,AME,AM2SCK,ALMP8,ALMS8) ENDIF ! BROAD KAPPA 13 AUGUSTUS 2010 c CALL FOOM(3,X,AME,AMSCK,ALMP1,ALMS8) ENDIF GOTO 250 C ETAP-DELTA EXCHANGE POTENTIALS: 19 IF(IETPDE.EQ.1) THEN PEX = 1.D0 M = 4 N = 1 C PARALLEL: CPANN = 2*ISFAC*GS1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*GS1*GS3*F9*(F10+F11) CPASS = -4*GS1*GS2*F9*F11 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(3,X,AMX,AMD,ALMP1,ALMS8) ENDIF GOTO 250 C ETAP-EPSILON EXCHANGE POTENTIALS: 20 IF(IETPEP.EQ.1) THEN PEX = 1.D0 M = 4 N = 3 C PARALLEL: CPANN = 2*GS6*GS6*F9*F9 CPALL = 2*GS6*GS7*F9*F10 CPALS = 0.D0 CPASS = 2*GS6*GS8*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR IF(JJ.EQ.2) THEN PEX = ASIG(1) CALL FOOM(3,X,AMX,AMSIG(1),ALMP1,ALMS1) ELSE PEX = ASIG(2) CALL FOOM(3,X,AMX,AMSIG(2),ALMP1,ALMS1) ENDIF ENDIF GOTO 250 C ETAP-SSTAR EXCHANGE POTENTIALS: 21 IF(IETPST.EQ.1) THEN PEX = 1.D0 M = 4 N = 4 C PARALLEL: CPANN = 2*GS9*GS9*F9*F9 CPALL = 2*GS9*GS10*F9*F10 CPALS = 0.D0 CPASS = 2*GS9*GS11*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR CALL FOOM(3,X,AMX,AMSST,ALMP1,ALMS8) ENDIF GOTO 250 C ETAP-KAPPA EXCHANGE POTENTIALS: 22 IF(IETPKP.EQ.1) THEN c PEX = P ! BROAD KAPPA 13 AUGUSTUS 2010 M = 4 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GS4**2*F9*F10 CPALS = -SR3*GS4*GS5*F9*(F10+F11) CPASS = -2*GS5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GS4**2*(F9**2+F10**2) CCRLS = -SR3*GS4*GS5*(F9**2+F10*F11) CCRSS = -GS5**2*(F9**2+F11**2) CCRDR = -2*CCRSS C IF(JJ.EQ.5) THEN ! BROAD KAPPA 13 AUGUSTUS 2010 PEX = ASCK*P CALL FOOM(3,X,AMX,AM1SCK,ALMP1,ALMS8) ELSE PEX = BSCK*P CALL FOOM(3,X,AMX,AM2SCK,ALMP1,ALMS8) ENDIF ! BROAD KAPPA 13 AUGUSTUS 2010 c CALL FOOM(3,X,AMX,AMSCK,ALMP1,ALMS8) ENDIF GOTO 250 250 IF(INA.EQ.1) THEN VSLL = VSLL + FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS + FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS + FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR + FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL + FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS + FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS + FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR + FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSSC(2,2,M,N)=VPSSC(2,2,M,N)+FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSSC(3,2,M,N)=VPSSC(3,2,M,N)+FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSSC(4,2,M,N)=VPSSC(4,2,M,N)+FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSSC(5,2,M,N)=VPSSC(5,2,M,N)+FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL - APV*FACT*( +1*CCRLL )*FPVS *PEX VSLS = VSLS - APV*FACT*( +1*CCRLS )*FPVS *PEX VSSS = VSSS - APV*FACT*( +1*CCRSS )*FPVS *PEX VSDR = VSDR - APV*FACT*( +1*CCRDR )*FPVS *PEX VTLL = VTLL - APV*FACT*( +1*CCRLL )*FPVT *PEX VTLS = VTLS - APV*FACT*( +1*CCRLS )*FPVT *PEX VTSS = VTSS - APV*FACT*( +1*CCRSS )*FPVT *PEX VTDR = VTDR - APV*FACT*( +1*CCRDR )*FPVT *PEX VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-APV*FACT*CCRNN*FPVS*PEX VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-APV*FACT*CCRLL*FPVS*PEX VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-APV*FACT*CCRLS*FPVS*PEX VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-APV*FACT*CCRSS*FPVS*PEX VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL - BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS - BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS - BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR - BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL - BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS - BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS - BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR - BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF 200 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(3,x,p) C END SCALAR MESONS C C D) BEGIN DIFFRACTIVE CONTRIBUTIONS ******************* C DO 300 II=1,9 GOTO(31,32,33,34,35,36,37,38,39), II C KAON-A2 EXCHANGE POTENTIALS: 31 IF(IKAA2.EQ.1) THEN PEX = P M = 2 N = 1 C PARALLEL: CPANN = 0.D0 CPALL = 6*GD1*GD3*F4*F5 CPALS = +2*SR3*GD1*GD2*F4*F5-SR3*GD1*GD3*(F4**2-F5**2) CPASS = 6*GD1*GD3*F4*F5+4*GD1*GD2*F5**2 CPADR = 4*GD1*GD2*F5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GD1**2*F4**2+GD3**2*F5**2) CCRLS = SR3*(GD1**2*F4*F5-GD3**2*F4*F5+2*GD2*GD3*F5**2) CCRSS = 5*GD1**2*F5**2+GD3**2*F4**2+4*GD2*GD3*F4*F5 CCRDR = 2*GD1**2*F5**2+GD3**2*F4**2+ . 3*GD2**2*F5**2-2*GD2*GD3*F4*F5 CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM) ENDIF GOTO 350 C KAON-POMERON: 32 IF(IKAPOM.EQ.1) THEN PEX = P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD6*GD7*F4**2 CPALS = -SR3*GD6*(GD7+GD8)*F4*F5 CPASS = -2*GD6*GD8*F5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = (GD6**2+GD7**2)*F4**2 CCRLS = -SR3*(GD6**2+GD7*GD8)*F4*F5 CCRSS = -(GD6**2+GD8**2)*F5**2 CCRDR = -2*CCRSS CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM) ENDIF GOTO 350 C KAON-K** EXCHANGE POTENTIALS: 33 IF(IKAKSS.EQ.1) THEN PEX = 1.D0 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*(GD4**2*F4**2+3*GD4*GD5*F4*F5) CPALS = SR3*(GD5**2*F4*F5+GD4*GD5*F5**2 . -GD4**2*F4*F5-GD4*GD5*F4**2) CPASS = 2*(3*GD4*GD5*F4*F5+GD5**2*F5**2) CPADR = 8*GD5**2*F5**2 C CROSSED: CCRNN = 2*(ISFLL*F4**2*GD4**2+ISFLS*F4*F5*GD4*GD5+ . ISFSS*F5**2*GD5**2) CCRLL = 2*(GD4*XGD12*F4*XF12+3*GD5*XGD12*F5*XF12) CCRLS = SR3*(GD4*F4-GD5*F5)*(XGD13*XF12+XGD12*XF13) CCRSS = -2*GD4*XGD13*F4*XF13+10*GD5*XGD13*F5*XF13 CCRDR = 4*(GD5*F5*XGD13*XF13+GD4*F4*XGD13*XF13) CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM) ENDIF GOTO 350 C ETA-A2 EXCHANGE POTENTIALS: 34 IF(IETA2.EQ.1) THEN PEX = 1.D0 M = 3 N = 1 C PARALLEL: CPANN = 2*ISFAC*GD1**2*F6**2 CPALL = 0.D0 CPALS = -SR3*GD1*GD3*F6*(F7+F8) CPASS = -4*GD1*GD2*F6*F8 CPADR = +2*GD1*GD2*F6*F8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 C ETA-POMERON EXCHANGE POTENTIALS: 35 IF(IETPO.EQ.1) THEN PEX = 1.D0 M = 3 N = 3 C PARALLEL: CPANN = 2*GD6**2*F6**2 CPALL = 2*GD6*GD7*F6*F7 CPALS = 0.D0 CPASS = 2*GD6*GD8*F6*F8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 C ETA-K** EXCHANGE POTENTIALS: 36 IF(IETKD.EQ.1) THEN PEX = P M = 3 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD4**2*F6*F7 CPALS = -SR3*GD4*GD5*F6*(F7+F8) CPASS = -2*GD5**2*F6*F8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GD4**2*(F6**2+F7**2) CCRLS = -SR3*GD4*GD5*(F6**2+F7*F8) CCRSS = -GD5**2*(F6**2+F8**2) CCRDR = -2*CCRSS CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM) ENDIF GOTO 350 C ETAP-A2 EXCHANGE POTENTIALS: 37 IF(IETPA2.EQ.1) THEN PEX = 1.D0 M = 4 N = 2 C PARALLEL: CPANN = 2*ISFAC*GD1**2*F9**2 CPALL = 0.D0 CPALS = -SR3*GD1*GD3*F9*(F10+F11) CPASS = -4*GD1*GD2*F9*F11 CPADR = +2*GD1*GD2*F9*F11 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM) ENDIF GOTO 350 C ETAP-POMERON EXCHANGE POTENTIALS: 38 IF(IETPPO.EQ.1) THEN PEX = 1.D0 M = 4 N = 3 C PARALLEL: CPANN = 2*GD6**2*F9**2 CPALL = 2*GD6*GD7*F9*F10 CPALS = 0.D0 CPASS = 2*GD6*GD8*F9*F11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = 0.D0 CCRSS = CPASS CCRDR = CPADR CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM) ENDIF GOTO 350 C ETAP-K** EXCHANGE POTENTIALS: 39 IF(IETPKD.EQ.1) THEN PEX = P M = 4 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD4**2*F9*F10 CPALS = -SR3*GD4*GD5*F9*(F10+F11) CPASS = -2*GD5**2*F9*F11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GD4**2*(F9**2+F10**2) CCRLS = -SR3*GD4*GD5*(F9**2+F10*F11) CCRSS = -GD5**2*(F9**2+F11**2) CCRDR = -2*CCRSS CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM) ENDIF GOTO 350 350 IF(INA.EQ.1) THEN VSLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX VSLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX VSSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX VSDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX VTLL = VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX VTLS = VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX VTSS = VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX VTDR = VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX VPSDF(2,2,M,N)=VPSDF(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX VPSDF(3,2,M,N)=VPSDF(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX VPSDF(4,2,M,N)=VPSDF(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX VPSDF(5,2,M,N)=VPSDf(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL + APV*FACT*( +1*CCRLL )*FPVS *PEX VSLS = VSLS + APV*FACT*( +1*CCRLS )*FPVS *PEX VSSS = VSSS + APV*FACT*( +1*CCRSS )*FPVS *PEX VSDR = VSDR + APV*FACT*( +1*CCRDR )*FPVS *PEX VTLL = VTLL + APV*FACT*( +1*CCRLL )*FPVT *PEX VTLS = VTLS + APV*FACT*( +1*CCRLS )*FPVT *PEX VTSS = VTSS + APV*FACT*( +1*CCRSS )*FPVT *PEX VTDR = VTDR + APV*FACT*( +1*CCRDR )*FPVT *PEX VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX ENDIF IF(IOFF.EQ.1) THEN C PIONIC OFF-SHELL CORRECTIONS INTMO: VSLL = VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0 VSLS = VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0 VSSS = VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0 VSDR = VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0 VTLL = VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0 VTLS = VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0 VTSS = VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0 VTDR = VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0 VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0 VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0 VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0 VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0 VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0 ENDIF 300 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(4,x,p) C END DIFFRACTIVE CONTRIBUTIONS 1000 CALL ERRSET(208,256,1,1) ICALL=ICALL+1 RETURN C END OMPSBE ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE OMSCDF(X,INA) C ********************************************************************** C * C * DATE: DECEMBER 1996 C C THIS ROUTINE: THE DOUBLE SCALAR/DIFFRACTIVE YN-POTENTIALS C * C * 1/M-CONTRIBUTIONS: 1) NON-ADIABATIC C * C * NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT C * C ********************************************************************** C C INCLUDED IN ENERGY-DENOMINATORS: C (i) L+R contributions included, 1/4 -> 1/2, the latter is C put into FACT,FACT2 C INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.: C (ii) 1 <-> 2 interchange effects for non-identical mesons. C C ********************************************************************** C IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKAP COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD, .ALPAX COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13, .XGD12,XGD13 COMMON/PSBEOM/ .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4), .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4) C COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) . ,(GS1,GS(1)),(GD1,GD(1)) DATA IEPEP/1/,ICALL/0/,NSCHR/1/ C DATA PI/3.14159265D0/,SRPI/1.7724538509D0/, . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/ DATA AMPRO/938.2796D0/,AMEPS/760.D0/ SAVE AMN,FACT C CALL ERRSET(208,256,-1,1) C pim=pim0 c pim=500.d0 IF(ICALL.EQ.0) THEN AMN = AMPRO FACT = PIM0/2.D0 c FACT = PIM0 c AMB = 2*AMNN*AMH/(AMNN+AMH) amb=ampro FACT = FACT*(PIM0/AMB) IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 ISFLL = (1+ISFAC)/2 ISFLS = (3-ISFAC) ISFSS = (9+ISFAC)/2 DO 250 NCHAN=1,5 DO 250 ITYPV=1,4 DO 250 M=1,4 DO 250 N=1,4 VSCSC(NCHAN,ITYPV,M,N)=0.D0 VSCDF(NCHAN,ITYPV,M,N)=0.D0 250 VDFDF(NCHAN,ITYPV,M,N)=0.D0 c ICALL=1 ENDIF C C 1/M-CORRECTIONS: C ************************************************************** C E) BEGIN DOUBLE SCALAR/DIFFRACTIVE EXCHANGE C ************************************************************** C IF(INA.EQ.1.AND.IEPEP.EQ.1) THEN C C DOUBLE SCALAR CONTRIBUTIONS: C DO 100 II=1,10 CPALS = 0.D0 CCRLS = 0.D0 GOTO(1,2,3,4,5,6,7,8,9,10), II C C DELTA-DELTA EXCHANGE POTENTIALS: C PARALLEL: 1 PEX = 1.D0 M = 1 N = 1 C PARALLEL: CPANN = 1*(3-2*ISFAC)*GS1**2*GS1**2 CPALL = 3*GS1**2*GS3**2 CPALS = 1*SR3*GS1**2*(GS3*GS2+GS2*GS3) CPASS = 1*GS1**2*(3*GS3**2+4*GS2**2) CPADR = 1*GS1**2*GS2**2 C CROSSED: CCRNN = 1*(3+2*ISFAC)*GS1**2*GS1**2 CCRLL = 3*GS1**2*GS3**2 CCRLS = -1*SR3*GS1**2*(GS3*GS2+GS2*GS3) CCRSS = -1*GS1**2*GS3**2 CCRDR = 1*GS1**2*(2*GS3**2+3*GS2**2) CALL FOOM(5,X,AMD,AMD,ALMS8,ALMS8) GOTO 150 C C DELTA-KAPPA EXCHANGE POTENTIALS: 2 PEX = P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*GS1*GS3*GS4*GS5 CPALS = 2*SR3*GS1*GS2*GS4*Gs5-SR3*GS1*GS3*(GS4**2-GS5**2) CPASS = 6*GS1*GS3*GS4*GS5+4*GS1*GS2*GS5**2 CPADR = 4*GS1*GS2*GS5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GS1**2*GS4**2+GS3**2*GS5**2) CCRLS = SR3*(GS1**2*GS4*GS5-GS3**2*GS4*GS5+2*Gs2*GS3*GS5**2) CCRSS = 5*GS1**2*GS5**2+GS3**2*GS4**2+4*Gs2*GS3*GS4*Gs5 CCRDR = 2*GS1**2*GS5**2+GS3**2*GS4**2+ . 3*GS2**2*GS5**2-2*GS2*GS3*GS4*GS5 CALL FOOM(5,X,AMD,AMSCK,ALMS8,ALMS8) GOTO 150 C C KAPPA-KAPPA EXCHANGE POTENTIALS: C PARALLEL: 3 PEX = 1.D0 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 1*(GS4**4+3*GS4**2*GS5**2) CPALS = 1*SR3*(GS5**2-GS4**2)*GS4*GS5 CPASS = 1*(3*GS4**2+GS5**2)*GS5**2 CPADR = 4*GS5**4 C CROSSED: CCRNN = 1*(ISFLL*GS4**2*GS4**2+ISFLS*GS4*GS5*GS4*GS5+ . ISFSS*GS5**2*GS5**2) CCRLL = 1*(GS4**2+3*GS5**2)*XGS12**2 CCRLS = 1*SR3*(GS4*GS4-GS5*GS5)*XGS13*XGS12 CCRSS = -1*(GS4**2-5*GS5**2)*XGS13**2 CCRDR = 2*(GS5*GS5+GS4*GS4)*XGS13**2 CALL FOOM(5,X,AMSCK,AMSCK,ALMS8,ALMS8) GOTO 150 C C S*-DELTA EXCHANGE POTENTIALS: C PARALLEL: 4 PEX = 1.D0 M = 1 N = 4 CPANN = 2*ISFAC*GS1**2*GS9**2 CPALL = 0.D0 CPALS = -SR3*GS1*GS3*GS9*(GS10+GS11) CPASS = -4*GS1*GS2*GS9*GS11 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMSST,AMD,ALMS8,ALMS8) GOTO 150 C C S*-KAPPA EXCHANGE POTENTIALS: C PARALLEL: 5 PEX = P M = 2 N = 4 CPANN = 0.D0 CPALL = 2*GS4**2*GS9*GS10 CPALS = -SR3*GS4*GS5*GS9*(GS10+GS11) CPASS = -2*GS5**2*GS9*GS11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GS4**2*(GS9**2+GS10**2) CCRLS = -SR3*GS4*GS5*(G9**2+GS10*GS11) CCRSS = -GS5**2*(GS9**2+GS11**2) CCRDR = -2*CCRSS CALL FOOM(5,X,AMSST,AMSCK,ALMS8,ALMS8) GOTO 150 C C S*-S* EXCHANGE POTENTIALS: C PARALLEL: 6 PEX = 1.D0 M = 4 N = 4 CPANN = GS9**2*GS9**2 CPALL = GS9**2*GS10**2 CPASS = GS9**2*GS11**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMSST,AMSST,ALMS8,ALMS8) GOTO 150 C C EPSILON-DELTA EXCHANGE POTENTIALS: C PARALLEL: 7 PEX = 1.D0 M = 1 N = 3 CPANN = 2*ISFAC*GS1**2*GS6**2 CPALL = 0.D0 CPALS = -SR3*GS1*GS3*GS6*(GS7+GS8) CPASS = -4*GS1*GS2*GS6*GS8 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR FNONH = 0.D0 DO 101 JJ=1,2 c CALL FOOM(5,X,AMEPS,AMD,ALMS1,ALMS8) CALL FOOM(5,X,AMSIG(JJ),AMD,ALMS1,ALMS8) 101 FNONH = FNONH + FNONC*ASIG(JJ) FNONC = FNONH GOTO 150 C EPSILON-KAPPA EXCHANGE POTENTIALS: C PARALLEL: 8 PEX = P M = 2 N = 3 CPANN = 0.D0 CPALL = 2*GS4**2*GS6*GS7 CPALS = -SR3*GS4*GS5*GS6*(GS7+GS8) CPASS = -2*GS5**2*GS6*GS8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GS4**2*(GS6**2+GS7**2) CCRLS = -SR3*GS4*GS5*(GS6**2+GS7*GS8) CCRSS = -GS5**2*(GS6**2+GS8**2) CCRDR = -2*CCRSS FNONH = 0.D0 DO 102 JJ=1,2 c CALL FOOM(5,X,AMEPS,AMSCK,ALMS1,ALMS8) CALL FOOM(5,X,AMSIG(JJ),AMSCK,ALMS1,ALMS8) 102 FNONH = FNONH + FNONC*ASIG(JJ) FNONC = FNONH GOTO 150 C C EPSILON-S* EXCHANGE POTENTIALS: C PARALLEL: 9 PEX = 1.D0 M = 3 N = 4 CPANN = 2*GS6**2*GS9**2 CPALL = 2*GS6*GS7*GS9*GS10 CPASS = 2*GS6*GS8*GS9*GS11 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR FNONH = 0.D0 DO 103 JJ=1,2 c CALL FOOM(5,X,AMEPS,AMSST,ALMS1,ALMS8) CALL FOOM(5,X,AMSIG(JJ),AMSST,ALMS1,ALMS8) 103 FNONH = FNONH + FNONC*ASIG(JJ) FNONC = FNONH GOTO 150 C C EPSILON-EPSILON EXCHANGE POTENTIALS: C PARALLEL: 10 PEX = 1.D0 M = 3 N = 3 CPANN = GS6**2*GS6**2 CPALL = GS6**2*GS7**2 CPASS = GS6**2*GS8**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR FNONH = 0.D0 DO 104 JJ=1,2 DO 104 KK=1,2 c CALL FOOM(5,X,AMEPS,AMEPS,ALMS1,ALMS1) CALL FOOM(5,X,AMSIG(JJ),AMSIG(KK),ALMS1,ALMS1) 104 FNONH = FNONH + FNONC*ASIG(JJ)*ASIG(KK) FNONC = FNONH GOTO 150 150 VCLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX VCLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX VCSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX VCDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX VSCSC(1,1,M,N)=VSCSC(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX VSCSC(2,1,M,N)=VSCSC(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX VSCSC(3,1,M,N)=VSCSC(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX VSCSC(4,1,M,N)=VSCSC(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX VSCSC(5,1,M,N)=VSCSC(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX 100 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(5,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wromtm(5,x,p) C C ************************************************************** C DOUBLE SCALAR/DIFFRACTIVE CONTRIBUTIONS: C ************************************************************** C DO 300 II=1,12 CPALS = 0.D0 CCRLS = 0.D0 GOTO(31,32,33,34,35,36,37,38,39,40,41,42),II C DELTA-A2 EXCHANGE POTENTIALS: 31 PEX = -1.D0 M = 1 N = 1 C PARALLEL: CPANN = 2*(3-2*ISFAC)*GS1**2*GD1**2 CPALL = 6*GS1*GS3*GD1*Gd3 CPALS = +2*SR3*GS1*GD1*(GD3*GS2+GD2*GS3) CPASS = 2*Gs1*GD1*(3*GD3*GS3+4*GD2*GS2) CPADR = 2*GS1*GD1*GS2*GD2 C CROSSED: CCRNN = 2*(3+2*ISFAC)*GS1**2*GD1**2 CCRLL = 6*GS1*GS3*GD1*Gd3 CCRLS = -2*SR3*GS1*GD1*(GS2*GD3+GS3*GD2) CCRSS = -2*GS1*GD1*GS3*GD3 CCRDR = 2*GS1*GD1*(2*GS3*GD3+3*GS2*GD2) CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM) GOTO 350 C DELTA-K** EXCHANGE POTENTIALS: 32 PEX = -P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*GD1*GD3*GS4*GS5 CPALS = +2*SR3*GD1*GD2*GS4*GS5-SR3*GD1*GD3*(GS4**2-GS5**2) CPASS = 6*GD1*GD3*GS4*GS5+4*GD1*GD2*GS5**2 CPADR = 4*GD1*GD2*GS5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GD1**2*GS4**2+GD3**2*GS5**2) CCRLS = SR3*(GD1**2*GS4*GS5-GD3**2*GS4*GS5+2*GD2*GD3*GS5**2) CCRSS = 5*GD1**2*GS5**2+GD3**2*GS4**2+4*GD2*GD3*GS4*GS5 CCRDR = 2*GD1**2*GS5**2+GD3**2*GS4**2+ . 3*GD2**2*GS5**2-2*GD2*GD3*GS4*GS5 CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM) GOTO 350 C DELTA-POMERON EXCHANGE POTENTIALS: 33 PEX = -1.D0 M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*GS1**2*GD6**2 CPALL = 0.D0 CPALS = -SR3*GS1*GS3*GD6*(GD7+GD8) CPASS = -4*GS1*GS2*GD6*GD8 CPADR = -0.5D0*CPASS C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM) GOTO 350 C KAPPA-A2 EXCHANGE POTENTIALS: 34 PEX = -P M = 2 N = 1 C PARALLEL: CPANN = 0.D0 CPALL = 6*GD1*GD3*GS4*GS5 CPALS = 2*SR3*GD1*GD2*GS4*GS5-SR3*GD1*GD3*(GS4**2-GS5**2) CPASS = 6*GD1*GD3*GS4*GS5+4*GD1*GD2*GS5**2 CPADR = 4*GD1*GD2*GS5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GD1**2*GS4**2+GD3**2*GS5**2) CCRLS = SR3*(GD1**2*GS4*GS5-GD3**2*GS4*GS5+2*GD2*GD3*GS5**2) CCRSS = 5*GD1**2*GS5**2+GD3**2*GS4**2+4*GD2*GD3*GS4*Gs5 CCRDR = 2*GD1**2*GS5**2+GD3**2*GS4**2+ . 3*GD2**2*GS5**2-2*GD2*GD3*GS4*GS5 CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM) GOTO 350 C KAPPA-K** EXCHANGE POTENTIALS: 35 PEX = -1.D0 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*(GD4**2*GS4**2+3*GD4*GD5*GS4*GS5) CPALS = SR3*(GD5**2*GS4*GS5+GD4*GD5*GS5**2 . -GD4**2*GS4*GS5-GD4*GD5*GS4**2) CPASS = 2*(3*GD4*GD5*GS4*GS5+GD5**2*GS5**2) CPADR = 8*GD5**2*GS5**2 C CROSSED: CCRNN = 2*(ISFLL*GS4**2*GD4**2+ISFLS*GS4*GS5*GD4*GD5+ . ISFSS*GS5**2*GD5**2) CCRLL = 2*(GD4*XGD12*GS4*XGS12+3*GD5*XGD12*GS5*XGS12) CCRLS = SR3*(GD4*GS4-GD5*GS5)*(XGD13*XGS12+XGD12*XGs13) CCRSS = -2*GD4*XGD13*GS4*XGS13+10*GD5*XGD13*GS5*XGS13 CCRDR = 4*(GD5*GS5*XGD13*XGS13+GD4*GS4*XGD13*XGS13) CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM) GOTO 350 C KAPPA-POMERON EXCHANGE POTENTIALS: 36 PEX = -P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*GS4*GD6*GD7 CPALS = -SR3*GS4*GS5*GD6*(GD7+GD8) CPASS = -2*GS5**2*GD6*GD8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GS4**2*(GD6**2+GD7**2) CCRLS = -SR3*GS4*GS5*(GD6**2+GD7*GD8) CCRSS = -GS5*2*(GD6**2+GD8**2) CCRDR = -2*CCRSS CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM) GOTO 350 C S*-A2 EXCHANGE POTENTIALS: 37 PEX = -1.D0 M = 4 N = 1 C PARALLEL: CPANN = 2*ISFAC*GS9**2*GD1**2 CPALL = 0.D0 CPALS = -SR3*GD1*GS9*GD3*(GS10+GS11) CPASS = -4*GD1*GS9*GD2*GS11 CPADR = +2*GD1*GS9*GD2*GS11 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM) GOTO 350 C S*-K** EXCHANGE POTENTIALS: 38 PEX = -P M = 4 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD4**2*GS9*GS10 CPALS = -SR3*GD4*GD5*GS9*(GS10+GS11) CPASS = -2*GD5**2*GS9*GS11 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GD4**2*(GS9**2+GS10**2) CCRLS = -SR3*GD4*GD5*(GS9**2+GD10*GD11) CCRSS = -GD5**2*(GS9**2+GS11**2) CCRDR = CPADR CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM) GOTO 350 C S*-POMERON EXCHANGE POTENTIALS: 39 PEX = -1.D0 M = 4 N = 3 C PARALLEL: CPANN = 2*GS9**2*GD6**2 CPALL = 2*GS9*GD6*GS10*GD7 CPASS = 2*GS9*GD6*GS11*GD8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM) GOTO 350 C EPSILON-POMERON EXCHANGE POTENTIALS: 40 PEX = -1.D0 M = 3 N = 3 C PARALLEL: CPANN = 2*GS6**2*GD6**2 CPALL = 2*GS6*GD6*GS7*GD7 CPASS = 2*GS6*GD6*GS8*GD8 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR HNONC = 0.D0 DO 241 JJ=1,2 CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM) c CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM) 241 HNONC = HNONC + ASIG(JJ)*FNONC FNONC = HNONC GOTO 350 C EPSILON-A2 EXCHANGE POTENTIALS: 41 PEX = -1.D0 M = 3 N = 1 C PARALLEL: CPANN = 2*ISFAC*GS6**2*GD1**2 CPALL = 0.D0 CPALS = -SR3*GD1*GS6*GD3*(GS7+GS8) CPASS = -4*GD1*GS6*GD2*GS8 CPADR = +2*GD1*GS6*GD2*GS8 C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR HNONC = 0.D0 DO 341 JJ=1,2 CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM) c CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM) 341 HNONC = HNONC + ASIG(JJ)*FNONC FNONC = HNONC GOTO 350 C EPSILON-K** EXCHANGE POTENTIALS: 42 PEX = -P M = 3 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD4**2*GS6*GS7 CPALS = -SR3*GD4*GD5*GS6*(GS7+GS8) CPASS = -2*GD5**2*GS6*GS8 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLL = GD4**2*(GS6**2+GS7**2) CCRLS = -SR3*GD4*GD5*(GS6**2+GD7*GD8) CCRSS = -GD5**2*(GS6**2+GS8**2) CCRDR = CPADR HNONC = 0.D0 DO 441 JJ=1,2 CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM) c CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM) 441 HNONC = HNONC + ASIG(JJ)*FNONC FNONC = HNONC GOTO 350 350 VCLL = VCLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX VCLS = VCLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX VCSS = VCSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX VCDR = VCDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX VSCDF(1,1,M,N)=VSCDF(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX VSCDF(2,1,M,N)=VSCDF(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX VSCDF(3,1,M,N)=VSCDF(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX VSCDF(4,1,M,N)=VSCDF(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX VSCDF(5,1,M,N)=VSCDF(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX 300 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(6,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wromtm(6,x,p) C C ************************************************************** C DOUBLE DIFFRACTIVE CONTRIBUTIONS: C ************************************************************** C DO 400 II=1,6 CPALS = 0.D0 CCRLS = 0.D0 GOTO(44,54,64,74,84,94), II C POMERON-POMERON EXCHANGE POTENTIALS: 44 PEX = +1.D0 M = 3 N = 3 C PARALLEL: CPANN = GD6**2*GD6**2 CPALL = GD6**2*GD7**2 CPASS = GD6**2*GD8**2 CPADR = CPASS C CROSSED: CCRNN = CPANN CCRLL = CPALL CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 C POMERON-A2 EXCHANGE POTENTIALS: 54 PEX = +1.D0 M = 1 N = 3 C PARALLEL: CPANN = 2*ISFAC*GD6**2*GD1**2 CPALL = 0.D0 CPALS = -SR3*GD1*GD6*GD3*(GD7+GD8) CPASS = -4*GD1*GD6*GD2*GD8 CPADR = +2*GD1*GD6*GD2*GD8 C CROSSED: CCRNN = CPANN CCRLL = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 C POMERON-K** EXCHANGE POTENTIALS: 64 PEX = +P M = 2 N = 3 C PARALLEL: CPANN = 0.D0 CPALL = 2*GD6*GD7*GD4**2 CPALS = -SR3*GD6*(GD7+GD8)*GD4*GD5 CPASS = -2*GD6*GD8*GD5**2 CPADR = -2*CPASS C CROSSED: CCRNN = 0.D0 CCRLS = CPALS CCRSS = CPASS CCRDR = CPADR CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 C A2-A2 EXCHANGE POTENTIALS: 74 PEX = +1.D0 M = 1 N = 1 C PARALLEL: CPANN = 1*(3-2*ISFAC)*GD1**2*GD1**2 CPALL = 3*GD1**2*GD3**2 CPALS = 2*SR3*GD1**2*GD3*GD2 CPASS = GD1**2*(3*GD3**2+4*GD2**2) CPADR = GD1**2*GD2**2 C CROSSED: CCRNN = 1*(3+2*ISFAC)*GD1**2*GD1**2 CCRLL = CPALL CCRLS = -CPALS CCRSS = -GD1**2*GD2**2 CCRDR = GD1**2*(2*GD3**2+2*GD2**2) CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 C A2-K** EXCHANGE POTENTIALS: 84 PEX = +P M = 1 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = 6*GD1*GD4*GD3*GD5 CPALS = -SR3*GD1*GD3*(GD4**2-GD5**2) . +2*SR3*GD1*GD2*GD4*GD5 CPASS = GD1*GD5*(6*GD3*GD4+4*GD2*GD5) CPADR = +4*GD1*GD2*GD5**2 C CROSSED: CCRNN = 0.D0 CCRLL = 3*(GD1**2*GD4**2+GD3**2*GD5**2) CCRLS = SR3*GD4*GD5*(GD1**2-GD3**2) . +2*SR3*GD2*GD3*GD5**2 CCRSS = 5*GD1**2*GD5**2+GD3**2*GD4**2 . +4*GD2*GD3*GD4*GD5 CCRDR = 2*GD1**2*GD5**2+GD3**2*GD4**2 . +3*GD2**2*GD5**2-2*GD2*GD3*GD4*GD5 CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 C K**-K** EXCHANGE POTENTIALS: 94 PEX = +1.D0 M = 2 N = 2 C PARALLEL: CPANN = 0.D0 CPALL = (GD4**2+3*GD5**2)*GD4**2 CPALS = SR3*(GD5**2-GD4**2)*GD4*GD5 CPASS = (3*GD4**2+GD5**2)*GD5**2 CPADR = +4*GD5**4 C CROSSED: CCRNN = 1*(ISFLL*GD4**2*GD4**2+ISFLS*GD4*GD5*GD4*GD5+ . ISFSS*GD5**2*GD5**2) CCRLL = (GD4**2*XGD12**2+3*GD5**2*XGD12**2) CCRLS = SR3*(GD4**2-GD5**2)*(XGD13*XGD12) CCRSS = -1*GD4**2*XGD13**2+5*GD5**2*XGD13**2 CCRDR = 2*(GD5*GD5*XGD13*XGD13+GD4*GD4*XGD13*XGD13) CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM) GOTO 450 450 VCLL = VSLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX VCLS = VSLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX VCSS = VSSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX VCDR = VSDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX VDFDF(1,1,M,N)=VDFDF(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX VDFDF(2,1,M,N)=VDFDF(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX VDFDF(3,1,M,N)=VDFDF(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX VDfDF(4,1,M,N)=VDFDF(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX VDFDF(5,1,M,N)=VDFDF(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX 400 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wromtm(7,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wromtm(7,x,p) ENDIF C END DOUBLE SCALAR/DIFFRACTIVE EXCHANGE 1000 CALL ERRSET(208,256,1,1) ICALL = ICALL + 1 RETURN C END OMSCDF ROUTINE *************************************************** END C ********************************************************************** SUBROUTINE OMPAIR(X,INA,IPV,APV) C ********************************************************************** C * C * DATE AUGUST 1995 C C * PHENOMENOLOGICAL PION-MESON PAIR YN-POTENTIALS C CALLED BY SUBROUTINE YNPAIR.FORTRAN C * C * 1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX C C IN COUPLING COMBINATIONS CENLL1 ETC.: C (i) YNCCPR: L+R contributions included, C (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams) C C PISI and PIRO1 A LA paper II C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/PRMTRS/ PAR(20,8) COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11) COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA ! MARCH 2009 . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV .,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 C DIMENSION WGHTID(2) C C COMMUNICATION WITH ROUTINE YNPAIRS: COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10), .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10) ,CCPR7(3,10), .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10), .CCPR11(4,10),CCPR11F(4,10) ! MARCH 2009 C COMMUNICATION WITH ROUTINE WROMPR: COMMON/PROMPR/VPRA(5,3,4,4),VPRB(5,3,4,4),VPRC(5,3,4,4), . VPRD(5,3,4,4),VPRE(5,3,4,4),VPRF(5,3,4,4) c COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5, c . VALL1,VALL2,VALL3,VALL4,VALL5 DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/ c* DATA FACID/0.5D0/,SR2/1.4142136D0/,SR3/1.732051D0/,NSCHR/0/ ! was voor su3-check DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,NSCHR/0/ ! na su3-checK 2008 DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/, . AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/ SAVE FACT,AMN,DAM,AA,AMB c SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7 C cc CALL ERRSET(208,256,-1,1) pim=pim0 IF(ICALL.EQ.0) THEN FACT = PIM0 c AMB = 2*AMNN*AMH/(AMNN+AMH) AMB = AMPRO FACT = FACT*(PIM0/AMB)/4.D0 IF(NSCHR.NE.0) PRINT 52, INA,IPV,PIM,AMB 52 FORMAT(//,' IN OMPAIR: INA, IPV=',2I3,' PIM=',F7.3, . ' AMB=',F10.3,/) c ICALL=1 ENDIF C C WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING C THV = 37.5D0*PI/180.D0 THV = PAR(10,3)*PI/180.D0 WGHTID(1) = DSIN(THV) WGHTID(2) = DCOS(THV) if(p.ne.pold) then icall=0 pold=p c*** nschr=1 nschr=0 endif c IF(ICALL.EQ.0) THEN IF(ICALL.EQ.20.AND.NSCHR.EQ.1) THEN DO 250 NCHAN=1,5 DO 250 ITYPV=1,3 DO 250 M=1,4 DO 250 N=1,4 VPRA(NCHAN,ITYPV,M,N)=0.D0 VPRB(NCHAN,ITYPV,M,N)=0.D0 VPRC(NCHAN,ITYPV,M,N)=0.D0 VPRD(NCHAN,ITYPV,M,N)=0.D0 VPRE(NCHAN,ITYPV,M,N)=0.D0 250 VPRF(NCHAN,ITYPV,M,N)=0.D0 ENDIF C C CONSTRUCTION 1/M-CORRECTIONS TO THE POTENTIALS: C C A) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} : C IF(IPIPI0.NE.0) THEN ITYPE=1 DO 10 II=1,3 GOTO(11,12,13),II C PI-PI(I=0): 11 CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8) M = 1 GOTO 14 C ETA-ETA: 12 CALL FOOMPR(ITYPE,X,AME,AME,ALMP8,ALMP8) M = 3 GOTO 14 C KA-KA(I=0): 13 CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA) M = 2 GOTO 14 14 IF(INA.EQ.1) THEN VCLL = VCLL - FACT*CCPR1(II,2)*FNONC VCSS = VCSS - FACT*CCPR1(II,4)*FNONC VCDR = VCDR - FACT*CCPR1(II,5)*FNONC VOLL = VOLL - FACT*CCPR1(II,2)*FNONO VOSS = VOSS - FACT*CCPR1(II,4)*FNONO VODR = VODR - FACT*CCPR1(II,5)*FNONO VPRA(1,1,M,M)=VPRA(1,1,M,M)-FACT*CCPR1(II,1)*FNONC VPRA(2,1,M,M)=VPRA(2,1,M,M)-FACT*CCPR1(II,2)*FNONC VPRA(4,1,M,M)=VPRA(4,1,M,M)-FACT*CCPR1(II,4)*FNONC VPRA(5,1,M,M)=VPRA(5,1,M,M)-FACT*CCPR1(II,5)*FNONC ENDIF IF(IPV.EQ.1) THEN VCLL = VCLL - APV*FACT*CCPR1(II,2)*FPVC VCSS = VCSS - APV*FACT*CCPR1(II,4)*FPVC VCDR = VCDR - APV*FACT*CCPR1(II,5)*FPVC VOLL = VOLL - APV*FACT*CCPR1(II,2)*FPVO VOSS = VOSS - APV*FACT*CCPR1(II,4)*FPVO VODR = VODR - APV*FACT*CCPR1(II,5)*FPVO VPRA(1,1,M,M)=VPRA(1,1,M,M)-APV*FACT*CCPR1(II,1)*FPVC VPRA(2,1,M,M)=VPRA(2,1,M,M)-APV*FACT*CCPR1(II,2)*FPVC VPRA(4,1,M,M)=VPRA(4,1,M,M)-APV*FACT*CCPR1(II,4)*FPVC VPRA(5,1,M,M)=VPRA(5,1,M,M)-APV*FACT*CCPR1(II,5)*FPVC ENDIF 10 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wrompr(1,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wrompr(1,x,p) ENDIF C C B) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(IPIET.NE.0) THEN c* ITYPE = 5 ITYPE = 1 ! in NN, is correct DO 20 II=1,10 PEX = 1.D0 GOTO(21,22,23,24,25,26,27,21,23,24),II C PI-ETA: 21 CALL FOOMPR(ITYPE,X,PIM,AME,ALMP8,ALMP8) IF(II.EQ.1) THEN M = 1 N = 3 ENDIF IF(II.EQ.8) THEN M = 3 N = 1 ENDIF GOTO 28 C KA-KA(8S)(I=1): 22 CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA) M = 2 N = 2 GOTO 28 C PI-KA(8s): 23 CALL FOOMPR(ITYPE,X,PIM,AMK,ALMP8,ALMKA) PEX = P IF(II.EQ.3) THEN M = 1 N = 2 ENDIF IF(II.EQ.9) THEN M = 2 N = 1 ENDIF GOTO 28 C ETA-KA(8s): 24 CALL FOOMPR(ITYPE,X,AME,AMK,ALMP8,ALMKA) PEX = P IF(II.EQ.4) THEN M = 2 N = 3 ENDIF IF(II.EQ.10) THEN M = 3 N = 2 ENDIF GOTO 28 C PI-PI(8S)(I=0): 25 CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8) M = 1 N = 1 GOTO 28 C ETA-ETA(8s): 26 CALL FOOMPR(ITYPE,X,AME,AME,ALMP8,ALMP8) M = 3 N = 3 GOTO 28 C KA-KA(8S)(I=0): 27 CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA) M = 2 N = 2 GOTO 28 28 IF(INA.EQ.1) THEN VCLL = VCLL - FACT*CCPR2(II,2)*FNONC*PEX VCLS = VCLS - FACT*CCPR2(II,3)*FNONC*PEX VCSS = VCSS - FACT*CCPR2(II,4)*FNONC*PEX VCDR = VCDR - FACT*CCPR2(II,5)*FNONC*PEX VOLL = VOLL - FACT*CCPR2(II,2)*FNONO*PEX VOLS = VOLS - FACT*CCPR2(II,3)*FNONO*PEX VOSS = VOSS - FACT*CCPR2(II,4)*FNONO*PEX VODR = VODR - FACT*CCPR2(II,5)*FNONO*PEX VPRB(1,1,M,N)=VPRB(1,1,M,N)-FACT*CCPR2(II,1)*FNONC*PEX VPRB(2,1,M,N)=VPRB(2,1,M,N)-FACT*CCPR2(II,2)*FNONC*PEX VPRB(3,1,M,N)=VPRB(3,1,M,N)-FACT*CCPR2(II,3)*FNONC*PEX VPRB(4,1,M,N)=VPRB(4,1,M,N)-FACT*CCPR2(II,4)*FNONC*PEX VPRB(5,1,M,N)=VPRB(5,1,M,N)-FACT*CCPR2(II,5)*FNONC*PEX ENDIF IF(IPV.EQ.1) THEN VCLL = VCLL - APV*FACT*CCPR2(II,2)*FPVC*PEX VCLS = VCLS - APV*FACT*CCPR2(II,3)*FPVC*PEX VCSS = VCSS - APV*FACT*CCPR2(II,4)*FPVC*PEX VCDR = VCDR - APV*FACT*CCPR2(II,5)*FPVC*PEX VOLL = VOLL - APV*FACT*CCPR2(II,2)*FPVO*PEX VOLS = VOLS - APV*FACT*CCPR2(II,3)*FPVO*PEX VOSS = VOSS - APV*FACT*CCPR2(II,4)*FPVO*PEX VODR = VODR - APV*FACT*CCPR2(II,5)*FPVO*PEX VPRB(1,1,M,N)=VPRB(2,1,M,N)-APV*FACT*CCPR2(II,1)*FPVC*PEX VPRB(2,1,M,N)=VPRB(2,1,M,N)-APV*FACT*CCPR2(II,2)*FPVC*PEX VPRB(3,1,M,N)=VPRB(3,1,M,N)-APV*FACT*CCPR2(II,3)*FPVC*PEX VPRB(4,1,M,N)=VPRB(4,1,M,N)-APV*FACT*CCPR2(II,4)*FPVC*PEX VPRB(5,1,M,N)=VPRB(5,1,M,N)-APV*FACT*CCPR2(II,5)*FPVC*PEX ENDIF c xfm=x*197.32d0/pim c if(xfm.ge.0.1d0.and.xfm.le.0.7d0) then c write(*,*) 'ompair, ii=',ii,' xfm=',xfm,' vsll=',vsll c endif 20 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wrompr(2,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wrompr(2,x,p) ENDIF C PI-ETA': * IF(IPIETP.EQ.1) THEN * VC = VC + FACT*ISFAC*GPIETP*( * . 2*FP*FETAP*DFI*DFIETP-0.5D0*GPIETP*FIPEP2) * ENDIF C C C) VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} : C C NOTE: for identical mesons: FACID=1/2 is included for 1-pair's!! C IF(IPIPI1.NE.0) THEN ITYPE = 2 c DO 30 II=1,9 DO 30 II=1,6 PEX = 1.D0 GOTO(31,32,33,34,341,35,33,34,341),II C PI-PI(I=1): 31 CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8) PEX = FACID M = 1 N = 1 GOTO 36 C KA-KA(8A)(I=1): 32 CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA) PEX = FACID M = 2 N = 2 GOTO 36 C PI-KA(8a): 33 CALL FOOMPR(ITYPE,X,PIM,AMK,ALMP8,ALMKA) PEX = P*2 IF(II.EQ.3) THEN M = 1 N = 2 ENDIF IF(II.EQ.7) THEN M = 2 N = 1 ENDIF GOTO 36 C ETA-KA(8a): 34 CALL FOOMPR(ITYPE,X,AME,AMK,ALMP8,ALMKA) PEX = P*2 IF(II.EQ.4) THEN M = 3 N = 2 ENDIF IF(II.EQ.8) THEN M = 2 N = 3 ENDIF GOTO 36 C ETAP-KA(8a): 341 CALL FOOMPR(ITYPE,X,AMX,AMK,ALMP8,ALMKA) PEX = P*2 IF(II.EQ.5) THEN M = 4 N = 2 ENDIF IF(II.EQ.9) THEN M = 2 N = 4 ENDIF GOTO 36 C KA-KA(8A)(I=0): 35 CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA) PEX = FACID M = 2 N = 2 GOTO 36 36 IF(INA.EQ.1) THEN VCLL = VCLL - FACT*CCPRG(II,2)*FNONC*PEX VCLS = VCLS - FACT*CCPRG(II,3)*FNONC*PEX VCSS = VCSS - FACT*CCPRG(II,4)*FNONC*PEX VCDR = VCDR - FACT*CCPRG(II,5)*FNONC*PEX VOLL = VOLL - FACT*CCPRG(II,2)*FNONO*PEX VOLS = VOLS - FACT*CCPRG(II,3)*FNONO*PEX VOSS = VOSS - FACT*CCPRG(II,4)*FNONO*PEX VODR = VODR - FACT*CCPRG(II,5)*FNONO*PEX VPRC(1,1,M,N)=VPRC(1,1,M,N)-FACT*CCPRG(II,1)*FNONC*PEX VPRC(2,1,M,N)=VPRC(2,1,M,N)-FACT*CCPRG(II,2)*FNONC*PEX VPRC(3,1,M,N)=VPRC(3,1,M,N)-FACT*CCPRG(II,3)*FNONC*PEX VPRC(4,1,M,N)=VPRC(4,1,M,N)-FACT*CCPRG(II,4)*FNONC*PEX VPRC(5,1,M,N)=VPRC(5,1,M,N)-FACT*CCPRG(II,5)*FNONC*PEX ENDIF IF(IPV.EQ.1) THEN VCLL = VCLL - APV*FACT*CCPRG(II,2)*FPVC*PEX VCLS = VCLS - APV*FACT*CCPRG(II,3)*FPVC*PEX VCSS = VCSS - APV*FACT*CCPRG(II,4)*FPVC*PEX VCDR = VCDR - APV*FACT*CCPRG(II,5)*FPVC*PEX VOLL = VOLL - APV*FACT*CCPRG(II,2)*FPVO*PEX VOLS = VOLS - APV*FACT*CCPRG(II,3)*FPVO*PEX VOSS = VOSS - APV*FACT*CCPRG(II,4)*FPVO*PEX VODR = VODR - APV*FACT*CCPRG(II,5)*FPVO*PEX VPRC(1,1,M,N)=VPRC(1,1,M,N)-APV*FACT*CCPRG(II,1)*FPVC*PEX VPRC(2,1,M,N)=VPRC(2,1,M,N)-APV*FACT*CCPRG(II,2)*FPVC*PEX VPRC(3,1,M,N)=VPRC(3,1,M,N)-APV*FACT*CCPRG(II,3)*FPVC*PEX VPRC(4,1,M,N)=VPRC(4,1,M,N)-APV*FACT*CCPRG(II,4)*FPVC*PEX VPRC(5,1,M,N)=VPRC(5,1,M,N)-APV*FACT*CCPRG(II,5)*FPVC*PEX ENDIF 30 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wrompr(3,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wrompr(3,x,p) ENDIF C C 3) AXIAL PAIR TERMS OF THE FIRST CLASS: C c ITYPE=3 c NO EXTRA 1/M-CORRECTIONS (ADIABATIC TERMS ARE 1/M!) c IF(GPIRO1.NE.0.D0) THEN c ENDIF C C 4) AXIAL PAIR TERMS OF THE SECOND CLASS: C c ITYPE=4 c NOT INCLUDED IN YNPAIRS c IF(IPIRO0.EQ.1) THEN c ENDIF C C------------------------------------------------------------ C 5) AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) : c INCLUDED IN YNOOM DEC.06 C------------------------------------------------------------ C HERE: ETA8 = ETA(548) (THPS IS SMALL), C PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019) C------------------------------------------------------------ IF(IPIOM.EQ.2) THEN ITYPE=5 DO 90 II=1,13 PEX = 1.D0 GOTO(91,911,92,93,94,95,96,97,971,98,981,991,992),II C PI-OMEGA 91 CALL FOOMPR(ITYPE,X,PIM,AMOM,ALMP8,ALMV1) FPVS = FPVS*WGHTID(1) FPVT = FPVT*WGHTID(1) GOTO 990 C PI-PHI: 911 CALL FOOMPR(ITYPE,X,PIM,AMFI,ALMP8,ALMV8) FPVS = FPVS*WGHTID(2) FPVT = FPVT*WGHTID(2) c IMES1 = 1 c IMES2 = 3 GOTO 990 C ETA-RHO: 92 CALL FOOMPR(ITYPE,X,AME,AMRO,ALMP8,ALMV8) c IMES1 = 3 c IMES2 = 1 GOTO 990 C KA-K*(8S)(I=1): 93 CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8) c IMES1 = 2 c IMES2 = 2 GOTO 990 C PI-K*(8S): 94 CALL FOOMPR(ITYPE,X,PIM,AMKS,ALMP8,ALMV8) c IMES1 = 1 c IMES2 = 2 PEX = P GOTO 990 C KA-RHO(8S)(I=1): 95 CALL FOOMPR(ITYPE,X,AMK,AMRO,ALMP8,ALMV8) c IMES1 = 2 c IMES2 = 1 PEX = P GOTO 990 C ETA-K*: 96 CALL FOOMPR(ITYPE,X,AME,AMKS,ALMP8,ALMV8) c IMES1 = 3 c IMES2 = 2 PEX = P GOTO 990 C KA-PHI8: C KA-OMEGA: 97 CALL FOOMPR(ITYPE,X,AMK,AMOM,ALMP8,ALMV8) FPVS = FPVS*WGHTID(1) FPVT = FPVT*WGHTID(1) PEX = P GOTO 990 C KA-PHI: 971 CALL FOOMPR(ITYPE,X,AMK,AMFI,ALMP8,ALMV8) FPVS = FPVS*WGHTID(2) FPVT = FPVT*WGHTID(2) c IMES1 = 2 c IMES2 = 3 PEX = P GOTO 990 C PI-RHO(8S)(I=0): 98 CALL FOOMPR(ITYPE,X,PIM,AMRO,ALMP8,ALMV8) c IMES1 = 1 c IMES2 = 1 GOTO 990 C KA-K*(8S)(I=0): 981 CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8) c IMES1 = 2 c IMES2 = 2 GOTO 990 C ETA-OMEGA(8s): 991 CALL FOOMPR(ITYPE,X,AME,AMOM,ALMP8,ALMV1) FPVS = FPVS*WGHTID(1) FPVT = FPVT*WGHTID(1) GOTO 990 C ETA-PHI(8s): 992 CALL FOOMPR(ITYPE,X,AME,AMFI,ALMP8,ALMV8) FPVS = FPVS*WGHTID(2) FPVT = FPVT*WGHTID(2) c IMES1 = 3 c IMES2 = 3 GOTO 990 990 CONTINUE c* question: factor 4, is that right? yes! c* UFAC1=4.D0/8.D0 ! old UFAC1=1.D0 ! new (check) !! UFAC1=2.D0 ! -> the correct factor! UFAC1=4.D0 ! -> factor 2 overshoot, a la NN-program! c if(icall.eq.0) write(6,*) ' ynoom.f/ompair: UFAC1=',UFAC1 c VSNN = VSNN + PEX*APV*FACT*CCPR10(II,1)*FPVS*1/3.D0 c .*UFAC1 VSLL = VSLL + PEX*APV*FACT*CCPR10(II,2)*FPVS*1/3.D0 .*UFAC1 VSLS = VSLS + PEX*APV*FACT*CCPR10(II,3)*FPVS*1/3.D0 .*UFAC1 VSSS = VSSS + PEX*APV*FACT*CCPR10(II,4)*FPVS*1/3.D0 .*UFAC1 VSDR = VSDR + PEX*APV*FACT*CCPR10(II,5)*FPVS*1/3.D0 .*UFAC1 c* VTNN = VTNN + PEX*APV*FACT*CCPR10(II,1)*FPVT*1/3.D0 c .*UFAC1 VTLL = VTLL + PEX*APV*FACT*CCPR10(II,2)*FPVT*1/3.D0 .*UFAC1 VTLS = VTLS + PEX*APV*FACT*CCPR10(II,3)*FPVT*1/3.D0 .*UFAC1 VTSS = VTSS + PEX*APV*FACT*CCPR10(II,4)*FPVT*1/3.D0 .*UFAC1 VTDR = VTDR + PEX*APV*FACT*CCPR10(II,5)*FPVT*1/3.D0 .*UFAC1 c------------------------------------------------------------ if(ii.eq.1) then dvsnn=0.d0 dvsll=0.d0 dvsls=0.d0 dvsss=0.d0 dvsdr=0.d0 dvtnn=0.d0 dvtll=0.d0 dvtls=0.d0 dvtss=0.d0 dvtdr=0.d0 endif DVSNN = DVSNN+ 2*PEX*APV*FACT*CCPR10(II,1)*FPVS*1/6.D0 DVSLL = DVSLl+ 2*PEX*APV*FACT*CCPR10(II,2)*FPVS*1/6.D0 DVSLS = DVSLS+ 2*PEX*APV*FACT*CCPR10(II,3)*FPVS*1/6.D0 DVSSS = DVSSS+ 2*PEX*APV*FACT*CCPR10(II,4)*FPVS*1/6.D0 DVSDR = DVSDR+ 2*PEX*APV*FACT*CCPR10(II,5)*FPVS*1/6.D0 DVTNN = DVTNN+ 2*PEX*APV*FACT*CCPR10(II,1)*FPVT*1/6.D0 DVTLL = DVTLL+ 2*PEX*APV*FACT*CCPR10(II,2)*FPVT*1/6.D0 DVTLS = DVTLS+ 2*PEX*APV*FACT*CCPR10(II,3)*FPVT*1/6.D0 DVTSS = DVTSS+ 2*PEX*APV*FACT*CCPR10(II,4)*FPVT*1/6.D0 DVTDR = DVTDR+ 2*PEX*APV*FACT*CCPR10(II,5)*FPVT*1/6.D0 c xfm=x*197.32d0/pim c if(xfm.ge.0.1d0.and.xfm.le.0.7d0) then c write(*,*) 'ompair, ii=',ii,' xfm=',xfm,' vsll=',vsll c if(ii.eq.13) then c write(*,*) 'ompair, ii=',ii,' xfm=',xfm c write(*,*) ' dvsnn,dvsll,dvsls,dvsss,dvsdr=', c . dvsnn,dvsll,dvsls,dvsss,dvsdr c write(*,*) ' dvtnn,dvtll,dvtls,dvtss,dvtdr=', c . dvtnn,dvtll,dvtls,dvtss,dvtdr c write(*,1313) xfm,dvsdr,dvsll,dvtdr,dvtll 1313 format('YNPRS,PIOM: xfm=',f5.2,' dvsdr=',f8.2,' dvsll=',f8.2, .' dvtdr=',f7.2,' dvtll=',f7.2,/) c endif c endif c------------------------------------------------------------ 90 CONTINUE ENDIF C------------------------------------------------------------ C C 6) PSEUDO SCALAR (PION-EPSILON) PAIR TERMS: IF(IPISI.NE.0) THEN ITYPE = 6 DO 50 II=1,6 PEX = 1.D0 GOTO(51,51,51,54,55,56),II C PI-EPSILON: C KA-EPSILON: C ETA-EPSILON: 51 HNONS = 0.D0 HNONT = 0.D0 HPVS = 0.D0 HPVT = 0.D0 DO 510 JJ=1,2 IF(II.EQ.1) CALL FOOMPR(ITYPE,X,PIM,AMSIG(JJ),ALMP8,ALMS1) IF(II.EQ.2) CALL FOOMPR(ITYPE,X,AMK,AMSIG(JJ),ALMKA,ALMS1) IF(II.EQ.3) CALL FOOMPR(ITYPE,X,AME,AMSIG(JJ),ALMP8,ALMS1) HNONS = HNONS + ASIG(JJ)*FNONS HNONT = HNONT + ASIG(JJ)*FNONT HPVS = HPVS + ASIG(JJ)*FPVS 510 HPVT = HPVT + ASIG(JJ)*FPVT FNONS = HNONS FNONT = HNONT FPVS = HPVS FPVT = HPVT IF(II.EQ.2) PEX = P M = II N = 4 GOTO 57 C PI-SSTAR: 54 CALL FOOMPR(ITYPE,X,PIM,AMSST,ALMP8,ALMS8) M = 1 N = 3 GOTO 57 C KA-SSTAR: 55 CALL FOOMPR(ITYPE,X,AMK,AMSST,ALMKA,ALMS8) PEX = P M = 2 N = 3 GOTO 57 C ETA-SSTAR: 56 CALL FOOMPR(ITYPE,X,AME,AMSST,ALMP8,ALMS8) M = 3 N = 3 GOTO 57 57 IF(INA.EQ.1) THEN VSLL = VSLL - FACT*CCPR5(II,2)*FNONS*PEX/3.D0 VSLS = VSLS - FACT*CCPR5(II,3)*FNONS*PEX/3.D0 VSSS = VSSS - FACT*CCPR5(II,4)*FNONS*PEX/3.D0 VSDR = VSDR - FACT*CCPR5(II,5)*FNONS*PEX/3.D0 VTLL = VTLL - FACT*CCPR5(II,2)*FNONT*PEX/3.D0 VTLS = VTLS - FACT*CCPR5(II,3)*FNONT*PEX/3.D0 VTSS = VTSS - FACT*CCPR5(II,4)*FNONT*PEX/3.D0 VTDR = VTDR - FACT*CCPR5(II,5)*FNONT*PEX/3.D0 VPRE(1,2,M,N)=VPRE(1,2,M,N)-FACT*CCPR5(II,1)*FNONS*PEX/3.D0 VPRE(2,2,M,N)=VPRE(2,2,M,N)-FACT*CCPR5(II,2)*FNONS*PEX/3.D0 VPRE(3,2,M,N)=VPRE(3,2,M,N)-FACT*CCPR5(II,3)*FNONS*PEX/3.D0 VPRE(4,2,M,N)=VPRE(4,2,M,N)-FACT*CCPR5(II,4)*FNONS*PEX/3.D0 VPRE(5,2,M,N)=VPRE(5,2,M,N)-FACT*CCPR5(II,5)*FNONS*PEX/3.D0 ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL + APV*FACT*CCPR5(II,2)*FPVS*PEX/3.D0 VSLS = VSLS + APV*FACT*CCPR5(II,3)*FPVS*PEX/3.D0 VSSS = VSSS + APV*FACT*CCPR5(II,4)*FPVS*PEX/3.D0 VSDR = VSDR + APV*FACT*CCPR5(II,5)*FPVS*PEX/3.D0 VTLL = VTLL + APV*FACT*CCPR5(II,2)*FPVT*PEX/3.D0 VTLS = VTLS + APV*FACT*CCPR5(II,3)*FPVT*PEX/3.D0 VTSS = VTSS + APV*FACT*CCPR5(II,4)*FPVT*PEX/3.D0 VTDR = VTDR + APV*FACT*CCPR5(II,5)*FPVT*PEX/3.D0 VPRE(1,2,M,N)=VPRE(1,2,M,N)+APV*FACT*CCPR5(II,1)*FPVS*PEX/3.D0 VPRE(2,2,M,N)=VPRE(2,2,M,N)+APV*FACT*CCPR5(II,2)*FPVS*PEX/3.D0 VPRE(3,2,M,N)=VPRE(3,2,M,N)+APV*FACT*CCPR5(II,3)*FPVS*PEX/3.D0 VPRE(4,2,M,N)=VPRE(4,2,M,N)+APV*FACT*CCPR5(II,4)*FPVS*PEX/3.D0 VPRE(5,2,M,N)=VPRE(5,2,M,N)+APV*FACT*CCPR5(II,5)*FPVS*PEX/3.D0 ENDIF 50 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wrompr(5,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wrompr(5,x,p) ENDIF C C PSEUDO SCALAR (PS-POMERON) PAIR TERMS: IF(IPIPOM.NE.0) THEN ITYPE = 7 DO 70 II=1,3 PEX = 1.D0 GOTO(71,72,73),II C PI-POMERON: 71 CALL FOOMPR(ITYPE,X,PIM,AMPOM,ALMP8,AMPOM) M = 1 N = 4 GOTO 74 C KA-POMERON: 72 CALL FOOMPR(ITYPE,X,AMK,AMPOM,ALMKA,AMPOM) PEX = P M = 2 N = 4 GOTO 74 C ETA-POMERON: 73 CALL FOOMPR(ITYPE,X,AME,AMPOM,ALMP8,AMPOM) M = 3 N = 4 GOTO 74 74 IF(INA.EQ.1) THEN VSLL = VSLL + FACT*CCPR7(II,2)*FNONS*PEX/3.D0 VSLS = VSLS + FACT*CCPR7(II,3)*FNONS*PEX/3.D0 VSSS = VSSS + FACT*CCPR7(II,4)*FNONS*PEX/3.D0 VSDR = VSDR + FACT*CCPR7(II,5)*FNONS*PEX/3.D0 VTLL = VTLL + FACT*CCPR7(II,2)*FNONT*PEX/3.D0 VTLS = VTLS + FACT*CCPR7(II,3)*FNONT*PEX/3.D0 VTSS = VTSS + FACT*CCPR7(II,4)*FNONT*PEX/3.D0 VTDR = VTDR + FACT*CCPR7(II,5)*FNONT*PEX/3.D0 VPRF(1,2,M,N)=VPRF(1,2,M,N)+FACT*CCPR7(II,1)*FNONS*PEX/3.D0 VPRF(2,2,M,N)=VPRF(2,2,M,N)+FACT*CCPR7(II,2)*FNONS*PEX/3.D0 VPRF(3,2,M,N)=VPRF(3,2,M,N)+FACT*CCPR7(II,3)*FNONS*PEX/3.D0 VPRF(4,2,M,N)=VPRF(4,2,M,N)+FACT*CCPR7(II,4)*FNONS*PEX/3.D0 VPRF(5,2,M,N)=VPRF(5,2,M,N)+FACT*CCPR7(II,5)*FNONS*PEX/3.D0 ENDIF IF(IPV.EQ.1) THEN VSLL = VSLL - APV*FACT*CCPR7(II,2)*FPVS*PEX/3.D0 VSLS = VSLS - APV*FACT*CCPR7(II,3)*FPVS*PEX/3.D0 VSSS = VSSS - APV*FACT*CCPR7(II,4)*FPVS*PEX/3.D0 VSDR = VSDR - APV*FACT*CCPR7(II,5)*FPVS*PEX/3.D0 VTLL = VTLL - APV*FACT*CCPR7(II,2)*FPVT*PEX/3.D0 VTLS = VTLS - APV*FACT*CCPR7(II,3)*FPVT*PEX/3.D0 VTSS = VTSS - APV*FACT*CCPR7(II,4)*FPVT*PEX/3.D0 VTDR = VTDR - APV*FACT*CCPR7(II,5)*FPVT*PEX/3.D0 VPRF(1,2,M,N)=VPRF(1,2,M,N)-APV*FACT*CCPR7(II,1)*FPVS*PEX/3.D0 VPRF(2,2,M,N)=VPRF(2,2,M,N)-APV*FACT*CCPR7(II,2)*FPVS*PEX/3.D0 VPRF(3,2,M,N)=VPRF(3,2,M,N)-APV*FACT*CCPR7(II,3)*FPVS*PEX/3.D0 VPRF(4,2,M,N)=VPRF(4,2,M,N)-APV*FACT*CCPR7(II,4)*FPVS*PEX/3.D0 VPRF(5,2,M,N)=VPRF(5,2,M,N)-APV*FACT*CCPR7(II,5)*FPVS*PEX/3.D0 ENDIF 70 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call wrompr(6,x,p) c* if(icall.eq.20.and.nschr.eq.1) call wrompr(6,x,p) ENDIF C C D) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} : C C 7) SCALAR (EPSILON-EPSILON) PAIR TERMS: IF(ISISI.NE.0) THEN ITYPE = 8 C EPSILON-EPSILON: c if(icall.eq.0.and.nschr.eq.1) then c if(icall.eq.20.and.nschr.eq.1) then c vprgnn = 0.d0 c vprgll = 0.d0 c vprgls = 0.d0 c vprgss = 0.d0 c vprgdr = 0.d0 c endif DO 710 JJ=1,2 DO 710 KK=1,2 CALL FOOMPR(ITYPE,X,AMSIG(JJ),AMSIG(KK),ALMS1,ALMS1) AJK = ASIG(JJ)*ASIG(KK) IF(INA.EQ.1) THEN VCLL = VCLL -AJK*FACT*CCPR6(2)*FNONC VCSS = VCSS -AJK*FACT*CCPR6(4)*FNONC VCDR = VCDR -AJK*FACT*CCPR6(5)*FNONC ENDIF c if(icall.eq.0.and.nschr.eq.1) then c* if(icall.eq.20.and.nschr.eq.1) then c VPRGNN = VPRGNN -AJK*FACT*CCPR6(1)*FNONC c VPRGLL = VPRGLL -AJK*FACT*CCPR6(2)*FNONC c VPRGLS = VPRGLS -AJK*FACT*CCPR6(3)*FNONC c VPRGSS = VPRGSS -AJK*FACT*CCPR6(4)*FNONC c VPRGDR = VPRGDR -AJK*FACT*CCPR6(5)*FNONC c* endif 710 CONTINUE c if(icall.eq.0.and.nschr.eq.1) then c* if(icall.eq.-20.and.nschr.eq.1) then c write(*,*) ' OMPAIR: EPSILON-EPSILON:' c write(*,*) ' ccpr6=',ccpr6 c write(*,*) ' VCNN=',vprgnn,' VCDR=',vprgdr c write(*,*) ' VCLL=',vprgll,' VCLS=',vprgls,' VCSS=',vprgss c endif ENDIF C C 8) VECTOR (PION-A1) PAIR TERMS: C c IF(IPIA1.EQ.1) THEN c ENDIF C CC 1000 CALL ERRSET(208,256,1,1) ICALL=ICALL+1 RETURN END C ********************************************************************** SUBROUTINE FOOM(ITYP,X,AM1,AM2,ALM1,ALM2) C ********************************************************************** C C COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO PS-EXCHANGE C C ITYP = 1 : PS-PS, ITYP = 2 : PS-VCT, ITYP = 3 : PS-SCA, C ITYP = 4 : PS-DIF C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/ C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 CC DO 1 IMES=1,2 IF(IMES.EQ.1) THEN AMES = AM1 ALAM = ALM1 ENDIF IF(IMES.EQ.2) THEN AMES = AM2 ALAM = ALM2 ENDIF C NORMAL (I.E. NON-DIFFRACTIVE) CASE: IF(ALAM.NE.AMES) THEN RATP =PIM/ALAM RATPM=PIM/AMES XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI) DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA) XA =X*AMES/PIM RATA =AMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA DHIA =-(AMES/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3 F4A = 0.5D0*(PIM/AMES)*X*HIA DF4A = 0.5D0*(PIM/AMES)*(HIA+X*DHIA) DDF4A = 0.5D0*(PIM/AMES)*(2*DHIA+X*DDHIA) D3F4A = 0.5D0*(PIM/AMES)*(3*DDHIA+X*D3HIA) C NAIVELY: C F4A = 0.5D0*RATPM*(X*HIA -2*RATA**2*FIA) C DF4A = 0.5D0*RATPM*(HIA+X*DHIA -2*RATA**2*DFIA*RATPM) C DDF4A = 0.5D0*RATPM*(2*DHIA+X*DDHIA -2*RATA**2*DDFIA*RATPM) C D3F4A = 0.5D0*RATPM*(3*DDHIA+X*D3HIA -2*RATA**2*D3FIA*RATPM) ENDIF C DIFFRACTIVE CASE: IF(ALAM.EQ.AMES) THEN AMPOM = AMES RATD = 0.5D0*PIM/AMPOM XPOM = X*AMPOM/PIM FIPO = (4.D0/SRPI)*(AMPOM/PIM)*(AMPOM/AMPRO)**2* . FDEXP(-XPOM*XPOM) DFIPO = -2*(AMPOM/PIM)*XPOM*FIPO DDFIPO= -2*(AMPOM/PIM)*(XPOM*DFIPO + FIPO*AMPOM/PIM) D3FIPO= -2*(AMPOM/PIM)*(XPOM*DDFIPO + 2*DFIPO*AMPOM/PIM) FIA = FIPO DFIA = DFIPO DDFIA= DDFIPO D3FIA= D3FIPO F4A = FIA*RATD**2 DF4A = DFIA*RATD**2 DDF4A= DDFIA*RATD**2 D3F4A= D3FIA*RATD**2 ENDIF IF(IMES.EQ.1) THEN C N=2: C F2 = FIA DF2 = DFIA DDF2 = DDFIA D3F2 = D3FIA C N=4: C F4 = F4A DF4 = DF4A DDF4 = DDF4A D3F4 = D3F4A DVKU1 = DVKUA*(ALAM/PIM)**2 ENDIF IF(IMES.EQ.2) THEN C N=2: DG2 = DFIA DDG2 = DDFIA D3G2 = D3FIA C N=4: C G4 = F4A DG4 = DF4A DDG4 = DDF4A D3G4 = D3F4A DVKU2 = DVKUA*(ALAM/PIM)**2 ENDIF 1 CONTINUE C C CONSTRUCTION BASE FUNCTIONS C GOTO(100,200,200,200,500), ITYP 100 FNONC = +0.5D0*( . 6*X2*(DDF4-X1*DF4)*(DDG2-X1*DG2)+D3F4*D3G2 . +6*X2*(DDG4-X1*DG4)*(DDF2-X1*DF2)+D3G4*D3F2 ) FNONS = -(1.D0/3.D0)*( . X2*(DDF4-X1*DF4-X*D3F4)*(DDG2-X1*DG2-X*D3G2)-D3F4*D3G2 . +X2*(DDG4-X1*DG4-X*D3G4)*(DDF2-X1*DF2-X*D3F2)-D3G4*D3F2 ) FNONT = +(1.D0/6.D0)*( . 4*X2*(DDF4-X1*DF4-X*D3F4/4)*(DDG2-X1*DG2-X*D3G2/4) . +4*X2*(DDG4-X1*DG4-X*D3G4/4)*(DDF2-X1*DF2-X*D3F2/4) . -D3F4*D3G2/4-D3G4*D3F2/4 ) FNONO = -2*X2*( (DDF4-X1*DF4)*(DDG2-X1*DG2) . +(DDF2-X1*DF2)*(DDG4-X1*DG4) ) FPVC = +( (-2*X2*DF2+2*X1*DDF2+D3F2)*DG2 . +(-2*X2*DG2+2*X1*DDG2+D3G2)*DF2 ) FPVO = +(2*X1*(DF2*DDG2+DDF2*DG2)+4*X2*DF2*DG2) FOFFC = 0.5D0*( ((AM1/PIM)**2+(AM2/PIM)**2)*DF2*DG2 . -DVKU1*DG2-DF2*DVKU2 ) FOFFO = 0.5D0*( 2*X1*( DDF2*DG2+DF2*DDG2-2*X1*DF2*DG2 )) !april16 RETURN 200 FNONS = 0.5D0*( (D3F2+2*X1*DDF2-2*X2*DF2)*DG4 . +(D3F4+2*X1*DDF4-2*X2*DF4)*DG2 )/3.D0 FNONT = 0.5D0*( (D3F2- X1*DDF2+ X2*DF2)*DG4 . +(D3F4- X1*DDF4+ X2*DF4)*DG2 )/3.D0 FPVS = + DF2*DG2/3.D0 FPVT = FPVS FOFFS = 0.5D0*DF2*DG2 FOFFT = FOFFS RETURN 500 FNONC = 0.5D0*( DF2*DG4 + DF4*DG2 ) RETURN CC END C ********************************************************************** SUBROUTINE FOOMPR(ITYP,X,AM1,AM2,ALM1,ALM2) C ********************************************************************** C C COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO PS-EXCHANGE C C ITYP = 1 : (PIPI)_0 ITYP = 2 : (PIPI)_1, C ITYP = 3 : (PIRHO)_0 ITYP = 4 : (PIRHO)_1, C ITYP = 5 : (PI-OM) ITYP = 6 : (PISIG) C ITYP = 7 : (PIPOM) ITYP = 8 : (SI SI_) C C--------------------------------------------------------------- C FUN(1) = F*G , FUN(2) = DF*G , FUN(3) = F*DG , C FUN(4) = DF*DG , FUN(5) = DDF*G , FUN(6) = F*DDG , C FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG , C FUN(10)= D3F*DG C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2 . ,FASO DIMENSION XX(20),WW(20),YB(3),FUN(10),FUNPV(10) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/ DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/,ICALL/0/ c DATA YB/0.D0,5.D0,20.D0/,NINT/2/,NPNT/16/,IMETH/0/,ICALL/0/ DATA AKMAX/0000.D0/,XKMAX/1.D0/ SAVE XX,WW C C POTENTIAL FUNTION DEFINITION C F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C CALL ERRSET(208,256,-1,1) C IF(ICALL.EQ.0) THEN CALL GAUSS(NPNT,XX,WW,1) IF(IMETH.EQ.1) NINT=1 ICALL=1 ENDIF CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 CC DO 1 IMES=1,2 IF(IMES.EQ.1) THEN AMES = AM1 ALAM = ALM1 RATP1=PIM/ALAM ENDIF IF(IMES.EQ.2) THEN AMES = AM2 ALAM = ALM2 RATP2=PIM/ALAM ENDIF C NORMAL CASE (I.E. NON-DIFFRACTIVE) IF(ALAM.NE.AMES) THEN RATP =PIM/ALAM XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI) DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) XA =X*AMES/PIM RATA =AMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA DHIA =-(AMES/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 ENDIF C DIFFRACTIVE CASE: IF(ALAM.EQ.AMES) THEN AMPOM = AMES RATP2 = 0.5D0*PIM/AMPOM XLAM = X*AMPOM XPOM = X*AMPOM/PIM FIPO = (4.D0/SRPI)*(AMPOM/PIM)*(AMPOM/AMPRO)**2* . FDEXP(-XPOM*XPOM) DFIPO = -2*(AMPOM/PIM)*XPOM*FIPO DDFIPO= -2*(AMPOM/PIM)*(XPOM*DFIPO + FIPO*AMPOM/PIM) D3FIPO= -2*(AMPOM/PIM)*(XPOM*DDFIPO + 2*DFIPO*AMPOM/PIM) FIA = FIPO DFIA = DFIPO DDFIA= DDFIPO D3FIA= D3FIPO VKUA = FIPO DVKUA= DFIPO DDVKUA= DDFIPO ENDIF IF(IMES.EQ.1) THEN C N=2: C FINITE CUT-OFF CORRECTIONS: IF(ITYP.LE.7.AND.AMES.NE.ALAM.AND. .AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AMES,ALAM,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIA = FIA + DFIC0*AMES/PIM DFIA = DFIA + DFIC1*AMES/PIM DDFIA = DDFIA + DFIC2*AMES/PIM D3FIA = D3FIA + DFIC3*AMES/PIM ENDIF XLM1 = XLAM FI1 = FIA DFI1 = DFIA DDFI1 = DDFIA D3FI1 = D3FIA VKU1 = VKUA DVKU1 = DVKUA DDVKU1= DDVKUA ENDIF IF(IMES.EQ.2) THEN C N=2: C FINITE CUT-OFF CORRECTIONS: IF((ITYP.LE.2.OR.ITYP.EQ.5).AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AMES,ALAM,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIA = FIA + DFIC0*AMES/PIM DFIA = DFIA + DFIC1*AMES/PIM DDFIA = DDFIA + DFIC2*AMES/PIM D3FIA = D3FIA + DFIC3*AMES/PIM ENDIF XLM2 = XLAM FI2 = FIA DFI2 = DFIA DDFI2 = DDFIA D3FI2 = D3FIA VKU2 = VKUA DVKU2 = DVKUA ENDIF 1 CONTINUE C C CONSTRUCTION BASE FUNCTIONS BY INTEGRATION C IF(ITYP.EQ.2) GOTO 200 DO 105 II=1,10 FUN(II) = 0.D0 105 FUNPV(II) = 0.D0 DO 100 INT=1,NINT ABM=0.5D0*(YB(INT+1)-YB(INT)) ABP=0.5D0*(YB(INT+1)+YB(INT)) DO 110 IY=1,NPNT IF(IMETH.EQ.0) THEN Y=ABM*XX(IY)+ABP GEW=WW(IY)*ABM*2.D0/PI ENDIF IF(IMETH.EQ.1) THEN Y=(1.D0+XX(IY))/(1.D0-XX(IY)) GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI ENDIF IF(Y.GT.50.D0) GOTO 110 GEWNA = GEW/Y/Y C FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. : FDISP1=FDEXP(-Y*Y*RATP1*RATP1) FDISP2=FDEXP(-Y*Y*RATP2*RATP2) C AM=PIM*DSQRT((AM1/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM1 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM1+RATM) EPM =FDERFC( XLM1+RATM) C FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2 D3FIM =-(DDFIM-2*DDVKU1)*X1+(DFIM-2*DVKU1)*X2-(AM/PIM)*DDHIM . +(DFIM-2*DVKU1)*X2-2*(FIM-2*VKU1)*X3 C FINITE CUT-OFF CORRECTIONS: IF(ITYP.LE.7.AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AM,ALM1,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIM = FIM + DFIC0*AM/PIM DFIM = DFIM + DFIC1*AM/PIM DDFIM = DDFIM + DFIC2*AM/PIM D3FIM = D3FIM + DFIC3*AM/PIM ENDIF FIM1 = FIM DFIM1 = DFIM DDFIM1 = DDFIM D3FIM1 = D3FIM C IF(ITYP.NE.7) THEN AM=PIM*DSQRT((AM2/PIM)**2+Y*Y) XM=AM*X/PIM RATM =AM/ALM2 ERATM=FDEXP(RATM*RATM) EXM =FDEXP(XM) EMM =FDERFC(-XLM2+RATM) EPM =FDERFC( XLM2+RATM) FIM = F0(ERATM,EXM,EMM,EPM,X ) HIM = H0(ERATM,EXM,EMM,EPM,X ) DFIM =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM DHIM =-(AM/PIM)*FIM-HIM*X1 DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM C FINITE CUT-OFF CORRECTIONS: IF((ITYP.LE.2.OR.ITYP.EQ.5).AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AM,ALM2,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIM = FIM + DFIC0*AM/PIM DFIM = DFIM + DFIC1*AM/PIM DDFIM = DDFIM + DFIC2*AM/PIM c* D3FIM = D3FIM + DFIC3*AM/PIM ENDIF ENDIF IF(ITYP.EQ.7) THEN FIM = FI2 DFIM = DFI2 DDFIM = DDFI2 ENDIF FIM2 = FIM DFIM2 = DFIM DDFIM2 = DDFIM C FDISP = FDISP1*FDISP2 FUN(1) = FUN(1) + GEWNA*( FI1* FI2- FIM1* FIM2*FDISP) FUN(2) = FUN(2) + GEWNA*( DFI1* FI2- DFIM1* FIM2*FDISP) FUN(3) = FUN(3) + GEWNA*( FI1* DFI2- FIM1* DFIM2*FDISP) FUN(4) = FUN(4) + GEWNA*( DFI1* DFI2- DFIM1* DFIM2*FDISP) FUN(5) = FUN(5) + GEWNA*(DDFI1* FI2-DDFIM1* FIM2*FDISP) FUN(6) = FUN(6) + GEWNA*( FI1*DDFI2- FIM1*DDFIM2*FDISP) FUN(7) = FUN(7) + GEWNA*(DDFI1* DFI2-DDFIM1* DFIM2*FDISP) FUN(8) = FUN(8) + GEWNA*( DFI1*DDFI2- DFIM1*DDFIM2*FDISP) FUN(9) = FUN(9) + GEWNA*(DDFI1*DDFI2-DDFIM1*DDFIM2*FDISP) FUN(10)= FUN(10)+ GEWNA*(D3FI1* DFI2-D3FIM1* DFIM2*FDISP) FUNPV(2)= FUNPV(2)+ GEW*( DFIM1* FIM2*FDISP) FUNPV(3)= FUNPV(3)+ GEW*( FIM1* DFIM2*FDISP) FUNPV(4)= FUNPV(4)+ GEW*( DFIM1* DFIM2*FDISP) FUNPV(5)= FUNPV(5)+ GEW*(DDFIM1* FIM2*FDISP) FUNPV(6)= FUNPV(6)+ GEW*( FIM1*DDFIM2*FDISP) 110 CONTINUE 100 CONTINUE c* FPVS = 2*X1*FUNPV(3)+FUNPV(4)+FUNPV(6) c* FPVT =-1*X1*FUNPV(3)+FUNPV(4)-FUNPV(6) ! this is wrong , does not vanish at r=0 C C CONSTRUCTION BASE FUNCTIONS C C (PIPI)_{0}: IF(ITYP.EQ.1) THEN FNONC = FUN(9) + 2*X2*FUN(4) FNONO = 2*X2*FUN(4) FPVC = (FUNPV(5)+2*X1*FUNPV(2)) + (FUNPV(6)+2*X1*FUNPV(3)) FPVO = 2*X1*( FUNPV(2) + FUNPV(3) ) RETURN ENDIF C (PIPI)_{1}: 200 IF(ITYP.EQ.2) THEN FNONC = 2*(DDFI1*DDFI2+2*X2*DFI1*DFI2) FNONO = 4*X2*DFI1*DFI2 FPVC = (DDFI1+2*X1*DFI1)*VKU2/RATP2**2 . + (DDFI2+2*X1*DFI2)*VKU1/RATP1**2 FPVO = 2*X1*(DFI1*VKU2/RATP2**2 + DFI2*VKU1/RATP1**2) RETURN ENDIF C (PIOM)_{1}: IF(ITYP.EQ.5) THEN FPVS = 2*X1*FUNPV(3)+FUNPV(4)+FUNPV(6) FPVT = -X1*FUNPV(3)+FUNPV(4)+FUNPV(6) FASO = -X1*(FUNPV(2)+FUNPV(3)) RETURN ENDIF C {PI-SIGM}, {PI-POM}: IF(ITYP.EQ.6.OR.ITYP.EQ.7) THEN FNONS = -(+4*X2*FUN(4)-2*X1*FUN(7)-FUN(10)+FUN(9) ) FNONT = -(-2*X2*FUN(4)+ X1*FUN(7)-FUN(10)+FUN(9) ) FPVS = 2*X1*FUNPV(3)+FUNPV(6)-FUNPV(4) FPVT = -X1*FUNPV(3)+FUNPV(6)-FUNPV(4) RETURN ENDIF IF(ITYP.EQ.8) THEN FNONC = FUN(4) RETURN ENDIF CC 1000 CALL ERRSET(208,256,1,1) RETURN END C ********************************************************************** SUBROUTINE WROMPR(NCASE,X,P) C ********************************************************************** C C NCASE = 1,2,7 : VC ; NCASE = 3 : VC,VS,VT ; NCASE = 4,5,6 : VS,VT C IMPLICIT REAL*8(A-H,O-Z) COMMON/PROMPR/VPR(5,3,4,4,6) CHARACTER *4 NTYPM(4,4) DATA N3/27/,NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','PHI ','OM ', .'DE ','KAP ','S* ','EPS ','A2 ','K** ','POMP','POM '/ C write(n3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' if(ncase.eq.1) write(n3,101) if(ncase.eq.2) write(n3,102) if(ncase.eq.3) write(n3,103) if(ncase.eq.4) write(n3,104) if(ncase.eq.5) write(n3,105) if(ncase.eq.6) write(n3,106) if(ncase.le.3) JJ=1 if(ncase.eq.4) JJ=2 if(ncase.eq.5) JJ=3 if(ncase.eq.6) JJ=4 c if(ncase.le.3 .OR. ncase.eq.7) then write(n3,100) x write(n3,110) (NTYPM(KK,JJ),KK=1,4) 110 format(10x,4(3x,a4,5x)) write(n3,*)'-----------------------------------------------------' DO 111 II=1,4 111 write(n3,1) NTYPM(II,1),(VPR(1,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 112 II=1,4 112 write(n3,2) NTYPM(II,1),(VPR(2,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 113 II=1,4 113 write(n3,3) NTYPM(II,1),(VPR(3,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 114 II=1,4 114 write(n3,4) NTYPM(II,1),(VPR(4,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 115 II=1,4 115 write(n3,5) NTYPM(II,1),(VPR(5,1,II,KK,NCASE),KK=1,4) call wrsu3pr(1,ncase,x,p) c endif if(ncase.ge.3 .AND. ncase.ne.7) then write(n3,200) x write(n3,110) (NTYPM(KK,JJ),KK=1,4) write(n3,*)'-----------------------------------------------------' DO 211 II=1,4 211 write(n3,1) NTYPM(II,1),(VPR(1,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 212 II=1,4 212 write(n3,2) NTYPM(II,1),(VPR(2,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 213 II=1,4 213 write(n3,3) NTYPM(II,1),(VPR(3,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 214 II=1,4 214 write(n3,4) NTYPM(II,1),(VPR(4,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 215 II=1,4 215 write(n3,5) NTYPM(II,1),(VPR(5,2,II,KK,NCASE),KK=1,4) write(n3,*)'*****************************************************' call wrsu3pr(2,ncase,x,p) endif return 101 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :',/) 102 format(/,' SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} :',/) 103 format(/,' VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :',/) 104 format(/,' AXIAL (PION-RHO) PAIR TERMS OF THE FIRST CLASS:',/) 105 format(/,' PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:',/) 106 format(/,' PSEUDO SCALAR (PS-POMERON) PAIR TERMS:',/) 107 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :',/) 100 format(55('*'),/,' OMPAIR: CENTRAL POTENTIALS: x=',f7.3,/,55('*')) 200 format(55('*'),/,' OMPAIR: SPIN-SPIN POTENTIALS: x=',f7.3,/, .55('*')) 1 FORMAT(1x,'NN: ',A4,4(F10.2,2X)) 2 FORMAT(1x,'LL: ',A4,4(F10.2,2X)) 3 FORMAT(1x,'LS: ',A4,4(F10.2,2X)) 4 FORMAT(1x,'SS: ',A4,4(F10.2,2X)) 5 FORMAT(1x,'DR: ',A4,4(F10.2,2X)) end C ********************************************************************** SUBROUTINE WROMTM(NCASE,X,P) C ********************************************************************** C C NCASE = 1: PSEUDO-SCALAR-PSEUDO POTENTIALS, C NCASE = 2: PSEUDO-SCALAR-VECTOR POTENTIALS, C NCASE = 3: PSEUDO-SCALAR-SCALAR POTENTIALS, C NCASE = 4: PSEUDO-SCALAR-DIFFR. POTENTIALS. C NCASE = 5: SCALAR-SCALAR POTENTIALS. C NCASE = 6: SCALAR-DIFFRACTIVE POTENTIALS. C NCASE = 7: DIFFRA-DIFFRACTIVE POTENTIALS. C IMPLICIT REAL*8(A-H,O-Z) COMMON/PSBEOM/ VPSBE(5,4,4,4,7) CHARACTER*4 NTYPM(4,4) DATA N3/27/,NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','OM ','PHI ', .'DE ','KAP ','EPS ','S* ','A2 ','K** ','POM ','POMP'/ C if(ncase.le.4) i1=1 if(ncase.le.4) i2=ncase if(ncase.eq.5) i1=3 if(ncase.eq.5) i2=3 if(ncase.eq.6) i1=3 if(ncase.eq.6) i2=4 if(ncase.eq.7) i1=4 if(ncase.eq.7) i2=4 write(n3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' C write(n3,*)'*****************************************************' if(ncase.eq.1) write(n3,*) ' OMPSPS: CENTRAL POTENTIALS: x=',x if(ncase.ge.2.and.ncase.le.4) .write(n3,*) ' OMPSBE: CENTRAL POTENTIALS: x=',x if(ncase.eq.5) write(n3,*) ' OMSCSC: CENTRAL POTENTIALS: x=',x if(ncase.eq.6) write(n3,*) ' OMSCDF: CENTRAL POTENTIALS: x=',x if(ncase.eq.7) write(n3,*) ' OMDFDF: CENTRAL POTENTIALS: x=',x write(n3,*)'*****************************************************' write(n3,110) (NTYPM(KK,I2),KK=1,4) 110 format(10x,4(3x,a4,5x)) write(n3,*)'-----------------------------------------------------' DO 111 II=1,4 111 write(n3,112) NTYPM(II,I1),(VPSBE(1,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 113 II=1,4 113 write(n3,114) NTYPM(II,I1),(VPSBE(5,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 123 II=1,4 123 write(n3,124) NTYPM(II,I1),(VPSBE(2,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 125 II=1,4 125 write(n3,126) NTYPM(II,I1),(VPSBE(3,1,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 127 II=1,4 127 write(n3,128) NTYPM(II,I1),(VPSBE(4,1,II,KK,NCASE),KK=1,4) write(n3,*)'*****************************************************' call wrsu3tm(1,ncase,x,p) if(ncase.ge.5) return if(ncase.eq.1) write(n3,*) ' OMPSPS: SPIN-SPIN POTENTIALS: x=',x if(ncase.ge.2.and.ncase.le.4) .write(n3,*) ' OMPSBE: SPIN-SPIN POTENTIALS: x=',x if(ncase.eq.5) write(n3,*) ' OMSCSC: SPIN-SPIN POTENTIALS: x=',x if(ncase.eq.6) write(n3,*) ' OMSCDF: SPIN-SPIN POTENTIALS: x=',x if(ncase.eq.7) write(n3,*) ' OMDFDF: SPIN-SPIN POTENTIALS: x=',x write(n3,*)'*****************************************************' write(n3,115) (NTYPM(KK,I2),KK=1,4) 115 format(10x,4(3x,a4,5x)) write(n3,*)'-----------------------------------------------------' DO 116 II=1,4 116 write(n3,112) NTYPM(II,I1),(VPSBE(1,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 118 II=1,4 118 write(n3,114) NTYPM(II,I1),(VPSBE(5,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 120 II=1,4 120 write(n3,124) NTYPM(II,I1),(VPSBE(2,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 129 II=1,4 129 write(n3,126) NTYPM(II,I1),(VPSBE(3,2,II,KK,NCASE),KK=1,4) write(n3,*)'=====================================================' DO 131 II=1,4 131 write(n3,128) NTYPM(II,I1),(VPSBE(4,2,II,KK,NCASE),KK=1,4) write(n3,*)'*****************************************************' call wrsu3tm(2,ncase,x,p) RETURN 112 FORMAT(1x,'NN: ',A4,4(F10.2,2X)) 114 FORMAT(1x,'DR: ',A4,4(F10.2,2X)) 124 FORMAT(1x,'LL: ',A4,4(F10.2,2X)) 126 FORMAT(1x,'LS: ',A4,4(F10.2,2X)) 128 FORMAT(1x,'SS: ',A4,4(F10.2,2X)) C END WROMTM ROUTINE ************************************************** END C ********************************************************************** SUBROUTINE WRSU3TM(IV,NCASE,X,P) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PSBEOM/ VPR(5,4,4,4,7) DIMENSION VTOT(5) DATA N3/27/ C SUMMED CONTRIBUTIONS: DO 120 ICHAN=1,5 VTOT(ICHAN)=0.D0 DO 120 M=1,4 DO 120 N=1,4 120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE) if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/, . ' VCLS=',F10.2,3x,' VCSS=',F10.2,/) if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/, . ' VSLS=',F10.2,3x,' VSSS=',F10.2,/) C CONTRIBUTIONS TO SU(3)-POTENTIALS: if(p.eq.1.d0) then V27a = VTOT(1) V27b = VTOT(5) V27c = (9*VTOT(2)-VTOT(4))/8.D0 c V8Sa = 10*VTOT(2)-9*VTOT(5) V8Sa = VTOT(2)+3*VTOT(3) V8Sb = (10*VTOT(4)-VTOT(5))/9.D0 V8Sc = (9*VTOT(4)-VTOT(2))/8.D0 VLSa = (-3*V27b+3*V8Sa)/10.D0 VLSb = (-3*V27b+3*V8Sb)/10.D0 VLSc = (-3*V27c+3*V8Sc)/10.D0 write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc 123 format(/,' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/, . ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/, . ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2) endif if(p.eq.-1.d0) then V10 = VTOT(5) V10sa= VTOT(2)+VTOT(3) V10sb= VTOT(4)+VTOT(3) V8Aa = VTOT(2)-VTOT(3) V8Ab = VTOT(4)-VTOT(3) write(n3,124) V10sa,V10sb,V8Aa,V8Ab,V10 124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,/, . ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,' V10 =',F10.2,/) endif write(n3,*)'*****************************************************' RETURN END C ********************************************************************** SUBROUTINE WRSU3PR(IV,NCASE,X,P) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PROMPR/VPR(5,3,4,4,6) DIMENSION VTOT(5) DATA N3/27/ C SUMMED CONTRIBUTIONS: DO 120 ICHAN=1,5 VTOT(ICHAN)=0.D0 DO 120 M=1,4 DO 120 N=1,4 120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE) if(iv.eq.1) write(n3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/, . ' VCLS=',F10.2,3x,' VCSS=',F10.2,/) if(iv.eq.2) write(n3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/, . ' VSLS=',F10.2,3x,' VSSS=',F10.2,/) C CONTRIBUTIONS TO SU(3)-POTENTIALS: if(p.eq.1.d0) then V27a = VTOT(1) V27b = VTOT(5) V27c = (9*VTOT(2)-VTOT(4))/8.D0 c V8Sa = 10*VTOT(2)-9*VTOT(5) V8Sa = VTOT(2)+3*VTOT(3) V8Sb = (10*VTOT(4)-VTOT(5))/9.D0 V8Sc = (9*VTOT(4)-VTOT(2))/8.D0 VLSa = (-3*V27b+3*V8Sa)/10.D0 VLSb = (-3*V27b+3*V8Sb)/10.D0 VLSc = (-3*V27c+3*V8Sc)/10.D0 write(n3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc 123 format(' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/, . ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/, . ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2,/) endif if(p.eq.-1.d0) then V10 = VTOT(5) V10sa= VTOT(2)+VTOT(3) V10sb= VTOT(4)+VTOT(3) V8Aa = VTOT(2)-VTOT(3) V8Ab = VTOT(4)-VTOT(3) write(n3,124) V10sa,V10sb,V8Aa,V8Ab,V10 124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,/, . ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10 =',F10.2,/) endif write(n3,*)'*****************************************************' RETURN END C ********************************************************************** C VERSION DD. MARCH 2009: WRT OCTOBER 2008: C IPIOM.EQ.2: NO 1/M^2-TERMS, BUT KEPT FOR IPIRO1.EQ.1 ! C SPLITTING YNPAIR: YNPRCOP + YNPAIR C version with explicit pi-omega , pi-phi for ntype=6 C ********************************************************************** C FOR TREATMENT PAIR-EXCHANGES: C ********************************************************************** BLOCK DATA BLKDAT c subroutine setpar IMPLICIT REAL*8(A-H,O-Z) COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/2/, . IPISI/1/,ISISI/0/,IPIET/1/,IPIETP/0/,IPIPOM/1/, . IPIROV/0/,IPIOMV/0/,IKKB0/0/,IKKB1/0/,IPIA1/0/,IOMETA/0/ c DATA IPIPI0/0/,IPIPI1/1/,IPIRO1/0/,IPIRO0/0/,IPIOM/0/, c . IPISI/0/,ISISI/0/,IPIET/0/,IPIETP/0/,IPIPOM/0/, c . IPIROV/0/,IPIOMV/0/,IKKB0/0/,IKKB1/0/,IPIA1/0/ c* DATA N2PR0/1/,N2PR1/1/,N2PRV/0/,N2PRA/1/,N2PRB/1/ DATA N2PR0/0/,N2PR1/0/,N2PRV/0/,N2PRA/0/,N2PRB/0/ c return END C ********************************************************************** SUBROUTINE YNPRCOP(ICSB,NSU3F) C ********************************************************************** C * C C * COUPLINGS PION-MESON PAIR YN-POTENTIALS C * C IN COUPLING COMBINATIONS CENLL1 ETC.: C (i) YNCCPR: L+R contributions included, C (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams) C (iii) FFUN2: identical particle factor included (2 contractions), C facip=2. C C ALTERNATIVE NOMENCLATURE PAIR COUPLINGS: C GAPAIR=GPIRO1, HAPAIR=GPIRO0, GPPAIR=GPISI, GEPAIR=GSISI C PISI and PIRO1 a la paper II !! C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PRMTRS/PAR(20,8) COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA c COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11, c . G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11, c . FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11, c . FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11, c . GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11, c . GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX c DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11) c EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)) c . ,(GS1,GS(1)),(GD1,GD(1)) COMMON/COUPL/ F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX C DIMENSION PRF(11) C COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11), . PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11), . PRTEN(11),PRTENF(11) C communication with routine YNPRCC: C C !! NOTICE: THIS VERSION IN YNPRCC ALL COUPLINGS ARE ORDERED AS !!!!! C !! FOR THE PS-SCALARS !!!! !!!!! C COMMON/PRCPLS/CENPR(10),SIGPR(10) COMMON/CPLRIJ/FA(11),FB(11),PR(11) COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10), .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10) ,CCPR7(3,10), .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10), .CCPR11(4,10),CCPR11F(4,10) ! MARCH 2009 C DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/ COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI, .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB c SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7 DATA SONV/1D0/,SONPV/1D0/,SONSC/1D0/,SON1/1D0/ DATA ISU3/0/,ICALL/0/,NSCHR/0/ *** DATA ISU3/1/,ICALL/0/,NSCHR/1/ DATA I3P0/1/ data ipipi2/0/ C SU3-BREAKING IN PAIR COUPLINGS: IF(NSU3F.NE.1) THEN c SONV = PAR(10,7) c SONPV = PAR(11,7) c SONSC = PAR(12,7) SONV = PAR(13,7) SONPV = PAR(14,7) SONSC = PAR(15,7) SON1 = PAR(14,1) IF(I3P0.EQ.1) THEN SONPV = PAR(11,7) SONV = PAR(10,7) SONSC = PAR(10,7) SONVA = PAR(10,7) SON1 = PAR(10,7) ENDIF ENDIF C IF(NSU3F.EQ.1) THEN c* CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS) CC New organization: the next statements are wrong: CC because in amatlp ynpair-routine is called CC prior to OBE-routines! c? GS(9)=PAR(3,5) c? GD(9)=PAR(3,6) c? CALL SU3(F,ALP) c? CALL SU3(FD,ALVD) c? CALL SU3(FV,ALVV) c? CALL SU3(GS,ALS) c? CALL SU3(GD,ALD) ENDIF ALPBPR= PAR(19,1) IF(ALPBPR.EQ.0.D0) ALPBPR = ALP IF(ICALL.EQ.0) THEN IF(NSCHR.NE.0) PRINT 99, . IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV, . IPISI,ISISI,IPIET,IPIETP,IKKB0,IKKB1,IPIPOM, . GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIET,GPISI,GSISI,GPIRO0, . HOPAIR,GPIETP,GPIPOM . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR . ,SONV,SONPV,SONSC,SON1 c . ,N2PR0,N2PR1,N2PRV,N2PRA,N2PRB,PIM,DAM . ,F,FD,FV,GS,GD 99 FORMAT(//,' IN YNPRCOP:',//, . 11X,' IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV=',7I2,//, . 11X,' IPISI ,ISISI ,IPIET ,IPIETP,IKKB0 ,IKKB1,IPIPOM=',7I2,//, . 11X,' GSPAIR=',F10.5,' GVPAIR=',F10.5,' FVPAIR=',F10.5,//, . 11X,' GPIRO1=',F10.5,' GPIET =',F10.5,' GPISI =',F10.5,//, . 11X,' GSISI =',F10.5,' GPIRO0=',F10.5,' HOPAIR=',F10.5,//, . 11X,' GPIETP=',F10.5,' GPIPOM=',F10.5,//, . 11X,' ALPVPR=',F10.5,' ALVDPR=',F10.5,' ALVVPR=',F10.5,//, . 11X,' ALSCPR=',F10.5,' ALPAPR=',F10.5,' ALPBPR=',F10.5,//, . 11X,' SONVPR=',F10.5,' SONPPR=',F10.5,' SONSPR=',F10.5,//, . 11X,' SON{1}=',F10.5,//, c . 11X,' N2PR0,N2PR1 ,N2PRV ,N2PRA ,N2PRB =',5(I3,2X),/, c . 11X,' PIM=',F10.3,' DAM=',F10.3,//, . 11X,' F =',6(F10.5),/,17X,5(F10.5),/, . 11X,' FD =',6(F10.5),/,17X,5(F10.5),/, . 11X,' FV =',6(F10.5),/,17X,5(F10.5),/, . 11X,' GS =',6(F10.5),/,17X,5(F10.5),/, . 11X,' GD =',6(F10.5),/,17X,5(F10.5)) c ICALL=1 ENDIF C C CONSTRUCTION OF COUPLING COMBINATIONS C C !! NOTICE: THIS VERSION ALL COUPLINGS ARE ORDERED AS !!!!! C !! FOR THE PS-SCALARS!! !!!!! C C a) scalar SU(3)-singlet pair terms, {1}->{8}x{8} : C IF(IPIPI0.NE.0) THEN PR(1) = GSPAIR c PR(1) = GSPAIR*DCOS(THS) c PR(1) = GSPAIR*(1.D0-GPIET) DO 110 KK=1,11 FA(KK) = F(KK) 110 FB(KK) = F(KK) DO 111 II=1,3 CALL YNPRCC(1,II,ICSB,ALP,ALP,P) DO 111 KK=1,5 CCPR1(II,KK) = CENPR(KK) 111 CCPR1(II,KK+5) = CENPR(KK+5)*N2PR0 ENDIF C C b) scalar SU(3)-octet pair terms, {8s}->{8}x{8} : C IF(IPIET.NE.0) THEN PR(1) = GPIET PR(9) = 0.D0 CALL SU3(PR,ALSCPR) IF(SONSC.NE.1.D0) CALL SU3SB03(PR,ALSCPR,SONSC) DO 120 KK=1,11 if(icall.eq.0) prpe1(kk)=pr(kk) prpe1(kk)= pr(kk) FA(KK) = F(KK) 120 FB(KK) = F(KK) DO 121 II=1,7 CALL YNPRCC(2,II,ICSB,ALP,ALP,P) DO 121 KK=1,5 CCPR2(II,KK) = CENPR(KK) 121 CCPR2(II,KK+5) = CENPR(KK+5)*N2PR0 ENDIF C C c) vector SU(3)-octet pair terms, {8a}->{8}x{8} : C IF(IPIPI1.NE.0) THEN PR(1) = GVPAIR PR(9) = 0.D0 CALL SU3(PR,ALVDPR) IF(SONV.NE.1.D0) CALL SU3SB03(PR,ALVDPR,SONV) DO 130 KK=1,11 if(icall.eq.0) prppg(kk)=pr(kk) FA(KK) = F(KK) 130 FB(KK) = F(KK) DO 131 II=1,9 CALL YNPRCC(3,II,ICSB,ALP,ALP,P) DO 131 KK=1,5 CCPRG(II,KK) = SIGPR(KK) 131 CCPRG(II,KK+5) = SIGPR(KK+5)*N2PR1 PRF(1) = FVPAIR PRF(9) = 0.D0 CALL SU3(PRF,ALVVPR) IF(SONV.NE.1.D0) CALL SU3SB03(PRF,ALVVPR,SONV) DO 135 II=1,11 if(icall.eq.0) prppf(ii)=prf(ii) 135 PR(II) = PR(II)+PRF(II) DO 136 II=1,9 CALL YNPRCC(3,II,ICSB,ALP,ALP,P) DO 136 KK=1,5 CCPRF(II,KK) = SIGPR(KK) 136 CCPRF(II,KK+5) = SIGPR(KK+5)*N2PR1 ENDIF C C d) axial pair terms, {8a}->{8}x{8} : C IF(IPIRO1.NE.0) THEN PR(1) = GPIRO1 PR(9) = 0.D0 CALL SU3(PR,ALPAPR) IF(SONPV.NE.1.D0) CALL SU3SB03(PR,ALPAPR,SONPV) DO 140 KK=1,11 if(icall.eq.0) prpr1(kk)=pr(kk) FA(KK) = F(KK) 140 FB(KK) = FD(KK) call reordr(fb) ! NOTE: FD-ordering is .ne. F-ordering DO 141 II=1,9 CALL YNPRCC(3,II,ICSB,ALP,ALVD,P) DO 141 KK=1,5 CCPR4(II,KK) = SIGPR(KK) 141 CCPR4(II,KK+5) = SIGPR(KK+5)*N2PRA DO 145 KK=1,11 FA(KK) = F(KK) 145 FB(KK) = FV(KK) call reordr(fb) ! NOTE: FV-ordering is .ne. F-ordering DO 146 II=1,9 CALL YNPRCC(3,II,ICSB,ALP,ALVV,P) DO 146 KK=1,5 CCPR4F(II,KK) = SIGPR(KK) 146 CCPR4F(II,KK+5) = SIGPR(KK+5)*N2PRA ENDIF C C e) axial pair terms, {8}->{8}x{1} : C IF(IPISI.NE.0) THEN C PS-EPSILON CONTRIBUTIONS: PR(1) = GPISI c* PR(1) = GPISI*DCOS(THS) PR(9) = 0.D0 CALL SU3(PR,ALPAPR) DO 150 KK=1,11 if(icall.eq.0) prpsi(kk)=pr(kk) FA(KK) = F(KK) 150 FB(KK) = GS(KK) call reordr(fb) ! NOTE: GS-ordering is .ne. F-ordering DO 151 II=1,3 CALL YNPRCC(4,II,ICSB,ALP,ALS,P) DO 151 KK=1,5 CCPR5(II,KK) = SIGPR(KK) 151 CCPR5(II,KK+5) = SIGPR(KK+5)*N2PRA C PS-SSTAR CONTRIBUTIONS: c PR(1) = 0.D0 PR(1) =-GPISI*DSIN(THS) PR(9) = 0.D0 CALL SU3(PR,ALPAPR) DO 155 KK=1,11 FA(KK) = F(KK) 155 FB(KK) = GS(KK) call reordr(fb) ! NOTE: GS-ordering is .ne. F-ordering DO 156 II=4,6 CALL YNPRCC(4,II,ICSB,ALP,ALS,P) DO 156 KK=1,5 CCPR5(II,KK) = SIGPR(KK) 156 CCPR5(II,KK+5) = SIGPR(KK+5)*N2PRA ENDIF IF(IPIPOM.NE.0) THEN C PS-POMERON CONTRIBUTIONS: PR(1) = GPIPOM PR(9) = 0.D0 CALL SU3(PR,ALPAPR) DO 170 KK=1,11 if(icall.eq.0) prppo(kk)=pr(kk) FA(KK) = F(KK) 170 FB(KK) = GD(KK) call reordr(fb) DO 171 II=1,3 CALL YNPRCC(4,II,ICSB,ALP,ALD,P) DO 171 KK=1,5 CCPR7(II,KK) = SIGPR(KK) 171 CCPR7(II,KK+5) = SIGPR(KK+5)*N2PRA ENDIF C C f) SU(3)-singlet pair terms, {1}->{1}x{1} : C IF(ISISI.NE.0) THEN c PR(1) = GSISI*DCOS(THS) PR(1) = GSISI PR(2) = GSISI*DABS(SON1) PR(3) = GSISI*DABS(SON1) DO 160 KK=1,11 FA(KK) = GS(KK) 160 FB(KK) = GS(KK) call reordr(fa) call reordr(fb) DO 161 II=1,1 CALL YNPRCC(5,II,ICSB,ALS,ALS,P) DO 161 KK=1,5 CCPR6(KK) = CENPR(KK) 161 CCPR6(KK+5) = CENPR(KK+5)*N2PR0 ENDIF C C h) second-class axial pair terms, {8s}->{8}x{8} : C IF(IPIOM.NE.0) THEN C PI-OMEGA CONTRIBUTIONS: ALPBPR= PAR(19,1) IF(ALPBPR.EQ.0D0) ALPBPR= ALP c* PR(1) = GPIOM PR(1) = HOPAIR c* ./dsqrt(2d0) ! we choose to include this factor in xnprcc PR(9) = 0.D0 CALL SU3(PR,ALPBPR) DO 190 KK=1,11 if(icall.eq.0) prpo1(kk)=pr(kk) prpo1(kk)= pr(kk) FA(KK) = F(KK) 190 FB(KK) = FD(KK) call reordr(fb) DO 191 II=1,13 CALL YNPRCC(6,II,ICSB,ALP,ALVD,P) c* CALL YNPRCC(2,II,ICSB,ALP,ALVD,P) DO 191 KK=1,5 CCPR10(II,KK) = CENPR(KK) 191 CCPR10(II,KK+5) = CENPR(KK+5)*N2PRB ENDIF C C i) tensor SU(3)-octet pair terms, {8s}->{8}x{8} : C IF(IPIPI2.NE.0) THEN GTENPR = par(16,8) PR(1) = GTENPR PR(9) = 0.D0 ALTDPR = 0d0 CALL SU3(PR,ALTDPR) DO 220 KK=1,11 if(icall.eq.0) prten(kk)=pr(kk) FA(KK) = F(KK) 220 FB(KK) = F(KK) DO 221 II=1,7 CALL YNPRCC(2,II,ICSB,ALP,ALP,P) DO 221 KK=1,5 CCPR8(II,KK) = CENPR(KK) 221 CCPR8(II,KK+5) = CENPR(KK+5)*N2PR0 ftenpr = par(17,8) PRF(1) = FTENPR PRF(9) = 0.D0 ALTVPR = ALVVPR CALL SU3(PR,ALTVPR) DO 222 KK=1,11 if(icall.eq.0) prten(kk)=pr(kk) 222 PR(KK)=PR(KK)+PRF(KK) DO 223 II=1,7 CALL YNPRCC(2,II,ICSB,ALP,ALP,P) DO 223 KK=1,5 CCPR8F(II,KK) = CENPR(KK) 223 CCPR8F(II,KK+5) = CENPR(KK+5)*N2PR0 ENDIF c PRINT 199, ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR 199 FORMAT(/,' ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR=', .5F10.5,//) C ****************************************************************** if(icall.eq.0.and.ns.ne.0) then write(6,94) prpe1,prppg,prppf,prpr1,prpo1,prpsi,prppo, .prten,prtenf endif 94 format(/,72('*'),/,' Pair Coupling Constants:',/,72('-'),/, .' ',' nnp ',' ssp ',' lsp ',' lnk ', .' snk ',/,' ',' nne ',' lle ',' sse ', .' nnx ',' llx ',' ssx ',/,72('-'),/, .' gpie =',5f8.5,/,7x,6f8.5,//,' gpp1 =',5f8.5,/,7x,6f8.5,//, .' fpp1 =',5f8.5,/,7x,6f8.5,//,' gpr1 =',5f8.5,/,7x,6f8.5,//, .' gpo1 =',5f8.5,/,7x,6f8.5,//,' gpsi =',5f8.5,/,7x,6f8.5,//, .' gppo"=',5f8.5,/,7x,6f8.5,//,' gpp2 =',5f8.5,/,7x,6f8.5,//, .' fpp2 =',5f8.5,/,7x,6f8.5,//) C ****************************************************************** ICALL=1 RETURN END C ********************************************************************** SUBROUTINE REORDR(FA) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) DIMENSION FA(11) DO 5 JO=6,8 JS=JO+3 WOA=FA(JO) WSA=FA(JS) FA(JO)=WSA 5 FA(JS)=WOA RETURN END C ********************************************************************** C FOR SU(3)-SYMMETRIC TREATMENT PAIR-EXCHANGES: C ********************************************************************** SUBROUTINE SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PRMTRS/PAR(20,8) COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11) COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA THPS = 0.D0 THV = 0.D0 ! Why? For pi-omega? THS = 0.D0 c* ALVVPR = ALVDPR ! why? ALMP1=ALMP8 ALMV1=ALMV8 ALMS1=ALMS8 ALMKA=ALMP8 ALMKS=ALMV8 ALMKP=ALMS8 c* AMPRO= 1115.6D0 AMPRO= 938.2796D0 ! for FOOMPR c* AMN = 1115.6D0 AMN = AMPRO c* PIM = 200.D0 c* PIM = AMK ! GMO-value, see ynlp08.f AMPI = AMK ! GMO-value, see ynlp08.f c AMK = AMPI c BMK = AMPI c AME = AMPI c AMX = AMPI AMRO = 800.D0 AMEPS= 800.D0 AMOM = AMRO AMFI = AMRO AMKS = AMRO BMKS = AMRO AMD = AMEPS AMSCK= AMEPS AMSST= AMEPS AMSIG(1) = AMEPS AMSIG(2) = AMEPS ASIG(1) = 1.D0 ASIG(2) = 0.D0 AMVEC(1) = AMRO AMVEC(2) = AMRO AVEC(1) = 1.D0 AVEC(2) = 0.D0 PAR(11,6)=0.d0 ! AHYPC=0 RETURN END C ********************************************************************** SUBROUTINE YNPAIR(X,INA,IPV,ICSB,APV) C ********************************************************************** C * C VERSION WITH K-FORM FACTOR: ALMKA (SEPT. 2000) C C * PHENOMENOLOGICAL PION-MESON PAIR YN-POTENTIALS C * C PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET C VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET C SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET C * C IN CALLS AAFUN, ETC. SCHEMATICALLY: C FUN(1) = F*G, FUN(2) = DF*G, FUN(3) = F*DG, C FUN(4) = DF*DG, FUN(5) = DDF*G, FUN(6) = F*DDG, C FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG C C IN COUPLING COMBINATIONS CENLL1 ETC.: C (i) YNCCPR: L+R contributions included, C (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams) C (iii) FFUN2: identical particle factor included (2 contractions), C facip=2. C C FOR FORM FACTOR TREATMENT SEE: C TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990). C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/MODEL/IXXX(8),NSU3F COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR common/nn/vcnn,vsnn,vtnn,vonn COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11) COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX C COMMON/OOM/ INA,IPV,IOFF C DIMENSION FUN(12),WGHTID(2) C COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11), . PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11), . PRTEN(11),PRTENF(11) C communication with routine YNPRCC: C COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10), .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10) ,CCPR7(3,10), .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10), .CCPR11(4,10),CCPR11F(4,10) ! MARCH 2009 C communication with routine WRITEPR: COMMON/PRWRITE/VPRA(5,3,4,4),VPRB(5,3,4,4),VPRC(5,3,4,4) . ,VPRD(5,3,4,4),VPRE(5,3,4,4),VPRF(5,3,4,4) . ,VPRG(5,3,4,4),VPRH(5,3,4,4) C COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI, .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN c COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5, c . VALL1,VALL2,VALL3,VALL4,VALL5 DATA PI/3.14159265D0/,SRPI/1.7724538509D0/ DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/, . AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/, . AKMAX/0000.D0/,XKMAX/1.D0/, . AMLAM/1115D0/,AMSIGM/1190D0/ DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/ data ipipi2/0/ ! if ipipi2.ne.0 -> su3f-breaking!? SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL C if(p.eq.+1.d0) isfac=1 if(p.eq.-1.d0) isfac=-3 c* isu3=1 C WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING WGHTID(1) = DSIN(THV) WGHTID(2) = DCOS(THV) IF(ICALL.EQ.0) THEN PIM = PIM0 IF(NSU3F.EQ.1) CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS) C F1 = F(1) C GS6= GS(6) XBEGIN=X pim0=pim FACT = PIM0 c AMNC = DSQRT(AM(2)*AM(3)) c AMHY = DSQRT(AMY(1)*AMY(2)) C AMN = DSQRT(AMNN*AMH ) DAM = AMH-AMNN AA = DAM/PIM0 IF(NSCHR.NE.0) PRINT 99, IZSC,INA,IPV, . IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV, . IPISI,ISISI,IPIET,IPIETP,IKKB0,IKKB1,IPIPOM, . N2PR0,N2PR1,N2PRV,N2PRA,N2PRB,PIM,DAM,ALMKA, . AKMAX,XKMAX 99 FORMAT(//,' IN YNPAIR.NOV02: IZSC, INA, IPV=',3I3,//, . 11X,' IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV=',7I2,//, . 11X,' IPISI ,ISISI ,IPIET ,IPIETP,IKKB0 ,IKKB1,IPIPOM=',7I2,//, . 11X,' N2PR0,N2PR1 ,N2PRV ,N2PRA ,N2PRB =',5(I3,2X),/, . 11X,' PIM=',F10.3,' DAM=',F10.3,' ALMKA=',F10.3,//, . ' IN YNPAIR,FOOMPR: AKMAX=',F10.3,' XKMAX=',F10.3//) c ICALL=1 ENDIF if(p.ne.pold) then icall=0 pold=p nschr=1 endif c DO 1 I=2,NMAX c X = XA(I) VCLL =0.D0 VCLS =0.D0 VCSS =0.D0 VCDR =0.D0 VSLL =0.D0 VSLS =0.D0 VSSS =0.D0 VSDR =0.D0 VTLL =0.D0 VTLS =0.D0 VTSS =0.D0 VTDR =0.D0 VOLL =0.D0 VOLS =0.D0 VOSS =0.D0 VODR =0.D0 VALL =0.D0 VALS =0.D0 VASS =0.D0 VADR =0.D0 VCNN =0.D0 VSNN =0.D0 VTNN =0.D0 VONN =0.D0 DO 250 NCHAN=1,5 DO 250 ITYPV=1,3 DO 250 IMES1=1,4 DO 250 IMES2=1,4 VPRA(NCHAN,ITYPV,IMES1,IMES2)=0.D0 VPRB(NCHAN,ITYPV,IMES1,IMES2)=0.D0 VPRC(NCHAN,ITYPV,IMES1,IMES2)=0.D0 VPRD(NCHAN,ITYPV,IMES1,IMES2)=0.D0 VPRE(NCHAN,ITYPV,IMES1,IMES2)=0.D0 VPRF(NCHAN,ITYPV,IMES1,IMES2)=0.D0 250 VPRH(NCHAN,ITYPV,IMES1,IMES2)=0.D0 CC X1 =1.D0/X X2 =X1*X1 CC c CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI) c CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1) c CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU) CALL FFUN(2,X,AMPI,ALMP8,FI,DFI,DDFI,D3FI) CALL FFUN(1,X,AMPI,ALMP8,FI1,DFI1,DDFI1,D3FI1) CALL FFUN(0,X,AMPI,ALMP8,VKU,DVKU,DDVKU,D3VKU) C FINITE CUT-OFF CORRECTIONS: IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN c CALL DCOFUN(X,PIM,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) CALL DCOFUN(X,AMPI,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FI = FI + DFIC0 DFI = DFI + DFIC1 DDFI = DDFI + DFIC2 D3FI = D3FI + DFIC3 ENDIF C ETA: CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA) C FINITE CUT-OFF CORRECTIONS: IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AME,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIETA = FIETA + DFIC0*AME/PIM DFIETA = DFIETA + DFIC1*AME/PIM DDFETA = DDFETA + DFIC2*AME/PIM D3FETA = D3FETA + DFIC3*AME/PIM ENDIF C ETAP: CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP) C FINITE CUT-OFF CORRECTIONS: IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AMX,ALMP1,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIETP = FIETP + DFIC0*AMX/PIM DFIETP = DFIETP + DFIC1*AMX/PIM DDFETP = DDFETP + DFIC2*AMX/PIM D3FETP = D3FETP + DFIC3*AMX/PIM ENDIF C KAON: c* CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA) CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA) C FINITE CUT-OFF CORRECTIONS: IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN CALL DCOFUN(X,AMK,ALMKA,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) FIKA = FIKA + DFIC0*AMK/PIM DFIKA = DFIKA + DFIC1*AMK/PIM DDFKA = DDFKA + DFIC2*AMK/PIM D3FKA = D3FKA + DFIC3*AMK/PIM ENDIF CC c CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR) FIRO = 0.D0 DFIR = 0.D0 DDFIR = 0.D0 DO 410 JJ=1,2 CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ) FIRO = FIRO + AVEC(JJ)*FJJ DFIR = DFIR + AVEC(JJ)*DFJJ 410 DDFIR= DDFIR + AVEC(JJ)*DDFJJ C K*(892): CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS) CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO) CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH) CC c CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1) CC CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP) FIEP = 0.D0 DFIEP = 0.D0 DDFIEP= 0.D0 DO 510 JJ=1,2 IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) FIEP = FIEP + ASIG(JJ)*FJJ DFIEP= DFIEP + ASIG(JJ)*DFJJ 510 DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ C S*: IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST) C POMERON: XPOM = X*AMPOM/PIM0 FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2* . FDEXP(-XPOM*XPOM) DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0) C------------------------------------------------------------ C C CONSTRUCTION OF THE POTENTIALS C C------------------------------------------------------------ C A) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} : C IF(IPIPI0.NE.0) THEN DO 10 II=1,3 GOTO(11,12,13),II C PI-PI(I=0): 11 FFUN1 = 0.5D0*DFI*DFI c CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMPI,AMPI,ALMP8,ALMP8,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*FACIP c VCNN = VCNN + FACT*( c . 6*GSPAIR*F1**2*FFUN1 + 3*GSPAIR**2*FFUN2 )*FACIP IMES = 1 GOTO 14 C ETA-ETA: 12 FFUN1 = 0.5D0*DFIETA*DFIETA CALL HFUN(0,X,AME,AME,ALMP8,ALMP8,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*FACIP IMES = 3 GOTO 14 C KA-KA(I=0): 13 FFUN1 = 0.5D0*DFIKA*DFIKA c* CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN) FFUN2 = -0.5D0*FUN(1) IMES = 2 GOTO 14 14 CONTINUE VCLL = VCLL + FACT*( . CCPR1(II,2)*FFUN1 + CCPR1(II,7 )*FFUN2 ) VCSS = VCSS + FACT*( . CCPR1(II,4)*FFUN1 + CCPR1(II,9 )*FFUN2 ) VCDR = VCDR + FACT*( . CCPR1(II,5)*FFUN1 + CCPR1(II,10)*FFUN2 ) VPRA(1,1,IMES,IMES) = VPRA(1,1,IMES,IMES) + FACT*( . CCPR1(II,1)*FFUN1 + CCPR1(II,6 )*FFUN2 ) VPRA(2,1,IMES,IMES) = VPRA(2,1,IMES,IMES) + FACT*( . CCPR1(II,2)*FFUN1 + CCPR1(II,7 )*FFUN2 ) VPRA(4,1,IMES,IMES) = VPRA(4,1,IMES,IMES) + FACT*( . CCPR1(II,4)*FFUN1 + CCPR1(II,9 )*FFUN2 ) VPRA(5,1,IMES,IMES) = VPRA(5,1,IMES,IMES) + FACT*( . CCPR1(II,5)*FFUN1 + CCPR1(II,10)*FFUN2 ) 10 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(1,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(1,x,p) ENDIF C C B) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(IPIET.NE.0) THEN c DO 20 II=1,7 ! zie verschil met xnpairs: ii=1,10! c GOTO(21,22,23,24,25,26,27),II c* DO 20 III=1,10 DO 20 III=1,7 II = III GOTO(21,22,23,24,25,26,27,21,23,24),III II = III C PI-ETA: 21 FFUN1 = 0.5D0*DFI*DFIETA c CALL HFUN(0,X,PIM,AME,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMPI,AME,ALMP8,ALMP8,0.D0,FUN) FFUN2 = -0.5D0*FUN(1) FFSO1 = 0.D0 if(iii.eq.1) then IMES1 = 1 IMES2 = 3 endif if(iii.eq.8) then IMES1 = 3 IMES2 = 1 endif ii = 1 GOTO 28 C KA-KA(8S)(I=1): 22 FFUN1 = 0.5D0*DFIKA*DFIKA c* CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN) FFUN2 = -0.5D0*FUN(1) FFSO1 = 0.D0 IMES1 = 2 IMES2 = 2 GOTO 28 C PI-KA(8s): 23 FFUN1 = 0.5D0*DFI*DFIKA*P c* CALL HFUN(0,X,PIM,AMK,ALMP8,ALMP8,0.D0,FUN) c CALL HFUN(0,X,PIM,AMK,ALMP8,ALMKA,0.D0,FUN) CALL HFUN(0,X,AMPI,AMK,ALMP8,ALMKA,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*P FFSO1 = -X1*DFI*FIKA*P if(iii.eq.3) then IMES1 = 1 IMES2 = 2 endif if(iii.eq.9) then IMES1 = 2 IMES2 = 1 endif ii = 3 GOTO 28 C ETA-KA(8s): 24 FFUN1 = 0.5D0*DFIETA*DFIKA*P c* CALL HFUN(0,X,AME,AMK,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AME,AMK,ALMP8,ALMKA,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*P FFSO1 = -X1*DFIETA*FIKA*P if(iii.eq.4) then IMES1 = 2 IMES2 = 3 endif if(iii.eq.10) then IMES1 = 3 IMES2 = 2 endif ii = 4 GOTO 28 C PI-PI(8S)(I=0): 25 FFUN1 = 0.5D0*DFI*DFI c CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMPI,AMPI,ALMP8,ALMP8,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*FACIP c* FFUN2 = -0.5D0*FUN(1) FFSO1 = 0.D0 IMES1 = 1 IMES2 = 1 GOTO 28 C ETA-ETA(8s): 26 FFUN1 = 0.5D0*DFIETA*DFIETA CALL HFUN(0,X,AME,AME,ALMP8,ALMP8,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*FACIP c* FFUN2 = -0.5D0*FUN(1) FFSO1 = 0.D0 IMES1 = 3 IMES2 = 3 GOTO 28 C KA-KA(8S)(I=0): 27 FFUN1 = 0.5D0*DFIKA*DFIKA c* CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN) CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN) FFUN2 = -0.5D0*FUN(1) FFSO1 = 0.D0 IMES1 = 2 IMES2 = 2 GOTO 28 28 CONTINUE VCNN = VCNN + FACT*( . CCPR2(II,1)*FFUN1 + CCPR2(II,6)*FFUN2 ) VCLL = VCLL + FACT*( . CCPR2(II,2)*FFUN1 + CCPR2(II,7)*FFUN2 ) VCLS = VCLS + FACT*( . CCPR2(II,3)*FFUN1 + CCPR2(II,8)*FFUN2 ) VCSS = VCSS + FACT*( . CCPR2(II,4)*FFUN1 + CCPR2(II,9)*FFUN2 ) VCDR = VCDR + FACT*( . CCPR2(II,5)*FFUN1 + CCPR2(II,10)*FFUN2 ) c* if(x.le.0.05d0) write(*,*) 'ipiet: ii=',ii,' x=',x, c* .' vcdr=',vcdr,' vcnn=',vcnn c* if(x.le.0.05d0) write(*,*) 'ffun1=',ffun1 VPRB(1,1,IMES1,IMES2) = VPRB(1,1,IMES1,IMES2) + FACT*( . CCPR2(II,1)*FFUN1 + N2PR0*CCPR2(II,6)*FFUN2 ) VPRB(2,1,IMES1,IMES2) = VPRB(2,1,IMES1,IMES2) + FACT*( . CCPR2(II,2)*FFUN1 + N2PR0*CCPR2(II,7)*FFUN2 ) VPRB(3,1,IMES1,IMES2) = VPRB(3,1,IMES1,IMES2) + FACT*( . CCPR2(II,3)*FFUN1 + N2PR0*CCPR2(II,8)*FFUN2 ) VPRB(4,1,IMES1,IMES2) = VPRB(4,1,IMES1,IMES2) + FACT*( . CCPR2(II,4)*FFUN1 + N2PR0*CCPR2(II,9)*FFUN2 ) VPRB(5,1,IMES1,IMES2) = VPRB(5,1,IMES1,IMES2) + FACT*( . CCPR2(II,5)*FFUN1 + N2PR0*CCPR2(II,10)*FFUN2 ) 20 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(2,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(2,x,p) ENDIF C PI-ETA': c IF(IPIETP.EQ.1) THEN c VC = VC + FACT*ISFAC*GPIETP*( c . 2*FP*FETAP*DFI*DFIETP-0.5D0*GPIETP*FIPEP2) c ENDIF C C C) VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} : C C FOR IDENTICAL MESONS, WE HERE APPLY FACID=1.0D0!! c for non-identical mesons, we add a factor 2: P*2! C IF(IPIPI1.NE.0) THEN c* ALM1 = ALMP8 c* ALM2 = ALMP8 c* DO 30 II=1,9 DO 30 II=1,6 GOTO(31,32,33,34,341,35,33,34,341),II C PI-PI(I=1): c31 AM1 = PIM c AM2 = PIM 31 AM1 = AMPI AM2 = AMPI ALM1= ALMP8 ALM2= ALMP8 FFSIG1 = 0.5D0*X1*DFI*(X1*DFI+2*DDFI)*(PIM0/AMPRO) FFTEN1 = 0.5D0*X1*DFI*(X1*DFI-1*DDFI)*(PIM0/AMPRO) FFSO1 = X2*DFI*DFI*PIM0/AMPRO/2.D0 c PEX = 1.D0 PEX = FACID IMES1 = 1 IMES2 = 1 GOTO 36 C KA-KA(8A)(I=1): 32 AM1 = AMK AM2 = AMK ALM1= ALMKA ALM2= ALMKA FFSIG1 = 0.5D0*X1*DFIKA*(X1*DFIKA+2*DDFKA)*(PIM0/AMPRO) FFTEN1 = 0.5D0*X1*DFIKA*(X1*DFIKA-1*DDFKA)*(PIM0/AMPRO) FFSO1 = X2*DFIKA*DFIKA*PIM0/AMPRO/2.D0 c PEX = 1.D0 PEX = FACID IMES1 = 2 IMES2 = 2 GOTO 36 C PI-KA(8a): c33 AM1 = PIM 33 AM1 = AMPI AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FFSIG1 = 0.5D0*X1*(X1*DFI*DFIKA+DFI*DDFKA . + DDFI*DFIKA )*(PIM0/AMPRO) FFTEN1 = 0.25D0*X1*(2*X1*DFI*DFIKA-DFI*DDFKA . - DDFI*DFIKA )*(PIM0/AMPRO) FFSO1 = X2*DFI*DFIKA*PIM0/AMPRO/2.D0 PEX = P*2 IF(II.EQ.3) THEN IMES1 = 1 IMES2 = 2 ENDIF IF(II.EQ.7) THEN IMES1 = 2 IMES2 = 1 ENDIF GOTO 36 C ETA-KA(8a): 34 AM1 = AME AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FFSIG1 = 0.5D0*X1*(X1*DFIETA*DFIKA+DFIETA*DDFKA . + DDFETA*DFIKA )*(PIM0/AMPRO) FFTEN1 = 0.25D0*X1*(2*X1*DFIETA*DFIKA-DFIETA*DDFKA . - DDFETA*DFIKA)*(PIM0/AMPRO) FFSO1 = X2*DFIETA*DFIKA*PIM0/AMPRO/2.D0 PEX = P*2 IF(II.EQ.4) THEN IMES1 = 3 IMES2 = 2 ENDIF IF(II.EQ.8) THEN IMES1 = 2 IMES2 = 3 ENDIF GOTO 36 C ETAP-KA(8a): 341 AM1 = AMX AM2 = AMK ALM1= ALMP1 ALM2= ALMKA FFSIG1 = 0.5D0*X1*(X1*DFIETP*DFIKA+DFIETP*DDFKA . + DDFETP*DFIKA )*(PIM0/AMPRO) FFTEN1 = 0.25D0*X1*(2*X1*DFIETP*DFIKA-DFIETP*DDFKA . - DDFETP*DFIKA)*(PIM0/AMPRO) FFSO1 = X2*DFIETP*DFIKA*PIM0/AMPRO/2.D0 PEX = P*2 IF(II.EQ.5) THEN IMES1 = 4 IMES2 = 2 ENDIF IF(II.EQ.9) THEN IMES1 = 2 IMES2 = 4 ENDIF GOTO 36 C KA-KA(8A)(I=0): 35 AM1 = AMK AM2 = AMK ALM1= ALMKA ALM2= ALMKA FFSIG1 = 0.5D0*X1*(X1*DFIKA*DFIKA+2*DFIKA*DDFKA)*(PIM0/AMPRO) FFTEN1 = 0.5D0*X1*(X1*DFIKA*DFIKA-1*DFIKA*DDFKA)*(PIM0/AMPRO) FFSO1 = X2*DFIKA*DFIKA*PIM0/AMPRO/2.D0 PEX = FACID IMES1 = 2 IMES2 = 2 GOTO 36 36 FFSIG1 = FFSIG1*PEX FFTEN1 = FFTEN1*PEX FFSO1 = FFSO1*PEX ! was ik vergeten !! CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) FGCEN1 = 0.5D0*FUN(4)*PEX CALL FFUN(0,X,AM1,ALM1,FI10,DFI10,DDFI10,D3FI10) CALL FFUN(1,X,AM1,ALM1,FI11,DFI11,DDFI11,D3FI11) CALL FFUN(0,X,AM2,ALM2,FI20,DFI20,DDFI20,D3FI20) CALL FFUN(1,X,AM2,ALM2,FI21,DFI21,DDFI21,D3FI21) CALL HFUN(-1,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) HFUN0 = FUN(1) FGCEN2 = -.25D0*(FI11*FI20+FI10*FI21-4*HFUN0)*PEX CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) DA11 = FUN(4) DA12 = FUN(8) FFSIG2 = -.5D0*X1*(X1*DA11+2*DA12)*(PIM0/AMPRO)**2*PEX FFTEN2 = -.5D0*X1*(2*X1*DA11-2*DA12)*(PIM0/AMPRO)**2*PEX VCNN = VCNN + FACT*( CCPRG(II,1)*FGCEN1) c* . +CCPRG(II,6)*FGCEN2 ) VCLL = VCLL + FACT*( CCPRG(II,2)*FGCEN1) c* . +CCPRG(II,7)*FGCEN2 ) VCLS = VCLS + FACT*( CCPRG(II,3)*FGCEN1) c* . +CCPRG(II,8)*FGCEN2 ) VCSS = VCSS + FACT*( CCPRG(II,4)*FGCEN1) c* . +CCPRG(II,9)*FGCEN2 ) VCDR = VCDR + FACT*( CCPRG(II,5)*FGCEN1) c* . +CCPRG(II,10)*FGCEN2 ) VSNN = VSNN - FACT*( CCPRF(II,1)*FFSIG1/3.D0) c . + CCPRF(II,6)*FFSIG2/3.D0 ) VSLL = VSLL - FACT*( CCPRF(II,2)*FFSIG1/3.D0) c . + CCPRF(II,7)*FFSIG2/3.D0 ) VSLS = VSLS - FACT*( CCPRF(II,3)*FFSIG1/3.D0) c . + CCPRF(II,8)*FFSIG2/3.D0 ) VSSS = VSSS - FACT*( CCPRF(II,4)*FFSIG1/3.D0) c . + CCPRF(II,9)*FFSIG2/3.D0 ) VSDR = VSDR - FACT*( CCPRF(II,5)*FFSIG1/3.D0) c . + CCPRF(II,10)*FFSIG2/3.D0 ) VTNN = VTNN - FACT*( CCPRF(II,1)*FFTEN1/3.D0) c . + CCPRF(II,6)*FFTEN2/3.D0 ) VTLL = VTLL - FACT*( CCPRF(II,2)*FFTEN1/3.D0) c . + CCPRF(II,7)*FFTEN2/3.D0 ) VTLS = VTLS - FACT*( CCPRF(II,3)*FFTEN1/3.D0) c . + CCPRF(II,8)*FFTEN2/3.D0 ) VTSS = VTSS - FACT*( CCPRF(II,4)*FFTEN1/3.D0) c . + CCPRF(II,9)*FFTEN2/3.D0 ) VTDR = VTDR - FACT*( CCPRF(II,5)*FFTEN1/3.D0) c . + CCPRF(II,10)*FFTEN2/3.D0 ) VONN = VONN - FACT*( CCPRG(II,1)*FFSO1) VOLL = VOLL - FACT*( CCPRG(II,2)*FFSO1) VOLS = VOLS - FACT*( CCPRG(II,3)*FFSO1) VOSS = VOSS - FACT*( CCPRG(II,4)*FFSO1) VODR = VODR - FACT*( CCPRG(II,5)*FFSO1) c if(x.le.0.05d0) then c write(*,*) 'ynpair: ii=',ii,' x=',x, c .' vcnn,vcdr=',vcnn,vcdr,' vonn,vodr=',vonn,vodr c write(*,*) ' fgcen1=',fgcen1,' ccprg=',ccprg(ii,1),' vcnn=',vcnn c endif c write(*,*) 'ratco=',fgcen1/ffso1,' vc/vo(nn)=',vcnn/vonn, c . ' vc/vo(dr)=',vcdr/vodr c* write(*,*) 'ynpair: ii=',ii,' x=',x, c* .' vcnn,vcdr=',vcnn,vcdr,' vsnn,vsdr=',vsnn,vsdr c write(*,*) 'ratcs=',fgcen1/ffsig1, c .' vc/vs(nn)=',vcnn/vsnn,' vc/vs(dr)=',vcdr/vsdr c write(*,*) ' ccprg1-5=',ccprg(ii,1),ccprg(ii,2),ccprg(ii,3), c .ccprg(ii,4),ccprg(ii,5) c write(*,*) ' ccprg6- =',ccprg(ii,6),ccprg(ii,7),ccprg(ii,8), c .ccprg(ii,9),ccprg(ii,10) c write(*,*) ' ccprf1-5=',ccprf(ii,1),ccprf(ii,2),ccprf(ii,3), c .ccprf(ii,4),ccprf(ii,5) c write(*,*) ' ccprf6- =',ccprf(ii,6),ccprf(ii,7),ccprf(ii,8), c .ccprf(ii,9),ccprf(ii,10) c* endif VPRC(1,1,IMES1,IMES2) = VPRC(1,1,IMES1,IMES2) + FACT*( . CCPRG(II,1)*FGCEN1 +CCPRG(II,6)*FGCEN2 ) VPRC(2,1,IMES1,IMES2) = VPRC(2,1,IMES1,IMES2) + FACT*( . CCPRG(II,2)*FGCEN1 +CCPRG(II,7)*FGCEN2 ) VPRC(3,1,IMES1,IMES2) = VPRC(3,1,IMES1,IMES2) + FACT*( . CCPRG(II,3)*FGCEN1 +CCPRG(II,8)*FGCEN2 ) VPRC(4,1,IMES1,IMES2) = VPRC(4,1,IMES1,IMES2) + FACT*( . CCPRG(II,4)*FGCEN1 +CCPRG(II,9)*FGCEN2 ) VPRC(5,1,IMES1,IMES2) = VPRC(5,1,IMES1,IMES2) + FACT*( . CCPRG(II,5)*FGCEN1 +CCPRG(II,10)*FGCEN2 ) VPRC(1,2,IMES1,IMES2) = VPRC(1,2,IMES1,IMES2) - FACT*( . CCPRF(II,1)*FFSIG1/3.D0 ) c . + CCPRF(II,6)*FFSIG2/3.D0 ) VPRC(2,2,IMES1,IMES2) = VPRC(2,2,IMES1,IMES2) - FACT*( . CCPRF(II,2)*FFSIG1/3.D0 ) c . + CCPRF(II,7)*FFSIG2/3.D0 ) VPRC(3,2,IMES1,IMES2) = VPRC(3,2,IMES1,IMES2) - FACT*( . CCPRF(II,3)*FFSIG1/3.D0 ) c . + CCPRF(II,8)*FFSIG2/3.D0 ) VPRC(4,2,IMES1,IMES2) = VPRC(4,2,IMES1,IMES2) - FACT*( . CCPRF(II,4)*FFSIG1/3.D0 ) c . + CCPRF(II,9)*FFSIG2/3.D0 ) VPRC(5,2,IMES1,IMES2) = VPRC(5,2,IMES1,IMES2) - FACT*( . CCPRF(II,5)*FFSIG1/3.D0 ) c . + CCPRF(II,10)*FFSIG2/3.D0 ) 30 CONTINUE if(icall.eq.0.and.nschr.eq.1) call writepr(3,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(3,x,p) ENDIF C C 3) AXIAL PAIR TERMS OF THE FIRST CLASS: C IF(IPIRO1.NE.0) THEN c* ALM1 = ALMP8 ALM2 = ALMV8 DO 40 II=1,9 FMASO1= 0.D0 FMASO2= 0.D0 FACISC= 0.D0 GOTO(41,42,43,44,488,45,46,47,49),II C PI-RHO(I=1): 41 FMSIG1= 0.5D0* (2*X1*DFI+DDFI)*FIRO FESIG1= 0.5D0* DFI*DFIR FMTEN1= 0.5D0* (-X1*DFI+DDFI)*FIRO c AM1 = PIM AM1 = AMPI AM2 = AMRO ALM1= ALMP8 PEX = 1.D0 IMES1 = 1 IMES2 = 1 GOTO 48 C KA-K*(AXIAL)(I=1): 42 FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS FESIG1= 0.5D0* DFIKA*DFIKS FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIKS AM1 = AMK AM2 = AMKS ALM1= ALMKA PEX = 1.D0 IMES1 = 2 IMES2 = 2 GOTO 48 C PI-K*(AXIAL): 43 FMSIG1= 0.5D0* (2*X1*DFI+DDFI)*FIKS*P FESIG1= 0.5D0* DFI*DFIKS*P FMTEN1= 0.5D0* (-X1*DFI+DDFI)*FIKS*P c AM1 = PIM AM1 = AMPI AM2 = AMKS ALM1= ALMP8 PEX = P IMES1 = 1 IMES2 = 2 GOTO 48 C ETA-K*(AXIAL): 44 FMSIG1= 0.5D0* (2*X1*DFIETA+DDFETA)*FIKS*P FESIG1= 0.5D0* DFIETA*DFIKS*P FMTEN1= 0.5D0* (-X1*DFIETA+DDFETA)*FIKS*P AM1 = AME AM2 = AMKS ALM1= ALMP8 PEX = P IMES1 = 3 IMES2 = 2 GOTO 48 C ETA'-K*(AXIAL): 488 FMSIG1= 0.5D0* (2*X1*DFIETP+DDFETP)*FIKS*P FESIG1= 0.5D0* DFIETP*DFIKS*P FMTEN1= 0.5D0* (-X1*DFIETP+DDFETP)*FIKS*P AM1 = AMX AM2 = AMKS ALM1= ALMP1 PEX = P IMES1 = 4 IMES2 = 2 GOTO 48 C KA-K*(AXIAL)(I=0): 45 FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS FESIG1= 0.5D0* DFIKA*DFIKS FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIKS AM1 = AMK AM2 = AMKS ALM1= ALMKA PEX = 1.D0 IMES1 = 2 IMES2 = 2 GOTO 48 C KA-RO(AXIAL): 46 FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIRO*P FESIG1= 0.5D0* DFIKA*DFIR*P FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIRO*P AM1 = AMK AM2 = AMRO ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 1 GOTO 48 C KA-PHI(AXIAL): 47 FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIPH*P FESIG1= 0.5D0* DFIKA*DFIPH*P FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIPH*P AM1 = AMK AM2 = AMFI ALM1= ALMKA ALM2= ALMV8 PEX = P IMES1 = 2 IMES2 = 3 GOTO 48 C KA-OMEGA(AXIAL): 49 FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIOM*P FESIG1= 0.5D0* DFIKA*DFIOM*P FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIOM*P AM1 = AMK AM2 = AMOM ALM1= ALMKA ALM2= ALMV1 PEX = P IMES1 = 2 IMES2 = 4 GOTO 48 48 FFSIG1 = FMSIG1 FFTEN1 = FMTEN1 FETEN1 = FESIG1 CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) FFSIG2 = -.5D0*FUN(1)*PEX c if(x.lt.0.05d0) then c write(*,*) ' in ynpairs: ii,x=',ii,x,' am1,am2=',am1,am2, c .' alm1,alm2=',alm1,alm2 c write(*,*) ' ffsig1,fften1,feten1,ffsig2=', c . ffsig1,fften1,feten1,ffsig2 c endif c if(ii.eq.3) then c vsig3 = 2*fact*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 c . *(pim0/amn/6d0) c write(*,*) 'YNPAIR: II=',ii,' vsig3 =',vsig3 c endif VSNN = VSNN - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFSIG1 . -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 ) . - CCPR4(II,6)*FFSIG2 ) VSLL = VSLL - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFSIG1 . -2*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 ) . - CCPR4(II,7)*FFSIG2 ) VSLS = VSLS - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFSIG1 . -2*(CCPR4(II,3)+CCPR4F(II,3))*FESIG1 ) . - CCPR4(II,8)*FFSIG2 ) VSSS = VSSS - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFSIG1 . -2*(CCPR4(II,4)+CCPR4F(II,4))*FESIG1 ) . - CCPR4(II,9)*FFSIG2 ) VSDR = VSDR - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFSIG1 . -2*(CCPR4(II,5)+CCPR4F(II,5))*FESIG1 ) . - CCPR4(II,10)*FFSIG2 ) VTNN = VTNN - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFTEN1 . + (CCPR4(II,1)+CCPR4F(II,1))*FETEN1 )) VTLL = VTLL - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFTEN1 . + (CCPR4(II,2)+CCPR4F(II,2))*FETEN1 )) VTLS = VTLS - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFTEN1 . + (CCPR4(II,3)+CCPR4F(II,3))*FETEN1 )) VTSS = VTSS - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFTEN1 . + (CCPR4(II,4)+CCPR4F(II,4))*FETEN1 )) VTDR = VTDR - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFTEN1 . + (CCPR4(II,5)+CCPR4F(II,5))*FETEN1 )) VPRD(1,2,IMES1,IMES2) = VPRD(1,2,IMES1,IMES2) - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFSIG1 . -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 ) . - CCPR4(II,6)*FFSIG2 ) VPRD(2,2,IMES1,IMES2) = VPRD(2,2,IMES1,IMES2) - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFSIG1 . -2*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 ) . - CCPR4(II,7)*FFSIG2 ) VPRD(3,2,IMES1,IMES2) = VPRD(3,2,IMES1,IMES2) - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFSIG1 . -2*(CCPR4(II,3)+CCPR4F(II,3))*FESIG1 ) . - CCPR4(II,8)*FFSIG2 ) VPRD(4,2,IMES1,IMES2) = VPRD(4,2,IMES1,IMES2) - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFSIG1 . -2*(CCPR4(II,4)+CCPR4F(II,4))*FESIG1 ) . - CCPR4(II,9)*FFSIG2 ) VPRD(5,2,IMES1,IMES2) = VPRD(5,2,IMES1,IMES2) - FACT*( . (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFSIG1 . -2*(CCPR4(II,5)+CCPR4F(II,5))*FESIG1 ) . - CCPR4(II,10)*FFSIG2 ) c if(x.le.0.05d0) then c write(*,*) 'ccpr4(ii,1),ccpr4f(ii,1)=',ccpr4(ii,1),ccpr4f(ii,1) c write(*,*) 'ccpr4(ii,2),ccpr4f(ii,2)=',ccpr4(ii,2),ccpr4f(ii,2) c write(*,*) 'ccpr4(ii,3),ccpr4f(ii,3)=',ccpr4(ii,3),ccpr4f(ii,3) c write(*,*) 'ccpr4(ii,4),ccpr4f(ii,4)=',ccpr4(ii,4),ccpr4f(ii,4) c write(*,*) 'ccpr4(ii,5),ccpr4f(ii,5)=',ccpr4(ii,5),ccpr4f(ii,5) c write(*,*) 'ynpair: ii=',ii,' x=',x, c .' vsnn,vsdr=',vsnn,vsdr,' vtnn,vtdr=',vtnn,vtdr c endif 40 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(4,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(4,x,p) ENDIF C C 4) AXIAL PAIR TERMS OF THE SECOND CLASS: C c IF(IPIRO0.EQ.1) THEN c VSIG = VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2 c . -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) ) c c VTEN = VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2 c . -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) ) c ENDIF C C 5) AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) : c IF(IPIOM.EQ.1) THEN c IF(HOPAIR.NE.0.D0) THEN c VSIG = VSIG + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c VTEN = VTEN + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c ENDIF c ENDIF C------------------------------------------------------------ C C E) AXIAL PAIR TERMS OF THE SECOND CLASS: C C------------------------------------------------------------ C HERE: ETA8 = ETA(548) (THPS IS SMALL), C PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019) C------------------------------------------------------------ IF(IPIOM.EQ.2) THEN c** DO 90 II=IIMIN,10 DO 90 II=1,13 PEX = 1.D0 FFSO1 = 0.D0 copln = 0d0 GOTO(91,911,92,93,94,95,96,97,971,98,981,991,992),II C PI-OMEGA 91 FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIOM+DFI*DFIOM)*WGHTID(1) FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIOM+DFI*DFIOM)*WGHTID(1) c CALL HFUN(0,X,PIM,AMOM,ALMP8,ALMV1,0.D0,FUN) CALL HFUN(0,X,AMPI,AMOM,ALMP8,ALMV1,0.D0,FUN) GOTO 990 C PI-PHI: 911 FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIPH+DFI*DFIPH)*WGHTID(2) FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIPH+DFI*DFIPH)*WGHTID(2) c CALL HFUN(0,X,PIM,AMFI,ALMP8,ALMV8,0.D0,FUN) CALL HFUN(0,X,AMPI,AMFI,ALMP8,ALMV8,0.D0,FUN) IMES1 = 1 IMES2 = 3 GOTO 990 C ETA-RHO: 92 FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIRO+DFIETA*DFIR ) FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIRO+DFIETA*DFIR ) CALL HFUN(0,X,AME,AMRO,ALMP8,ALMV8,0.D0,FUN) IMES1 = 3 IMES2 = 1 GOTO 990 C KA-K*(8S)(I=1): 93 FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS ) FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS ) CALL HFUN(0,X,AMK,AMKS,ALMP8,ALMV8,0.D0,FUN) IMES1 = 2 IMES2 = 2 GOTO 990 C PI-K*(8S): 94 FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIKS+DFI*DFIKS )*P FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIKS+DFI*DFIKS )*P c CALL HFUN(0,X,PIM,AMKS,ALMP8,ALMV8,0.D0,FUN) CALL HFUN(0,X,AMPI,AMKS,ALMP8,ALMV8,0.D0,FUN) IMES1 = 1 IMES2 = 2 PEX = P GOTO 990 C KA-RHO(8S)(I=1): 95 FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIRO+DFIKA*DFIR )*P FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIRO+DFIKA*DFIR )*P CALL HFUN(0,X,AMK,AMRO,ALMP8,ALMV8,0.D0,FUN) IMES1 = 2 IMES2 = 1 PEX = P FFSO1 = -X1*DFIR*VKU*P copln = 1*prpo1(4)*f(4)*(fd(1)+fv(1)) GOTO 990 C ETA-K*: 96 FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIKS+DFIETA*DFIKS )*P FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIKS+DFIETA*DFIKS )*P CALL HFUN(0,X,AME,AMKS,ALMP8,ALMV8,0.D0,FUN) IMES1 = 3 IMES2 = 2 PEX = P GOTO 990 C KA-PHI8: C KA-OMEGA: 97 FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIOM+DFIKA*DFIOM) .*WGHTID(1)*P FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIOM+DFIKA*DFIOM) .*WGHTID(1)*P CALL HFUN(0,X,AMK,AMOM,ALMP8,ALMV1,0.D0,FUN) PEX = P FFSO1 = -X1*DFIOM*VKU*P copln = 1*prpo1(4)*f(4)*(fd(6)+fv(6)) GOTO 990 C KA-PHI: 971 FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIPH+DFIKA*DFIPH) .*WGHTID(2)*P FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIPH+DFIKA*DFIPH) .*WGHTID(2)*P CALL HFUN(0,X,AMK,AMFI,ALMP8,ALMV8,0.D0,FUN) IMES1 = 2 IMES2 = 3 PEX = P FFSO1 = -X1*DFIPH*VKU*P copln = 1*prpo1(4)*f(4)*(fd(9)+fv(9)) GOTO 990 C PI-RHO(8S)(I=0): 98 FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIRO+DFI*DFIR ) FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIRO+DFI*DFIR ) c CALL HFUN(0,X,PIM,AMRO,ALMP8,ALMV8,0.D0,FUN) CALL HFUN(0,X,AMPI,AMRO,ALMP8,ALMV8,0.D0,FUN) IMES1 = 1 IMES2 = 1 GOTO 990 C KA-K*(8S)(I=0): 981 FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS ) FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS ) CALL HFUN(0,X,AMK,AMKS,ALMP8,ALMV8,0.D0,FUN) IMES1 = 2 IMES2 = 2 GOTO 990 C ETA-OMEGA(8s): 991 FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM) .*WGHTID(1) FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM) .*WGHTID(1) CALL HFUN(0,X,AME,AMOM,ALMP8,ALMV1,0.D0,FUN) GOTO 990 C ETA-PHI(8s): 992 FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH) .*WGHTID(2) FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH) .*WGHTID(2) CALL HFUN(0,X,AME,AMFI,ALMP8,ALMV8,0.D0,FUN) IMES1 = 3 IMES2 = 3 GOTO 990 990 FFSIG2 = -0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) +2*FUN(4) )*PEX FFTEN2 = -0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )*PEX c !!! note: checked with nnpairs.f -> reason 'extra' factor 4 -> !!!!! c !!! note: NO EXTRA FACTOR HERE: UFAC0=4.D0 ! old, factor 2 overshoot a la NN-program! c* UFAC0=2.D0 ! -> the correct factor! c* UFAC0=1.D0 ! new,check!! c* if(icall.eq.0) write(6,*) ' ynpairs.02.f: UFAC0=',ufac0,' !!!!!' VSNN = VSNN + FACT*(UFAC0* . CCPR10(II,1)*FFSIG1 + CCPR10(II,6)*FFSIG2 )/3.D0 VSLL = VSLL + FACT*(UFAC0* . CCPR10(II,2)*FFSIG1 + CCPR10(II,7)*FFSIG2 )/3.D0 VSLS = VSLS + FACT*(UFAC0* . CCPR10(II,3)*FFSIG1 + CCPR10(II,8)*FFSIG2 )/3.D0 VSSS = VSSS + FACT*(UFAC0* . CCPR10(II,4)*FFSIG1 + CCPR10(II,9)*FFSIG2 )/3.D0 VSDR = VSDR + FACT*(UFAC0* . CCPR10(II,5)*FFSIG1 + CCPR10(II,10)*FFSIG2 )/3.D0 VTNN = VTNN + FACT*(UFAC0* . CCPR10(II,1)*FFTEN1 + CCPR10(II,6)*FFTEN2 )/3.D0 VTLL = VTLL + FACT*(UFAC0* . CCPR10(II,2)*FFTEN1 + CCPR10(II,7)*FFTEN2 )/3.D0 VTLS = VTLS + FACT*(UFAC0* . CCPR10(II,3)*FFTEN1 + CCPR10(II,8)*FFTEN2 )/3.D0 VTSS = VTSS + FACT*(UFAC0* . CCPR10(II,4)*FFTEN1 + CCPR10(II,9)*FFTEN2 )/3.D0 VTDR = VTDR + FACT*(UFAC0* . CCPR10(II,5)*FFTEN1 + CCPR10(II,10)*FFTEN2 )/3.D0 c VALL = VALL + 2*FACT* copln*FFSO1*PIM0**2/AMN/(AMLAM+AMN) c write(*,*) ' ynpairs, piom: ii=',ii,' copln=',copln, c .' prpo1(4)=',prpo1(4) c write(*,*) ' FFSO1=',FFSO1,' vall=',vall VPRH(1,2,IMES1,IMES2) = VPRH(1,2,IMES1,IMES2) + FACT*( . 1*CCPR10(II,1)*FFSIG1 + CCPR10(II,6)*FFSIG2 )/3.D0 VPRH(2,2,IMES1,IMES2) = VPRH(2,2,IMES1,IMES2) + FACT*( . 1*CCPR10(II,2)*FFSIG1 + CCPR10(II,7)*FFSIG2 )/3.D0 VPRH(3,2,IMES1,IMES2) = VPRH(3,2,IMES1,IMES2) + FACT*( . 1*CCPR10(II,3)*FFSIG1 + CCPR10(II,8)*FFSIG2 )/3.D0 VPRH(4,2,IMES1,IMES2) = VPRH(4,2,IMES1,IMES2) + FACT*( . 1*CCPR10(II,4)*FFSIG1 + CCPR10(II,9)*FFSIG2 )/3.D0 VPRH(5,2,IMES1,IMES2) = VPRH(5,2,IMES1,IMES2) + FACT*( . 1*CCPR10(II,5)*FFSIG1 + CCPR10(II,10)*FFSIG2 )/3.D0 c if(x.le.0.05d0) then c write(*,*) 'ccpr10(ii,1)=',ccpr10(ii,1), c . 'ccpr10(ii,2)=',ccpr10(ii,2) c write(*,*) 'ccpr10(ii,3)=',ccpr10(ii,3), c . 'ccpr10(ii,4)=',ccpr10(ii,4) c write(*,*) 'ccpr10(ii,5)=',ccpr10(ii,5) c write(*,*) 'ynpair: ii=',ii,' x=',x, c .' vsnn,vsdr=',vsnn,vsdr,' vtnn,vtdr=',vtnn,vtdr c write(*,*) 'ratst=',fgsig1/ften1,' vs/vt(nn)=',vsnn/vtnn, c . ' vs/vt(dr)=',vsdr/vtdr c endif 90 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(8,x,p) c* if(icall.eq.20.and.nschr.eq.1) write(37,*) 'ccpr10=',ccpr10 c* if(icall.eq.20.and.nschr.eq.1) call writepr(8,x,p) ENDIF C------------------------------------------------------------ C C 6) PSEUDO SCALAR (PION-EPSILON) PAIR TERMS: IF(IPISI.NE.0) THEN DO 50 II=1,6 GOTO(51,52,53,54,55,56),II C PI-EPSILON: 51 FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIEP -DFI*DFIEP) FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIEP -DFI*DFIEP ) c AM1 = PIM AM1 = AMPI ALM1= ALMP8 PEX = 1.D0 IMES1 = 1 IMES2 = 4 GOTO 57 C KA-EPSILON: 52 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P AM1 = AMK ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 4 GOTO 57 C ETA-EPSILON: 53 FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIEP -DFIETA*DFIEP) FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIEP -DFIETA*DFIEP ) AM1 = AME ALM1= ALMP8 PEX = 1.D0 IMES1 = 3 IMES2 = 4 GOTO 57 C PI-SSTAR: 54 FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIST -DFI*DFIST) FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIST -DFI*DFIST ) c AM1 = PIM AM1 = AMPI AM2 = AMSST ALM1= ALMP8 PEX = 1.D0 IMES1 = 1 IMES2 = 3 GOTO 57 C KA-SSTAR: 55 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P AM1 = AMK AM2 = AMSST ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 3 GOTO 57 C ETA-SSTAR: 56 FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIST -DFIETA*DFIST) FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIST -DFIETA*DFIST ) AM1 = AME AM2 = AMSST ALM1= ALMP8 PEX = 1.D0 IMES1 = 3 IMES2 = 3 GOTO 57 57 IF(II.LE.3) THEN FFSIG2 = 0.D0 FFTEN2 = 0.D0 IF(N2PRA.EQ.1) THEN DO 112 JJ=1,2 AM2=AMSIG(JJ) CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN) FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX 112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF ELSE CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN) FFSIG2 = +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX FFTEN2 = +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF VSNN = VSNN + FACT*( . CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0 VSLL = VSLL + FACT*( . CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0 VSLS = VSLS + FACT*( . CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0 VSSS = VSSS + FACT*( . CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0 VSDR = VSDR + FACT*( . CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0 VTNN = VTNN + FACT*( . CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0 VTLL = VTLL + FACT*( . CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0 VTLS = VTLS + FACT*( . CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0 VTSS = VTSS + FACT*( . CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0 VTDR = VTDR + FACT*( . CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0 c* if(x.le.0.05d0) write(*,*) 'ipisi: ii=',ii,' x=',x,' vsdr=',vsdr, c* .' vcnn=',vsnn c* if(x.le.0.05d0) write(*,*) 'ffsig1=',ffsig1 VPRE(1,2,IMES1,IMES2) = + FACT*( . 1*CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0 VPRE(2,2,IMES1,IMES2) = + FACT*( . 1*CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0 VPRE(3,2,IMES1,IMES2) = + FACT*( . 1*CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0 VPRE(4,2,IMES1,IMES2) = + FACT*( . 1*CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0 VPRE(5,2,IMES1,IMES2) = + FACT*( . 1*CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0 50 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(5,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(5,x,p) ENDIF C C PSEUDO SCALAR (PS-POMERON) PAIR TERMS: IF(IPIPOM.NE.0) THEN DO 70 II=1,3 GOTO(71,72,73),II C PI-POMERON: 71 FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIPO -DFI*DFIPO) FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIPO -DFI*DFIPO ) c AM1 = PIM AM1 = AMPI ALM1= ALMP8 PEX = 1.D0 IMES1 = 1 IMES2 = 4 GOTO 74 C KA-POMERON: 72 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIPO -DFIKA*DFIPO)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIPO -DFIKA*DFIPO )*P AM1 = AMK ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 4 GOTO 74 C ETA-POMERON: 73 FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIPO -DFIETA*DFIPO) FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIPO -DFIETA*DFIPO ) AM1 = AME ALM1= ALMP8 PEX = 1.D0 IMES1 = 3 IMES2 = 4 GOTO 74 74 FFSIG2 = 0.D0 FFTEN2 = 0.D0 AM2=AMPOM CALL HDIF(0,X,AM1,AM2,ALM1,0.D0,FUN) FFSIG2 = 0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX FFTEN2 = 0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX VSNN = VSNN - FACT*( . CCPR7(II,1)*FFSIG1 + CCPR7(II,6)*FFSIG2 )/3.D0 VSLL = VSLL - FACT*( . CCPR7(II,2)*FFSIG1 + CCPR7(II,7)*FFSIG2 )/3.D0 VSLS = VSLS - FACT*( . CCPR7(II,3)*FFSIG1 + CCPR7(II,8)*FFSIG2 )/3.D0 VSSS = VSSS - FACT*( . CCPR7(II,4)*FFSIG1 + CCPR7(II,9)*FFSIG2 )/3.D0 VSDR = VSDR - FACT*( . CCPR7(II,5)*FFSIG1 + CCPR7(II,10)*FFSIG2 )/3.D0 VTNN = VTNN - FACT*( . CCPR7(II,1)*FFTEN1 + CCPR7(II,6)*FFTEN2 )/3.D0 VTLL = VTLL - FACT*( . CCPR7(II,2)*FFTEN1 + CCPR7(II,7)*FFTEN2 )/3.D0 VTLS = VTLS - FACT*( . CCPR7(II,3)*FFTEN1 + CCPR7(II,8)*FFTEN2 )/3.D0 VTSS = VTSS - FACT*( . CCPR7(II,4)*FFTEN1 + CCPR7(II,9)*FFTEN2 )/3.D0 VTDR = VTDR - FACT*( . CCPR7(II,5)*FFTEN1 + CCPR7(II,10)*FFTEN2 )/3.D0 VPRF(1,2,IMES1,IMES2) = - FACT*( . 1*CCPR7(II,1)*FFSIG1 + CCPR7(II,6)*FFSIG2 )/3.D0 VPRF(2,2,IMES1,IMES2) = - FACT*( . 1*CCPR7(II,2)*FFSIG1 + CCPR7(II,7)*FFSIG2 )/3.D0 VPRF(3,2,IMES1,IMES2) = - FACT*( . 1*CCPR7(II,3)*FFSIG1 + CCPR7(II,8)*FFSIG2 )/3.D0 VPRF(4,2,IMES1,IMES2) = - FACT*( . 1*CCPR7(II,4)*FFSIG1 + CCPR7(II,9)*FFSIG2 )/3.D0 VPRF(5,2,IMES1,IMES2) = - FACT*( . 1*CCPR7(II,5)*FFSIG1 + CCPR7(II,10)*FFSIG2 )/3.D0 70 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(6,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(6,x,p) ENDIF C C D) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} : C C 7) SCALAR (EPSILON-EPSILON) PAIR TERMS: IF(ISISI.NE.0) THEN C EPSILON-EPSILON: FFUN1 = 0.5D0*FIEP*FIEP CALL HFUN(0,X,AMEPS,AMEPS,ALMS1,ALMS1,0.D0,FUN) FFUN2 = -0.5D0*FUN(1)*FACIP VCNN = VCNN +FACT*(CCPR6(6)*FFUN2+CCPR6(1)*FFUN1) VCLL = VCLL +FACT*(CCPR6(7)*FFUN2+CCPR6(2)*FFUN1) VCSS = VCSS +FACT*(CCPR6(9)*FFUN2+CCPR6(4)*FFUN1) VCDR = VCDR +FACT*(CCPR6(10)*FFUN2+CCPR6(5)*FFUN1) c if(icall.eq.0.and.nschr.eq.1) then if(icall.eq.20.and.nschr.eq.1) then VPRGNN = +FACT*(CCPR6(6)*FFUN2+CCPR6(1)*FFUN1) VPRGLL = +FACT*(CCPR6(7)*FFUN2+CCPR6(2)*FFUN1) VPRGSS = +FACT*(CCPR6(9)*FFUN2+CCPR6(4)*FFUN1) VPRGDR = +FACT*(CCPR6(10)*FFUN2+CCPR6(5)*FFUN1) write(N3,*) ' EPSILON-EPSILON PAIR-TERMS: x=',x write(N3,*) ' VCNN=',vprgnn,' VCDR=',vprgdr write(N3,*) ' VCLL=',vprgll,' VCSS=',vprgss write(N3,*) '***************************************************' endif ENDIF C -------------------------------------------------------------- C 8) TENSOR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C -------------------------------------------------------------- C only 1-pair terms included!! IF(IPIPI2.NE.0) THEN DO 80 II=1,7 GOTO(81,82,83,84,85,86,87),II C PI-ETA: *81 AM1 = PIM 81 AM1 = AMPI AM2 = AME FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIETA) . +0.5D0*(2*X2*DFI*DFIETA+DDFI*DDFETA)/3.D0 . -0.25D0*(1.D0+(AME/PIM)**2)*DFI*DFIETA/3.D0 IMES1 = 1 IMES2 = 3 GOTO 88 C KA-KA(8S)(I=1): 82 AM1 = AMK AM2 = AMK c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFIKA*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFIKA*DFIKA+DDFKA*DDFKA)/3.D0 . -0.5D0*(AMK/PIM)**2*DFIKA*DFIKA/3.D0 IMES1 = 2 IMES2 = 2 GOTO 88 C PI-KA(8s): c83 AM1 = PIM 83 AM1 = AMPI AM2 = AMK c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0 IMES1 = 1 IMES2 = 2 GOTO 88 C ETA-KA(8s): 84 AM1 = AMK AM2 = AME c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0 IMES1 = 2 IMES2 = 3 GOTO 88 C PI-PI(8S)(I=0): c85 AM1 = PIM c AM2 = PIM 85 AM1 = AMPI AM2 = AMPI FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFI) . +0.5D0*(2*X2*DFI*DFI+DDFI*DDFI)/3.D0 . -0.5D0*DFI*DFI/3.D0 IMES1 = 1 IMES2 = 1 GOTO 88 C ETA-ETA(8s): 86 AM1 = AME AM2 = AME FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIETA) . +0.5D0*(2*X2*DFIETA*DFIETA+DDFETA*DDFETA)/3.D0 . -0.5D0*(AME/PIM)**2*DFIETA*DFIETA/3.D0 IMES1 = 3 IMES2 = 3 GOTO 88 C KA-KA(8S)(I=0): 87 AM1 = AMK AM2 = AMK c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFIKA*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFIKA*DFIKA+DDFKA*DDFKA)/3.D0 . -0.5D0*(AMK/PIM)**2*DFIKA*DFIKA/3.D0 IMES1 = 2 IMES2 = 2 GOTO 88 88 IF(II.EQ.2.OR.II.EQ.5) THEN CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN) ELSE CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN) ENDIF FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO) FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO) FSO1 = -X2*FUN(4)*(PIM/AMPRO) VCNN = VCNN + ISFAC*FACT* CCPR8(II,1)*FCEN1 VSNN = VSNN + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0 VTNN = VTNN + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0 VONN = VONN + ISFAC*FACT* CCPR8(II,1)*FSO1 VCLL = VCLL + FACT* CCPR8(II,2)*FCEN1 VSLL = VSLL + FACT* CCPR8F(II,2)*FSIG1/3.D0 VTLL = VTLL + FACT* CCPR8F(II,2)*FTEN1/3.D0 VOLL = VOLL + FACT* CCPR8(II,2)*FSO1 VCLS = VCLS + FACT* CCPR8(II,3)*FCEN1 VSLS = VSLS + FACT* CCPR8F(II,3)*FSIG1/3.D0 VTLS = VTLS + FACT* CCPR8F(II,3)*FTEN1/3.D0 VOLS = VOLS + FACT* CCPR8(II,3)*FSO1 VCSS = VCSS + FACT* CCPR8(II,4)*FCEN1 VSSS = VSSS + FACT* CCPR8F(II,4)*FSIG1/3.D0 VTSS = VTSS + FACT* CCPR8F(II,4)*FTEN1/3.D0 VOSS = VOSS + FACT* CCPR8(II,4)*FSO1 VCDR = VCDR + FACT* CCPR8(II,5)*FCEN1 VSDR = VSDR + FACT* CCPR8F(II,5)*FSIG1/3.D0 VTDR = VTDR + FACT* CCPR8F(II,5)*FTEN1/3.D0 VODR = VODR + FACT* CCPR8(II,5)*FSO1 80 CONTINUE c if(icall.eq.0.and.nschr.eq.1) call writepr(2,x,p) c* if(icall.eq.20.and.nschr.eq.1) call writepr(2,x,p) if(x.eq.0.01d0) then write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1 write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 write(*,*) ' ccpr8=',ccpr8(ii,1) endif ENDIF C------------------------------------------------------------ C 9) VECTOR (PION-A1) PAIR TERMS: C------------------------------------------------------------ C c IF(IPIA1.EQ.1) THEN c VC = VC + FACT*ISFAC*GPIA1*(GPIA1*FIPA1C c . - FP*(PIM/AMN)*(2*X1*DFI+DDFI)*FIA1 ) c VSIG = VSIG - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)* c . ((2*X1*DFI+DDFI)*FIA1 + DFI*DFIA)*(4.D0/3.D0) c VTEN = VTEN - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)* c . ((X1*DFI-DDFI)*FIA1 - DFI*DFIA)*(2.D0/3.D0) c ENDIF C CC C---------------------------------------------------------------- C 1/M-CORRECTIONS: IF(INA.EQ.1.OR.IPV.EQ.1) THEN CALL OMPAIR(X,INA,IPV,APV) c* if(icall.eq.0) write(*,*) ' WARNING: NO OMPAIR !!!!!' ENDIF C---------------------------------------------------------------- c if(x.le.0.05d0) write(*,*) ' Before call ynprexpv:' c* if(icall.eq.0.and.nschr.eq.1) call writepr(3,x,p) c* if(x.le.0.05d0) call writepr(4,x,p) c if(x.le.0.05d0) call writepr(8,x,p) c if(x.le.0.05d0) write(*,*) 'ynpairs,ipiom =2: p,x=',p,x, c .' vsll,vsss,vsls,vsdr,vsnn=', vsll,vsss,vsls,vsdr,vsnn c if(x.le.0.05d0) write(*,*) 'ynpairs,ipiom =2: p,x=',p,x, c .' vtll,vtss,vtls,vtdr,vtnn=', vtll,vtss,vtls,vtdr,vtnn C STRANGENESS-EXCHANGE SPIN-ORBIT AND BARYON MASS DIFFERENCES : IF(NSU3F.NE.1) THEN IF(IPV.EQ.1) CALL YNPREXPV(X,IPV) IF(IPV.EQ.0) CALL YNPREXPS(X,IPV) c*** CALL YNPREX(X,INA,IPV,APV) ENDIF ICALL=ICALL+1 RETURN END C ********************************************************************** SUBROUTINE YNPRCC(NTYPE,NCASE,ICSB,ALFA,ALFB,P) C ********************************************************************** C * in this version: YNPRCC and YCCMPE give identical results!! C ********************************************************************** C * C * COMPUTATION COUPLING-CONSTANT COMBINATIONS FOR THE C * 1-PAIR AND 2-PAIR DIAGRAMS FOR THE YN-CHANNELS C * C ntype = 1 : 1 -> {8}x{8} C ntype = 2 : 8s -> {8}x{8} C ntype = 3 : 8a -> {8}x{8} C ntype = 4 : 8 -> {8}x{1} C ntype = 5 : 1 -> {1}x{1} C ntype = 6 : 8s -> {8}x{8} C C ncase: 1 -> pipi, 2 -> etc. C C !! NOTICE: THIS VERSION ALL COUPLINGS ARE ORDERED AS !!!!! C !! FOR THE PS-SCALARS!! !!!!! C c exchanged mesons are treated as distinguishable particles -> C IN COUPLING COMBINATIONS CENLL1 ETC.: C (i) L+R contributions included, C (ii) 1 <-> 2 interchange factor included (extra diagrams). C note: for idendical particles factor 2 from vertex, so in effect C no difference with distinguishable particles in 1-pair graph C (iii) 1-pair graphs from (L_{meson}+L_{pair})**3/3! i.e. term C L_{pair}L_{meson}^{2}/2!, so this cancels 1<->2 factor: IP12 C (iv) 2-pair graphs from L_{pair}^{2}/2! C note: identical particle factors for 2-pair graphs: added in YNPAI C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PRCPLS/CENNN1,CENLL1,CENLS1,CENSS1,CENDR1, . CENNN2,CENLL2,CENLS2,CENSS2,CENDR2, . SIGNN1,SIGLL1,SIGLS1,SIGSS1,SIGDR1, . SIGNN2,SIGLL2,SIGLS2,SIGSS2,SIGDR2 c COMMON/PRCPLS/CENLL1,CENLS1,CENSS1,CENDR1, c . CENLL2,CENLS2,CENSS2,CENDR2, c . SIGLL1,SIGLS1,SIGSS1,SIGDR1, c . SIGLL2,SIGLS2,SIGSS2,SIGDR2 COMMON/CPLRIJ/FA1,FA2,FA3,FA4,FA5,FA6,FA7,FA8,FA9,FA10,FA11, . FB1,FB2,FB3,FB4,FB5,FB6,FB7,FB8,FB9,FB10,FB11, . PR1,PR2,PR3,PR4,PR5,PR6,PR7,PR8,PR9,PR10,PR11 COMMON/COUCON/XX1(3),THPS,XX2(2),THV,XX3(2),THS,XX4(8),THD,XX5(4) .,ALPA DIMENSION PR(11),FA(11),FB(11) EQUIVALENCE (PR1,PR(1)),(FA1,FA(1)),(FB1,FB(1)) C CHANNEL-TYPE SEQUENCES: C (PI= PI, RHO, ETC.; ETA = ETA, PHI, ETC.; K = KA, K*, ETC. ) C 8S: (PI1 ETA2), (K1 K2)_{1}, (PI1 K2), (ETA1 K2), C (PI1 PI2)_{0}, (EAT1 ETA2), (K1 K2)_{0}, (7-CASES). C (K1 PI2), (K1 ETA2). C 8A: (PI1 PI2), (K1 K2)_{1}, (PI1 K2), (ETA1 K2), (K1 K2)_{0}, C (K1 PI2), (K1 ETA2), (7-CASES). C DATA SR2/1.4142136D0/,SR3/1.732051D0/ C C CONSTRUCTION OF THE COUPLINGS C IF(P.EQ.+1.D0) ISFAC=+1 IF(P.EQ.-1.D0) ISFAC=-3 c* ISFAC = +1 C XI-COUPLINGS: XA12 = -FA1*(4*ALFA-1.D0)/SR3 XA13 = +FA1 XB12 = -FB1*(4*ALFB-1.D0)/SR3 XB13 = +FB1 C 1) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} : C IF(NTYPE.EQ.1) THEN GOTO(11,12,13),NCASE C PI1-PI2(I=0): 11 GPRNN = PR(1) GPRLL = GPRNN GPRSS = GPRNN CENNN1 = 3*GPRNN*FA1*FB1*4 CENLL1 = (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2 CENLS1 = 0.D0 CENSS1 = (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2) )*2 CENDR1 = CENSS1 CENNN2 = 3*GPRNN*GPRNN CENLL2 = 3*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 3*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 14 C ETA1-ETA2: 12 GPRNN = PR(1) GPRLL = GPRNN GPRSS = GPRNN CENNN1 = GPRNN*(FA6*FB6)*4 CENLL1 = (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2 CENDR1 = CENSS1 CENNN2 = 1*GPRNN*GPRNN CENLL2 = 1*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 1*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 14 C KA1-KA2(I=0): 13 GPRNN = 1*PR(1) GPRLL = GPRNN GPRSS = GPRNN CENNN1 = GPRNN*(FA4*FB4+3*FA5*FB5)*4 CENLL1 = GPRLL*(FA4*FB4+3*FA5*FB5)*2 + . GPRNN*(2*FA4*FB4+2*XA12*XB12)*2 CENLS1 = 0.D0 CENSS1 = GPRSS*(FA4*FB4+3*FA5*FB5)*2 + . GPRNN*(2*FA5*FB5+2*XA13*XB13)*2 CENDR1 = CENSS1 CENNN2 = 4*GPRNN*GPRNN CENLL2 = 4*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 4*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 14 14 RETURN ENDIF C C 2) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(NTYPE.EQ.2) THEN GOTO(21,22,23,24,25,26,27),NCASE C PI1-ETA2: 21 GPRNN = PR(1) GPRSS = PR(2) GPRLS = PR(3) CENNN1 = ISFAC*GPRNN*FA1*FB6*4 CENLL1 = 0.D0 c CENLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6) ! CSB CENLS1 = -SR3*(GPRNN*FA3*FB8+GPRLS*FA1*FB6 . +GPRNN*FA3*FB7+GPRLS*FA1*FB6 ) CENSS1 = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -SR3*GPRLS*GPRNN CENSS2 = -2*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 28 C KA1-KA2(I=1)(8S): 22 GPRNN = 0.5D0*SR3*PR(1) GPRSS = 0.5D0*SR3*PR(2) GPRLS = 0.5D0*SR3*PR(3) CENNN1 = ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*2 CENLL1 = 0.D0 CENLS1 = -0.5D0*SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2 + . GPRNN*(2*FA4*FB5-2*XA12*XB13) + . GPRNN*(2*FA5*FB4-2*XA13*XB12) ) CENSS1 = -1*(GPRSS*(FA4*FB4-FA5*FB5) . -GPRNN*(2*FA5*FB5-2*XA13*XB13) )*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*2*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -2*SR3*GPRLS*GPRNN CENSS2 = -4*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 28 C PI1-KA2(8s): 23 GPRLN = 0.5D0*SR3*PR(4) GPRSN = 0.5D0*SR3*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(3*FA1*FB4+3*FA3*FB5)*2 CENLS1 = -SR3*(-GPRLN*FA1*FB5 + GPRSN*3*FA3*FB5) . -SR3*(+GPRLN*(FA3*FB4-2*FA2*FB5)+3*GPRSN*FA1*FB4) CENSS1 = +GPRSN*(+FA1*FB5-FA3*FB4+2*FA2*FB5)*2 CENDR1 = -2*CENSS1 CENNN2 = 0.D0 CENLL2 = 3*GPRLN**2 CENLS2 = -3*SR3*GPRLN*GPRSN CENSS2 = -3*GPRSN**2 CENDR2 = -2*CENSS2 GOTO 28 C ETA1-KA2(8S): 24 GPRLN = -0.5D0*PR(4) GPRSN = -0.5D0*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(FA6+FA7)*FB4*2 CENLS1 = -SR3*(GPRLN*FA6*FB5+GPRSN*FA7*FB4) . -SR3*(GPRLN*FA8*FB5+GPRSN*FA6*FB4) CENSS1 = -GPRSN*(FA6*FB5+FA8*FB5)*2 CENNN2 = 0.D0 CENDR1 = -2*CENSS1 CENLL2 = GPRLN**2 CENLS2 = -SR3*GPRLN*GPRSN CENSS2 = -GPRSN**2 CENDR2 = -2*CENSS2 GOTO 28 C PI1-PI2(I=0)(8S): 25 GPRNN = 0.5D0*PR(6) GPRLL = 0.5D0*PR(7) GPRSS = 0.5D0*PR(8) CENNN1 = 3*GPRNN*FA1*FB1*4 CENLL1 = (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2 CENLS1 = 0.D0 CENSS1 = (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2))*2 CENDR1 = CENSS1 CENNN2 = 3*GPRNN*GPRNN CENLL2 = 3*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 3*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 28 C ETA-ETA(8s): 26 GPRNN = -0.5D0*PR(6) GPRLL = -0.5D0*PR(7) GPRSS = -0.5D0*PR(8) CENNN1 = GPRNN*FA6*FB6*4 CENLL1 = (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2 CENDR1 = CENSS1 CENNN2 = GPRNN*GPRNN CENLL2 = 1*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 1*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 28 C KA1-KA2(I=0)(8S): 27 GPRNN = -0.5D0*PR(6) GPRLL = -0.5D0*PR(7) GPRSS = -0.5D0*PR(8) CENNN1 = GPRNN*(FA4*FB4+3*FA5*FB5)*2 CENLL1 = (GPRLL*(FA4*FB4+3*FA5*FB5) + . GPRNN*(2*FA4*FB4+2*XA12*XB12))*1 CENLS1 = 0.D0 CENSS1 = (GPRSS*(FA4*FB4+3*FA5*FB5) + . GPRNN*(2*FA5*FB5+2*XA13*XB13))*1 CENDR1 = CENSS1 CENNN2 = 2*GPRNN*GPRNN CENLL2 = 2*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 2*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 28 28 RETURN ENDIF C C 3) VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} : C IF(NTYPE.EQ.3) THEN GOTO(41,42,43,44,48,45,46,47,49),NCASE C PI1-RHO2(I=1)(AXIAL): 41 GPRNN = PR(1) GPRSS = PR(2) GPRLS = PR(3) SIGNN1 = ISFAC*GPRNN*(2*FA1*FB1)*4 SIGLL1 = 0.D0 c SIGLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*(FA3*FB6+FA6*FB3)) ! CSB SIGLS1 = -SR3*(2*GPRLS*FA1*FB1+2*GPRNN*(FA3*FB2)) . -SR3*(2*GPRLS*FA1*FB1+2*GPRNN*(FA2*FB3)) SIGSS1 = -2*(2*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+FA2*FB2))*2 SIGDR1 = -0.5D0*SIGSS1 SIGNN2 = ISFAC*2*GPRNN*GPRNN SIGLL2 = 0.D0 SIGLS2 = -2*SR3*GPRLS*GPRNN SIGSS2 = -4*GPRSS*GPRNN SIGDR2 = -0.5D0*SIGSS2 GOTO 488 C KA-K*(I=1)(AXIAL): 42 GPRNN = 0.5D0*PR(1) GPRSS = 0.5D0*PR(2) GPRLS = 0.5D0*PR(3) SIGNN1 = ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*4 SIGLL1 = 0.D0 SIGLS1 = -SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2 . -2*GPRNN*(FA4*FB5+XA12*XB13) . -2*GPRNN*(FA5*FB4+XA13*XB12) ) SIGSS1 = -2*GPRSS*(FA4*FB4-FA5*FB5)*2 . -4*GPRNN*(FA5*FB5+XA13*XB13)*2 SIGDR1 = -0.5D0*SIGSS1 SIGNN2 = ISFAC*4*GPRNN*GPRNN SIGLL2 = 0.D0 SIGLS2 = -4*SR3*GPRLS*GPRNN SIGSS2 = -8*GPRSS*GPRNN SIGDR2 = -0.5D0*SIGSS2 GOTO 488 C PI-K*(AXIAL): 43 GPRLN = -0.5D0*PR(4) GPRSN = -0.5D0*PR(5) SIGNN1 = 0.D0 SIGLL1 = 3*GPRLN*(-FA1*FB4+FA3*FB5)*2 SIGLS1 = -SR3*(+GPRLN*FA1*FB5+3*GPRSN*FA3*FB5) . -SR3*(+GPRLN*(+FA3*FB4-2*FA2*FB5)-3*GPRSN*FA1*FB4) SIGSS1 = 1*GPRSN*(-FA1*FB5-FA3*FB4+2*FA2*FB5)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = 3*GPRLN**2 SIGLS2 = -3*SR3*GPRLN*GPRSN SIGSS2 = -3*GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 C ETA-K*(AXIAL): 44 GPRLN = -0.5D0*SR3*PR(4)*DCOS(THPS) GPRSN = -0.5D0*SR3*PR(5)*DCOS(THPS) SIGNN1 = 0.D0 SIGLL1 = GPRLN*(-FA6*FB4+FA7*FB4)*2 SIGLS1 = -SR3*(-GPRLN*FA6*FB5+GPRSN*FA7*FB4) . -SR3*(+GPRLN*FA8*FB5-GPRSN*FA6*FB4) SIGSS1 = -1*GPRSN*(-FA6*FB5+FA8*FB5)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 C ETA'-K*(AXIAL): 48 GPRLN = -0.5D0*SR3*PR(4)*DSIN(THPS) GPRSN = -0.5D0*SR3*PR(5)*DSIN(THPS) SIGNN1 = 0.D0 SIGLL1 = GPRLN*(-FA9*FB4+FA10*FB4)*2 SIGLS1 = -SR3*(-GPRLN*FA9*FB5+GPRSN*FA10*FB4) . -SR3*(+GPRLN*FA11*FB5-GPRSN*FA9*FB4) SIGSS1 = -1*GPRSN*(-FA9*FB5+FA11*FB5)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 C KA-K*(I=0)(AXIAL): 45 GPRNN = 0.5D0*SR3*PR(6) GPRLL = 0.5D0*SR3*PR(7) GPRSS = 0.5D0*SR3*PR(8) SIGNN1 = GPRNN*(FA4*FB4+3*FA5*FB5)*4 SIGLL1 = 1*(GPRLL*(FA4*FB4+3*FA5*FB5) . +GPRNN*(-2*FA4*FB4+2*XA12*XB12) )*2 SIGLS1 = 0.D0 SIGSS1 = +1*(GPRSS*(FA4*FB4+3*FA5*FB5) . +GPRNN*(-2*FA5*FB5+2*XA13*XB13) )*2 SIGDR1 = SIGSS1 SIGNN2 = 4*GPRNN*GPRNN SIGLL2 = 4*GPRLL*GPRNN SIGLS2 = 0.D0 SIGSS2 = 4*GPRSS*GPRNN SIGDR2 = SIGSS2 GOTO 488 C KA-RO(AXIAL): 46 GPRLN = -0.5D0*PR(4) GPRSN = -0.5D0*PR(5) c gprln = +0.5D0*PR(4) c gprsn = +0.5D0*PR(5) SIGNN1 = 0.D0 SIGLL1 = 3*GPRLN*(FA5*FB3-FA4*FB1)*2 SIGLS1 = -SR3*(+GPRLN*FA5*FB1+3*GPRSN*FA5*FB3) . -SR3*(+GPRLN*(FA4*FB3-2*FA5*FB2)-3*GPRSN*FA4*FB1) SIGSS1 = -1*GPRSN*(FA4*FB3-2*FA5*FB2+FA5*FB1)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = 3*GPRLN**2 SIGLS2 = -3*SR3*GPRLN*GPRSN SIGSS2 = -3*GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 C KA-PHI(AXIAL): 47 GPRLN = -0.5D0*SR3*PR(4)*DCOS(THV) GPRSN = -0.5D0*SR3*PR(5)*DCOS(THV) c gprln = +0.5D0*SR3*PR(4)*DCOS(THV) c gprsn = +0.5D0*SR3*PR(5)*DCOS(THV) SIGNN1 = 0.D0 SIGLL1 = 1*GPRLN*(-FA4*FB6+FA4*FB7)*2 SIGLS1 = -SR3*(GPRLN*FA5*FB8-GPRSN*FA4*FB6) . -SR3*(-GPRLN*FA5*FB6+GPRSN*FA4*FB7) SIGSS1 = -1*GPRSN*(FA5*FB8-FA5*FB6)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 C KA-OMEGA(AXIAL): 49 GPRLN = -0.5D0*SR3*PR(4)*DSIN(THV) GPRSN = -0.5D0*SR3*PR(5)*DSIN(THV) c gprln = +0.5D0*SR3*PR(4)*DSIN(THV) c gprsn = +0.5D0*SR3*PR(5)*DSIN(THV) SIGNN1 = 0.D0 SIGLL1 = 1*GPRLN*(-FA4*FB9+FA4*FB10)*2 SIGLS1 = -SR3*(GPRLN*FA5*FB11-GPRSN*FA4*FB9) . -SR3*(-GPRLN*FA5*FB9+GPRSN*FA4*FB10) SIGSS1 = -1*GPRSN*(FA5*FB11-FA5*FB9)*2 SIGDR1 = -2*SIGSS1 SIGNN2 = 0.D0 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 488 488 RETURN ENDIF C C 4) PSEUDO SCALAR PAIR TERMS {8}->{8}x{1} (PION-EPSILON): C IF(NTYPE.EQ.4) THEN if(ncase.eq.1) then gnn1 = 0.d0 gnn2 = 0.d0 gdr1 = 0.d0 gdr2 = 0.d0 endif GOTO(51,52,53,54,55,56),NCASE C PI-EPSILON: 51 GPRNN = PR(1) GPRSS = PR(2) GPRLS = PR(3) signn1 = isfac*2*pr(1)*fa1*fb9*2 signn2 = isfac*pr(1)*pr(1) SIGLL1 = 0.D0 c SIGLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6) ! CSB SIGLS1 = -0.5D0*SR3*(2*GPRLS*FA1*FB9+GPRNN*FA3*(FB10+FB11))*2 SIGSS1 = -2*(GPRSS*FA1*FB9+GPRNN*FA2*FB10)*2 SIGDR1 = -0.5D0*SIGSS1 SIGLL2 = 0.D0 SIGLS2 = -SR3*GPRLS*GPRNN SIGSS2 = -2*GPRSS*GPRNN SIGDR2 = -0.5D0*SIGSS2 GOTO 57 C KA-EPSILON: 52 GPRLN = PR(4) GPRSN = PR(5) C GPRLN = PR(4)*2 C GPRSN = PR(5)*2 signn1 = 0.d0 signn2 = 0.d0 SIGLL1 = 1*GPRLN*FA4*(FB9+FB10)*2 SIGLS1 = -0.5D0*SR3*(GPRLN*FA5*(FB9+FB11)+GPRSN*FA4*(FB9+FB10))*2 SIGSS1 = -1*GPRSN*FA5*(FB9+FB11)*2 SIGDR1 = -2*SIGSS1 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 57 C ETA-EPSILON: 53 GPRNN = PR(6) GPRLL = PR(7) GPRSS = PR(8) signn1 = 2*pr(6)*fa6*fb9*2 signn2 = pr(6)*pr(6) SIGLL1 = 1*(GPRNN*FA7*FB10+GPRLL*FA6*FB9)*2 SIGLS1 = 0.D0 SIGSS1 = 1*(GPRNN*FA8*FB11+GPRSS*FA6*FB9)*2 SIGDR1 = SIGSS1 SIGLL2 = GPRLL*GPRNN SIGLS2 = 0.D0 SIGSS2 = GPRSS*GPRNN SIGDR2 = SIGSS2 GOTO 57 C PI-SSTAR: 54 GPRNN = PR(1) GPRSS = PR(2) GPRLS = PR(3) signn1 = isfac*2*pr(1)*fa1*fb6*2 signn2 = isfac*pr(1)*pr(1) SIGLL1 = 0.D0 SIGLS1 = -0.5D0*SR3*(2*GPRLS*FA1*FB6+GPRNN*FA3*(FB7+FB8))*2 SIGSS1 = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2 SIGDR1 = -0.5D0*SIGSS1 SIGLL2 = 0.D0 SIGLS2 = -SR3*GPRLS*GPRNN SIGSS2 = -2*GPRSS*GPRNN SIGDR2 = -0.5D0*SIGSS2 GOTO 57 C KA-SSTAR: 55 GPRLN = PR(4) GPRSN = PR(5) C GPRLN = PR(4)*2 C GPRSN = PR(5)*2 signn1 = 0.d0 signn2 = 0.d0 SIGLL1 = 1*GPRLN*FA4*(FB6+FB7)*2 SIGLS1 = -0.5D0*SR3*(GPRLN*FA5*(FB6+FB8)+GPRSN*FA4*(FB6+FB7))*2 SIGSS1 = -1*GPRSN*FA5*(FB6+FB8)*2 SIGDR1 = -2*SIGSS1 SIGLL2 = GPRLN**2 SIGLS2 = -SR3*GPRLN*GPRSN SIGSS2 = -GPRSN**2 SIGDR2 = -2*SIGSS2 GOTO 57 C ETA-SSTAR: 56 GPRNN = PR(6) GPRLL = PR(7) GPRSS = PR(8) signn1 = 2*pr(6)*fa6*fb6*2 signn2 = pr(6)*pr(6) SIGLL1 = 1*(GPRNN*FA7*FB7+GPRLL*FA6*FB6)*2 SIGLS1 = 0.D0 SIGSS1 = 1*(GPRNN*FA8*FB8+GPRSS*FA6*FB6)*2 SIGDR1 = SIGSS1 SIGLL2 = GPRLL*GPRNN SIGLS2 = 0.D0 SIGSS2 = GPRSS*GPRNN SIGDR2 = SIGSS2 GOTO 57 57 RETURN ENDIF C C D) SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} (EPSILON-EPSILON): C C 5) SCALAR (EPSILON-EPSILON) PAIR TERMS: IF(NTYPE.EQ.5) THEN C EPSILON-EPSILON: GPRNN = PR(1) GPRLL = PR(2) GPRSS = PR(3) c GPRLL = GPRNN c GPRSS = GPRNN CENNN1 = (GPRNN*FA9*FB9)*4 CENLL1 = (GPRLL*FA9*FB9+GPRNN*FA10*FB10)*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*FA9*FB9+GPRNN*FA11*FB11)*2 CENDR1 = CENSS1 CENNN2 = GPRNN*GPRNN CENLL2 = GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = GPRSS*GPRNN CENDR2 = CENSS2 ENDIF C C 6) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(NTYPE.EQ.6) THEN GOTO(61,611,62,63,64,65,66,67,671,68,69,691,693), NCASE C PI1-OMEGA: 61 GPRNN = 0.5D0*PR(1) GPRSS = 0.5D0*PR(2) GPRLS = 0.5D0*PR(3) CENNN1 = ISFAC*GPRNN*FA1*FB9*4 CENLL1 = 0.D0 c CENLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6) ! CSB CENLS1 = -SR3*(GPRNN*FA3*FB11+GPRLS*FA1*FB9 . +GPRNN*FA3*FB10+GPRLS*FA1*FB9 ) CENSS1 = -2*(GPRSS*FA1*FB9+GPRNN*FA2*FB11)*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -SR3*GPRLS*GPRNN CENSS2 = -2*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 692 C PI1-PHI2: 611 GPRNN = 0.5D0*PR(1) GPRSS = 0.5D0*PR(2) GPRLS = 0.5D0*PR(3) CENNN1 = ISFAC*GPRNN*FA1*FB6*4 CENLL1 = 0.D0 CENLS1 = -SR3*(GPRNN*FA3*FB8+GPRLS*FA1*FB6 . +GPRNN*FA3*FB7+GPRLS*FA1*FB6 ) CENSS1 = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -SR3*GPRLS*GPRNN CENSS2 = -2*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 692 C ETA1-RHO2: 62 GPRNN = 0.5D0*PR(1) GPRSS = 0.5D0*PR(2) GPRLS = 0.5D0*PR(3) CENNN1 = ISFAC*GPRNN*FA6*FB1*4 CENLL1 = 0.D0 CENLS1 = -SR3*(GPRNN*FA8*FB3+GPRLS*FA6*FB1 . +GPRNN*FA7*FB3+GPRLS*FA6*FB1 ) CENSS1 = -2*(GPRSS*FA6*FB1+GPRNN*FA8*FB2)*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -SR3*GPRLS*GPRNN CENSS2 = -2*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 692 C KA1-K*2(I=1)(8S): 63 GPRNN = 0.25D0*SR3*PR(1) GPRSS = 0.25D0*SR3*PR(2) GPRLS = 0.25D0*SR3*PR(3) CENNN1 = ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*4 CENLL1 = 0.D0 CENLS1 = -SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2 + . GPRNN*(2*FA4*FB5-2*XA12*XB13) + . GPRNN*(2*FA5*FB4-2*XA13*XB12) ) CENSS1 = -2*(GPRSS*(FA4*FB4-FA5*FB5) . -GPRNN*(2*FA5*FB5-2*XA13*XB13) )*2 CENDR1 = -0.5D0*CENSS1 CENNN2 = ISFAC*4*GPRNN*GPRNN CENLL2 = 0.D0 CENLS2 = -4*SR3*GPRLS*GPRNN CENSS2 = -8*GPRSS*GPRNN CENDR2 = -0.5D0*CENSS2 GOTO 692 C PI1-K*2(8s): 64 GPRLN = 0.25D0*SR3*PR(4) GPRSN = 0.25D0*SR3*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(3*FA1*FB4+3*FA3*FB5)*2 CENLS1 = -SR3*(-GPRLN*FA1*FB5 + GPRSN*3*FA3*FB5) . -SR3*(+GPRLN*(FA3*FB4-2*FA2*FB5)+3*GPRSN*FA1*FB4) CENSS1 = +GPRSN*(+FA1*FB5-FA3*FB4+2*FA2*FB5)*2 CENDR1 = -2*CENSS1 CENNN2 = 0.D0 CENLL2 = 3*GPRLN**2 CENLS2 = -3*SR3*GPRLN*GPRSN CENSS2 = -3*GPRSN**2 CENDR2 = -2*CENSS2 GOTO 692 C KA1-RHO2(8s): 65 GPRLN = 0.25D0*SR3*PR(4) GPRSN = 0.25D0*SR3*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(3*FA4*FB1+3*FA5*FB3)*2 CENLS1 = -SR3*(-GPRLN*FA5*FB1 + GPRSN*3*FA5*FB3) . -SR3*(+GPRLN*(FA4*FB3-2*FA5*FB2)+3*GPRSN*FA4*FB1) CENSS1 = +GPRSN*(+FA5*FB1-FA4*FB3+2*FA5*FB2)*2 CENDR1 = -2*CENSS1 CENNN2 = 0.D0 CENLL2 = 3*GPRLN**2 CENLS2 = -3*SR3*GPRLN*GPRSN CENSS2 = -3*GPRSN**2 CENDR2 = -2*CENSS2 GOTO 692 C ETA1-K*2(8S): 66 GPRLN = -0.25D0*PR(4) GPRSN = -0.25D0*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(FA6+FA7)*FB4*2 CENLS1 = -SR3*(GPRLN*FA6*FB5+GPRSN*FA7*FB4) . -SR3*(GPRLN*FA8*FB5+GPRSN*FA6*FB4) CENSS1 = -GPRSN*(FA6*FB5+FA8*FB5)*2 CENNN2 = 0.D0 CENDR1 = -2*CENSS1 CENLL2 = GPRLN**2 CENLS2 = -SR3*GPRLN*GPRSN CENSS2 = -GPRSN**2 CENDR2 = -2*CENSS2 GOTO 692 C KA1-OMEGA(8S): 67 GPRLN = -0.25D0*PR(4) GPRSN = -0.25D0*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(FB9+FB10)*FA4*2 CENLS1 = -SR3*(GPRLN*FA5*FB9+GPRSN*FA4*FB10) . -SR3*(GPRLN*FA5*FB11+GPRSN*FA4*FB9) CENSS1 = -GPRSN*(FA5*FB9+FA5*FB11)*2 CENNN2 = 0.D0 CENDR1 = -2*CENSS1 CENLL2 = GPRLN**2 CENLS2 = -SR3*GPRLN*GPRSN CENSS2 = -GPRSN**2 CENDR2 = -2*CENSS2 GOTO 692 C KA1-PHI2(8S): 671 GPRLN = -0.25D0*PR(4) GPRSN = -0.25D0*PR(5) CENNN1 = 0.D0 CENLL1 = GPRLN*(FB6+FB7)*FA4*2 CENLS1 = -SR3*(GPRLN*FA5*FB6+GPRSN*FA4*FB7) . -SR3*(GPRLN*FA5*FB8+GPRSN*FA4*FB6) CENSS1 = -GPRSN*(FA5*FB6+FA5*FB8)*2 CENNN2 = 0.D0 CENDR1 = -2*CENSS1 CENLL2 = GPRLN**2 CENLS2 = -SR3*GPRLN*GPRSN CENSS2 = -GPRSN**2 CENDR2 = -2*CENSS2 GOTO 692 C PI1-RHO2(I=0)(8S): 68 GPRNN = 0.5D0*PR(6) GPRLL = 0.5D0*PR(7) GPRSS = 0.5D0*PR(8) CENNN1 = 3*GPRNN*FA1*FB1*4 CENLL1 = (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2 CENLS1 = 0.D0 CENSS1 = (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2))*2 CENDR1 = CENSS1 CENNN2 = 3*GPRNN*GPRNN CENLL2 = 3*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 3*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 692 C KA1-K*2(I=0)(8S): 69 GPRNN = -0.25D0*PR(6) GPRLL = -0.25D0*PR(7) GPRSS = -0.25D0*PR(8) CENNN1 = GPRNN*(FA4*FB4+3*FA5*FB5)*4 CENLL1 = (GPRLL*(FA4*FB4+3*FA5*FB5) + . GPRNN*(2*FA4*FB4+2*XA12*XB12))*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*(FA4*FB4+3*FA5*FB5) + . GPRNN*(2*FA5*FB5+2*XA13*XB13))*2 CENDR1 = CENSS1 CENNN2 = 4*GPRNN*GPRNN CENLL2 = 4*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 4*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 692 C ETA-OMEGA(8s): 691 GPRNN = -0.5D0*PR(6) GPRLL = -0.5D0*PR(7) GPRSS = -0.5D0*PR(8) CENNN1 = GPRNN*FA6*FB9*4 CENLL1 = (GPRLL*FA6*FB9+GPRNN*FA7*FB10)*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*FA6*FB9+GPRNN*FA8*FB11)*2 CENDR1 = CENSS1 CENNN2 = GPRNN*GPRNN CENLL2 = 1*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 1*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 692 C ETA-PHI(8s): 693 GPRNN = -0.5D0*PR(6) GPRLL = -0.5D0*PR(7) GPRSS = -0.5D0*PR(8) CENNN1 = GPRNN*FA6*FB6*4 CENLL1 = (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2 CENLS1 = 0.D0 CENSS1 = (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2 CENDR1 = CENSS1 CENNN2 = GPRNN*GPRNN CENLL2 = 1*GPRLL*GPRNN CENLS2 = 0.D0 CENSS2 = 1*GPRSS*GPRNN CENDR2 = CENSS2 GOTO 692 692 RETURN ENDIF END C ********************************************************************** SUBROUTINE WRITEPR(NCASE,X,P) C ********************************************************************** C C NCASE = 1,2,7 : VC ; NCASE = 3 : VC,VS,VT ; NCASE = 4,5,6 : VS,VT C NCASE = 8 : VS,VT C IMPLICIT REAL*8(A-H,O-Z) COMMON/PRWRITE/VPR(5,3,4,4,8) CHARACTER *4 NTYPM(4,4) c* DATA N3/37/,NTYPM/ DATA N3/27/,NTYPM/ c* DATA N3/6/,NTYPM/ .'PI ','KA ','ETA ','ETAP','RHO ','K* ','PHI ','OM ', .'DE ','KAP ','S* ','EPS ','A2 ','K** ','POMP','POM '/ C c selected printing: c** if(ncase.ne.8) return write(N3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC' if(ncase.eq.1) write(N3,101) if(ncase.eq.2) write(N3,102) if(ncase.eq.3) write(N3,103) if(ncase.eq.4) write(N3,104) if(ncase.eq.5) write(N3,105) if(ncase.eq.6) write(N3,106) if(ncase.eq.8) write(N3,108) if(ncase.le.3) JJ=1 if(ncase.eq.4) JJ=2 if(ncase.eq.5) JJ=3 if(ncase.eq.6) JJ=4 if(ncase.eq.8) JJ=2 if(ncase.le.3 .OR. ncase.eq.7) then c if(ncase.ne.8) then write(N3,100) x,p write(N3,110) (NTYPM(KK,JJ),KK=1,4) 110 format(10x,4(3x,a4,5x)) write(N3,*)'-----------------------------------------------------' DO 111 II=1,4 111 write(N3,1) NTYPM(II,1),(VPR(1,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 112 II=1,4 112 write(N3,2) NTYPM(II,1),(VPR(2,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 113 II=1,4 113 write(N3,3) NTYPM(II,1),(VPR(3,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 114 II=1,4 114 write(N3,4) NTYPM(II,1),(VPR(4,1,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 115 II=1,4 115 write(N3,5) NTYPM(II,1),(VPR(5,1,II,KK,NCASE),KK=1,4) call su3prnt(1,ncase,x,p) endif if(ncase.ge.3 .AND. ncase.ne.7) then write(N3,200) x,p write(N3,110) (NTYPM(KK,JJ),KK=1,4) write(N3,*)'-----------------------------------------------------' DO 211 II=1,4 211 write(N3,1) NTYPM(II,1),(VPR(1,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 212 II=1,4 212 write(N3,2) NTYPM(II,1),(VPR(2,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 213 II=1,4 213 write(N3,3) NTYPM(II,1),(VPR(3,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 214 II=1,4 214 write(N3,4) NTYPM(II,1),(VPR(4,2,II,KK,NCASE),KK=1,4) write(N3,*)'=====================================================' DO 215 II=1,4 215 write(N3,5) NTYPM(II,1),(VPR(5,2,II,KK,NCASE),KK=1,4) write(N3,*)'*****************************************************' call su3prnt(2,ncase,x,p) endif return 101 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :',/) 102 format(/,' SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} :',/) 103 format(/,' VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :',/) 104 format(/,' AXIAL (PION-RHO) PAIR TERMS OF THE FIRST CLASS:',/) 105 format(/,' PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:',/) 106 format(/,' PSEUDO SCALAR (PS-POMERON) PAIR TERMS:',/) 107 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :',/) 108 format(/,' AXIAL (PION-PHI) PAIR TERMS OF THE SECND CLASS:',/) 100 format(55('*'),/,' YNPAIR: CENTRAL POTENTIALS: x=',f7.3, .' p=',f4.1,/,55('*')) 200 format(55('*'),/,' YNPAIR: SPIN-SPIN POTENTIALS: x=',f7.3, .' p=',f4.1,/,55('*')) 1 FORMAT(1x,'NN: ',A4,4(F10.3,2X)) 2 FORMAT(1x,'LL: ',A4,4(F10.3,2X)) 3 FORMAT(1x,'LS: ',A4,4(F10.3,2X)) 4 FORMAT(1x,'SS: ',A4,4(F10.3,2X)) 5 FORMAT(1x,'DR: ',A4,4(F10.3,2X)) end C ********************************************************************** SUBROUTINE SU3PRNT(IV,NCASE,X,P) C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PRWRITE/VPR(5,3,4,4,8) DIMENSION VTOT(5) DATA N3/27/ c* DATA N3/6/ C SUMMED CONTRIBUTIONS: DO 120 ICHAN=1,5 VTOT(ICHAN)=0.D0 DO 120 M=1,4 DO 120 N=1,4 120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE) if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/, . ' VCLS=',F10.2,3x,' VCSS=',F10.2,/) if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4) 122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/, . ' VSLS=',F10.2,3x,' VSSS=',F10.2,/) C CONTRIBUTIONS TO SU(3)-POTENTIALS: if(p.eq.1.d0) then V27a = VTOT(1) V27b = VTOT(5) c* V27c = (9*VTOT(2)-VTOT(4))/8.D0 V27c = (3*VTOT(2)-VTOT(3))/3.D0 c V8Sa = 10*VTOT(2)-9*VTOT(5) V8Sa = VTOT(2)+3*VTOT(3) V8Sb = (10*VTOT(4)-VTOT(5))/9.D0 V8Sc = (9*VTOT(4)-VTOT(2))/8.D0 VLSa = (-3*V27b+3*V8Sa)/10.D0 VLSb = (-3*V27b+3*V8Sb)/10.D0 VLSc = (-3*V27c+3*V8Sc)/10.D0 write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc c* write(*,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc 123 format(' V27a =',F10.3,3x,' V27b =',F10.3,3x,' V27c =',F10.3,/, . ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/, . ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2) endif if(p.eq.-1.d0) then V10nn= VTOT(1) V10 = VTOT(5) V10sa= VTOT(2)+VTOT(3) V10sb= VTOT(4)+VTOT(3) V8Aa = VTOT(2)-VTOT(3) V8Ab = VTOT(4)-VTOT(3) write(N3,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10 c* write(*,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10 124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,3x,' V10nn=',F10.2,/, . ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10 =',F10.2) endif write(N3,*)'*****************************************************' return END C ********************************************************************** SUBROUTINE YNPREXPV(X,IPV) C ********************************************************************** C USED: PREXLS_PV.C.TEX C * C COMPUTATION SPIN-ORBIT, NOW USING PV_COUPLING C WHICH GIVES OMEGA's AT THE VERTICES !! C MASS DIFFERENCE CONTRIBUTION FOR STRANGENESS-EXCHANGE C TO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT POTENTIALS C C NOTE: THIS ROUTINE NOT READY FOR SU3F-TEST! C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/MODEL/IXXX(8),NSU3F COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11) COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX DIMENSION FUN(12),WGHTID(2) C COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11), . PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11), . PRTEN(11),PRTENF(11) C communication with routine YNPRCC: C COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10), .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10) ,CCPR7(3,10), .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10), .CCPR11(4,10),CCPR11F(4,10) ! MARCH 2009 COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO . ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2,FASO C COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI, .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN DATA PI/3.14159265D0/,SRPI/1.7724538509D0/ DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/, . AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/, . AKMAX/0000.D0/,XKMAX/2.D0/, . AMLAM/1115D0/,AMSIGM/1190D0/ DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/ data ipipi2/0/ COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5, . VALL1,VALL2,VALL3,VALL4,VALL5 SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL C IF(IPV.NE.1) RETURN C WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING WGHTID(1) = DSIN(THV) WGHTID(2) = DCOS(THV) IF(ICALL.EQ.0) THEN PIM = PIM0 IF(NSU3F.EQ.1) THEN CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS) AMLAM=AMLN AMSIGM=AMLN ENDIF XBEGIN=X FACT = PIM0 c AMNC = DSQRT(AM(2)*AM(3)) c AMHY = DSQRT(AMY(1)*AMY(2)) C AMN = DSQRT(AMNN*AMH ) DAM = AMH-AMNN AA = DAM/PIM0 ENDIF if(p.ne.pold) then icall=0 pold=p nschr=1 endif c DO 1 I=2,NMAX c X = XA(I) VOLL1 = 0D0 VOLL2 = 0D0 VOLL3 = 0D0 VOLL4 = 0D0 VOLL5 = 0D0 VALL1 = 0D0 VALL2 = 0D0 VALL3 = 0D0 VALL4 = 0D0 VALL5 = 0D0 CC CC X1 =1.D0/X X2 =X1*X1 CC CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI) CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1) CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU) C ETA: CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA) C ETAP: CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP) C KAON: c* CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA) CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA) CC * CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR) FIRO = 0.D0 DFIR = 0.D0 DO 410 JJ=1,2 CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ) FIRO = FIRO + AVEC(JJ)*FJJ 410 DFIR = DFIR + AVEC(JJ)*DFJJ C K*(892): CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS) CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO) CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH) CC * CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1) CC CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP) FIEP = 0.D0 DFIEP = 0.D0 DDFIEP= 0.D0 DO 510 JJ=1,2 IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) FIEP = FIEP + ASIG(JJ)*FJJ DFIEP= DFIEP + ASIG(JJ)*DFJJ 510 DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ C S*: IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST) C POMERON: c* XPOM = X*AMPOM/PIM0 c* FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2* c* . FDEXP(-XPOM*XPOM) c* DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO c* DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0) C------------------------------------------------------------ C C CONSTRUCTION OF THE POTENTIALS C C------------------------------------------------------------ C C B) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(IPIET.NE.0) THEN ALM2 = ALMKA DO 20 II=1,3 GOTO(23,24,25),II C PI-KA(8s): 23 FACISC= 0.5d0*SR3 c IF(APV.EQ.1.D0) THEN FACSO1= PIM0/(AMLAM+AMN) FACSO2= PIM0/(2*AMN) FACSO3= PIM0/(AMSIGM+AMN) FACSO4= PIM0/(AMSIGM+AMLAM) copln = +3*prpe1(4)*f(1)*f(4) copsn = +3*prpe1(4)*f(3)*f(5) ALM1 = ALMP8 AM1 = PIM AM2 = AMK GOTO 28 C ETA-KA(8s): 24 FACISC= -0.5D0*DCOS(THPS) copln = +prpe1(4)*f(6)*f(4) copsn = 0.d0 ALM1 = ALMP8 AM1 = AME AM2 = AMK GOTO 28 C ETA'-KA(8s): 25 FACISC= -0.5D0*DSIN(THPS) copln = +prpe1(4)*f(9)*f(4) copsn = 0.d0 ALM1 = ALMP1 AM1 = AMX AM2 = AMK 28 CONTINUE C COMPUTATION SPIN-ORBIT, NOW USING PV_COUPLING C WHICH GIVES OMEGA's AT THE VERTICES: CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) FMSO1 = -X1*FUN(2)*P ! PV-coupling FMSO2 = -X1*FUN(3)*P ! PV-coupling FMSO3 = -X1*FUN(2)*P ! PV-coupling FMSO4 = -X1*FUN(3)*P ! PV-coupling fmso1=0d0 ! terms are already included vi ompair!? fmso2=0d0 fmso3=0d0 fmso4=0d0 VOLL1= VOLL1 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1 . +FACSO2*FMSO2) . + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1 . +FACSO4*FMSO2) c write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn, c write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn, c .' prpe1(4)=',prpe1(4) c write(*,*) ' piet: FMSO1=',FMSO1,' voll1=',voll1 20 CONTINUE c VOLL = VOLL + VOLL1 VALL = VALL + VALL1 ENDIF C C C) VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} : C IF(IPIPI1.NE.0) THEN DO 30 II=1,3 c PX = -1.D0 PSF= -PX PSF= +PX GOTO(33,34,341),II C PI-KA(8a): 33 AM1 = PIM AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FMSO1 = -X1*DFI*VKU*PSF ! PV-coupling FMSO2 = -X1*VKU*DFIKA*PSF ! PV-coupling FACISC = 0.5D0 c IF(APV.EQ.1.D0) THEN FACSO1= PIM0/(AMLAM+AMN) FACSO2= PIM0/(2*AMN) FACSO3= PIM0/(AMSIGM+AMN) FACSO4= PIM0/(AMSIGM+AMLAM) copln = +3*prppg(4)*f(1)*f(4) copsn = +3*prppg(4)*f(3)*f(5) PEX = P GOTO 36 C ETA-KA(8a): 34 AM1 = AME AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FMSO1 = -X1*DFIETA*VKU*PSF ! PV-coupling FMSO2 = -X1*VKU*DFIKA*PSF ! PV-coupling FACISC = 0.5D0*SR3*DCOS(THPS) copln = +prppg(4)*f(6)*f(4) copsn = 0d0 PEX = P C ETAP-KA(8a): 341 AM1 = AMX AM2 = AMK ALM1= ALMP1 ALM2= ALMKA FMSO1 = -X1*DFIETP*VKU*PSF ! PV-coupling FMSO2 = -X1*VKU*DFIKA*PSF ! PV-coupling FACISC = 0.5D0*SR3*DSIN(THPS) copln = +prppg(4)*f(9)*f(4) copsn = 0d0 PEX = P 36 CONTINUE c fmso1=0d0 ! terms already included via ompair!? c fmso2=0d0 c36 CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) c VOLL2 = VOLL2 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1 c . +FACSO2*FMSO2) c . + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1 c . +FACSO4*FMSO2) VALL2 = VALL2 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1 . -FACSO2*FMSO2) . + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1 . +FACSO4*FMSO2) c write(*,*) 'YNPAIRS, pi-pi: II=',ii,' vall2=',vall2 30 CONTINUE VALL = VALL + VALL2 ENDIF C C 3) AXIAL PAIR TERMS OF THE FIRST CLASS: C IF(IPIRO1.NE.0) THEN PX = -1.d0 ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO PSF = -PX PSF = +PX c* ALM1 = ALMP8 ALM2 = ALMV8 DO 40 II=1,6 GOTO(43,44,488,46,47,49),II C PI-K*(AXIAL): 43 FMSO1= (-X1*DFI*FIKS)*PSF FACISC = 0.5D0 FACSO1= PIM0/AMN-PIM0/AMLAM FACSO2= PIM0/AMN+PIM0/AMLAM FACSO3= PIM0/AMN-PIM0/AMSIGM FACSO4= PIM0/AMN+PIM0/AMSIGM DIVLN = 0.5D0*PIM0/AMN DIVSN = 1.0D0*PIM0/(AMLAM+AMSIGM) copln = +3*prpr1(4)*f(1)*(fd(4)+fv(4)) copsn = +3*prpr1(4)*f(3)*(fd(5)+fv(5)) fesig2= dfi*dfiks AM1 = PIM AM2 = AMKS ALM1= ALMP8 PEX = P GOTO 48 C ETA-K*(AXIAL): 44 FMSO1= (-X1*DFIETA*FIKS)*PSF FACISC = 0.5D0*SR3*DCOS(THPS) copln = +prpr1(4)*f(6)*(fd(4)+fv(4)) copsn = 0d0 fesig2= dfieta*dfiks AM1 = AME AM2 = AMKS ALM1= ALMP8 PEX = P GOTO 48 C ETA'-K*(AXIAL): 488 FMSO1= (-X1*DFIETP*FIKS)*PSF FACISC = 0.5D0*SR3*DSIN(THPS) copln = +prpr1(4)*f(9)*(fd(4)+fv(4)) copsn = 0d0 fesig2= dfietp*dfiks AM1 = AMX AM2 = AMKS ALM1= ALMP1 PEX = P GOTO 48 C KA-RO(AXIAL): 46 FMSO1= (-X1*FIKA*DFIR)*PSF FACISC = 0.5D0 FACSO1= 0.D0 FACSO2= 2*PIM0/AMN FACSO3= PIM0/AMLAM-PIM0/AMSIGM FACSO4= PIM0/AMLAM+PIM0/AMSIGM DIVLN = 1.0D0*PIM0/(AMN+AMLAM) DIVSN = 1.0D0*PIM0/(AMN+AMSIGM) copln = +3*prpr1(4)*f(4)*(fd(1)+fv(1)) copsn = +3*prpr1(4)*f(5)*(fd(3)+fv(3)) fesig2= dfika*dfir AM1 = AMK AM2 = AMRO ALM1= ALMKA PEX = P GOTO 48 C KA-PHI(AXIAL): 47 FMSO1= (-X1*FIKA*DFIPH)*PSF FACISC = 0.5D0*SR3*DCOS(THV) copln = +prpr1(4)*f(4)*(fd(6)+fv(6)) copsn = 0d0 fesig2= dfika*dfiph AM1 = AMK AM2 = AMFI ALM1= ALMKA ALM2= ALMV8 PEX = P GOTO 48 C KA-OMEGA(AXIAL): 49 FMSO1= (-X1*FIKA*DFIOM)*PSF FACISC = 0.5D0*SR3*DSIN(THV) copln = +prpr1(4)*f(4)*(fd(9)+fv(9)) copsn = 0d0 fesig2= dfika*dfiom AM1 = AMK AM2 = AMOM ALM1= ALMKA ALM2= ALMV1 PEX = P GOTO 48 48 CONTINUE CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) FMSO3 = -X1*FUN(2) .*PSF FMSO4 = -X1*FUN(3) .*PSF c VALS = VALS - FACT*2*(CCPR4(II,2)+CCPR4F(II,2))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VALS = VALS - FACT*2*(CCPR4(II,3)+CCPR4F(II,3))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VASS = VASS - FACT*2*(CCPR4(II,4)+CCPR4F(II,4))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VADR = VADR - FACT*2*(CCPR4(II,5)+CCPR4F(II,5))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 C COMPARISON WITH PRC54, paper II -> extra overall (-)-sign C------------------------------------------------------------------ C FOR PI-K* ETC: -(i/2) for H_AVP: IF(II.LE.3) THEN c VOLL31= + FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN) c . +(FACSO2-FACSO1)*DIVLN*FMSO4 ) c VOLL32= + FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN) c . -(FACSO4+FACSO3)*DIVSN*FMSO4 ) c voll3 = voll3 + voll31+voll32 cjan07VALL31= + FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN) VALL31= - FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN) . +(FACSO2-FACSO1)*DIVLN*FMSO4 ) VALL32= - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN) . -(FACSO4+FACSO3)*DIVSN*FMSO4 ) vall3 = vall3 + vall31+vall32 c write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3,1=',vall31, c .' vall3,2=',vall32 c vsig3 = - FACT*FACISC*COPLN*FACSO2*FESIG2/3D0 c vsig3 = - FACT*FACISC*COPLN*2*PIM0/AMN*FESIG2/3D0 * if(ii.eq.1) write(*,*) 'YNEXLS: II=',ii,' vsig3,1=',vsig3 ENDIF C------------------------------------------------------------------ C FOR K-RHO ETC: +(i/2) for H_AVP: IF(II.GE.4) THEN c VOLL33= + FACT*FACISC*COPLN*(FACSO2*FMSO4*DIVLN) c VOLL34= - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN) c . -(FACSO4+FACSO3)*DIVSN*FMSO4 ) c voll3 = voll3 + voll33+voll34 VALL33= - FACT*FACISC*COPLN*(FACSO2*FMSO4*DIVLN) VALL34= - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN) . -(FACSO4+FACSO3)*DIVSN*FMSO4 ) vall3 = vall3 + vall33+vall34 c write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3,3=',vall33, c .' vall3,4=',vall34 c vsig3 = - FACT*FACISC*COPLN*FACSO2*FESIG2/3D0 c if(ii.eq.1) write(*,*) 'YNEXLS: II=',ii,' vsig3,2=',vsig3 ENDIF C------------------------------------------------------------------ c write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll3=',voll3 c write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3=',vall3 c write(*,*) ' copln=',copln,' copsn=',copsn c write(*,*) ' fms01=',fmso1,' fmso2=',fmso2 c write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3 40 CONTINUE VOLL = VOLL + VOLL3 VALL = VALL + VALL3 ENDIF C C 4) AXIAL PAIR TERMS OF THE SECOND CLASS: C * IF(IPIRO0.EQ.1) THEN * VSIG = VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2 * . -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) ) * * VTEN = VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2 * . -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) ) * ENDIF C C 5) AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) : c IF(IPIOM.EQ.1) THEN c IF(HOPAIR.NE.0.D0) THEN c VSIG = VSIG + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c VTEN = VTEN + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c ENDIF c ENDIF C------------------------------------------------------------ C C E) AXIAL PAIR TERMS OF THE SECOND CLASS: C C------------------------------------------------------------ C HERE: ETA8 = ETA(548) (THPS IS SMALL), C PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019) C------------------------------------------------------------ IF(IPIOM.EQ.2) THEN ITYPE=5 PX = -1.d0 ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO c* DO 90 II=1,5 DO 90 II=1,4 PEX = 1.D0 GOTO(94,96,95,97,971),II C PI-K*(8S): 94 FMSO1= -X1*(DVKU*FIKS+VKU*DFIKS)*P FMSO2= (-X1*VKU*DFIKS)*P FMSO3= FMSO1 FMSO4= FMSO1 FMSO5= -X1*(DVKU*FIKS-VKU*DFIKS)*P FACISC = +0.25D0*SR3 FACSO1= +0.5D0*(PIM0/AMN-PIM0/AMLAM)*PIM0/AMN FACSO2= -0.5D0*(PIM0/AMN+PIM0/AMLAM)*PIM0/AMN FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM) FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM) . /2.D0 FACSO5= -FACSO4 CALL FOOMPR(ITYPE,X,PIM,AMKS,ALMP8,ALMV8) c** copln = +3*prpo1(4)*f(1)*(fd(4)+fv(4)) c** copsn = +3*prpo1(4)*f(3)*(fd(5)+fv(5)) copln = +3*prpo1(4)*f(1)*fd(4) copsn = +3*prpo1(4)*f(3)*fd(5) PEX = P GOTO 990 C ETA-K*: 96 FMSO1= (-X1*DFI*FIKS)*P FMSO2= (-X1*FI*DFIKS)*P FACISC = -0.25D0*DCOS(THPS) CALL FOOMPR(ITYPE,X,AME,AMKS,ALMP8,ALMV8) c** copln = +prpo1(4)*f(6)*(fd(4)+fv(4)) copln = +prpo1(4)*f(6)*fd(4) copsn = 0d0 PEX = P GOTO 990 C KA-RHO(8S)(I=1): 95 FMSO1= (-X1*VKU*DFIKS)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIKS)*P FMSO4= (-X1*VKU*DFIKS)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3 FACSO1= +2*PIM0/AMN*PIM0/(AMN+AMSIGM) FACSO2= 0.D0 FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)* . PIM0/(AMN+AMSIGM) FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)* . PIM0/(AMN+AMSIGM) FACSO5= 0.D0 CALL FOOMPR(ITYPE,X,AMK,AMRO,ALMP8,ALMV8) c** copln = +prpo1(4)*f(4)*(fd(1)+fv(1)) c** copsn = +prpo1(4)*f(5)*(fd(3)+fv(3)) copln = +prpo1(4)*f(4)*fd(1) copsn = +prpo1(4)*f(5)*fd(3) PEX = P GOTO 990 C KA-PHI8: C KA-OMEGA: 97 FMSO1= (-X1*VKU*DFIOM)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIOM)*P FMSO4= (-X1*VKU*DFIOM)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3*DSIN(THV) CALL FOOMPR(ITYPE,X,AMK,AMOM,ALMP8,ALMV8) FASO = FASO c** copln = +prpo1(4)*f(4)*(fd(9)+fv(9)) copln = +prpo1(4)*f(4)*fd(9) copsn =0d0 PEX = P GOTO 990 C KA-PHI: 971 FMSO1= (-X1*VKU*DFIPH)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIPH)*P FMSO4= (-X1*VKU*DFIPH)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3*DCOS(THV) CALL FOOMPR(ITYPE,X,AMK,AMFI,ALMP8,ALMV8) FASO = FASO c** copln = +prpo1(4)*f(4)*(fd(6)+fv(6)) copln = +prpo1(4)*f(4)*fd(6) copsn = 0d0 PEX = P 990 CONTINUE c !!! NOT INCLUDED VIA OMPAIR !! c --> DO ALSO THE OTHER EXCHANGES!! GOTO 5000 ! NO 1/M^2-TERMS! VOLL4 = VOLL4 + FACT*FACISC* . COPLN*(FACSO1*FMSO1+FACSO2*FMSO2) c write(*,*) 'YNPAIRS, pi-K*: II=',ii,' voll41=',voll4 VOLL4 = VOLL4 + FACT*FACISC*COPSN*(FACSO3*FMSO3+ . FACSO4*FMSO4) VALL4 = VALL4 + FACT*FACISC*COPSN*(FACSO5*FMSO5) c write(*,*) 'YNPAIRS, K-rho : II=',ii,' voll42=',voll4 c write(*,*) 'YNPAIRS, K-rho : II=',ii,' vall42=',vall4 c write(*,*) ' copln=',copln,' copsn=',copsn c write(*,*) ' fms01=',fmso1,' fmso2=',fmso2,' fmso3=',fmso3 c write(*,*) ' fms04=',fmso4,' fmso5=',fmso5 c write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3 c write(*,*) ' facs04=',facso4,' facso5=',facso5 5000 CONTINUE c 1/M-TERMS: VALL4 = VALL4 + PX*FACT*FACISC*FASO* . (COPLN*PIM0/AMN/2D0 - COPSN*PIM0/(AMLAM+AMSIGM)) 90 CONTINUE VOLL = VOLL + VOLL4 VALL = VALL + VALL4 ENDIF C------------------------------------------------------------ C C 6) PSEUDO SCALAR (PION-EPSILON) PAIR TERMS: ccc nog te doen: goto 500 IF(IPISI.NE.0) THEN DO 50 II=1,2 GOTO(52,55),II C KA-EPSILON: 52 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P AM1 = AMK ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 4 GOTO 57 C KA-SSTAR: 55 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P AM1 = AMK AM2 = AMSST ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 3 57 IF(II.LE.3) THEN FFSIG2 = 0.D0 FFTEN2 = 0.D0 IF(N2PRA.EQ.1) THEN DO 112 JJ=1,2 AM2=AMSIG(JJ) CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN) FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX 112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF ELSE CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN) FFSIG2 = +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX FFTEN2 = +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF c VSNN = VSNN + FACT*( c . CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0 c VSLL = VSLL + FACT*( c . CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0 c VSLS = VSLS + FACT*( c . CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0 c VSSS = VSSS + FACT*( c . CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0 c VSDR = VSDR + FACT*( c . CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0 c VTNN = VTNN + FACT*( c . CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0 c VTLL = VTLL + FACT*( c . CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0 c VTLS = VTLS + FACT*( c . CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0 c VTSS = VTSS + FACT*( c . CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0 c VTDR = VTDR + FACT*( c . CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0 50 CONTINUE ENDIF 500 continue C C -------------------------------------------------------------- C 8) TENSOR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C -------------------------------------------------------------- C only 1-pair terms included!! ccc nog te doen: goto 800 IF(IPIPI2.NE.0) THEN DO 80 II=1,2 GOTO(83,84),II C PI-KA(8s): 83 AM1 = PIM AM2 = AMK c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0 IMES1 = 1 IMES2 = 2 GOTO 88 C ETA-KA(8s): 84 AM1 = AMK AM2 = AME c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0 IMES1 = 2 IMES2 = 3 GOTO 88 88 IF(II.EQ.2.OR.II.EQ.5) THEN CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN) ELSE CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN) ENDIF FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO) FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO) FSO1 = -X2*FUN(4)*(PIM/AMPRO) c VCNN = VCNN + ISFAC*FACT* CCPR8(II,1)*FCEN1 c VSNN = VSNN + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0 c VTNN = VTNN + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0 c VONN = VONN + ISFAC*FACT* CCPR8(II,1)*FSO1 c VCLL = VCLL + FACT* CCPR8(II,2)*FCEN1 c VSLL = VSLL + FACT* CCPR8F(II,2)*FSIG1/3.D0 c VTLL = VTLL + FACT* CCPR8F(II,2)*FTEN1/3.D0 c VOLL = VOLL + FACT* CCPR8(II,2)*FSO1 c VCLS = VCLS + FACT* CCPR8(II,3)*FCEN1 c VSLS = VSLS + FACT* CCPR8F(II,3)*FSIG1/3.D0 c VTLS = VTLS + FACT* CCPR8F(II,3)*FTEN1/3.D0 c VOLS = VOLS + FACT* CCPR8(II,3)*FSO1 c VCSS = VCSS + FACT* CCPR8(II,4)*FCEN1 c VSSS = VSSS + FACT* CCPR8F(II,4)*FSIG1/3.D0 c VTSS = VTSS + FACT* CCPR8F(II,4)*FTEN1/3.D0 c VOSS = VOSS + FACT* CCPR8(II,4)*FSO1 c VCDR = VCDR + FACT* CCPR8(II,5)*FCEN1 c VSDR = VSDR + FACT* CCPR8F(II,5)*FSIG1/3.D0 c VTDR = VTDR + FACT* CCPR8F(II,5)*FTEN1/3.D0 c VODR = VODR + FACT* CCPR8(II,5)*FSO1 80 CONTINUE if(x.eq.0.01d0) then write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1 write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 write(*,*) ' ccpr8=',ccpr8(ii,1) endif ENDIF 800 continue ICALL=ICALL+1 RETURN END C ********************************************************************** SUBROUTINE YNPREXPS(X,IPV) C ********************************************************************** C * C MASS DIFFERENCE CONTRIBUTION FOR STRANGENESS-EXCHANGE C TO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT POTENTIALS C ALTERNAIVE COMPUTATION SPIN-ORBIT, NOW USING PS_COUPLING C WHICH GIVES MASS DIFFERENCES AT THE VERTICES !! C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) COMMON/PIMAS/PIM0 COMMON/MODEL/IXXX(8),NSU3F COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1, . ALMKA,ALMKS,ALMKP COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR, . VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR, . VALL,VASS,VALS,VADR COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11) COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL, .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX DIMENSION FUN(12),WGHTID(2) C COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR . ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11), . PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11), . PRTEN(11),PRTENF(11) C communication with routine YNPRCC: C COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10), .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10) ,CCPR7(3,10), .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10), .CCPR11(4,10),CCPR11F(4,10) ! MARCH 2009 C COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI, .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA ! MARCH 2009 COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN DATA PI/3.14159265D0/,SRPI/1.7724538509D0/ DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/ DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/, . AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/, . AKMAX/0000.D0/,XKMAX/2.D0/, . AMLAM/1115D0/,AMSIGM/1190D0/ DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/ data ipipi2/0/ COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5, . VALL1,VALL2,VALL3,VALL4,VALL5 SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL C IF(IPV.NE.0) RETURN C WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING WGHTID(1) = DSIN(THV) WGHTID(2) = DCOS(THV) IF(ICALL.EQ.0) THEN PIM = PIM0 XBEGIN=X IF(NSU3F.EQ.1) CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS) FACT = PIM0 c AMNC = DSQRT(AM(2)*AM(3)) c AMHY = DSQRT(AMY(1)*AMY(2)) C AMN = DSQRT(AMNN*AMH ) DAM = AMH-AMN AA = DAM/PIM0 ENDIF if(p.ne.pold) then icall=0 pold=p nschr=1 endif c DO 1 I=2,NMAX c X = XA(I) VOLL1 = 0D0 VOLL2 = 0D0 VOLL3 = 0D0 VOLL4 = 0D0 VOLL5 = 0D0 VALL1 = 0D0 VALL2 = 0D0 VALL3 = 0D0 VALL4 = 0D0 VALL5 = 0D0 CC CC X1 =1.D0/X X2 =X1*X1 CC CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI) CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1) CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU) C ETA: CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA) C ETAP: CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP) C KAON: c* CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA) CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA) CC c CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR) FIRO = 0.D0 DFIR = 0.D0 DO 410 JJ=1,2 CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ) FIRO = FIRO + AVEC(JJ)*FJJ 410 DFIR = DFIR + AVEC(JJ)*DFJJ C K*(892): CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS) CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO) CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH) CC c CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1) CC CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP) FIEP = 0.D0 DFIEP = 0.D0 DDFIEP= 0.D0 DO 510 JJ=1,2 IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ) FIEP = FIEP + ASIG(JJ)*FJJ DFIEP= DFIEP + ASIG(JJ)*DFJJ 510 DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ C S*: IF(IZSC.EQ.0) CALL .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST) IF(IZSC.NE.0) CALL .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST) C POMERON: c* XPOM = X*AMPOM/PIM0 c* FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2* c* . FDEXP(-XPOM*XPOM) c* DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO c* DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0) C------------------------------------------------------------ C C CONSTRUCTION OF THE POTENTIALS C C------------------------------------------------------------ C C B) SCALAR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C IF(IPIET.NE.0) THEN ALM2 = ALMKA DO 20 II=1,3 GOTO(23,24,25),II C PI-KA(8s): 23 FMSO1 = -X1*DFI*FIKA*P FMSO3 = -X1*FI*DFIKA*P FACISC= 0.5d0*SR3 c IF(APV.EQ.0.D0) THEN FACSO1= (AMLAM-AMN)/(AMLAM+AMN) FACSO2= -(AMSIGM-AMN)/(AMSIGM+AMN) FACSO3= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM) copln = +3*prpe1(4)*f(1)*f(4) copsn = +3*prpe1(4)*f(3)*f(5) ALM1 = ALMP8 AM1 = PIM AM2 = AMK GOTO 28 C ETA-KA(8s): 24 FMSO1 = -X1*DFIETA*FIKA*P FMSO3 = -X1*FIETA*DFIKA*P FACISC= -0.5D0*DCOS(THPS) copln = +prpe1(4)*f(6)*f(4) copsn = 0.d0 ALM1 = ALMP8 AM1 = AME AM2 = AMK GOTO 28 C ETA'-KA(8s): 25 FMSO1 = -X1*DFIETP*FIKA*P FMSO3 = -X1*FIETP*DFIKA*P FACISC= -0.5D0*DSIN(THPS) copln = +prpe1(4)*f(9)*f(4) copsn = 0.d0 ALM1 = ALMP1 AM1 = AMX AM2 = AMK 28 CONTINUE C ALTERNAIVE COMPUTATION SPIN-ORBIT, NOW USING PS_COUPLING C WHICH GIVES MASS DIFFERENCES AT THE VERTICES, INSTEAD C OF OMEGA's: VOLL1= VOLL1 + 4*FACT*FACISC*COPLN*FACSO1*FMSO1 . + 4*FACT*FACISC*COPSN*FACSO2*FMSO1 . + 4*FACT*FACISC*COPSN*FACSO3*FMSO3 write(*,*) ' piet: FMSO1=',FMSO1,' voll1=',voll1 c write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn, c write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn, c .' prpe1(4)=',prpe1(4) 20 CONTINUE c VOLL = VOLL + VOLL1 VALL = VALL + VALL1 ENDIF C C C) VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} : C IF(IPIPI1.NE.0) THEN DO 30 II=1,3 GOTO(33,34,341),II C PI-KA(8a): 33 AM1 = PIM AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FACISC = 0.5D0 c IF(APV.EQ.0.D0) THEN FACSO1= (AMLAM-AMN)/(AMLAM+AMN) FACSO2= -(AMSIGM-AMN)/(AMSIGM+AMN) FACSO2= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM) copln = +3*prppg(4)*f(1)*f(4) copsn = +3*prppg(4)*f(3)*f(5) PEX = P GOTO 36 C ETA-KA(8a): 34 AM1 = AME AM2 = AMK ALM1= ALMP8 ALM2= ALMKA FACISC = 0.5D0*SR3*DCOS(THPS) copln = +prppg(4)*f(6)*f(4) copsn = 0d0 PEX = P C ETAP-KA(8a): 341 AM1 = AMX AM2 = AMK ALM1= ALMP1 ALM2= ALMKA FACISC = 0.5D0*SR3*DSIN(THPS) copln = +prppg(4)*f(9)*f(4) copsn = 0d0 PEX = P 36 CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN) FMSO1 = -X1*FUN(2)*P ! PS-coupling FMSO3 = -X1*FUN(3)*P ! PS-coupling VOLL2 = VOLL2 + 8*FACT*FACISC*(COPLN*FACSO1*FMSO1 . +COPSN*FACSO2*FMSO1+COPSN*FACSO3*FMSO3) write(*,*) 'YNPAIRS, pi-pi: II=',ii,' voll12=',voll2 30 CONTINUE VOLL = VOLL + VOLL2 ENDIF C C 3) AXIAL PAIR TERMS OF THE FIRST CLASS: C IF(IPIRO1.NE.0) THEN PX = -1.d0 ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO copln=0d0 copsn=0d0 c* ALM1 = ALMP8 ALM2 = ALMV8 DO 40 II=1,6 FMASO1= 0.D0 FMASO2= 0.D0 FACISC= 0.D0 GOTO(43,44,488,46,47,49),II C PI-K*(AXIAL): 43 FMSO1= (-X1*DFI*FIKS)*P FMSO2= FMSO1 FMSO3= (-X1*FI*DFIKS)*P FACISC = 0.5D0 FACSO1= PIM0/AMN-PIM0/AMLAM FACSO2= PIM0/AMN-PIM0/AMSIGM FACSO3= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM)* . (1.D0/AMN+1.D0/AMLAM) copln = +3*prpr1(4)*f(1)*(fd(4)+fv(4)) copsn = +3*prpr1(4)*f(3)*(fd(5)+fv(5)) AM1 = PIM AM2 = AMKS ALM1= ALMP8 PEX = P GOTO 48 C ETA-K*(AXIAL): 44 FMSO1= (-X1*DFIETA*FIKS)*P FMSO2= (-X1*FIETA*DFIKS)*P FACISC = 0.5D0*SR3*DCOS(THPS) copln = +prpr1(4)*f(6)*(fd(4)+fv(4)) copsn = 0d0 AM1 = AME AM2 = AMKS ALM1= ALMP8 PEX = P GOTO 48 C ETA'-K*(AXIAL): 488 FMSO1= (-X1*DFIETP*FIKS)*P FMSO2= (-X1*FIETP*DFIKS)*P FACISC = 0.5D0*SR3*DSIN(THPS) copln = +prpr1(4)*f(9)*(fd(4)+fv(4)) copsn = 0d0 AM1 = AMX AM2 = AMKS ALM1= ALMP1 PEX = P GOTO 48 C KA-RO(AXIAL): 46 FMSO1= (-X1*FIKA*DFIR)*P FMSO2= FMSO1 FMSO3= (-X1*DFIKA*FIRO)*P FACISC = 0.5D0 FACSO1= -2*(AMLAM-AMN)/(AMLAM+AMN)*PIM0/AMN FACSO2= +(AMSIGM-AMN)/(AMSIGM+AMN)*(PIM0/AMSIGM+PIM0/AMLAM) FACSO3= +(PIM0/AMLAM-PIM0/AMSIGM) copln = +3*prpr1(4)*f(4)*(fd(1)+fv(1)) copsn = +3*prpr1(4)*f(5)*(fd(3)+fv(3)) AM1 = AMK AM2 = AMRO ALM1= ALMKA PEX = P GOTO 48 C KA-PHI(AXIAL): 47 FMSO1= (-X1*FIKA*DFIPH)*P FMSO2= (-X1*DFIKA*FIPH)*P FACISC = 0.5D0*SR3*DCOS(THV) copln = +prpr1(4)*f(4)*(fd(6)+fv(6)) copsn = 0d0 AM1 = AMK AM2 = AMFI ALM1= ALMKA ALM2= ALMV8 PEX = P GOTO 48 C KA-OMEGA(AXIAL): 49 FMSO1= (-X1*FIKA*DFIOM)*P FMSO2= (-X1*DFIKA*FIOM)*P FACISC = 0.5D0*SR3*DSIN(THV) copln = +prpr1(4)*f(4)*(fd(9)+fv(9)) copsn = 0d0 AM1 = AMK AM2 = AMOM ALM1= ALMKA ALM2= ALMV1 PEX = P GOTO 48 48 CONTINUE c VALS = VALS - FACT*2*(CCPR4(II,2)+CCPR4F(II,2))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VALS = VALS - FACT*2*(CCPR4(II,3)+CCPR4F(II,3))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VASS = VASS - FACT*2*(CCPR4(II,4)+CCPR4F(II,4))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 c VADR = VADR - FACT*2*(CCPR4(II,5)+CCPR4F(II,5))* c . FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1 VOLL3 = VOLL3 + FACT*FACISC*(COPLN*FACSO1 + COPSN*FACSO2)*FMSO1 write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll31=',voll3 VOLL3 = VOLL3 + FACT*FACISC*COPSN*FACSO3*FMSO3 write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll32=',voll3 write(*,*) ' copln=',copln,' copsn=',copsn write(*,*) ' fms01=',fmso1,' fmso2=',fmso2 write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3 40 CONTINUE VOLL = VOLL + VOLL3 ENDIF C C 4) AXIAL PAIR TERMS OF THE SECOND CLASS: C c IF(IPIRO0.EQ.1) THEN c VSIG = VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2 c . -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) ) c c VTEN = VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2 c . -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) ) c ENDIF C C 5) AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) : c IF(IPIOM.EQ.1) THEN c IF(HOPAIR.NE.0.D0) THEN c VSIG = VSIG + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c VTEN = VTEN + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2 c . -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) ) c ENDIF c ENDIF C------------------------------------------------------------ C C E) AXIAL PAIR TERMS OF THE SECOND CLASS: C C------------------------------------------------------------ C HERE: ETA8 = ETA(548) (THPS IS SMALL), C PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019) C------------------------------------------------------------ IF(IPIOM.EQ.2) THEN ccc nog te doen: c* DO 90 II=1,5 DO 90 II=1,4 PEX = 1.D0 GOTO(94,96,95,97,971),II C PI-K*(8S): 94 FMSO1= -X1*(DVKU*FIKS+VKU*DFIKS)*P FMSO2= (-X1*VKU*DFIKS)*P FMSO3= FMSO1 FMSO4= FMSO1 FMSO5= -X1*(DVKU*FIKS-VKU*DFIKS)*P FACISC = +0.25D0*SR3 FACSO1= +0.5D0*(PIM0/AMN-PIM0/AMLAM)*PIM0/AMN FACSO2= -0.5D0*(PIM0/AMN+PIM0/AMLAM)*PIM0/AMN FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM) FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM) . /2.D0 FACSO5= -FACSO4 copln = +3*prpo1(4)*f(1)*(fd(4)+fv(4)) copsn = +3*prpo1(4)*f(3)*(fd(5)+fv(5)) PEX = P GOTO 990 C ETA-K*: 96 FMSO1= (-X1*DFI*FIKS)*P FMSO2= (-X1*FI*DFIKS)*P FACISC = -0.25D0*DCOS(THPS) copln = +prpo1(4)*f(6)*(fd(4)+fv(4)) copsn = 0d0 PEX = P GOTO 990 C KA-RHO(8S)(I=1): 95 FMSO1= (-X1*VKU*DFIKS)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIKS)*P FMSO4= (-X1*VKU*DFIKS)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3 FACSO1= +2*PIM0/AMN*PIM0/(AMN+AMSIGM) FACSO2= 0.D0 FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)* . PIM0/(AMN+AMSIGM) FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)* . PIM0/(AMN+AMSIGM) FACSO5= 0.D0 copln = +prpo1(4)*f(4)*(fd(1)+fv(1)) copsn = +prpo1(4)*f(5)*(fd(3)+fv(3)) PEX = P GOTO 990 C KA-PHI8: C KA-OMEGA: 97 FMSO1= (-X1*VKU*DFIOM)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIOM)*P FMSO4= (-X1*VKU*DFIOM)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3*DSIN(THV) copln = +prpo1(4)*f(4)*(fd(9)+fv(9)) copsn =0d0 PEX = P GOTO 990 C KA-PHI: 971 FMSO1= (-X1*VKU*DFIPH)*P FMSO2= 0.D0 FMSO3= (-X1*DVKU*FIPH)*P FMSO4= (-X1*VKU*DFIPH)*P FMSO5= 0.D0 FACISC = +0.25D0*SR3*DCOS(THV) copln = +prpo1(4)*f(4)*(fd(6)+fv(6)) copsn = 0d0 PEX = P 990 CONTINUE C-----------------------------------------------------------1yy C IN PS-PS THEORY: NO(!) CONTRIBUTIONS: fmso1=0d0 fmso2=0d0 fmso3=0d0 fmso4=0d0 fmso5=0d0 C-----------------------------------------------------------1yy VOLL4 = VOLL4 + FACT*FACISC* . COPLN*(FACSO1*FMSO1+FACSO2*FMSO2) write(*,*) 'YNPAIRS, pi-K*: II=',ii,' voll41=',voll4 VOLL4 = VOLL4 + FACT*FACISC*COPSN*(FACSO3*FMSO3+ . FACSO4*FMSO4) VALL4 = VALL4 + FACT*FACISC*COPSN*(FACSO5*FMSO5) write(*,*) 'YNPAIRS, K-rho : II=',ii,' voll42=',voll4 write(*,*) ' copln=',copln,' copsn=',copsn write(*,*) ' fms01=',fmso1,' fmso2=',fmso2,' fmso3=',fmso3 write(*,*) ' fms04=',fmso4,' fmso5=',fmso5 write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3 write(*,*) ' facs04=',facso4,' facso5=',facso5 90 CONTINUE VOLL = VOLL + VOLL4 VALL = VALL + VALL4 ENDIF C------------------------------------------------------------ C C 6) PSEUDO SCALAR (PION-EPSILON) PAIR TERMS: ccc nog te doen: goto 500 IF(IPISI.NE.0) THEN DO 50 II=1,2 GOTO(52,55),II C KA-EPSILON: 52 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P AM1 = AMK ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 4 GOTO 57 C KA-SSTAR: 55 FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P AM1 = AMK AM2 = AMSST ALM1= ALMKA PEX = P IMES1 = 2 IMES2 = 3 57 IF(II.LE.3) THEN FFSIG2 = 0.D0 FFTEN2 = 0.D0 IF(N2PRA.EQ.1) THEN DO 112 JJ=1,2 AM2=AMSIG(JJ) CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN) FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX 112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF ELSE CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN) FFSIG2 = +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5)) . +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX FFTEN2 = +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5)) . +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX ENDIF c VSNN = VSNN + FACT*( c . CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0 c VSLL = VSLL + FACT*( c . CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0 c VSLS = VSLS + FACT*( c . CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0 c VSSS = VSSS + FACT*( c . CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0 c VSDR = VSDR + FACT*( c . CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0 c VTNN = VTNN + FACT*( c . CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0 c VTLL = VTLL + FACT*( c . CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0 c VTLS = VTLS + FACT*( c . CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0 c VTSS = VTSS + FACT*( c . CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0 c VTDR = VTDR + FACT*( c . CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0 50 CONTINUE ENDIF 500 continue C C -------------------------------------------------------------- C 8) TENSOR SU(3)-OCTET PAIR TERMS, {8s}->{8}x{8} : C -------------------------------------------------------------- C only 1-pair terms included!! ccc nog te doen: goto 800 IF(IPIPI2.NE.0) THEN DO 80 II=1,2 GOTO(83,84),II C PI-KA(8s): 83 AM1 = PIM AM2 = AMK c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0 IMES1 = 1 IMES2 = 2 GOTO 88 C ETA-KA(8s): 84 AM1 = AMK AM2 = AME c CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN) FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA) . +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0 . -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0 IMES1 = 2 IMES2 = 3 GOTO 88 88 IF(II.EQ.2.OR.II.EQ.5) THEN CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN) ELSE CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN) ENDIF FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO) FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO) FSO1 = -X2*FUN(4)*(PIM/AMPRO) c VCNN = VCNN + ISFAC*FACT* CCPR8(II,1)*FCEN1 c VSNN = VSNN + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0 c VTNN = VTNN + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0 c VONN = VONN + ISFAC*FACT* CCPR8(II,1)*FSO1 c VCLL = VCLL + FACT* CCPR8(II,2)*FCEN1 c VSLL = VSLL + FACT* CCPR8F(II,2)*FSIG1/3.D0 c VTLL = VTLL + FACT* CCPR8F(II,2)*FTEN1/3.D0 c VOLL = VOLL + FACT* CCPR8(II,2)*FSO1 c VCLS = VCLS + FACT* CCPR8(II,3)*FCEN1 c VSLS = VSLS + FACT* CCPR8F(II,3)*FSIG1/3.D0 c VTLS = VTLS + FACT* CCPR8F(II,3)*FTEN1/3.D0 c VOLS = VOLS + FACT* CCPR8(II,3)*FSO1 c VCSS = VCSS + FACT* CCPR8(II,4)*FCEN1 c VSSS = VSSS + FACT* CCPR8F(II,4)*FSIG1/3.D0 c VTSS = VTSS + FACT* CCPR8F(II,4)*FTEN1/3.D0 c VOSS = VOSS + FACT* CCPR8(II,4)*FSO1 c VCDR = VCDR + FACT* CCPR8(II,5)*FCEN1 c VSDR = VSDR + FACT* CCPR8F(II,5)*FSIG1/3.D0 c VTDR = VTDR + FACT* CCPR8F(II,5)*FTEN1/3.D0 c VODR = VODR + FACT* CCPR8(II,5)*FSO1 80 CONTINUE c if(x.eq.0.01d0) then c write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1 c write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 c write(*,*) ' ccpr8=',ccpr8(ii,1) c endif ENDIF 800 continue ICALL=ICALL+1 RETURN END C ********************************************************************** SUBROUTINE FUNPS2(N,X,AMES,ALAM,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO) C ********************************************************************** C C 1 C FOURIER TRANSFORM OF F(OMEGA)= (4 PI) x --------- C OMEGA^{N} C FOR N=2; X = DISTANCE IN PION-WAVE-LENGTH C C DF = DF/DX, DDF = D^2 F/DX^2, ETC. , X = PIM*R C C ********************************************************************** IMPLICIT REAL*8(A-H,O-Z) DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,PIM/138.041D0/ c SAVE PIM,PI,SRPI C----------------------------------------------------------------- C C POTENTIAL FUNTION DEFINITION C C----------------------------------------------------------------- F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH) H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH) C----------------------------------------------------------------- CC X1 = 1.D0/X X2 = X1*X1 X3 = X1*X2 X4 = X2*X2 CC RATP =PIM/ALAM XLAM =0.5D0*X*ALAM/PIM XLAM2=XLAM*XLAM VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI) DVKUA =-0.5D0*(ALAM/PIM)**2*X*VKUA DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA) D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA) D4VKUA=-0.5D0*(ALAM/PIM)**2*(X*D3VKUA+3*DDVKUA) C IF(N.EQ.0) THEN C F = (ALAM/PIM)**2*VKUA C DF = (ALAM/PIM)**2*DVKUA C DDF = (ALAM/PIM)**2*DDVKUA C D3F = (ALAM/PIM)**2*D3VKUA C D4F = (ALAM/PIM)**2*D4VKUA C RETURN C ENDIF C IF(N.NE.1) THEN XA =X*AMES/PIM RATA =AMES/ALAM ERATA=DEXP(RATA*RATA) EXA =DEXP(XA) EMA =FDERFC(-XLAM +RATA) EPA =FDERFC( XLAM +RATA) FIA =F0(ERATA,EXA ,EMA ,EPA ,X) HIA =H0(ERATA,EXA ,EMA ,EPA ,X) DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA DHIA =-(AMES/PIM)*FIA -HIA *X1 DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2 D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA . +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3 C D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3 C D4FIA =-(D3FIA-2*D3VKUA)*X1+3*(DDFIA-2*DDVKUA)*X2-(AMES/PIM) C . *D3HIA-6*(DFIA-2*DVKUA)*X3+6*(FIA-2*VKUA)*X4 C----------------------------------------------------------------- C F = FIA C DF = DFIA C DDF = DDFIA C D3F = D3FIA C D4F = D4FIA C----------------------------------------------------------------- FC0 = FIA FC1 = (DDFIA+2*DFIA*X1) FTEN = (DDFIA-DFIA*X1)/3.D0 FSO = -X1*DFIA DFC0 = DFIA DFC1 = (D3FIA+2*DDFIA*X1-2*DFIA*X2) DFTEN = (D3FIA-DDFIA*X1+DFIA*X2)/3.D0 C----------------------------------------------------------------- C IF(N.EQ.2) RETURN C ENDIF CC RETURN END