#include "../defines.inc"
module update_rU
! use update_rU, only: update_r, checkR
contains

   subroutine update_r(I)
! values from wlcsim_data
      use params, only: wlc_bin, wlc_R_period, wlc_R, wlc_UP, wlc_VP &
                        , wlc_U, wlc_V, wlc_RP
      use params, only: dp, NAN
      use binning, only: addBead, removeBead
      implicit none
      integer, intent(in) :: I

      if (WLC_P__NEIGHBOR_BINS) then
         if (WLC_P__CONFINETYPE == 'excludedShpereInPeriodic') then
            call removeBead(wlc_bin, wlc_R_period(:, I), I)
         elseif (WLC_P__CONFINETYPE == 'none') then
            call removeBead(wlc_bin, wlc_R_period(:, I), I)
         elseif (WLC_P__CONFINETYPE == 'sphere') then
            if (WLC_P__GJK_STERICS) then
               call GJK_removeBead(I)
            else
               call removeBead(wlc_bin, wlc_R(:, I), I)
            endif
         elseif (WLC_P__CONFINETYPE == 'cube') then
            if (WLC_P__GJK_STERICS) then
               call GJK_removeBead(I)
            else
               print *, "Not an option yet.  See mcsim."
               stop 1
            endif
         endif
      endif
      wlc_R(:, I) = wlc_RP(:, I)
      wlc_U(:, I) = wlc_UP(:, I)
      if (WLC_P__LOCAL_TWIST) then
         wlc_V(:, I) = wlc_VP(:, I)/norm2(wlc_VP(:, I))
      endif
      if (WLC_P__NEIGHBOR_BINS) then
         if (WLC_P__CONFINETYPE == 'excludedShpereInPeriodic' .or. WLC_P__CONFINETYPE == 'none') then
            wlc_R_period(1, I) = modulo(wlc_R(1, I), WLC_P__LBOX_X)
            wlc_R_period(2, I) = modulo(wlc_R(2, I), WLC_P__LBOX_Y)
            wlc_R_period(3, I) = modulo(wlc_R(3, I), WLC_P__LBOX_Z)
            call addBead(wlc_bin, wlc_R_period, WLC_P__NT, I)
         elseif (WLC_P__CONFINETYPE == 'sphere') then
            if (WLC_P__GJK_STERICS) then
               call GJK_update(I, .true.)
            else
               call addBead(wlc_bin, wlc_R, WLC_P__NT, I)
            endif
         elseif (WLC_P__CONFINETYPE == 'cube') then
            if (WLC_P__GJK_STERICS) then
               call GJK_update(I, .true.)
            endif
         else
            print *, "Not an option yet.  See mcsim."
            stop 1
         endif
      else if (WLC_P__GJK_STERICS) then
         call GJK_update(I, .false.)
      endif

   end subroutine update_r

   subroutine GJK_removeBead(I)
   ! helper function to remove beads with binning
      use params, only: wlc_bin, wlc_R_period, wlc_R, wlc_UP, wlc_VP &
                        , wlc_U, wlc_V, wlc_RP, wlc_R_GJK, wlc_GJK
      use params, only: dp, NAN
      use binning, only: removeBead
      use polydispersity, only: get_IP, first_bead_of_chain, last_bead_of_chain
      implicit none
      integer, intent(in) :: I

      ! if bead i moves, then remove virtual beads i-1 and i
      if (I > first_bead_of_chain(get_IP(I))) then
         call removeBead(wlc_bin, wlc_R_GJK(:, I - 1), I - 1)
      endif
      if (I < last_bead_of_chain(get_IP(I))) then
         call removeBead(wlc_bin, wlc_R_GJK(:, I), I)
      endif

   end subroutine GJK_removeBead

   subroutine GJK_update(I, binningBool)
   ! helper routine to update R in GJK simulations
      use params, only: wlc_bin, wlc_R_period, wlc_R, wlc_UP, wlc_VP, &
                        wlc_U, wlc_V, wlc_RP, wlc_R_GJK, wlc_GJK, wlc_nucleosomeWrap
      use params, only: dp, NAN
      use GJKAlgorithm, only: constructPolygonPrism
      use binning, only: addBead
      use polydispersity, only: get_IP, first_bead_of_chain, last_bead_of_chain
      implicit none
      integer, intent(in) :: I
      logical, intent(in) :: binningBool
      real(dp) poly(WLC_P__GJK_POLYGON, 3)

      ! add back in virtual beads i-1 and i for moved bead i
      if (I > first_bead_of_chain(get_IP(I))) then
         if (isnan(wlc_RP(1, I - 1))) then
            poly = constructPolygonPrism(wlc_R(:, I - 1), wlc_R(:, I), wlc_nucleosomeWrap(I - 1), &
                                          wlc_U(:, I - 1), wlc_V(:, I - 1), WLC_P__GJK_POLYGON)
         else
            poly = constructPolygonPrism(wlc_RP(:, I - 1), wlc_R(:, I), wlc_nucleosomeWrap(I - 1), &
                                          wlc_UP(:, I - 1), wlc_VP(:, I - 1)/norm2(wlc_VP(:, I - 1)), WLC_P__GJK_POLYGON)
         endif
         wlc_GJK(:, :, I - 1) = poly
         wlc_R_GJK(1, I - 1) = sum(poly(:, 1)/WLC_P__GJK_POLYGON)
         wlc_R_GJK(2, I - 1) = sum(poly(:, 2)/WLC_P__GJK_POLYGON)
         wlc_R_GJK(3, I - 1) = sum(poly(:, 3)/WLC_P__GJK_POLYGON)
         if (binningBool) then
            call addBead(wlc_bin, wlc_R_GJK, WLC_P__NT, I - 1)
         endif
      endif
      if (I < last_bead_of_chain(get_IP(I))) then
         if (isnan(wlc_RP(1, I + 1))) then
            poly = constructPolygonPrism(wlc_R(:, I), wlc_R(:, I + 1), wlc_nucleosomeWrap(I), &
                                          wlc_U(:, I), wlc_V(:, I), WLC_P__GJK_POLYGON)
         else
            poly = constructPolygonPrism(wlc_R(:, I), wlc_RP(:, I + 1), wlc_nucleosomeWrap(I), &
                                          wlc_U(:, I), wlc_V(:, I), WLC_P__GJK_POLYGON)
         endif
         wlc_GJK(:, :, I) = poly
         wlc_R_GJK(1, I) = sum(poly(:, 1)/WLC_P__GJK_POLYGON)
         wlc_R_GJK(2, I) = sum(poly(:, 2)/WLC_P__GJK_POLYGON)
         wlc_R_GJK(3, I) = sum(poly(:, 3)/WLC_P__GJK_POLYGON)
         if (binningBool) then
            call addBead(wlc_bin, wlc_R_GJK, WLC_P__NT, I)
         endif
      endif
   end subroutine GJK_update

   function checkR(I, IT1, IT2)
! values from wlcsim_data
      use params, only: wlc_ExplicitBindingPair, wlc_R, wlc_RP
      use params, only: eps
      implicit none
      integer, intent(in) :: IT1, IT2
      integer, intent(in) :: I
      logical checkR

      integer otherEnd
      otherEnd = wlc_ExplicitBindingPair(I)
      if (WLC_P__NETWORK) then
         print *, "checkR not implemented for Network"
         stop 1
      endif
      if (otherEnd == -1) then
         checkR = .False.
         return
      endif

      if (IT1 <= otherend .and. otherEnd <= IT2) then

         if (norm2(wlc_RP(:, I) - wlc_RP(:, otherEnd)) > eps) then
            print *, "moved apart"
            print *, "I", I, "otherEnd", otherEnd
            print *, " R(I)", wlc_R(:, I)
            print *, " R(o)", wlc_R(:, otherEnd)
            print *, "RP(I)", wlc_RP(:, I)
            print *, "RP(o)", wlc_RP(:, otherEnd)
            print *, "error", norm2(wlc_RP(:, I) - wlc_RP(:, otherEnd))
            checkR = .True.
         endif
      else
         if (norm2(wlc_RP(:, I) - wlc_R(:, otherEnd)) > eps) then
            print *, "moved apart"
            print *, "I", I, "otherEnd", otherEnd
            print *, " R(I)", wlc_R(:, I)
            print *, " R(o)", wlc_R(:, otherEnd)
            print *, "RP(I)", wlc_RP(:, I)
            print *, "R(o)", wlc_R(:, otherEnd)
            print *, "error", norm2(wlc_RP(:, I) - wlc_RP(:, otherEnd))
            checkR = .True.
         endif
      endif
   end function checkR

end module


PROGRAM cases
IMPLICIT NONE
  INTEGER :: temp ! Temperature in degrees Celsius
  WRITE(*, *) "Enter the temperature in degrees Celsius"
  READ(*, *) temp
  WRITE(*, *) temp, " degrees Celsius:"
  weather: SELECT CASE (temp)
  CASE(:-1)
    WRITE(*, *) "Below freezin'"
  CASE(0)
    WRITE(*, *) "Exactly freezin'"
  CASE DEFAULT
    WRITE(*, *) "Probably not freezin'"
  END SELECT weather
END PROGRAM cases


