cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYRAND
C...Generates quantities characterizing the high-pT scattering at the
C...parton level according to the matrix elements. Chooses incoming,
C...reacting partons, their momentum fractions and one of the possible
C...subprocesses.

      SUBROUTINE PYRAND

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)
      INTEGER PYCOMP
C...Parameter statement to help give large particle numbers.
      PARAMETER (KSUSY1=1000000,KSUSY2=2000000,KTECHN=3000000,
     &KEXCIT=4000000,KDIMEN=5000000)

C...User process initialization and event commonblocks.
      include 'inc/heprup'
      include 'inc/hepeup'

C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pydat2'
      include 'inc/pydat3'
      include 'inc/pysubs'
      include 'inc/pypars'
      include 'inc/pyint1'
      include 'inc/pyint2'
      include 'inc/pyint3'
      include 'inc/pyint4'
      include 'inc/pyint5'
      include 'inc/pyint7'
      include 'inc/pymssm'
      include 'inc/pytcco'
      include 'inc/tcpara'

C...Local arrays.
      DIMENSION XPQ(-25:25),PMM(2),PDIF(4),BHAD(4),PMMN(2)

C...Parameters and data used in elastic/diffractive treatment.
      DATA EPS/0.0808D0/, ALP/0.25D0/, CRES/2D0/, PMRC/1.062D0/,
     &SMP/0.880D0/, BHAD/2.3D0,1.4D0,1.4D0,0.23D0/

C...Initial values, specifically for (first) semihard interaction.
      MINT(10)=0
      MINT(17)=0
      MINT(18)=0
      VINT(143)=1D0
      VINT(144)=1D0
      VINT(157)=0D0
      VINT(158)=0D0
      MFAIL=0
      IF(MSTP(171).EQ.1.AND.MSTP(172).EQ.2) MFAIL=1
      ISUB=0
      ISTSB=0
      LOOP=0
  100 LOOP=LOOP+1
      MINT(51)=0
      MINT(143)=1
      VINT(97)=1D0

C...Start by assuming incoming photon is entering subprocess.
      IF(MINT(11).EQ.22) THEN
         MINT(15)=22
         VINT(307)=VINT(3)**2
      ENDIF
      IF(MINT(12).EQ.22) THEN
         MINT(16)=22
         VINT(308)=VINT(4)**2
      ENDIF
      MINT(103)=MINT(11)
      MINT(104)=MINT(12)

C...Choice of process type - first event of pileup.
      INMULT=0
      IF(MINT(82).EQ.1.AND.ISUB.GE.91.AND.ISUB.LE.96) THEN
      ELSEIF(MINT(82).EQ.1) THEN

C...For gamma-p or gamma-gamma first pick between alternatives.
        IGA=0
        IF(MINT(121).GT.1) CALL PYSAVE(4,IGA)
        MINT(122)=IGA

C...For real gamma + gamma with different nature, flip at random.
        IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
     &  MSTP(14).LE.10.AND.PYR(0).GT.0.5D0) THEN
          MINTSV=MINT(41)
          MINT(41)=MINT(42)
          MINT(42)=MINTSV
          MINTSV=MINT(45)
          MINT(45)=MINT(46)
          MINT(46)=MINTSV
          MINTSV=MINT(107)
          MINT(107)=MINT(108)
          MINT(108)=MINTSV
          IF(MINT(47).EQ.2.OR.MINT(47).EQ.3) MINT(47)=5-MINT(47)
        ENDIF

C...Pick process type, possibly by user process machinery.
C...(If the latter, also event will be picked here.)
        IF(MINT(111).GE.11.AND.ABS(IDWTUP).EQ.2.AND.LOOP.GE.2) THEN
          CALL UPEVNT
          CALL PYUPRE
        ELSEIF(MINT(111).GE.11.AND.ABS(IDWTUP).GE.3) THEN
          CALL UPEVNT
          CALL PYUPRE
          ISUB=0
  110     ISUB=ISUB+1
          IF((ISET(ISUB).NE.11.OR.KFPR(ISUB,2).NE.IDPRUP).AND.
     &    ISUB.LT.500) GOTO 110
        ELSE
          RSUB=XSEC(0,1)*PYR(0)
          DO 120 I=1,500
            IF(MSUB(I).NE.1.OR.I.EQ.96) GOTO 120
            ISUB=I
            RSUB=RSUB-XSEC(I,1)
            IF(RSUB.LE.0D0) GOTO 130
  120     CONTINUE
  130     IF(ISUB.EQ.95) ISUB=96
          IF(ISUB.EQ.96) INMULT=1
          IF(ISET(ISUB).EQ.11) THEN
            IDPRUP=KFPR(ISUB,2)
            CALL UPEVNT
            CALL PYUPRE
          ENDIF
        ENDIF

C...Choice of inclusive process type - pileup events.
      ELSEIF(MINT(82).GE.2.AND.ISUB.EQ.0) THEN
        RSUB=VINT(131)*PYR(0)
        ISUB=96
        IF(RSUB.GT.SIGT(0,0,5)) ISUB=94
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)) ISUB=93
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)) ISUB=92
        IF(RSUB.GT.SIGT(0,0,5)+SIGT(0,0,4)+SIGT(0,0,3)+SIGT(0,0,2))
     &  ISUB=91
        IF(ISUB.EQ.96) INMULT=1
      ENDIF

C...Choice of photon energy and flux factor inside lepton.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
        CALL PYGAGA(3,WTGAGA)
        IF(ISUB.GE.131.AND.ISUB.LE.140) THEN
          CKIN(3)=MAX(VINT(285),VINT(154))
          CKIN(1)=2D0*CKIN(3)
        ENDIF
C...When necessary set direct/resolved photon by hand.
      ELSEIF(MINT(15).EQ.22.OR.MINT(16).EQ.22) THEN
        IF(MINT(15).EQ.22.AND.MINT(41).EQ.2) MINT(15)=0
        IF(MINT(16).EQ.22.AND.MINT(42).EQ.2) MINT(16)=0
      ENDIF

C...Restrict direct*resolved processes to pTmin >= Q,
C...to avoid doublecounting  with DIS.
      IF(MSTP(18).EQ.3.AND.ISUB.GE.131.AND.ISUB.LE.136) THEN
        IF(MINT(15).EQ.22) THEN
          CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(3)))
        ELSE
          CKIN(3)=MAX(VINT(285),VINT(154),ABS(VINT(4)))
        ENDIF
        CKIN(1)=2D0*CKIN(3)
      ENDIF

C...Set up for multiple interactions (may include impact parameter).
      IF(INMULT.EQ.1) THEN
        IF(MINT(35).LE.1) CALL PYMULT(2)
        IF(MINT(35).GE.2) CALL PYMIGN(2)
      ENDIF

C...Loopback point for minimum bias in photon physics.
      LOOP2=0
  140 LOOP2=LOOP2+1
      IF(MINT(82).EQ.1) NGEN(0,1)=NGEN(0,1)+MINT(143)
      IF(MINT(82).EQ.1) NGEN(ISUB,1)=NGEN(ISUB,1)+MINT(143)
      IF(ISUB.EQ.96.AND.LOOP2.EQ.1.AND.MINT(82).EQ.1)
     &NGEN(97,1)=NGEN(97,1)+MINT(143)
      MINT(1)=ISUB
      ISTSB=ISET(ISUB)

C...Random choice of flavour for some SUSY processes.
      IF(ISUB.GE.201.AND.ISUB.LE.301) THEN
C...~e_L ~nu_e or ~mu_L ~nu_mu.
        IF(ISUB.EQ.210) THEN
          KFPR(ISUB,1)=KSUSY1+11+2*INT(0.5D0+PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)+1
C...~nu_e ~nu_e(bar) or ~nu_mu ~nu_mu(bar).
        ELSEIF(ISUB.EQ.213) THEN
          KFPR(ISUB,1)=KSUSY1+12+2*INT(0.5D0+PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q ~chi/~g; ~q = ~d, ~u, ~s, ~c or ~b.
        ELSEIF(ISUB.GE.246.AND.ISUB.LE.259.AND.ISUB.NE.255.AND.
     &  ISUB.NE.257) THEN
          IF(ISUB.GE.258) THEN
            RKF=4D0
          ELSE
            RKF=5D0
          ENDIF
          IF(MOD(ISUB,2).EQ.0) THEN
            KFPR(ISUB,1)=KSUSY1+1+INT(RKF*PYR(0))
          ELSE
            KFPR(ISUB,1)=KSUSY2+1+INT(RKF*PYR(0))
          ENDIF
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.GE.271.AND.ISUB.LE.276) THEN
          IF(ISUB.EQ.271.OR.ISUB.EQ.274) THEN
            KSU1=KSUSY1
            KSU2=KSUSY1
          ELSEIF(ISUB.EQ.272.OR.ISUB.EQ.275) THEN
            KSU1=KSUSY2
            KSU2=KSUSY2
          ELSEIF(PYR(0).LT.0.5D0) THEN
            KSU1=KSUSY1
            KSU2=KSUSY2
          ELSE
            KSU1=KSUSY2
            KSU2=KSUSY1
          ENDIF
          KFPR(ISUB,1)=KSU1+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KSU2+1+INT(4D0*PYR(0))
C...~q ~q(bar);  ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.EQ.277.OR.ISUB.EQ.279) THEN
          KFPR(ISUB,1)=KSUSY1+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
        ELSEIF(ISUB.EQ.278.OR.ISUB.EQ.280) THEN
          KFPR(ISUB,1)=KSUSY2+1+INT(4D0*PYR(0))
          KFPR(ISUB,2)=KFPR(ISUB,1)
C...~q1 ~q2; ~q = ~d, ~u, ~s, or ~c.
        ELSEIF(ISUB.GE.281.AND.ISUB.LE.286) THEN
          IF(ISUB.EQ.281.OR.ISUB.EQ.284) THEN
            KSU1=KSUSY1
            KSU2=KSUSY1
          ELSEIF(ISUB.EQ.282.OR.ISUB.EQ.285) THEN
            KSU1=KSUSY2
            KSU2=KSUSY2
          ELSEIF(PYR(0).LT.0.5D0) THEN
            KSU1=KSUSY1
            KSU2=KSUSY2
          ELSE
            KSU1=KSUSY2
            KSU2=KSUSY1
          ENDIF
          IF(ISUB.EQ.281.OR.ISUB.LE.283) THEN
            RKF=5D0
          ELSE
            RKF=4D0
          ENDIF
          KFPR(ISUB,2)=KSU2+1+INT(RKF*PYR(0))
        ENDIF
      ENDIF

C...Random choice of flavours for some UED processes
c...The production processes can generate a doublet pair,
c...a singlet pair, or a doublet + singlet.
      IF(ISUB.EQ.313)THEN
C...q + q -> q*_Di + q*_Dj, q*_Si + q*_Sj
         IF(PYR(0).LE.0.1)THEN
            KFPR(ISUB,1)=5100001
         ELSE
            KFPR(ISUB,1)=5100002
         ENDIF
         KFPR(ISUB,2)=KFPR(ISUB,1)
      ELSEIF(ISUB.EQ.314.OR.ISUB.EQ.315)THEN
C...g + g -> q*_D + q*_Dbar, q*_S + q*_Sbar
C...q + qbar -> q*_D + q*_Dbar, q*_S + q*_Sbar
         IF(PYR(0).LE.0.1)THEN
            KFPR(ISUB,1)=5100001
         ELSE
            KFPR(ISUB,1)=5100002
         ENDIF
         KFPR(ISUB,2)=-KFPR(ISUB,1)
      ELSEIF(ISUB.EQ.316)THEN
C...qi + qbarj -> q*_Di + q*_Sbarj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
c Changed from private pythia6410_ued code
c            KFPR(ISUB,2)=-5010001
            KFPR(ISUB,2)=-6100002
         ELSE
            KFPR(ISUB,1)=5100002
c Changed from private pythia6410_ued code
c            KFPR(ISUB,2)=-5010002
            KFPR(ISUB,2)=-6100001
         ENDIF
      ELSEIF(ISUB.EQ.317)THEN
C...qi + qbarj -> q*_Di + q*_Dbarj, q*_Si + q*_Dbarj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
            KFPR(ISUB,2)=-5100002
         ELSE
            KFPR(ISUB,1)=5100002
            KFPR(ISUB,2)=-5100001
         ENDIF
      ELSEIF(ISUB.EQ.318)THEN
C...qi + qj -> q*_Di + q*_Sj
         IF(PYR(0).LE.0.5)THEN
            KFPR(ISUB,1)=5100001
            KFPR(ISUB,2)=6100002
         ELSE
            KFPR(ISUB,1)=5100002
            KFPR(ISUB,2)=6100001
         ENDIF
      ENDIF

C...Find resonances (explicit or implicit in cross-section).
      MINT(72)=0
      KFR1=0
      IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
        KFR1=KFPR(ISUB,1)
      ELSEIF(ISUB.EQ.24.OR.ISUB.EQ.25.OR.ISUB.EQ.110.OR.ISUB.EQ.165.OR.
     &  ISUB.EQ.171.OR.ISUB.EQ.176) THEN
        KFR1=23
      ELSEIF(ISUB.EQ.23.OR.ISUB.EQ.26.OR.ISUB.EQ.166.OR.ISUB.EQ.172.OR.
     &  ISUB.EQ.177) THEN
        KFR1=24
      ELSEIF(ISUB.GE.71.AND.ISUB.LE.77) THEN
        KFR1=25
        IF(MSTP(46).EQ.5) THEN
          KFR1=89
          PMAS(89,1)=PARP(45)
          PMAS(89,2)=PARP(45)**3/(96D0*PARU(1)*PARP(47)**2)
        ENDIF
      ELSEIF(ISUB.EQ.481) THEN
        KFR1=9900001
      ENDIF
      CKMX=CKIN(2)
      IF(CKMX.LE.0D0) CKMX=VINT(1)
      KCR1=PYCOMP(KFR1)
      IF(KCR1.EQ.0) KFR1=0
      IF(KFR1.NE.0) THEN
        IF(CKIN(1).GT.PMAS(KCR1,1)+20D0*PMAS(KCR1,2).OR.
     &  CKMX.LT.PMAS(KCR1,1)-20D0*PMAS(KCR1,2)) KFR1=0
      ENDIF
      IF(KFR1.NE.0) THEN
        TAUR1=PMAS(KCR1,1)**2/VINT(2)
        GAMR1=PMAS(KCR1,1)*PMAS(KCR1,2)/VINT(2)
        MINT(72)=1
        MINT(73)=KFR1
        VINT(73)=TAUR1
        VINT(74)=GAMR1
      ENDIF
      KFR2=0
      KFR3=0
      IF(ISUB.EQ.141.OR.ISUB.EQ.194.OR.ISUB.EQ.195.OR.
     $(ISUB.GE.361.AND.ISUB.LE.380))
     $THEN
        KFR2=23
        IF(ISUB.EQ.141) THEN
          KCR2=PYCOMP(KFR2)
          IF(CKIN(1).GT.PMAS(KCR2,1)+20D0*PMAS(KCR2,2).OR.
     &     CKMX.LT.PMAS(KCR2,1)-20D0*PMAS(KCR2,2)) THEN
            KFR2=0
          ELSE
            TAUR2=PMAS(KCR2,1)**2/VINT(2)
            GAMR2=PMAS(KCR2,1)*PMAS(KCR2,2)/VINT(2)
            MINT(72)=2
            MINT(74)=KFR2
            VINT(75)=TAUR2
            VINT(76)=GAMR2
          ENDIF
