C Copyright (c) 2007-2017 National Technology & Engineering Solutions of
C Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of NTESS nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C=====================================================================
*     DECK,MKE
      SUBROUTINE MKE(NELND,NUMEB,NUMND,ICON,NDLST,ITYPE,
     &     VELX,VELY,VELZ,EMSS,RNMS,
     &     RMX,RMY,RMZ,RKE,PSQ,RJ2,
     &     SIGXX,SIGYY,SIGZZ,SIGXY,SIGYZ,SIGZX)
C
C     ****************************************************************
C
C     Compute momenta (x, y, and z) and kinetic energy
C     for an element block. Totals are stored in MKEI.
C     Called when check on accuracy of map is requested
C
C     Called by MAPVAR
C
C     ****************************************************************
C
C     NELND  INT   Number of nodes per element
C     NUMEB  INT   Number of elements in element block
C     NUMND  int   Number of nodes in element block
C     ICON   INT   Connectivity array (1:nelnd,1:numeb)
C     NDLST  INT   Array of nodes in element block (1:nneb)
C     ITYPE  INT   Element type
C     VELX   REAL  Array of velocities from data base (1:nnod)
C     VELY   REAL  Array of velocities from data base (1:nnod)
C     VELZ   REAL  Array of velocities from data base (1:nnod)
C     EMSS   REAL  Array of element masses from data base (1:numeb)
C     RNMS   REAL  Array of nodal masses (1:nnod)
C     RMX    REAL  X-momentum for this element block, this time step
C     RMY    REAL  Y-momentum for this element block, this time step
C     RMZ    REAL  Z-momentum for this element block, this time step
C     RKE    REAL  Kinetic energy for this element block, this time step
C     PSQ    REAL  Pressure squared * element mass for element block
C     RJ2    REAL  J2 * element mass for element block
C     SIGXX  REAL  Component of stress tensot
C     SIGYY  REAL  Component of stress tensot
C     SIGZZ  REAL  Component of stress tensot
C     SIGXY  REAL  Component of stress tensot
C     SIGYZ  REAL  Component of stress tensot
C     SIGZX  REAL  Component of stress tensot

C
C     ****************************************************************
C
      include 'amesh.blk'
C
      DIMENSION ICON(NELND,*),NDLST(*)
      DIMENSION VELX(*),VELY(*),VELZ(*),EMSS(*),RNMS(*)
      DIMENSION SIGXX(*),SIGYY(*),SIGZZ(*),SIGXY(*),SIGYZ(*),SIGZX(*)
C
C     ****************************************************************
C
C     zero nodal mass array
C
      DO I = 1, NUMEB
         DO J = 1, NELND
            RNMS(ICON(J,I)) = 0.
         end do
      end do
C
C     Translate element mass to nodal mass
C     First cut, come back and do better if necessary
C
      IF (ITYPE .EQ. 3 .OR. ITYPE .EQ. 4 .OR. ITYPE .EQ. 5)THEN
C
C     Treat all quads the same, use only four corner nodes
C     can fix if needed
C
         NEND = 4
         DO I = 1, NUMEB
            DO J = 1, NEND
               RNMS(ICON(J,I)) = RNMS(ICON(J,I)) + 0.25 * EMSS(I)
            end do
         end do
      ELSE IF (ITYPE .EQ. 10)THEN
C
C     8-node hex
C
         NEND = 8
         DO I = 1, NUMEB
            DO J = 1, NEND
               RNMS(ICON(J,I)) = RNMS(ICON(J,I)) + 0.125 * EMSS(I)
            end do
         end do
      ELSE IF (ITYPE .EQ. 13)THEN
C
C     4-node shell
C
         NEND = 4
         DO I = 1, NUMEB
            DO J = 1, NEND
               RNMS(ICON(J,I)) = RNMS(ICON(J,I)) + 0.25 * EMSS(I)
            end do
         end do
      ELSE IF (ITYPE .EQ. 6)THEN
C
C     treat all tets the same, use only four corner nodes
C     can fix if needed
C
         NEND = 4
         DO I = 1, NUMEB
            DO J = 1, NEND
               RNMS(ICON(J,I)) = RNMS(ICON(J,I)) + 0.25 * EMSS(I)
            end do
         end do
      ELSE
         CALL ERROR ('MKE','UNSUPPORTED ELEMENT TYPE','ITYPE',itype,
     &        ' ',0,' ',' ',1)
      END IF
C
C     compute momenta, KE, P-sqM, J2-sqM for element block
C     loop over all nodes in element block
C
      RMX = 0.
      RMY = 0.
      RMZ = 0.
      RKE = 0.
      PSQ = 0.
      RJ2 = 0.
      DO I = 1, NUMND
         INOD = NDLST(I)
         IF (NDIMA .EQ. 3)THEN
            VELSQ = VELX(INOD)*VELX(INOD) + VELY(INOD)*VELY(INOD)
     &           + VElZ(INOD)*VELZ(INOD)
            RMZ = RMZ + (VELZ(INOD) * RNMS(INOD))
         ELSE
            VELSQ = VELX(INOD)*VELX(INOD) + VELY(INOD)*VELY(INOD)
         END IF
         RMX = RMX + (VELX(INOD) * RNMS(INOD))
         RMY = RMY + (VELY(INOD) * RNMS(INOD))
         RKE = RKE + (0.5 * RNMS(INOD) * VELSQ)
      end do
C
      DO I = 1, NUMEB
         P = (SIGXX(I) + SIGYY(I) + SIGZZ(I)) / 3.
         PSQ = PSQ + P*P*EMSS(I)
         TAUP1 = SIGXX(I) - P
         TAUP2 = SIGYY(I) - P
         TAUP3 = SIGZZ(I) - P
         IF (NDIMA .EQ. 3)THEN
            RJ2 = RJ2 + ((((TAUP1**2 + TAUP2**2 + TAUP3**2)/6.)
     &           + SIGXY(I)**2 + SIGYZ(I)**2 + SIGZX(I)**2) * EMSS(I))
         ELSE
            RJ2 = RJ2 + ((((TAUP1**2 + TAUP2**2 + TAUP3**2)/6.)
     &           + SIGXY(I)**2) * EMSS(I))
         END IF
      end do
C
      RETURN
      END


      subroutine pwhgplotter(p,pjet,wt0,nd)
      implicit none
      include 'hepevt.h'
      include 'masses.f'
      include 'part.f'
      include 'nproc.f'
      double precision p(12,4),pjet(12,4),ph(4),wt0,pt(1:4),
     1     d1t,d2t,d1a,d2a
      integer switch,nd,ond,j
      logical first
      data first/.true./
      save first,ond
      double precision pjetcom(12,4),wt
      common/pjetcom/pjetcom

c Translate from femto- (MCFM) to pico- (POWHEG)
      wt=wt0/1000

c------------ SET-UP NUMBER OF PARTICLES TO APPEAR IN EVENT RECORD

      if(first) then
c This is trick to communicate the number of jets
c to the histogram booking section
c JC/RKE - what's the purpose of setting these twice?
         if    (nproc.eq.31) then
            nhep=4
            call init_hist_Z
         elseif(nproc.eq.44) then
            nhep=6
            call init_hist_KN
         elseif(nproc.eq.203) then
            nhep=6
            call init_hist_KN
         elseif(nproc.ge.141.and.nproc.le.151) then
            nhep=12
            call init_hist_KN
         elseif(nproc.ge.171.and.nproc.le.177) then
            nhep=8
            call init_hist_ST_sch_dk
         elseif(nproc.ge.231.and.nproc.le.239) then
            nhep=9
            call init_hist_ST_tch_dk
         elseif(nproc.ge.181.and.nproc.le.187) then
            nhep=10
            call init_hist_ST_wt_dk
         else
            stop 'process not implemented in pwhgplotter.f'
         endif
         ond=0
         first = .false.
      else