Subroutine ludecy(ip)
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Save /lujets/
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Save /ludat1/
  Common /ludat2/kchg(500, 3), pmas(500, 4), parf(2000), vckm(4, 4)
  Save /ludat2/
  Common /ludat3/mdcy(500, 3), mdme(2000, 2), brat(2000), kfdp(2000, 5)
  Save /ludat3/
  Dimension vdcy(4), kflo(4), kfl1(4), pv(10, 5), rord(10), ue(3), be(3), wtcor(10)
  Common /resdcy/nsav, iksdcy
  Save /resdcy/
  Data wtcor/2., 5., 15., 60., 250., 1500., 1.2E4, 1.2E5, 150., 16./
  pawt(a, b, c) = sqrt((a**2-(b+c)**2)*(a**2-(b-c)**2))/(2.*a)
  four(i, j) = p(i, 4)*p(j, 4) - p(i, 1)*p(j, 1) - p(i, 2)*p(j, 2) - p(i, 3)*p(j, 3)
  hmeps(ha) = ((1.-hrq-ha)**2+3.*ha*(1.+hrq-ha))*sqrt((1.-hrq-ha)**2-4.*hrq*ha)
  ntry = 0
  nsav = n
  kfa = iabs(k(ip,2))
  kfs = isign(1, k(ip,2))
  kc = lucomp(kfa)
  mstj(92) = 0
  If (k(ip,1)==5) Then
    v(ip, 5) = 0.
  Else If (k(ip,1)/=4) Then
    v(ip, 5) = -pmas(kc, 4)*log(rlu(0))
  End If
  Do j = 1, 4
    vdcy(j) = v(ip, j) + v(ip, 5)*p(ip, j)/p(ip, 5)
  End Do
  mout = 0
  If (mstj(22)==2) Then
    If (pmas(kc,4)>parj(71)) mout = 1
  Else If (mstj(22)==3) Then
    If (vdcy(1)**2+vdcy(2)**2+vdcy(3)**2>parj(72)**2) mout = 1
  Else If (mstj(22)==4) Then
    If (vdcy(1)**2+vdcy(2)**2>parj(73)**2) mout = 1
    If (abs(vdcy(3))>parj(74)) mout = 1
  End If
  If (mout==1 .And. k(ip,1)/=5) Then
    k(ip, 1) = 4
    Return
  End If
  kca = kc
  If (mdcy(kc,2)>0) Then
    mdmdcy = mdme(mdcy(kc,2), 2)
    If (mdmdcy>80 .And. mdmdcy<=90) kca = mdmdcy
  End If
  If (mdcy(kca,2)<=0 .Or. mdcy(kca,3)<=0) Then
    Call luerrm(9, '(LUDECY:) no decay channel defined')
    Return
  End If
  If (mod(kfa/1000,10)==0 .And. (kca==85 .Or. kca==87)) kfs = -kfs
  If (kchg(kc,3)==0) Then
    kfsp = 1
    kfsn = 0
    If (rlu(0)>0.5) kfs = -kfs
  Else If (kfs>0) Then
    kfsp = 1
    kfsn = 0
  Else
    kfsp = 0
    kfsn = 1
  End If
  nope = 0
  brsu = 0.
  Do idl = mdcy(kca, 2), mdcy(kca, 2) + mdcy(kca, 3) - 1
    If (mdme(idl,1)/=1 .And. kfsp*mdme(idl,1)/=2 .And. kfsn*mdme(idl,1)/=3) Goto 120
    If (mdme(idl,2)>100) Goto 120
    nope = nope + 1
    brsu = brsu + brat(idl)
  120 End Do
  If (nope==0) Then
    Call luerrm(2, '(LUDECY:) all decay channels closed by user')
    Return
  End If
  130 rbr = brsu*rlu(0)
  idl = mdcy(kca, 2) - 1
  140 idl = idl + 1
  If (mdme(idl,1)/=1 .And. kfsp*mdme(idl,1)/=2 .And. kfsn*mdme(idl,1)/=3) Then
    If (idl<mdcy(kca,2)+mdcy(kca,3)-1) Goto 140
  Else If (mdme(idl,2)>100) Then
    If (idl<mdcy(kca,2)+mdcy(kca,3)-1) Goto 140
  Else
    idc = idl
    rbr = rbr - brat(idl)
    If (idl<mdcy(kca,2)+mdcy(kca,3)-1 .And. rbr>0.) Goto 140
  End If
  mmat = mdme(idc, 2)
  150 ntry = ntry + 1
  If (ntry>1000) Then
    Call luerrm(14, '(LUDECY:) caught in infinite loop')
    If (mstu(21)>=1) Return
  End If
  i = n
  np = 0
  nq = 0
  mbst = 0
  If (mmat>=11 .And. mmat/=46 .And. p(ip,4)>20.*p(ip,5)) mbst = 1
  Do j = 1, 4
    pv(1, j) = 0.
    If (mbst==0) pv(1, j) = p(ip, j)
  End Do
  If (mbst==1) pv(1, 4) = p(ip, 5)
  pv(1, 5) = p(ip, 5)
  ps = 0.
  psq = 0.
  mrem = 0
  jtmax = 5
  If (mdme(idc+1,2)==101) jtmax = 10
  Do jt = 1, jtmax
    If (jt<=5) kp = kfdp(idc, jt)
    If (jt>=6) kp = kfdp(idc+1, jt-5)
    If (kp==0) Goto 170
    kpa = iabs(kp)
    kcp = lucomp(kpa)
    If (kchg(kcp,3)==0 .And. kpa/=81 .And. kpa/=82) Then
      kfp = kp
    Else If (kpa/=81 .And. kpa/=82) Then
      kfp = kfs*kp
    Else If (kpa==81 .And. mod(kfa/1000,10)==0) Then
      kfp = -kfs*mod(kfa/10, 10)
    Else If (kpa==81 .And. mod(kfa/100,10)>=mod(kfa/10,10)) Then
      kfp = kfs*(100*mod(kfa/10,100)+3)
    Else If (kpa==81) Then
      kfp = kfs*(1000*mod(kfa/10,10)+100*mod(kfa/100,10)+1)
    Else If (kp==82) Then
      Call lukfdi(-kfs*int(1.+(2.+parj(2))*rlu(0)), 0, kfp, kdump)
      If (kfp==0) Goto 150
      mstj(93) = 1
      If (pv(1,5)<parj(32)+2.*ulmass(kfp)) Goto 150
    Else If (kp==-82) Then
      kfp = -kfp
      If (iabs(kfp)>10) kfp = kfp + isign(10000, kfp)
    End If
    If (kpa==81 .Or. kpa==82) kcp = lucomp(kfp)
    kfpa = iabs(kfp)
    kqp = kchg(kcp, 2)
    If (mmat>=11 .And. mmat<=30 .And. kqp/=0) Then
      nq = nq + 1
      kflo(nq) = kfp
      mstj(93) = 2
      psq = psq + ulmass(kflo(nq))
    Else If (mmat>=42 .And. mmat<=43 .And. np==3 .And. mod(nq,2)==1) Then
      nq = nq - 1
      ps = ps - p(i, 5)
      k(i, 1) = 1
      kfi = k(i, 2)
      Call lukfdi(kfp, kfi, kfldmp, k(i,2))
      If (k(i,2)==0) Goto 150
      mstj(93) = 1
      p(i, 5) = ulmass(k(i,2))
      ps = ps + p(i, 5)
    Else
      i = i + 1
      np = np + 1
      If (mmat/=33 .And. kqp/=0) nq = nq + 1
      If (mmat==33 .And. kqp/=0 .And. kqp/=2) nq = nq + 1
      k(i, 1) = 1 + mod(nq, 2)
      If (mmat==4 .And. jt<=2 .And. kfp==21) k(i, 1) = 2
      If (mmat==4 .And. jt==3) k(i, 1) = 1
      k(i, 2) = kfp
      k(i, 3) = ip
      k(i, 4) = 0
      k(i, 5) = 0
      p(i, 5) = ulmass(kfp)
      If (mmat==45 .And. kfpa==89) p(i, 5) = parj(32)
      ps = ps + p(i, 5)
    End If
  170 End Do
  180 If (mmat>=11 .And. mmat<=30) Then
    psp = ps
    cnde = parj(61)*log(max((pv(1,5)-ps-psq)/parj(62),1.1))
    If (mmat==12) cnde = cnde + parj(63)
    190 ntry = ntry + 1
    If (ntry>1000) Then
      Call luerrm(14, '(LUDECY:) caught in infinite loop')
      If (mstu(21)>=1) Return
    End If
    If (mmat<=20) Then
      gauss = sqrt(-2.*cnde*log(max(1E-10,rlu(0))))*sin(paru(2)*rlu(0))
      nd = int(0.5+0.5*np+0.25*nq+cnde+gauss)
      If (nd<np+nq/2 .Or. nd<2 .Or. nd>10) Goto 190
      If (mmat==13 .And. nd==2) Goto 190
      If (mmat==14 .And. nd<=3) Goto 190
      If (mmat==15 .And. nd<=4) Goto 190
    Else
      nd = mmat - 20
    End If
    Do jt = 1, 4
      kfl1(jt) = kflo(jt)
    End Do
    If (nd==np+nq/2) Goto 220
    Do i = n + np + 1, n + nd - nq/2
      jt = 1 + int((nq-1)*rlu(0))
      Call lukfdi(kfl1(jt), 0, kfl2, k(i,2))
      If (k(i,2)==0) Goto 190
      kfl1(jt) = -kfl2
    End Do
    220 jt = 2
    jt2 = 3
    jt3 = 4
    If (nq==4 .And. rlu(0)<parj(66)) jt = 4
    If (jt==4 .And. isign(1,kfl1(1)*(10-iabs(kfl1(1))))*isign(1,kfl1(jt)*(10-iabs(kfl1(jt))))>0) jt = 3
    If (jt==3) jt2 = 2
    If (jt==4) jt3 = 2
    Call lukfdi(kfl1(1), kfl1(jt), kfldmp, k(n+nd-nq/2+1,2))
    If (k(n+nd-nq/2+1,2)==0) Goto 190
    If (nq==4) Call lukfdi(kfl1(jt2), kfl1(jt3), kfldmp, k(n+nd,2))
    If (nq==4 .And. k(n+nd,2)==0) Goto 190
    ps = psp
    Do i = n + np + 1, n + nd
      k(i, 1) = 1
      k(i, 3) = ip
      k(i, 4) = 0
      k(i, 5) = 0
      p(i, 5) = ulmass(k(i,2))
      ps = ps + p(i, 5)
    End Do
    If (ps+parj(64)>pv(1,5)) Goto 190
  Else If ((mmat==31 .Or. mmat==33 .Or. mmat==44 .Or. mmat==45) .And. np>=3) Then
    ps = ps - p(n+np, 5)
    pqt = (p(n+np,5)+parj(65))/pv(1, 5)
    Do j = 1, 5
      p(n+np, j) = pqt*pv(1, j)
      pv(1, j) = (1.-pqt)*pv(1, j)
    End Do
    If (ps+parj(64)>pv(1,5)) Goto 150
    nd = np - 1
    mrem = 1
  Else If (mmat==46) Then
    mstj(93) = 1
    psmc = ulmass(k(n+1,2))
    mstj(93) = 1
    psmc = psmc + ulmass(k(n+2,2))
    If (max(ps,psmc)+parj(32)>pv(1,5)) Goto 130
    hr1 = (p(n+1,5)/pv(1,5))**2
    hr2 = (p(n+2,5)/pv(1,5))**2
    If ((1.-hr1-hr2)*(2.+hr1+hr2)*sqrt((1.-hr1-hr2)**2-4.*hr1*hr2)<2.*rlu(0)) Goto 130
    nd = np
  Else
    If (np>=2 .And. ps+parj(64)>pv(1,5)) Goto 150
    nd = np
  End If
  If (mmat==45 .And. mstj(25)<=0) Then
    hlq = (parj(32)/pv(1,5))**2
    huq = (1.-(p(n+2,5)+parj(64))/pv(1,5))**2
    hrq = (p(n+2,5)/pv(1,5))**2
    250 hw = hlq + rlu(0)*(huq-hlq)
    If (hmeps(hw)<rlu(0)) Goto 250
    p(n+1, 5) = pv(1, 5)*sqrt(hw)
  Else If (mmat==45) Then
    hqw = (pv(1,5)/pmas(24,1))**2
    hlw = (parj(32)/pmas(24,1))**2
    huw = ((pv(1,5)-p(n+2,5)-parj(64))/pmas(24,1))**2
    hrq = (p(n+2,5)/pv(1,5))**2
    hg = pmas(24, 2)/pmas(24, 1)
    hatl = atan((hlw-1.)/hg)
    hm = min(1., huw-0.001)
    hmv1 = hmeps(hm/hqw)/((hm-1.)**2+hg**2)
    260 hm = hm - hg
    hmv2 = hmeps(hm/hqw)/((hm-1.)**2+hg**2)
    hsav1 = hmeps(hm/hqw)
    hsav2 = 1./((hm-1.)**2+hg**2)
    If (hmv2>hmv1 .And. hm-hg>hlw) Then
      hmv1 = hmv2
      Goto 260
    End If
    hmv = min(2.*hmv1, hmeps(hm/hqw)/hg**2)
    hm1 = 1. - sqrt(1./hmv-hg**2)
    If (hm1>hlw .And. hm1<hm) Then
      hm = hm1
    Else If (hmv2<=hmv1) Then
      hm = max(hlw, hm-min(0.1,1.-hm))
    End If
    hatm = atan((hm-1.)/hg)
    hwt1 = (hatm-hatl)/hg
    hwt2 = hmv*(min(1.,huw)-hm)
    hwt3 = 0.
    If (huw>1.) Then
      hatu = atan((huw-1.)/hg)
      hmp1 = hmeps(1./hqw)
      hwt3 = hmp1*hatu/hg
    End If
    270 hreg = rlu(0)*(hwt1+hwt2+hwt3)
    If (hreg<=hwt1) Then
      hw = 1. + hg*tan(hatl+rlu(0)*(hatm-hatl))
      hacc = hmeps(hw/hqw)
    Else If (hreg<=hwt1+hwt2) Then
      hw = hm + rlu(0)*(min(1.,huw)-hm)
      hacc = hmeps(hw/hqw)/((hw-1.)**2+hg**2)/hmv
    Else
      hw = 1. + hg*tan(rlu(0)*hatu)
      hacc = hmeps(hw/hqw)/hmp1
    End If
    If (hacc<rlu(0)) Goto 270
    p(n+1, 5) = pmas(24, 1)*sqrt(hw)
  End If
  nm = 0
  msgn = 0
  If (mmat==3 .Or. mmat==46) Then
    im = k(ip, 3)
    If (im<0 .Or. im>=ip) im = 0
    If (im/=0) kfam = iabs(k(im,2))
    If (im/=0 .And. mmat==3) Then
      Do il = max(ip-2, im+1), min(ip+2, n)
        If (k(il,3)==im) nm = nm + 1
      End Do
      If (nm/=2 .Or. kfam<=100 .Or. mod(kfam,10)/=1 .Or. mod(kfam/1000,10)/=0) nm = 0
    Else If (im/=0 .And. mmat==46) Then
      msgn = isign(1, k(im,2)*k(ip,2))
      If (kfam>100 .And. mod(kfam/1000,10)==0) msgn = msgn*(-1)**mod(kfam/100, 10)
    End If
  End If
  If (nd==1) Then
    Do j = 1, 4
      p(n+1, j) = p(ip, j)
    End Do
    Goto 510
  End If
  pv(nd, 5) = p(n+nd, 5)
  If (nd>=3) Then
    wtmax = 1./wtcor(nd-2)
    pmax = pv(1, 5) - ps + p(n+nd, 5)
    pmin = 0.
    Do il = nd - 1, 1, -1
      pmax = pmax + p(n+il, 5)
      pmin = pmin + p(n+il+1, 5)
      wtmax = wtmax*pawt(pmax, pmin, p(n+il,5))
    End Do
  End If
  310 If (nd==2) Then
  Else If (mmat==2) Then
    pmes = 4.*pmas(11, 1)**2
    pmrho2 = pmas(131, 1)**2
    pgrho2 = pmas(131, 2)**2
    320 pmst = pmes*(p(ip,5)**2/pmes)**rlu(0)
    wt = (1+0.5*pmes/pmst)*sqrt(max(0.,1.-pmes/pmst))*(1.-pmst/p(ip,5)**2)**3*(1.+pgrho2/pmrho2)/((1.-pmst/pmrho2)**2+pgrho2/pmrho2)
    If (wt<rlu(0)) Goto 320
    pv(2, 5) = max(2.00001*pmas(11,1), sqrt(pmst))
  Else
    330 rord(1) = 1.
    Do il1 = 2, nd - 1
      rsav = rlu(0)
      Do il2 = il1 - 1, 1, -1
        If (rsav<=rord(il2)) Goto 350
        rord(il2+1) = rord(il2)
      End Do
      350 rord(il2+1) = rsav
    End Do
    rord(nd) = 0.
    wt = 1.
    Do il = nd - 1, 1, -1
      pv(il, 5) = pv(il+1, 5) + p(n+il, 5) + (rord(il)-rord(il+1))*(pv(1,5)-ps)
      wt = wt*pawt(pv(il,5), pv(il+1,5), p(n+il,5))
    End Do
    If (wt<rlu(0)*wtmax) Goto 330
  End If
  370 Do il = 1, nd - 1
    pa = pawt(pv(il,5), pv(il+1,5), p(n+il,5))
    ue(3) = 2.*rlu(0) - 1.
    phi = paru(2)*rlu(0)
    ue(1) = sqrt(1.-ue(3)**2)*cos(phi)
    ue(2) = sqrt(1.-ue(3)**2)*sin(phi)
    Do j = 1, 3
      p(n+il, j) = pa*ue(j)
      pv(il+1, j) = -pa*ue(j)
    End Do
    p(n+il, 4) = sqrt(pa**2+p(n+il,5)**2)
    pv(il+1, 4) = sqrt(pa**2+pv(il+1,5)**2)
  End Do
  Do j = 1, 4
    p(n+nd, j) = pv(nd, j)
  End Do
  Do il = nd - 1, 1, -1
    Do j = 1, 3
      be(j) = pv(il, j)/pv(il, 4)
    End Do
    ga = pv(il, 4)/pv(il, 5)
    Do i = n + il, n + nd
      bep = be(1)*p(i, 1) + be(2)*p(i, 2) + be(3)*p(i, 3)
      Do j = 1, 3
        p(i, j) = p(i, j) + ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
      End Do
      p(i, 4) = ga*(p(i,4)+bep)
    End Do
  End Do
  If (mmat==1) Then
    wt = (p(n+1,5)*p(n+2,5)*p(n+3,5))**2 - (p(n+1,5)*four(n+2,n+3))**2 - (p(n+2,5)*four(n+1,n+3))**2 - (p(n+3,5)*four(n+1,n+2))**2 + 2.*four(n+1, n+2)*four(n+1, n+3)*four(n+2, n+3)
    If (max(wt*wtcor(9)/p(ip,5)**6,0.001)<rlu(0)) Goto 310
  Else If (mmat==2) Then
    four12 = four(n+1, n+2)
    four13 = four(n+1, n+3)
    four23 = 0.5*pmst - 0.25*pmes
    wt = (pmst-0.5*pmes)*(four12**2+four13**2) + pmes*(four12*four13+four12**2+four13**2)
    If (wt<rlu(0)*0.25*pmst*(p(ip,5)**2-pmst)**2) Goto 370
  Else If (mmat==3 .And. nm==2) Then
    If ((p(ip,5)**2*four(im,n+1)-four(ip,im)*four(ip,n+1))**2<=rlu(0)*(four(ip,im)**2-(p(ip,5)*p(im,5))**2)*(four(ip,n+1)**2-(p(ip,5)*p(n+1,5))**2)) Goto 370
  Else If (mmat==4) Then
    hx1 = 2.*four(ip, n+1)/p(ip, 5)**2
    hx2 = 2.*four(ip, n+2)/p(ip, 5)**2
    hx3 = 2.*four(ip, n+3)/p(ip, 5)**2
    wt = ((1.-hx1)/(hx2*hx3))**2 + ((1.-hx2)/(hx1*hx3))**2 + ((1.-hx3)/(hx1*hx2))**2
    If (wt<2.*rlu(0)) Goto 310
    If (k(ip+1,2)==22 .And. (1.-hx1)*p(ip,5)**2<4.*parj(32)**2) Goto 310
  Else If (mmat==41) Then
    hx1 = 2.*four(ip, n+1)/p(ip, 5)**2
    If (8.*hx1*(3.-2.*hx1)/9.<rlu(0)) Goto 310
  Else If (mmat>=42 .And. mmat<=44 .And. nd==3) Then
    If (mbst==0) wt = four(ip, n+1)*four(n+2, n+3)
    If (mbst==1) wt = p(ip, 5)*p(n+1, 4)*four(n+2, n+3)
    If (wt<rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) Goto 310
  Else If (mmat>=42 .And. mmat<=44) Then
    Do j = 1, 4
      p(n+np+1, j) = 0.
      Do is = n + 3, n + np
        p(n+np+1, j) = p(n+np+1, j) + p(is, j)
      End Do
    End Do
    If (mbst==0) wt = four(ip, n+1)*four(n+2, n+np+1)
    If (mbst==1) wt = p(ip, 5)*p(n+1, 4)*four(n+2, n+np+1)
    If (wt<rlu(0)*p(ip,5)*pv(1,5)**3/wtcor(10)) Goto 310
  Else If (mmat==46 .And. msgn/=0) Then
    If (msgn>0) wt = four(im, n+1)*four(n+2, ip+1)
    If (msgn<0) wt = four(im, n+2)*four(n+1, ip+1)
    If (wt<rlu(0)*p(im,5)**4/wtcor(10)) Goto 370
  End If
  If (mrem==1) Then
    Do j = 1, 5
      pv(1, j) = pv(1, j)/(1.-pqt)
    End Do
    nd = nd + 1
    mrem = 0
  End If
  If ((mmat==31 .Or. mmat==45) .And. nd==3) Then
    mstj(93) = 1
    pm2 = ulmass(k(n+2,2))
    mstj(93) = 1
    pm3 = ulmass(k(n+3,2))
    If (p(n+2,5)**2+p(n+3,5)**2+2.*four(n+2,n+3)>=(parj(32)+pm2+pm3)**2) Goto 510
    k(n+2, 1) = 1
    kftemp = k(n+2, 2)
    Call lukfdi(kftemp, k(n+3,2), kfldmp, k(n+2,2))
    If (k(n+2,2)==0) Goto 150
    p(n+2, 5) = ulmass(k(n+2,2))
    ps = p(n+1, 5) + p(n+2, 5)
    pv(2, 5) = p(n+2, 5)
    mmat = 0
    nd = 2
    Goto 370
  Else If (mmat==44) Then
    mstj(93) = 1
    pm3 = ulmass(k(n+3,2))
    mstj(93) = 1
    pm4 = ulmass(k(n+4,2))
    If (p(n+3,5)**2+p(n+4,5)**2+2.*four(n+3,n+4)>=(parj(32)+pm3+pm4)**2) Goto 480
    k(n+3, 1) = 1
    kftemp = k(n+3, 2)
    Call lukfdi(kftemp, k(n+4,2), kfldmp, k(n+3,2))
    If (k(n+3,2)==0) Goto 150
    p(n+3, 5) = ulmass(k(n+3,2))
    Do j = 1, 3
      p(n+3, j) = p(n+3, j) + p(n+4, j)
    End Do
    p(n+3, 4) = sqrt(p(n+3,1)**2+p(n+3,2)**2+p(n+3,3)**2+p(n+3,5)**2)
    ha = p(n+1, 4)**2 - p(n+2, 4)**2
    hb = ha - (p(n+1,5)**2-p(n+2,5)**2)
    hc = (p(n+1,1)-p(n+2,1))**2 + (p(n+1,2)-p(n+2,2))**2 + (p(n+1,3)-p(n+2,3))**2
    hd = (pv(1,4)-p(n+3,4))**2
    he = ha**2 - 2.*hd*(p(n+1,4)**2+p(n+2,4)**2) + hd**2
    hf = hd*hc - hb**2
    hg = hd*hc - ha*hb
    hh = (sqrt(hg**2+he*hf)-hg)/(2.*hf)
    Do j = 1, 3
      pcor = hh*(p(n+1,j)-p(n+2,j))
      p(n+1, j) = p(n+1, j) + pcor
      p(n+2, j) = p(n+2, j) - pcor
    End Do
    p(n+1, 4) = sqrt(p(n+1,1)**2+p(n+1,2)**2+p(n+1,3)**2+p(n+1,5)**2)
    p(n+2, 4) = sqrt(p(n+2,1)**2+p(n+2,2)**2+p(n+2,3)**2+p(n+2,5)**2)
    nd = nd - 1
  End If
  480 If (mmat>=42 .And. mmat<=44 .And. iabs(k(n+1,2))<10) Then
    pmr = sqrt(max(0.,p(n+1,5)**2+p(n+2,5)**2+2.*four(n+1,n+2)))
    mstj(93) = 1
    pm1 = ulmass(k(n+1,2))
    mstj(93) = 1
    pm2 = ulmass(k(n+2,2))
    If (pmr>parj(32)+pm1+pm2) Goto 490
    kfldum = int(1.5+rlu(0))
    Call lukfdi(k(n+1,2), -isign(kfldum,k(n+1,2)), kfldmp, kf1)
    Call lukfdi(k(n+2,2), -isign(kfldum,k(n+2,2)), kfldmp, kf2)
    If (kf1==0 .Or. kf2==0) Goto 150
    psm = ulmass(kf1) + ulmass(kf2)
    If (mmat==42 .And. pmr>parj(64)+psm) Goto 490
    If (mmat>=43 .And. pmr>0.2*parj(32)+psm) Goto 490
    If (nd==4 .Or. kfa==15) Goto 150
    k(n+1, 1) = 1
    kftemp = k(n+1, 2)
    Call lukfdi(kftemp, k(n+2,2), kfldmp, k(n+1,2))
    If (k(n+1,2)==0) Goto 150
    p(n+1, 5) = ulmass(k(n+1,2))
    k(n+2, 2) = k(n+3, 2)
    p(n+2, 5) = p(n+3, 5)
    ps = p(n+1, 5) + p(n+2, 5)
    pv(2, 5) = p(n+3, 5)
    mmat = 0
    nd = 2
    Goto 370
  End If
  490 If (mmat==42 .And. iabs(k(n+1,2))<10) Then
    kflo(1) = k(n+1, 2)
    kflo(2) = k(n+2, 2)
    k(n+1, 1) = k(n+3, 1)
    k(n+1, 2) = k(n+3, 2)
    Do j = 1, 5
      pv(1, j) = p(n+1, j) + p(n+2, j)
      p(n+1, j) = p(n+3, j)
    End Do
    pv(1, 5) = pmr
    n = n + 1
    np = 0
    nq = 2
    ps = 0.
    mstj(93) = 2
    psq = ulmass(kflo(1))
    mstj(93) = 2
    psq = psq + ulmass(kflo(2))
    mmat = 11
    Goto 180
  End If
  510 n = n + nd
  If (mbst==1) Then
    Do j = 1, 3
      be(j) = p(ip, j)/p(ip, 4)
    End Do
    ga = p(ip, 4)/p(ip, 5)
    Do i = nsav + 1, n
      bep = be(1)*p(i, 1) + be(2)*p(i, 2) + be(3)*p(i, 3)
      Do j = 1, 3
        p(i, j) = p(i, j) + ga*(ga*bep/(1.+ga)+p(i,4))*be(j)
      End Do
      p(i, 4) = ga*(p(i,4)+bep)
    End Do
  End If
  Do i = nsav + 1, n
    Do j = 1, 4
      v(i, j) = vdcy(j)
    End Do
    v(i, 5) = 0.
  End Do
  If (mstj(23)>=1 .And. mmat==4 .And. k(nsav+1,2)==21) Then
    k(nsav+1, 1) = 3
    k(nsav+2, 1) = 3
    k(nsav+3, 1) = 3
    k(nsav+1, 4) = mstu(5)*(nsav+2)
    k(nsav+1, 5) = mstu(5)*(nsav+3)
    k(nsav+2, 4) = mstu(5)*(nsav+3)
    k(nsav+2, 5) = mstu(5)*(nsav+1)
    k(nsav+3, 4) = mstu(5)*(nsav+1)
    k(nsav+3, 5) = mstu(5)*(nsav+2)
    mstj(92) = -(nsav+1)
  Else If (mstj(23)>=1 .And. mmat==4) Then
    k(nsav+2, 1) = 3
    k(nsav+3, 1) = 3
    k(nsav+2, 4) = mstu(5)*(nsav+3)
    k(nsav+2, 5) = mstu(5)*(nsav+3)
    k(nsav+3, 4) = mstu(5)*(nsav+2)
    k(nsav+3, 5) = mstu(5)*(nsav+2)
    mstj(92) = nsav + 2
  Else If (mstj(23)>=1 .And. (mmat==32 .Or. mmat==44 .Or. mmat==46) .And. iabs(k(nsav+1,2))<=10 .And. iabs(k(nsav+2,2))<=10) Then
    k(nsav+1, 1) = 3
    k(nsav+2, 1) = 3
    k(nsav+1, 4) = mstu(5)*(nsav+2)
    k(nsav+1, 5) = mstu(5)*(nsav+2)
    k(nsav+2, 4) = mstu(5)*(nsav+1)
    k(nsav+2, 5) = mstu(5)*(nsav+1)
    mstj(92) = nsav + 1
  Else If (mstj(23)>=1 .And. mmat==33 .And. iabs(k(nsav+2,2))==21) Then
    k(nsav+1, 1) = 3
    k(nsav+2, 1) = 3
    k(nsav+3, 1) = 3
    kcp = lucomp(k(nsav+1,2))
    kqp = kchg(kcp, 2)*isign(1, k(nsav+1,2))
    jcon = 4
    If (kqp<0) jcon = 5
    k(nsav+1, jcon) = mstu(5)*(nsav+2)
    k(nsav+2, 9-jcon) = mstu(5)*(nsav+1)
    k(nsav+2, jcon) = mstu(5)*(nsav+3)
    k(nsav+3, 9-jcon) = mstu(5)*(nsav+2)
    mstj(92) = nsav + 1
  Else If (mstj(23)>=1 .And. mmat==33) Then
    k(nsav+1, 1) = 3
    k(nsav+3, 1) = 3
    k(nsav+1, 4) = mstu(5)*(nsav+3)
    k(nsav+1, 5) = mstu(5)*(nsav+3)
    k(nsav+3, 4) = mstu(5)*(nsav+1)
    k(nsav+3, 5) = mstu(5)*(nsav+1)
    mstj(92) = nsav + 1
  End If
  If (k(ip,1)==5) k(ip, 1) = 15
  If (k(ip,1)<=10) k(ip, 1) = 11
  k(ip, 4) = nsav + 1
  k(ip, 5) = n
  Return