C...3 resonances at work:   rho, omega, a
        ELSEIF(ISUB.EQ.194.OR.(ISUB.GE.361.AND.ISUB.LE.368)
     &     .OR.ISUB.EQ.379.OR.ISUB.EQ.380) THEN
          MINT(72)=IRES
          IF(IRES.GE.1) THEN
            VINT(73)=XMAS(1)**2/VINT(2)
            VINT(74)=XMAS(1)*XWID(1)/VINT(2)
            TAUR1=VINT(73)
            GAMR1=VINT(74)
            KFR1=1
          ENDIF
          IF(IRES.GE.2) THEN
            VINT(75)=XMAS(2)**2/VINT(2)
            VINT(76)=XMAS(2)*XWID(2)/VINT(2)
            TAUR2=VINT(75)
            GAMR2=VINT(76)
            KFR2=2
          ENDIF
          IF(IRES.EQ.3) THEN
            VINT(77)=XMAS(3)**2/VINT(2)
            VINT(78)=XMAS(3)*XWID(3)/VINT(2)
            TAUR3=VINT(77)
            GAMR3=VINT(78)
            KFR3=3
          ENDIF
C...Charged current:  rho+- and a+-
        ELSEIF(ISUB.EQ.195.OR.ISUB.GE.370.AND.ISUB.LE.378) THEN
          MINT(72)=IRES
          IF(JRES.GE.1) THEN
            VINT(73)=YMAS(1)**2/VINT(2)
            VINT(74)=YMAS(1)*YWID(1)/VINT(2)
            KFR1=1
            TAUR1=VINT(73)
            GAMR1=VINT(74)
          ENDIF
          IF(JRES.GE.2) THEN
            VINT(75)=YMAS(2)**2/VINT(2)
            VINT(76)=YMAS(2)*YWID(2)/VINT(2)
            KFR2=2
            TAUR2=VINT(73)
            GAMR2=VINT(74)
          ENDIF
          KFR3=0
        ENDIF
        IF(ISUB.NE.141) THEN
          IF(KFR3.NE.0.AND.KFR2.NE.0.AND.KFR1.NE.0) THEN

          ELSEIF(KFR1.NE.0.AND.KFR2.NE.0) THEN
            MINT(72)=2
          ELSEIF(KFR1.NE.0.AND.KFR3.NE.0) THEN
            MINT(72)=2
            MINT(74)=KFR3
            VINT(75)=TAUR3
            VINT(76)=GAMR3
          ELSEIF(KFR2.NE.0.AND.KFR3.NE.0) THEN
            MINT(72)=2
            MINT(73)=KFR2
            VINT(73)=TAUR2
            VINT(74)=GAMR2
            MINT(74)=KFR3
            VINT(75)=TAUR3
            VINT(76)=GAMR3
          ELSEIF(KFR1.NE.0) THEN
            MINT(72)=1
          ELSEIF(KFR2.NE.0) THEN
            MINT(72)=1
            MINT(73)=KFR2
            VINT(73)=TAUR2
            VINT(74)=GAMR2
          ELSEIF(KFR3.NE.0) THEN
            MINT(72)=1
            MINT(73)=KFR3
            VINT(73)=TAUR3
            VINT(74)=GAMR3
          ELSE
            MINT(72)=0
          ENDIF
        ELSE
          IF(KFR2.NE.0.AND.KFR1.NE.0) THEN

          ELSEIF(KFR2.NE.0) THEN
            KFR1=KFR2
            TAUR1=TAUR2
            GAMR1=GAMR2
            MINT(72)=1
            MINT(73)=KFR1
            VINT(73)=TAUR1
            VINT(74)=GAMR1
            KFR2=0
          ELSE
            MINT(72)=0
          ENDIF
        ENDIF
      ENDIF

C...Find product masses and minimum pT of process,
C...optionally with broadening according to a truncated Breit-Wigner.
      VINT(63)=0D0
      VINT(64)=0D0
      MINT(71)=0
      VINT(71)=CKIN(3)
      IF(MINT(82).GE.2) VINT(71)=0D0
      VINT(80)=1D0
      IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
        NBW=0
        DO 160 I=1,2
          PMMN(I)=0D0
          IF(KFPR(ISUB,I).EQ.0) THEN
          ELSEIF(MSTP(42).LE.0.OR.PMAS(PYCOMP(KFPR(ISUB,I)),2).LT.
     &      PARP(41)) THEN
            VINT(62+I)=PMAS(PYCOMP(KFPR(ISUB,I)),1)**2
          ELSE
            NBW=NBW+1
C...This prevents SUSY/t particles from becoming too light.
            KFLW=KFPR(ISUB,I)
            IF(KFLW/KSUSY1.EQ.1.OR.KFLW/KSUSY1.EQ.2) THEN
              KCW=PYCOMP(KFLW)
              PMMN(I)=PMAS(KCW,1)
              DO 150 IDC=MDCY(KCW,2),MDCY(KCW,2)+MDCY(KCW,3)-1
                IF(MDME(IDC,1).GT.0.AND.BRAT(IDC).GT.1E-4) THEN
                  PMSUM=PMAS(PYCOMP(KFDP(IDC,1)),1)+
     &            PMAS(PYCOMP(KFDP(IDC,2)),1)
                  IF(KFDP(IDC,3).NE.0) PMSUM=PMSUM+
     &            PMAS(PYCOMP(KFDP(IDC,3)),1)
                  PMMN(I)=MIN(PMMN(I),PMSUM)
                ENDIF
  150         CONTINUE
            ELSEIF(KFLW.EQ.6) THEN
              PMMN(I)=PMAS(24,1)+PMAS(5,1)
            ENDIF
          ENDIF
  160   CONTINUE
        IF(NBW.GE.1) THEN
          CKIN41=CKIN(41)
          CKIN43=CKIN(43)
          CKIN(41)=MAX(PMMN(1),CKIN(41))
          CKIN(43)=MAX(PMMN(2),CKIN(43))
          CALL PYOFSH(4,0,KFPR(ISUB,1),KFPR(ISUB,2),0D0,PQM3,PQM4)
          CKIN(41)=CKIN41
          CKIN(43)=CKIN43
          IF(MINT(51).EQ.1) THEN
            IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
            IF(MFAIL.EQ.1) THEN
              MSTI(61)=1
              RETURN
            ENDIF
            GOTO 100
          ENDIF
          VINT(63)=PQM3**2
          VINT(64)=PQM4**2
        ENDIF
        IF(MIN(VINT(63),VINT(64)).LT.CKIN(6)**2) MINT(71)=1
        IF(MINT(71).EQ.1) VINT(71)=MAX(CKIN(3),CKIN(5))
      ENDIF

C...Prepare for additional variable choices in 2 -> 3.
      IF(ISTSB.EQ.5) THEN
        VINT(201)=0D0
        IF(KFPR(ISUB,2).GT.0) VINT(201)=PMAS(PYCOMP(KFPR(ISUB,2)),1)
        VINT(206)=VINT(201)
        IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(206)=PMAS(5,1)
        VINT(204)=PMAS(23,1)
        IF(ISUB.EQ.124.OR.ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351)
     &   VINT(204)=PMAS(24,1)
        IF(ISUB.EQ.352) VINT(204)=PMAS(PYCOMP(9900024),1)
        IF(ISUB.EQ.121.OR.ISUB.EQ.122.OR.ISUB.EQ.181.OR.ISUB.EQ.182.OR.
     &    ISUB.EQ.186.OR.ISUB.EQ.187.OR.ISUB.EQ.401.OR.ISUB.EQ.402)
     &         VINT(204)=VINT(201)
        VINT(209)=VINT(204)
          IF(ISUB.EQ.401.OR.ISUB.EQ.402) VINT(209)=VINT(206)
      ENDIF

C...Select incoming VDM particle (rho/omega/phi/J/psi).
      IF(ISTSB.NE.0.AND.(MINT(101).GE.2.OR.MINT(102).GE.2).AND.
     &(MINT(123).EQ.2.OR.MINT(123).EQ.3.OR.MINT(123).EQ.7)) THEN
        VRN=PYR(0)*SIGT(0,0,5)
        IF(MINT(101).LE.1) THEN
          I1MN=0
          I1MX=0
        ELSE
          I1MN=1
          I1MX=MINT(101)
        ENDIF
        IF(MINT(102).LE.1) THEN
          I2MN=0
          I2MX=0
        ELSE
          I2MN=1
          I2MX=MINT(102)
        ENDIF
        DO 180 I1=I1MN,I1MX
          KFV1=110*I1+3
          DO 170 I2=I2MN,I2MX
            KFV2=110*I2+3
            VRN=VRN-SIGT(I1,I2,5)
            IF(VRN.LE.0D0) GOTO 190
  170     CONTINUE
  180   CONTINUE
  190   IF(MINT(101).GE.2) MINT(103)=KFV1
        IF(MINT(102).GE.2) MINT(104)=KFV2
      ENDIF

      IF(ISTSB.EQ.0) THEN
C...Elastic scattering or single or double diffractive scattering.

C...Select incoming particle (rho/omega/phi/J/psi for VDM) and mass.
        MINT(103)=MINT(11)
        MINT(104)=MINT(12)
        PMM(1)=VINT(3)
        PMM(2)=VINT(4)
        IF(MINT(101).GE.2.OR.MINT(102).GE.2) THEN
          JJ=ISUB-90
          VRN=PYR(0)*SIGT(0,0,JJ)
          IF(MINT(101).LE.1) THEN
            I1MN=0
            I1MX=0
          ELSE
            I1MN=1
            I1MX=MINT(101)
          ENDIF
          IF(MINT(102).LE.1) THEN
            I2MN=0
            I2MX=0
          ELSE
            I2MN=1
            I2MX=MINT(102)
          ENDIF
          DO 210 I1=I1MN,I1MX
            KFV1=110*I1+3
            DO 200 I2=I2MN,I2MX
              KFV2=110*I2+3
              VRN=VRN-SIGT(I1,I2,JJ)
              IF(VRN.LE.0D0) GOTO 220
  200       CONTINUE
  210     CONTINUE
  220     IF(MINT(101).GE.2) THEN
            MINT(103)=KFV1
            PMM(1)=PYMASS(KFV1)
          ENDIF
          IF(MINT(102).GE.2) THEN
            MINT(104)=KFV2
            PMM(2)=PYMASS(KFV2)
          ENDIF
        ENDIF
        VINT(67)=PMM(1)
        VINT(68)=PMM(2)

C...Select mass for GVMD states (rejecting previous assignment).
        Q0S=4D0*PARP(15)**2
        Q1S=4D0*VINT(154)**2
        LOOP3=0
  230   LOOP3=LOOP3+1
        DO 240 JT=1,2
          IF(MINT(106+JT).EQ.3) THEN
            PS=VINT(2+JT)**2
            PMM(JT)=SQRT((Q0S+PS)*(Q1S+PS)/
     &      (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS)
            IF(MINT(102+JT).GE.333) PMM(JT)=PMM(JT)-
     &      PMAS(PYCOMP(113),1)+PMAS(PYCOMP(MINT(102+JT)),1)
          ENDIF
  240   CONTINUE
        IF(PMM(1)+PMM(2)+PARP(104).GE.VINT(1)) THEN
          IF(LOOP3.LT.100.AND.(MINT(107).EQ.3.OR.MINT(108).EQ.3))
     &    GOTO 230
          GOTO 100
        ENDIF

C...Side/sides of diffractive system.
        MINT(17)=0
        MINT(18)=0
        IF(ISUB.EQ.92.OR.ISUB.EQ.94) MINT(17)=1
        IF(ISUB.EQ.93.OR.ISUB.EQ.94) MINT(18)=1

C...Find masses of particles and minimal masses of diffractive states.
        DO 250 JT=1,2
          PDIF(JT)=PMM(JT)
          VINT(68+JT)=PDIF(JT)
          IF(MINT(16+JT).EQ.1) PDIF(JT)=PDIF(JT)+PARP(102)
  250   CONTINUE
        SH=VINT(2)
        SQM1=PMM(1)**2
        SQM2=PMM(2)**2
        SQM3=PDIF(1)**2
        SQM4=PDIF(2)**2
        SMRES1=(PMM(1)+PMRC)**2
        SMRES2=(PMM(2)+PMRC)**2

C...Find elastic slope and lower limit diffractive slope.
        IHA=MAX(2,ABS(MINT(103))/110)
        IF(IHA.GE.5) IHA=1
        IHB=MAX(2,ABS(MINT(104))/110)
        IF(IHB.GE.5) IHB=1
        IF(ISUB.EQ.91) THEN
          BMN=2D0*BHAD(IHA)+2D0*BHAD(IHB)+4D0*SH**EPS-4.2D0
        ELSEIF(ISUB.EQ.92) THEN
          BMN=MAX(2D0,2D0*BHAD(IHB))
        ELSEIF(ISUB.EQ.93) THEN
          BMN=MAX(2D0,2D0*BHAD(IHA))
        ELSEIF(ISUB.EQ.94) THEN
          BMN=2D0*ALP*4D0
        ENDIF

C...Determine maximum possible t range and coefficient of generation.
        SQLA12=(SH-SQM1-SQM2)**2-4D0*SQM1*SQM2
        SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
        THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
        THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
        THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
     &  (SQM1*SQM4-SQM2*SQM3)/SH
        THL=-0.5D0*(THA+THB)
        THU=THC/THL
        THRND=EXP(MAX(-50D0,BMN*(THL-THU)))-1D0

C...Select diffractive mass/masses according to dm^2/m^2.
        LOOP3=0
  260   LOOP3=LOOP3+1
        DO 270 JT=1,2
          IF(MINT(16+JT).EQ.0) THEN
            PDIF(2+JT)=PDIF(JT)
          ELSE
            PMMIN=PDIF(JT)
            PMMAX=MAX(VINT(2+JT),VINT(1)-PDIF(3-JT))
            PDIF(2+JT)=PMMIN*(PMMAX/PMMIN)**PYR(0)
          ENDIF
  270   CONTINUE
        SQM3=PDIF(3)**2
        SQM4=PDIF(4)**2

C..Additional mass factors, including resonance enhancement.
        IF(PDIF(3)+PDIF(4).GE.VINT(1)) THEN
          IF(LOOP3.LT.100) GOTO 260
          GOTO 100
        ENDIF
        IF(ISUB.EQ.92) THEN
          FSD=(1D0-SQM3/SH)*(1D0+CRES*SMRES1/(SMRES1+SQM3))
          IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
        ELSEIF(ISUB.EQ.93) THEN
          FSD=(1D0-SQM4/SH)*(1D0+CRES*SMRES2/(SMRES2+SQM4))
          IF(FSD.LT.PYR(0)*(1D0+CRES)) GOTO 260
        ELSEIF(ISUB.EQ.94) THEN
          FDD=(1D0-(PDIF(3)+PDIF(4))**2/SH)*(SH*SMP/
     &    (SH*SMP+SQM3*SQM4))*(1D0+CRES*SMRES1/(SMRES1+SQM3))*
     &    (1D0+CRES*SMRES2/(SMRES2+SQM4))
          IF(FDD.LT.PYR(0)*(1D0+CRES)**2) GOTO 260
        ENDIF

C...Select t according to exp(Bmn*t) and correct to right slope.
        TH=THU+LOG(1D0+THRND*PYR(0))/BMN
        IF(ISUB.GE.92) THEN
          IF(ISUB.EQ.92) THEN
            BADD=2D0*ALP*LOG(SH/SQM3)
            IF(BHAD(IHB).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHB)-2D0)
          ELSEIF(ISUB.EQ.93) THEN
            BADD=2D0*ALP*LOG(SH/SQM4)
            IF(BHAD(IHA).LT.1D0) BADD=MAX(0D0,BADD+2D0*BHAD(IHA)-2D0)
          ELSEIF(ISUB.EQ.94) THEN
            BADD=2D0*ALP*(LOG(EXP(4D0)+SH/(ALP*SQM3*SQM4))-4D0)
          ENDIF
          IF(EXP(MAX(-50D0,BADD*(TH-THU))).LT.PYR(0)) GOTO 260
        ENDIF