c put partons in the hephep interface
         if    (nproc.eq.31) then
            nhep=4
         elseif(nproc.eq.44) then
            nhep=6
         elseif(nproc.eq.203) then
            nhep=5
         elseif(nproc.ge.141.and.nproc.le.151) then
            nhep=12
         elseif(nproc.ge.171.and.nproc.le.177) then
            nhep=8
         elseif(nproc.ge.231.and.nproc.le.239) then
            nhep=9
         elseif(nproc.ge.181.and.nproc.le.187) then
            nhep=10
         else
            stop 'process not implemented in pwhgplotter.f'
         endif

c--- additional parton present in real corrections
         if(part.eq.'real'.and.nd.eq.0) then
            nhep=nhep+1
         endif

c------------ EVENT RECORD INITIALIZATION

c----spuriously set everyone to a gluon?
         do j=1,nhep
            idhep(j)=21
            isthep(j)=1
         enddo
         isthep(1)=-1
         isthep(2)=-1

c--- JC/RKE: should leptons be properly defined for all the processes below?

c------------ PROCESS-SPECIFIC FILLING OF EVENT RECORD

c------ Z
         if(nproc.eq.31) then
            idhep(3)=11
            idhep(4)=-11
            do j=1,nhep
               phep(1:4,j)=p(j,:)
            enddo
         endif

c------ W/Z + jets
         if(nproc.eq.11.or.nproc.eq.22.or.nproc.eq.44) then
            idhep(3)=11
            idhep(4)=-11
            do j=1,nhep
               phep(1:4,j)=p(j,:)
            enddo
            do j=1,12
               pjetcom(j,1:4)=pjet(j,1:4)
            enddo
         endif

c------ H + jet
         if(nproc.eq.203) then
            idhep(3)=25
c            ph=p(3,:)+p(4,:)
c            write(*,*)
c     1           sqrt(abs(ph(4)**2-ph(1)**2-ph(2)**2-ph(3)**2))
c we want the undecayed Higgs
            do j=1,2
               phep(1:4,j)=p(j,:)
            enddo
            phep(1:4,3)=p(3,:)+p(4,:)
            do j=4,nhep
               phep(1:4,j)=p(j+1,:)
            enddo
         endif

c------ t-tbar
         if(nproc.ge.141.and.nproc.le.151) then
            phep(1:4,3)=p(3,:)+p(4,:)+p(5,:)
            phep(1:4,4)=p(6,:)+p(7,:)+p(8,:)
            phep(1:4,5)=p(3,:)+p(4,:)
            phep(1:4,6)=p(7,:)+p(8,:)
            phep(1:4,7)=p(4,:)
            phep(1:4,8)=p(3,:)
            phep(1:4,9)=p(7,:)
            phep(1:4,10)=p(8,:)
            phep(1:4,11)=p(5,:)
            phep(1:4,12)=p(6,:)
            if(nhep.eq.13) then
                phep(1:4,13)=p(9,:)
c is 3 a full top?
                pt=phep(1:4,3)
                d1t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=pt+phep(1:4,13)
                d2t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=phep(1:4,4)
                d1a=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=pt+phep(1:4,13)
                d2a=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
c                write(*,*) d1t,d2t,d1a,d2a
                if(d2t.lt.d1t.and.d2a.ge.d2t) then
c                   write(*,*) ' t with radiation'
                   phep(1:4,3)=phep(1:4,3)+phep(1:4,13)
                elseif(d2a.lt.d1a.and.d2t.ge.d2a) then
c                   write(*,*) ' at with radiation'
                   phep(1:4,4)=phep(1:4,4)+phep(1:4,13)
                endif
c                read(*,*)
            endif
            idhep(3)=6
            idhep(4)=-6
            idhep(5)=24
            idhep(6)=-24
            idhep(11)=5
            idhep(12)=-5
         endif

c------ s-channel single top
         if(nproc.ge.171.and.nproc.le.177) then
            phep(1:4,3)=p(3,:)+p(4,:)+p(5,:)
            phep(1:4,4)=p(3,:)+p(4,:)
            phep(1:4,5)=p(3,:)
            phep(1:4,6)=p(4,:)
            phep(1:4,7)=p(5,:)
            phep(1:4,8)=p(6,:)
            if(nhep.eq.9) then
                phep(1:4,9)=p(7,:)
c is 3 a full top?
                pt=phep(1:4,3)
                d1t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=pt+phep(1:4,9)
                d2t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
c                write(*,*) d1t,d2t
                if(d2t.lt.d1t) then
c                   write(*,*) ' t with radiation'
                   phep(1:4,3)=phep(1:4,3)+phep(1:4,9)
                endif
c                read(*,*)
            endif
            idhep(3)=6
            idhep(4)=24
            idhep(7)=5
            idhep(8)=-5
         endif

c------ t-channel single top
         if(nproc.ge.231.and.nproc.le.239) then
            phep(1:4,3)=p(3,:)+p(4,:)+p(5,:)
            phep(1:4,4)=p(3,:)+p(4,:)
            phep(1:4,5)=p(3,:)
            phep(1:4,6)=p(4,:)
            phep(1:4,7)=p(5,:)
            phep(1:4,8)=p(6,:)
            phep(1:4,9)=p(7,:)
            if(nhep.eq.10) then
                phep(1:4,10)=p(8,:)
c is 3 a full top?
                pt=phep(1:4,3)
                d1t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=pt+phep(1:4,10)
                d2t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
c                write(*,*) d1t,d2t
                if(d2t.lt.d1t) then
c                   write(*,*) ' t with radiation'
                   phep(1:4,3)=phep(1:4,3)+phep(1:4,10)
                endif
c                read(*,*)
            endif
            idhep(3)=6
            idhep(4)=24
            idhep(7)=5
            idhep(8)=-5
        endif

c------ W-t-single top
         if(nproc.ge.181.and.nproc.le.187) then
            phep(1:4,3)=p(5,:)+p(6,:)+p(7,:)
            phep(1:4,4)=p(5,:)+p(6,:)
            phep(1:4,5)=p(3,:)+p(4,:)
            phep(1:4,6)=p(3,:)
            phep(1:4,7)=p(4,:)
            phep(1:4,8)=p(5,:)
            phep(1:4,9)=p(6,:)
            phep(1:4,10)=p(7,:)
            if(nhep.eq.11) then
                phep(1:4,11)=p(8,:)
c is 3 a full top?
                pt=phep(1:4,3)
                d1t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
                pt=pt+phep(1:4,11)
                d2t=abs(pt(4)**2-pt(1)**2-pt(2)**2-pt(3)**2-mt**2)/mt**2
c                write(*,*) d1t,d2t
                if(d2t.lt.d1t) then
c                   write(*,*) ' t with radiation'
                   phep(1:4,3)=phep(1:4,3)+phep(1:4,11)
                endif
c                read(*,*)
            endif
            idhep(3)=6
            idhep(4)=24
            idhep(5)=-24
            idhep(10)=5
         endif

c------------ FILL HISTOGRAMS

         if(part.ne.'real') then
            call analysis_wrap(wt)
            call pwhgaccumup
         else
            if(nd.eq.0.and.ond.ne.0) then
               call pwhgaccumup
               call analysis_wrap(wt)
            else
               call analysis_wrap(wt)
            endif
            ond=nd
         endif
      endif

      end

      subroutine analysis_wrap(wt)
      implicit none
      double precision wt
      integer nproc
      common/nproc/nproc

         if(nproc.eq.44) then
            write(6,*) 'No analysis routine written for nproc=',nproc
            stop
         elseif(nproc.eq.203) then
            write(6,*) 'No analysis routine written for nproc=',nproc
            stop
         elseif(nproc.ge.31) then
            call analysis_Z(wt)
         elseif(nproc.ge.141.and.nproc.le.151) then
            call analysis_KN(wt)
         elseif(nproc.ge.171.and.nproc.le.177) then
            call analysis_ST_sch_dk(wt)
         elseif(nproc.ge.231.and.nproc.le.239) then
            call analysis_ST_tch_dk(wt)
         elseif(nproc.ge.181.and.nproc.le.186) then
            call analysis_ST_wt_dk(wt)
         else
            write(6,*) 'No analysis routine written for nproc=',nproc
            stop
         endif
      end

      subroutine pwhghistofin(itno,itmx)
      implicit none
      include 'part.f'
      integer itno,itmx
      character *255 runname,outfile
      integer iun, iostat
      common/runname/runname
      parameter (iun=99)

      if(part.eq.'real') then