End Subroutine ludecy


      SUBROUTINE gpggaa( ihour, min, isec, mils, dlat, dlong, istat )
c****  mils will be 9999 if it's not in the nmea string.
c****  GPGGA decodes a NMEA $GPGGA string that was read via subroutine
c****  rline.  The string must be in rline common buffer because
c****  that's where subroutine getoke expects it.
c
c mod 4 June 2004 - set everything to zero if the first field is empty.
c mod 8 October 2006 - set everything to zero if the lat or long are empty.
c mod 19 June 2007 - Read minutes as REAL*8
c mod 23 Feb 2016 - UW Micro Eel  is bad:
c   $GPGGA,230741.60,3258.8455102,N,11758.7932197,W,1,0?,1.2,5.0,M,-33.6,M,,*58
c         so just return after doing dlong and forget the other things nobody uses
c mod 29 Mar 2016 - Geo Eel might screw up any field, so check every field for proper length
c         and keep track of a delta_lat and delta_long and apply them to the last lat/long
c         if the current lat/long is screwed up.
c                 - add mils
c  $GPGGA,084117.20,3308.8398645,N,11841.9110338,W,1,09,0.9,7.2,M,-34.0,M,,*51
c  $GPGGA,084122.20,3308.8382883,N,11841.9030828,W,1,09,0.9,6.9,M,-34.0,M,,*5B
c  $GPGGA,08412w.20,3308.8367035,N,11841.8953377,W,1,09,0.9,7.2,M,-34.0,M,,*56   BAD timestamp
c  $GPGGA,084132.20,3308.8352674,N,11851.8870243,W,1,09,0.9,7.0,M,-34.0,M,,*53   BAD longitude minute
c  $GPGGA,084137.20,3308.8335151,N,11841.8790745,W,1,09,0.9,6.6,M,-34.0,M,,*52
c
c mod 29 Mar 2016 - change to gpggaa to delete unused arguments and add istat
c         istat = 0 if ok
c               = 1 if not ok - an error occurred
c mod 13 Apr 2016 - detecting bad $GPGGA is uglier than I thought.  Don't try to correct anything
c        until all fields are examined.  i.e. lat may pass being the right length and being a
c        number, but may be bad - the long may not be detected bad.
c
      REAL*8 dlat, dlong, dtemp, dmin
      REAL*8 delta_lat/99999./, delta_long/99999./, last_lat/0/,
     &       last_long/0/
      INTEGER dgps_sec
      CHARACTER*3 dgps_id
      INTEGER ishort/1/
      CHARACTER*82 out
      SAVE

      istat = 0
      CALL getokec( out, n )
      IF( out(1:6) .NE. '$GPGGA' ) THEN
          PRINT *,'  ***  ERROR  ***  Nav string is not $GPGGA',
     &        out(1:n)
          STOP
      ENDIF
c
c     get the timestamp
      CALL getokec( out, n )
      IF( n .LT. 6 ) GOTO 9000
