subroutine mk2cse(iband,ikk,lossfn, &
& 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, &
& ipwx,ipwndx,npwndx,ntpwndx,napwndx, &
& npwc,npwx,invpw2ndx,pwsymndx,iqsymndx, &
& igmx,igmn,igndx,igndxq,ikndx,ikndxq,iqndx,isymndx,isymndxq,npw,npwq, &
& nband,nbandq,nsppol,shiftk,shiftkq,zz,cse,xse)
implicit none
integer :: iband,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,npwc,npwx,npwq,ipw1,npwndx,ntpwndx,napwndx,ipaw
double precision :: vol,pi,wmax,xred(3,natom)
double complex :: lossfn(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 :: ipwx(3,npwx),ipwndx(2,napwndx)
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, allocatable :: ssi(:)
double complex :: ssc(-nwpt:nwpt),cse,dcse,cse1(-nwpt:nwpt),zz,ctest,cse2(-nwpt:nwpt)
double precision :: xse,ssx,ssx1,ssx2,xse2
integer :: ii,jj,kk,ix,iy,iz,iskip,isign
integer :: iqq(3),iqqp(3),jka(3),jkb(3),jkk(3),iqv(3),ictr(3)
integer :: ikpt,ikptq,iks(3),ikslf1(3),ikslf2(3)
integer :: igg(3),igh(3),igg0(3),isym,isymq,ibp,iqpt,iqsym,iw,iww,ie,je,ies
double precision :: xck(3),xckq(3),qadj(6)
double complex :: cmatel,cmatel2,amatel,amatel2,vqmat2(ngkpt(1),ngkpt(2),ngkpt(3))
double complex :: vfactor(ngkpt(1),ngkpt(2),ngkpt(3),nwpt),vfv(8,nwpt),vfx(8)
double precision :: vq2(8),vqvtx0(4),vqvtx(4),qkcvt(3,3)
double precision :: omega(ngkpt(1),ngkpt(2),ngkpt(3))
double precision :: whi,wlo,wwhi,wwlo,ww,www,enval(8),dw,eshift,evtx0(4),evtx(4)
double precision :: rrpyr(3,4),vpyr0(4,nwpt),kvtx(3,4),xk(3,4),rg(3,3),tvol,vpyr(4),xpyr0(4),xpyr(4)
double precision :: de21,de31,de32,de41,de42,de43,thresh
double precision :: fbx(4),fb(4),cmx(3,4),cm(3,4),xkt(3,3)
double precision :: aa0(nwpt),av(3,nwpt),xme,xv(3)
double precision :: avec(3),bgrad(3),xmult
double precision :: abr,rlr
integer :: iwh,iwl,ibmin,ibmax,iwhi,iwlo,iehi,ielo
integer :: indxe(4),iwwhi,iwwlo
double precision :: vq(ngkpt(1),ngkpt(2),ngkpt(3)),qq(3),qp(3),qq2,qp2,qs(3),ek,ekmq
double precision :: stvec(ngkpt(3)),stvec2(ngkpt(3)),temparray(ngkpt(1),ngkpt(2),ngkpt(3))
integer :: iipw,jjpw
integer :: iqsymndx(ngkpt(1),ngkpt(2),ngkpt(3)),invpw2ndx(npwx,npwx)
integer :: pwsymndx(npwc,2*nsym)
integer :: ipw2,jw
double precision :: eps1,eps2,eps
double precision :: eval,brd,esprd
double precision :: gfo,gamma(3),pln(3),dist(3)
double precision :: sint1,sint1a,sint1b,svec(3),sveca(3),svecb(3)
double complex :: wint,wint0,w2int,w2int0,gterm,vcentr
double precision :: wcentr(-nwpt:nwpt),wgrid(nwpt)
double complex :: pwmatel(nlmn,nlmn,npwx,ngkpt(1),ngkpt(2),ngkpt(3)), &
&                tpwmatel(nlmn,nlmn,npwx,ngkpt(1),ngkpt(2),ngkpt(3))
logical :: lqsing,lqcentr
integer :: idum
logical :: lx,lc
double precision :: xdum,vdum(3)
double precision :: linterp
double precision :: rr(3,8)
integer :: ivndx(4,6),itet,iv
character*4 :: label
external linterp
data rr(1:3,1) /0.0d0,0.0d0,0.0d0/
data rr(1:3,2) /1.0d0,0.0d0,0.0d0/
data rr(1:3,3) /0.0d0,1.0d0,0.0d0/
data rr(1:3,4) /1.0d0,1.0d0,0.0d0/
data rr(1:3,5) /0.0d0,0.0d0,1.0d0/
data rr(1:3,6) /1.0d0,0.0d0,1.0d0/
data rr(1:3,7) /0.0d0,1.0d0,1.0d0/
data rr(1:3,8) /1.0d0,1.0d0,1.0d0/
data ivndx(1:4,1) /1,2,3,5/
data ivndx(1:4,2) /3,5,6,7/
data ivndx(1:4,3) /2,3,5,6/
data ivndx(1:4,4) /2,3,4,6/
data ivndx(1:4,5) /3,4,6,7/
data ivndx(1:4,6) /4,6,7,8/

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=-nwpt,nwpt
  cse1(ie)=(0.d0,0.d0)
enddo
xse=0.d0
dw=wmax/dble(nwpt)
do iw=1,nwpt
  wgrid(iw)=iw*dw
enddo
ikpt=ikndx(ikk(1),ikk(2),ikk(3))
isym=isymndx(ikk(1),ikk(2),ikk(3))
ek=enrgy(indxkbnd(ikpt)+iband)
do ii=1,3
do jj=1,3
  qkcvt(ii,jj)=blat(ii,jj)/dble(ngkpt(ii))
enddo
enddo

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

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

!ipaw=0
!write(6,'(a)') '      finding contibutions from:'
!write(6,'(a)') 'band  plane waves    correlation                exchange'
do ibp=nbcore+1,ncband
!do ibp=1,1
!do ibp=16,16
  seibc=sei
  cse2=cse1
  xse2=xse
  if (ibp.gt.nbocc) then
    isign=-1
  else
    isign=1
  endif
  do iipw=1,napwndx
!  do iipw=1,1
!  do iipw=15,15
!    write(6,'(a,i4)') 'iipw ',iipw
    seipw=sei
    do ie=-nwpt,nwpt
      ssc(ie)=(0.d0,0.d0)
    enddo
    ipw1=ipwndx(1,iipw)
    ipw2=ipwndx(2,iipw)
!    if (ipw1.ne.ipw2) cycle
!    write(6,'(38x,i3,14x,2i3)') ibp,ipw1,ipw2
    lx=ipw1.eq.ipw2.and.ibp.le.nbocc
    lc=iipw.le.ntpwndx
    if ((.not.lx).and.(.not.lc)) cycle

    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,4
      iqq=(/ix,iy,iz/)
!write(6,*) '>>>>> iqq = ',iqq
!write(6,'(a,3f10.5)') 'kpt = ',kpt(:,ikpt)
      iks=iqq-ngkpt/2
      jka=ikk-iks
      jkk=mod(jka,ngkpt(ii))
      do ii=1,3
        if (jkk(ii).le.0) jkk(ii)=jkk(ii)+ngkpt(ii)
      enddo
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
!      if (.true.) then
        ikptq=ikndxq(jkk(1),jkk(2),jkk(3))
        jkb=nint(kptq(:,ikptq)*dble(ngkpt))+ngkpt/2
        qq=kpt(:,ikpt)-kptq(:,ikptq)
!write(6,'(a,3f10.5)') 'kptq = ',kptq(:,ikptq)
      else
        ikptq=ikndx(jkk(1),jkk(2),jkk(3))
        jkb=nint(kpt(:,ikptq)*dble(ngkpt))+ngkpt/2
        qq=kpt(:,ikpt)-kpt(:,ikptq)
!write(6,'(a,3f10.5)') 'kptq = ',kptq(:,ikptq)
      endif
      igg=nint(dble(jkb-jka)/dble(ngkpt))
      qp=qq+igg+ipwx(:,ipw2)
      qq=qq+igg+ipwx(:,ipw1)
      qq2=0.d0
      qp2=0.d0
      do ii=1,3
      do jj=1,3
        qq2=qq2+qq(ii)*bmet(ii,jj)*qq(jj)
        qp2=qp2+qp(ii)*bmet(ii,jj)*qp(jj)
      enddo
      enddo
      vq(ix,iy,iz)=4.d0*pi/sqrt(qq2*qp2)
!write(6,'(a,3f10.5)') 'qq = ',qq
!write(6,'(a,3f10.5)') 'qp = ',qp
!write(6,'(a,3f10.5)') 'qq2 = ',qq2
!write(6,'(a,3f10.5)') 'qp2 = ',qp2
!write(6,*) 'vq = ',vq(ix,iy,iz)
!write(6,*) 'jka = ',jka
!write(6,*) 'jkk = ',jkk
!write(6,*) 'jkb = ',jkb
!write(6,*) 'igg = ',igg
!write(6,*) 'ikpt = ',ikpt
!write(6,*) 'ikptq = ',ikptq
      if (iks(1).eq.0.and.iks(2).eq.0.and.iks(3).eq.0) then
        call mkmatelX(ibp,iband,ikpt,ikptq,ipwx(:,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) then
          cmatel2=cmatel
          amatel2=amatel
        else
          call mkmatelX(ibp,iband,ikpt,ikptq,ipwx(:,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,iband,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
        omega(ix,iy,iz)=enrgyq(indxkbndq(ikptq)+ibp)-ek+dw/2
      else
        call mkmatelX(ibp,iband,ikpt,ikptq,ipwx(:,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) then
          cmatel2=cmatel
          amatel2=amatel
        else
          call mkmatelX(ibp,iband,ikpt,ikptq,ipwx(:,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,iband,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
        omega(ix,iy,iz)=enrgy(indxkbnd(ikptq)+ibp)-ek+dw/2
      endif
      vqmat2(ix,iy,iz)=(cmatel+amatel)*conjg(cmatel2+amatel2)*vq(ix,iy,iz)
!write(6,*) 'cmatel  = ',cmatel
!write(6,*) 'amatel  = ',amatel
!write(6,*) 'cmatel+amatel  = ',cmatel+amatel
!write(6,*) '|cmatel+amatel|^2  = ',dble((cmatel+amatel)*conjg(cmatel+amatel))
!write(6,*) 'cmatel2 = ',cmatel2
!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))
!      stvec(iqq(3))=dble(amatel*conjg(amatel))
!      stvec(iqq(3))=dble((cmatel+amatel)*conjg(cmatel+amatel))
!      temparray(ix,iy,iz)=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,'(10f8.5)') 10.d0**(log10(stvec(:))-int(log10(stvec(:))))
!    write(76,*)
    enddo
!    write(76,*) iqq(1)+1,'--------------------------------------------------',ibp
    enddo
!stop
    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

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

    if (lc) then
      do iw=1,nwpt
        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,npwc,npwx,nsym,pwsymndx,invpw2ndx,jjpw)
          if (jjpw.ne.0) then
            vfactor(iqq(1),iqq(2),iqq(3),iw)=vqmat2(iqq(1),iqq(2),iqq(3))*dimag(lossfn(iw,iqpt,jjpw))
          else
            vfactor(iqq(1),iqq(2),iqq(3),iw)=(0.d0,0.d0)
          endif
        enddo
        enddo
        enddo
      enddo
    endif

    if (ipw1.eq.1.or.ipw2.eq.1) then
      ix=ngkpt(1)/2
      iy=ngkpt(2)/2
      iz=ngkpt(3)/2
      qadj(1)=abs(vqmat2(ix,iy,iz)/vqmat2(ix+1,iy,iz))
      qadj(2)=abs(vqmat2(ix,iy,iz)/vqmat2(ix-1,iy,iz))
      qadj(3)=abs(vqmat2(ix,iy,iz)/vqmat2(ix,iy+1,iz))
      qadj(4)=abs(vqmat2(ix,iy,iz)/vqmat2(ix,iy-1,iz))
      qadj(5)=abs(vqmat2(ix,iy,iz)/vqmat2(ix,iy,iz+1))
      qadj(6)=abs(vqmat2(ix,iy,iz)/vqmat2(ix,iy,iz-1))
      if (qadj(1).gt.1.d3.and.qadj(2).gt.1.d3.and.qadj(3).gt.1.d3.and.  &
&         qadj(4).gt.1.d3.and.qadj(5).gt.1.d3.and.qadj(6).gt.1.d3) then
        lqsing=.true.
      else
        lqsing=.false.
      endif
    else
      lqsing=.false.
    endif

    ictr=(/ngkpt(1)/2,ngkpt(2)/2,ngkpt(3)/2/)
    do ix=1,ngkpt(1)
    do iy=1,ngkpt(2)
    do iz=1,ngkpt(3)
!    do ix=6,6
!    do iy=5,5
!    do iz=5,5
!    do ix=1,1
!    do iy=1,1
!    do iz=1,1
      iqq=(/ix,iy,iz/)
      ssx1=ssx
      call fval(omega,iqq,iqqp,ngkpt,enval)
      if (lqsing) call fval(vq,iqq,iqqp,ngkpt,vq2)
      if (lc) then
        do iw=1,nwpt
          call fpol(vfactor(:,:,:,iw),ngkpt,iqq,iqqp,vfv(:,iw))
        enddo
      endif
      if (lx) call fpol(vqmat2(:,:,:),ngkpt,iqq,iqqp,vfx)
      do itet=1,6
!      do itet=1,1
        ssx2=ssx
        lqcentr=.false.
        do iv=1,4
          evtx0(iv)=enval(ivndx(iv,itet))
          rrpyr(1:3,iv)=rr(1:3,ivndx(iv,itet))
          if (lc) then
            do iw=1,nwpt
              vpyr0(iv,iw)=vfv(ivndx(iv,itet),iw)
            enddo
          endif
          if (lx) xpyr0(iv)=vfx(ivndx(iv,itet))
          if (lqsing.and..not.lqcentr) then
            iqv=iqq+nint(rrpyr(:,iv))
            if (iqv(1).eq.ictr(1).and.iqv(2).eq.ictr(2).and.iqv(3).eq.ictr(3)) then
              lqcentr=.true.
            endif
          endif
        enddo
        call indxhpsort(4,4,evtx0,indxe)
        evtx=evtx0(indxe)    ! order vertices by energy
!write(6,'(4es15.5)') evtx
!        kvtx(1:3,1:4)=rrpyr(1:3,indxe)
        do ii=1,4
          jj=indxe(ii)
          do kk=1,3
            kvtx(kk,ii)=dot_product(iqq+rrpyr(:,jj)-ictr,qkcvt(:,kk))
          enddo
        enddo
        xk(1:3,1)=(/0.d0,0.d0,0.d0/)
        do ii=2,4
          xk(1:3,ii)=kvtx(1:3,ii)-kvtx(1:3,1)
        enddo
        call cross(xk(:,3),xk(:,4),vdum)
        tvol=dot_product(vdum,xk(:,2))
        do jj=1,3  ! make contragradient
          call cross(xk(1:3,mod(jj,3)+2),xk(1:3,mod(jj+1,3)+2),rg(1:3,jj))
        enddo
        rg=rg/tvol
        tvol=abs(tvol)
        iwwlo=nint(evtx(1)/dw)
        iwwhi=nint(evtx(4)/dw)
        de21=evtx(2)-evtx(1)
        de31=evtx(3)-evtx(1)
        de32=evtx(3)-evtx(2)
        de41=evtx(4)-evtx(1)
        de42=evtx(4)-evtx(2)
        de43=evtx(4)-evtx(3)
        thresh=1.d-5*de41
        if (lqcentr) then            ! integral around coulomb singularity
!        if (.true.) then
          do iv=1,4
            vqvtx0(iv)=vq2(ivndx(iv,itet))
          enddo
          bgrad=(/0.d0,0.d0,0.d0/)   ! energy gradient
          do jj=1,3
            bgrad=bgrad+(evtx(jj+1)-evtx(1))*rg(:,jj)
          enddo
          xmult=4.d0*pi/norm2(bgrad)
          if (lc) then
            do iw=1,nwpt
              vpyr(:)=vpyr0(:,iw)/vqvtx0
              aa0(iw)=vpyr(indxe(1))
              av(1:3,iw)=(/0.d0,0.d0,0.d0/)
              do jj=1,3
                av(1:3,iw)=av(1:3,iw) &
&                         +(vpyr(indxe(jj+1))-vpyr(indxe(1)))*rg(1:3,jj)
              enddo
            enddo
          endif
          if (lx) then
            xpyr=xpyr0/vqvtx0
            xme=xpyr(indxe(1))
            xv=(/0.d0,0.d0,0.d0/)
            do jj=1,3
              xv=xv+(xpyr(indxe(jj+1))-xpyr(indxe(1)))*rg(:,jj)
            enddo
          endif
          do iww=iwwlo,iwwhi
            www=dw*iww
            if (www.lt.evtx(1)) then
              cycle
            elseif (www.lt.evtx(2)) then
              call singint(1,www,xk,kvtx(:,1),evtx,sint1,svec)
            elseif (www.lt.evtx(3)) then
              if (de21.lt.thresh.and.de43.lt.thresh) then
                call singint2(www,xk,kvtx(:,1),evtx,sint1b,svecb)
                sint1a=0.d0
                sveca=(/0.d0,0.d0,0.d0/)
              elseif (de21.ge.de43) then
                call singint(2,www,xk,kvtx(:,1),evtx,sint1a,sveca)
                call singint(1,www,xk,kvtx(:,1),evtx,sint1b,svecb)
              else
                call singint(3,www,xk,kvtx(:,1),evtx,sint1a,sveca)
                call singint(4,www,xk,kvtx(:,1),evtx,sint1b,svecb)
              endif
              sint1=sint1b-sint1a
              svec=svecb-sveca
            elseif (www.lt.evtx(4)) then
              call singint(4,www,xk,kvtx(:,1),evtx,sint1,svec)
            else
              cycle
            endif
            sint1=sint1*xmult
            svec=svec*xmult
            if (lc) then
              do iw=1,nwpt
                ie=iww-isign*iw
                ssi(ie)=ssi(ie)+(aa0(iw)*sint1+dot_product(av(:,iw),svec))*dw
              enddo
            endif
            if (lx) ssx=ssx+(xme*sint1+dot_product(xv,svec))*dw
          enddo
        else                         ! non-singular, tetrahedron method
          fbx(1)=tvol/(2.d0*de21*de31*de41)
          if (de21.ge.de43) then
            fbx(2)=tvol/(2.d0*de21*de32*de42)
          else
            fbx(3)=tvol/(2.d0*de31*de32*de43)
          endif
          fbx(4)=tvol/(2.d0*de41*de42*de43)
          do ii=1,4
            cmx(1:3,ii)=(/0.d0,0.d0,0.d0/)
            do jj=1,4
              if (jj.ne.ii) cmx(1:3,ii)=cmx(1:3,ii)+(xk(1:3,jj)-xk(1:3,ii)) &
&                                                  /(3*(evtx(jj)-evtx(ii)))
            enddo
          enddo
          if (lc) then
            do iw=1,nwpt
              aa0(iw)=vpyr0(indxe(1),iw)   ! base value of function
              av(1:3,iw)=(/0.d0,0.d0,0.d0/) ! gradient of function
              do jj=1,3
                av(1:3,iw)=av(1:3,iw) &
&                         +(vpyr0(indxe(jj+1),iw)-vpyr0(indxe(1),iw))*rg(1:3,jj)
              enddo
            enddo
          endif
          if (lx) then
            xme=xpyr0(indxe(1))
            xv=(/0.d0,0.d0,0.d0/)
            do jj=1,3
              xv=xv+(xpyr0(indxe(jj+1))-xpyr0(indxe(1)))*rg(:,jj)
            enddo
          endif
          do iww=iwwlo,iwwhi
            www=dw*iww
            if (www.lt.evtx(1)) then
              cycle
            elseif (www.lt.evtx(2)) then
label='1  F'
              sint1=fbx(1)*(www-evtx(1))**2
              svec=(xk(1:3,1)+(www-evtx(1))*cmx(1:3,1))*sint1
            elseif (www.lt.evtx(3)) then
              if (de21.lt.thresh.and.de43.lt.thresh) then
                xkt(:,1)=xk(:,3)*(www-evtx(1))/de31
                xkt(:,2)=xk(:,4)*(www-evtx(1))/de41
                xkt(:,3)=(xk(:,4)-xk(:,2))*(www-evtx(2))/de42+xk(:,2)
                sint1=tvol*(2*(www-evtx(1))/(de31*de41) &
&                     -(www-evtx(1))**2*(de31+de41)/(de31*de41)**2)/2
                svec=((xkt(:,1)+xkt(:,3))/2.d0)*sint1
              elseif (de21.ge.de43) then
                fb(1)=fbx(1)*(www-evtx(1))**2
                fb(2)=fbx(2)*(www-evtx(2))**2
                sint1=fb(1)-fb(2)
                cm(1:3,1)=xk(1:3,1)+(www-evtx(1))*cmx(1:3,1)
                cm(1:3,2)=xk(1:3,2)+(www-evtx(2))*cmx(1:3,2)
                svec=cm(:,1)*fb(1)-cm(:,2)*fb(2)
              else
                fb(3)=fbx(3)*(www-evtx(3))**2
                fb(4)=fbx(4)*(www-evtx(4))**2
                sint1=fb(4)-fb(3)
                cm(1:3,3)=xk(1:3,3)+(www-evtx(3))*cmx(1:3,3)
                cm(1:3,4)=xk(1:3,4)+(www-evtx(4))*cmx(1:3,4)
                svec=cm(:,4)*fb(4)-cm(:,3)*fb(3)
              endif
            elseif (www.lt.evtx(4)) then
              sint1=fbx(4)*(www-evtx(4))**2
              svec=(xk(1:3,4)+(www-evtx(4))*cmx(1:3,4))*sint1
            else
              cycle
            endif
            if (lc) then
              do iw=1,nwpt
                ie=iww-isign*iw
                ssi(ie)=ssi(ie)+(aa0(iw)*sint1+dot_product(av(:,iw),svec))*dw
              enddo
            endif
            if (lx) ssx=ssx+(xme*sint1+dot_product(xv,svec))*dw
          enddo
        endif
!if (lqcentr) then
!write(47,'(3i3,3x,i3,f16.8,3x,a)') ix,iy,iz,itet,ssx-ssx2,'T'
!else
!write(47,'(3i3,3x,i3,f16.8,3x,a)') ix,iy,iz,itet,ssx-ssx2,'F'
!endif
      enddo
!      temparray(ix,iy,iz)=(ssx-ssx1)/((2*pi)**3)
    enddo
    enddo
    enddo
!!!!!!!!!!    ssi=ssi/(dble(ngkpt(1)*ngkpt(2)*ngkpt(3))*vol*pi)
    if (lc) ssi=-isign*ssi/((2*pi)**3*pi)
    if (lx) ssx=-ssx/((2*pi)**3)

    if (lc) then
      do ie=-nwpt,nwpt
        eps1=dble(ie)*dw-dw/2
!        ssc(ie)=(0.d0,0.d0)
        do je=ielo,iehi
          if (ie.eq.je) then
            ssc(ie)=ssc(ie)+(0.d0,1.d0)*pi*ssi(je)
          else
            eps2=dble(je)*dw-dw/2
            ssc(ie)=ssc(ie)+isign*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
      enddo
    endif
    deallocate (ssi)

    if (lc) cse1=cse1+ssc
    if (lx) xse=xse+ssx
!    if (lx) then
!      write(6,'(i4,4x,i5,3x,3i3,5x,"(",f10.6,",",f10.6,")",5x,f10.6)')  &
!&          ibp,ipw1,ipwx(:,ipw1),((ssc(1)+ssc(0))/2)*27.2114,dble(ssx)*27.2114
!    else
!      write(6,'(i4,4x,i5,3x,3i3,5x,"(",f10.6,",",f10.6,")")') ibp,ipw1,ipwx(:,ipw1), &
!&          ((ssc(1)+ssc(0))/2)*27.2114
!    endif

  enddo
!  if (lx) then
!    write(6,'(i4,5x,"(",f10.6,",",f10.6,")",5x,f10.6)') ibp, &
!& (cse1(1)+cse1(0)-cse2(1)-cse2(0))*27.2114/2.d0, &
!& dble(xse-xse2)*27.2114
!  else
!    write(6,'(i4,5x,"(",f10.6,",",f10.6,")",f10.6)') ibp, &
!& (cse1(1)+cse1(0)-cse2(1)-cse2(0))*27.2114/2.d0
!  endif
enddo

do ie=-nwpt,nwpt
  eps1=dble(ie)*dw-dw/2
!  write(12,'(i4,f10.3,2(3x,2es12.3))') ie,eps1*27.2114,cse1(ie)*27.2114
enddo
cse=(cse1(0)+cse1(1))/2
dcse=(cse1(1)-cse1(0))/dw
zz=1.d0/(1.d0-dcse)
!write(6,*) cse*27.2114
!write(6,*) xse*27.2114
!write(6,*) zz
!write(6,*) dble(zz)*dimag(cse)*27.2114

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

return
end subroutine mk2cse

!***************************************************************************
!
! Over a surface S defined by the triangle with vertices xkvtx+xkp(1:3,1)
!                                                        xkvtx+xkp(1:3,2)
!                                                        xkvtx+xkp(1:3,3)
! where xkp defined to give S of constant energy
! (see G. Lehmann and M. Taut, Phys. stat. sol. (b) 54 469 (1972))
! and vector k measured from tip of xkvtx
! find      sint1 = integral dS 1/q^2
! and       svec  = integral dS k/q^2
! where q=k+xkvtx
! On S, define coordinates X and Y such that k=xkp(1:3,3)+Y*xq1+X*xq2
! normal=cross product(xq1,xq2)
! dot_product(k+xkvtx,k+xkvtx) = aa*Y^2+Y*(bb+cc*X)+dd*X+ee*X^2+FF
! integral dS -> |normal|*integral^1_0 dX integral^{1-X}_0 dY
! integral^{1-X}_0 dY 1/(dot_product(k+xkvtx,k+xkvtx)) = xfn1
! integral^{1-X}_0 dY X/(dot_product(k+xkvtx,k+xkvtx)) = X*xfn1 = xfn3
! integral^{1-X}_0 dY Y/(dot_product(k+xkvtx,k+xkvtx)) = (xfn2-bb*xfn1-cc*xfn3)/(2*aa)
! numerically integrate xfn1,xfn2,xfn3
! sint1 = integral^1_0 dX xfn1
! sint2 = integral^1_0 dX xfn2
! sint3 = integral^1_0 dX xfn3
! svec = xkp(:,3)*sint1+xq1*(sint2-bb*sint1-cc*sint3)/(2*aa)+xq2*sint3

subroutine singint(ive,ww,xk,xkvtx,evtx,sint1,svec)
implicit none
integer :: ive
double precision :: xk(3,4),xkvtx(3),evtx(4),ww
double precision :: xkp(3,3),xq1(3),xq2(3),xkv0(3),xcvt
double precision :: aa,bb,cc,dd,ee,ff,qq
double precision :: xmin,xmax,abr,rlr,xsing(20),error
double precision :: xfn1,xfn2,xfn3,grater
double precision :: sint1,sint2,sint3,svec(3),root1,root2
double precision :: xnorm(3),area
double precision :: xdum
integer :: ii,jj,ll
integer :: nsing,numcal,maxns,nroots
integer :: iter  !######
common /fn/ aa,bb,cc,dd,ee,ff,iter !######
external xfn1,xfn2,xfn3,grater

!write(6,*) ive
!write(6,'(4es15.5)') evtx
!write(6,'(3f10.6)') xk(:,1)
!write(6,*)
!write(6,*) 'boundary vectors of tetrahedron'
!write(6,'(3f10.6)') xk(:,2)
!write(6,'(3f10.6)') xk(:,3)
!write(6,'(3f10.6)') xk(:,4)
  if (ive.eq.1) then
    xkp(:,1)=(ww-evtx(1))*xk(:,2)/(evtx(2)-evtx(1))
    xkp(:,2)=(ww-evtx(1))*xk(:,3)/(evtx(3)-evtx(1))
    xkp(:,3)=(ww-evtx(1))*xk(:,4)/(evtx(4)-evtx(1))
  elseif (ive.eq.2) then
    xkp(:,1)=(ww-evtx(1))*xk(:,2)/(evtx(2)-evtx(1))
    xkp(:,2)=(ww-evtx(2))*(xk(:,3)-xk(:,2))/(evtx(3)-evtx(2)) + xk(:,2)
    xkp(:,3)=(ww-evtx(2))*(xk(:,4)-xk(:,2))/(evtx(4)-evtx(2)) + xk(:,2)
  elseif (ive.eq.3) then
    xkp(:,1)=(ww-evtx(1))*xk(:,3)/(evtx(3)-evtx(1))
    xkp(:,2)=(ww-evtx(2))*(xk(:,3)-xk(:,2))/(evtx(3)-evtx(2)) + xk(:,2)
    xkp(:,3)=(ww-evtx(3))*(xk(:,4)-xk(:,3))/(evtx(4)-evtx(3)) + xk(:,3)
  else
    xkp(:,1)=(ww-evtx(2))*(xk(:,4)-xk(:,2))/(evtx(4)-evtx(2)) + xk(:,2)
    xkp(:,2)=(ww-evtx(3))*(xk(:,4)-xk(:,3))/(evtx(4)-evtx(3)) + xk(:,3)
    xkp(:,3)=(ww-evtx(1))*xk(:,4)/(evtx(4)-evtx(1))
  endif
!write(6,*)
!write(6,*) 'vertices of S'
!write(6,'(3f10.6)') xkp(:,1)
!write(6,'(3f10.6)') xkp(:,2)
!write(6,'(3f10.6)') xkp(:,3)
  xq1=xkp(:,1)-xkp(:,3)
  xq2=xkp(:,2)-xkp(:,3)
!write(6,*)
!write(6,*) 'boundary vectors xq'
!write(6,'(3f10.6)') xq1
!write(6,'(3f10.6)') xq2
  xkv0=xkp(:,3)+xkvtx
!write(6,'(3f10.6)') xkvtx
!write(6,'(3f10.6)') xkv0
  call cross(xq1,xq2,xnorm)
  area=norm2(xnorm)
!write(6,*)
!write(6,'(a,es15.5)') 'area  ',area
  aa=dot_product(xq1,xq1)
  bb=2*dot_product(xq1,xkv0)
  cc=2*dot_product(xq1,xq2)
  dd=2*dot_product(xq2,xkv0)
  ee=dot_product(xq2,xq2)
  ff=dot_product(xkv0,xkv0)
!write(6,'("coef",6f10.6)') aa,bb,cc,dd,ee,ff
  nsing=0
  call rquadroots(ee,dd,ff,nroots,root1,root2)
!write(6,'(i4,2es15.5)') nroots,root1,root2
  if (nroots.gt.0.and.root1.gt.0.d0.and.root1.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root1
  endif
  if (nroots.gt.1.and.root2.gt.0.d0.and.root2.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root2
  endif
  call rquadroots(1.d0+cc/2+ee,bb/2+dd,ff,nroots,root1,root2)
!write(6,'(i4,2es15.5)') nroots,root1,root2
  if (nroots.gt.0.and.root1.gt.0.d0.and.root1.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root1
  endif
  if (nroots.gt.1.and.root2.gt.0.d0.and.root2.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root2
  endif
!write(6,'(i4,4es15.5)') nsing,xsing(1:nsing)
  call hpsort(nsing,nsing,xsing(1:nsing))
!write(6,'("sings",i4,4es15.5)') nsing,xsing(1:nsing)
  xmin=0.d0
  xmax=1.d0
  abr=1.d-12
  rlr=1.d-6
  sint1=grater(xfn1,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
  sint2=grater(xfn2,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
  sint3=grater(xfn3,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
!write(6,*)
!write(6,'("sints",6f10.6)') sint1,sint2,sint3
  svec=xkp(:,3)*sint1+xq1*(sint2-bb*sint1-cc*sint3)/(2*aa)+xq2*sint3
!write(6,'("svec",6f10.6)') svec
!tint=(aa0*sint1+dot_product(av,svec))/bmag

end subroutine singint

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

double precision function xfn1(xx)
implicit none
double precision :: xx,xx2
double precision :: aa,bb,cc,dd,ee,ff
double precision :: xt1,xt2,xl1,qq,dx
double precision :: sqq,xterm,df,d2f
integer :: iter
common /fn/ aa,bb,cc,dd,ee,ff,iter
!integer :: ict
!data ict /0/
!save ict

  xx2=xx*xx
  xt1=bb+cc*xx
  xt2=dd*xx+ee*xx2+ff
  dx=2.d0*aa*(1.d0-xx)
  xl1=dx+xt1
  qq=4.d0*aa*xt2-xt1**2
  if (qq.lt.0.d0) then
    sqq=sqrt(-qq)
!    xfn1=(log(abs((sqq+xl1)/(sqq-xl1)))-log(abs((sqq+xt1)/(sqq-xt1))))/sqq
    xfn1=(log(abs(((sqq+xl1)*(sqq-xt1))/((sqq-xl1)*(sqq+xt1)))))/sqq
!write(iter,'(" B",es15.5,4x,2es15.5)') xx,xfn1
  else
!    df=2.d0*dx/(qq+xt1**2)
!    d2f=df**2*xt1/2.d0
!    if (d2f/df.lt.1.d-6) then
!      xfn1=df-d2f
!    else
      sqq=sqrt(qq)
      if (abs(dx/(qq+xt1**2)).gt.abs(1.d8*(dx**2*xt1/(qq+xt1**2)**2))) then
! atan(z+d)->atan(z)+d/(1+z^2)-d^2z/(1+z^2)^2+..., d->0 (taylor expansion)
! for small dx, xfn1->dx/(qq+xt1^2)
        xfn1=2*(dx/(qq+xt1**2)-dx**2*xt1/(qq+xt1**2)**2)
      elseif (abs(1.d0/xl1-1.d0/xt1).gt.abs(1.d8*qq*(1.d0/xl1**3-1.d0/xt1**3))) then
! atan(z)->pi/2-1/z+1/(3z^3)-1/(5z^5)+..., z->infty
! => at small sqq or large xt1, xl1, xfn1->-1/xl1+1/xt1
        xfn1=2*(-1.d0/xl1+1.d0/xt1+(qq/3.d0)*(1.d0/xl1**3-1.d0/xt1**3))
      else
        xfn1=2*(atan(xl1/sqq)-atan(xt1/sqq))/sqq
      endif
!write(iter,'(" A",es15.5,3x,4es15.5)') xx,xfn1,xt1,bb,cc
!    endif
  endif
!write(6,'(es15.5,4es15.5)') xx,qq,xl1,xt1,xfn1
!write(6,'(es15.5,4es15.5)') xx-1.d0,2/(qq+xt1**2),df,df-d2f,xfn1
!write(6,'(es15.5,4es15.5)') xx-1.d0,d2f/df,df,df-d2f,xfn1
!write(47,'(es15.7,4es15.7)') xx-1.d0,2/(qq+xt1**2),df,df-d2f,xfn1
!write(6,'(es15.7,4es15.7)') xx,2/(qq+xt1**2),qq,xt1**2,4.d0*aa*xt2
!write(6,'(es15.7,4es15.7)') xx,qq,xl1,xt1,xfn1
!write(47,'(es15.7,4es15.7)') xx,qq,xl1,xt1,xfn1
!write(6,'(es15.5,4es15.5)') xx,dx,qq,xt1**2,xfn1
!write(iter,'(es15.5,4x,2es15.5)') xx,xfn1
!ict=ict+1
!if (ict.gt.3000) stop

end function xfn1

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

double precision function xfn2(xx)
implicit none
double precision :: xx,xx2,omx
double precision :: aa,bb,cc,dd,ee,ff
double precision :: xt1,xt2,xl1,qq
double precision :: xterm,sqq
integer :: iter  !######
common /fn/ aa,bb,cc,dd,ee,ff,iter !######

  xx2=xx*xx
  omx=1.d0-xx
  xterm=(aa*omx*omx+omx*(bb+cc*xx)+dd*xx+ee*xx2+ff)/(dd*xx+ee*xx2+ff)
  xfn2=log(abs(xterm))
!  xt1=bb+cc*xx
!  xt2=dd*xx+ee*xx2+ff
!  xl1=2.d0*aa*omx+xt1
!  qq=4.d0*aa*xt2-xt1**2
!  if (qq.lt.0.d0) then
!    sqq=sqrt(-qq)
!    xfn2=log(abs(xterm))+xt1*(log(abs((sqq+xl1)/(sqq-xl1)))-log(abs((sqq+xt1)/(sqq-xt1))))/sqq
!  else
!    sqq=sqrt(qq)
!    xfn2=log(abs(xterm))+2*xt1*(atan((xl1)/sqq)-atan(xt1/sqq))/sqq
!  endif
!!write(47,'(4es15.5)') xx,xfn2,(aa+cc+ee)*xx2+(bb+dd)*xx+ff,dd*xx+ee*xx2+ff

end function xfn2

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

double precision function xfn3(xx)
implicit none
double precision :: xfn1,xx
external xfn1

  xfn3=xx*xfn1(xx)

end function xfn3

!***************************************************************************
!
! Over a surface S defined by the parallelogram with vertices
!           xkvtx+xkp(1:3,1)
!           xkvtx+xkp(1:3,2)
!           xkvtx+xkp(1:3,3)
!           xkvtx+xkp(1:3,1)+(xkp(1:3,2)-xkp(1:3,3))
! where xkp defined to give S of constant energy
! (see G. Lehmann and M. Taut, Phys. stat. sol. (b) 54 469 (1972))
! and vector k measured from tip of xkvtx
! find      sint1 = integral dS 1/q^2
! and       svec  = integral dS k/q^2
! where q=k+xkvtx
! On S, define coordinates X and Y such that k=xkp(1:3,3)+Y*xq1+X*xq2
! normal=cross product(xq1,xq2)
! dot_product(k+xkvtx,k+xkvtx) = aa*Y^2+Y*(bb+cc*X)+dd*X+ee*X^2+FF
! integral dS -> |normal|*integral^1_0 dX integral^1_0 dY
! integral^1_0 dY 1/(dot_product(k+xkvtx,k+xkvtx)) = xfn4
! integral^1_0 dY X/(dot_product(k+xkvtx,k+xkvtx)) = X*xfn4 = xfn6
! integral^1_0 dY Y/(dot_product(k+xkvtx,k+xkvtx)) = (xfn5-bb*xfn4-cc*xfn6)/(2*aa)
! numerically integrate xfn4,xfn5,xfn6
! sint1 = integral^1_0 dX xfn4
! sint2 = integral^1_0 dX xfn5
! sint3 = integral^1_0 dX xfn6
! svec = xkp(:,3)*sint1+xq1*(sint2-bb*sint1-cc*sint3)/(2*aa)+xq2*sint3

subroutine singint2(ww,xk,xkvtx,evtx,sint1,svec)
implicit none
double precision :: xk(3,4),xkvtx(3),evtx(4),ww
double precision :: xkp(3,3),xq1(3),xq2(3),xkv0(3),xcvt
double precision :: aa,bb,cc,dd,ee,ff,qq
double precision :: xmin,xmax,abr,rlr,xsing(20),error
double precision :: xfn4,xfn5,xfn6,grater
double precision :: sint1,sint2,sint3,svec(3),root1,root2
double precision :: xnorm(3),area
double precision :: xdum
integer :: ii,jj,ll
integer :: nsing,numcal,maxns,nroots
integer :: iter  !######
common /fn/ aa,bb,cc,dd,ee,ff,iter !######
external xfn4,xfn5,xfn6,grater

!write(6,*) ive
!write(6,'(4es15.5)') evtx
!write(6,'(3f10.6)') xk(:,1)
!write(6,*)
!write(6,*) 'boundary vectors of tetrahedron'
!write(6,'(3f10.6)') xk(:,2)
!write(6,'(3f10.6)') xk(:,3)
!write(6,'(3f10.6)') xk(:,4)
  xkp(:,1)=(ww-evtx(1))*xk(:,3)/(evtx(3)-evtx(1))
  xkp(:,2)=(ww-evtx(1))*xk(:,4)/(evtx(4)-evtx(1))
  xkp(:,3)=(ww-evtx(2))*(xk(:,4)-xk(:,2))/(evtx(4)-evtx(2)) + xk(:,2)
!write(6,*)
!write(6,*) 'vertices of S'
!write(6,'(3f10.6)') xkp(:,1)
!write(6,'(3f10.6)') xkp(:,2)
!write(6,'(3f10.6)') xkp(:,3)
  xq1=xkp(:,1)-xkp(:,3)
  xq2=xkp(:,2)-xkp(:,3)
!write(6,*)
!write(6,*) 'boundary vectors xq'
!write(6,'(3f10.6)') xq1
!write(6,'(3f10.6)') xq2
  xkv0=xkp(:,3)+xkvtx
!write(6,'(3f10.6)') xkvtx
!write(6,'(3f10.6)') xkv0
  call cross(xq1,xq2,xnorm)
  area=norm2(xnorm)
!write(6,*)
!write(6,'(a,es15.5)') 'area  ',area
  aa=dot_product(xq1,xq1)
  bb=2*dot_product(xq1,xkv0)
  cc=2*dot_product(xq1,xq2)
  dd=2*dot_product(xq2,xkv0)
  ee=dot_product(xq2,xq2)
  ff=dot_product(xkv0,xkv0)
!write(6,'("coef",6f10.6)') aa,bb,cc,dd,ee,ff
  nsing=0
  call rquadroots(ee,dd,ff,nroots,root1,root2)
!write(6,'(i4,2es15.5)') nroots,root1,root2
  if (nroots.gt.0.and.root1.gt.0.d0.and.root1.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root1
  endif
  if (nroots.gt.1.and.root2.gt.0.d0.and.root2.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root2
  endif
  call rquadroots(1.d0+cc/2+ee,bb/2+dd,ff,nroots,root1,root2)
!write(6,'(i4,2es15.5)') nroots,root1,root2
  if (nroots.gt.0.and.root1.gt.0.d0.and.root1.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root1
  endif
  if (nroots.gt.1.and.root2.gt.0.d0.and.root2.lt.1.d0) then
    nsing=nsing+1
    xsing(nsing)=root2
  endif
!write(6,'(i4,4es15.5)') nsing,xsing(1:nsing)
  call hpsort(nsing,nsing,xsing(1:nsing))
!write(6,'("sings",i4,4es15.5)') nsing,xsing(1:nsing)
  xmin=0.d0
  xmax=1.d0
  abr=1.d-12
  rlr=1.d-6
  sint1=grater(xfn4,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
  sint2=grater(xfn5,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
  sint3=grater(xfn6,xmin,xmax,abr,rlr,nsing,xsing,error,numcal,maxns)*area
!write(6,*)
!write(6,'("sints",6f10.6)') sint1,sint2,sint3
  svec=xkp(:,3)*sint1+xq1*(sint2-bb*sint1-cc*sint3)/(2*aa)+xq2*sint3
!write(6,'("svec",6f10.6)') svec
!tint=(aa0*sint1+dot_product(av,svec))/bmag

end subroutine singint2

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

double precision function xfn4(xx)
implicit none
double precision :: xx,xx2
double precision :: aa,bb,cc,dd,ee,ff
double precision :: xt1,xt2,xl1,qq
double precision :: sqq,xterm
integer :: iter  !######
common /fn/ aa,bb,cc,dd,ee,ff,iter !######

  xx2=xx*xx
  xt1=bb+cc*xx
  xt2=dd*xx+ee*xx2+ff
  xl1=2.d0*aa+xt1
  qq=4.d0*aa*xt2-xt1**2
  if (qq.lt.0.d0) then
    sqq=sqrt(-qq)
    xfn4=(log(abs((sqq+xl1)/(sqq-xl1)))-log(abs((sqq+xt1)/(sqq-xt1))))/sqq
  else
    sqq=sqrt(qq)
    xfn4=2*(atan((xl1)/sqq)-atan(xt1/sqq))/sqq
  endif
!write(47,'(es15.5,4x,2es15.5)') xx,xfn4

end function xfn4

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

double precision function xfn5(xx)
implicit none
double precision :: xx,xx2
double precision :: aa,bb,cc,dd,ee,ff
double precision :: xt1,xt2,xl1,qq
double precision :: xterm,sqq
integer :: iter  !######
common /fn/ aa,bb,cc,dd,ee,ff,iter !######

  xx2=xx*xx
  xterm=(aa+bb+(cc+dd)*xx+ee*xx2+ff)/(dd*xx+ee*xx2+ff)
  xfn5=log(abs(xterm))
!  xt1=bb+cc*xx
!  xt2=dd*xx+ee*xx2+ff
!  xl1=2.d0*aa+xt1
!  qq=4.d0*aa*xt2-xt1**2
!  if (qq.lt.0.d0) then
!    sqq=sqrt(-qq)
!    xfn5=log(abs(xterm))+xt1*(log(abs((sqq+xl1)/(sqq-xl1)))-log(abs((sqq+xt1)/(sqq-xt1))))/sqq
!  else
!    sqq=sqrt(qq)
!    xfn5=log(abs(xterm))+2*xt1*(atan((xl1)/sqq)-atan(xt1/sqq))/sqq
!  endif

end function xfn5

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

double precision function xfn6(xx)
implicit none
double precision :: xfn4,xx
external xfn4

  xfn6=xx*xfn4(xx)

end function xfn6


!   The MIT License (MIT)
!
!   Copyright (c) 2016 Holger Kruse
!
!   Permission is hereby granted, free of charge, to any person obtaining a copy
!   of this software and associated documentation files (the "Software"), to deal
!   in the Software without restriction, including without limitation the rights
!   to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
!   copies of the Software, and to permit persons to whom the Software is
!   furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in all
!   copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
!   AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
!   OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
!   SOFTWARE.
!
program cm5charge
implicit none
integer nat,i,j,k,l,ii,jj,kdelta
integer, allocatable :: iat(:)
real(8), allocatable :: xyz(:,:),qcm5(:),qh(:)
real(8) dx,dy,dz,rij,s,alpha,tkk,bkk,fscale,dipole(3)
character(120) infile,chrgfile
character(2) esym
real(kind=8) rvdw(94),rconv(94),bohr,quad(3,3)
real(8), parameter :: AMBER_ELECTROSTATIC = 18.2223d0
real(8), parameter :: INV_AMBER_ELECTROSTATIC = 1.0d0/AMBER_ELECTROSTATIC

! atomic radii from Mantina, Valero, Cramer, Truhlar "Atomic radii of elements"
! Copyed by hand,  maybe contain typos...
!            H       He
data rvdw /1.10d0,1.40d0, &
    ! Li     Be     B     C       N      O     F      Ne
    1.82d0,1.53d0,1.92d0,1.70d0,1.54d0,1.52d0,1.47d0,1.54d0, &
    ! Na    Mg     Al     Si     P      S       Cl     Ar
    2.27d0,1.73d0,1.84d0,2.10d0,1.80d0,1.80d0,1.75d0,1.88d0, &
    ! K      Ca     Sc     Ti     V      Cr      Mn     Fe     Co    Ni     Cu     Zn     Ga     Ge     As     Se     Br    Kr
    2.75d0,2.31d0,2.15d0,2.11d0,2.07d0,2.06d0,2.05d0,2.04d0,2.00d0,1.97d0,1.96d0,2.01d0,1.87d0,2.11d0,1.85d0,1.90d0,1.85d0,2.02d0, &
    !  Rb    Sr     Y      Zr      Nb     Mo    Tc     Ru     Rh     Pd     Ag     Cd     In    Sn      Sb      Te     I     Xe
    3.03d0,2.49d0,2.26d0,2.23d0,2.18d0,2.17d0,2.16d0,2.13d0,2.10d0,2.10d0,2.11d0,2.18d0,1.93d0,2.17d0,2.06d0,2.06d0,1.98d0,2.16d0, &
    ! Cs Ba
    3.32d0,2.68d0, &
    ! La-Lu
    2.43d0,2.42d0,2.40d0,2.46d0,2.38d0,2.36d0,2.35d0,2.34d0,2.33d0,2.31d0,2.30d0,2.29d0,2.27d0,2.26d0,2.24d0, &
    ! Hf     Ta     W       Re     Os    Ir     Pt     Au     Hg     Ti     Pb     Bi     Po     At     Rn
    2.23d0,2.22d0,2.18d0,2.16d0,2.16d0,2.13d0,2.13d0,2.23d0,2.23d0,2.11d0,2.02d0,2.07d0,1.97d0,2.02d0,2.20d0, &
    ! Fr-Pu
    3.48d0,2.83d0,2.47d0,2.45d0,2.43d0,2.41d0,2.39d0,2.43d0/

data rconv /0.32d0,0.37d0, &
    ! Li     Be     B     C       N      O     F      Ne
    1.30d0,0.99d0,0.84d0,0.75d0,0.71d0,0.64d0,0.60d0,0.62d0,  &
    ! Na    Mg     Al     Si     P      S       Cl     Ar
    1.60d0,1.40d0,1.24d0,1.14d0,1.09d0,1.04d0,1.00d0,1.01d0,  &
    ! K      Ca     Sc     Ti     V      Cr      Mn     Fe     Co    Ni     Cu     Zn     Ga     Ge     As     Se     Br    Kr
    2.00d0,1.74d0,1.59d0,1.48d0,1.44d0,1.30d0,1.29d0,1.24d0,1.18d0,1.17d0,1.22d0,1.20d0,1.23d0,1.20d0,1.20d0,1.18d0,1.17d0,1.24d0, &
    !  Rb    Sr     Y      Zr      Nb     Mo    Tc     Ru     Rh     Pd     Ag     Cd     In    Sn      Sb      Te     I     Xe
    2.15d0,1.90d0,1.78d0,1.64d0,1.56d0,1.46d0,1.38d0,1.36d0,1.34d0,1.30d0,1.36d0,1.40d0,1.42d0,1.40d0,1.40d0,1.37d0,1.32d0,1.36d0, &
    ! Cs Ba
    2.38d0,2.06d0,  &
    ! La-Lu
     1.94d0,1.84d0,1.90d0,1.73d0,1.86d0,1.85d0,1.83d0,1.82d0,1.81d0,1.80d0,1.79d0,1.77d0,1.77d0,1.78d0,1.74d0,  &
    ! Hf     Ta     W       Re     Os    Ir     Pt     Au     Hg     Ti     Pb     Bi     Po     At     Rn
    1.64d0,1.58d0,1.50d0,1.41d0,1.36d0,1.32d0,1.30d0,1.64d0,1.88d0,1.48d0,1.45d0,1.50d0,1.42d0,1.47d0,1.46d0,  &
    ! Fr-Pu
    2.42d0,2.11d0,2.01d0,1.90d0,1.84d0,1.83d0,1.80d0,1.80d0/

print*,'|-----------------------------------------|'
print*,'| CM5 charges calculator from             |'
print*,'| ORCA Hirsheld charges                   |'
print*,'| set: "%output print[P_Hirshfeld] 1 end" |'
print*,'| v1.0 Holger Kruse                       |'
print*,'|-----------------------------------------|'
print*,''

bohr=0.52917726d0

alpha=2.474  ! angstrom

call getarg(1,infile)
call getarg(2,chrgfile)

if(chrgfile=='') then
  fscale=1.20
else
 read(chrgfile,*) fscale
endif

if(infile=='') then
print*,'USAGE: cm5 <orca output> [<scale factor]'
print*,''
stop
endif

write(*,*) ''
write(*,'(a,F4.2)'),'* scaling factor for CM5 *: ', fscale
write(*,*) ''

nat=1
call tmolrd(nat,xyz,iat,infile,.false.,.true.)
allocate(xyz(3,nat),iat(nat))
allocate(qh(nat),qcm5(nat))
call tmolrd(nat,xyz,iat,infile,.true.,.false.)

xyz=xyz*bohr ! angstrom

write(*,'(a)'),' data in electron/angstrom '
call read_hirsh(qh,nat,trim(infile))
!print*,' Hirshfeld charges '
!do i=1,nat
!write(*,'(I3,a,F5.2)') i,esym(iat(i)),qh(i)
!enddo

qcm5=0d0
do i=1,nat
ii=iat(i)
 s=0
 do j=1,nat
  if(i==j) cycle
   jj=iat(j)
   dx=xyz(1,i)-xyz(1,j)
   dy=xyz(2,i)-xyz(2,j)
   dz=xyz(3,i)-xyz(3,j)
   rij=sqrt(dx*dx+dy*dy+dz*dz)
   bkk=exp(-alpha*(rij-rconv(ii)-rconv(jj))) ! eq.2
   s=s+tkk(ii,jj)*bkk
!  print*,s,tkk(ii,jj)*bkk,tkk(ii,jj),bkk,rij
 enddo
 qcm5(i)=qh(i)+s
enddo

print*,'CHARGES:'
print*,'           CM5      CM5scale     HPA         X            Y            Z'
do i=1,nat
write(*,'(I3,2x,a2,2x,3(F9.5,x),3(F12.7,x))') i,esym(iat(i)),qcm5(i),qcm5(i)*fscale,qh(i),xyz(1:3,i)
enddo

write(*,*) ''
write(*,*) 'electrostatic moments'
write(*,*) ' ref. point: 0.0  0.0  0.0'

!CM5 dipole moment
dipole=0
do i=1,nat
 do j=1,3
dipole(j)=dipole(j)+qcm5(i)*xyz(j,i)
enddo
enddo

dipole=dipole*4.802889778d0
dx= dipole(1)
dy= dipole(2)
dz= dipole(3)
s=sqrt(dipole(1)**2+dipole(2)**2+dipole(3)**2)

write(*,'(a,F10.6)'     ) '  Total CM5 charge       : ',sum(qcm5)
write(*,*)                '                             X          Y          Z      TOTAL'
write(*,'(a,4(F10.6,x))') '  CM5 dipole [Debye]  : ', dx,dy,dz,s

! scaled
! could have just scaled the dipole directly, oh well...
dipole=0
do i=1,nat
 do j=1,3
dipole(j)=dipole(j)+qcm5(i)*xyz(j,i)*fscale
enddo
enddo

dipole=dipole*4.802889778d0
dx= dipole(1)
dy= dipole(2)
dz= dipole(3)
s=sqrt(dipole(1)**2+dipole(2)**2+dipole(3)**2)

write(*,'(a,4(F10.6,x))') '  CM5 scaled [Debye]  : ', dx,dy,dz,s

! Quadrupole moment
quad=0
  do k=1,nat
   dx=xyz(1,k)/bohr
   dy=xyz(2,k)/bohr
   dz=xyz(3,k)/bohr
   quad(1,1)=quad(1,1)+ dx*dx*qcm5(k)
   quad(2,2)=quad(2,2)+ dy*dy*qcm5(k)
   quad(3,3)=quad(3,3)+ dz*dz*qcm5(k)
   quad(1,2)=quad(1,2)+ dx*dy*qcm5(k)
   quad(1,3)=quad(1,3)+ dx*dz*qcm5(k)
   quad(2,3)=quad(2,3)+ dy*dz*qcm5(k)
  enddo

!quad=quad*4.802889778d0
print*, ' quadrupole moment (au):'
write(*,'(2x,3(a,F12.6,x))') 'XX= ',quad(1,1),'YY= ',quad(2,2),'ZZ= ',quad(3,3)
write(*,'(2x,3(a,F12.6,x))') 'XY= ',quad(1,2),'XZ= ',quad(1,3),'YZ= ',quad(2,3)
write(*,'(2x,a,F12.6)') '  1/3 trace= ',(quad(1,1)+quad(2,2)+quad(3,3)/3d0)

! write data
print*,'writing: '//trim(infile)//'_cm5.dat with normal and  scaled CM5 charges'
open(99,file=trim(infile)//'_cm5.dat')
do i=1,nat
write(99,'(2(F10.6,x))') qcm5(i),qcm5(i)*fscale
enddo
close(99)

! write topology file section
qcm5=qcm5*fscale/INV_AMBER_ELECTROSTATIC
print*,'writing: '//trim(infile)//'_cm5.top (amber topology) with scaled CM5 charges'
open(111,file=trim(infile)//'_cm5.top')
  write(111,'(a)')'%FLAG CHARGE'
  write(111,'(a)')'%FORMAT(5E16.8)'
  write(111,'(5E16.8)') (qcm5(i),i = 1,nat)
close(111)

end program

! form Tkk' eq.3,4
real(kind=8) function tkk(i,j)
implicit none
integer i,j
real(8) dz(54)
real(8) dzz(6)

data dz /0.0056,-0.1543, &
 0.0, 0.0333, -0.1030, -0.0446, -0.1072, -0.0802, -0.0629, -0.1088, & ! Li-Ne
0.0184, 0.0 ,-0.0726, -0.0790, -0.0756, -0.0565, -0.0444, -0.07676,  & !Na-Ar
0.0130, 0.0,10*0.0,-0.0557,-0.0533,-0.0399, -0.0313,0.0,0.0, & !K-Kr
16*0.0, -0.0220,0.0/ !Rb - Xe

!H-C; H-N H-O C-N C-O N-O
data dzz /0.0502d0,0.1747d0,0.1671d0,0.0556d0, 0.0234d0,-0.0346d0/

tkk=dz(i)-dz(j)

! catch special cases
 if(i==1.and.j==6) tkk=dzz(1)
 if(i==1.and.j==7) tkk=dzz(2)
 if(i==1.and.j==8) tkk=dzz(3)
 if(i==6.and.j==7) tkk=dzz(4)
 if(i==6.and.j==8) tkk=dzz(5)
 if(i==7.and.j==8) tkk=dzz(6)

 if(i==6.and.j==1) tkk=-dzz(1)
 if(i==7.and.j==1) tkk=-dzz(2)
 if(i==8.and.j==1) tkk=-dzz(3)
 if(i==7.and.j==6) tkk=-dzz(4)
 if(i==8.and.j==6) tkk=-dzz(5)
 if(i==8.and.j==7) tkk=-dzz(6)

end function

subroutine read_hirsh(qh,nat,fname)
implicit none
integer nat,i
real(8) qh(nat)
character(*) fname
character(80) aa
real(8) xx,yy

write(*,*) 'reading ORCA file :  ', trim(fname)
open(99,file=fname)
do
read(99,'(a)') aa
if(index(aa,'HIRSHFELD ANALYSIS').ne.0) then
! 6 dummy line, then read
read(99,'(a)') aa
read(99,'(a)') aa
read(99,'(a)') aa
read(99,'(a)') aa
read(99,'(a)') aa
read(99,'(a)') aa
do i=1,nat
read(99,*) yy,aa,qh(i),xx
enddo
exit
endif
enddo

! read charges file for testing
!open(99,file='charges')
!do i=1,nat
!read(99,*) qh(i)
!enddo

close(99)

end

!************************************************************
!* reads a turbomole (bohr) or xmol (angst)rom file.        *
!* Tests if xmol starts with "number of atoms + blank" or   *
!* directly with the coordinates.                           *
!************************************************************
subroutine tmolrd(nat,xyz,iat,infile,echo,c_nat)
!use parm
implicit none

integer i,j,k,l,nat
real(8) xyz(3,*),energy,s2r
integer ifrez(nat),iat(nat)

character*2 cc,ff
character(200)  atmp
character*(*) infile
real(kind=8) txyz(3,nat),xx(10)
real(kind=8) bohr
integer tiat(nat),nn,tifrez(nat),istat,iff
logical da,c_nat,echo,doORCA
bohr=0.52917726d0
i=0
tifrez=0
iff=0
doORCA=.false.

inquire(file=infile,exist=da)
select case (da)
case (.true.)
      if(echo) write(*,'('' reading...'',$)')

open(unit=33,file=infile)
! test for tmol or txyz file

! test for ORCA
do i=1,10
 read(33,'(a)') atmp ! $coord
if(index(atmp,' O   R   C   A ').ne.0) doORCA=.true.
enddo
rewind(33)

 read(33,'(a)') atmp ! $coord
rewind(33)
if(index(atmp,'$coord').ne.0) then

 ! count number of atoms
 do while (da)
  read(33,'(a)',end=100) atmp ! $coord
   if(index(atmp,'$coord').ne.0) cycle
   if(index(atmp,'$').ne.0) exit
   i=i+1
  enddo
 nat=i
 100 continue
 if(c_nat) then
  close(33)
  return  ! just return number of atoms
 endif
 rewind(unit=33)

 ! read TMOL file
 read(33,*) atmp ! $coord
 do j=1,nat
    read(33,'(a)') atmp ! $coord
    backspace(33)
    if(index(atmp,' f ').ne.0) then
    read(33,*) txyz(1,j),txyz(2,j),txyz(3,j),cc,ff
     tifrez(j)=1
    iff=iff+1
    else ! default
     read(33,*) txyz(1,j),txyz(2,j),txyz(3,j),cc
   endif
   call elem(cc,tiat(j))
   txyz(1:3,j)=txyz(1:3,j)
  enddo
 if(echo) write(*,*) ' Turbomole file [bohr] :  ', trim(infile)

 close(33)

!**********
! PDB FILE
!**********
elseif(index(atmp,'REMARK').ne.0.or.index(atmp,'ATOM').ne.0) then
rewind(33)

 if(c_nat) then ! just count atoms
  do
   read (33,'(a)',end=777) atmp
   if(index(atmp,'ATOM').ne.0) i=i+1
  enddo
  777 continue
  nat=i
  close(33)
  return
  endif

   i=0
   do
     read (33,'(a)',end=778) atmp
     if(index(atmp,'ATOM').ne.0) then
      i=i+1
      txyz(1,i)=s2r(atmp(31:38))
      txyz(2,i)=s2r(atmp(39:46))
      txyz(3,i)=s2r(atmp(47:54))
     endif
   enddo
  txyz=0
 778 continue
   txyz=txyz*1d0/bohr
   close(33)
   if(echo) write(*,'(5x,'' PDB file [angst]: '',a)')  trim(infile)
!******************
!* ORCA output file
!******************
elseif(doORCA) then
i=0
if(c_nat) then ! just count atoms
do
 read(33,'(a)',end=801) atmp
 if(index(atmp,'CARTESIAN COORDINATES (A.U.)').ne.0) then
  read(33,'(a)') atmp
 do
  read(33,'(a)') atmp
  i=i+1
  if(index(atmp,'------').ne.0) goto 800
 enddo
 endif
enddo
800 continue
nat=i-3
close(33)
801 continue
if(nat<=0) stop 'no atoms found!'
return
endif

i=0
do
 read(33,'(a)',end=779) atmp
 if(index(atmp,'CARTESIAN COORDINATES (A.U.)').ne.0) then
 read(33,'(a)') atmp ! dummy line
 read(33,'(a)') atmp ! dummy line
 do i=1,nat
   read(33,'(a)') atmp ! dummy line
   call readl(atmp,xx,nn)
   call elem(atmp,tiat(i))
   txyz(1:3,i)=xx(5:7)
 enddo
 endif
enddo
779 continue
close(33)
 if(echo) write(*,'(5x,'' ORCA output file [A.U.]: '',a)')  trim(infile)

!******************
!* TMOL output file
!******************
else ! txyz file
       read(33,'(a)',end=101) atmp
! check for first two lines
       call readl(atmp,xx,nn)
        if(nn.gt.1) then   ! more than one argument found, assuming they are coords
           do
            nat=nat+1
            read(33,'(a)',end=123) atmp
           enddo
            if(c_nat) then
              close(33)
              return  ! just return number of atoms
            endif
          else
            nat=idint(xx(1))
            if(c_nat) then
             close(33)
             return  ! just return number of atoms
            endif
           read(33,'(a)',end=101) atmp  !titel line
        endif
 123   if(nn.gt.1) rewind(3)
       do i=1,nat
            read(33,'(a)') atmp
            call readl(atmp,xx,nn)
            call elem(atmp,tiat(i))
            txyz(1:3,i)=xx(1:3)*1d0/bohr
       enddo
 101  close(33)
      if(echo) write(*,'(5x,'' XYZ file [angst]: '',a)')  trim(infile)
      endif

if(maxval(tifrez,nat).eq.1) then
 if(echo) then
  write(*,'(a,x,I4,x,a)') '  found ',iff,' frozen cart. coordinates'
  if(iff.lt.50) then ! dont spam the output to much ...
   write(*,'(a,$)') '  atom nr: '
   do i=1,nat
     if(tifrez(i)==1) write(*,'(x,I2,$)') i
   enddo
   print*,''
  endif
 endif
endif

case (.false.)
  write(*,*) ' no input file <',trim(infile) ,'> found !! '
end select

do i=1,nat
xyz(1:3,i)=txyz(1:3,i)
iat(i)=tiat(i)
ifrez(i)=tifrez(i)
enddo
return

end subroutine

 SUBROUTINE ELEM(KEY1, NAT)
 IMPLICIT DOUBLE PRECISION (A-H,O-Z)
 CHARACTER*(*) KEY1
 CHARACTER*2 ELEMNT(94),E

 DATA ELEMNT/'h ','he',                                      &
 'li','be','b ','c ','n ','o ','f ','ne',                    &
 'na','mg','al','si','p ','s ','cl','ar',                    &
 'k ','ca','sc','ti','v ','cr','mn','fe','co','ni','cu',     &
 'zn','ga','ge','as','se','br','kr',                         &
 'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag',     &
 'cd','in','sn','sb','te','i ','xe',                         &
 'cs','ba','la','ce','pr','nd','pm','sm','eu','gd','tb','dy',&
 'ho','er','tm','yb','lu','hf','ta','w ','re','os','ir','pt',&
 'au','hg','tl','pb','bi','po','at','rn',                    &
 'fr','ra','ac','th','pa','u ','np','pu'/

 nat=0
 e='  '
 k=1
 DO J=1,len(key1)
    if (k.gt.2)exit
    N=ICHAR(key1(J:J))
    if(n.ge.ichar('A') .and. n.le.ichar('Z') )then
       e(k:k)=char(n+ICHAR('a')-ICHAR('A'))
       k=k+1
    endif
    if(n.ge.ichar('a') .and. n.le.ichar('z') )then
       e(k:k)=key1(j:j)
       k=k+1
    endif
 enddo
 DO I=1,107
         if(e.eq.elemnt(i))then
            NAT=I
            RETURN
         ENDIF
      ENDDO

      end

character*2 FUNCTION ESYM(I)
CHARACTER*2 ELEMNT(94)
DATA ELEMNT/'h ','he',                                           &
  'li','be','b ','c ','n ','o ','f ','ne',                       &
  'na','mg','al','si','p ','s ','cl','ar',                       &
  'k ','ca','sc','ti','v ','cr','mn','fe','co','ni','cu',        &
  'zn','ga','ge','as','se','br','kr',                            &
  'rb','sr','y ','zr','nb','mo','tc','ru','rh','pd','ag',        &
  'cd','in','sn','sb','te','i ','xe',                            &
  'cs','ba','la','ce','pr','nd','pm','sm','eu','gd','tb','dy',   &
  'ho','er','tm','yb','lu','hf','ta','w ','re','os','ir','pt',   &
  'au','hg','tl','pb','bi','po','at','rn',                       &
  'fr','ra','ac','th','pa','u ','np','pu'/
  ESYM=ELEMNT(I)
  RETURN
END

      SUBROUTINE READL(A1,X,N)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*(*) A1
      DIMENSION X(*)
      I=0
      IS=1
  10  I=I+1
      X(I)=READAA(A1,IS,IB,IE)
      IF(IB.GT.0 .AND. IE.GT.0) THEN
                                IS=IE
                                GOTO 10
      ENDIF
      N=I-1
      RETURN
      END

      FUNCTION READAA(A,ISTART,IEND,IEND2)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 READAA
      CHARACTER*(*) A
      NINE=ICHAR('9')
      IZERO=ICHAR('0')
      MINUS=ICHAR('-')
      IDOT=ICHAR('.')
      ND=ICHAR('D')
      NE=ICHAR('E')
      IBL=ICHAR(' ')
      IEND=0
      IEND2=0
      IDIG=0
      C1=0
      C2=0
      ONE=1.D0
      X = 1.D0
      NL=LEN(A)
      DO 10 J=ISTART,NL-1
         N=ICHAR(A(J:J))
         M=ICHAR(A(J+1:J+1))
         IF(N.LE.NINE.AND.N.GE.IZERO .OR.N.EQ.IDOT)GOTO 20
         IF(N.EQ.MINUS.AND.(M.LE.NINE.AND.M.GE.IZERO.OR. M.EQ.IDOT)) GOTO 20

   10 CONTINUE
      READAA=0.D0
      RETURN
   20 CONTINUE
      IEND=J
      DO 30 I=J,NL
         N=ICHAR(A(I:I))
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN
            IDIG=IDIG+1
            IF (IDIG.GT.10) GOTO 60
            C1=C1*10+N-IZERO
         ELSEIF(N.EQ.MINUS.AND.I.EQ.J) THEN
            ONE=-1.D0
         ELSEIF(N.EQ.IDOT) THEN
            GOTO 40
         ELSE
            GOTO 60
         ENDIF
   30 CONTINUE
   40 CONTINUE
      IDIG=0
      DO 50 II=I+1,NL
         N=ICHAR(A(II:II))
         IF(N.LE.NINE.AND.N.GE.IZERO) THEN
            IDIG=IDIG+1
            IF (IDIG.GT.10) GOTO 60
            C2=C2*10+N-IZERO
            X = X /10
         ELSEIF(N.EQ.MINUS.AND.II.EQ.I) THEN
            X=-X
         ELSE
            GOTO 60
         ENDIF
   50 CONTINUE
!C
!C PUT THE PIECES TOGETHER
!C
   60 CONTINUE
      READAA= ONE * ( C1 + C2 * X)
      DO 55 J=IEND,NL
         N=ICHAR(A(J:J))
         IEND2=J
         IF(N.EQ.IBL)RETURN
   55 IF(N.EQ.ND .OR. N.EQ.NE)GOTO 57
      RETURN

   57 C1=0.0D0
      ONE=1.0D0
      DO 31 I=J+1,NL
         N=ICHAR(A(I:I))
         IEND2=I
         IF(N.EQ.IBL)GOTO 70
         IF(N.LE.NINE.AND.N.GE.IZERO) C1=C1*10.0D0+N-IZERO
         IF(N.EQ.MINUS)ONE=-1.0D0
   31 CONTINUE
   61 CONTINUE
   70 READAA=READAA*10**(ONE*C1)
      RETURN
      END
!********************************
!* convert a word to lower case *
!********************************
      subroutine lower_case(word)
      character (len=*) , intent(in out) :: word
      integer :: i,ic,nlen
      nlen = len(word)
      do i=1,nlen
      ic = ichar(word(i:i))
      if (ic >= 65 .and. ic < 90) word(i:i) = char(ic+32)
      end do
      end subroutine lower_case

!********************************************
!* split a string s into n separate words w *
!********************************************
subroutine charsplit(s,n,w)
implicit none
integer i,n,k
character*80, intent(in) :: s
character*80, intent(out) :: w(n)
character*80   a,aa

aa=adjustl(s)
do i=1,n
  a=aa
  k=index(a,' ')
  w(i)=trim(a(:(k-1)))
  aa=adjustl(trim(a((k+1):)))
enddo
return
end subroutine

!***************************************************
!* split a string s iand the return the x'ths word *
!***************************************************
subroutine charXsplit(s,wx,x)
implicit none
integer i,n,k,x
character*80, intent(in) :: s
character*80, intent(out) ::wx
character*80   w(20)
character*80   a,aa

aa=adjustl(s)
i=0
do while (index(aa,' ').ne.1)
  i=i+1
  a=aa
  k=index(a,' ')
  w(i)=trim(a(:(k-1)))
  aa=adjustl(trim(a((k+1):)))
!  print*,'AA',trim(aa),index(aa,' ')
  if(i.gt.50) stop '!* string split error: subroutine charXsplit *!'
enddo
wx=w(x)
!print*, trim(wx)
return
end subroutine

!***********************************
!*  count words n in string s      *
!***********************************
subroutine cstring(s,n)
implicit none
integer i,n,k,x
character(*), intent(in) :: s
character*80   a,aa
aa=adjustl(s)
i=0
do while (index(aa,' ').ne.1)
  i=i+1
  a=aa
  k=index(a,' ')
!  w(i)=trim(a(:(k-1)))
  aa=adjustl(trim(a((k+1):)))
!  print*,'AA',trim(aa),index(aa,' ')
  if(i.gt.50) stop '!* string split error: subroutine charXsplit *!'
enddo
n=i
return
end subroutine

integer function nwords(s)
implicit none
integer i,k,x
character(*), intent(in) :: s
character*80   a,aa
aa=adjustl(s)
i=0
do while (index(aa,' ').ne.1)
  i=i+1
  a=aa
  k=index(a,' ')
!  w(i)=trim(a(:(k-1)))
  aa=adjustl(trim(a((k+1):)))
!  print*,'AA',trim(aa),index(aa,' ')
  if(i.gt.50) stop '!* string split error: subroutine charXsplit *!'
enddo
nwords=i
return
end function

! String to integer
integer pure function s2i(a)
implicit none
character(*), intent(in):: a
read(a,*) s2i
return
end function

! String to real(8)
real(8) pure function s2r(a)
implicit none
character(*), intent(in):: a
read(a,*) s2r
return
end function

!******************
!* write xyz      *
!******************
subroutine wrxyz(iat,nat,xyz,infile)
implicit none
integer i,j,k,l,nat,iat(nat)
real(8) xyz(3,*)
integer ierr
character(*) infile
character(2) esym
real(8) f

!f=0.5291770d0
f=1d0
open(unit=55,file=infile,iostat=ierr,status='replace')
if(ierr.ne.0) stop 'cannot write xopt.xyz'
write(55,'(I5)') nat
write(55,*)
!write(55,'(2F16.8)')energy,gnorm
do i=1,nat
 write(55,'(a2,5x,3(F18.14,3x))') esym(iat(i)), xyz(1,i)*f,xyz(2,i)*f,xyz(3,i)*f
enddo
close(55)
end subroutine wrxyz

integer function kdelta(i,j)
implicit none
integer i,j

kdelta=0
if(i==j) kdelta=1

end function


C$Procedure    ZZPSXTNT ( MKDSK, compute plate set extents )

      SUBROUTINE ZZPSXTNT ( NV, VERTS, NP, PLATES, EXTENT, AVPLEX )

C$ Abstract
C
C     Compute plate set extents and average plate extent.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     DSK
C
C$ Keywords
C
C     DSK
C     FILES
C
C$ Declarations

      IMPLICIT NONE

      INCLUDE 'mkdsk02.inc'

      INTEGER               NV
      DOUBLE PRECISION      VERTS  ( 3, * )
      INTEGER               NP
      INTEGER               PLATES ( 3, * )
      DOUBLE PRECISION      EXTENT ( 2, 3 )
      DOUBLE PRECISION      AVPLEX

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     NV         I   Vertex count.
C     VERTS      I   Vertices.
C     NP         I   Plate count.
C     PLATES     I   Plates.
C     EXTENT     O   Extents of the vertex set.
C     AVPLEX     O   Average plate extent.
C
C$ Detailed_Input
C
C     NV             is the number of vertices in the input vertex
C                    array.
C
C     VERTS          is an array of vertices associated with plates.
C
C     NP             is the number of plates in the input plate array.
C
C     PLATES         is an array of triangular plates. The element
C
C                       PLATES(J,I)
C
C                    is the index in the VERTS array of the Jth vertex
C                    of the Ith plate. The vertex indices are 1-based.
C
C$ Detailed_Output
C
C     EXTENT         is the extent of the input vertex set. See
C                    Particulars.
C
C     AVPLEX         is the average extent of the plates in the
C                    plate set. See Particulars.
C
C$ Parameters
C
C     See mkdsk02.inc
C
C$ Exceptions
C
C     This routine is meant to be operated in RETURN SPICE error
C     handling mode. The caller is expected to delete the DSK file if
C     an error occurs during file creation.
C
C
C     1)  If the vertex count is less than 3 or greater than MAXVRT,
C         the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C     2)  If the plate count is less than 1 or greater than MAXPLT,
C         the error SPICE(VALUEOUTOFRANGE) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The "extent" of a set of vertices is the set of extrema
C     of the coordinates of those vertices.
C
C     The extent of a plate along a coordinate axis is the length of
C     the orthogonal projection of the plate onto that axis.
C
C     The average "extent" of a set of plates is the average of the
C     extents of the plates along the coordinate axes.
C
C$ Examples
C
C     See usage in MKDSK.
C
C$ Restrictions
C
C     This routine should be called only from within MKDSK.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    MKDSK Version 1.0.0, 18-FEB-2017 (NJB)
C
C-&

C$ Index_Entries
C
C     determine vertex set extents and average plate extent
C
C-&

C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      DPMIN

      LOGICAL               RETURN

C
C     Local parameters
C

C
C     Local variables
C
      DOUBLE PRECISION      PLTBDS ( 2 )
      DOUBLE PRECISION      SUM

      INTEGER               I
      INTEGER               J
      INTEGER               K

      IF ( RETURN() ) THEN
         RETURN
      END IF

      CALL CHKIN ( 'ZZPSXTNT' )

C
C     Reject invalid plate and vertex counts.
C
      IF (  ( NV .LT. 3 ) .OR. ( NV .GT. MAXVRT )  ) THEN

         CALL SETMSG ( 'Vertex count NV = #; count must '
     .   //            'be in the range 3:#.'            )
         CALL ERRINT ( '#',  NV                          )
         CALL ERRINT ( '#',  MAXVRT                      )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'          )
         CALL CHKOUT ( 'ZZPSXTNT'                        )
         RETURN

      END IF

      IF (  ( NP .LT. 1 ) .OR. ( NP .GT. MAXPLT )  ) THEN

         CALL SETMSG ( 'Plate count NP = #; count must '
     .   //            'be in the range 1:#.'            )
         CALL ERRINT ( '#',  NP                          )
         CALL ERRINT ( '#',  MAXPLT                      )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'          )
         CALL CHKOUT ( 'ZZPSXTNT'                        )
         RETURN

      END IF

C
C     Compute extents of the plate set. These depend only on
C     the vertex set.
C
      DO I = 1, 3

         EXTENT(1,I) = DPMAX()
         EXTENT(2,I) = DPMIN()

      END DO

      DO I = 1, NV

         DO J = 1, 3

            EXTENT(1,J) = MIN( EXTENT(1,J), VERTS(J,I) )
            EXTENT(2,J) = MAX( EXTENT(2,J), VERTS(J,I) )

         END DO

      END DO

C
C     Compute plate extents in all 3 dimensions; compute
C     the average of all extents.
C
      SUM = 0.D0

      DO I = 1, NP
C
C        I is the current plate index.
C
         DO J = 1, 3
C
C           J is the current coordinate index.
C
            PLTBDS(1) = DPMAX()
            PLTBDS(2) = DPMIN()

            DO K = 1, 3
C
C              K is the current vertex index for the current plate.
C              Account for this vertex's contributions to the plate's
C              extent in the direction of coordinate J.
C
               PLTBDS(1) = MIN( PLTBDS(1),  VERTS( J, PLATES(K,I) ) )
               PLTBDS(2) = MAX( PLTBDS(2),  VERTS( J, PLATES(K,I) ) )

            END DO
C
C           Add the current plate's extent in the Jth coordinate.
C
            SUM = SUM + ( PLTBDS(2) - PLTBDS(1) )

         END DO

      END DO

C
C     We've added three extents per plate, so we have 3*NP in all.
C     Note we've ensured NP is positive.
C
      AVPLEX = SUM / ( 3*NP )

      CALL CHKOUT ( 'ZZPSXTNT' )
      RETURN
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###########################################################
c     ##                                                       ##
c     ##  subroutine gradrot  --  energy and torsional derivs  ##
c     ##                                                       ##
c     ###########################################################
c
c
c     "gradrot" calls subroutines to calculate the potential
c     energy and its torsional first derivatives
c
c
      subroutine gradrot (energy,derivs)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'deriv.i'
      include 'domega.i'
      include 'omega.i'
      include 'potent.i'
      include 'rotate.i'
      integer i,j,k
      integer base,partner
      real*8 energy,norm
      real*8 xatom,yatom,zatom
      real*8 xdist,ydist,zdist
      real*8 xterm,yterm,zterm
      real*8 derivs(*)
      real*8, allocatable :: g(:,:)
c
c
c     zero out individual components of torsional derivatives
c
      do i = 1, nomega
         teb(i) = 0.0d0
         tea(i) = 0.0d0
         teba(i) = 0.0d0
         teub(i) = 0.0d0
         teaa(i) = 0.0d0
         teopb(i) = 0.0d0
         teopd(i) = 0.0d0
         teid(i) = 0.0d0
         teit(i) = 0.0d0
         tet(i) = 0.0d0
         tept(i) = 0.0d0
         tebt(i) = 0.0d0
         tett(i) = 0.0d0
         tev(i) = 0.0d0
         tec(i) = 0.0d0
         tecd(i) = 0.0d0
         ted(i) = 0.0d0
         tem(i) = 0.0d0
         tep(i) = 0.0d0
         ter(i) = 0.0d0
         tes(i) = 0.0d0
         telf(i) = 0.0d0
         teg(i) = 0.0d0
         tex(i) = 0.0d0
      end do
c
c     perform dynamic allocation of some local arrays
c
      allocate (g(3,n))
c
c     calculate the energy and Cartesian first derivatives
c
      call gradient (energy,g)
c
c     perform deallocation of some local arrays
c
      deallocate (g)
c
c     transform Cartesian derivatives to torsional space
c
      do i = 1, nomega
         base = iomega(1,i)
         partner = iomega(2,i)
         call rotlist (base,partner)
         xdist = x(base) - x(partner)
         ydist = y(base) - y(partner)
         zdist = z(base) - z(partner)
         norm = sqrt(xdist**2 + ydist**2 + zdist**2)
         xdist = xdist / norm
         ydist = ydist / norm
         zdist = zdist / norm
         do j = 1, nrot
            k = rot(j)
            xatom = x(k) - x(base)
            yatom = y(k) - y(base)
            zatom = z(k) - z(base)
            xterm = ydist*zatom - zdist*yatom
            yterm = zdist*xatom - xdist*zatom
            zterm = xdist*yatom - ydist*xatom
            teb(i) = teb(i) + deb(1,k)*xterm + deb(2,k)*yterm
     &                              + deb(3,k)*zterm
            tea(i) = tea(i) + dea(1,k)*xterm + dea(2,k)*yterm
     &                              + dea(3,k)*zterm
            teba(i) = teba(i) + deba(1,k)*xterm + deba(2,k)*yterm
     &                              + deba(3,k)*zterm
            teub(i) = teub(i) + deub(1,k)*xterm + deub(2,k)*yterm
     &                              + deub(3,k)*zterm
            teaa(i) = teaa(i) + deaa(1,k)*xterm + deaa(2,k)*yterm
     &                              + deaa(3,k)*zterm
            teopb(i) = teopb(i) + deopb(1,k)*xterm + deopb(2,k)*yterm
     &                              + deopb(3,k)*zterm
            teopd(i) = teopd(i) + deopd(1,k)*xterm + deopd(2,k)*yterm
     &                              + deopd(3,k)*zterm
            teid(i) = teid(i) + deid(1,k)*xterm + deid(2,k)*yterm
     &                              + deid(3,k)*zterm
            teit(i) = teit(i) + deit(1,k)*xterm + deit(2,k)*yterm
     &                              + deit(3,k)*zterm
            tet(i) = tet(i) + det(1,k)*xterm + det(2,k)*yterm
     &                              + det(3,k)*zterm
            tept(i) = tept(i) + dept(1,k)*xterm + dept(2,k)*yterm
     &                              + dept(3,k)*zterm
            tebt(i) = tebt(i) + debt(1,k)*xterm + debt(2,k)*yterm
     &                              + debt(3,k)*zterm
            tett(i) = tett(i) + dett(1,k)*xterm + dett(2,k)*yterm
     &                              + dett(3,k)*zterm
            tev(i) = tev(i) + dev(1,k)*xterm + dev(2,k)*yterm
     &                              + dev(3,k)*zterm
            tec(i) = tec(i) + dec(1,k)*xterm + dec(2,k)*yterm
     &                              + dec(3,k)*zterm
            tecd(i) = tecd(i) + decd(1,k)*xterm + decd(2,k)*yterm
     &                              + decd(3,k)*zterm
            ted(i) = ted(i) + ded(1,k)*xterm + ded(2,k)*yterm
     &                              + ded(3,k)*zterm
            tem(i) = tem(i) + dem(1,k)*xterm + dem(2,k)*yterm
     &                              + dem(3,k)*zterm
            tep(i) = tep(i) + dep(1,k)*xterm + dep(2,k)*yterm
     &                              + dep(3,k)*zterm
            ter(i) = ter(i) + der(1,k)*xterm + der(2,k)*yterm
     &                              + der(3,k)*zterm
            tes(i) = tes(i) + des(1,k)*xterm + des(2,k)*yterm
     &                              + des(3,k)*zterm
            telf(i) = telf(i) + delf(1,k)*xterm + delf(2,k)*yterm
     &                              + delf(3,k)*zterm
            teg(i) = teg(i) + deg(1,k)*xterm + deg(2,k)*yterm
     &                              + deg(3,k)*zterm
            tex(i) = tex(i) + dex(1,k)*xterm + dex(2,k)*yterm
     &                              + dex(3,k)*zterm
         end do
      end do
c
c     sum up to give the total torsional first derivatives
c
      do i = 1, nomega
         tesum(i) = teb(i) + tea(i) + teba(i) + teub(i) + teaa(i)
     &                 + teopb(i) + teopd(i) + teid(i) + teit(i)
     &                 + tet(i) + tept(i) + tebt(i) + tett(i) + tev(i)
     &                 + tec(i) + tecd(i) + ted(i) + tem(i) + tep(i)
     &                 + ter(i) + tes(i) + telf(i) + teg(i) + tex(i)
         derivs(i) = tesum(i)
      end do
      return
      end