c     in this case a call to accumup is missin
         call pwhgaccumup
      endif
c finalize histograms
      call pwhgsetout
c mcfm delivered weights divided by n; should now multiply
c by n to get proper normalization. Furthermore, if itno#0
c we should divide by itno; otherwise we should divide by itmx
      if(itno.gt.0) then
         call pwhgfixmcfm(itno)
      else
         call pwhgfixmcfm(itmx)
      endif
c print histograms

      outfile = trim(runname)//'pwg.gdat'
      open(unit=iun,file=outfile,status='unknown',iostat=iostat)
      call pwhgtopout
      close(iun)

      end

      subroutine pwhgfixmcfm(it)
c analysis, leaving the yhistarr1 and errhistarr1 unchanged.
      implicit none
      integer it
      include 'pwhg_bookhist-new.h'
      integer j,k
      real *8 xxx,sum,sumsq
      do j=1,jhist
         xxx=ient1(j)
         xxx=xxx/it
         do k=0,nbins(j)+1
            yhistarr2(k,j)=yhistarr2(k,j)*xxx
            errhistarr2(k,j)=errhistarr2(k,j)*xxx
         enddo
      enddo
      end


subroutine mksekss(iband,jband,ikk,omegap2,xkf,lossfn,fsum, &
& vol,pi,nwpt,wmax,nbcore,nbocc,ncband,ngkpt,natom,xred,projwf,nlmn, &
& pwmatel,tpwmatel, &
& gbig,gbigq,en,enq,wfg,wfgq, &
& npwkss,npwkssq,nbandkss,nbandkssq, &
& kpt,kptq,nkpt,nkptq,nqpt,nsymk,nsymkq,symk,symkq,nsym,nsymq,symrel,syminv, &
& lvtrans,lvtransq,bmet,blat,ipaw, &
& ipwlf,npwlf,ipwndx,npwndx,ntpwndx, &
& npwup,invpw2ndx,pwsymndx,iqsymndx,invpwndx,pwupmin,pwupmax, &
& igkmx,igkmn,igkndx,igkndxq,ikndx,ikndxq,iqndx,isymndx,isymndxq,npw,npwq, &
& shiftk,shiftkq,zz,zzpp,zzcorr,cse,csepp,csecorr,xse)
implicit none
integer :: iband,jband,ikk(3),nwpt,nbcore,nbocc,ncband,ngkpt(3),natom,nlmn
integer :: igkmn(3),igkmx(3)
integer :: nkpt,nkptq,nqpt,nsym,nsymq
integer :: npw,npwq,ipw1,npwlf,npwndx,ntpwndx,ipwa,ipaw
double precision :: vol,pi,wmax,xred(3,natom)
double precision :: omegap2,xkf,ppfct
double complex :: lossfn(nwpt,nqpt,ntpwndx)
double complex :: projwf(natom,nlmn,nkpt,ncband)
integer :: gbig(3,npwkss),gbigq(3,npwkssq)
double precision :: en(nkpt,nbandkss),enq(nkptq,nbandkssq)
double complex :: wfg(npwkss,nbandkss,nkpt),wfgq(npwkssq,nbandkssq,nkptq)
integer :: npwkss,npwkssq,nbandkss,nbandkssq
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))
double precision :: bmet(3,3),blat(3,3)
integer :: ipwlf(3,npwlf),ipwndx(2,ntpwndx)
integer :: igkndx(igkmn(1):igkmx(1),igkmn(2):igkmx(2),igkmn(3):igkmx(3))
integer :: igkndxq(igkmn(1):igkmx(1),igkmn(2):igkmx(2),igkmn(3):igkmx(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))
double complex :: sei,seipw,seiold,seibc,csepw,cseold,csebc
double complex :: xse1,xse2
double complex :: cse(nbcore+1:ncband),cse1(nbcore+1:ncband),cse2(nbcore+1:ncband)
double complex :: csepp(nbcore+1:ncband),cse1pp(nbcore+1:ncband)
double complex :: csecorr(nbcore+1:ncband),cse1corr(nbcore+1:ncband)
double complex :: zz(nbcore+1:ncband),zz1(nbcore+1:ncband),zz2(nbcore+1:ncband)
double complex :: zzpp(nbcore+1:ncband),zz1pp(nbcore+1:ncband)
double complex :: zzcorr(nbcore+1:ncband),zz1corr(nbcore+1:ncband)
double precision :: xse
integer :: ii,jj,kk,ix,iy,iz,iqq(3),iqqp(3),jka(3),jkk(3),iskip,isign,iloss,insd
integer :: ikpt,ikptq,iks(3),ikslf1(3),ikslf2(3)
integer :: pwupmin(3),pwupmax(3)
integer :: igg(3),igpw(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,wwq
double precision :: abr,rlr
double complex :: tseincr,tseincrx,dse,dcse
integer :: iwh,iwl,ibmin,ibmax
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))
integer :: npwup,iipw,jjpw
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwup,npwup), &
& invpwndx(pwupmin(1):pwupmax(1),pwupmin(2):pwupmax(2),pwupmin(3):pwupmax(3))
integer :: pwsymndx(npwup,2*nsym)
integer :: ipw2,jw
double precision :: fsum(npwup,nqpt)
double precision :: eps1(nbcore+1:ncband),eps2,eps
double precision :: eval,brd,esprd
double complex :: cenrgy
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 :: wppint(nbcore+1:ncband),wppint0(nbcore+1:ncband)
double complex :: wpp2int(nbcore+1:ncband),wpp2int0(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,lcorr
double precision :: xdum
double precision :: linterp
external linterp

abr=1.d-6
rlr=1.d-6
sei=0.d0
xse=0.d0
cse=(0.d0,0.d0)
csecorr=(0.d0,0.d0)
zz=(0.d0,0.d0)
igg0=(/0,0,0/)
dw=wmax/dble(nwpt)
ikpt=ikndx(ikk(1),ikk(2),ikk(3))
isym=isymndx(ikk(1),ikk(2),ikk(3))
ek=en(ikpt,iband)

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)

!write(6,'(a)') '      finding contibutions from band:      plane waves:'
do ibp=nbcore+1,ncband
!do ibp=1,1
  xse2=xse
  cse2=cse
  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 ipw1=1,npwkss
!  do ipw1=1,1
    ipw2=ipw1
    igpw=gbig(:,ipw1)
    if (igpw(1).ge.pwupmin(1).and.igpw(1).le.pwupmax(1).and.  &
&       igpw(2).ge.pwupmin(2).and.igpw(2).le.pwupmax(2).and.  &
&       igpw(3).ge.pwupmin(3).and.igpw(3).le.pwupmax(3)) then
      ipwa=invpwndx(igpw(1),igpw(2),igpw(3))
    else
      ipwa=0
    endif
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=2,2
!    do iy=2,2
!    do iz=4,5
      iqq=(/ix,iy,iz/)
      do ii=1,3
        iks(ii)=iqq(ii)-ngkpt(ii)/2
        ikslf1(ii)=iks(ii)+gbig(ii,ipw1)*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)
      else
        call fqq(shiftk,shiftk,ikslf1,ngkpt,qq,qs)
      endif
      qq2=0.d0
      do ii=1,3
      do jj=1,3
        qq2=qq2+qq(ii)*bmet(ii,jj)*qq(jj)
      enddo
      enddo
      vq(ix,iy,iz)=4.d0*pi/qq2
      wwq=sqrt(omegap2+(xkf**2/3.d0)*qq2+qq2**2/4.d0)