c      READ ( out, '(I2,I2,I2)' ) ihour, min, isec
c      Unfortunately, g77 crashes if the above is bad
      CALL dcode( out(1:1), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          ihour = NINT(areal)
      ELSE
          ihour = 999
          GOTO 10000
      ENDIF
      CALL dcode( out(3:3), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          min = NINT(areal)
      ELSE
          min = 999
          GOTO 10000
      ENDIF
      CALL dcode( out(5:5), 2, areal, jstat )
      IF( jstat .EQ. 2 ) THEN
          isec = NINT(areal)
      ELSE
          isec = 999
          GOTO 10000
      ENDIF
      mils = 9999
c      IF( n .EQ. 9 ) READ ( out, '(7X,I2)' ) mils
      IF( n .EQ. 9 ) THEN
          CALL dcode( out(8:8), 2, areal, jstat )
          IF( jstat .EQ. 2 ) THEN
              mils = NINT(areal)
          ELSE
              mils = 9999
              GOTO 10000
          ENDIF
      ENDIF
c
c     Get the lat
      CALL getokec( out, n )
      IF( n .LT. 9 ) THEN        ! some "old" units didn't have much precision
          IF( delta_lat .EQ. 99999. ) GOTO 9000
c         if lat is bad, long will be too
          GOTO 10000
      ENDIF
      CALL dcode(out, 2, deg, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      ideg = deg
      CALL ddcode(out(3:n), n-2, dmin, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      dlat = DFLOAT(ideg)
      dlat = dlat + dmin / 60.D0
      CALL getokec( out, n )
      IF( n .NE. 1 ) GOTO 10000
      IF( out(1:1) .EQ. 'S' ) dlat = -dlat
c
c     Get the long
      CALL getokec( out, n )
      IF( n .LT. 9 ) THEN        ! some "old" units didn't have much precision
          IF( delta_long .EQ. 99999. ) GOTO 9000
          GOTO 10000
      ENDIF
      CALL dcode(out, 3, deg, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      ideg = deg
      CALL ddcode(out(4:n), n-3, dmin, jstat )
      IF( jstat .NE. 2 ) GOTO 10000    !   2 means successful
      dlong = DFLOAT(ideg)
      dlong = dlong + dmin / 60.D0
      CALL getokec( out, n )
      IF( n .NE. 1 ) GOTO 10000
      IF( out(1:1) .EQ. 'W' ) dlong = -dlong
c
c
c     clean up for the next fix
      IF( last_lat + last_long .NE. 0. ) THEN     ! can only do this on/after second fix
          delta_lat = dlat - last_lat
          delta_long = dlong - last_long
      ENDIF

 9000 CONTINUE
      last_lat = dlat
      last_long = dlong
      RETURN

10000 CONTINUE
      dlat = last_lat + delta_lat
      dlong = last_long + delta_long
      istat = 1
      GOTO 9000

      END


program suma

implicit none
real :: a
real :: b
real :: c

write(*,*) 'Ingrese el valor a: '
read(*,*) a
write(*,*) 'Ingrese el valor b: '
read(*,*) b

c = a + b

write(*,*) 'La suma es: ', c

end program suma


subroutine mkcse(iband,jband,ikk,W, &
& vol,pi,nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom,xred,projwf,nlmn, &
& pwmatel,tpwmatel, &
& kg,kgq,enrgy,enrgyq,cg,cgq,npwt,npwtq,bantot,bantotq,ncg,ncgq, &
& indxkpw,indxkpwq,indxkbnd,indxkbndq,indxkcg,indxkcgq,npwarr,npwarrq, &
& kpt,kptq,nkpt,nkptq,nqpt,nsymk,nsymkq,symk,symkq,nsym,nsymq,symrel,syminv, &
& ihlf,ihlfq,lvtrans,lvtransq,bmet,blat,ipaw, &
& ipwlf,npwlf,ipwndx,npwndx,ntpwndx, &
& npwup,invpw2ndx,pwsymndx,iqsymndx, &
& igmx,igmn,igndx,igndxq,ikndx,ikndxq,iqndx,isymndx,isymndxq,npw,npwq, &
& nband,nbandq,nsppol,shiftk,shiftkq,cse,xse)
implicit none
integer :: iband,jband,ikk(3),nwpt,nbcore,nbocc,ncband,ngkpt(3),natom,nlmn
integer :: igmn(3),igmx(3)
integer :: npwt,npwtq,bantot,bantotq,ncg,ncgq,nkpt,nkptq,nqpt,nsym,nsymq,nsppol
integer :: npw,npwq,ipw1,npwlf,npwndx,ntpwndx,ipaw
double precision :: vol,pi,wmax,xred(3,natom)
double complex :: W(nwpt,nqpt,ntpwndx)
double complex :: projwf(natom,nlmn,nkpt,ncband)
integer :: kg(3,npwt),kgq(3,npwtq)
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)
double precision :: bmet(3,3),blat(3,3)
integer :: ipwlf(3,npwlf),ipwndx(2,ntpwndx)
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 :: iqndx(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 :: sei,seipw,seiold,seibc,csepw,cseold,csebc
double complex :: ssi(nwpt),ssc(nwpt),sec(nwpt),xse1,xse2,cse(nbcore+1:ncband),cse1(nbcore+1:ncband),zz(nbcore+1:ncband),zz1(nbcore+1:ncband),ctest
double precision :: xse
integer :: ii,jj,kk,ix,iy,iz,iskip,isign,iloss
integer :: iqq(3),iqqp(3),jka(3),jkk(3),ikks(3)
integer :: ikpt,ikptq,iks(3),ikslf1(3),ikslf2(3)
integer :: igg(3),igh(3),igg0(3),icenter,isym,isymq,ibp,iqpt,iqsym,iw,ie,je,ies
double precision :: xck(3),xckq(3)
double complex :: cmatel,cmatel2,amatel,amatel2,vqmat2(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: vfactor(ngkpt(1),ngkpt(2),ngkpt(3)),vfv(8),lossv(8)
double precision :: vq2(8)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,wwhi,wwlo,ww,enval(8),dw,eshift
double precision :: abr,rlr
double complex :: tseincr,tseincrx,dse,dcse
integer :: iwh,iwl,ibmin,ibmax,ioff,ioff2
double precision :: vq(ngkpt(1),ngkpt(2),ngkpt(3)),qq(3),qp(3),qq2,qp2,qs(3),xk(3),xkmq(3),ek,ekmq
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),temparray(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: npwup,iipw,jjpw
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwup,npwup)
integer :: pwsymndx(npwup,2*nsym)
integer :: ipw2,jw
double precision :: eps1(nbcore+1:ncband),eps2,eps
double precision :: eval,brd,esprd
double precision :: gfo,gamma(3),pln(3),dist(3)
double complex :: wint(nbcore+1:ncband),wint0(nbcore+1:ncband)
double complex :: w2int(nbcore+1:ncband),w2int0(nbcore+1:ncband)
double complex :: cmgamma2,gterm
double complex :: pwmatel(nlmn,nlmn,npwup,ngkpt(1),ngkpt(2),ngkpt(3)), &
&                tpwmatel(nlmn,nlmn,npwup,ngkpt(1),ngkpt(2),ngkpt(3))
integer :: iqsing
integer :: idum
logical :: lx,lc
double precision :: xdum
double precision :: linterp
external linterp

abr=1.d-6
rlr=1.d-6
sei=0.d0
xse=(0.d0,0.d0)
ctest=(0.d0,0.d0)
cse=(0.d0,0.d0)
zz=(0.d0,0.d0)
igg0=(/0,0,0/)
do ie=1,nwpt
  sec(ie)=(0.d0,0.d0)
enddo
dw=wmax/dble(nwpt)
ikpt=ikndx(ikk(1),ikk(2),ikk(3))
!isym=isymndx(ikk(1),ikk(2),ikk(3))
isym=1 ! symtest
ek=enrgy(indxkbnd(ikpt)+iband)

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
ikks=(/0,0,0/)   ! symtest
do ii=1,3   ! symtest
do jj=1,3   ! symtest
  ikks(jj)=ikks(jj)+(ikk(ii)-ngkpt(ii)/2)*symrel(ii,jj,isym)   ! symtest
enddo   ! symtest
enddo   ! symtest
ikks=ikks+ngkpt/2   ! symtest
!write(6,*) 'ikk = ',ikk
!write(6,*) 'ikks = ',ikks

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)/norm2(pln)
enddo
gfo=minval(dist)

!write(6,'(a)') '      finding contibutions from band:      plane waves:'
do ibp=nbcore+1,ncband
!do ibp=1,1
  seibc=sei
  if (ibp.gt.nbocc) then
    isign=-1
  else
    isign=1
  endif
  if (ibp.ge.ibmin.and.ibp.le.ibmax) then
    iloss=1
  else
    iloss=0
  endif
!  do iipw=1,ntpwndx
  do iipw=1,1
!  do iipw=2,48,46
!  do iipw=2,2
!  do iipw=55,55
!    write(6,'(a,i4)') 'iipw ',iipw
!    write(6,'(38x,i3,14x,2i3)') ibp,ipw1,ipw2
    seipw=sei
    ipw1=ipwndx(1,iipw)
    ipw2=ipwndx(2,iipw)
    if (ipw1.ne.ipw2) cycle
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do iy=2,2
!    do ix=3,3
!    do iz=4,4
      iqq=(/ix,iy,iz/)
      do ii=1,3
        iks(ii)=iqq(ii)-ngkpt(ii)/2
        ikslf1(ii)=iks(ii)+ipwlf(ii,ipw1)*ngkpt(ii)
        ikslf2(ii)=iks(ii)+ipwlf(ii,ipw2)*ngkpt(ii)
      enddo
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call fqq(shiftk,shiftkq,ikslf1,ngkpt,qq,qs)
        call fqq(shiftk,shiftkq,ikslf2,ngkpt,qp,qs)
      else
        call fqq(shiftk,shiftk,ikslf1,ngkpt,qq,qs)
        call fqq(shiftk,shiftk,ikslf2,ngkpt,qp,qs)
      endif
      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,*) '>>>>> iqq = ',iqq
!write(6,*) 'ikslf1 = ',ikslf1
!write(6,*) 'ikslf2 = ',ikslf2
!write(6,'(a,3f10.6)') ' qq = ',qq
!write(6,'(a,3f10.6)') ' qp = ',qp
!write(6,*) 'qq2 = ',qq2
!write(6,*) 'qp2 = ',qp2
!write(6,*) 'vq = ',vq(ix,iy,iz)
      do ii=1,3
!        jka(ii)=ikk(ii)-iks(ii)
        jka(ii)=ikks(ii)-iks(ii)  ! symtest
        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))
        igh(ii)=nint(xckq(ii)-xck(ii)+qp(ii))
      enddo
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        ikptq=ikndxq(jkk(1),jkk(2),jkk(3))
        isymq=isymndxq(jkk(1),jkk(2),jkk(3))
      else
        ikptq=ikndx(jkk(1),jkk(2),jkk(3))
        isymq=isymndx(jkk(1),jkk(2),jkk(3))
      endif
!write(6,*) 'jka = ',jka
!write(6,*) 'jkk = ',jkk
!write(6,'(a,3f10.6)') ' xck = ',xck
!write(6,'(a,3f10.6)') ' xckq = ',xckq
!write(6,*) 'igg = ',igg
!write(6,*) 'igh = ',igh
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call mkmatelS(ibp,iband,ikpt,ikptq,ipwlf(:,ipw1),igg, &
&         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, &
&         cmatel)
        if (ipaw.ne.0) then
!          call mkmatelP(pi,xred,natom,ibp,iband,ikpt,ikptq,qq,igg0,ngkpt, &
!&               pwmatel(:,:,ipw1,ix,iy,iz),tpwmatel(:,:,ipw1,ix,iy,iz), &
!&               projwf,nlmn,nkpt,nkptq,ncband,amatel)
        else
          amatel=(0.d0,0.d0)
        endif
        if (ipw1.eq.ipw2.and.iband.eq.jband) then
          cmatel2=cmatel
          amatel2=amatel
        else
          call mkmatelS(ibp,jband,ikpt,ikptq,ipwlf(:,ipw2),igh, &
&         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)
          if (ipaw.ne.0) then
!            call mkmatelP(pi,xred,natom,ibp,jband,ikpt,ikptq,qp,igg0,ngkpt, &
!&                 pwmatel(:,:,ipw2,ix,iy,iz),tpwmatel(:,:,ipw2,ix,iy,iz), &
!&                 projwf,nlmn,nkpt,nkptq,ncband,amatel2)
          else
            amatel2=(0.d0,0.d0)
          endif
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-enrgyq(indxkbndq(ikptq)+ibp)
        else
          omega(ix,iy,iz)=enrgyq(indxkbndq(ikptq)+ibp)
        endif
      else
        call mkmatelS(ibp,iband,ikpt,ikptq,ipwlf(:,ipw1),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,ibp,iband,ikpt,ikptq,qq,igg0,ngkpt, &
!&               pwmatel(:,:,ipw1,ix,iy,iz),tpwmatel(:,:,ipw1,ix,iy,iz), &
!&               projwf,nlmn,nkpt,nkpt,ncband,amatel)
        else
          amatel=(0.d0,0.d0)
        endif
        if (ipw1.eq.ipw2.and.iband.eq.jband) then
          cmatel2=cmatel
          amatel2=amatel
        else
          call mkmatelS(ibp,jband,ikpt,ikptq,ipwlf(:,ipw2),igh, &
&         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, &
&         cmatel2)
          if (ipaw.ne.0) then
!            call mkmatelP(pi,xred,natom,ibp,jband,ikpt,ikptq,qp,igg0,ngkpt, &
!&                 pwmatel(:,:,ipw2,ix,iy,iz),tpwmatel(:,:,ipw2,ix,iy,iz), &
!&                 projwf,nlmn,nkpt,nkpt,ncband,amatel2)
          else
            amatel2=(0.d0,0.d0)
          endif
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-enrgy(indxkbnd(ikptq)+ibp)
        else
          omega(ix,iy,iz)=enrgy(indxkbnd(ikptq)+ibp)
        endif
      endif
      vqmat2(ix,iy,iz)=(cmatel+amatel)*conjg(cmatel2+amatel2)*vq(ix,iy,iz)
      if (ix.eq.ngkpt(1)/2.and.iy.eq.ngkpt(2)/2.and.iz.eq.ngkpt(3)/2) then
        cmgamma2=(cmatel+amatel)*conjg(cmatel2+amatel2)
      endif
!write(6,*) 'cmatel  = ',cmatel
!write(6,*) 'cmatel2 = ',cmatel2
!write(6,*) '|cmatel+amatel|^2 = ',(cmatel+amatel)*conjg(cmatel2+amatel2)
!write(6,*) 'vqmat2 = ',vqmat2(iqq(1),iqq(2),iqq(3))
!write(56,*) '>>>>>',iqq,vqmat2(iqq(1),iqq(2),iqq(3))
!      stvec(iqq(3))=vq(ix,iy,iz)
!      stvec(iqq(3))=sqrt(qq2)
      stvec(iqq(3))=dble(vqmat2(iqq(1),iqq(2),iqq(3)))
!      stvec2(iqq(3))=dimag(vqmat2(iqq(1),iqq(2),iqq(3)))
!      stvec(iqq(3))=dble(cmatel)
!      stvec2(iqq(3))=dimag(cmatel)
!      stvec(iqq(3))=dble(cmatel2)
!      stvec2(iqq(3))=dimag(cmatel2)
!      stvec(iqq(3))=dble(cmatel*conjg(cmatel))
      temparray(ix,iy,iz)=stvec(iqq(3))
    enddo
!    write(76,'(10f8.2)') stvec(:)
!    write(76,'(10es8.1)') stvec(:)
!    write(76,'(10es8.1)') stvec2(:)
!    write(76,*)
    enddo
!    write(76,*) iqq(1)+1,'--------------------------------------------------',ibp
    enddo
!stop
! Cut material for testing energy dependence of self energy at bottom of file

    lx=ipw1.eq.ipw2.and.ibp.le.nbocc
    if (lx) xse1=(0.d0,0.d0)
    do ie=nbcore+1,ncband
      cse1(ie)=(0.d0,0.d0)
      eps=enrgy(indxkbnd(ikpt)+ie)
      if (ibp.gt.nbocc) then
        eps1(ie)=eps
      else
        eps1(ie)=-eps
      endif
    enddo
    brd=dw
!write(6,*) brd*27.2114
    if (abs(vqmat2(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2)/vqmat2(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2-1)).gt.1.d3 &
&   .and.(ipw1.eq.1.or.ipw2.eq.1)) then
      iqsing=1
      iqq=(/ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2/)
      iqpt=iqndx(iqq(1),iqq(2),iqq(3))
!      call fespread(iqq,ngkpt,omega,esprd)
!      brd=max(esprd,dw)
      call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
      do ie=nbcore+1,ncband
        wint0(ie)=(0.d0,0.d0)
        if (jjpw.ne.0) then
          do iw=1,nwpt
            ww=iw*dw
            eval=omega(iqq(1),iqq(2),iqq(3))+eps1(ie)-ww
            wint0(ie)=wint0(ie)+dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)
            w2int0(ie)=w2int0(ie)-dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)**2
          enddo
        endif
      enddo
    else
      iqsing=0
    endif
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
      iqq=(/ix,iy,iz/)
      xse2=xse1
      iqpt=iqndx(ix,iy,iz)
!      call fespread(iqq,ngkpt,omega,esprd)
!      brd=max(esprd,dw)
!write(6,'(3i3,es20.10)') ix,iy,iz,esprd*27.2114
      call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
      do ie=nbcore+1,ncband
        wint(ie)=(0.d0,0.d0)
        w2int(ie)=(0.d0,0.d0)
        if (jjpw.ne.0) then
          do iw=1,nwpt
            ww=iw*dw
            eval=omega(ix,iy,iz)+eps1(ie)-ww
            wint(ie)=wint(ie)+dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)
            w2int(ie)=w2int(ie)-dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)**2
          enddo
        endif
      enddo
      if (iqsing.eq.0) then
        if (lx) xse1=xse1+vqmat2(ix,iy,iz)
        cse1=cse1+wint*vqmat2(ix,iy,iz)
        zz1=zz1+w2int*vqmat2(ix,iy,iz)
      else
        qq2=4.d0*pi/vq(ix,iy,iz)
        if (sqrt(qq2).lt.gfo) then
          if (ix.eq.ngkpt(1)/2.and.iy.eq.ngkpt(2)/2.and.iz.eq.ngkpt(3)/2) cycle
          gterm=cmgamma2*(1+cos(pi*sqrt(qq2)/gfo))/(2.d0)
          if (lx) xse1=xse1+vqmat2(ix,iy,iz)-gterm*vq(ix,iy,iz)
          cse1=cse1+wint*vqmat2(ix,iy,iz)-wint0*gterm*vq(ix,iy,iz)
          zz1=zz1+w2int*vqmat2(ix,iy,iz)-w2int0*gterm*vq(ix,iy,iz)