C...Check whether m^2 and t choices are consistent.
        SQLA34=(SH-SQM3-SQM4)**2-4D0*SQM3*SQM4
        THA=SH-(SQM1+SQM2+SQM3+SQM4)+(SQM1-SQM2)*(SQM3-SQM4)/SH
        THB=SQRT(MAX(0D0,SQLA12))*SQRT(MAX(0D0,SQLA34))/SH
        IF(THB.LE.1D-8) GOTO 260
        THC=(SQM3-SQM1)*(SQM4-SQM2)+(SQM1+SQM4-SQM2-SQM3)*
     &  (SQM1*SQM4-SQM2*SQM3)/SH
        THLM=-0.5D0*(THA+THB)
        THUM=THC/THLM
        IF(TH.LT.THLM.OR.TH.GT.THUM) GOTO 260

C...Information to output.
        VINT(21)=1D0
        VINT(22)=0D0
        VINT(23)=MIN(1D0,MAX(-1D0,(THA+2D0*TH)/THB))
        VINT(45)=TH
        VINT(59)=2D0*SQRT(MAX(0D0,-(THC+THA*TH+TH**2)))/THB
        VINT(63)=PDIF(3)**2
        VINT(64)=PDIF(4)**2
        VINT(283)=PMM(1)**2/4D0
        VINT(284)=PMM(2)**2/4D0

C...Note: in the following, by In is meant the integral over the
C...quantity multiplying coefficient cn.
C...Choose tau according to h1(tau)/tau, where
C...h1(tau) = c1 + I1/I2*c2*1/tau + I1/I3*c3*1/(tau+tau_R) +
C...I1/I4*c4*tau/((s*tau-m^2)^2+(m*Gamma)^2) +
C...I1/I5*c5*1/(tau+tau_R') +
C...I1/I6*c6*tau/((s*tau-m'^2)^2+(m'*Gamma')^2) +
C...I1/I7*c7*tau/(1.-tau), and
C...c1 + c2 + c3 + c4 + c5 + c6 + c7 = 1.
      ELSEIF(ISTSB.GE.1.AND.ISTSB.LE.5) THEN
        CALL PYKLIM(1)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        RTAU=PYR(0)
        MTAU=1
        IF(RTAU.GT.COEF(ISUB,1)) MTAU=2
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)) MTAU=3
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)) MTAU=4
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4))
     &  MTAU=5
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
     &  COEF(ISUB,5)) MTAU=6
        IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)+COEF(ISUB,4)+
     &  COEF(ISUB,5)+COEF(ISUB,6)) MTAU=7
C...Additional check to handle techni-processes with extra resonance
C....Only modify tau treatment
        IF(ISUB.EQ.194.OR.ISUB.EQ.195.OR.(ISUB.GE.361.AND.ISUB.LE.380))
     &   THEN
          IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
     &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)) MTAU=8
          IF(RTAU.GT.COEF(ISUB,1)+COEF(ISUB,2)+COEF(ISUB,3)
     &     +COEF(ISUB,4)+COEF(ISUB,5)+COEF(ISUB,6)+COEF(ISUB,7)
     &     +COEFX(ISUB,1)) MTAU=9
        ENDIF
        CALL PYKMAP(1,MTAU,PYR(0))

C...2 -> 3, 4 processes:
C...Choose tau' according to h4(tau,tau')/tau', where
C...h4(tau,tau') = c1 + I1/I2*c2*(1 - tau/tau')^3/tau' +
C...I1/I3*c3*1/(1 - tau'), and c1 + c2 + c3 = 1.
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
          CALL PYKLIM(4)
          IF(MINT(51).NE.0) THEN
            IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
            IF(MFAIL.EQ.1) THEN
              MSTI(61)=1
              RETURN
            ENDIF
            GOTO 100
          ENDIF
          RTAUP=PYR(0)
          MTAUP=1
          IF(RTAUP.GT.COEF(ISUB,18)) MTAUP=2
          IF(RTAUP.GT.COEF(ISUB,18)+COEF(ISUB,19)) MTAUP=3
          CALL PYKMAP(4,MTAUP,PYR(0))
        ENDIF

C...Choose y* according to h2(y*), where
C...h2(y*) = I0/I1*c1*(y*-y*min) + I0/I2*c2*(y*max-y*) +
C...I0/I3*c3*1/cosh(y*) + I0/I4*c4*1/(1-exp(y*-y*max)) +
C...I0/I5*c5*1/(1-exp(-y*-y*min)), I0 = y*max-y*min,
C...and c1 + c2 + c3 + c4 + c5 = 1.
        CALL PYKLIM(2)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        RYST=PYR(0)
        MYST=1
        IF(RYST.GT.COEF(ISUB,8)) MYST=2
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)) MYST=3
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)) MYST=4
        IF(RYST.GT.COEF(ISUB,8)+COEF(ISUB,9)+COEF(ISUB,10)+
     &  COEF(ISUB,11)) MYST=5
        CALL PYKMAP(2,MYST,PYR(0))

C...2 -> 2 processes:
C...Choose cos(theta-hat) (cth) according to h3(cth), where
C...h3(cth) = c0 + I0/I1*c1*1/(A - cth) + I0/I2*c2*1/(A + cth) +
C...I0/I3*c3*1/(A - cth)^2 + I0/I4*c4*1/(A + cth)^2,
C...A = 1 + 2*(m3*m4/sh)^2 (= 1 for massless products),
C...and c0 + c1 + c2 + c3 + c4 = 1.
        CALL PYKLIM(3)
        IF(MINT(51).NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
        IF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
          RCTH=PYR(0)
          MCTH=1
          IF(RCTH.GT.COEF(ISUB,13)) MCTH=2
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)) MCTH=3
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)) MCTH=4
          IF(RCTH.GT.COEF(ISUB,13)+COEF(ISUB,14)+COEF(ISUB,15)+
     &    COEF(ISUB,16)) MCTH=5
          CALL PYKMAP(3,MCTH,PYR(0))
        ENDIF

C...2 -> 3 : select pT1, phi1, pT2, phi2, y3 for 3 outgoing.
        IF(ISTSB.EQ.5) THEN
          CALL PYKMAP(5,0,0D0)
          IF(MINT(51).NE.0) THEN
            IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
            IF(MFAIL.EQ.1) THEN
              MSTI(61)=1
              RETURN
            ENDIF
            GOTO 100
          ENDIF
        ENDIF

C...DIS as f + gamma* -> f process: set dummy values.
      ELSEIF(ISTSB.EQ.8) THEN
        VINT(21)=0.9D0
        VINT(22)=0D0
        VINT(23)=0D0
        VINT(47)=0D0
        VINT(48)=0D0

C...Low-pT or multiple interactions (first semihard interaction).
      ELSEIF(ISTSB.EQ.9) THEN
        IF(MINT(35).LE.1) CALL PYMULT(3)
        IF(MINT(35).GE.2) CALL PYMIGN(3)
        ISUB=MINT(1)

C...Study user-defined process: kinematics plus weight.
      ELSEIF(ISTSB.EQ.11) THEN
        IF(IDWTUP.GT.0.AND.XWGTUP.LT.0D0) CALL
     &  PYERRM(26,'(PYRAND:) Negative XWGTUP for user process')
        MSTI(51)=0
        IF(NUP.LE.0) THEN
          MINT(51)=2
          MSTI(51)=1
          IF(MINT(82).EQ.1) THEN
            NGEN(0,1)=NGEN(0,1)-1
            NGEN(ISUB,1)=NGEN(ISUB,1)-1
          ENDIF
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          RETURN
        ENDIF

C...Extract cross section event weight.
        IF(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.4) THEN
          SIGS=1D-9*XWGTUP
        ELSE
          SIGS=1D-9*XSECUP(KFPR(ISUB,1))
        ENDIF
        IF(ABS(IDWTUP).GE.1.AND.ABS(IDWTUP).LE.3) THEN
          VINT(97)=SIGN(1D0,XWGTUP)
        ELSE
          VINT(97)=1D-9*XWGTUP
        ENDIF

C...Construct 'trivial' kinematical variables needed.
        KFL1=IDUP(1)
        KFL2=IDUP(2)
        VINT(41)=PUP(4,1)/EBMUP(1)
        VINT(42)=PUP(4,2)/EBMUP(2)
        IF (VINT(41).GT.1.000001.OR.VINT(42).GT.1.000001) THEN
          CALL PYERRM(9,'(PYRAND:) x > 1 in external event '//
     &        '(listing follows):')
          CALL PYLIST(7)
        ENDIF
        VINT(21)=VINT(41)*VINT(42)
        VINT(22)=0.5D0*LOG(VINT(41)/VINT(42))
        VINT(44)=VINT(21)*VINT(2)
        VINT(43)=SQRT(MAX(0D0,VINT(44)))
        VINT(55)=SCALUP
        IF(SCALUP.LE.0D0) VINT(55)=VINT(43)
        VINT(56)=VINT(55)**2
        VINT(57)=AQEDUP
        VINT(58)=AQCDUP

C...Construct other kinematical variables needed (approximately).
        VINT(23)=0D0
        VINT(26)=VINT(21)
        VINT(45)=-0.5D0*VINT(44)
        VINT(46)=-0.5D0*VINT(44)
        VINT(49)=VINT(43)
        VINT(50)=VINT(44)
        VINT(51)=VINT(55)
        VINT(52)=VINT(56)
        VINT(53)=VINT(55)
        VINT(54)=VINT(56)
        VINT(25)=0D0
        VINT(48)=0D0
        IF(ISTUP(1).NE.-1.OR.ISTUP(2).NE.-1) CALL PYERRM(26,
     &  '(PYRAND:) unacceptable ISTUP code for incoming particles')
        DO 280 IUP=3,NUP
          IF(ISTUP(IUP).LT.1.OR.ISTUP(IUP).GT.3) CALL PYERRM(26,
     &    '(PYRAND:) unacceptable ISTUP code for particles')
          IF(ISTUP(IUP).EQ.1) VINT(25)=VINT(25)+2D0*(PUP(5,IUP)**2+
     &    PUP(1,IUP)**2+PUP(2,IUP)**2)/VINT(2)
          IF(ISTUP(IUP).EQ.1) VINT(48)=VINT(48)+0.5D0*(PUP(1,IUP)**2+
     &    PUP(2,IUP)**2)
  280   CONTINUE
        VINT(47)=SQRT(VINT(48))
      ENDIF

C...Choose azimuthal angle.
      VINT(24)=0D0
      IF(ISTSB.NE.11) VINT(24)=PARU(2)*PYR(0)

C...Check against user cuts on kinematics at parton level.
      MINT(51)=0
      IF((ISUB.LE.90.OR.ISUB.GT.100).AND.ISTSB.LE.10) CALL PYKLIM(0)
      IF(MINT(51).NE.0) THEN
        IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
        IF(MFAIL.EQ.1) THEN
          MSTI(61)=1
          RETURN
        ENDIF
        GOTO 100
      ENDIF
      IF(MINT(82).EQ.1.AND.MSTP(141).GE.1.AND.ISTSB.LE.10) THEN
        MCUT=0
        IF(MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+MSUB(95).EQ.0)
     &  CALL PYKCUT(MCUT)
        IF(MCUT.NE.0) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
      ENDIF

      IF(ISTSB.LE.10) THEN
C...  If internal process, call PYSIGH
        CALL PYSIGH(NCHN,SIGS)
      ELSE
C...  If external process, still have to set MI starting scale
        IF (MSTP(86).EQ.1) THEN
C...  Limit phase space by xT2 of hard interaction
C...  (gives undercounting of MI when ext proc != dijets)
          XT2GMX = VINT(25)
        ELSE
C...  All accessible phase space allowed
C...  (gives double counting of MI when ext proc = dijets)
          XT2GMX = (1D0-VINT(41))*(1D0-VINT(42))
        ENDIF
        VINT(62)=0.25D0*XT2GMX*VINT(2)
        VINT(61)=SQRT(MAX(0D0,VINT(62)))
      ENDIF

      SIGSOR=SIGS
      SIGLPT=SIGT(0,0,5)*VINT(315)*VINT(316)

C...Multiply cross section by lepton -> photon flux factor.
      IF(MINT(141).NE.0.OR.MINT(142).NE.0) THEN
        SIGS=WTGAGA*SIGS
        DO 290 ICHN=1,NCHN
          SIGH(ICHN)=WTGAGA*SIGH(ICHN)
  290   CONTINUE
        SIGLPT=WTGAGA*SIGLPT
      ENDIF

C...Multiply cross-section by user-defined weights.
      IF(MSTP(173).EQ.1) THEN
        SIGS=PARP(173)*SIGS
        DO 300 ICHN=1,NCHN
          SIGH(ICHN)=PARP(173)*SIGH(ICHN)
  300   CONTINUE
        SIGLPT=PARP(173)*SIGLPT
      ENDIF
      WTXS=1D0
      SIGSWT=SIGS
      VINT(99)=1D0
      VINT(100)=1D0
      IF(MINT(82).EQ.1.AND.MSTP(142).GE.1) THEN
        IF(ISUB.NE.96.AND.MSUB(91)+MSUB(92)+MSUB(93)+MSUB(94)+
     &  MSUB(95).EQ.0) CALL PYEVWT(WTXS)
        SIGSWT=WTXS*SIGS
        VINT(99)=WTXS
        IF(MSTP(142).EQ.1) VINT(100)=1D0/WTXS
      ENDIF

C...Calculations for Monte Carlo estimate of all cross-sections.
      IF(MINT(82).EQ.1.AND.ISUB.LE.90.OR.ISUB.GE.96) THEN
        IF(MSTP(142).LE.1) THEN
          XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
        ELSE
          XSEC(ISUB,2)=XSEC(ISUB,2)+SIGSWT
        ENDIF
      ELSEIF(MINT(82).EQ.1) THEN
        XSEC(ISUB,2)=XSEC(ISUB,2)+SIGS
      ENDIF
      IF((ISUB.EQ.95.OR.ISUB.EQ.96).AND.LOOP2.EQ.1.AND.
     &MINT(82).EQ.1) XSEC(97,2)=XSEC(97,2)+SIGLPT

C...Multiple interactions: store results of cross-section calculation.
      IF(MINT(50).EQ.1.AND.MSTP(82).GE.3) THEN
        VINT(153)=SIGSOR
        IF(MINT(35).LE.1) CALL PYMULT(4)
        IF(MINT(35).GE.2) CALL PYMIGN(4)
      ENDIF

C...Ratio of actual to maximum cross section.
      IF(ISTSB.NE.11) THEN
        VIOL=SIGSWT/XSEC(ISUB,1)
        IF(ISUB.EQ.96.AND.MSTP(173).EQ.1) VIOL=VIOL/PARP(174)
      ELSEIF(IDWTUP.EQ.1.OR.IDWTUP.EQ.2) THEN
        VIOL=XWGTUP/XMAXUP(KFPR(ISUB,1))
      ELSEIF(IDWTUP.EQ.-1.OR.IDWTUP.EQ.-2) THEN
        VIOL=ABS(XWGTUP)/ABS(XMAXUP(KFPR(ISUB,1)))
      ELSE
        VIOL=1D0
      ENDIF

C...Check that weight not negative.
      IF(MSTP(123).LE.0) THEN
        IF(VIOL.LT.-1D-3) THEN
          WRITE(MSTU(11),5000) VIOL,NGEN(0,3)+1
          IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &    VINT(22),VINT(23),VINT(26)
          CALL PYSTOP(2)
        ENDIF
      ELSE
        IF(VIOL.LT.MIN(-1D-3,VINT(109))) THEN
          VINT(109)=VIOL
          IF(MSTP(123).LE.2) WRITE(MSTU(11),5200) VIOL,NGEN(0,3)+1
          IF(MSTP(122).GE.1) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &    VINT(22),VINT(23),VINT(26)
        ENDIF
      ENDIF