!write(6,*) '>>>>> iqq = ',iqq
!write(6,*) 'ikslf1 = ',ikslf1
!write(6,*) 'qq = ',qq
!write(6,*) 'qq2 = ',qq2
!write(6,*) 'vq = ',vq(ix,iy,iz)
      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))
      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,*) 'xck = ',xck
!write(6,*) 'xckq = ',xckq
!write(6,*) 'igg = ',igg
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call mkmatelK(ibp,iband,ikpt,ikptq,igpw,igg, &
&         nkpt,nkptq,igkmx,igkmn,igkndx,igkndxq,npwkss,npwkssq,nbandkss,nbandkssq, &
&         wfg,wfgq,gbig,gbigq, &
&         cmatel)
        if (ipaw.ne.0) then
!*** need to calculate pwmatel for all plane waves
!*** ipw1 indexes full plane wave set, not the local field plane wave set
!*** pwmatel is calculated for
!          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
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-enq(ikptq,ibp)
        else
          omega(ix,iy,iz)=enq(ikptq,ibp)
        endif
      else
        call mkmatelK(ibp,iband,ikpt,ikptq,igpw,igg, &
&         nkpt,nkpt,igkmx,igkmn,igkndx,igkndx,npwkss,npwkss,nbandkss,nbandkss, &
&         wfg,wfg,gbig,gbig, &
&         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
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-en(ikptq,ibp)
        else
          omega(ix,iy,iz)=en(ikptq,ibp)
        endif
      endif
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call mkmatelK(ibp,jband,ikpt,ikptq,igpw,igg, &
&         nkpt,nkptq,igkmx,igkmn,igkndx,igkndxq,npwkss,npwkssq,nbandkss,nbandkssq, &
&         wfg,wfgq,gbig,gbigq, &
&         cmatel2)
        if (ipaw.ne.0) then
!*** need to calculate pwmatel for all plane waves
!*** ipw1 indexes full plane wave set, not the local field plane wave set
!*** pwmatel is calculated for
!          call mkmatelP(pi,xred,natom,ibp,jband,ikpt,ikptq,qq,igg0,ngkpt, &
!&               pwmatel(:,:,ipw1,ix,iy,iz),tpwmatel(:,:,ipw1,ix,iy,iz), &
!&               projwf,nlmn,nkpt,nkptq,ncband,amatel2)
        else
          amatel2=0.d0
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-enq(ikptq,ibp)
        else
          omega(ix,iy,iz)=enq(ikptq,ibp)
        endif
      else
        call mkmatelK(ibp,jband,ikpt,ikptq,igpw,igg, &
&         nkpt,nkpt,igkmx,igkmn,igkndx,igkndx,npwkss,npwkss,nbandkss,nbandkss, &
&         wfg,wfg,gbig,gbig, &
&         cmatel2)
        if (ipaw.ne.0) then
!          call mkmatelP(pi,xred,natom,ibp,jband,ikpt,ikptq,qq,igg0,ngkpt, &
!&               pwmatel(:,:,ipw1,ix,iy,iz),tpwmatel(:,:,ipw1,ix,iy,iz), &
!&               projwf,nlmn,nkpt,nkpt,ncband,amatel2)
        else
          amatel2=0.d0
        endif
        if (ibp.gt.nbocc) then
          omega(ix,iy,iz)=-en(ikptq,ibp)
        else
          omega(ix,iy,iz)=en(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(cmatel+amatel)
      endif
!write(6,*) 'cmatel  = ',cmatel
!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(cmatel*conjg(cmatel))
    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=ibp.le.nbocc
    lcorr=ipwa.ne.0
    if (lx) xse1=(0.d0,0.d0)
    do ie=nbcore+1,ncband
      cse1(ie)=(0.d0,0.d0)
      if (lcorr) cse1corr(ie)=(0.d0,0.d0)
      zz1(ie)=(0.d0,0.d0)
      eps=en(ikpt,ie)
      if (ibp.gt.nbocc) then
        eps1(ie)=eps
      else
        eps1(ie)=-eps
      endif
    enddo
    brd=dw

    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) then
!    if (.true.) 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)
      qq2=4.d0*pi/vq(ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2)
      wwq=sqrt(omegap2+(xkf**2/3.d0)*qq2+qq2**2/4.d0)
      ppfct=pi*omegap2/(2.d0*wwq)
      if (lcorr) then
        call locateelement(iqq,ipwa,ipwa,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
      else
        jjpw=0
      endif
      do ie=nbcore+1,ncband
        eval=omega(iqq(1),iqq(2),iqq(3))+eps1(ie)-wwq
        cenrgy=eval*(1.d0,0.d0)+brd*(0.d0,1.d0)
        wppint0(ie)=dble(ppfct/cenrgy)
        wpp2int0(ie)=-dble(ppfct/cenrgy**2)
        wint0(ie)=(0.d0,0.d0)
        w2int0(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
            cenrgy=eval*(1.d0,0.d0)+brd*(0.d0,1.d0)
            wint0(ie)=wint0(ie)+dw*dimag(lossfn(iw,iqpt,jjpw))/cenrgy
            w2int0(ie)=w2int0(ie)-dw*dimag(lossfn(iw,iqpt,jjpw))/cenrgy**2
          enddo
        endif
      enddo
    else
      iqsing=0
    endif
    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
      iqq=(/ix,iy,iz/)
      iqpt=iqndx(ix,iy,iz)
!      call fespread(iqq,ngkpt,omega,esprd)
!      brd=3*max(esprd,dw)
!write(6,'(3i3,es20.10)') ix,iy,iz,esprd*27.2114
      qq2=4.d0*pi/vq(ix,iy,iz)
      wwq=sqrt(omegap2+(xkf**2/3.d0)*qq2+qq2**2/4.d0)
      ppfct=pi*omegap2/(2.d0*wwq)
      if (lcorr) then
        call locateelement(iqq,ipwa,ipwa,ngkpt,iqsymndx,npwup,nsym,pwsymndx,invpw2ndx,jjpw)
      else
        jjpw=0
      endif
      do ie=nbcore+1,ncband
        eval=omega(ix,iy,iz)+eps1(ie)-wwq
        cenrgy=eval*(1.d0,0.d0)+brd*(0.d0,1.d0)
        wppint(ie)=ppfct/cenrgy
        wpp2int(ie)=-ppfct/cenrgy**2
        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
            cenrgy=eval*(1.d0,0.d0)+brd*(0.d0,1.d0)
            wint(ie)=wint(ie)+dw*dimag(lossfn(iw,iqpt,jjpw))/cenrgy
            w2int(ie)=w2int(ie)-dw*dimag(lossfn(iw,iqpt,jjpw))/cenrgy**2
          enddo
        endif
      enddo
      if (iqsing.eq.0) then
        if (lx) xse1=xse1+vqmat2(ix,iy,iz)
        cse1pp=cse1pp+wppint*vqmat2(ix,iy,iz)
        zz1pp=zz1pp+wpp2int*vqmat2(ix,iy,iz)
        if (lcorr) then
          cse1=cse1+wint*vqmat2(ix,iy,iz)
          zz1=zz1+w2int*vqmat2(ix,iy,iz)
          cse1corr=cse1corr &
&                +wppint*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt))
          zz1corr=zz1corr &
&                +wpp2int*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt))
        endif
      else
        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)
          cse1pp=cse1pp+wppint*vqmat2(ix,iy,iz)-wppint0*gterm*vq(ix,iy,iz)
          zz1pp=zz1pp+wpp2int*vqmat2(ix,iy,iz)-wpp2int0*gterm*vq(ix,iy,iz)
          if (lcorr) then
            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)
            cse1corr=cse1corr &
&                 +wppint*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt)) &
&                 -wppint0*gterm*vq(ix,iy,iz)*(1.d0-fsum(ipwa,1))
            zz1corr=zz1corr &