!write(6,'(3i3,2f12.6)') ix,iy,iz,(wint*vqmat2(ix,iy,iz)-wint0*gterm*vq(ix,iy,iz))/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
!write(21,'(3i3,2f14.2,4x,2f14.2)') ix,iy,iz,wint*vqmat2(ix,iy,iz),wint0*gterm*vq(ix,iy,iz)
!write(22,'(3i3,2f14.2,4x,2f14.2)') ix,iy,iz,vqmat2(ix,iy,iz),gterm*vq(ix,iy,iz)
!write(23,'(3i3,2f14.2,4x,2f14.2)') ix,iy,iz,wint,wint0
        else
          if (lx) xse1=xse1+vqmat2(ix,iy,iz)
          cse1=cse1+wint*vqmat2(ix,iy,iz)
          zz1=zz1+w2int*vqmat2(ix,iy,iz)
!write(6,'(3i3,2f12.6)') ix,iy,iz,wint*vqmat2(ix,iy,iz)/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
        endif
      endif
!      temparray(ix,iy,iz)=(xse1-xse2)/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
    enddo
    enddo
    enddo
    if (lx) xse1=xse1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
    cse1=cse1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    zz1=zz1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    if (iqsing.eq.1) then
! 1/pi Integral (d^3q/(2 pi)^3) wint0 gterm vq
      if (lx) xse1=xse1+cmgamma2*8.d0*pi*pi*gfo/((2.d0*pi)**3)
      cse1=cse1+wint0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
      zz1=zz1+w2int0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
!write(6,*) wint0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
!write(6,*) cmgamma2
!write(6,*) wint0
    endif
    xse1=-xse1
    cse1=-cse1*isign
    zz1=-zz1*isign
    if (lx) xse=xse+dble(xse1)
!    if (lx) ctest=ctest+xse1
    cse=cse+cse1
    zz=zz+zz1
!if (lx) then
!  write(6,'(i4,4x,2i3,5x,"(",f10.6,",",f10.6,")",5x,f10.6)') ibp,ipw1,ipw2,cse1*27.2114,dble(xse1)*27.2114
!else
!  write(6,'(i4,4x,2i3,5x,"(",f10.6,",",f10.6,")")') ibp,ipw1,ipw2,cse1*27.2114
!endif
!write(6,'("(",f10.6,",",f10.6,")")') cse1*27.2114
!if (lx) write(6,'(f10.6)') dble(xse1)*27.2114
!write(6,*) ioff2-ioff
!write(6,*) cse
!write(6,*) (ssi(ioff2-ioff)+ssi(ioff2-ioff-1))/2.d0
!write(6,*) zz
!write(6,*) (ssi(ioff2-ioff)-ssi(ioff2-ioff-1))/dw

  enddo
!  write(68,'(2i3,2f10.3)') iband,ibp,(sei-seibc)*27.2114,sei*27.2114
enddo

do ie=1,nwpt
  eps1=ek+dble(ie-nwpt/2)*dw+dw/2.d0
!  write(69,'(i4,f10.3,2(3x,2es12.3))') ie,eps1*27.2114,sec(ie)*27.2114
enddo
!cse=(0.d0,1.d0)*sei

zz=1.d0/(1.d0-zz)
!cse=zz*cse
!write(6,*) cse*27.2114
!write(6,*) xse*27.2114
!write(6,*) zz

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 mkcse

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

subroutine fek(xk,bmet,ek)
! Finds the kinetic energy of a plane wave
implicit none
double precision :: xk(3),bmet(3,3)
double precision :: ek
integer ii,jj

ek=0.d0
do ii=1,3
do jj=1,3
  ek=ek+xk(ii)*bmet(ii,jj)*xk(jj)
enddo
enddo
ek=ek/2.d0

return
end subroutine fek

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

subroutine fcenter(iqq,ngkpt,icenter)
implicit none
integer :: iqq(3),ngkpt(3),icenter
integer :: ii

icenter=1
do ii=1,3
  if (iqq(ii).ne.ngkpt(ii)/2.and.iqq(ii)+1.ne.ngkpt(ii)/2) icenter=0
enddo

return
end subroutine fcenter

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

subroutine fespread(iqq,ngkpt,omega,esprd)
implicit none
integer :: iqq(3),ngkpt(3)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3)),esprd
integer :: ix,iy,iz,iqp(3)
double precision :: e1,e0

e0=omega(iqq(1),iqq(2),iqq(3))
!write(6,'(3i3,3x,3i3)') iqq
esprd=0.d0
do ix=-1,1
do iy=-1,1
do iz=-1,1
  iqp=mod(iqq+(/ix,iy,iz/)-1+ngkpt,ngkpt)+1
  e1=omega(iqp(1),iqp(2),iqp(3))
  esprd=max(esprd,abs(e1-e0))
!write(6,'(3i3,3x,3i3,3x,2f10.3)') ix,iy,iz,iqp,e1*27.2114,abs(e1-e0)*27.2114
enddo
enddo
enddo

return
end subroutine fespread

!**************************************************************************
! cut material from mkcse for testing energy dependence of self energy

!    do ix=1,ngkpt(1)
!    do iy=1,ngkpt(2)
!    do iz=1,ngkpt(3)
!      iqq=(/ix,iy,iz/)
!      call fhilo(omega,iqq,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
!    if (ibp.gt.nbocc) then
!      ioff=nint(-wwlo*dble(nwpt)/wmax)
!    else
!      ioff=nint(wwhi*dble(nwpt)/wmax)-nwpt
!    endif
!    ioff2=nint(ek*dble(nwpt)/wmax)
!    do ie=1,nwpt
!      eps=(ie+ioff-ioff2)*dw+ek+dw/2.d0
!      ssi(ie)=(0.d0,0.d0)
!!IF (.TRUE.) THEN
!IF (.FALSE.) THEN
!      if (ibp.gt.nbocc) then
!        iwh=nint((eps+wwhi)*dble(nwpt)/wmax)
!        iwl=nint((eps+wwlo)*dble(nwpt)/wmax)
!      else
!        iwh=nint((wwhi-eps)*dble(nwpt)/wmax)
!        iwl=nint((wwlo-eps)*dble(nwpt)/wmax)
!      endif
!      do iw=max(iwl,1),min(iwh,nwpt)
!        if (ibp.gt.nbocc) then
!          ww=iw*dw-eps
!        else
!          ww=iw*dw+eps
!        endif
!!        write(6,*) ie,iw,ww*27.2114
!        do ix=1,ngkpt(1)
!        do iy=1,ngkpt(2)
!        do iz=1,ngkpt(3)
!          iqq=(/ix,iy,iz/)
!          iqpt=iqndx(iqq(1),iqq(2),iqq(3))
!          call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
!          if (jjpw.ne.0) then
!            vfactor(iqq(1),iqq(2),iqq(3))=vqmat2(iqq(1),iqq(2),iqq(3))*dimag(W(iw,iqpt,jjpw))
!          else
!            vfactor(iqq(1),iqq(2),iqq(3))=(0.d0,0.d0)
!          endif
!!          stvec(iqq(3))=dble(vfactor(iqq(1),iqq(2),iqq(3)))
!!          stvec2(iqq(3))=dimag(vfactor(iqq(1),iqq(2),iqq(3)))
!!          stvec(iqq(3))=dimag(W(iw,iqpt,jjpw))
!!          stvec(iqq(3))=dble(iqpt)
!!          stvec2(iqq(3))=dble(jjpw)
!        enddo
!!        write(77,'(10es8.1)') stvec(:)
!!        write(77,'(10es8.1)') stvec2(:)
!!        write(77,'(10i8)') nint(stvec(:))
!!        write(77,'(10i8)') nint(stvec2(:))
!!        write(77,*)
!        enddo
!!        write(77,*) iqq(1)+1,'--------------------------------------------------',ibp
!        enddo
!        seiold=sei
!        do ix=1,ngkpt(1)
!        do iy=1,ngkpt(2)
!        do iz=1,ngkpt(3)
!          iqq=(/ix,iy,iz/)
!          call fval(omega,iqq,iqqp,ngkpt,enval)
!          call fpol(vfactor,ngkpt,iqq,iqqp,vfv)
!!          write(42,*) '>>>>',iqq,ww
!!          write(42,*)
!!          write(42,'(2es12.3,2(4x,2es12.3))') enval(1:2),dble(vfv(1:2)),dimag(vfv(1:2))
!!          write(42,'(2es12.3,2(4x,2es12.3))') enval(3:4),dble(vfv(3:4)),dimag(vfv(3:4))
!!          write(42,*)
!!          write(42,'(2es12.3,2(4x,2es12.3))') enval(5:6),dble(vfv(5:6)),dimag(vfv(5:6))
!!          write(42,'(2es12.3,2(4x,2es12.3))') enval(7:8),dble(vfv(7:8)),dimag(vfv(7:8))
!!          write(42,*)
!          call cubeint(enval,ww,vfv,tseincr)
!!          write(42,*) tseincr
!          call fcenter(iqq,ngkpt,icenter)
!          if (abs(tseincr).ne.0.d0.and.icenter.ne.0 &
!&   .and.(ipw1.eq.1.or.ipw2.eq.1)) then
!            rlr=1.d-2
!            abr=1.d-2
!!            write(42,*) '>>>>',iqq,ww
!!            write(6,*) tseincr
!            call fvq2(iqq,shiftk,shiftkq,bmet,ngkpt,ipw1,ipw2,ipwlf,npwlf,vq2)
!!            write(42,*)
!!            write(42,'(2es12.3,5x,2es12.3)') vq2(1:2),dble(vfv(1:2))
!!            write(42,'(2es12.3,5x,2es12.3)') vq2(3:4),dble(vfv(3:4))
!!            write(42,*)
!!            write(42,'(2es12.3,5x,2es12.3)') vq2(5:6),dble(vfv(5:6))
!!            write(42,'(2es12.3,5x,2es12.3)') vq2(7:8),dble(vfv(7:8))
!!            write(42,*)
!            if (ipw1.ge.ipw2) then
!              lossv=vfv*vq2/(4.d0*pi)
!              call subint2(iqq,shiftk,shiftkq,lossv,enval,ww,iw,bmet,iqndx,ngkpt,nwpt,nqpt,ikndxq,vol,ipw1,ipw2,ipwlf,npwlf,pi,rlr,abr,tseincr)
!            else
!              lossv=-conjg(vfv)*vq2/(4.d0*pi)
!              tseincrx=-conjg(tseincr)
!              call subint2(iqq,shiftk,shiftkq,lossv,enval,ww,iw,bmet,iqndx,ngkpt,nwpt,nqpt,ikndxq,vol,ipw1,ipw2,ipwlf,npwlf,pi,rlr,abr,tseincrx)
!              tseincr=-conjg(tseincrx)
!            endif
!!            write(6,*) tseincr
!          endif
!!          write(42,*) tseincr
!          dse=tseincr/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
!          ssi(ie)=ssi(ie)+dse*dw*isign/pi
!!          write(66,'(3i4,5x,es10.3)') iqq,dse
!!          write(66,'(3i4,5x,f20.6)') iqq,dble(dse)*27.2114
!!          write(66,'(3i4,a)') iqq,'-----------------------------------------------'
!!          write(66,'(es10.3,5x,2es10.3)') ww,dse
!!          write(66,*)
!!          write(66,'(2es10.3,5x,2es10.3)') dble(vfv(1)),dble(vfv(2)),enval(1:2)-ww
!!          write(66,'(2es10.3,5x,2es10.3)') dble(vfv(3)),dble(vfv(4)),enval(3:4)-ww
!!          write(66,*)
!!          write(66,'(2es10.3,5x,2es10.3)') dble(vfv(5)),dble(vfv(6)),enval(5:6)-ww
!!          write(66,'(2es10.3,5x,2es10.3)') dble(vfv(7)),dble(vfv(8)),enval(7:8)-ww
!!          write(42,*) ssi(iw)
!!          stvec(iqq(3))=dble(tseincr)
!!          stvec2(iqq(3))=dimag(tseincr)
!!          stvec(iqq(3))=dble(icenter)
!        enddo
!!        write(78,'(10es8.1)') stvec(:)
!!        write(78,'(10es8.1)') stvec2(:)
!!        write(78,*)
!!        write(78,'(10i4)') nint(stvec(:))
!        enddo
!!        write(78,*) iqq(1)+1,'--------------------------------------------------',ibp
!        enddo
!      enddo
!ELSE
!      brd=dw
!      if (ibp.gt.nbocc) then
!        eps1=eps
!      else
!        eps1=-eps
!      endif
!      if (abs(vqmat2(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2)/vqmat2(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2-1)).gt.1.d3 &
!&     .and.(ipw1.eq.1.or.ipw2.eq.1)) then
!        iqsing=1
!        iqpt=iqndx(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2)
!        call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
!        wint0=(0.d0,0.d0)
!        if (jjpw.ne.0) then
!          do iw=1,nwpt
!            ww=iw*dw
!            eval=omega(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2)+eps1-ww
!            wint0=wint0+dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)
!          enddo
!        endif
!!        ssi(ie)=ssi(ie)+wint0*cmgamma2*gfo/pi
!!        ssi(ie)=ssi(ie)+wint0*cmgamma2*4.d0*pi*gfo**3*(1.d0/6.d0-1.d0/(pi**2))
!      else
!        iqsing=0
!      endif
!      do ix=1,ngkpt(1)
!      do iy=1,ngkpt(2)
!      do iz=1,ngkpt(3)
!        iqq=(/ix,iy,iz/)
!        iqpt=iqndx(ix,iy,iz)
!        wint=(0.d0,0.d0)
!        call locateelement(iqq,ipw1,ipw2,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
!        if (jjpw.eq.0) cycle
!        do iw=1,nwpt
!          ww=iw*dw
!          eval=omega(ix,iy,iz)+eps1-ww
!          wint=wint+dw*dimag(W(iw,iqpt,jjpw))/(eval,brd)
!        enddo
!        if (iqsing.eq.0) then
!          ssi(ie)=ssi(ie)+wint*vqmat2(ix,iy,iz)
!        else
!          qq2=4.d0*pi/vq(ix,iy,iz)
!          if (sqrt(qq2).lt.gfo) then
!            gterm=cmgamma2*(1+cos(pi*sqrt(qq2)/gfo))/(2.d0)
!            ssi(ie)=ssi(ie)+(wint*vqmat2(ix,iy,iz)/vq(ix,iy,iz)-wint0*gterm)*vq(ix,iy,iz)
!          else
!            gterm=0.d0
!            ssi(ie)=ssi(ie)+wint*vqmat2(ix,iy,iz)
!          endif
!        endif
!      enddo
!      enddo
!      enddo
!      ssi(ie)=ssi(ie)/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
!      if (iqsing.eq.1) then
!! 1/pi Integral (d^3q/(2 pi)^3) wint0 gterm vq
!        ssi(ie)=ssi(ie)+wint0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
!      endif
!ENDIF
!    enddo
!
!    do ie=1,nwpt
!!      eps1=ek+dble(ie-nwpt/2)*dw+dw/2.d0
!!      ssc(ie)=(0.d0,0.d0)
!!      do je=1,nwpt
!!        if (ie.eq.(je+ioff-ioff2+nwpt/2)) then
!!          ssc(ie)=ssc(ie)-(0.d0,pi)*ssi(je)
!!        else
!!          eps2=dble(je+ioff-ioff2)*dw+ek+dw/2.d0
!!          ssc(ie)=ssc(ie)+ssi(je)*dw/(eps2-eps1)
!!        endif
!!write(6,'(2i4,2f10.3,es12.3,2(2x,2es11.3))') ie,je,eps1*27.2114,eps2*27.2114,1/(eps2-eps1),ssc(ie)*27.2114,dble(ssi(je)*27.2114)
!!      enddo
!!      write(69,'(i4,f10.3,2(3x,2es12.3))') ie,eps1*27.2114,ssc(ie)*27.2114,ssi(ie)*27.2114
!      sec(ie)=sec(ie)+ssi(ie)
!    enddo


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...PYSIGH
C...Differential matrix elements for all included subprocesses
C...Note that what is coded is (disregarding the COMFAC factor)
C...1) for 2 -> 1 processes: s-hat/pi*d(sigma-hat), where,
C...when d(sigma-hat) is given in the zero-width limit, the delta
C...function in tau is replaced by a (modified) Breit-Wigner:
C...1/pi*s*H_res/((s*tau-m_res^2)^2+H_res^2),
C...where H_res = s-hat/m_res*Gamma_res(s-hat);
C...2) for 2 -> 2 processes: (s-hat)**2/pi*d(sigma-hat)/d(t-hat);
C...i.e., dimensionless quantities
C...3) for 2 -> 3 processes: abs(M)^2, where the total cross-section is
C...Integral abs(M)^2/(2shat') * (prod_(i=1)^3 d^3p_i/((2pi)^3*2E_i)) *
C...(2pi)^4 delta^4(P - sum p_i)
C...COMFAC contains the factor pi/s (or equivalent) and
C...the conversion factor from GeV^-2 to mb

      SUBROUTINE PYSIGH(NCHN,SIGS)

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...Commonblocks
      include 'inc/pyjets'
      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/pyssmt'
      include 'inc/pytcsm'
      include 'inc/pypued'
      include 'inc/pysgcm'
      include 'inc/pytcco'

C...Local arrays and complex variables
      DIMENSION XPQ(-25:25)

C...Map of processes onto which routine to call
C...in order to evaluate cross section:
C...0 = not implemented;
C...1 = standard QCD (including photons);
C...2 = heavy flavours;
C...3 = W/Z;
C...4 = Higgs (2 doublets; including longitudinal W/Z scattering);
C...5 = SUSY;
C...6 = Technicolor;
C...7 = exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
C...8 = Universal Extra Dimensions
      DIMENSION MAPPR(500)
      DATA (MAPPR(I),I=1,180)/
     &    3,  3,  4,  0,  4,  0,  0,  4,  0,  1,
     1    1,  1,  1,  1,  3,  3,  0,  1,  3,  3,
     2    0,  3,  3,  4,  3,  4,  0,  1,  1,  3,
     3    3,  4,  1,  1,  3,  3,  0,  0,  0,  0,
     4    0,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     5    0,  0,  1,  1,  0,  0,  0,  1,  0,  0,
     6    0,  0,  0,  0,  0,  0,  0,  1,  3,  3,
     7    4,  4,  4,  0,  0,  4,  4,  0,  0,  1,
     8    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     9    1,  1,  1,  1,  1,  1,  0,  0,  1,  0,
     &    0,  4,  4,  2,  2,  2,  2,  2,  0,  4,
     1    4,  4,  4,  1,  1,  0,  0,  0,  0,  0,
     2    4,  4,  4,  4,  0,  0,  0,  0,  0,  0,
     3    1,  1,  1,  1,  1,  1,  1,  1,  1,  1,
     4    7,  7,  4,  7,  7,  7,  7,  7,  6,  0,
     5    4,  4,  4,  0,  0,  4,  4,  4,  0,  0,
     6    4,  7,  7,  7,  6,  6,  7,  7,  7,  0,
     7    4,  4,  4,  4,  0,  4,  4,  4,  4,  0/
      DATA (MAPPR(I),I=181,500)/
     8    4,  4,  4,  4,  4,  4,  4,  4,  4,  4,
     9    6,  6,  6,  6,  6,  0,  0,  0,  0,  0,
     &    100*5,
     &    5,  0,  0,  0,  0,  0,  0,  0,  0,  0,
     &    8,  8,  8,  8,  8,  8,  8,  8,  8,  0,
     1    20*0,
     4    7,  7,  7,  7,  7,  7,  7,  7,  7,  7,
     5    7,  7,  7,  7,  0,  0,  0,  0,  0,  0,
     6    6,  6,  6,  6,  6,  6,  6,  6,  0,  6,
     7    6,  6,  6,  6,  6,  6,  6,  6,  6,  6,
     8    6,  6,  6,  6,  6,  6,  6,  6,  0,  0,
     9    7,  7,  7,  7,  7,  0,  0,  0,  0,  0,
     &    4,  4,  18*0,
     2    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
     3    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     4     20*0,
     6    2,  2,  2,  2,  2,  2,  2,  2,  2,  2,
     7    2,  2,  2,  2,  2,  2,  2,  2,  2,  0,
     8    7,  7,  18*0/

C...Reset number of channels and cross-section
      NCHN=0
      SIGS=0D0

C...Read process to consider.
      ISUB=MINT(1)
      ISUBSV=ISUB
      MAP=MAPPR(ISUB)

C...Read kinematical variables and limits
      ISTSB=ISET(ISUBSV)
      TAUMIN=VINT(11)
      YSTMIN=VINT(12)
      CTNMIN=VINT(13)
      CTPMIN=VINT(14)
      TAUPMN=VINT(16)
      TAU=VINT(21)
      YST=VINT(22)
      CTH=VINT(23)
      XT2=VINT(25)
      TAUP=VINT(26)
      TAUMAX=VINT(31)
      YSTMAX=VINT(32)
      CTNMAX=VINT(33)
      CTPMAX=VINT(34)
      TAUPMX=VINT(36)

C...Derive kinematical quantities
      TAUE=TAU
      IF(ISTSB.GE.3.AND.ISTSB.LE.5) TAUE=TAUP
      X(1)=SQRT(TAUE)*EXP(YST)
      X(2)=SQRT(TAUE)*EXP(-YST)
      IF(MINT(45).EQ.2.AND.ISTSB.GE.1) THEN
        IF(X(1).GT.1D0-1D-7) RETURN
      ELSEIF(MINT(45).EQ.3) THEN
        X(1)=MIN(1D0-1.1D-10,X(1))
      ENDIF
      IF(MINT(46).EQ.2.AND.ISTSB.GE.1) THEN
        IF(X(2).GT.1D0-1D-7) RETURN
      ELSEIF(MINT(46).EQ.3) THEN
        X(2)=MIN(1D0-1.1D-10,X(2))
      ENDIF
      SH=MAX(1D0,TAU*VINT(2))
      SQM3=VINT(63)
      SQM4=VINT(64)
      RM3=SQM3/SH
      RM4=SQM4/SH
      BE34=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4))
      RPTS=4D0*VINT(71)**2/SH
      BE34L=SQRT(MAX(0D0,(1D0-RM3-RM4)**2-4D0*RM3*RM4-RPTS))
      RM34=MAX(1D-20,2D0*RM3*RM4)
      RSQM=1D0+RM34
      IF(2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)).LT.0.0001D0)
     &RM34=MAX(RM34,2D0*VINT(71)**2/MAX(1D0,VINT(21)*VINT(2)))
      RTHM=(4D0*RM3*RM4+RPTS)/(1D0-RM3-RM4+BE34L)
      IF(ISTSB.EQ.0) THEN
        TH=VINT(45)
        UH=-0.5D0*SH*MAX(RTHM,1D0-RM3-RM4+BE34*CTH)
        SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*VINT(59)**2)
      ELSE
