CDECK ID>, HWHEWW. *CMZ :- -02/05/91 10.58.29 by Federico Carminati *-- Author : Zoltan Kunszt, modified by Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHEWW C----------------------------------------------------------------------- C E+E- -> W+W-/Z0Z0 (BASED ON ZOLTAN KUNSZT'S PROGRAM) C----------------------------------------------------------------------- INCLUDE 'HERWIG61.INC' COMPLEX ZH,ZCH,ZD DOUBLE PRECISION HWUAEM,HWR,HWUPCM,ETOT,STOT,FLUXW,GAMM,GIMM, & WM2,WXMIN,WX1MAX,WX2MAX,FJAC1,FJAC2,WX1,WX2,WMM1,WMM2,XXM,W2BO, & PST,WEIGHT,TOTSIG,WMASS,WWIDTH,ELST,CV,CA,BR,XMASS,PLAB,PRW,PCM, & AMPWW(4),CCC,HELSUM,HELCTY,BRZED(12),BRTOT,CPFAC,CPALL,RLL(12), & RRL(12),DIST(4) INTEGER IB,IBOS,I,ID1,ID2,NTRY,IDP(10),IDBOS(2),J1,J2,IPRC,ILST, & IDZOLT(16),MAP(12),NEWHEP LOGICAL EISBM1,HWRLOG EXTERNAL HWUAEM,HWR,HWUPCM SAVE IDP,STOT,FLUXW,GAMM,GIMM,WM2,WXMIN,WX1MAX,FJAC1,ELST,ILST, & IDBOS,WMASS,WWIDTH COMMON/HWHEWP/XMASS(10),PLAB(5,10),PRW(5,2),PCM(5,10) COMMON/HWHEWQ/ZH(7,7),ZCH(7,7),ZD(7,7) COMMON/HWHEWR/CPFAC(12,12,8),CPALL(8) DATA ELST,ILST/0.,0/ DATA IDZOLT/4,3,8,7,12,11,4*0,2,1,6,5,10,9/ DATA MAP/12,11,2,1,14,13,4,3,16,15,6,5/ IF (IERROR.NE.0) RETURN EISBM1=IDHW(1).LT.IDHW(2) IF (GENEV) THEN NEWHEP=NHEP NHEP=NHEP+2 DO 20 IB=1,2 IBOS=IB+NEWHEP CALL HWVEQU(5,PRW(1,IB),PHEP(1,IBOS)) IF (EISBM1) PHEP(3,IBOS)=-PHEP(3,IBOS) CALL HWVZRO(4,VHEP(1,IBOS)) CALL HWUDKL(IDBOS(IB),PHEP(1,IBOS),DIST) CALL HWVSUM(4,VHEP(1,IBOS),DIST,DIST) IDHW(IBOS)=IDBOS(IB) IDHEP(IBOS)=IDPDG(IDBOS(IB)) JMOHEP(1,IBOS)=1 JMOHEP(2,IBOS)=2 ISTHEP(IBOS)=110 DO 10 I=1,2 CALL HWVEQU(5,PLAB(1,2*IB+I),PHEP(1,NHEP+I)) IF (EISBM1) PHEP(3,NHEP+I)=-PHEP(3,NHEP+I) CALL HWVEQU(4,DIST,VHEP(1,NHEP+I)) C---STATUS, IDs AND POINTERS ISTHEP(NHEP+I)=112+I IDHW(NHEP+I)=IDP(2*IB+I) IDHEP(NHEP+I)=IDPDG(IDP(2*IB+I)) JDAHEP(I,IBOS)=NHEP+I JMOHEP(1,NHEP+I)=IBOS JMOHEP(2,NHEP+I)=JMOHEP(1,IBOS) 10 CONTINUE NHEP=NHEP+2 JMOHEP(2,NHEP)=NHEP-1 JDAHEP(2,NHEP)=NHEP-1 JMOHEP(2,NHEP-1)=NHEP JDAHEP(2,NHEP-1)=NHEP 20 CONTINUE ELSE EMSCA=PHEP(5,3) ETOT=EMSCA IPRC=MOD(IPROC,100) IF (ETOT.NE.ELST .OR. IPRC.NE.ILST) THEN STOT=ETOT*ETOT FLUXW=GEV2NB*.125*(HWUAEM(STOT)/PIFAC)**4/STOT IF (IPRC.EQ.0) THEN WMASS=RMASS(198) WWIDTH=GAMW IDBOS(1)=198 IDBOS(2)=199 ELSEIF (IPRC.EQ.50) THEN WMASS=RMASS(200) WWIDTH=GAMZ IDBOS(1)=200 IDBOS(2)=200 C---LOAD FERMION COUPLINGS TO Z DO 30 I=1,12 RLL(I)=VFCH(MAP(I),1)+AFCH(MAP(I),1) RRL(I)=VFCH(MAP(I),1)-AFCH(MAP(I),1) 30 CONTINUE RLL(11)=0 RRL(11)=0 BRTOT=0 DO 60 J1=1,12 BRZED(J1)=0 DO 50 J2=1,12 CCC=1 IF (MOD(J1-1,4).GE.2) CCC=CCC*CAFAC IF (MOD(J2-1,4).GE.2) CCC=CCC*CAFAC CPFAC(J1,J2,1)=CCC*(RLL(2)**2*RLL(J1)*RLL(J2))**2 CPFAC(J1,J2,2)=CCC*(RLL(2)**2*RRL(J1)*RLL(J2))**2 CPFAC(J1,J2,3)=CCC*(RLL(2)**2*RLL(J1)*RRL(J2))**2 CPFAC(J1,J2,4)=CCC*(RLL(2)**2*RRL(J1)*RRL(J2))**2 CPFAC(J1,J2,5)=CCC*(RRL(2)**2*RLL(J1)*RLL(J2))**2 CPFAC(J1,J2,6)=CCC*(RRL(2)**2*RRL(J1)*RLL(J2))**2 CPFAC(J1,J2,7)=CCC*(RRL(2)**2*RLL(J1)*RRL(J2))**2 CPFAC(J1,J2,8)=CCC*(RRL(2)**2*RRL(J1)*RRL(J2))**2 DO 40 I=1,8 IF (J1.EQ.1.AND.J2.EQ.1) CPALL(I)=0 CPALL(I)=CPALL(I)+CPFAC(J1,J2,I) BRZED(J1)=BRZED(J1)+CPFAC(J1,J2,I) BRTOT=BRTOT+CPFAC(J1,J2,I) 40 CONTINUE 50 CONTINUE 60 CONTINUE DO 70 I=1,12 70 BRZED(I)=BRZED(I)/BRTOT ELSE CALL HWWARN('HWHEWW',500,*999) ENDIF GAMM=WMASS*WWIDTH GIMM=1.D0/GAMM WM2=WMASS*WMASS WXMIN=ATAN(-WMASS/WWIDTH) WX1MAX=ATAN((STOT-WM2)*GIMM) FJAC1=WX1MAX-WXMIN ILST=IPRC ELST=ETOT ENDIF EVWGT=0 C---CHOOSE W MASSES WX1=WXMIN+FJAC1*HWR() WMM1=GAMM*TAN(WX1)+WM2 XMASS(1)=SQRT(WMM1) WX2MAX=ATAN(((ETOT-XMASS(1))**2-WM2)*GIMM) FJAC2=WX2MAX-WXMIN WX2=WXMIN+FJAC2*HWR() WMM2=GAMM*TAN(WX2)+WM2 XMASS(2)=SQRT(WMM2) IF (HWRLOG(HALF))THEN XXM=XMASS(1) XMASS(1)=XMASS(2) XMASS(2)=XXM ENDIF C---CTMAX=ANGULAR CUT ON COS W-ANGLE CALL HWHEW0(1,ETOT,XMASS(1),PRW(1,1),W2BO,CTMAX) IF (W2BO.EQ.ZERO) RETURN C---FOR ZZ EVENTS, FORCE BOSE STATISTICS, BY KILLING EVENTS WITH COS1<0 IF (IPRC.NE.0) THEN IF (PRW(3,1).LT.ZERO) RETURN C---AND THEN SYMMETRIZE (THIS PROCEDURE VASTLY IMPROVES EFFICIENCY) IF (HWRLOG(HALF)) THEN PRW(3,1)=-PRW(3,1) PRW(3,2)=-PRW(3,2) ENDIF ENDIF PLAB(3,1)=0.5*ETOT PLAB(4,1)=PLAB(3,1) PLAB(3,2)=-PLAB(3,1) PLAB(4,2)=PLAB(3,1) C C---LET THE W BOSONS DECAY NTRY=0 80 NTRY=NTRY+1 DO 90 IB=1,2 CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,1) PST=HWUPCM(XMASS(IB),RMASS(ID1),RMASS(ID2)) IF (PST.LT.ZERO) THEN CALL HWDBOZ(IDBOS(IB),ID1,ID2,CV,CA,BR,2) IF (NTRY.LE.NBTRY) GOTO 80 C CALL HWWARN('HWHEWW',1,*999) RETURN ENDIF PRW(5,IB)=XMASS(IB) IDP(2*IB+1)=ID1 IDP(2*IB+2)=ID2 PLAB(5,2*IB+1)=RMASS(ID1) PLAB(5,2*IB+2)=RMASS(ID2) CALL HWDTWO(PRW(1,IB),PLAB(1,2*IB+1),PLAB(1,2*IB+2), & PST,TWO,.TRUE.) 90 CONTINUE WEIGHT=FLUXW*W2BO*FJAC1*FJAC2*(0.5D0*PIFAC*GIMM)**2 CALL HWHEW1(6) CALL HWHEW2(6,PCM(1,1),ZH,ZCH,ZD) IF (IPRC.EQ.0) THEN CALL HWHEW3(5,6,3,4,1,2,AMPWW) TOTSIG=9.*AMPWW(1)+6.*(AMPWW(2)+AMPWW(3))+4.*AMPWW(4) EVWGT=TOTSIG*WEIGHT*BR ELSE ID1=IDZOLT(IDPDG(IDP(3))) ID2=IDZOLT(IDPDG(IDP(5))) CALL HWHEW5(5,6,3,4,1,2,HELSUM,HELCTY,ID1,ID2) EVWGT=HELCTY*WEIGHT*BR/(BRZED(ID1)*BRZED(ID2)) ENDIF ENDIF 999 END CDECK ID>, HWHHVY. *CMZ :- -18/05/99 14.55.44 by Kosuke Odagiri *-- Author : Bryan Webber C----------------------------------------------------------------------- SUBROUTINE HWHHVY C----------------------------------------------------------------------- C QCD HEAVY FLAVOUR PRODUCTION: MEAN EVWGT = SIGMA IN NB C----------------------------------------------------------------------- INCLUDE 'HERWIG61.INC' DOUBLE PRECISION HWR,HWRUNI,HWUALF,EPS,RCS,Z1,Z2,ET,EJ, & QM2,QPE,FACTR,S,T,U,ST,TU,US,TUS,UST,EN,RN,AF,ASTU, & AUST,CF,CN,CS,CSTU,CSUT,CTSU,CTUS,HCS,UT,SU,GT,DIST,KK,KK2, & YJ1INF,YJ1SUP,YJ2INF,YJ2SUP INTEGER IQ1,IQ2,ID1,ID2 LOGICAL HQ1,HQ2 EXTERNAL HWR,HWRUNI,HWUALF SAVE HCS,ASTU,AUST,CSTU,CSUT,CTSU,CTUS,S,T,TU,U,US PARAMETER (EPS=1.D-9) IF (GENEV) THEN RCS=HCS*HWR() ELSE EVWGT=0. CALL HWRPOW(ET,EJ) KK = ET/PHEP(5,3) KK2=KK**2 IF (KK.GE.ONE) RETURN YJ1INF = MAX( YJMIN, LOG((ONE-SQRT(ONE-KK2))/KK) ) YJ1SUP = MIN( YJMAX, LOG((ONE+SQRT(ONE-KK2))/KK) ) IF (YJ1INF.GE.YJ1SUP) RETURN Z1=EXP(HWRUNI(1,YJ1INF,YJ1SUP)) YJ2INF = MAX( YJMIN, -LOG(TWO/KK-ONE/Z1) ) YJ2SUP = MIN( YJMAX, LOG(TWO/KK-Z1) ) IF (YJ2INF.GE.YJ2SUP) RETURN Z2=EXP(HWRUNI(2,YJ2INF,YJ2SUP)) XX(1)=HALF*(Z1+Z2)*KK IF (XX(1).GE.ONE) RETURN XX(2)=XX(1)/(Z1*Z2) IF (XX(2).GE.ONE) RETURN S=XX(1)*XX(2)*PHEP(5,3)**2 IQ1=MOD(IPROC,100) QM2=RMASS(IQ1)**2 QPE=S-4.*QM2 IF (QPE.LE.ZERO) RETURN COSTH=HALF*ET*(Z1-Z2)/SQRT(Z1*Z2*QPE) IF (ABS(COSTH).GT.ONE) RETURN C---REDEFINE S, T, U AS P1.P2, -P1.P3, -P1.P4 S=HALF*S T=-HALF*(1.+Z2/Z1)*(HALF*ET)**2 U=-S-T C---SET EMSCA TO HEAVY HARD PROCESS SCALE EMSCA=SQRT(4.*S*T*U/(S*S+T*T+U*U)) FACTR = GEV2NB*.125*PIFAC*EJ*ET*(HWUALF(1,EMSCA)/S)**2 & *(YJ1SUP-YJ1INF)*(YJ2SUP-YJ2INF) CALL HWSGEN(.FALSE.) C ST=S/T TU=T/U UT=U/T US=U/S SU=S/U TUS=US/ST UST=ST/TU C EN=CAFAC RN=CFFAC/EN AF=FACTR*RN ASTU=AF*(1.-2.*UST+QM2/T) AUST=AF*(1.-2.*TUS+QM2/S) CF=FACTR/(2.*CFFAC) CN=1./(EN*EN) C----------------------------------------------------------------------- C---Heavy flavour colour decomposition modifications below (KO) C----------------------------------------------------------------------- CS=(TU+UT-CN/TUS)*(HALF-TUS+QM2/S-QM2**2/U/T/TWO) CSTU=CF*CS/(ONE+TU**2) CSUT=CF*CS/(ONE+UT**2) CS=(SU+US-CN/UST)*(HALF-UST+QM2/T-QM2**2/U/S/TWO) CTSU=-FACTR*CS/(ONE+SU**2) CTUS=-FACTR*CS/(ONE+US**2) C----------------------------------------------------------------------- C CS=HALF/TU-QM2/T-HALF*(QM2/T)**2 C CSTU=CF*(CS- US**2-QM2/S - CN*(CS+QM2*QM2/(S*T))) C CS=HALF*TU-QM2/U-HALF*(QM2/U)**2 C CSUT=CF*(CS-1./ST**2-QM2/S - CN*(CS+QM2*QM2/(S*U))) C CS=HALF*US-QM2/S-HALF*(QM2/S)**2 C CTSU=-FACTR*(CS-1./TU**2-QM2/T - CN*(CS+QM2*QM2/(S*T))) C CS=HALF/US-QM2/U-HALF*(QM2/U)**2 C CTUS=-FACTR*(CS- ST**2-QM2/T - CN*(CS+QM2*QM2/(T*U))) C----------------------------------------------------------------------- ENDIF C HCS=0. IQ2=IQ1+6 DO 6 ID1=1,13 IF (DISF(ID1,1).LT.EPS) GOTO 6 HQ1=ID1.EQ.IQ1.OR.ID1.EQ.IQ2 DO 5 ID2=1,13 IF (DISF(ID2,2).LT.EPS) GOTO 5 HQ2=ID2.EQ.IQ1.OR.ID2.EQ.IQ2 DIST=DISF(ID1,1)*DISF(ID2,2) IF (HQ1.OR.HQ2) THEN C---PROCESSES INVOLVING HEAVY CONSTITUENT C N.B. NEGLECT CASE THAT BOTH ARE HEAVY IF (HQ1.AND.HQ2) GOTO 5 IF (ID1.LT.7) THEN C---QUARK FIRST IF (ID2.LT.7) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421, 3,*9) ELSEIF (ID2.NE.13) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142, 9,*9) ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,10,*9) HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,11,*9) ENDIF ELSEIF (ID1.NE.13) THEN C---QBAR FIRST IF (ID2.LT.7) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,17,*9) ELSEIF (ID2.NE.13) THEN HCS=HCS+ASTU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,20,*9) ELSE HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,21,*9) HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,22,*9) ENDIF ELSE C---GLUON FIRST IF (ID2.LT.7) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,2413,23,*9) HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3421,24,*9) ELSEIF (ID2.LT.13) THEN HCS=HCS+CTSU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,3142,25,*9) HCS=HCS+CTUS*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(ID1,ID2,4312,26,*9) ENDIF ENDIF ELSEIF (ID2.NE.13.AND.ID2.EQ.ID1+6) THEN C---LIGHT Q-QBAR ANNIHILATION HCS=HCS+AUST*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413, 4,*9) ELSEIF (ID1.NE.13.AND.ID1.EQ.ID2+6) THEN C---LIGHT QBAR-Q ANNIHILATION HCS=HCS+AUST*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ2,IQ1,3142,12,*9) ELSEIF (ID1.EQ.13.AND.ID2.EQ.13) THEN C---GLUON FUSION HCS=HCS+CSTU*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,2413,27,*9) HCS=HCS+CSUT*DIST IF (GENEV.AND.HCS.GT.RCS) CALL HWHQCP(IQ1,IQ2,4123,28,*9) ENDIF 5 CONTINUE 6 CONTINUE EVWGT=HCS RETURN C---GENERATE EVENT 9 IDN(1)=ID1 IDN(2)=ID2 IDCMF=15 CALL HWETWO IF (AZSPIN) THEN C Calculate coefficients for constructing spin density matrices IF (IHPRO.EQ.7 .OR.IHPRO.EQ.8 .OR. & IHPRO.EQ.15.OR.IHPRO.EQ.16) THEN C qqbar-->gg or qbarq-->gg UT=1./TU GCOEF(1)=UT+TU GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=UT-TU GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.10.OR.IHPRO.EQ.11.OR. & IHPRO.EQ.21.OR.IHPRO.EQ.22.OR. & IHPRO.EQ.23.OR.IHPRO.EQ.24.OR. & IHPRO.EQ.25.OR.IHPRO.EQ.26) THEN C qg-->qg or qbarg-->qbarg or gq-->gq or gqbar-->gqbar SU=1./US GCOEF(1)=-(SU+US) GCOEF(2)=0. GCOEF(3)=2. GCOEF(4)=0. GCOEF(5)=SU-US GCOEF(6)=GCOEF(1) GCOEF(7)=-GCOEF(5) ELSEIF (IHPRO.EQ.27.OR.IHPRO.EQ.28) THEN C gg-->qqbar UT=1./TU GCOEF(1)=TU+UT GCOEF(2)=-2. GCOEF(3)=0. GCOEF(4)=0. GCOEF(5)=GCOEF(1) GCOEF(6)=TU-UT GCOEF(7)=-GCOEF(6) ELSEIF (IHPRO.EQ.29.OR.IHPRO.EQ.30.OR. & IHPRO.EQ.31) THEN C gg-->gg GT=S*S+T*T+U*U GCOEF(2)=2.*U*U*T*T GCOEF(3)=2.*S*S*U*U GCOEF(4)=2.*S*S*T*T GCOEF(1)=GT*GT-GCOEF(2)-GCOEF(3)-GCOEF(4) GCOEF(5)=GT*(GT-2.*S*S)-GCOEF(2) GCOEF(6)=GT*(GT-2.*T*T)-GCOEF(3) GCOEF(7)=GT*(GT-2.*U*U)-GCOEF(4) ELSE CALL HWVZRO(7,GCOEF) ENDIF ENDIF 999 END CDECK ID>, HWHIG1. *CMZ :- -23/08/94 13.22.29 by Mike Seymour *-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles C----------------------------------------------------------------------- FUNCTION HWHIG1(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C Basic matrix elements for Higgs + jet production; used in HWHIGA C----------------------------------------------------------------------- IMPLICIT NONE DOUBLE COMPLEX HWHIG1,HWHIG2,HWHIG5,BI(4),CI(7),DI(3) DOUBLE PRECISION S,T,U,EH2,EQ2,S1,T1,U1,ONE,TWO,FOUR,HALF INTEGER I,J,K,I1,J1,K1 COMMON/CINTS/BI,CI,DI PARAMETER (ONE =1.D0, TWO =2.D0, FOUR =4.D0, HALF =0.5D0) C----------------------------------------------------------------------- C +++ helicity amplitude for: g+g --> g+H C----------------------------------------------------------------------- S1=S-EH2 T1=T-EH2 U1=U-EH2 HWHIG1=EQ2*FOUR*DSQRT(TWO*S*T*U)*( & -FOUR*(ONE/(U*T)+ONE/(U*U1)+ONE/(T*T1)) & -FOUR*((TWO*S+T)*BI(K)/U1**2+(TWO*S+U)*BI(J)/T1**2)/S & -(S-FOUR*EQ2)*(S1*CI(I1)+(U-S)*CI(J1)+(T-S)*CI(K1))/(S*T*U) & -8.D0*EQ2*(CI(J1)/(T*T1)+CI(K1)/(U*U1)) & +HALF*(S-FOUR*EQ2)*(S*T*DI(K)+U*S*DI(J)-U*T*DI(I))/(S*T*U) & +FOUR*EQ2*DI(I)/S & -TWO*(U*CI(K)+T*CI(J)+U1*CI(K1)+T1*CI(J1)-U*T*DI(I))/S**2 ) RETURN C----------------------------------------------------------------------- ENTRY HWHIG2(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C ++- helicity amplitude for: g+g --> g+H C----------------------------------------------------------------------- S1=S-EH2 T1=T-EH2 U1=U-EH2 HWHIG2=EQ2*FOUR*DSQRT(TWO*S*T*U)*(FOUR*EH2 & +(EH2-FOUR*EQ2)*(S1*CI(4)+T1*CI(5)+U1*CI(6)) & -HALF*(EH2-FOUR*EQ2)*(S*T*DI(3)+U*S*DI(2)+U*T*DI(1)) )/(S*T*U) RETURN C----------------------------------------------------------------------- ENTRY HWHIG5(S,T,U,EH2,EQ2,I,J,K,I1,J1,K1) C----------------------------------------------------------------------- C Amplitude for: q+qbar --> g+H C----------------------------------------------------------------------- HWHIG5=DCMPLX(TWO+TWO*S/(S-EH2))*BI(I)+DCMPLX(FOUR*EQ2-U-T)*CI(K) RETURN END