&                 +wpp2int*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt)) &
&                 -wpp2int0*gterm*vq(ix,iy,iz)*(1.d0-fsum(ipwa,1))
          endif
        else
          if (lx) xse1=xse1+vqmat2(ix,iy,iz)
          cse1pp=cse1pp+wppint*vqmat2(ix,iy,iz)
          zz1pp=zz1pp+wpp2int*vqmat2(ix,iy,iz)
          if (lcorr) then
            cse1=cse1+wint*vqmat2(ix,iy,iz)
            zz1=zz1+w2int*vqmat2(ix,iy,iz)
            cse1corr=cse1corr &
&                 +wppint*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt))
            zz1corr=zz1corr &
&                 +wpp2int*vqmat2(ix,iy,iz)*(1.d0-fsum(ipwa,iqpt))
          endif
        endif
      endif
    enddo
    enddo
    enddo
    if (lx) xse1=xse1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol)
    cse1pp=cse1pp/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    zz1pp=zz1pp/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    if (lcorr) then
      cse1=cse1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
      zz1=zz1/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
      cse1corr=cse1corr/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
      zz1pp=zz1pp/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    endif
    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)
      cse1pp=cse1pp+wppint0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
      zz1pp=zz1pp+wpp2int0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)
      if (lcorr) then
        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)
        cse1corr=cse1corr+ &
&         wppint0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)*(1.d0-fsum(ipwa,1))
        zz1corr=zz1corr+ &
&         wpp2int0*cmgamma2*8.d0*pi*pi*gfo/(pi*(2.d0*pi)**3)*(1.d0-fsum(ipwa,1))
      endif
    endif
    if (lx) xse1=-xse1
    cse1pp=-cse1pp*isign
    if (lcorr) then
      cse1=-cse1*isign
      zz1=-zz1*isign
      cse1corr=-cse1corr*isign
      zz1corr=-zz1corr*isign
    endif
    if (lx) xse=xse+dble(xse1)
    csepp=csepp+cse1pp
    if (lcorr) then
      cse=cse+cse1
      zz=zz+zz1
      csecorr=csecorr+cse1corr
      zzcorr=zzcorr+zz1corr
    endif
!if (lx) then
!  write(33,'(i4,4x,i5,3x,3i3,5x,"(",f10.6,",",f10.6,")",5x,f10.6)') &
!&        ibp,ipw1,gbig(ii,ipw1),cse1*27.2114,dble(xse1)*27.2114
!else
!  write(33,'(i4,4x,i5,3x,3i3,5x,"(",f10.6,",",f10.6,")")') &
!&        ibp,ipw1,gbig(ii,ipw1),cse1*27.2114
!endif
  enddo
!  if (lx) then
!    write(6,'(i4,5x,"(",f10.6,",",f10.6,")",5x,f10.6)') ibp,(cse(4)-cse2(4))*27.2114,dble(xse-xse2)*27.2114
!  else
!    write(6,'(i4,5x,"(",f10.6,",",f10.6,")",f10.6)') ibp,(cse(4)-cse2(4))*27.2114
!  endif
enddo

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

return
end subroutine mksekss

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

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

insd=0
e0=omega(iqq(1),iqq(2),iqq(3))
do ix=0,1
do iy=0,1
do iz=0,1
  iqp=mod(iqq+(/ix,iy,iz/)-1+ngkpt,ngkpt)+1
  e1=omega(iqp(1),iqp(2),iqp(3))
  if (e0*e1.lt.0.d0) insd=1
enddo
enddo
enddo

return
end subroutine tebound2

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

subroutine mkmatelK(ibp,iband,ikpt,ikptq,igglf,igg, &
& nkpt,nkptq,igkmx,igkmn,igkndx,igkndxq,npwkss,npwkssq,nbandkss,nbandkssq, &
& wfg,wfgq,gbig,gbigq, &
& cmatel)
implicit none
integer :: ibp,iband,ikpt,ikptq,nkpt,nkptq,igg(3)
integer :: gbig(3,npwkss),gbigq(3,npwkssq)
integer :: npwkss,npwkssq,nbandkss,nbandkssq
integer :: igkmx(3),igkmn(3)
integer :: igkndx(igkmn(1):igkmx(1),igkmn(2):igkmx(2),igkmn(3):igkmx(3))
integer :: igkndxq(igkmn(1):igkmx(1),igkmn(2):igkmx(2),igkmn(3):igkmx(3))
double complex :: wfg(npwkss,nbandkss,nkpt),wfgq(npwkssq,nbandkssq,nkptq)
double complex :: cmatel,xcg,xcgq
integer :: ig,igr,ii,jj,igq,igo
integer :: iggi(3),iggr(3),iggq(3),iggqr(3),igglf(3)
! iggi  - initial lattice vector of kpt
! iggq  - lattice vector of k-q point

cmatel=(0.d0,0.d0)
l1: do ig=1,npwkss
  xcg=wfg(ig,iband,ikpt)
  iggi(1:3)=gbig(:,ig)
  do ii=1,3
    iggq(ii)=iggi(ii)-igg(ii)-igglf(ii)
  enddo
  do ii=1,3
    if (iggq(ii).lt.igkmn(ii).or.iggq(ii).gt.igkmx(ii)) cycle l1
  enddo
  igq=igkndxq(iggq(1),iggq(2),iggq(3))
  if (igq.eq.0) cycle
  xcgq=wfgq(igq,ibp,ikptq)
  cmatel=cmatel+xcg*conjg(xcgq)
enddo l1

return
end subroutine mkmatelK