C...Kinematics with incoming masses tricky: now depends on how
C...subprocess has been set up w.r.t. order of incoming partons.
        RM1=0D0
        IF(MINT(15).EQ.22.AND.VINT(3).LT.0D0) RM1=-VINT(3)**2/SH
        RM2=0D0
        IF(MINT(16).EQ.22.AND.VINT(4).LT.0D0) RM2=-VINT(4)**2/SH
        IF(ISUB.EQ.35) THEN
          RM2=MIN(RM1,RM2)
          RM1=0D0
        ENDIF
        BE12=SQRT(MAX(0D0,(1D0-RM1-RM2)**2-4D0*RM1*RM2))
        TUCOM=(1D0-RM1-RM2)*(1D0-RM3-RM4)
        TH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM4-2D0*RM2*RM3-
     &  BE12*BE34*CTH)
        UH=-0.5D0*SH*MAX(RTHM,TUCOM-2D0*RM1*RM3-2D0*RM2*RM4+
     &  BE12*BE34*CTH)
        SQPTH=MAX(VINT(71)**2,0.25D0*SH*BE34**2*(1D0-CTH**2))
      ENDIF
      SHR=SQRT(SH)
      SH2=SH**2
      TH2=TH**2
      UH2=UH**2

C...Choice of Q2 scale for hard process (e.g. alpha_s).
      IF(ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5) THEN
        Q2=SH
      ELSEIF(ISTSB.EQ.8) THEN
        IF(MINT(107).EQ.4) Q2=VINT(307)
        IF(MINT(108).EQ.4) Q2=VINT(308)
      ELSEIF(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9) THEN
        Q2IN1=0D0
        IF(MINT(11).EQ.22.AND.VINT(3).LT.0D0) Q2IN1=VINT(3)**2
        Q2IN2=0D0
        IF(MINT(12).EQ.22.AND.VINT(4).LT.0D0) Q2IN2=VINT(4)**2
        IF(MSTP(32).EQ.1) THEN
          Q2=2D0*SH*TH*UH/(SH**2+TH**2+UH**2)
        ELSEIF(MSTP(32).EQ.2) THEN
          Q2=SQPTH+0.5D0*(SQM3+SQM4)
        ELSEIF(MSTP(32).EQ.3) THEN
          Q2=MIN(-TH,-UH)
        ELSEIF(MSTP(32).EQ.4) THEN
          Q2=SH
        ELSEIF(MSTP(32).EQ.5) THEN
          Q2=-TH
        ELSEIF(MSTP(32).EQ.6) THEN
          XSF1=X(1)
          IF(ISTSB.EQ.9) XSF1=X(1)/VINT(143)
          XSF2=X(2)
          IF(ISTSB.EQ.9) XSF2=X(2)/VINT(144)
          Q2=(1D0+XSF1*Q2IN1/SH+XSF2*Q2IN2/SH)*
     &    (SQPTH+0.5D0*(SQM3+SQM4))
        ELSEIF(MSTP(32).EQ.7) THEN
          Q2=(1D0+Q2IN1/SH+Q2IN2/SH)*(SQPTH+0.5D0*(SQM3+SQM4))
        ELSEIF(MSTP(32).EQ.8) THEN
          Q2=SQPTH+0.5D0*(Q2IN1+Q2IN2+SQM3+SQM4)
        ELSEIF(MSTP(32).EQ.9) THEN
          Q2=SQPTH+Q2IN1+Q2IN2+SQM3+SQM4
        ELSEIF(MSTP(32).EQ.10) THEN
          Q2=VINT(2)
C..Begin JA 040914
        ELSEIF(MSTP(32).EQ.11) THEN
          Q2=0.25*(SQM3+SQM4+2*SQRT(SQM3*SQM4))
        ELSEIF(MSTP(32).EQ.12) THEN
          Q2=PARP(193)
C..End JA
        ELSEIF(MSTP(32).EQ.13) THEN
          Q2=SQPTH
        ENDIF
        IF(MINT(35).LE.2.AND.ISTSB.EQ.9) Q2=SQPTH
        IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2=Q2+
     &  (PARP(82)*(VINT(1)/PARP(89))**PARP(90))**2
      ENDIF

C...Choice of Q2 scale for parton densities.
      Q2SF=Q2
C..Begin JA 040914
      IF(MSTP(32).EQ.12.AND.(MOD(ISTSB,2).EQ.0.OR.ISTSB.EQ.9)
     &     .OR.MSTP(39).EQ.8.AND.(ISTSB.GE.3.AND.ISTSB.LE.5))
     &     Q2=PARP(194)
C..End JA
      IF(ISTSB.GE.3.AND.ISTSB.LE.5) THEN
        Q2SF=PMAS(23,1)**2
        IF(ISUB.EQ.8.OR.ISUB.EQ.76.OR.ISUB.EQ.77.OR.ISUB.EQ.124.OR.
     &  ISUB.EQ.174.OR.ISUB.EQ.179.OR.ISUB.EQ.351) Q2SF=PMAS(24,1)**2
        IF(ISUB.EQ.352) Q2SF=PMAS(PYCOMP(9900024),1)**2
        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) THEN
          Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,2)),1)**2
          IF(MSTP(39).EQ.2) Q2SF=
     &         MAX(VINT(201)**2+VINT(202),VINT(206)**2+VINT(207))
          IF(MSTP(39).EQ.3) Q2SF=SH
          IF(MSTP(39).EQ.4) Q2SF=VINT(26)*VINT(2)
          IF(MSTP(39).EQ.5) Q2SF=PMAS(PYCOMP(KFPR(ISUBSV,1)),1)**2
C..Begin JA 040914
          IF(MSTP(39).EQ.6) Q2SF=0.25*(VINT(201)+SQRT(SH))**2
          IF(MSTP(39).EQ.7) Q2SF=
     &         (VINT(201)**2+VINT(202)+VINT(206)**2+VINT(207))/2d0
          IF(MSTP(39).EQ.8) Q2SF=PARP(193)
C..End JA
        ENDIF
      ENDIF
      IF(MINT(35).GE.3.AND.ISTSB.EQ.9) Q2SF=SQPTH

      Q2PS=Q2SF
      Q2SF=Q2SF*PARP(34)
      IF(MSTP(69).GE.1.AND.MINT(47).EQ.5) Q2SF=VINT(2)
      IF(MSTP(69).GE.2) Q2SF=VINT(2)

C...Identify to which class(es) subprocess belongs
      ISMECR=0
      ISQCD=0
      ISJETS=0
      IF (ISUBSV.EQ.1.OR.ISUBSV.EQ.2.OR.ISUBSV.EQ.3.OR.
     &     ISUBSV.EQ.102.OR.ISUBSV.EQ.141.OR.ISUBSV.EQ.142.OR.
     &     ISUBSV.EQ.144.OR.ISUBSV.EQ.151.OR.ISUBSV.EQ.152.OR.
     &     ISUBSV.EQ.156.OR.ISUBSV.EQ.157) ISMECR=1
      IF (ISUBSV.EQ.11.OR.ISUBSV.EQ.12.OR.ISUBSV.EQ.13.OR.
     &     ISUBSV.EQ.28.OR.ISUBSV.EQ.53.OR.ISUBSV.EQ.68) ISQCD=1
      IF ((ISUBSV.EQ.81.OR.ISUBSV.EQ.82).AND.MINT(55).LE.5) ISQCD=1
      IF (ISUBSV.GE.381.AND.ISUBSV.LE.386) ISQCD=1
      IF ((ISUBSV.EQ.387.OR.ISUBSV.EQ.388).AND.MINT(55).LE.5) ISQCD=1
      IF (ISTSB.EQ.9) ISQCD=1
      IF ((ISUBSV.GE.86.AND.ISUBSV.LE.89).OR.ISUBSV.EQ.107.OR.
     &     (ISUBSV.GE.14.AND.ISUBSV.LE.16).OR.(ISUBSV.GE.29.AND.
     &     ISUBSV.LE.32).OR.(ISUBSV.GE.111.AND.ISUBSV.LE.113).OR.
     &     ISUBSV.EQ.115.OR.(ISUBSV.GE.183.AND.ISUBSV.LE.185).OR.
     &     (ISUBSV.GE.188.AND.ISUBSV.LE.190).OR.ISUBSV.EQ.161.OR.
     &     ISUBSV.EQ.167.OR.ISUBSV.EQ.168.OR.(ISUBSV.GE.393.AND.
     &     ISUBSV.LE.395).OR.(ISUBSV.GE.421.AND.ISUBSV.LE.439).OR.
     &     (ISUBSV.GE.461.AND.ISUBSV.LE.479)) ISJETS=1