C...Weighting using estimate of maximum of differential cross-section.
      RATND=1D0
      IF(MFAIL.EQ.0.AND.ISUB.NE.95.AND.ISUB.NE.96) THEN
        IF(VIOL.LT.PYR(0)) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(ISUB.GE.91.AND.ISUB.LE.94) ISUB=0
          GOTO 100
        ENDIF
      ELSEIF(MFAIL.EQ.0) THEN
        RATND=SIGLPT/XSEC(95,1)
        VIOL=VIOL/RATND
        IF(LOOP2.EQ.1.AND.RATND.LT.PYR(0)) THEN
          IF(VIOL.GT.PYR(0).AND.MINT(82).EQ.1.AND.MSUB(95).EQ.1.AND.
     &    (ISUB.LE.90.OR.ISUB.GE.95)) NGEN(95,1)=NGEN(95,1)+MINT(143)
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          ISUB=0
          GOTO 100
        ENDIF
        IF(VIOL.LT.PYR(0)) THEN
          GOTO 140
        ENDIF
      ELSEIF(ISUB.NE.95.AND.ISUB.NE.96) THEN
        IF(VIOL.LT.PYR(0)) THEN
          MSTI(61)=1
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          RETURN
        ENDIF
      ELSE
        RATND=SIGLPT/XSEC(95,1)
        IF(LOOP.EQ.1.AND.RATND.LT.PYR(0)) THEN
          MSTI(61)=1
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          RETURN
        ENDIF
        VIOL=VIOL/RATND
        IF(VIOL.LT.PYR(0)) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          GOTO 100
        ENDIF
      ENDIF

C...Check for possible violation of estimated maximum of differential
C...cross-section used in weighting.
      IF(MSTP(123).LE.0) THEN
        IF(VIOL.GT.1D0) THEN
          WRITE(MSTU(11),5300) VIOL,NGEN(0,3)+1
          IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &    VINT(22),VINT(23),VINT(26)
          CALL PYSTOP(2)
        ENDIF
      ELSEIF(MSTP(123).EQ.1) THEN
        IF(VIOL.GT.VINT(108)) THEN
          VINT(108)=VIOL
          IF(VIOL.GT.1.0001D0) THEN
            MINT(10)=1
            WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
            IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &      VINT(22),VINT(23),VINT(26)
          ENDIF
        ENDIF
      ELSEIF(VIOL.GT.VINT(108)) THEN
        VINT(108)=VIOL
        IF(VIOL.GT.1D0) THEN
          MINT(10)=1
          IF(MSTP(123).EQ.2) WRITE(MSTU(11),5400) VIOL,NGEN(0,3)+1
          IF(ISTSB.EQ.11.AND.(ABS(IDWTUP).EQ.1.OR.ABS(IDWTUP).EQ.2))
     &    THEN
            XMAXUP(KFPR(ISUB,1))=VIOL*XMAXUP(KFPR(ISUB,1))
            IF(KFPR(ISUB,1).LE.9) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5800) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ELSEIF(KFPR(ISUB,1).LE.99) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5900) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ELSE
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),6000) KFPR(ISUB,1),
     &        XMAXUP(KFPR(ISUB,1))
            ENDIF
          ENDIF
          IF(ISTSB.NE.11.OR.ABS(IDWTUP).EQ.1) THEN
            XDIF=XSEC(ISUB,1)*(VIOL-1D0)
            XSEC(ISUB,1)=XSEC(ISUB,1)+XDIF
            IF(MSUB(ISUB).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GT.96))
     &      XSEC(0,1)=XSEC(0,1)+XDIF
            IF(MSTP(122).GE.2) WRITE(MSTU(11),5100) ISUB,VINT(21),
     &      VINT(22),VINT(23),VINT(26)
            IF(ISUB.LE.9) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5500) ISUB,XSEC(ISUB,1)
            ELSEIF(ISUB.LE.99) THEN
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5600) ISUB,XSEC(ISUB,1)
            ELSE
              IF(MSTP(123).EQ.2) WRITE(MSTU(11),5700) ISUB,XSEC(ISUB,1)
            ENDIF
          ENDIF
          VINT(108)=1D0
        ENDIF
      ENDIF

C...Multiple interactions: choose impact parameter (if not already done).
      IF(MINT(39).EQ.0) VINT(148)=1D0
      IF(MINT(50).EQ.1.AND.(ISUB.LE.90.OR.ISUB.GE.96).AND.
     &MSTP(82).GE.3) THEN
        IF(MINT(35).LE.1) CALL PYMULT(5)
        IF(MINT(35).GE.2) CALL PYMIGN(5)
        IF(VINT(150).LT.PYR(0)) THEN
          IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)
          IF(MFAIL.EQ.1) THEN
            MSTI(61)=1
            RETURN
          ENDIF
          GOTO 100
        ENDIF
      ENDIF
      IF(MINT(82).EQ.1) NGEN(0,2)=NGEN(0,2)+1
      IF(MINT(82).EQ.1.AND.MSUB(95).EQ.1) THEN
        IF(ISUB.LE.90.OR.ISUB.GE.95) NGEN(95,1)=NGEN(95,1)+MINT(143)
        IF(ISUB.LE.90.OR.ISUB.GE.96) NGEN(96,2)=NGEN(96,2)+1
      ENDIF
      IF(ISUB.LE.90.OR.ISUB.GE.96) MINT(31)=MINT(31)+1

C...Choose flavour of reacting partons (and subprocess).
      IF(ISTSB.GE.11) GOTO 320
      RSIGS=SIGS*PYR(0)
      QT2=VINT(48)
      RQQBAR=PARP(87)*(1D0-(QT2/(QT2+(PARP(88)*PARP(82)*
     &(VINT(1)/PARP(89))**PARP(90))**2))**2)
      IF(ISUB.NE.95.AND.(ISUB.NE.96.OR.MSTP(82).LE.1.OR.
     &PYR(0).GT.RQQBAR)) THEN
        DO 310 ICHN=1,NCHN
          KFL1=ISIG(ICHN,1)
          KFL2=ISIG(ICHN,2)
          MINT(2)=ISIG(ICHN,3)
          RSIGS=RSIGS-SIGH(ICHN)
          IF(RSIGS.LE.0D0) GOTO 320
  310   CONTINUE

C...Multiple interactions: choose qqbar preferentially at small pT.
      ELSEIF(ISUB.EQ.96) THEN
        MINT(105)=MINT(103)
        MINT(109)=MINT(107)
        CALL PYSPLI(MINT(11),21,KFL1,KFLDUM)
        MINT(105)=MINT(104)
        MINT(109)=MINT(108)
        CALL PYSPLI(MINT(12),21,KFL2,KFLDUM)
        MINT(1)=11
        MINT(2)=1
        IF(KFL1.EQ.KFL2.AND.PYR(0).LT.0.5D0) MINT(2)=2

C...Low-pT: choose string drawing configuration.
      ELSE
        KFL1=21
        KFL2=21
        RSIGS=6D0*PYR(0)
        MINT(2)=1
        IF(RSIGS.GT.1D0) MINT(2)=2
        IF(RSIGS.GT.2D0) MINT(2)=3
      ENDIF

C...Reassign QCD process. Partons before initial state radiation.
  320 IF(MINT(2).GT.10) THEN
        MINT(1)=MINT(2)/10
        MINT(2)=MOD(MINT(2),10)
      ENDIF
      IF(MINT(82).EQ.1.AND.MSTP(111).GE.0) NGEN(MINT(1),2)=
     &NGEN(MINT(1),2)+1
      MINT(15)=KFL1
      MINT(16)=KFL2
      MINT(13)=MINT(15)
      MINT(14)=MINT(16)
      VINT(141)=VINT(41)
      VINT(142)=VINT(42)
      VINT(151)=0D0
      VINT(152)=0D0

C...Calculate x value of photon for parton inside photon inside e.
      DO 350 JT=1,2
        MINT(18+JT)=0
        VINT(154+JT)=0D0
        MSPLI=0
        IF(JT.EQ.1.AND.MINT(43).LE.2) MSPLI=1
        IF(JT.EQ.2.AND.MOD(MINT(43),2).EQ.1) MSPLI=1
        IF(ABS(MINT(14+JT)).LE.8.OR.MINT(14+JT).EQ.21) MSPLI=MSPLI+1
        IF(MSPLI.EQ.2) THEN
          KFLH=MINT(14+JT)
          XHRD=VINT(140+JT)
          Q2HRD=VINT(54)
          MINT(105)=MINT(102+JT)
          MINT(109)=MINT(106+JT)
          VINT(120)=VINT(2+JT)
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(22,XHRD,Q2HRD,XPQ)
          ELSE
            CALL PYPDFL(22,XHRD,Q2HRD,XPQ)
          ENDIF
          WTMX=4D0*XPQ(KFLH)
          IF(MSTP(13).EQ.2) THEN
            Q2PMS=Q2HRD/PMAS(11,1)**2
            WTMX=WTMX*LOG(MAX(2D0,Q2PMS*(1D0-XHRD)/XHRD**2))
          ENDIF
  330     XE=XHRD**PYR(0)
          XG=MIN(1D0-1D-10,XHRD/XE)
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(22,XG,Q2HRD,XPQ)
          ELSE
            CALL PYPDFL(22,XG,Q2HRD,XPQ)
          ENDIF
          WT=(1D0+(1D0-XE)**2)*XPQ(KFLH)
          IF(MSTP(13).EQ.2) WT=WT*LOG(MAX(2D0,Q2PMS*(1D0-XE)/XE**2))
          IF(WT.LT.PYR(0)*WTMX) GOTO 330
          MINT(18+JT)=1
          VINT(154+JT)=XE
          DO 340 KFLS=-25,25
            XSFX(JT,KFLS)=XPQ(KFLS)
  340     CONTINUE
        ENDIF
  350 CONTINUE

C...Pick scale where photon is resolved.
      Q0S=PARP(15)**2
      Q1S=VINT(154)**2
      VINT(283)=0D0
      IF(MINT(107).EQ.3) THEN
        IF(MSTP(66).EQ.1) THEN
          VINT(283)=Q0S*(VINT(54)/Q0S)**PYR(0)
        ELSEIF(MSTP(66).EQ.2) THEN
          PS=VINT(3)**2
          Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
          Q2INT=SQRT(Q0S*Q2EFF)
          VINT(283)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
        ELSEIF(MSTP(66).EQ.3) THEN
          VINT(283)=Q0S*(Q1S/Q0S)**PYR(0)
        ELSEIF(MSTP(66).GE.4) THEN
          PS=0.25D0*VINT(3)**2
          VINT(283)=(Q0S+PS)*(Q1S+PS)/
     &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
        ENDIF
      ENDIF
      VINT(284)=0D0
      IF(MINT(108).EQ.3) THEN
        IF(MSTP(66).EQ.1) THEN
          VINT(284)=Q0S*(VINT(54)/Q0S)**PYR(0)
        ELSEIF(MSTP(66).EQ.2) THEN
          PS=VINT(4)**2
          Q2EFF=VINT(54)*((Q0S+PS)/(VINT(54)+PS))*
     &    EXP(PS*(VINT(54)-Q0S)/((VINT(54)+PS)*(Q0S+PS)))
          Q2INT=SQRT(Q0S*Q2EFF)
          VINT(284)=Q2INT*(VINT(54)/Q2INT)**PYR(0)
        ELSEIF(MSTP(66).EQ.3) THEN
          VINT(284)=Q0S*(Q1S/Q0S)**PYR(0)
        ELSEIF(MSTP(66).GE.4) THEN
          PS=0.25D0*VINT(4)**2
          VINT(284)=(Q0S+PS)*(Q1S+PS)/
     &    (Q0S+PYR(0)*(Q1S-Q0S)+PS)-PS
        ENDIF
      ENDIF
      IF(MINT(121).GT.1) CALL PYSAVE(2,IGA)

C...Format statements for differential cross-section maximum violations.
 5000 FORMAT(/1X,'Error: negative cross-section fraction',1P,D11.3,1X,
     &'in event',1X,I7,'D0'/1X,'Execution stopped!')
 5100 FORMAT(1X,'ISUB = ',I3,'; Point of violation:'/1X,'tau =',1P,
     &D11.3,', y* =',D11.3,', cthe = ',0P,F11.7,', tau'' =',1P,D11.3)
 5200 FORMAT(/1X,'Warning: negative cross-section fraction',1P,D11.3,1X,
     &'in event',1X,I7)
 5300 FORMAT(/1X,'Error: maximum violated by',1P,D11.3,1X,
     &'in event',1X,I7,'D0'/1X,'Execution stopped!')
 5400 FORMAT(/1X,'Advisory warning: maximum violated by',1P,D11.3,1X,
     &'in event',1X,I7)
 5500 FORMAT(1X,'XSEC(',I1,',1) increased to',1P,D11.3)
 5600 FORMAT(1X,'XSEC(',I2,',1) increased to',1P,D11.3)
 5700 FORMAT(1X,'XSEC(',I3,',1) increased to',1P,D11.3)
 5800 FORMAT(1X,'XMAXUP(',I1,') increased to',1P,D11.3)
 5900 FORMAT(1X,'XMAXUP(',I2,') increased to',1P,D11.3)
 6000 FORMAT(1X,'XMAXUP(',I3,') increased to',1P,D11.3)

      RETURN
      END


subroutine mkhex(ncond,nval, ,hres)
implicit none

!ncond=2
!nval=4
do ix1=1,nkpt*nval*ncond
do ix2=1,ix1
  ikpt1=mod(ix1-1,nkpt)+1
  ikpt2=mod(ix2-1,nkpt)+1
  ic1=mod(ix1/nkpt-1,ncond)+1+nbocc
  ic2=mod(ix2/nkpt-1,ncond)+1+nbocc
  iv1=mod(ix1/(nkpt*ncond)-1,nval)+1+nbocc-nval
  iv2=mod(ix2/(nkpt*ncond)-1,nval)+1+nbocc-nval
  hres(ix1,ix2)=hdirlmnt(iv1,ic1,ikpt1,iv2,ic2,ikpt2, &
&                 ncg,cg,nkpt,npwarr,indxkcg,igmn(3),igmx(3), &
&                 ipwndx,ntpwndx,ipwup,npwup,igndx) &
&              +hexchlmnt(iv1,ic1,ikpt1,iv2,ic2,ikpt2, &
&                 ncg,cg,nkpt,npwarr,indxkcg,igmn(3),igmx(3),
&                 ipwup,npwup,igndx)
  if (ix1.eq.ix2) then
    hres(ix1,ix2)=hres(ix1,ix2)+enrgy(indxkbnd(ikpt1)+ic1)-enrgy(indxkbnd(ikpt1)+iv1)
  endif
enddo
enddo

return
end subroutine mkhex

!*************************************************************************