!**************************************************************************
! 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(lossfn(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(lossfn(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(lossfn(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(lossfn(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


      subroutine stokestrace
c******************************************************************************
c     This program can synthesize the full stokes parameters for multiple
c     sections of spectra for multiple input model atmospheres
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Factor.com'
      include 'Mol.com'
      include 'Linex.com'
      include 'Pstuff.com'
      include 'Stokes.com'
      include 'Angles.com'

      zeros(1,1) = 0.0
      zeros(1,2) = 0.0
      zeros(1,3) = 0.0
      zeros(2,1) = 0.0
      zeros(2,2) = 0.0
      zeros(2,3) = 0.0
      zeros(3,1) = 0.0
      zeros(3,2) = 0.0
      zeros(3,3) = 0.0

c*****examine the parameter file
      call params
      linfileopt = 2
      linprintopt = linprintalt

c*****open and read the model atmosphere file
      nfmodel = 30
c      lscreen = lscreen + 2
      array = 'THE MODEL ATMOSPHERE'
      nchars = 20
      call infile ('input  ',nfmodel,'formatted  ',0,nchars,
     .             fmodel,lscreen)
      call inmodel

c*****open the line list file and the strong line list file
      nflines = 31
c      lscreen = lscreen + 2
      array = 'THE LINE LIST'
      nchars = 13
      call infile ('input  ',nflines,'formatted  ',0,nchars,
     .              flines,lscreen)
      if (dostrong .gt. 0) then
         nfslines = 32
c         lscreen = lscreen + 2
         array = 'THE STRONG LINE LIST'
         nchars = 20
         call infile ('input  ',nfslines,'formatted  ',0,nchars,
     .                 fslines,lscreen)
      endif

      B_sph(1) = 1.0
      B_sph(2) = 0.0
      B_sph(3) = 0.0

      B_xyz(1) = 0.0
      B_xyz(2) = 0.0
      B_xyz(3) = 0.0

      start = oldstart
      isynth = 1
      call wavegrid
c*****Read in the line list and calculate the equilibria
      call inlines (1)
      call eqlib
      call nearly (1)

c***** Calculate zdepth, the physical depth scale
      call spl_def(ntau, xref, kapref, kref_knots, n_kref_knots,
     .             kref_coeffs)
      nz = 1
      dtau = 0.05
      do ztau = xref(1), xref(ntau), dtau
          if (nz.eq.1) then
              zdepth(nz) = 0.0
          else
              h1=1.0/spl_ev(kref_knots, n_kref_knots, kref_coeffs,
     .                      ztau)
              h2=1.0/spl_ev(kref_knots, n_kref_knots, kref_coeffs,
     .                      ztau-dtau)
              dt = (10.0**ztau-10.0**(ztau-dtau))
              zdepth(nz) = zdepth(nz-1)+(h1+h2)/2.0*dt
          endif
          taus(nz) = ztau
          nz=nz+1
      enddo
      taus(nz) = xref(ntau)
      h2=1.0/kapref(ntau)
      dt = 10.0**taus(nz)-10.0**taus(nz-1)
      zdepth(nz) = zdepth(nz-1)+(h2+h1)/2.0*dt
      call spl_def(nz, taus, zdepth, z_knots, n_z_knots, z_coeffs)

      curr_strong = 1
      curr_weak = 1
c*****Perform the Synthesis
      wavl = 0.
      mode = 3
      wave = dipstickwave
30    if (dabs(wave-wavl)/wave .ge. 0.001) then
         wavl = wave
         call opacit (2,wave)
      endif
20    call linlimit
      if (lim2line .lt. 0) then
          call inlines(2)
          call nearly (1)
          go to 20
      endif
      lim1 = lim1line
      lim2 = lim2line
      call calcopacities
      call stokesdipstick(dble(0.0), dble(0.0), dble(1.0))

c*****finish
      call finish (0)

c1001  format (a80)
c12345 format (f10.4,5e15.5)
12346 format (i5,8e16.5)
12347 format (2i5,2e16.5)
12348 format (i5)
12349 format (i5,2e16.5)
6520  format (f10.4)
6521  format (e16.8)
      end


!     path:      $Source$
!     author:    $Author: miacono $
!     revision:  $Revision: 29812 $
!     created:   $Date: 2016-09-02 17:01:49 -0400 (Fri, 02 Sep 2016) $
!
      module rrtmg_sw_vrtqdr

!----------------------------------------------------------------------------
! Copyright (c) 2002-2016, Atmospheric & Environmental Research, Inc. (AER)
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!  * Redistributions of source code must retain the above copyright
!    notice, this list of conditions and the following disclaimer.
!  * Redistributions in binary form must reproduce the above copyright
!    notice, this list of conditions and the following disclaimer in the
!    documentation and/or other materials provided with the distribution.
!  * Neither the name of Atmospheric & Environmental Research, Inc., nor
!    the names of its contributors may be used to endorse or promote products
!    derived from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL ATMOSPHERIC & ENVIRONMENTAL RESEARCH, INC.,
! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF
! THE POSSIBILITY OF SUCH DAMAGE.
!                        (http://www.rtweb.aer.com/)
!----------------------------------------------------------------------------

! ------- Modules -------

      use parkind, only: im => kind_im, rb => kind_rb
!      use parrrsw, only: ngptsw

      implicit none

      contains

! --------------------------------------------------------------------------
      subroutine vrtqdr_sw(klev, kw, &
                           pref, prefd, ptra, ptrad, &
                           pdbt, prdnd, prup, prupd, ptdbt, &
                           pfd, pfu)
! --------------------------------------------------------------------------

! Purpose: This routine performs the vertical quadrature integration
!
! Interface:  *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw*
!
! Modifications.
!
! Original: H. Barker
! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002
! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006
!
!-----------------------------------------------------------------------

! ------- Declarations -------

! Input

      integer(kind=im), intent (in) :: klev                   ! number of model layers
      integer(kind=im), intent (in) :: kw                     ! g-point index

      real(kind=rb), intent(in) :: pref(:)                    ! direct beam reflectivity
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(in) :: prefd(:)                   ! diffuse beam reflectivity
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(in) :: ptra(:)                    ! direct beam transmissivity
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(in) :: ptrad(:)                   ! diffuse beam transmissivity
                                                              !   Dimensions: (nlayers+1)

      real(kind=rb), intent(in) :: pdbt(:)
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(in) :: ptdbt(:)
                                                              !   Dimensions: (nlayers+1)

      real(kind=rb), intent(inout) :: prdnd(:)
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(inout) :: prup(:)
                                                              !   Dimensions: (nlayers+1)
      real(kind=rb), intent(inout) :: prupd(:)
                                                              !   Dimensions: (nlayers+1)

! Output
      real(kind=rb), intent(out) :: pfd(:,:)                  ! downwelling flux (W/m2)
                                                              !   Dimensions: (nlayers+1,ngptsw)
                                                              ! unadjusted for earth/sun distance or zenith angle
      real(kind=rb), intent(out) :: pfu(:,:)                  ! upwelling flux (W/m2)
                                                              !   Dimensions: (nlayers+1,ngptsw)
                                                              ! unadjusted for earth/sun distance or zenith angle

! Local

      integer(kind=im) :: ikp, ikx, jk

      real(kind=rb) :: zreflect
      real(kind=rb) :: ztdn(klev+1)

! Definitions
!
! pref(jk)   direct reflectance
! prefd(jk)  diffuse reflectance
! ptra(jk)   direct transmittance
! ptrad(jk)  diffuse transmittance
!
! pdbt(jk)   layer mean direct beam transmittance
! ptdbt(jk)  total direct beam transmittance at levels
!
!-----------------------------------------------------------------------------

! Link lowest layer with surface

      zreflect = 1._rb / (1._rb - prefd(klev+1) * prefd(klev))
      prup(klev) = pref(klev) + (ptrad(klev) * &
                 ((ptra(klev) - pdbt(klev)) * prefd(klev+1) + &
                   pdbt(klev) * pref(klev+1))) * zreflect
      prupd(klev) = prefd(klev) + ptrad(klev) * ptrad(klev) * &
                    prefd(klev+1) * zreflect

! Pass from bottom to top

      do jk = 1,klev-1
         ikp = klev+1-jk
         ikx = ikp-1
         zreflect = 1._rb / (1._rb -prupd(ikp) * prefd(ikx))
         prup(ikx) = pref(ikx) + (ptrad(ikx) * &
                   ((ptra(ikx) - pdbt(ikx)) * prupd(ikp) + &
                     pdbt(ikx) * prup(ikp))) * zreflect
         prupd(ikx) = prefd(ikx) + ptrad(ikx) * ptrad(ikx) * &
                      prupd(ikp) * zreflect
      enddo

! Upper boundary conditions

      ztdn(1) = 1._rb
      prdnd(1) = 0._rb
      ztdn(2) = ptra(1)
      prdnd(2) = prefd(1)

! Pass from top to bottom

      do jk = 2,klev
         ikp = jk+1
         zreflect = 1._rb / (1._rb - prefd(jk) * prdnd(jk))
         ztdn(ikp) = ptdbt(jk) * ptra(jk) + &
                    (ptrad(jk) * ((ztdn(jk) - ptdbt(jk)) + &
                     ptdbt(jk) * pref(jk) * prdnd(jk))) * zreflect
         prdnd(ikp) = prefd(jk) + ptrad(jk) * ptrad(jk) * &
                      prdnd(jk) * zreflect
      enddo

! Up and down-welling fluxes at levels

      do jk = 1,klev+1
         zreflect = 1._rb / (1._rb - prdnd(jk) * prupd(jk))
         pfu(jk,kw) = (ptdbt(jk) * prup(jk) + &
                      (ztdn(jk) - ptdbt(jk)) * prupd(jk)) * zreflect
         pfd(jk,kw) = ptdbt(jk) + (ztdn(jk) - ptdbt(jk)+ &
                      ptdbt(jk) * prup(jk) * prdnd(jk)) * zreflect
      enddo

      end subroutine vrtqdr_sw

      end module rrtmg_sw_vrtqdr


!-----------------------BEGIN NOTICE -- DO NOT EDIT-----------------------
! NASA Goddard Space Flight Center
! Land Information System Framework (LISF)
! Version 7.3
!
! Copyright (c) 2020 United States Government as represented by the
! Administrator of the National Aeronautics and Space Administration.
! All Rights Reserved.
!-------------------------END NOTICE -- DO NOT EDIT-----------------------
!
! CRTM_MW_Land_SfcOptics
!
! Module to compute the surface optical properties for LAND surfaces at
! microwave frequencies required for determining the LAND surface
! contribution to the radiative transfer.
!
! This module is provided to allow developers to "wrap" their existing
! codes inside the provided functions to simplify integration into
! the main CRTM_SfcOptics module.
!
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 23-Jun-2005
!                       paul.vandelst@ssec.wisc.edu
!

MODULE CRTM_MW_Land_SfcOptics

  ! -----------------
  ! Environment setup
  ! -----------------
  ! Module use
  USE Type_Kinds,               ONLY: fp
  USE Message_Handler,          ONLY: SUCCESS
  USE CRTM_Parameters,          ONLY: ZERO, ONE, MAX_N_ANGLES
  USE CRTM_SpcCoeff,            ONLY: SC
  USE CRTM_Surface_Define,      ONLY: CRTM_Surface_type
  USE CRTM_GeometryInfo_Define, ONLY: CRTM_GeometryInfo_type
  USE CRTM_SfcOptics_Define,    ONLY: CRTM_SfcOptics_type
  USE NESDIS_LandEM_Module,     ONLY: NESDIS_LandEM2
  ! Disable implicit typing
  IMPLICIT NONE

  ! ------------
  ! Visibilities
  ! ------------
  ! Everything private by default
  PRIVATE
  ! Data types
  PUBLIC :: MWLSOVariables_type
  ! Science routines
  PUBLIC :: Compute_MW_Land_SfcOptics
  PUBLIC :: Compute_MW_Land_SfcOptics_TL
  PUBLIC :: Compute_MW_Land_SfcOptics_AD

  ! -----------------
  ! Module parameters
  ! -----------------
  ! RCS Id for the module
  CHARACTER(*), PRIVATE, PARAMETER :: MODULE_RCS_ID = &
  '$Id: CRTM_MW_Land_SfcOptics.f90 7080 2010-03-15 17:19:38Z david.groff@noaa.gov $'

  ! --------------------------------------
  ! Structure definition to hold forward
  ! variables across FWD, TL, and AD calls
  ! --------------------------------------
  TYPE :: MWLSOVariables_type
    PRIVATE
    INTEGER :: Dummy = 0
  END TYPE MWLSOVariables_type

CONTAINS

!----------------------------------------------------------------------------------
!
! NAME:
!       Compute_MW_Land_SfcOptics
!
! PURPOSE:
!       Function to compute the surface emissivity and reflectivity at microwave
!       frequencies over a land surface.
!
!       This function is a wrapper for third party code.
!
! CALLING SEQUENCE:
!       Error_Status = Compute_MW_Land_SfcOptics( Surface               , &  ! Input
!                                                 GeometryInfo          , &  ! Input
!                                                 SensorIndex           , &  ! Input
!                                                 ChannelIndex          , &  ! Output
!                                                 SfcOptics             , &  ! Output
!                                                 MWLSOVariables        , &  ! Internal variable output
!                                                 Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Surface:         CRTM_Surface structure containing the surface state
!                        data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_Surface_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       GeometryInfo:    CRTM_GeometryInfo structure containing the
!                        view geometry information.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_GeometryInfo_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:     Character string specifying a filename in which any
!                        messages will be logged. If not specified, or if an
!                        error occurs opening the log file, the default action
!                        is to output messages to standard output.
!                        UNITS:      None
!                        TYPE:       CHARACTER(*)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OUTPUT ARGUMENTS:
!       SfcOptics:       CRTM_SfcOptics structure containing the surface
!                        optical properties required for the radiative
!                        transfer calculation. On input the Angle component
!                        is assumed to contain data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_SfcOptics_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
!       MWLSOVariables:  Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of the CRTM_MW_Land_SfcOptics module.
!                        UNITS:      N/A
!                        TYPE:       MWLSOVariables_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(OUT)
!
! FUNCTION RESULT:
!       Error_Status:    The return value is an integer defining the error status.
!                        The error codes are defined in the Message_Handler module.
!                        If == SUCCESS the computation was sucessful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the output SfcOptics argument is IN OUT rather
!       than just OUT as it is assumed to contain some data upon input.
!
!----------------------------------------------------------------------------------

  FUNCTION Compute_MW_Land_SfcOptics( Surface     , &  ! Input
                                      GeometryInfo, &  ! Input
                                      SensorIndex , &  ! Input
                                      ChannelIndex, &  ! Input
                                      SfcOptics   , &  ! Output
                                      MWLSOV      , &  ! Internal variable output
                                      Message_Log ) &  ! Error messaging
                                    RESULT ( Error_Status )
    ! Arguments
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_GeometryInfo_type), INTENT(IN)     :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics
    TYPE(MWLSOVariables_type),    INTENT(IN OUT) :: MWLSOV
    CHARACTER(*), OPTIONAL,       INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_MW_Land_SfcOptics'
    REAL(fp),     PARAMETER :: FREQUENCY_CUTOFF   = 200.0_fp  ! GHz
    REAL(fp),     PARAMETER :: DEFAULT_EMISSIVITY = 0.95_fp
    ! Local variables
    INTEGER :: i

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS

    ! --------------------------------------
    ! Compute the surface optical parameters
    ! --------------------------------------
    IF ( SC(SensorIndex)%Frequency(ChannelIndex) < FREQUENCY_CUTOFF ) THEN
      ! Frequency is low enough for the model
      DO i = 1, SfcOptics%n_Angles
!YDT        CALL NESDIS_LandEM(SfcOptics%Angle(i),            & ! Input, Degree
!                           SC(SensorIndex)%Frequency(ChannelIndex),   & ! Input, GHz
!                           Surface%Soil_Moisture_Content, & ! Input, g.cm^-3
!                           Surface%Vegetation_Fraction,   & ! Input
!                           Surface%Soil_Temperature,      & ! Input, K
!                           Surface%Land_Temperature,      & ! Input, K
!                           ZERO,                          & ! Input, Snow depth, mm
!                           SfcOptics%Emissivity(i,2),     & ! Output, H component
!                           SfcOptics%Emissivity(i,1)      ) ! Output, V component
        CALL NESDIS_LandEM2(SfcOptics%Angle(i),            & ! Input, Degree
                           SC(SensorIndex)%Frequency(ChannelIndex),   & ! Input, GHz
                           Surface,                          & ! Input
                           SfcOptics%Emissivity(i,2),     & ! Output, H component
                           SfcOptics%Emissivity(i,1)      ) ! Output, V component

        ! Assume specular surface
        SfcOptics%Reflectivity(i,1,i,1) = ONE-SfcOptics%Emissivity(i,1)
        SfcOptics%Reflectivity(i,2,i,2) = ONE-SfcOptics%Emissivity(i,2)
      END DO
    ELSE
      ! Frequency is too high for model. Use default.
      DO i = 1, SfcOptics%n_Angles
        SfcOptics%Emissivity(i,1:2)           = DEFAULT_EMISSIVITY
        SfcOptics%Reflectivity(i,1:2,i,1:2) = ONE-DEFAULT_EMISSIVITY
      END DO
    END IF

  END FUNCTION Compute_MW_Land_SfcOptics

!----------------------------------------------------------------------------------
!
! NAME:
!       Compute_MW_Land_SfcOptics_TL
!
! PURPOSE:
!       Function to compute the tangent-linear surface emissivity and
!       reflectivity at microwave frequencies over a land surface.
!
!       This function is a wrapper for third party code.
!
! CALLING SEQUENCE:
!       Error_Status = Compute_MW_Land_SfcOptics_TL( Surface               , &  ! Input
!                                                    SfcOptics             , &  ! Input
!                                                    Surface_TL            , &  ! Input
!                                                    GeometryInfo          , &  ! Input
!                                                    SensorIndex           , &  ! Input
!                                                    ChannelIndex          , &  ! Output
!                                                    SfcOptics_TL          , &  ! Output
!                                                    MWLSOVariables        , &  ! Internal variable input
!                                                    Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Surface:         CRTM_Surface structure containing the surface state
!                        data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_Surface_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       Surface_TL:      CRTM_Surface structure containing the tangent-linear
!                        surface state data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_Surface_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SfcOptics:       CRTM_SfcOptics structure containing the surface
!                        optical properties required for the radiative
!                        transfer calculation.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_SfcOptics_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       GeometryInfo:    CRTM_GeometryInfo structure containing the
!                        view geometry information.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_GeometryInfo_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       MWLSOVariables:  Structure containing internal variables required for
!                        subsequent tangent-linear or adjoint model calls.
!                        The contents of this structure are NOT accessible
!                        outside of the CRTM_MW_Land_SfcOptics module.
!                        UNITS:      N/A
!                        TYPE:       MWLSOVariables_type
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:     Character string specifying a filename in which any
!                        messages will be logged. If not specified, or if an
!                        error occurs opening the log file, the default action
!                        is to output messages to standard output.
!                        UNITS:      None
!                        TYPE:       CHARACTER(*)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OUTPUT ARGUMENTS:
!       SfcOptics_TL:    CRTM_SfcOptics structure containing the tangent-linear
!                        surface optical properties required for the tangent-
!                        linear radiative transfer calculation.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_SfcOptics_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       Error_Status:    The return value is an integer defining the error status.
!                        The error codes are defined in the Message_Handler module.
!                        If == SUCCESS the computation was sucessful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the output SfcOptics_TL argument is IN OUT rather
!       than just OUT. This is necessary because the argument may be defined
!       upon input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!----------------------------------------------------------------------------------

  FUNCTION Compute_MW_Land_SfcOptics_TL( Surface     , &  ! Input
                                         SfcOptics   , &  ! Input
                                         Surface_TL  , &  ! Input
                                         GeometryInfo, &  ! Input
                                         SensorIndex , &  ! Input
                                         ChannelIndex, &  ! Input
                                         SfcOptics_TL, &  ! Output
                                         MWLSOV      , &  ! Internal variable input
                                         Message_Log )  &  ! Error messaging
                                       RESULT ( Error_Status )
    ! Arguments
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface_TL
    TYPE(CRTM_SfcOptics_type),    INTENT(IN)     :: SfcOptics
    TYPE(CRTM_GeometryInfo_type), INTENT(IN)     :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics_TL
    TYPE(MWLSOVariables_type),    INTENT(IN)     :: MWLSOV
    CHARACTER(*), OPTIONAL,       INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_MW_Land_SfcOptics_TL'
    ! Local variables

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS

    ! -----------------------------------------------------
    ! Compute the tangent-linear surface optical parameters
    !
    ! ***No TL models yet, so default TL output is zero***
    ! -----------------------------------------------------
    SfcOptics_TL%Reflectivity = ZERO
    SfcOptics_TL%Emissivity   = ZERO

  END FUNCTION Compute_MW_Land_SfcOptics_TL

!----------------------------------------------------------------------------------
!
! NAME:
!       Compute_MW_Land_SfcOptics_AD
!
! PURPOSE:
!       Function to compute the adjoint surface emissivity and
!       reflectivity at microwave frequencies over a land surface.
!
!       This function is a wrapper for third party code.
!
! CALLING SEQUENCE:
!       Error_Status = Compute_MW_Land_SfcOptics_AD( Surface               , &  ! Input
!                                                    SfcOptics             , &  ! Input
!                                                    SfcOptics_AD          , &  ! Input
!                                                    GeometryInfo          , &  ! Input
!                                                    SensorIndex           , &  ! Input
!                                                    ChannelIndex          , &  ! Output
!                                                    Surface_AD            , &  ! Output
!                                                    MWLSOVariables        , &  ! Internal variable input
!                                                    Message_Log=Message_Log )  ! Error messaging
!
! INPUT ARGUMENTS:
!       Surface:         CRTM_Surface structure containing the surface state
!                        data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_Surface_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SfcOptics:       CRTM_SfcOptics structure containing the surface
!                        optical properties required for the radiative
!                        transfer calculation.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_SfcOptics_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SfcOptics_AD:    CRTM_SfcOptics structure containing the adjoint
!                        surface optical properties required for the adjoint
!                        radiative transfer calculation.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_SfcOptics_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
!       GeometryInfo:    CRTM_GeometryInfo structure containing the
!                        view geometry information.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_GeometryInfo_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       SensorIndex:     Sensor index id. This is a unique index associated
!                        with a (supported) sensor used to access the
!                        shared coefficient data for a particular sensor.
!                        See the ChannelIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
!       ChannelIndex:    Channel index id. This is a unique index associated
!                        with a (supported) sensor channel used to access the
!                        shared coefficient data for a particular sensor's
!                        channel.
!                        See the SensorIndex argument.
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN)
!
! OPTIONAL INPUT ARGUMENTS:
!       Message_Log:     Character string specifying a filename in which any
!                        messages will be logged. If not specified, or if an
!                        error occurs opening the log file, the default action
!                        is to output messages to standard output.
!                        UNITS:      None
!                        TYPE:       CHARACTER(*)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN), OPTIONAL
!
! OUTPUT ARGUMENTS:
!       Surface_AD:      CRTM_Surface structure containing the adjoint
!                        surface state data.
!                        UNITS:      N/A
!                        TYPE:       TYPE(CRTM_Surface_type)
!                        DIMENSION:  Scalar
!                        ATTRIBUTES: INTENT(IN OUT)
!
! FUNCTION RESULT:
!       Error_Status:    The return value is an integer defining the error status.
!                        The error codes are defined in the Message_Handler module.
!                        If == SUCCESS the computation was sucessful
!                           == FAILURE an unrecoverable error occurred
!                        UNITS:      N/A
!                        TYPE:       INTEGER
!                        DIMENSION:  Scalar
!
! COMMENTS:
!       Note the INTENT on the input SfcOptics_AD argument is IN OUT rather
!       than just OUT. This is necessary because components of this argument
!       may need to be zeroed out upon output.
!
!       Note the INTENT on the output Surface_AD argument is IN OUT rather
!       than just OUT. This is necessary because the argument may be defined
!       upon input. To prevent memory leaks, the IN OUT INTENT is a must.
!
!----------------------------------------------------------------------------------

  FUNCTION Compute_MW_Land_SfcOptics_AD( Surface     , &  ! Input
                                         SfcOptics   , &  ! Input
                                         SfcOptics_AD, &  ! Input
                                         GeometryInfo, &  ! Input
                                         SensorIndex , &  ! Input
                                         ChannelIndex, &  ! Input
                                         Surface_AD  , &  ! Output
                                         MWLSOV      , &  ! Internal variable input
                                         Message_Log ) &  ! Error messaging
                                       RESULT ( Error_Status )
    ! Arguments
    TYPE(CRTM_Surface_type),      INTENT(IN)     :: Surface
    TYPE(CRTM_SfcOptics_type),    INTENT(IN)     :: SfcOptics
    TYPE(CRTM_SfcOptics_type),    INTENT(IN OUT) :: SfcOptics_AD
    TYPE(CRTM_GeometryInfo_type), INTENT(IN)     :: GeometryInfo
    INTEGER,                      INTENT(IN)     :: SensorIndex
    INTEGER,                      INTENT(IN)     :: ChannelIndex
    TYPE(CRTM_Surface_type),      INTENT(IN OUT) :: Surface_AD
    TYPE(MWLSOVariables_type),    INTENT(IN)     :: MWLSOV
    CHARACTER(*), OPTIONAL,       INTENT(IN)     :: Message_Log
    ! Function result
    INTEGER :: Error_Status
    ! Local parameters
    CHARACTER(*), PARAMETER :: ROUTINE_NAME = 'Compute_MW_Land_SfcOptics_AD'
    ! Local variables

    ! ------
    ! Set up
    ! ------
    Error_Status = SUCCESS

    ! ----------------------------------------------
    ! Compute the adjoint surface optical parameters
    !
    ! ***No AD models yet, so there is no impact on AD result***
    ! ----------------------------------------------
    SfcOptics_AD%Reflectivity = ZERO
    SfcOptics_AD%Emissivity   = ZERO

  END FUNCTION Compute_MW_Land_SfcOptics_AD

END MODULE CRTM_MW_Land_SfcOptics