C...WBF is special case of ISJETS
      IF (ISUBSV.EQ.5.OR.ISUBSV.EQ.8.OR.
     &    (ISUBSV.GE.71.AND.ISUBSV.LE.73).OR.
     &    ISUBSV.EQ.76.OR.ISUBSV.EQ.77.OR.
     &    (ISUBSV.GE.121.AND.ISUBSV.LE.124).OR.
     &    ISUBSV.EQ.173.OR.ISUBSV.EQ.174.OR.
     &    ISUBSV.EQ.178.OR.ISUBSV.EQ.179.OR.
     &    ISUBSV.EQ.181.OR.ISUBSV.EQ.182.OR.
     &    ISUBSV.EQ.186.OR.ISUBSV.EQ.187.OR.
     &    ISUBSV.EQ.351.OR.ISUBSV.EQ.352) ISJETS=2
C...Some processes with photons also belong here.
      IF (ISUBSV.EQ.10.OR.(ISUBSV.GE.18.AND.ISUBSV.LE.20).OR.
     &     (ISUBSV.GE.33.AND.ISUBSV.LE.36).OR.ISUBSV.EQ.54.OR.
     &     ISUBSV.EQ.58.OR.ISUBSV.EQ.69.OR.ISUBSV.EQ.70.OR.
     &     ISUBSV.EQ.80.OR.(ISUBSV.GE.83.AND.ISUBSV.LE.85).OR.
     &     (ISUBSV.GE.106.AND.ISUBSV.LE.110).OR.ISUBSV.EQ.114.OR.
     &     (ISUBSV.GE.131.AND.ISUBSV.LE.140)) ISJETS=3

C...Choice of Q2 scale for parton-shower activity.
      IF(MSTP(22).GE.1.AND.(ISUB.EQ.10.OR.ISUB.EQ.83).AND.
     &(MINT(43).EQ.2.OR.MINT(43).EQ.3)) THEN
        XBJ=X(2)
        IF(MINT(43).EQ.3) XBJ=X(1)
        IF(MSTP(22).EQ.1) THEN
          Q2PS=-TH
        ELSEIF(MSTP(22).EQ.2) THEN
          Q2PS=((1D0-XBJ)/XBJ)*(-TH)
        ELSEIF(MSTP(22).EQ.3) THEN
          Q2PS=SQRT((1D0-XBJ)/XBJ)*(-TH)
        ELSE
          Q2PS=(1D0-XBJ)*MAX(1D0,-LOG(XBJ))*(-TH)
        ENDIF
      ENDIF
C...For multiple interactions, start from scale defined above
C...For all other QCD or "+jets"-type events, start shower from pThard.
      IF (ISJETS.EQ.1.OR.ISQCD.EQ.1.AND.ISTSB.NE.9) Q2PS=SQPTH
      IF((MSTP(68).EQ.1.OR.MSTP(68).EQ.3).AND.ISMECR.EQ.1) THEN
C...Max shower scale = s for ME corrected processes.
C...(pT-ordering: max pT2 is s/4)
        Q2PS=VINT(2)
        IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
      ELSEIF(MSTP(68).GE.2.AND.ISQCD.EQ.0.AND.ISJETS.EQ.0) THEN
C...Max shower scale = s for all non-QCD, non-"+ jet" type processes.
C...(pT-ordering: max pT2 is s/4)
        Q2PS=VINT(2)
        IF (MINT(35).GE.3) Q2PS=Q2PS*0.25D0
      ENDIF
      IF(MINT(35).EQ.2.AND.ISTSB.EQ.9) Q2PS=SQPTH

C...Elastic and diffractive events not associated with scales so set 0.
      IF(ISUBSV.GE.91.AND.ISUBSV.LE.94) THEN
        Q2SF=0D0
        Q2PS=0D0
      ENDIF

C...Store derived kinematical quantities
      VINT(41)=X(1)
      VINT(42)=X(2)
      VINT(44)=SH
      VINT(43)=SQRT(SH)
      VINT(45)=TH
      VINT(46)=UH
      IF(ISTSB.NE.8) VINT(48)=SQPTH
      IF(ISTSB.NE.8) VINT(47)=SQRT(SQPTH)
      VINT(50)=TAUP*VINT(2)
      VINT(49)=SQRT(MAX(0D0,VINT(50)))
      VINT(52)=Q2
      VINT(51)=SQRT(Q2)
      VINT(54)=Q2SF
      VINT(53)=SQRT(Q2SF)
      VINT(56)=Q2PS
      VINT(55)=SQRT(Q2PS)

C...Set starting scale for multiple interactions
      IF (ISUBSV.EQ.95) THEN
        XT2GMX=0D0
      ELSEIF(MSTP(86).EQ.3.OR.(MSTP(86).EQ.2.AND.ISUBSV.NE.11.AND.
     &      ISUBSV.NE.12.AND.ISUBSV.NE.13.AND.ISUBSV.NE.28.AND.
     &      ISUBSV.NE.53.AND.ISUBSV.NE.68.AND.ISUBSV.NE.95.AND.
     &      ISUBSV.NE.96)) THEN
C...All accessible phase space allowed.
        XT2GMX=(1D0-VINT(41))*(1D0-VINT(42))
      ELSE
C...Scale of hard process sets limit.
C...2 -> 1. Limit is tau = x1*x2.
C...2 -> 2. Limit is XT2 for hard process + FS masses.
C...2 -> n > 2. Limit is tau' = tau of outer process.
        XT2GMX=VINT(25)
        IF(ISTSB.EQ.1) XT2GMX=VINT(21)
        IF(ISTSB.EQ.2)
     &      XT2GMX=(4D0*VINT(48)+2D0*VINT(63)+2D0*VINT(64))/VINT(2)
        IF(ISTSB.GE.3.AND.ISTSB.LE.5) XT2GMX=VINT(26)
      ENDIF
      VINT(62)=0.25D0*XT2GMX*VINT(2)
      VINT(61)=SQRT(MAX(0D0,VINT(62)))

C...Calculate parton distributions
      IF(ISTSB.LE.0) GOTO 160
      IF(MINT(47).GE.2) THEN
        DO 110 I=3-MIN(2,MINT(45)),MIN(2,MINT(46))
          XSF=X(I)
          IF(ISTSB.EQ.9) XSF=X(I)/VINT(142+I)
          IF(ISUB.EQ.99) THEN
            IF(MINT(140+I).EQ.0) THEN
              XSF=VINT(309-I)/(VINT(2)+VINT(309-I)-VINT(I+2)**2)
            ELSE
              XSF=VINT(309-I)/(VINT(2)+VINT(307)+VINT(308))
            ENDIF
            VINT(40+I)=XSF
            Q2SF=VINT(309-I)
          ENDIF
          MINT(105)=MINT(102+I)
          MINT(109)=MINT(106+I)
          VINT(120)=VINT(2+I)
C...Default is to use standard PDFs, but for interactions after the first
C...in the new multiple-parton-interactions framework, set which side to
C...evaluate the MPI-modified PDFs on.
          MINT(30)=0
          IF (MINT(31).GE.1) MINT(30)=I
          IF(MSTP(57).LE.1) THEN
            CALL PYPDFU(MINT(10+I),XSF,Q2SF,XPQ)
          ELSE
            CALL PYPDFL(MINT(10+I),XSF,Q2SF,XPQ)
          ENDIF
C...Safety margin against heavy flavour very close to threshold,
C...e.g. caused by mismatch in c and b masses.
          IF(Q2SF.LT.1.1*PMAS(4,1)**2) THEN
            XPQ(4)=0D0
            XPQ(-4)=0D0
          ENDIF
          IF(Q2SF.LT.1.1*PMAS(5,1)**2) THEN
            XPQ(5)=0D0
            XPQ(-5)=0D0
          ENDIF
          DO 100 KFL=-25,25
            XSFX(I,KFL)=XPQ(KFL)
  100     CONTINUE
  110   CONTINUE
      ENDIF

C...Calculate alpha_em, alpha_strong and K-factor
      XW=PARU(102)
      XWV=XW
      IF(MSTP(8).GE.2.OR.(ISUB.GE.71.AND.ISUB.LE.77)) XW=
     &1D0-(PMAS(24,1)/PMAS(23,1))**2
      XW1=1D0-XW
      XWC=1D0/(16D0*XW*XW1)
      AEM=PYALEM(Q2)
      IF(MSTP(8).GE.1) AEM=SQRT(2D0)*PARU(105)*PMAS(24,1)**2*XW/PARU(1)
      IF(MSTP(33).NE.3) AS=PYALPS(PARP(34)*Q2)
      FACK=1D0
      FACA=1D0
      IF(MSTP(33).EQ.1) THEN
        FACK=PARP(31)
      ELSEIF(MSTP(33).EQ.2) THEN
        FACK=PARP(31)
        FACA=PARP(32)/PARP(31)
      ELSEIF(MSTP(33).EQ.3) THEN
        Q2AS=PARP(33)*Q2
        IF(ISTSB.EQ.9.AND.MSTP(82).GE.2) Q2AS=Q2AS+
     &  PARU(112)*PARP(82)*(VINT(1)/PARP(89))**PARP(90)
        AS=PYALPS(Q2AS)
C...PS (12 Feb 2010)
C...New options MSTP(33) = 10 and 11
C...  10: use K-factor = PARP(32) only for process 96 (MPI)
C...  11: as for 10, but also use K-factor = PARP(31) for other procs
      ELSEIF(MSTP(33).GE.10) THEN
        IF (ISUB.EQ.96) THEN
          FACK = PARP(32)
        ELSEIF (ISUB.NE.96.AND.MSTP(33).EQ.11) THEN
          FACK = PARP(31)
        ENDIF
      ENDIF
      VINT(138)=1D0
      VINT(57)=AEM
      VINT(58)=AS

C...Set flags for allowed reacting partons/leptons
      DO 140 I=1,2
        DO 120 J=-25,25
          KFAC(I,J)=0
  120   CONTINUE
        IF(MINT(44+I).EQ.1) THEN
          KFAC(I,MINT(10+I))=1
        ELSEIF(MINT(40+I).EQ.1.AND.MSTP(12).EQ.0) THEN
          KFAC(I,MINT(10+I))=1
          KFAC(I,22)=1
          KFAC(I,24)=1
          KFAC(I,-24)=1
        ELSE
          DO 130 J=-25,25
            KFAC(I,J)=KFIN(I,J)
            IF(ABS(J).GT.MSTP(58).AND.ABS(J).LE.10) KFAC(I,J)=0
            IF(XSFX(I,J).LT.1D-10) KFAC(I,J)=0
  130     CONTINUE
        ENDIF
  140 CONTINUE

C...Lower and upper limit for fermion flavour loops
      MMIN1=0
      MMAX1=0
      MMIN2=0
      MMAX2=0
      DO 150 J=-20,20
        IF(KFAC(1,-J).EQ.1) MMIN1=-J
        IF(KFAC(1,J).EQ.1) MMAX1=J
        IF(KFAC(2,-J).EQ.1) MMIN2=-J
        IF(KFAC(2,J).EQ.1) MMAX2=J
  150 CONTINUE
      MMINA=MIN(MMIN1,MMIN2)
      MMAXA=MAX(MMAX1,MMAX2)

C...Common resonance mass and width combinations
      SQMZ=PMAS(23,1)**2
      SQMW=PMAS(24,1)**2
      GMMZ=PMAS(23,1)*PMAS(23,2)
      GMMW=PMAS(24,1)*PMAS(24,2)

C...Polarization factors...implemented so far for W+W-(25)
      POLR=(1D0+PARJ(132))*(1D0-PARJ(131))
      POLL=(1D0-PARJ(132))*(1D0+PARJ(131))
      POLRR=(1D0+PARJ(132))*(1D0+PARJ(131))
      POLLL=(1D0-PARJ(132))*(1D0-PARJ(131))