function hdirlmnt(iv1,ic1,ikpt1,iv2,ic2,ikpt2, &
& ncg,cg,nkpt,npwarr,indxkcg,igmn(3),igmx(3),ipwndx,ntpwndx,ipwup,npwup,igndx)
implicit none
integer :: iv1,ic1,ikpt1,iv2,ic2,ikpt2
integer :: ncg,nkpt,npwarr(nkpt),indxkcg(nkpt),igmn(3),igmx(3)
integer :: npwup,ipwup(3,npwup),ntpwndx,ipwndx(2,ntpwndx)
integer :: igndx(mkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
double complex :: cg(ncg)
double precision :: qq(3)
integer :: iqq(3),iqp(3),iqpt,iqg(3),iipw,ipw1,ipw2,igpw,igg1(3),igg2(3),jgpw1,jgpw2,icg1,jcg1.icg2,jcg2
double complex :: hdirlmnt,amp1,amp2

 qq=kpt(:,ikpt2)-kpt(:,ikpt1)
 iqq=nint(ngkpt*(qq+0.5d0))
 iqp=mod(iqq-1,ngkpt)+1
 iqpt=iqndx(iqp(1),iqp(2),iqp(3))
 iqg=(iqq-iqp)/ngkpt
 ikk=nint(ngkpt*(kpt(ikpt1)+0.5d0))

 hdirlmnt=0.d0
 do iipw=1,ntpwndx
   ipw1=ipwndx(1,iipw)
   ipw2=ipwndx(2,iipw)
   if (ikpt1.eq.ikpt2) then
     call mkmatelX(iv1,iv2,ikpt1,ikpt2,ipw1,iqg, &
&      ncg,ncgq,nkpt,nkptq,npwt,npwtq,igmx,igmn,igndx,igndxq, &
&      isym,isymq,symrel,syminv,nsym,nsymq,ihlf,ihlfq,kpt,kptq, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtransq(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cgq,indxkcg,indxkcgq,indxkpw,indxkpwq,npwarr,npwarrq,kg,kgq, &
&      cmatel1)
!     call mkmatelP(pi,xred,natom,iv1,iv2,ikpt1,ikpt2,qq,ipw1,ngkpt, &
!&      pwmatel(:,:,ipw1,iqq(1),iqq(2),iqq(3)), &
!&      tpwmatel(:,:,ipw1,iqq(1),iqq(2),iqq(3)), &
!&      projwf,nlmn,nkpt,nkptq,ncband,amatel1)
     call mkmatelX(iv1,iv2,ikpt1,ikpt2,ipw2,iqg, &
&      ncg,ncgq,nkpt,nkptq,npwt,npwtq,igmx,igmn,igndx,igndxq, &
&      isym,isymq,symrel,syminv,nsym,nsymq,ihlf,ihlfq,kpt,kptq, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtransq(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cgq,indxkcg,indxkcgq,indxkpw,indxkpwq,npwarr,npwarrq,kg,kgq, &
&      cmatel2)
!     call mkmatelP(pi,xred,natom,ic1,ic2,ikpt1,ikpt2,qq,ipw2,ngkpt, &
!&      pwmatel(:,:,ipw2,iqq(1),iqq(2),iqq(3)), &
!&      tpwmatel(:,:,ipw2,iqq(1),iqq(2),iqq(3)), &
!&      projwf,nlmn,nkpt,nkptq,ncband,amatel1)
   else
     call mkmatelX(iv1,iv2,ikpt1,ikpt2,ipw1,iqg, &
&      ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&      isym,isym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&      cmatel1)
!     call mkmatelP(pi,xred,natom,iv1,iv2,ikpt1,ikpt2,qq,ipw1,ngkpt, &
!&      pwmatel(:,:,ipw1,iqq(1),iqq(2),iqq(3)), &
!&      tpwmatel(:,:,ipw1,iqq(1),iqq(2),iqq(3)), &
!&      projwf,nlmn,nkpt,nkpt,ncband,amatel1)
     call mkmatelX(iv1,iv2,ikpt1,ikpt2,ipw2,iqg, &
&      ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&      isym,isym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&      cmatel2)
!     call mkmatelP(pi,xred,natom,ic1,ic2,ikpt1,ikpt2,qq,ipw2,ngkpt, &
!&      pwmatel(:,:,ipw2,iqq(1),iqq(2),iqq(3)), &
!&      tpwmatel(:,:,ipw2,iqq(1),iqq(2),iqq(3)), &
!&      projwf,nlmn,nkpt,nkpt,ncband,amatel1)
   endif
   hdirlmnt = hdirlmnt-(cmatel1+amatel1)*(cmatel2+amatel2)*W(1,iqpt,iipw)
 enddo

return
end function hdirlmnt

!*************************************************************************

function hexchlmnt(iv1,ic1,ikpt1,iv2,ic2,ikpt2, &
& ncg,cg,nkpt,npwarr,indxkcg,igmn(3),igmx(3),ipwup,npwup,igndx)
implicit none
integer :: iv1,ic1,ikpt1,iv2,ic2,ikpt2
integer :: ncg,nkpt,npwarr(nkpt),indxkcg(nkpt),igmn(3),igmx(3)
integer :: npwup,ipwup(3,npwup)
integer :: igndx(mkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
double complex :: cg(ncg)
integer :: ipw1,jpw1,iqq(3),ipw2,jpw2,jgg2(3),icg1,jcg1,icg2,jcg2,ii,jj
double precision :: qq2,vqq
double complex :: hexchlmnt

 igg0=(/0,0,0/)
 iqctr=ngkpt/2
 qq=(/0.d0,0.d0,0.d0/)
 hexchlmnt = 0.d0
 do ipw1=1,npwarr(ikpt1)
   iqq=ipwup(:,ipw1)
   if (iqq(1).eq.0.and.iqq(2).eq.0.and.iqq(3).eq.0) cycle
   qq2=0.d0
   do ii=1,3
   do jj=1,3
     qq2=qq2+iqq(ii)*bmet(ii,jj)*iqq(jj)
   enddo
   enddo
   vqq=4.d0*pi/qq2
   call mkmatelX(iv1,ic1,ikpt1,ikpt1,ipw1,igg0, &
&      ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&      isym,isym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&      cmatel1)
!   call mkmatelP(pi,xred,natom,iv1,ic1,ikpt1,ikpt1,qq,ipw1,ngkpt, &
!&      pwmatel(:,:,ipw1,iqctr(1),iqctr(2),iqctr(3)), &
!&      tpwmatel(:,:,ipw1,iqctr(1),iqctr(2),iqctr(3)), &
!&      projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel1)
   call mkmatelX(iv2,ic2,ikpt2,ikpt2,ipw1,igg0, &
&      ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&      isym,isym,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&      lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&      cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&      cmatel2)
!   call mkmatelP(pi,xred,natom,iv2,ic2,ikpt2,ikpt2,qq,ipw1,ngkpt, &
!&      pwmatel(:,:,ipw1,iqctr(1),iqctr(2),iqctr(3)), &
!&      tpwmatel(:,:,ipw1,iqctr(1),iqctr(2),iqctr(3)), &
!&      projwf,projwf,nlmn,nkpt,nkpt,ncband,amatel2)
   hexchlmnt = hexchlmnt+(cmatel1+amatel1)*(cmatel2+amatel2)*vqq
 enddo

return
end function hexchlmnt

!*************************************************************************

subroutine felmnt(vec1,vec2,xmat,nn,elmnt)
implicit none
integer :: nn
double complex :: vec1(nn),vec2(nn),xmat(nn,nn),elmnt
double complex :: vv(nn)

 elmnt=(0.d0,0.d0)
 do ix=1,nn
   vv(ix)=0.d0
   do iy=1,nn
     vv(ix)=vv(ix)+xmat(ix,iy)*vec2(iy)
   enddo
   elmnt=elmnt+vec1(ix)*vv(ix)
 enddo

return
end subroutine felement

!*************************************************************************

subroutine pert1(nn,eigvec0,eigval0,xmat1,eigvec1)
implicit none
integer :: nn
double complex :: eigvec0(nn,nn),eigval0(nn),xmat1(nn,nn),eigvec1(nn,nn)

do ix=1,nn
  eigvec1(:,ix)=eigvec0(:,ix)
  do iy=1,nn
    if (ix.eq.iy) cycle
    call felmnt(eigvec0(:,iy),eigvec0(:,ix),xmat1,nn,elmnt)
    eigvec1(:,ix)=eigvec1(:,ix)+eigvec0(:,iy)*elmnt/(eigval(ix)-eigval(iy))
  enddo
enddo

return
end subroutine pert1


subroutine mkploss(iband,ikk,lossfn, &
& vol,pi,nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom,xred,projwf,nlmn, &
& test_bands_se, &
& ntypepaw, &
& pwmatel,tpwmatel, pwjmatel, tpwjmatel, &
& kg,enrgy,cg,npwt,bantot,ncg, &
& indxkpw,indxkbnd,indxkcg,npwarr, &
& kpt,nkpt,nqpt,nsymk,symk,nsym,symrel,syminv, &
& ihlf,lvtrans,bmet,blat,ipaw,itetrahedron, &
& ipwx,ipwndx,npwndx,ntpwndx,napwndx, &
& npwc,npwx,invpw2ndx,pwsymndx,iqsymndx, &
& igmx,igmn,igndx,ikndx,iqndx,isymndx,isymg,npw, &
& nband,nsppol,shiftk,total_se,ploss)
implicit none
integer :: iband,ikk(3),nwpt,nbcore,nbocc,ncband,ngkpt(3),natom,nlmn
integer :: igmn(3),igmx(3)
integer :: npwt,bantot,ncg,nkpt,nqpt,nsym,nsppol
integer :: npw,npwc,npwx,ipw1,npwndx,ntpwndx,napwndx,ipaw,itetrahedron
double precision :: vol,pi,wmax,xred(3,natom)
double complex :: lossfn(nwpt,nqpt+9,ntpwndx)
integer :: test_bands_se(2)
double complex :: projwf(natom,nlmn,nkpt,ncband)
integer :: kg(3,npwt)
double precision :: enrgy(bantot)
double complex :: cg(ncg)
integer :: indxkpw(nkpt),indxkbnd(nkpt)
integer :: indxkcg(nkpt),npwarr(nkpt)
double precision :: kpt(3,nkpt),shiftk(3)
integer :: nsymk(nkpt),symk(nkpt,nsym*2)
integer :: symrel(3,3,nsym),syminv(3,3,nsym)
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ihlf(nkpt)
double precision :: bmet(3,3),blat(3,3),bmetinv(3,3),bmet_t(3,3),bmet2(3,3)
double precision :: volelmnt, volred
integer :: ipwx(3,npwx),ipwndx(2,napwndx)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: ikndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: iqndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymndx(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymg(3,nkpt,nsym),igsymk(3),igsymq(3)
integer :: nband(nkpt*nsppol)
double complex :: sei,seipw,seiold,seibc
double complex, allocatable :: ssi(:)
double precision :: ploss
double precision :: ploss1(-nwpt:nwpt)
double precision :: total_se
double complex :: ctest
integer :: ii,jj,kk,ll,ix,iy,iz,iskip,ocsign,iiq
integer :: iqq(3),jka(3),jkb(3),jkk(3),iqv(3),ictr(3),iqr(3),ixr(3)
integer :: ixx(3),ixxp(3),ixp2(3),ixp1(3),ixm1(3),ixm2(3)
integer :: ikpt,ikptq
integer :: igg(3),igh(3),igg0(3),isym,isymq,ibp,iqpt,iqsym,iw,iww,ie,je,ies,iqctr
double precision :: xck(3),xckq(3),qadj(6)
double complex :: cmatel,cmatel2,amatel,amatel2
double complex :: jmatel(3),jmatel2(3),vmatel(3),vmatel2(3)
double complex :: vqmat2(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: xmat2(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: jmat2(3,3), rjmat2(3,3), rjmatdum
double precision :: smat2
double complex :: vfactor(ngkpt(1),ngkpt(2),ngkpt(3),nwpt),vjfactor(3,3,nwpt),vsfactor(3,3,nwpt)
double complex :: vfv(8,nwpt),vfx(8),vsm1(3,3,nwpt),vsm2(3,3,nwpt)
double precision :: vq2(8),vqvtx0(4),vqvtx(4),qkcvt(3,3)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3)), omega_t
double precision :: whi,wlo,wwhi,wwlo,ww,www,wwwlo,wwwhi,enval(8),dw,rw,eshift,evtx0(4),evtx(4)
double precision :: rrpyr(3,4),kvtx(3,4),xk(3,4),ckvtx(3,4),cxk(3,4),rg(3,3),tvol,xpyr0(4),xpyr(4)
double precision :: xkc(3,4),rgc(3,3),tvolc,kvtxc(3,4)
double complex :: vpyr0(4,nwpt),vpyr(4)
double precision :: de21,de31,de32,de41,de42,de43,thresh
double precision :: fbx(4),fb(4),cmx(3,4),cm(3,4),xkt(3,3)
double complex :: aa0(nwpt),av(3,nwpt)
double precision :: xme,xv(3)
double precision :: avec(3),bgrad(3),xmult
double precision :: abr,rlr
integer :: iwh,iwl,ibmin,ibmax,iwhi,iwlo,iehi,ielo
integer :: indxe(4),iwwlim(4)
double precision :: vq(ngkpt(1),ngkpt(2),ngkpt(3)),qq(3),qp(3),qq2,qp2,qs(3),ek,ekmq
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),temparray(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: iipw,jjpw,jjpwt
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwx,npwx)
integer :: pwsymndx(npwc,2*nsym)
integer :: ipw2,jpw1,jpw2,jw,iqcentr,jqcentr
double precision :: eps1,eps2,eps
double precision :: eval,brd,esprd
double precision :: gfo,gamma(3),pln(3),dist(3)
double precision :: sint1,sint1a,sint1b,svec(3),sveca(3),svecb(3),stens(3,3)
double complex :: cint
double complex :: wint,wint0,w2int,w2int0,gterm,vcentr
double precision :: wcentr(-nwpt:nwpt),wgrid(nwpt)
integer :: ntypepaw
double complex :: pwmatel(ntypepaw,nlmn,nlmn,npwx,ngkpt(1),ngkpt(2),ngkpt(3)), &
&                tpwmatel(ntypepaw,nlmn,nlmn,npwx,ngkpt(1),ngkpt(2),ngkpt(3)), &
&                 pwjmatel(3,ntypepaw,nlmn,nlmn),               &
&                tpwjmatel(3,ntypepaw,nlmn,nlmn)
logical :: lqsing,lqcentr
logical :: lc
double precision :: linterp
double precision :: rr(3,8)
integer :: ivndx(4,6),itet,iv
integer :: nsing
double precision :: wsing(20)
character*4 :: label
external linterp
data rr(1:3,1) /0.0d0,0.0d0,0.0d0/
data rr(1:3,2) /1.0d0,0.0d0,0.0d0/
data rr(1:3,3) /0.0d0,1.0d0,0.0d0/
data rr(1:3,4) /1.0d0,1.0d0,0.0d0/
data rr(1:3,5) /0.0d0,0.0d0,1.0d0/
data rr(1:3,6) /1.0d0,0.0d0,1.0d0/
data rr(1:3,7) /0.0d0,1.0d0,1.0d0/
data rr(1:3,8) /1.0d0,1.0d0,1.0d0/
data ivndx(1:4,1) /1,2,3,5/
data ivndx(1:4,2) /3,5,6,7/
data ivndx(1:4,3) /2,3,5,6/
data ivndx(1:4,4) /2,3,4,6/
data ivndx(1:4,5) /3,4,6,7/
data ivndx(1:4,6) /4,6,7,8/
integer :: iter
data iter /30/
logical centerint
integer vcenterint
integer :: i_prt_DEBUG, j_prt_DEBUG, k_prt_DEBUG, &
& i_ct_DEBUG, j_ct_DEBUG, k_ct_DEBUG, l_ct_DEBUG, &
& k_ref_DEBUG, i_ref_DEBUG
common /tsingint_DEBUG/ i_prt_DEBUG, j_prt_DEBUG, k_prt_DEBUG, &
& i_ct_DEBUG, j_ct_DEBUG, k_ct_DEBUG, l_ct_DEBUG, &
& k_ref_DEBUG, i_ref_DEBUG
integer :: idum
double precision :: xdum,xdum2,xdum3,vdum(3),mtxdum(3,3),mtxdum2(3,3)
double complex :: cdum,cdum2,cdum3,cvecdum(3),cvecdum2(3),ctensdum(3,3),ctensdum2(3,3)

!write(6,*) "qopf ",total_se,ploss
i_prt_DEBUG = 0
j_prt_DEBUG = 0
k_prt_DEBUG = 0
i_ct_DEBUG = 0
j_ct_DEBUG = 0
k_ct_DEBUG = 0
l_ct_DEBUG = 0
i_ref_DEBUG = -1
k_ref_DEBUG = -1
abr=1.d-4
rlr=1.d-4
sei=0.d0
ctest=(0.d0,0.d0)
igg0=(/0,0,0/)
ploss=0.d0
do ie=-nwpt,nwpt
  ploss1(ie)=0.d0
enddo
dw=wmax/dble(nwpt)
do iw=1,nwpt
  wgrid(iw)=iw*dw
enddo
volelmnt=(vol*ngkpt(1)*ngkpt(2)*ngkpt(3))/((2.d0*pi)**3)
volred = 1.d0
ikpt=ikndx(ikk(1),ikk(2),ikk(3))
isym=isymndx(ikk(1),ikk(2),ikk(3))
igsymk=isymg(:,ikpt,isym)
ek=enrgy(indxkbnd(ikpt)+iband)
do ii=1,3
do jj=1,3
  qkcvt(ii,jj)=blat(ii,jj)/dble(ngkpt(ii))
enddo
enddo
ictr=(/ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2/)
iqctr=iqndx(ictr(1),ictr(2),ictr(3))
nsing=0

do ii=1,3
do kk=1,3
  bmet2(ii,kk) = 0.d0                   ! bmet2 = bmet*bmet
  do jj=1,3
    bmet2(ii,kk) = bmet2(ii,kk) + bmet(ii,jj)*bmet(jj,kk)
  enddo
enddo
enddo

do ix=1,ngkpt(1)
do iy=1,ngkpt(2)
do iz=1,ngkpt(3)
  temparray(ix,iy,iz)=(0.d0,0.d0)
enddo
enddo
enddo

gamma=(blat(1,:)+blat(2,:)+blat(3,:))/2.d0
do ii=1,3
  jj=mod(ii,3)+1
  kk=mod(ii+1,3)+1
  pln(1)=blat(jj,2)*blat(kk,3)-blat(jj,3)*blat(kk,2)
  pln(2)=-blat(jj,1)*blat(kk,3)+blat(jj,3)*blat(kk,1)
  pln(3)=blat(jj,1)*blat(kk,2)-blat(jj,2)*blat(kk,1)
  dist(ii)=dot_product(gamma,pln)/sqrt(dot_product(pln,pln))
enddo
gfo=minval(dist)

!ipaw=0
!write(6,'(a)') '      finding contibutions from:'
!write(6,'(a)') 'band  plane waves    correlation                exchange'
do ibp=test_bands_se(1),test_bands_se(2)
!do ibp=2,2
!do ibp=iband,iband
  write(6,'(3(a,i4))') 'quasiparticle band ',iband,', polarized band ',ibp,' out of ',test_bands_se(2)
  seibc=sei
  if (ibp.gt.nbocc) then
    ocsign=-1
  else
    ocsign=1
  endif
  do iipw=1,napwndx
!  do iipw=napwndx,napwndx
!  do iipw=1,1
!  do iipw=15,15
!    write(6,'(a,i4)') 'iipw ',iipw
    seipw=sei
    ipw1=ipwndx(1,iipw)
    ipw2=ipwndx(2,iipw)
!    if (ipw1.ne.ipw2) cycle
!    write(6,'(1x,i3,4x,2i4)') ibp,ipw1,ipw2
    lc=iipw.le.ntpwndx  ! do correlation
    if (.not.lc) cycle

! Step 1: Compute matrix elements
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=10,10
!    do iz=10,10
      vqmat2(ix,iy,iz)=(0.d0,0.d0)
      ixx=(/ix,iy,iz/)
      iqq=ixx-ictr
      qq = dble(iqq)/dble(ngkpt)
      jka=ikk-iqq
      jkk=mod(jka,ngkpt)
      do ii=1,3
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
      enddo
      ikptq=ikndx(jkk(1),jkk(2),jkk(3))
      isymq=isymndx(jkk(1),jkk(2),jkk(3))
      igsymq=isymg(:,ikptq,isymq)
      jkb=nint(kpt(:,ikptq)*dble(ngkpt))+ictr
      igg=nint(dble(jkk-jka)/dble(ngkpt))
!write(6,*) '>>>>> iqq = ',iqq
!write(6,*) '>>>>> ikk = ',ikk
!write(6,*) '>>>>> jkk = ',jkk
!write(6,*) '>>>>> jka = ',jka
!write(6,*) '>>>>> igg = ',igg
!write(6,'(a,3f10.5)') 'kpt = ',kpt(:,ikpt)
!write(6,'(a,3f10.5)') 'kptq = ',kpt(:,ikptq)
!read(*,*)
      qp=qq+ipwx(:,ipw2)
      qq=qq+ipwx(:,ipw1)
      qq2=0.d0
      qp2=0.d0
      do ii=1,3
      do jj=1,3
        qq2=qq2+qq(ii)*bmet(ii,jj)*qq(jj)
        qp2=qp2+qp(ii)*bmet(ii,jj)*qp(jj)
      enddo
      enddo
      vq(ix,iy,iz)=4.d0*pi/sqrt(qq2*qp2)
!write(6,'(a,3f10.5)') 'qq = ',qq
!write(6,'(a,3f10.5)') 'qp = ',qp
!write(6,'(a,3f10.5)') 'qq2 = ',qq2
!write(6,'(a,3f10.5)') 'qp2 = ',qp2
!write(6,*) 'vq = ',vq(ix,iy,iz)
!write(6,*) 'jka = ',jka
!write(6,*) 'jkk = ',jkk
!write(6,*) 'jkb = ',jkb
!write(6,*) 'igg = ',igg
!write(6,*) 'ikpt = ',ikpt
!write(6,*) 'ikptq = ',ikptq
      omega_t=enrgy(indxkbnd(ikptq)+ibp)-ek
      omega(ix,iy,iz)=enrgy(indxkbnd(ikptq)+ibp)-ek+dw/2
      if (iqq(1).eq.0.and.iqq(2).eq.0.and.iqq(3).eq.0) then
        if (ipw1.eq.1.and.ipw2.eq.1.and.iband.eq.ibp) then
! Find singular factor
!          call mkmatelX1(ibp,iband,ikpt,ikptq,ipwx(:,ipw1),igg, &
!&           ncg,nkpt,npwt,igmx,igmn,igndx, &
!&           isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
!&           lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
!&           cg,indxkcg,indxkpw,npwarr,kg, &
!&           cmatel)
!          if (ipaw.ne.0) then
!            call mkPAWmatelX1(pi,ibp,iband,ikk,jkk,qq,igg0, &
!&                 pwmatel,tpwmatel,nbcore,ncband,amatel)
!          else
!            amatel2=(0.d0,0.d0)
!          endif
!          smat2=4.d0*pi*dble((cmatel+amatel)*conjg(cmatel+amatel))
!          if (smat2.ne.0.d0) then
!            lqsing=.true.
!          else
!            lqsing=.false.
!          endif
          smat2=4.d0*pi*omega_t
          lqsing=.true.
        else
          smat2=0.d0
          lqsing=.false.
        endif
! If not singular, find tensor response at q=0
        if (.not.lqsing) then
          if (ipwx(1,ipw1).eq.0.and.ipwx(2,ipw1).eq.0.and.ipwx(3,ipw1).eq.0) then
            call mkmatelJ1(ibp,iband,ikpt,ikptq,ipwx(:,ipw1),igg, &
&             ncg,nkpt,npwt,igmx,igmn,igndx, &
&             isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&             lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&             cg,indxkcg,indxkpw,npwarr,kg, &
&             jmatel)
            if (ipaw.ne.0) then
              call mkPAWmatelJ1(pi,ibp,iband,ikk,jkk, &
&                           pwjmatel,tpwjmatel,nbcore,ncband,vmatel)
              jmatel(:) = jmatel(:) + vmatel(:)
            endif
            do ii=1,3
              jmatel(ii) = jmatel(ii)/(enrgy(indxkbnd(ikptq)+ibp)-ek)
            enddo
          else
            call mkmatelX1(ibp,iband,ikpt,ikptq,ipwx(:,ipw1),igg, &
&             ncg,nkpt,npwt,igmx,igmn,igndx, &
&             isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&             lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&             cg,indxkcg,indxkpw,npwarr,kg, &
&             cmatel)
            if (ipaw.ne.0) then
              call mkPAWmatelX1(pi,ibp,iband,ikk,jkk,qq,igg0, &
&                   pwmatel,tpwmatel,nbcore,ncband,amatel)
            else
              amatel=(0.d0,0.d0)
            endif
            jmatel = (cmatel+amatel)*qq/qq2
          endif
          if (ipw1.eq.ipw2) then
            jmatel2=jmatel
          else
            if (ipwx(1,ipw2).eq.0.and.ipwx(2,ipw2).eq.0.and.ipwx(3,ipw2).eq.0) then
              call mkmatelJ1(ibp,iband,ikpt,ikptq,ipwx(:,ipw2),igh, &
&               ncg,nkpt,npwt,igmx,igmn,igndx, &
&               isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&               lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&               cg,indxkcg,indxkpw,npwarr,kg, &
&               jmatel2)
              if (ipaw.ne.0) then
                call mkPAWmatelJ1(pi,ibp,iband,ikk,jkk, &
&                             pwjmatel,tpwjmatel,nbcore,ncband,vmatel)
                jmatel2(:) = jmatel2(:) + vmatel(:)
              endif
              do ii=1,3
                jmatel2(ii) = jmatel2(ii)/(enrgy(indxkbnd(ikptq)+ibp)-ek)
              enddo
            else
              call mkmatelX1(ibp,iband,ikpt,ikptq,ipwx(:,ipw2),igh, &
&             ncg,nkpt,npwt,igmx,igmn,igndx, &
&             isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&             lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&             cg,indxkcg,indxkpw,npwarr,kg, &
&             cmatel2)
              if (ipaw.ne.0) then
                call mkPAWmatelX1(pi,ibp,iband,ikk,jkk,qp,igg0, &
&                     pwmatel,tpwmatel,nbcore,ncband,amatel2)
              else
                amatel2=(0.d0,0.d0)
              endif
              jmatel2 = (cmatel2+amatel2)*qp/qp2
            endif
          endif
!! DEBUG
!write(6,*) "jmatel"
!do ii=1,3
!write(6,*) jmatel(ii)
!enddo
!write(6,*) "jmatel2"
!do ii=1,3
!write(6,*) jmatel2(ii)
!enddo
!read(*,*)
          do ii=1,3
          do jj=1,3
            jmat2(ii,jj)=4.d0*pi*jmatel(ii)*conjg(jmatel2(jj))*omega_t
          enddo
          enddo
        else
          do ii=1,3
          do jj=1,3
            jmat2(ii,jj)=(0.d0,0.d0)
          enddo
          enddo
        endif
      else
        call mkmatelX1(ibp,iband,ikpt,ikptq,ipwx(:,ipw1),igg, &
&         ncg,nkpt,npwt,igmx,igmn,igndx, &
&         isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&         lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&         cg,indxkcg,indxkpw,npwarr,kg, &
&         cmatel)
        if (ipaw.ne.0) then
          call mkPAWmatelX1(pi,ibp,iband,ikk,jkk,qq,igg0, &
&               pwmatel,tpwmatel,nbcore,ncband,amatel)
        else
          amatel=(0.d0,0.d0)
        endif
        if (ipw1.eq.ipw2) then
          cmatel2=cmatel
          amatel2=amatel
        else
          call mkmatelX1(ibp,iband,ikpt,ikptq,ipwx(:,ipw2),igh, &
&         ncg,nkpt,npwt,igmx,igmn,igndx, &
&         isym,isymq,symrel,syminv,nsym,ihlf,igsymk,igsymq,kpt, &
&         lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&         cg,indxkcg,indxkpw,npwarr,kg, &
&         cmatel2)
          if (ipaw.ne.0) then
            call mkPAWmatelX1(pi,ibp,iband,ikk,jkk,qp,igg0, &
&                 pwmatel,tpwmatel,nbcore,ncband,amatel2)
          else
            amatel2=(0.d0,0.d0)
          endif
        endif
        xmat2(ix,iy,iz)=(cmatel+amatel)*conjg(cmatel2+amatel2)*omega_t
        vqmat2(ix,iy,iz)=xmat2(ix,iy,iz)*vq(ix,iy,iz)
      endif
    enddo
    enddo
    enddo

! Alternate way of getting jmat2
! Interpolation of density matrix elements / q^2 to q=0
! For equally spaced samples A(-2) = -2 q, A(-1) = -1 q, A(1) = 1 q, A(2) = 2 q
! average of two quadratic interpolations gives (see Numerical Recipes 3.1)
! A(0) = (2/3) A(-1) + (2/3) A(1) - (1/6) A(-2) - (1/6) A(2)
! Expect vqmat2 to converge to well defined value at q = 0, interpolate this
! sum(ii,jj) qq(ii) * (bmet * jmat2 * bmet)(ii,jj) * qq(jj) / qq^2 = vqmat
! define rjmat2 = bmet * jmat2 * bmet
! find rjmat2 as q->0, then
! jmat2(q->0) = bmet^(-1)*rjmat2(q->0)*bmet^(-1)
!
! note qq * rjmat2 * qq = rjmat2(1,1)*qq(1)^2 + rjmat2(2,2)*qq(2)^2 + rjmat2(3,3)*qq(3)^2 + (rjmat2(1,2)+rjmat2(2,1))*qq(1)*qq(2) + (rjmat2(1,3)+rjmat2(3,1))*qq(1)*qq(3) + (rjmat2(2,3)+rjmat2(3,2))*qq(2)*qq(3)
! so longitudinal response only depends on sum of symmetric off-diagonal terms,
! independent of difference.
! Thus, we can safely set rjmat2(ii,jj) = (rjmat2(ii,jj)+rjmat2(jj,ii))/2
    if (.true.) then
! first do diagonal parts
! e.g., along direction 1
! qq = qq(1) * blat(1,:)
! qq^2 = qq(1)*qq(1) * dot_product(blat(1,:),blat(1,:))
! sum(ii,jj) qq(ii) * rjmat2(ii,jj) * qq(jj) / qq^2
! = (1/qq^2) * rjmat2(1,1) * qq(1)*qq(1)
! = rjmat2(1,1) / dot_product(blat(1,:),blat(1,:))
! -> rjmat2(1,1) = dot_product(blat(1,:),blat(1,:)) * [response in direction 1]
      do ii=1,3
        ixx = (/0,0,0/)
        ixx(ii) = 1
        ixp2 = ictr+2*ixx
        ixp1 = ictr+ixx
        ixm1 = ictr-ixx
        ixm2 = ictr-2*ixx
        qq2 = dot_product(blat(ii,:),blat(ii,:))
        rjmatdum = 2.d0/3.d0 * vqmat2(ixp1(1),ixp1(2),ixp1(3)) &
&                + 2.d0/3.d0 * vqmat2(ixm1(1),ixm1(2),ixm1(3)) &
&                - 1.d0/6.d0 * vqmat2(ixp2(1),ixp2(2),ixp2(3)) &
&                - 1.d0/6.d0 * vqmat2(ixm2(1),ixm2(2),ixm2(3))
        rjmat2(ii,ii) =  qq2 * rjmatdum
      enddo
! find off-diagonals using qq along directions (1,1,0), (1,0,1), and (0,1,1)
! e.g., along direction (1,1,0)
! qq = qq(1) * blat(1,:) + qq(2) * blat(2,:)
! qq^2 =    qq(1)*qq(1) * dot_product(blat(1,:),blat(1,:))
!       +   qq(2)*qq(2) * dot_product(blat(2,:),blat(2,:))
!       + 2*qq(1)*qq(2) * dot_product(blat(1,:),blat(2,:))
!      =    dot_product(blat(1,:),blat(1,:)) + dot_product(blat(2,:),blat(2,:))
!       + 2*dot_product(blat(1,:),blat(2,:))
! sum(ii,jj) qq(ii) * rjmat2(ii,jj) * qq(jj) / qq^2
! = (1/qq^2) * ( rjmat2(1,1) * qq(1)*qq(1) + rjmat2(2,2) * qq(2)*qq(2)
!               + qq(1)*qq(2) * (rjmat2(1,2) + rjmat2(2,1)) )
! = (1/qq^2) * ( rjmat2(1,1) * qq(1)*qq(1) + rjmat2(2,2) * qq(2)*qq(2)
!               + 2 * rjmat2(1,2) qq(1)*qq(2))
! = (1/qq^2) * ( rjmat2(1,1) + rjmat2(2,2) + 2 * rjmat2(1,2) )
! -> rjmat2(1,2) = (qq^2 * [response in direction 1] - (rjmat2(1,1) + rjmat2(2,2)))/2
      do ii=1,3
        ixx = (/1,1,1/)
        ixx(ii) = 0
        ixp2 = ictr+2*ixx
        ixp1 = ictr+ixx
        ixm1 = ictr-ixx
        ixm2 = ictr-2*ixx
        qq2 = dot_product(blat(jj,:),blat(jj,:))   &
&           + dot_product(blat(kk,:),blat(kk,:))   &
&           + dot_product(blat(jj,:),blat(kk,:))*2
        rjmatdum = 2.d0/3.d0 * vqmat2(ixp1(1),ixp1(2),ixp1(3)) &
&                + 2.d0/3.d0 * vqmat2(ixm1(1),ixm1(2),ixm1(3)) &
&                - 1.d0/6.d0 * vqmat2(ixp2(1),ixp2(2),ixp2(3)) &
&                - 1.d0/6.d0 * vqmat2(ixm2(1),ixm2(2),ixm2(3))
        jj = mod(ii,3)+1   ! note ii = mod(ii-1,3)+1
        kk = mod(ii+1,3)+1
        rjmat2(jj,kk) = (qq2*rjmatdum - (rjmat2(jj,jj)+rjmat2(kk,kk)))/2.d0
        rjmat2(kk,jj) = rjmat2(jj,kk)
!! DEBUG
!qq = ixx/dble(ngkpt)
!qq2=0.d0
!do kk=1,3
!do jj=1,3
!qq2=qq2+qq(kk)*bmet(kk,jj)*qq(jj)
!enddo
!enddo
!cvecdum = bmet(:,1)*qq(1)+bmet(:,2)*qq(2)+bmet(:,3)*qq(3)
!cvecdum2 = jmat2(:,1)*cvecdum(1)+jmat2(:,2)*cvecdum(2)+jmat2(:,3)*cvecdum(3)
!cvecdum = bmet(:,1)*cvecdum2(1)+bmet(:,2)*cvecdum2(2)+bmet(:,3)*cvecdum2(3)
!write(6,*) "qq: ",qq
!write(6,*) (cvecdum(1)*qq(1)+cvecdum(2)*qq(2)+cvecdum(3)*qq(3))/qq2
!write(6,*) ixx
!write(6,*) vqmat2(ixp2(1),ixp2(2),ixp2(3))
!write(6,*) vqmat2(ixp1(1),ixp1(2),ixp1(3))
!write(6,*) rjmatdum
!write(6,*) vqmat2(ixm1(1),ixm1(2),ixm1(3))
!write(6,*) vqmat2(ixm2(1),ixm2(2),ixm2(3))
      enddo
! DEBUG
!do ii=1,3
!do jj=1,3
!if (ii.eq.jj) then
!rjmat2(ii,jj) = 2.9357115896d0
!else
!rjmat2(ii,jj) = 0.d0;
!endif
!enddo
!enddo
      bmet_t=bmet
      call inverse(bmet_t,bmetinv,3,3)
      do ii=1,3
      do jj=1,3
        jmat2(ii,jj) = (0.d0,0.d0)
        do kk=1,3
        do ll=1,3
          jmat2(ii,jj) = jmat2(ii,jj) + bmetinv(ii,kk)*rjmat2(kk,ll)*bmetinv(ll,jj)
        enddo
        enddo
      enddo
      enddo
    endif
!! DEBUG
!write(6,*) "rjmat2"
!do ii=1,3
!write(6,*) dble(rjmat2(:,ii))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dimag(rjmat2(:,ii))
!enddo
!write(6,*)
!write(6,*) "jmat2"
!do ii=1,3
!write(6,*) dble(jmat2(:,ii))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dimag(jmat2(:,ii))
!enddo
!write(6,*)
!write(6,*) "in Cartesian coordinates"
!do ii=1,3
!do jj=1,3
!ctensdum(ii,jj) = (0.d0,0.d0)
!do kk=1,3
!do ll=1,3
!ctensdum(ii,jj) = ctensdum(ii,jj) + blat(kk,ii)*jmat2(kk,ll)*blat(ll,jj)
!enddo
!enddo
!enddo
!enddo
!do ii=1,3
!write(6,*) dble(ctensdum(:,ii))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dimag(ctensdum(:,ii))
!enddo
!stop
! DEBUG
!write(6,*) "Matrix elements computed"

    if (itetrahedron.eq.0) then
      write(6,*) "Sum over points not yet implemented in self energy calculation"
      write(6,*) "set itetrahedron=1 and run again"
    else
! tetrahedron integration

! Don't waste time integrating over energies with no contribution
      do ix=1,ngkpt(1)
      do iy=1,ngkpt(2)
      do iz=1,ngkpt(3)
        ixx=(/ix,iy,iz/)
        call fhilo(omega,ixx,ngkpt,whi,wlo)
        if (ix.eq.1.and.iy.eq.1.and.iz.eq.1) then
          wwhi=whi
          wwlo=wlo
        else
          wwhi=max(wwhi,whi)
          wwlo=min(wwlo,wlo)
        endif
      enddo
      enddo
      enddo

      iwlo=nint(wwlo*dble(nwpt)/wmax)
      iwhi=nint(wwhi*dble(nwpt)/wmax)
      if (ibp.gt.nbocc) then
        ielo=iwlo+1
        iehi=iwhi+nwpt
      else
        ielo=iwlo-nwpt
        iehi=iwhi-1
      endif
      allocate (ssi(ielo:iehi))
      do ie=ielo,iehi
        ssi(ie)=0.d0
      enddo

      if (lc) then
        do iw=1,nwpt
          do ix=1,ngkpt(1)
          do iy=1,ngkpt(2)
          do iz=1,ngkpt(3)
            ixx=(/ix,iy,iz/)
            iqpt=iqndx(ixx(1),ixx(2),ixx(3))
            call locateelement(ixx,ipw1,ipw2,ngkpt,iqsymndx,npwc,npwx,nsym,pwsymndx,invpw2ndx,jjpw)
            call locateelement(ixx,ipw2,ipw1,ngkpt,iqsymndx,npwc,npwx,nsym,pwsymndx,invpw2ndx,jjpwt) ! transpose matrix coordiantes, to find anti-Hermitian part of lossfn
            if (iqpt.eq.iqctr) then
              vfactor(ixx(1),ixx(2),ixx(3),iw)=(0.d0,0.d0)
            else if (jjpw.ne.0.and.jjpwt.ne.0) then
              vfactor(ixx(1),ixx(2),ixx(3),iw)= &
&                 vqmat2(ixx(1),ixx(2),ixx(3))* &
&                 (lossfn(iw,iqpt,jjpw)-conjg(lossfn(iw,iqpt,jjpwt)))*0.5d0
            else
              vfactor(ixx(1),ixx(2),ixx(3),iw)=(0.d0,0.d0)
            endif
          enddo
          enddo
          enddo
!write(6,*) "iw = ", iw
          call locateelement(ictr,ipw1,ipw2,ngkpt,iqsymndx,npwc,npwx,nsym,pwsymndx,invpw2ndx,jjpw)
          call locateelement(ictr,ipw2,ipw1,ngkpt,iqsymndx,npwc,npwx,nsym,pwsymndx,invpw2ndx,jjpwt)
          do ii=1,3
          do jj=1,3
            if (jjpw.ne.0.and.jjpwt.ne.0) then
              vjfactor(ii,jj,iw)=(0.d0,0.d0)
              do kk=1,3
              do ll=1,3
                iiq=ii + 3*(kk-1)
                vjfactor(ii,jj,iw)= &
&                     vjfactor(ii,jj,iw) + &
&                     0.5d0*(lossfn(iw,nqpt+iiq,jjpw)-conjg(lossfn(iw,nqpt+iiq,jjpwt))) &
&                     *bmet(kk,ll)*jmat2(ll,jj)
              enddo
              enddo
              iiq=ii + 3*(jj-1)
              vsfactor(ii,jj,iw)=smat2*(lossfn(iw,nqpt+iiq,jjpw)-conjg(lossfn(iw,nqpt+iiq,jjpwt)))*0.5d0
            else
              vjfactor(ii,jj,iw)=(0.d0,0.d0)
              vsfactor(ii,jj,iw)=(0.d0,0.d0)
            endif
          enddo
          enddo
!do ii=1,3
!write(6,*) dble(vjfactor(ii,:,iw))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dimag(vjfactor(ii,:,iw))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dble(vsfactor(ii,:,iw))
!enddo
!write(6,*)
!do ii=1,3
!write(6,*) dimag(vsfactor(ii,:,iw))
!enddo
!read(*,*)
          do ii=1,3
          do jj=1,3
            vsm1(ii,jj,iw)=(0.d0,0.d0)
            do kk=1,3
              vsm1(ii,jj,iw)=vsm1(ii,jj,iw)+bmet(ii,kk)*vsfactor(kk,jj,iw)
            enddo
          enddo
          enddo
          do ii=1,3
          do jj=1,3
            vsm2(ii,jj,iw)=(0.d0,0.d0)
            do kk=1,3
              vsm2(ii,jj,iw)=vsm2(ii,jj,iw)+vsm1(ii,kk,iw)*bmet(kk,jj)
            enddo
          enddo
          enddo
        enddo
      endif

! DEBUG
!write(6,*) "Beginning integration"

! Do the integration
      do ix=1,ngkpt(1)
      do iy=1,ngkpt(2)
      do iz=1,ngkpt(3)
        ixx=(/ix,iy,iz/)
        iqq=ixx-ictr
        call fval(omega,ixx,ixxp,ngkpt,enval)
        if (lqsing) call fval(vq,ixx,ixxp,ngkpt,vq2)
        if (lc) then
          do iw=1,nwpt
            call fpol(vfactor(:,:,:,iw),ngkpt,ixx,ixxp,vfv(:,iw))
          enddo
        endif
        do itet=1,6
          centerint = .false.
          do iv=1,4
            evtx0(iv)=enval(ivndx(iv,itet))
            rrpyr(1:3,iv)=rr(1:3,ivndx(iv,itet))
            if (lc) then
              do iw=1,nwpt
                vpyr0(iv,iw)=vfv(ivndx(iv,itet),iw)
              enddo
            endif
            if ((ixx(1)+rrpyr(1,iv).eq.ictr(1)).and.(ixx(2)+rrpyr(2,iv).eq.ictr(2)).and.(ixx(3)+rrpyr(3,iv).eq.ictr(3))) then
              centerint = .true.  ! does tetrahedron contain center vertex?
              vcenterint = iv     ! index of center vertex
            endif
          enddo
!write(6,*) ixx
!write(6,*) itet,centerint
!if (centerint) then
!write(6,*) itet
!do iv=1,4
!write(6,*) ixx+rrpyr(:,iv)
!enddo
!!read(*,*)
!endif
          call indxhpsort(4,4,evtx0,indxe)
          evtx=evtx0(indxe)
          do ii=1,4
            jj=indxe(ii)
            kvtx(:,ii) = (iqq(:) + rrpyr(:,jj))
            do kk=1,3
              kvtxc(kk,ii)=dot_product(iqq+rrpyr(:,jj),qkcvt(:,kk))
            enddo
          enddo
          xk(1:3,1)=(/0.d0,0.d0,0.d0/)
          xkc(1:3,1)=(/0.d0,0.d0,0.d0/)
          do ii=1,3
            xk(:,ii+1)=rrpyr(:,indxe(ii+1))-rrpyr(:,indxe(1))
          enddo
          do ii=2,4
            xkc(1:3,ii)=kvtxc(1:3,ii)-kvtxc(1:3,1)
          enddo
          do jj=1,3  ! make contragredient, reduced coordinates
            call cross(xk(:,mod(jj,3)+2),xk(:,mod(jj+1,3)+2),rg(:,jj))
          enddo
          do jj=1,3  ! make contragredient, Cartesian coordinates
            call cross(xkc(:,mod(jj,3)+2),xkc(:,mod(jj+1,3)+2),rgc(:,jj))
          enddo
          tvol=dot_product(xk(1:3,2),rg(1:3,1))
          rg=rg/tvol
          tvol=abs(tvol)
          tvolc=dot_product(xkc(1:3,2),rgc(1:3,1))
          rgc=rgc/tvolc
          tvolc=abs(tvolc)
          iwwlim=nint(evtx/dw)
          if (lqsing .and. centerint) then
! singular part
! DEBUG
!xdum = 0.d0
!write(6,*)
!write(6,*) "singular integration"
!write(6,*) 'ixx: ',ixx
!write(6,*) 'itet: ',itet,'  centerint: ',centerint
!write(6,*) 'iwwlim: ',iwwlim
            do iv=1,4
! subtraction of integrated singular function from values at vertices
              ixr=ixx+rrpyr(:,iv)
              iqr = ixr - ictr
              if (ixr(1).eq.ictr(1).and.ixr(2).eq.ictr(2).and.ixr(3).eq.ictr(3)) then
                if (lc) then
                  do iw=1,nwpt
                    vpyr0(iv,iw) = 0.d0
                  enddo
                endif
              else
                qq = dble(iqr)/dble(ngkpt)
                qq2 = 0.d0
                do ii=1,3
                do jj=1,3
                  qq2 = qq2 + qq(ii)*bmet(ii,jj)*qq(jj)
                enddo
                enddo
                if (lc) then
                  do iw=1,nwpt
                    do ii=1,3
                    do jj=1,3
                      vpyr0(iv,iw)=vpyr0(iv,iw)-qq(ii)*vsm2(ii,jj,iw)*qq(jj)/(qq2**2)
                    enddo
                    enddo
                  enddo
                endif
              endif
            enddo
            bgrad=(/0.d0,0.d0,0.d0/)   ! energy gradient
            do jj=1,3
              bgrad=bgrad+(evtx(jj+1)-evtx(1))*rgc(:,jj)
            enddo
            xmult=1.d0/sqrt(dot_product(bgrad,bgrad))
! DEBUG
!cdum = 0.d0
! DEBUG
!write(6,*) "first set"
            do iww=iwwlim(1),iwwlim(2) ! energies between evtx(1) & evtx(2)
! DEBUG
!write(6,*) iww
              wwwlo=max(dw*(iww-0.5d0),evtx(1))
              wwwhi=min(dw*(iww+0.5d0),evtx(2))
              if (abs(wwwhi-wwwlo)*1.d14.lt.max(abs(wwwhi),abs(wwwlo),dw)) cycle
              do ii=1,3
              do jj=1,3
! DEBUG
k_ct_DEBUG = k_ct_DEBUG + 1
!write(6,*) "k_ct_DEBUG: ",k_ct_DEBUG,ii,jj
!if (k_ct_DEBUG.eq.k_ref_DEBUG) write(6,*) "E_LIM:      ",wwwlo,wwwhi
!if (k_ct_DEBUG.le.9) write(77,*) "# ",ii,jj
                call tsinggrater(ii,jj,wwwlo,wwwhi,1,xk,kvtx(:,1),ngkpt,evtx,abr,rlr,nsing,wsing,stens(ii,jj))
              enddo
              enddo
              stens = stens * xmult
              if (lc) then
                do iw=1,nwpt
                  ie=iww-ocsign*iw
!! DEBUG
!cdum = 0.d0
!do ii=1,3
!do jj=1,3
!ctensdum2(ii,jj) = (0.d0,0.d0)
!do kk=1,3
!do ll=1,3
!ctensdum2(ii,jj) = ctensdum2(ii,jj) + blat(kk,ii)*vsfactor(kk,ll,iw)*blat(ll,jj)
!enddo
!enddo
!enddo
!enddo
                  do ii=1,3
                  do jj=1,3
                    ssi(ie)=ssi(ie)+vsm2(ii,jj,iw)*stens(jj,ii)
!! DEBUG
!if (ie.eq.0.or.ie.eq.1) then
!cdum = cdum+vsm2(ii,jj,iw)*stens(jj,ii)
!endif
!if (iw.eq.158) then
!write(6,*) ii,jj,dimag(ctensdum2(ii,jj)),dimag(vsfactor(ii,jj,iw)),dimag(vsm2(ii,jj,iw)),stens(jj,ii)
!endif
                  enddo
                  enddo
! DEBUG
!if (iw.eq.158) then
!write(6,'(i4,23e14.3)') iw,cdum
!stop
!endif
!if (cdum.ne.(0.d0,0.d0)) then
!write(6,'(i4,23e14.3)') iw,cdum
!read(*,*)
!endif
                enddo
              endif
! DEBUG
!write(6,'(5i3,2x,2f16.10)') ix,iy,iz,itet,iww,cdum
            enddo
! DEBUG
!write(6,*) 'Khst7',xdum
!read(*,*)
!write(6,*) "second set"
            do iww=iwwlim(2),iwwlim(3) ! energies between evtx(2) & evtx(3)
! DEBUG
!write(6,*) iww
              wwwlo=max(dw*(iww-0.5d0),evtx(2))
              wwwhi=min(dw*(iww+0.5d0),evtx(3))
              if (abs(wwwhi-wwwlo)*1.d14.lt.max(abs(wwwhi),abs(wwwlo),dw)) cycle
              do ii=1,3
              do jj=1,3
! DEBUG
k_ct_DEBUG = k_ct_DEBUG + 1
!write(6,*) "k_ct_DEBUG: ",k_ct_DEBUG,ii,jj
!if (k_ct_DEBUG.eq.k_ref_DEBUG) write(6,*) "E_LIM:      ",wwwlo,wwwhi
                call tsinggrater(ii,jj,wwwlo,wwwhi,2,xk,kvtx(:,1),ngkpt,evtx,abr,rlr,nsing,wsing,sint1a)
! DEBUG
k_ct_DEBUG = k_ct_DEBUG + 1
!write(6,*) "k_ct_DEBUG: ",k_ct_DEBUG,ii,jj
!if (k_ct_DEBUG.eq.k_ref_DEBUG) write(6,*) "E_LIM:      ",wwwlo,wwwhi
                call tsinggrater(ii,jj,wwwlo,wwwhi,3,xk,kvtx(:,1),ngkpt,evtx,abr,rlr,nsing,wsing,sint1b)
                stens(ii,jj) = sint1a+sint1b
              enddo
              enddo
              stens = stens * xmult
! DEBUG
!cdum = 0.d0
              if (lc) then
                do iw=1,nwpt
                  ie=iww-ocsign*iw
                  do ii=1,3
                  do jj=1,3
                      ssi(ie)=ssi(ie)+vsm2(ii,jj,iw)*stens(jj,ii)
! DEBUG
!if (ie.eq.0.or.ie.eq.1) then
!cdum = cdum+vsm2(ii,jj,iw)*stens(jj,ii)
!endif
                  enddo
                  enddo
                enddo
              endif
! DEBUG
!write(6,'(5i3,2x,2f16.10)') ix,iy,iz,itet,iww,cdum
            enddo
! DEBUG
!write(6,*) 'Khst7',xdum
!write(6,*) "third set"
            do iww=iwwlim(3),iwwlim(4) ! energies between evtx(3) & evtx(4)
! DEBUG
!write(6,*) iww
              wwwlo=max(dw*(iww-0.5d0),evtx(3))
              wwwhi=min(dw*(iww+0.5d0),evtx(4))
              if (abs(wwwhi-wwwlo)*1.d14.lt.max(abs(wwwhi),abs(wwwlo),dw)) cycle
              do ii=1,3
              do jj=1,3
! DEBUG
k_ct_DEBUG = k_ct_DEBUG + 1
!write(6,*) "k_ct_DEBUG: ",k_ct_DEBUG,ii,jj
!if (k_ct_DEBUG.eq.k_ref_DEBUG) write(6,*) "E_LIM:      ",wwwlo,wwwhi
                call tsinggrater(ii,jj,wwwlo,wwwhi,4,xk,kvtx(:,1),ngkpt,evtx,abr,rlr,nsing,wsing,stens(ii,jj))
              enddo
              enddo
              stens = stens * xmult
! DEBUG
!cdum = 0.d0
              if (lc) then
                do iw=1,nwpt
                  ie=iww-ocsign*iw
                  do ii=1,3
                  do jj=1,3
                      ssi(ie)=ssi(ie)+vsm2(ii,jj,iw)*stens(jj,ii)
! DEBUG
!if (ie.eq.0.or.ie.eq.1) then
!cdum = cdum+vsm2(ii,jj,iw)*stens(jj,ii)
!endif
                  enddo
                  enddo
                enddo
              endif
! DEBUG
!write(6,'(5i3,2x,2f16.10)') ix,iy,iz,itet,iww,cdum
            enddo
! DEBUG
!write(6,*) 'Khst7',xdum
!write(32,'(4i3,2x,f14.10,2x,f14.10,"  sing")') ixx,itet,(cdum/2.d0)
!write(6,*) "finished singular integration"
          elseif (centerint) then
! anisotropic part
! DEBUG
!cdum = 0.d0
            if (lc) then
              do iww=iwwlim(1)-1,iwwlim(4)+1
                wwwlo=dw*(iww-0.5d0)
!                wwwhi=dw*(iww+0.5d0)
                do iw=1,nwpt
                  call vnitetint(rrpyr,evtx0,wwwlo,dw,vjfactor(:,:,iw),bmet,vcenterint,cint)
                  ie=iww-ocsign*iw
                  ssi(ie)=ssi(ie)+cint/volelmnt
! DEBUG
!if (ie.eq.0.or.ie.eq.1) cdum = cdum+cint/volelmnt
                enddo
              enddo
            endif
! DEBUG
!write(32,'(4i3,2x,f14.10,2x,f14.10,"  cent")') ixx,itet,(cdum/2.d0)
          endif
! can use basic tetrahedron integration for everything else
! DEBUG
!cdum = 0.d0
          if (lc) then
            do iw=1,nwpt
              aa0(iw)=vpyr0(indxe(1),iw)   ! base value of function
              av(1:3,iw)=(/0.d0,0.d0,0.d0/) ! gradient of function
              do jj=1,3
                av(1:3,iw)=av(1:3,iw) &
&                      +(vpyr0(indxe(jj+1),iw)-vpyr0(indxe(1),iw))*rg(1:3,jj)
              enddo
            enddo
            do iww=iwwlim(1)-1,iwwlim(4)+1
              wwwlo=dw*(iww-0.5d0)
!              wwwhi=dw*(iww+0.5d0)
              call mkvsint(rrpyr(1:3,indxe),xk,volred,evtx,wwwlo,dw,sint1,svec)
              do iw=1,nwpt
                ie=iww-ocsign*iw
                ssi(ie)=ssi(ie)+(aa0(iw)*sint1+dot_product(svec,av(:,iw)))/volelmnt
! DEBUG
!if (ie.eq.0.or.ie.eq.1) cdum = cdum+(aa0(iw)*sint1+dot_product(svec,av(:,iw)))/volelmnt
              enddo
            enddo
          endif
! DEBUG
!write(32,'(4i3,2x,f14.10,2x,f14.10)') ixx,itet,(cdum/2.d0)
        enddo
      enddo
      enddo
      enddo
!    if (lc) ssi=-ssi/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
      if (lc) ssi=-ocsign*ssi/((2*pi)**3*pi)

! DEBUG
!write(6,*) "Integration complete"

      if (lc) then
        do ie=max(-nwpt,ielo),min(nwpt,iehi)
          ploss1(ie)=ploss1(ie)+abs(dimag(ssi(ie)))*pi
        enddo
      endif
      deallocate (ssi)
    endif

  enddo
enddo

do ie=-nwpt,nwpt
  eps1=dble(ie)*dw-dw/2
!  write(14,'(i4,f10.3,2(3x,2es12.3))') ie,eps1*27.2114,ploss1(ie)
enddo
write(14,*)
if (itetrahedron.eq.1) then
  iw = int(total_se/dw)
  rw = total_se - iw*dw
!  write(14,*) iw,rw
  ploss=ploss1(iw)*((dw-rw)/dw)+ploss1(iw+1)*(rw/dw)
!  ploss=(ploss1(0)+ploss1(1))/2.
!  write(14,*) ploss
endif

!write(6,*) "kwls ",total_se,ploss

!temparray=log10(temparray)
!temparray=10**(temparray-int(temparray))
!do ix=1,ngkpt(1)
!  write(76,*) ix,'--------------------------------------------------'
!  do iy=1,ngkpt(2)
!!    write(76,'(10es8.1)') dble(temparray(ix,iy,:))
!    write(76,'(10f8.5)') dble(temparray(ix,iy,:))
!  enddo
!enddo

return
end subroutine mkploss


subroutine mkrho(igglf,iks,vol,pi, &
& nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom,xred,projwf,nlmn, &
& kg,kgq,enrgy,enrgyq,cg,cgq,npwt,npwtq,bantot,bantotq,ncg,ncgq, &
& indxkpw,indxkpwq,indxkbnd,indxkbndq,indxkcg,indxkcgq,npwarr,npwarrq, &
& kpt,kptq,nkpt,nkptq,nsymk,nsymkq,symk,symkq,nsym,nsymq,symrel,syminv, &
& ihlf,ihlfq,lvtrans,lvtransq,ipaw, &
& pwmatel1,tpwmatel1,pwmatel2,tpwmatel2, &
& igmx,igmn,igndx,igndxq,ikndx,ikndxq,isymndx,isymndxq,npw,npwq, &
& nband,nbandq,nsppol,shiftk,shiftkq,pola,polb)
implicit none
double precision :: qq(3),qp(3),dq(3),vq,vol,pi,wmax,dw,xred(3,natom)
integer :: nwpt,nbcore,nbocc,ncband,ngkpt(3),npwt,npwtq,npw,npwq,iks(3)
integer :: bantot,bantotq,ncg,ncgq,nkpt,nkptq,ipw1,ipw2,ipw,nlmn,natom
integer :: nsym,nsymq,igmx(3),igmn(3),igcut,nsppol,ipaw
integer :: kg(3,npwt),kgq(3,npwtq),igglf1(3),igglf2(3)
double complex :: projwf(natom,nlmn,nkpt,ncband)
double precision :: enrgy(bantot),enrgyq(bantotq)
double complex :: cg(ncg),cgq(ncgq)
integer :: indxkpw(nkpt),indxkpwq(nkptq),indxkbnd(nkpt),indxkbndq(nkptq)
integer :: indxkcg(nkpt),indxkcgq(nkptq),npwarr(nkpt),npwarrq(nkptq)
double precision :: kpt(3,nkpt),kptq(3,nkptq),shiftk(3),shiftkq(3)
integer :: nsymk(nkpt),nsymkq(nkptq),symk(nkpt,nsym*2),symkq(nkptq,nsymq*2)
integer :: symrel(3,3,nsym),syminv(3,3,nsymq)
integer :: lvtrans(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: lvtransq(3,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ihlf(nkpt),ihlfq(nkptq)
integer :: igndx(nkpt,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: igndxq(nkptq,igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3))
integer :: ikndx(ngkpt(1),ngkpt(2),ngkpt(3)),ikndxq(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: isymndx(ngkpt(1),ngkpt(2),ngkpt(3)),isymndxq(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: nband(nkpt*nsppol),nbandq(nkptq*nsppol)
double complex :: pola(nwpt),polb(nwpt),dielf(npwt),tpolincr,polci(npwt),dpol
! pola - hermitian part of vq * polarization matrix element for igglf1,igglf2
! polb - antihermitian part of vq * polarization matrix element
double complex :: cmat2(ngkpt(1),ngkpt(2),ngkpt(3)),cmatel,cmatellf,cmat2v(8)
double complex :: amatel,amatellf
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,ww,ww1,ww2,enval(8)
integer :: iwh,iwl
double precision :: xck(3),xckq(3)
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),gap
integer :: ivgndx(igmn(1):igmx(1),igmn(2):igmx(2),igmn(3):igmx(3),ngkpt(1),ngkpt(2),ngkpt(3))
integer :: ii,jj,kk,iw,jw,iocc,iunocc,ikk(3),ikkp(3),jkk(3),jka(3),isym,isymq
integer :: ig,jg,igg(3),jgg(3),jgs(3),ikpt,ikptq,ix,iy,iz,igx,igy,igz,igg0(3)
double complex :: pwmatel1(nlmn,nlmn),pwmatel2(nlmn,nlmn),tpwmatel1(nlmn,nlmn),tpwmatel2(nlmn,nlmn)

  igg0=(/0,0,0/)
  rho=(0.d0,0.d0)

  do iocc=nbcore+1,nbocc
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=1,1
!    do iy=1,1
!    do iz=1,1
      ikk=(/ix,iy,iz/)
      ikpt=ikndx(ikk(1),ikk(2),ikk(3))
      isym=isymndx(ikk(1),ikk(2),ikk(3))
      do ii=1,3
        jka(ii)=ikk(ii)-iks(ii)
        jkk(ii)=mod(jka(ii)-1,ngkpt(ii))+1
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
        xck(ii)=dble(ikk(ii))/dble(ngkpt(ii))+shiftk(ii)/dble(ngkpt(ii))
        xck(ii)=mod(xck(ii),1.d0)
        if (xck(ii).lt.0.d0) xck(ii)=xck(ii)+1
        xck(ii)=1.d0-mod(1.d0-xck(ii),1.d0)
        xck(ii)=xck(ii)-0.5d0
        xckq(ii)=dble(jkk(ii))/dble(ngkpt(ii))+shiftkq(ii)/dble(ngkpt(ii))
        xckq(ii)=mod(xckq(ii),1.d0)
        if (xckq(ii).lt.0.d0) xckq(ii)=xckq(ii)+1
        xckq(ii)=1.d0-mod(1.d0-xckq(ii),1.d0)
        xckq(ii)=xckq(ii)-0.5d0
        igg(ii)=nint(xckq(ii)-xck(ii)+qq(ii))-igglf1(ii)
      enddo
      ikptq=ikndxq(jkk(1),jkk(2),jkk(3))
      isymq=isymndxq(jkk(1),jkk(2),jkk(3))
!      write(6,'(4(3i3,3x))') ikk,jkk,iks,igg
!      write(6,'(3(3f10.6,3x))') xck,xckq
!      write(6,'(3(3f10.6,3x))') qq,qq-igglf1
!      write(6,'(3f8.4,4x,3f8.4)') kpt(1:3,ikpt),kptq(1:3,ikptq)
!      write(6,'(3i5)') ikpt,ikptq
!      write(6,'(3i5)') isym,isymq,nsym
!      write(6,'(2i4,4x,2i4)') mod(isym-1,nsym)+1,-(2*((isym-1)/nsym)-1),mod(isymq-1,nsym)+1,-(2*((isymq-1)/nsym)-1)
      call mkmatelX(iocc,iocc,ikpt,ikpt,igglf1,igg, &
&       ncg,ncg,nkpt,nkpt,npwt,npwt,igmx,igmn,igndx,igndx, &
&       isym,isymq,symrel,syminv,nsym,nsym,ihlf,ihlf,kpt,kpt, &
&       lvtrans(1:3,ikk(1),ikk(2),ikk(3)),lvtrans(1:3,ikk(1),ikk(2),ikk(3)), &
&       cg,cg,indxkcg,indxkcg,indxkpw,indxkpw,npwarr,npwarr,kg,kg, &
&       cmatel)
      if (ipaw.ne.0) then
!        call mkmatelP(pi,xred,natom,iocc,iunocc,ikpt,ikptq,qq,igg0,ngkpt,pwmatel1,tpwmatel1,projwf,nlmn,nkpt,nkptq,ncband,amatel)
      else
        amatel=(0.d0,0.d0)
      endif
      rho=rho+cmatel+amatel
    enddo
    enddo
    enddo
  enddo
  rho=rho/(vol*ngkpt(1)*ngkpt(2)*ngkpt(3))

return
end subroutine mkrho