C...Phase space integral in tau
      COMFAC=PARU(1)*PARU(5)/VINT(2)
      IF(MINT(41).EQ.2.AND.MINT(42).EQ.2) COMFAC=COMFAC*FACK
      IF((MINT(47).GE.2.OR.(ISTSB.GE.3.AND.ISTSB.LE.5)).AND.
     &ISTSB.NE.8.AND.ISTSB.NE.9) THEN
        ATAU1=LOG(TAUMAX/TAUMIN)
        ATAU2=(TAUMAX-TAUMIN)/(TAUMAX*TAUMIN)
        H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/TAU
        IF(MINT(72).GE.1) THEN
          TAUR1=VINT(73)
          GAMR1=VINT(74)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR1)/(TAUMAX+TAUR1))
          ATAU3=ATAUD/TAUR1
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU3)*COEF(ISUBSV,3)/(TAU+TAUR1)
          ATAUD=ATAN((TAUMAX-TAUR1)/GAMR1)-ATAN((TAUMIN-TAUR1)/GAMR1)
          ATAU4=ATAUD/GAMR1
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU4)*COEF(ISUBSV,4)*TAU/((TAU-TAUR1)**2+GAMR1**2)
        ENDIF
        IF(MINT(72).GE.2) THEN
          TAUR2=VINT(75)
          GAMR2=VINT(76)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR2)/(TAUMAX+TAUR2))
          ATAU5=ATAUD/TAUR2
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU5)*COEF(ISUBSV,5)/(TAU+TAUR2)
          ATAUD=ATAN((TAUMAX-TAUR2)/GAMR2)-ATAN((TAUMIN-TAUR2)/GAMR2)
          ATAU6=ATAUD/GAMR2
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU6)*COEF(ISUBSV,6)*TAU/((TAU-TAUR2)**2+GAMR2**2)
        ENDIF
        IF(MINT(72).EQ.3) THEN
          TAUR3=VINT(77)
          GAMR3=VINT(78)
          ATAUD=LOG(TAUMAX/TAUMIN*(TAUMIN+TAUR3)/(TAUMAX+TAUR3))
          ATAU50=ATAUD/TAUR3
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU50)*COEFX(ISUBSV,1)/(TAU+TAUR3)
          ATAUD=ATAN((TAUMAX-TAUR3)/GAMR3)-ATAN((TAUMIN-TAUR3)/GAMR3)
          ATAU60=ATAUD/GAMR3
          IF(ATAUD.GT.1D-10) H1=H1+
     &    (ATAU1/ATAU60)*COEFX(ISUBSV,2)*TAU/((TAU-TAUR3)**2+GAMR3**2)
        ENDIF
        IF(MINT(47).EQ.5.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
          ATAU7=LOG(MAX(2D-10,1D0-TAUMIN)/MAX(2D-10,1D0-TAUMAX))
          IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
     &    MAX(2D-10,1D0-TAU)
        ELSEIF(MINT(47).GE.6.AND.(ISTSB.LE.2.OR.ISTSB.GE.5)) THEN
          ATAU7=LOG(MAX(1D-10,1D0-TAUMIN)/MAX(1D-10,1D0-TAUMAX))
          IF(ATAU7.GT.1D-10) H1=H1+(ATAU1/ATAU7)*COEF(ISUBSV,7)*TAU/
     &    MAX(1D-10,1D0-TAU)
        ENDIF
        COMFAC=COMFAC*ATAU1/(TAU*H1)
      ENDIF

C...Phase space integral in y*
      IF((MINT(47).EQ.4.OR.MINT(47).EQ.5).AND.ISTSB.NE.8.AND.ISTSB.NE.9)
     &THEN
        AYST0=YSTMAX-YSTMIN
        IF(AYST0.LT.1D-10) THEN
          COMFAC=0D0
        ELSE
          AYST1=0.5D0*(YSTMAX-YSTMIN)**2
          AYST2=AYST1
          AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
          H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
     &    (AYST0/AYST2)*COEF(ISUBSV,9)*(YSTMAX-YST)+
     &    (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
          IF(MINT(45).EQ.3) THEN
            YST0=-0.5D0*LOG(TAUE)
            AYST4=LOG(MAX(1D-10,EXP(YST0-YSTMIN)-1D0)/
     &      MAX(1D-10,EXP(YST0-YSTMAX)-1D0))
            IF(AYST4.GT.1D-10) H2=H2+(AYST0/AYST4)*COEF(ISUBSV,11)/
     &      MAX(1D-10,1D0-EXP(YST-YST0))
          ENDIF
          IF(MINT(46).EQ.3) THEN
            YST0=-0.5D0*LOG(TAUE)
            AYST5=LOG(MAX(1D-10,EXP(YST0+YSTMAX)-1D0)/
     &      MAX(1D-10,EXP(YST0+YSTMIN)-1D0))
            IF(AYST5.GT.1D-10) H2=H2+(AYST0/AYST5)*COEF(ISUBSV,12)/
     &      MAX(1D-10,1D0-EXP(-YST-YST0))
          ENDIF
          COMFAC=COMFAC*AYST0/H2
        ENDIF
      ENDIF

C...2 -> 1 processes: reduction in angular part of phase space integral
C...for case of decaying resonance
      ACTH0=CTNMAX-CTNMIN+CTPMAX-CTPMIN
      IF((ISTSB.EQ.1.OR.ISTSB.EQ.3.OR.ISTSB.EQ.5)) THEN
        IF(MDCY(PYCOMP(KFPR(ISUBSV,1)),1).EQ.1) THEN
          IF(KFPR(ISUB,1).EQ.25.OR.KFPR(ISUB,1).EQ.37.OR.
     &    KFPR(ISUB,1).EQ.39) THEN
            COMFAC=COMFAC*0.5D0*ACTH0
          ELSE
            COMFAC=COMFAC*0.125D0*(3D0*ACTH0+CTNMAX**3-CTNMIN**3+
     &      CTPMAX**3-CTPMIN**3)
          ENDIF
        ENDIF

C...2 -> 2 processes: angular part of phase space integral
      ELSEIF(ISTSB.EQ.2.OR.ISTSB.EQ.4) THEN
        ACTH1=LOG((MAX(RM34,RSQM-CTNMIN)*MAX(RM34,RSQM-CTPMIN))/
     &  (MAX(RM34,RSQM-CTNMAX)*MAX(RM34,RSQM-CTPMAX)))
        ACTH2=LOG((MAX(RM34,RSQM+CTNMAX)*MAX(RM34,RSQM+CTPMAX))/
     &  (MAX(RM34,RSQM+CTNMIN)*MAX(RM34,RSQM+CTPMIN)))
        ACTH3=1D0/MAX(RM34,RSQM-CTNMAX)-1D0/MAX(RM34,RSQM-CTNMIN)+
     &  1D0/MAX(RM34,RSQM-CTPMAX)-1D0/MAX(RM34,RSQM-CTPMIN)
        ACTH4=1D0/MAX(RM34,RSQM+CTNMIN)-1D0/MAX(RM34,RSQM+CTNMAX)+
     &  1D0/MAX(RM34,RSQM+CTPMIN)-1D0/MAX(RM34,RSQM+CTPMAX)
        H3=COEF(ISUBSV,13)+
     &  (ACTH0/ACTH1)*COEF(ISUBSV,14)/MAX(RM34,RSQM-CTH)+
     &  (ACTH0/ACTH2)*COEF(ISUBSV,15)/MAX(RM34,RSQM+CTH)+
     &  (ACTH0/ACTH3)*COEF(ISUBSV,16)/MAX(RM34,RSQM-CTH)**2+
     &  (ACTH0/ACTH4)*COEF(ISUBSV,17)/MAX(RM34,RSQM+CTH)**2
        COMFAC=COMFAC*ACTH0*0.5D0*BE34/H3

C...2 -> 2 processes: take into account final state Breit-Wigners
        COMFAC=COMFAC*VINT(80)
      ENDIF

C...2 -> 3, 4 processes: phace space integral in tau'
      IF(MINT(47).GE.2.AND.ISTSB.GE.3.AND.ISTSB.LE.5) THEN
        ATAUP1=LOG(TAUPMX/TAUPMN)
        ATAUP2=((1D0-TAU/TAUPMX)**4-(1D0-TAU/TAUPMN)**4)/(4D0*TAU)
        H4=COEF(ISUBSV,18)+
     &  (ATAUP1/ATAUP2)*COEF(ISUBSV,19)*(1D0-TAU/TAUP)**3/TAUP
        IF(MINT(47).EQ.5) THEN
          ATAUP3=LOG(MAX(2D-10,1D0-TAUPMN)/MAX(2D-10,1D0-TAUPMX))
          H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(2D-10,1D0-TAUP)
        ELSEIF(MINT(47).GE.6) THEN
          ATAUP3=LOG(MAX(1D-10,1D0-TAUPMN)/MAX(1D-10,1D0-TAUPMX))
          H4=H4+(ATAUP1/ATAUP3)*COEF(ISUBSV,20)*TAUP/MAX(1D-10,1D0-TAUP)
        ENDIF
        COMFAC=COMFAC*ATAUP1/H4
      ENDIF

C...2 -> 3, 4 processes: effective W/Z parton distributions
      IF(ISTSB.EQ.3.OR.ISTSB.EQ.4) THEN
        IF(1D0-TAU/TAUP.GT.1D-4) THEN
          FZW=(1D0+TAU/TAUP)*LOG(TAUP/TAU)-2D0*(1D0-TAU/TAUP)
        ELSE
          FZW=1D0/6D0*(1D0-TAU/TAUP)**3*TAU/TAUP
        ENDIF
        COMFAC=COMFAC*FZW
      ENDIF

C...2 -> 3 processes: phase space integrals for pT1, pT2, y3, mirror
      IF(ISTSB.EQ.5) THEN
        COMFAC=COMFAC*VINT(205)*VINT(210)*VINT(212)*VINT(214)/
     &  (128D0*PARU(1)**4*VINT(220))*(TAU**2/TAUP)
      ENDIF

C...Phase space integral for low-pT and multiple interactions
      IF(ISTSB.EQ.9) THEN
        COMFAC=PARU(1)*PARU(5)*FACK*0.5D0*VINT(2)/SH2
        ATAU1=LOG(2D0*(1D0+SQRT(1D0-XT2))/XT2-1D0)
        ATAU2=2D0*ATAN(1D0/XT2-1D0)/SQRT(XT2)
        H1=COEF(ISUBSV,1)+(ATAU1/ATAU2)*COEF(ISUBSV,2)/SQRT(TAU)
        COMFAC=COMFAC*ATAU1/H1
        AYST0=YSTMAX-YSTMIN
        AYST1=0.5D0*(YSTMAX-YSTMIN)**2
        AYST3=2D0*(ATAN(EXP(YSTMAX))-ATAN(EXP(YSTMIN)))
        H2=(AYST0/AYST1)*COEF(ISUBSV,8)*(YST-YSTMIN)+
     &  (AYST0/AYST1)*COEF(ISUBSV,9)*(YSTMAX-YST)+
     &  (AYST0/AYST3)*COEF(ISUBSV,10)/COSH(YST)
        COMFAC=COMFAC*AYST0/H2
        IF(MSTP(82).LE.1) COMFAC=COMFAC*XT2**2*(1D0/VINT(149)-1D0)
C...For MSTP(82)>=2 an additional factor (xT2/(xT2+VINT(149))**2 is
C...introduced to make cross-section finite for xT2 -> 0
        IF(MSTP(82).GE.2) COMFAC=COMFAC*XT2**2/(VINT(149)*
     &  (1D0+VINT(149)))
      ENDIF

C...Real gamma + gamma: include factor 2 when different nature
  160 IF(MINT(11).EQ.22.AND.MINT(12).EQ.22.AND.MINT(123).GE.4.AND.
     &MSTP(14).LE.10) COMFAC=2D0*COMFAC

C...Extra factors to include the effects of
C...longitudinal resolved photons (but not direct or DIS ones).
      DO 170 ISDE=1,2
        IF(MINT(10+ISDE).EQ.22.AND.MINT(106+ISDE).GE.1.AND.
     &  MINT(106+ISDE).LE.3) THEN
          VINT(314+ISDE)=1D0
          XY=PARP(166+ISDE)
          IF(MSTP(16).EQ.0) THEN
            IF(VINT(304+ISDE).GT.0D0.AND.VINT(304+ISDE).LT.1D0)
     &      XY=VINT(304+ISDE)
          ELSE
            IF(VINT(308+ISDE).GT.0D0.AND.VINT(308+ISDE).LT.1D0)
     &      XY=VINT(308+ISDE)
          ENDIF
          Q2GA=VINT(306+ISDE)
          IF(MSTP(17).GT.0.AND.XY.GT.0D0.AND.XY.LT.1D0.AND.
     &    Q2GA.GT.0D0) THEN
            REDUCE=0D0
            IF(MSTP(17).EQ.1) THEN
              REDUCE=4D0*Q2*Q2GA/(Q2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.2) THEN
              REDUCE=4D0*Q2GA/(Q2+Q2GA)
            ELSEIF(MSTP(17).EQ.3) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.1) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.2) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*PMVIRT**2*Q2GA/(PMVIRT**2+Q2GA)**2
            ELSEIF(MSTP(17).EQ.4.AND.MINT(106+ISDE).EQ.3) THEN
              PMVSMN=4D0*PARP(15)**2
              PMVSMX=4D0*VINT(154)**2
              REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
              REDLON=(3D0*PMVSMN+Q2GA)/(PMVSMN+Q2GA)**3-
     &        (3D0*PMVSMX+Q2GA)/(PMVSMX+Q2GA)**3
              REDUCE=4D0*(Q2GA/6D0)*REDLON/REDTRA
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.1) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.2) THEN
              PMVIRT=PMAS(PYCOMP(113),1)
              REDUCE=4D0*Q2GA/(PMVIRT**2+Q2GA)
            ELSEIF(MSTP(17).EQ.5.AND.MINT(106+ISDE).EQ.3) THEN
              PMVSMN=4D0*PARP(15)**2
              PMVSMX=4D0*VINT(154)**2
              REDTRA=1D0/(PMVSMN+Q2GA)-1D0/(PMVSMX+Q2GA)
              REDLON=1D0/(PMVSMN+Q2GA)**2-1D0/(PMVSMX+Q2GA)**2
              REDUCE=4D0*(Q2GA/2D0)*REDLON/REDTRA
            ENDIF
            BEAMAS=PYMASS(11)
            IF(VINT(302+ISDE).GT.0D0) BEAMAS=VINT(302+ISDE)
            FRACLT=1D0/(1D0+XY**2/2D0/(1D0-XY)*
     &      (1D0-2D0*BEAMAS**2/Q2GA))
            VINT(314+ISDE)=1D0+PARP(165)*REDUCE*FRACLT
          ENDIF
        ELSE
          VINT(314+ISDE)=1D0
        ENDIF
        COMFAC=COMFAC*VINT(314+ISDE)
  170 CONTINUE

C...Evaluate cross sections - done in separate routines by kind
C...of physics, to keep PYSIGH of sensible size.
      IF(MAP.EQ.1) THEN
C...Standard QCD (including photons).
        CALL PYSGQC(NCHN,SIGS)
      ELSEIF(MAP.EQ.2) THEN
C...Heavy flavours.
        CALL PYSGHF(NCHN,SIGS)
      ELSEIF(MAP.EQ.3) THEN
C...W/Z.
        CALL PYSGWZ(NCHN,SIGS)
      ELSEIF(MAP.EQ.4) THEN
C...Higgs (2 doublets; including longitudinal W/Z scattering).
        CALL PYSGHG(NCHN,SIGS)
      ELSEIF(MAP.EQ.5) THEN
C...SUSY.
        CALL PYSGSU(NCHN,SIGS)
      ELSEIF(MAP.EQ.6) THEN
C...Technicolor.
        CALL PYSGTC(NCHN,SIGS)
      ELSEIF(MAP.EQ.7) THEN
C...Exotics (Z'/W'/LQ/R/f*/H++/Z_R/W_R/G*).
        CALL PYSGEX(NCHN,SIGS)
      ELSEIF(MAP.EQ.8) THEN
C... Universal Extra Dimensions
        CALL PYXUED(NCHN,SIGS)
      ENDIF

C...Multiply with parton distributions
      IF(ISUB.LE.90.OR.ISUB.GE.96) THEN
        DO 180 ICHN=1,NCHN
          IF(MINT(45).GE.2) THEN
            KFL1=ISIG(ICHN,1)
            SIGH(ICHN)=SIGH(ICHN)*XSFX(1,KFL1)
          ENDIF
          IF(MINT(46).GE.2) THEN
            KFL2=ISIG(ICHN,2)
            SIGH(ICHN)=SIGH(ICHN)*XSFX(2,KFL2)
          ENDIF
          SIGS=SIGS+SIGH(ICHN)
  180   CONTINUE
      ENDIF

      RETURN
      END


PROGRAM loop_decompose

  USE omp_lib
  IMPLICIT NONE
  INTEGER, PARAMETER :: max_its = 10000
  INTEGER :: i, its_global

its_global = 0
!$OMP PARALLEL DO REDUCTION(+:its_global)
  DO i = 1, max_its
  !Reduction means that its_global is recorded separately
   !on each thread and then combined between all threads by using
   !a reduction operator (here +) at the end
    its_global = its_global + 1
  END DO
!$OMP END PARALLEL DO

PRINT '(A,I0,A)','Counter records ', its_global, ' iterations'

END PROGRAM loop_decompose


program ifendif

    implicit none

    ! Declare the variables, ask for input
    real :: x, y
    integer :: choice

    print *, "What are your x and y values?"
    read *, x
    read *, y

    ! Ask user to choose from a list of options
    print *, "Please choose an option: "
    print *, "1. Addition"
    print *, "2. Subtraction"
    print *, "3. Multiplication"
    print *, "4. Division"

    read *, choice

    ! Act accordingly
    if (choice == 1) print *, "Your result is", x + y
    if (choice == 2) print *, "Your result is", x - y
    if (choice == 3) print *, "Your result is", x * y
    if (choice == 4) print *, "Your result is", x / y ! The guide suggested putting a tertiary variable here, which is silly imo

    ! If I wanted to do this with more complicated if statements, the syntax is:
    ! if (choice == 5) then
    !     print *, "This is a more complicated if statement involving more than 1 line."
    !     print *, "Bow before its might and wonder."
    ! end if

    ! Additionally: if I want to compare a value to 0, like (x == 0), FORTRAN can fail to evaluate it to a hard 0. Thus, I should do something like:
    ! if (abs(x) < 0.000001) then ... ! where abs() takes the absolute value of something.

end program ifendif