

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C         B E G I N   O F   P B C   P A R T 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
c read coordinates in Angst and converts them to au 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

c      subroutine pbcrdcoord(fname,lattice,n,xyz,iat,autoang)
c      implicit none             
c      interface
c        subroutine parse(str,delims,args,nargs)
c        character(len=*),intent(inout) :: str
c        character(len=*),intent(in)  :: delims
c        character(len=*),dimension(:),intent(inout) :: args
c        integer, intent(out) :: nargs
c        end subroutine parse
c      end interface
c       
c      real*8                :: xyz(3,*)
c      real*8, INTENT(OUT)   ::lattice(3,3)
c      integer, INTENT(out)               :: iat(*) 
c      integer, INTENT(in)               :: n 
c      character*(*), INTENT(IN)          :: fname
c      logical              :: selective=.FALSE. ! Selective dynamics
c      logical              :: cartesian=.TRUE.  ! Cartesian or direct
c      real*8, INTENT(IN)   ::autoang
c
c      real*8 xx(10),scalar
c      character*80 line,args(90),args2(90)
c      
c      integer i,j,ich,nn,ntype,ntype2,atnum,i_dummy1,i_dummy2,ncheck
c
c
c      lattice=0
c      
c      ich=142
c      open(unit=ich,file=fname)
c      rewind(ich)
c      ncheck=0
c      ntype=0
c      read(ich,'(a)',end=200)line !first line must contain Element Info
c      call parse(line,' ',args,ntype)
c      read(ich,'(a)',end=200)line !second line contains global scaling factor
c      call readl(line,xx,nn)
c      scalar=xx(1)/autoang        !the Ang->au conversion is included in the scaling factor
cc      write(*,'(F8.6)')scalar
c      DO i=1,3            ! reading the lattice constants
c        read(ich,'(a)',end=200)line
c        call readl(line,xx,nn)
c        IF (nn < 3) call stoprun( 'Error reading unit cell vectors' )
c        lattice(1,i)=xx(1)*scalar
c        lattice(2,i)=xx(2)*scalar
c        lattice(3,i)=xx(3)*scalar
c      !  write(*,'(3F6.2)')lattice(1,i),lattice(2,i),lattice(3,i)
c      ENDDO
c      read(ich,'(a)',end=200)line !Ether here are the numbers of each element, or (>vasp.5.1) here are the element symbols
c      line=adjustl(line)
c      call readl(line,xx,nn)
c      IF (nn.eq.0) then      ! CONTCAR files have additional Element line here since vasp.5.1
c        call parse(line,' ',args,ntype)
c        read(ich,'(a)',end=200)line
c        line=adjustl(line)
c        call readl(line,xx,nn)
c      ENDIF
c!       call elem(args(1),i_dummy2)
c!       IF (i_dummy2<1 .OR. i_dummy2>94) THEN
c!          args=args2
c!       ENDIF
c      IF (nn.NE.ntype ) THEN
c!         IF(nn.NE.ntype2) THEN
c        call stoprun( 'Error reading number of atomtypes')
c!         ELSE
c!           ntype=ntype2
c!         ENDIF
c      ENDIF
c      ncheck=0
c      DO i=1,nn
c        i_dummy1=INT(xx(i))
c        call elem(args(i),i_dummy2)
c        IF (i_dummy2<1 .OR. i_dummy2>94) 
c     .   call stoprun( 'Error: unknown element.')
c        DO j=1,i_dummy1
c          ncheck=ncheck+1
c          iat(ncheck)=i_dummy2
c        ENDDO
c      ENDDO
c      if (n.ne.ncheck) call stoprun('Error reading Number of Atoms')
c
c      read(ich,'(a)',end=200)line
c      line=adjustl(line)
c      IF (line(:1).EQ.'s' .OR. line(:1).EQ.'S') THEN
c        selective=.TRUE.
c        read(ich,'(a)',end=200)line
c        line=adjustl(line)
c      ENDIF
c
cc      write(*,*)line(:1)
c      cartesian=(line(:1).EQ.'c' .OR. line(:1).EQ.'C' .OR. 
c     .line(:1).EQ.'k' .OR. line(:1).EQ.'K')
c      DO i=1,n
c        read(ich,'(a)',end=200)line
c        call readl(line,xx,nn)
c        IF (nn.NE.3) call stoprun( 'Error reading coordinates.')
c
c        IF (cartesian) THEN
c          xyz(1,i)=xx(1)*scalar
c          xyz(2,i)=xx(2)*scalar
c          xyz(3,i)=xx(3)*scalar
c        ELSE
c          xyz(1,i)=lattice(1,1)*xx(1)+lattice(1,2)*
c     .    xx(2)+lattice(1,3)*xx(3)
c          xyz(2,i)=lattice(2,1)*xx(1)+lattice(2,2)*xx(2)+lattice(2,3)*
c     .    xx(3)
c          xyz(3,i)=lattice(3,1)*xx(1)+lattice(3,2)*xx(2)+lattice(3,3)*
c     .    xx(3)
c        ENDIF
c        
cc      write(*,321)xyz(:,i),iat(i)   !debug printout
c      
c      ENDDO
c
c      
cc      IF line(1)
c
cc      lattice(1,*)=xx
c      
c
cc      call readl(line,xx,nn)
c      
c 200  continue
c
c      close(ich)
cc  321 FORMAT(3F20.10,1X,I3) !debug output
c      end subroutine pbcrdcoord


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C compute coordination numbers by adding an inverse damping function
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine pbcncoord_sh(natoms,rcov,iz,xyz,cn,lat,rep_cn,crit_cn)
      implicit none  
      !include 'param'

#include "global.fh"
#include "msgtypesf.h" 

      real*8 k1,k2,k3

c global ad hoc parameters
      parameter (k1=16.0)
      parameter (k2=4./3.) 

c reasonable choices are between 3 and 5
c this gives smoth curves with maxima around the integer values
c k3=3 give for CN=0 a slightly smaller value than computed
c for the free atom. This also yields to larger CN for atoms
c in larger molecules but with the same chem. environment
c which is physically not right
c values >5 might lead to bumps in the potential
      parameter (k3=-4.) 


      integer,intent(in) :: natoms,iz(*)
      real*8,intent(in)  :: rcov(94)

      integer i,max_elem,rep_cn(3)
      real*8 xyz(3,*),cn(*),lat(3,3)

      integer iat,taux,tauy,tauz    
      real*8 dx,dy,dz,r,damp,xn,rr,rco,tau(3)
      real*8, INTENT(IN) :: crit_cn
      integer taskid,np,pcount

      call dcopy(natoms,0.0d0,0,cn,1)
      taskid = GA_Nodeid()
      np     = GA_Nnodes()
      pcount = 0

      do i=1,natoms
      xn=0.0d0
      do iat=1,natoms

        if (mod(pcount,np).eq.taskid) then

        do taux=-rep_cn(1),rep_cn(1)
         do tauy=-rep_cn(2),rep_cn(2)
          do tauz=-rep_cn(3),rep_cn(3)
            if(iat.eq.i .and. taux.eq.0 .and. tauy.eq.0 .and. 
     .       tauz.eq.0)        cycle
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
            dx=xyz(1,iat)-xyz(1,i)+tau(1)
            dy=xyz(2,iat)-xyz(2,i)+tau(2)
            dz=xyz(3,iat)-xyz(3,i)+tau(3)
            r=(dx*dx+dy*dy+dz*dz)
            if (r.gt.crit_cn) cycle
            r=sqrt(r)
c covalent distance in Bohr
            rco=rcov(iz(i))+rcov(iz(iat))
            rr=rco/r
c counting function exponential has a better long-range behavior than MHGs inverse damping
            damp=1.d0/(1.d0+exp(-k1*(rr-1.0d0)))
            xn=xn+damp
c            print '("cn(",I2,I2,"): ",E14.8)',i,iat,damp

          enddo !tauz
         enddo !tauy
        enddo !taux

        end if
        pcount = pcount + 1

      enddo !iat
      cn(i)=xn  
      enddo !i


      if (np.gt.1) call GA_DGOP(9+MSGDBL,cn,natoms,'+')


      end subroutine pbcncoord_sh

c      subroutine pbcrdatomnumber(fname,n)
c      implicit none             
c      interface
c        subroutine parse(str,delims,args,nargs)
c        character(len=*),intent(inout) :: str
c        character(len=*),intent(in)  :: delims
c        character(len=*),dimension(:),intent(inout) :: args
c        integer, intent(out) :: nargs
c        end subroutine parse
c      end interface
c       
c      integer, INTENT(out)               :: n 
c      character*(*), INTENT(IN)          :: fname
c      logical              :: selective=.FALSE. ! Selective dynamics
c      logical              :: cartesian=.TRUE.  ! Cartesian or direct
c
c      real*8 xx(10),scalar,fdum
c      character*80 line,args(90),args2(90)
c      
c      integer i,j,ich,nn,ntype,ntype2,atnum,i_dummy1,i_dummy2
c      
c      ich=142
c      open(unit=ich,file=fname)
c      n=0
c      ntype=0
c      read(ich,'(a)',end=200)line !first line must contain Element Info
c      call parse(line,' ',args,ntype)
c      read(ich,'(a)',end=200)line !second line contains global scaling factor
c      call readl(line,xx,nn)
cc      write(*,'(F8.6)')scalar
c      DO i=1,3            ! reading the lattice constants
c        read(ich,'(a)',end=200)line
c        call readl(line,xx,nn)
c        IF (nn < 3) call stoprun( 'Error reading unit cell vectors' )
c      !  write(*,'(3F6.2)')lattice(1,i),lattice(2,i),lattice(3,i)
c      ENDDO
c      read(ich,'(a)',end=200)line !Ether here are the numbers of each element, or (>vasp.5.1) here are the element symbols
c      line=adjustl(line)
c      call readl(line,xx,nn)
c      IF (nn.eq.0) then      ! CONTCAR files have additional Element line here since vasp.5.1
c        call parse(line,' ',args,ntype)
c        read(ich,'(a)',end=200)line
c        line=adjustl(line)
c        call readl(line,xx,nn)
c      ENDIF
c!       call elem(args(1),i_dummy2)
c!       IF (i_dummy2<1 .OR. i_dummy2>94) THEN
c!          args=args2
c!       ENDIF
c      IF (nn.NE.ntype ) THEN
c!         IF(nn.NE.ntype2) THEN
c        call stoprun( 'Error reading number of atomtypes')
c!         ELSE
c!           ntype=ntype2
c!         ENDIF
c      ENDIF
c      n=0
c      DO i=1,nn
c        i_dummy1=INT(xx(i))
c          n=n+i_dummy1
c      ENDDO
c
c 200  continue
c
c      close(ich)
c      end subroutine pbcrdatomnumber



CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C compute energy
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
      subroutine pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e63,lat,rthr,rep_vdw,cn_thr,rep_cn)
      implicit none  

#include "global.fh"
#include "msgtypesf.h"

      integer max_elem,maxc
      real*8 r2r4(max_elem),rcov(max_elem)
      real*8 rs6,rs8,rs10,alp6,alp8,alp10
      real*8 rthr,cn_thr,crit_cn
      integer rep_vdw(3),rep_cn(3)
      integer n,iz(*),version,mxc(max_elem)
!      integer rep_v(3)=rep_vdw!,rep_cn(3)
      real*8 xyz(3,*),r0ab(max_elem,max_elem),lat(3,3)!,r2r4(*)
!      real*8 rs6,rs8,rs10,alp6,alp8,alp10,rcov(max_elem)
      real*8 c6ab(max_elem,max_elem,maxc,maxc,3)
      real*8 e6, e8, e10, e12, e63!,crit_vdw,crit_cn
      logical noabc
 
      integer iat,jat,kat
      real*8 r,r2,r6,r8,tmp,dx,dy,dz,c6,c8,c10,ang,rav
      real*8 damp6,damp8,damp10,rr,thr,c9,r42,c12,r10,c14
      real*8 cn(n),rxyz(3),dxyz(3)
      real*8 r2ab(n*n),cc6ab(n*n),dmp(n*n),d2(3),t1,t2,t3,tau(3)
      integer*2 icomp(n*n)
      integer lin_sh,ij,ik,jk
      integer taux,tauy,tauz,counter
      real*8 a1,a2  !BJ-parameter
      real*8 bj_dmp6,bj_dmp8
      integer taskid,np,pcount

      np     = GA_Nnodes()
      taskid = GA_Nodeid()
      pcount = 0



      e6 =0
      e8 =0
      e10=0
      e12=0
      e63=0
      tau=(/0.0,0.0,0.0/)
      counter=0
      crit_cn=cn_thr
c Becke-Johnson parameters
      a1=rs6
      a2=rs8      
      


C DFT-D2
      if(version.eq.2)then


      do iat=1,n-1
         do jat=iat+1,n
         if (mod(pcount,np).eq.taskid) then
           c6=c6ab(iz(jat),iz(iat),1,1,1)
           do taux=-rep_vdw(1),rep_vdw(1)
           do tauy=-rep_vdw(2),rep_vdw(2)
           do tauz=-rep_vdw(3),rep_vdw(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
            dx=xyz(1,iat)-xyz(1,jat)+tau(1)
            dy=xyz(2,iat)-xyz(2,jat)+tau(2)
            dz=xyz(3,iat)-xyz(3,jat)+tau(3)
            r2=dx*dx+dy*dy+dz*dz
           if(r2.gt.rthr) cycle
            r=sqrt(r2)
            damp6=1./(1.+exp(-alp6*(r/(rs6*r0ab(iz(jat),iz(iat)))-1.)))
            r6=r2**3      
            e6 =e6+c6*damp6/r6
            counter=counter+1
           enddo !taux
           enddo !tauy
           enddo !tauz
         end if
         pcount = pcount + 1
         enddo
      enddo
      
      do iat=1,n
      if (mod(pcount,np).eq.taskid) then
        jat=iat
        c6=c6ab(iz(jat),iz(iat),1,1,1)
        do taux=-rep_vdw(1),rep_vdw(1)
        do tauy=-rep_vdw(2),rep_vdw(2)
        do tauz=-rep_vdw(3),rep_vdw(3)
          if (taux.eq.0 .and. tauy.eq.0 .and. tauz.eq.0) cycle
          tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
          dx=tau(1)
          dy=tau(2)
          dz=tau(3)
          r2=dx*dx+dy*dy+dz*dz
           if(r2.gt.rthr) cycle
          r=sqrt(r2)
          damp6=1./(1.+exp(-alp6*(r/(rs6*r0ab(iz(jat),iz(iat)))-1.)))
          r6=r2**3      
          e6 =e6+c6*damp6/r6*0.50d0
          counter=counter+1
        enddo
        enddo
        enddo
      end if
      pcount = pcount + 1
      enddo !iat
!      write(*,*)'counter: ',counter

      if (np.gt.1) call GA_DGOP(9+MSGDBL,e6,1,'+')
      
      

      else if (version.eq.3) then
C DFT-D3(zero-damping)

      call dcopy(n*n,0.0d0,0,cc6ab,1)

      call pbcncoord_sh(n,rcov,iz,xyz,cn,lat,rep_cn,crit_cn)

      icomp=0
      do iat=1,n-1
         do jat=iat+1,n
         if (mod(pcount,np).eq.taskid) then
c get C6
          call getc6_sh(maxc,max_elem,c6ab,mxc,iz(iat),iz(jat),
     .                                  cn(iat),cn(jat),c6)

           do taux=-rep_vdw(1),rep_vdw(1)
           do tauy=-rep_vdw(2),rep_vdw(2)
           do tauz=-rep_vdw(3),rep_vdw(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

            dx=xyz(1,iat)-xyz(1,jat)+tau(1)
            dy=xyz(2,iat)-xyz(2,jat)+tau(2)
            dz=xyz(3,iat)-xyz(3,jat)+tau(3)
            r2=dx*dx+dy*dy+dz*dz
c cutoff

           if(r2.gt.rthr) cycle
            r =sqrt(r2)
            rr=r0ab(iz(jat),iz(iat))/r
c damping
            tmp=rs6*rr   
            damp6 =1.d0/( 1.d0+6.d0*tmp**alp6 )
            tmp=rs8*rr     
            damp8 =1.d0/( 1.d0+6.d0*tmp**alp8 )

            if(.not.noabc)then
              ij=lin_sh(jat,iat)
              icomp(ij)=1
c store C6 for C9, calc as sqrt
              cc6ab(ij)=sqrt(c6)
            endif

            r6=r2**3      
            e6 =e6+c6*damp6/r6
c             write(*,*)'e6: ',c6*damp6/r6*autokcal

c stored in main as sqrt
            c8 =3.0d0*c6*r2r4(iz(iat))*r2r4(iz(jat))
            r8 =r6*r2

            e8 =e8+c8*damp8/r8

            counter=counter+1

           enddo !tauz
           enddo !tauy
           enddo !taux
         end if
         pcount = pcount + 1
         enddo !jat
      enddo !iat
      
      do iat=1,n
      if (mod(pcount,np).eq.taskid) then
        jat=iat
c get C6
        call getc6_sh(maxc,max_elem,c6ab,mxc,iz(iat),iz(jat),
     .                                  cn(iat),cn(jat),c6)
         
        do taux=-rep_vdw(1),rep_vdw(1)
         do tauy=-rep_vdw(2),rep_vdw(2)
          do tauz=-rep_vdw(3),rep_vdw(3)
            if (taux.eq.0 .and. tauy.eq.0 .and. tauz.eq.0) cycle
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

            dx=tau(1)
            dy=tau(2)
            dz=tau(3)
            r2=dx*dx+dy*dy+dz*dz
c cutoff
           if(r2.gt.rthr) cycle
            r =sqrt(r2)
            rr=r0ab(iz(jat),iz(iat))/r
c damping
            tmp=rs6*rr   
            damp6 =1.d0/( 1.d0+6.d0*tmp**alp6 )
            tmp=rs8*rr     
            damp8 =1.d0/( 1.d0+6.d0*tmp**alp8 )

            if(.not.noabc)then
              ij=lin_sh(jat,iat)
              icomp(ij)=1
c store C6 for C9, calc as sqrt
              cc6ab(ij)=sqrt(c6)
            endif

            r6=r2**3      

            e6 =e6+c6*damp6/r6*0.50d0

c stored in main as sqrt
            c8 =3.0d0*c6*r2r4(iz(iat))*r2r4(iz(jat))
            r8 =r6*r2

            e8 =e8+c8*damp8/r8*0.50d0
            counter=counter+1

         enddo !tauz
        enddo !tauy
       enddo !taux
      end if
      pcount = pcount + 1
      enddo !iat
!      write(*,*)'counter(edisp): ',counter
      if (np.gt.1) call GA_DGOP(9+MSGDBL,e6,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,e8,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,cc6ab,n*n,'+')

      else if (version.eq.4) then

      call dcopy(n*n,0.0d0,0,cc6ab,1)

C DFT-D3(BJ-damping)
      call pbcncoord_sh(n,rcov,iz,xyz,cn,lat,rep_cn,crit_cn)

      icomp=0
      do iat=1,n
         do jat=iat+1,n
         if (mod(pcount,np).eq.taskid) then
c get C6
           call getc6_sh(maxc,max_elem,c6ab,mxc,iz(iat),iz(jat),
     .                                  cn(iat),cn(jat),c6)

           rxyz=xyz(:,iat)-xyz(:,jat)
           r42=r2r4(iz(iat))*r2r4(iz(jat))
           bj_dmp6=(a1*dsqrt(3.0d0*r42)+a2)**6
           bj_dmp8=(a1*dsqrt(3.0d0*r42)+a2)**8

           do taux=-rep_vdw(1),rep_vdw(1)
           do tauy=-rep_vdw(2),rep_vdw(2)
           do tauz=-rep_vdw(3),rep_vdw(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
            
            dxyz=rxyz+tau

            r2=sum(dxyz*dxyz)
c cutoff
           if(r2.gt.rthr) cycle
            r =sqrt(r2)
            rr=r0ab(iz(jat),iz(iat))/r

            if(.not.noabc)then
              ij=lin_sh(jat,iat)
              icomp(ij)=1
c store C6 for C9, calc as sqrt
              cc6ab(ij)=sqrt(c6)
            endif

            r6=r2**3      

            e6 =e6+c6/(r6+bj_dmp6)
c            write(*,*)'e6: ',e6

c stored in main as sqrt
            c8 =3.0d0*c6*r42
            r8 =r6*r2

            e8 =e8+c8/(r8+bj_dmp8)

            counter=counter+1

           enddo !tauz
           enddo !tauy
           enddo !taux
         end if
         pcount = pcount + 1
         enddo !jat

         if (mod(pcount,np).eq.taskid) then

! Now the self interaction
        jat=iat
c get C6
        call getc6_sh(maxc,max_elem,c6ab,mxc,iz(iat),iz(jat),
     .                                  cn(iat),cn(jat),c6)
        r42=r2r4(iz(iat))*r2r4(iz(iat))
        bj_dmp6=(a1*dsqrt(3.0d0*r42)+a2)**6
        bj_dmp8=(a1*dsqrt(3.0d0*r42)+a2)**8
         
        do taux=-rep_vdw(1),rep_vdw(1)
         do tauy=-rep_vdw(2),rep_vdw(2)
          do tauz=-rep_vdw(3),rep_vdw(3)
            if (taux.eq.0 .and. tauy.eq.0 .and. tauz.eq.0) cycle
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

            r2=sum(tau*tau)
c cutoff
           if(r2.gt.rthr) cycle
            r =sqrt(r2)
            rr=r0ab(iz(jat),iz(iat))/r

            if(.not.noabc)then
              ij=lin_sh(jat,iat)
              icomp(ij)=1
c store C6 for C9, calc as sqrt
              cc6ab(ij)=sqrt(c6)
            endif

            r6=r2**3      

            e6 =e6+c6/(r6+bj_dmp6)*0.50d0

c stored in main as sqrt
            c8 =3.0d0*c6*r42
            r8 =r6*r2

            e8 =e8+c8/(r8+bj_dmp8)*0.50d0
            counter=counter+1


c           r10=r8*r2
c           c10=(49.0d0/40.0d0)*c8*c8/c6
c           e10=e10+c10*damp8 /r10       
c           c12=c6*(c10/c8)**3 
c           e12=e12+c12*damp8 /(r10*r2)
c           c14=c8*(c12/c10)**3 
c           e12=e12+c14*damp8 /(r10*r2*r2)
         enddo !tauz
        enddo !tauy
       enddo !taux
      end if
      pcount = pcount + 1
      enddo !iat
      if (np.gt.1) call GA_DGOP(9+MSGDBL,e6,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,e8,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,cc6ab,n*n,'+')


      endif !version


      if(noabc)return

C compute non-additive third-order energy using averaged C6
!      call stoprun( 'Threebodyterm not jet  implemented' )
       call pbcthreebody_sh(max_elem,xyz,lat,n,iz,rep_cn,cc6ab,r0ab,e63)

      end subroutine pbcedisp_sh


      subroutine pbcthreebody_sh(max_elem,xyz,lat,n,iz,repv,cc6ab,r0ab,
     .           eabc)
      IMPLICIT NONE
      integer max_elem
      INTEGER         :: n,i,j,k,jtaux,jtauy,jtauz,iat,jat,kat
      INTEGER         :: ktaux,ktauy,ktauz,counter,ij,ik,jk
      REAL*8          :: dx,dy,dz,rij2,rik2,rjk2,c9,rr0ij,rr0ik
      REAL*8          :: rr0jk,geomean,fdamp,rik,rjk,rij,tmp
      REAL*8,INTENT(OUT)::eabc
      REAL*8          :: cosij,cosik,cosjk !cosine of the triangular by "law of cosine"
                                           ! cosij is the angle opposite to the side ij
      REAL*8 ,DIMENSION(3,3),INTENT(IN)::lat
      REAL*8 ,DIMENSION(3,*),INTENT(IN) :: xyz
      INTEGER,DIMENSION(*),INTENT(IN)::iz
      REAL*8,DIMENSION(3):: jtau,ktau,jxyz,kxyz,ijvec,ikvec,jkvec,dumvec
      INTEGER,DIMENSION(3):: repv
      REAL*8,DIMENSION(n*n),INTENT(IN)::cc6ab
      REAL*8,DIMENSION(max_elem,max_elem),INTENT(IN):: r0ab
      REAL*8,PARAMETER::sr9=0.75d0    !reciprocal radii scaling parameter for damping function (s_r=4/3)
      REAL*8,PARAMETER::alp9=-16.0d0  !alpha saved with "-" sign
      INTEGER,EXTERNAL :: lin_sh

#include "global.fh"
#include "msgtypesf.h"

      integer taskid,np,pcount

      np     = GA_Nnodes()
      taskid = GA_Nodeid()
      pcount = 0


      counter=0
      eabc=0.0d0

      do iat=1,n-2
        do jat=iat+1,n-1
        if (mod(pcount,np).eq.taskid) then
          ijvec=xyz(:,jat)-xyz(:,iat)
          ij=lin_sh(iat,jat)
          do kat=jat+1,n
!         write(*,*)'i:',iat,'j:',jat,'k:',kat
            ik=lin_sh(iat,kat)
            jk=lin_sh(jat,kat)
            ikvec=xyz(:,kat)-xyz(:,iat)
            jkvec=xyz(:,kat)-xyz(:,jat)
            c9=-1.0d0*(cc6ab(ij)*cc6ab(ik)*cc6ab(jk))
!            write(*,*)'c9: ',c9



            do jtaux=-repv(1),repv(1)
            do jtauy=-repv(2),repv(2)
            do jtauz=-repv(3),repv(3)
              jtau=jtaux*lat(:,1)+jtauy*lat(:,2)+jtauz*lat(:,3)
              dumvec=ijvec+jtau
              dumvec=dumvec*dumvec
              rij2=SUM(dumvec)
              rij=SQRT(rij2)

              rr0ij=rij/r0ab(iz(iat),iz(jat))
!              write(*,*)'r0ij:',r0ab(iz(iat),iz(jat))
!              write(*,*)'rr0ij:',rr0ij**1./3.


              do ktaux=-repv(1),repv(1)
              do ktauy=-repv(2),repv(2)
              do ktauz=-repv(3),repv(3)
                ktau=ktaux*lat(:,1)+ktauy*lat(:,2)+ktauz*lat(:,3)
                dumvec=ikvec+ktau
                dumvec=dumvec*dumvec
                rik2=SUM(dumvec)
                rik=DSQRT(rik2)
                rr0ik=rik/r0ab(iz(iat),iz(kat))

                dumvec=jkvec+ktau-jtau
                dumvec=dumvec*dumvec
                rjk2=SUM(dumvec)
                rjk=DSQRT(rjk2)
                rr0jk=rjk/r0ab(iz(jat),iz(kat))
!                write(*,*)'rr:',1.0/rr0jk

                geomean=(rr0ij*rr0ik*rr0jk)**(1.0d0/3.0d0)
!               write(*,*)'geomean:',geomean
                fdamp=1./(1.+6.*(sr9*geomean)**alp9)  !alp9 is already saved with "-"
                cosij=(rik2+rjk2-rij2)/(2.*rik*rjk)
                cosik=(rij2+rjk2-rik2)/(2.*rij*rjk)
                cosjk=(rij2+rik2-rjk2)/(2.*rik*rij)
                tmp=c9*(3.*cosij*cosik*cosjk+1)/
     .                 (rij*rik*rjk*rij2*rik2*rjk2)
!      write(*,*)'fdmp:',fdamp
!       write(*,*)'ang:',3.*cosij*cosik*cosjk+1 
                eabc=eabc+fdamp*tmp
!                write(*,'(''ktau'',3I2)'),ktaux,ktauy,ktauz
                counter=counter+1
              ENDDO !ktauz
              ENDDO !ktauy
              ENDDO !ktaux

            ENDDO !jtauz
            ENDDO !jtauy
            ENDDO !jtaux

          ENDDO !kat
        end if
        pcount = pcount + 1
        ENDDO !jat
      ENDDO !iat
!      write(*,*)'counter ijk: ',counter

      ! And now jat=iat, but cycling throug all imagecells without (0,0,0). and kat>iat going though all cells
      ! But this counts only 1/2

      DO iat=1,n-1
      if (mod(pcount,np).eq.taskid) then
      jat=iat
      ijvec=0.0d0
      ij=lin_sh(iat,jat)
        DO kat=iat+1,n
          ik=lin_sh(iat,kat)
          jk=lin_sh(jat,kat)
          ikvec=xyz(:,kat)-xyz(:,iat)
          jkvec=ikvec
          c9=-(cc6ab(ij)*cc6ab(ik)*cc6ab(jk))
          do jtaux=-repv(1),repv(1)
          do jtauy=-repv(2),repv(2)
          do jtauz=-repv(3),repv(3)
            IF (jtaux.eq.0 .and. jtauy.eq.0 .and. jtauz.eq.0) cycle
            jtau=jtaux*lat(:,1)+jtauy*lat(:,2)+jtauz*lat(:,3)
            dumvec=jtau
            dumvec=dumvec*dumvec
            rij2=SUM(dumvec)
            rij=SQRT(rij2)

            rr0ij=rij/r0ab(iz(iat),iz(jat))
       
            do ktaux=-repv(1),repv(1)
            do ktauy=-repv(2),repv(2)
            do ktauz=-repv(3),repv(3)
! every result * 0.5
              ktau=ktaux*lat(:,1)+ktauy*lat(:,2)+ktauz*lat(:,3)
              dumvec=ikvec+ktau
              dumvec=dumvec*dumvec
              rik2=SUM(dumvec)
              rik=SQRT(rik2)
              rr0ik=rik/r0ab(iz(iat),iz(kat))

              dumvec=jkvec+ktau-jtau
              dumvec=dumvec*dumvec
              rjk2=SUM(dumvec)
              rjk=SQRT(rjk2)
              rr0jk=rjk/r0ab(iz(jat),iz(kat))

              geomean=(rr0ij*rr0ik*rr0jk)**(1./3.)
              fdamp=1./(1.+6.*(sr9*geomean)**alp9)
              cosij=(rik2+rjk2-rij2)/(2.*rik*rjk)
              cosik=(rij2+rjk2-rik2)/(2.*rij*rjk)
              cosjk=(rij2+rik2-rjk2)/(2.*rik*rij)
              tmp=c9*(3.*cosij*cosik*cosjk+1)/
     .                 (rij*rik*rjk*rij2*rik2*rjk2)

              eabc=eabc+fdamp*tmp*0.5d0
              counter=counter+1
            ENDDO !ktauz
            ENDDO !ktauy
            ENDDO !ktaux
 
          ENDDO !jtauz
          ENDDO !jtauy
          ENDDO !jtaux
        ENDDO !kat
      end if
      pcount = pcount + 1
      ENDDO !iat

!      write(*,*)'counter iik: ',counter

! And finally the self interaction iat=jat=kat all 

      DO iat=1,n
      if (mod(pcount,np).eq.taskid) then
      jat=iat
      kat=iat
      ijvec=0.0d0
      ij=lin_sh(iat,jat)
      ik=lin_sh(iat,kat)
      jk=lin_sh(jat,kat)
      ikvec=ijvec
      jkvec=ikvec
          c9=-(cc6ab(ij)*cc6ab(ik)*cc6ab(jk))

        do jtaux=-repv(1),repv(1)
        do jtauy=-repv(2),repv(2)
        do jtauz=-repv(3),repv(3)
          IF (jtaux.eq.0 .and. jtauy.eq.0 .and. jtauz.eq.0) cycle
          jtau=jtaux*lat(:,1)+jtauy*lat(:,2)+jtauz*lat(:,3)
          dumvec=jtau
          dumvec=dumvec*dumvec
          rij2=SUM(dumvec)
          rij=SQRT(rij2)
          rr0ij=rij/r0ab(iz(iat),iz(jat))

          do ktaux=-repv(1),repv(1)
          do ktauy=-repv(2),repv(2)
          do ktauz=-repv(3),repv(3)
            IF (ktaux.eq.0 .and. ktauy.eq.0 .and. ktauz.eq.0) cycle !IF iat and kat are the same then cycle
            IF (ktaux.eq.jtaux .and. ktauy.eq.jtauy 
     .         .and. ktaux.eq.jtaux) cycle      !If kat and jat are the same then cycle
! every result * 1/6 becaues every triple is counted twice due to the two loops jtau and ktau going from -repv to repv -> *1/2
! 
!plus 1/3 becaues every triple is three times in each unitcell
              ktau=ktaux*lat(:,1)+ktauy*lat(:,2)+ktauz*lat(:,3)
              dumvec=ktau
              dumvec=dumvec*dumvec
              rik2=SUM(dumvec)
              rik=SQRT(rik2)
              rr0ik=rik/r0ab(iz(iat),iz(kat))

              dumvec=jkvec+ktau-jtau
              dumvec=dumvec*dumvec
              rjk2=SUM(dumvec)
              rjk=SQRT(rjk2)
              rr0jk=rjk/r0ab(iz(jat),iz(kat))

              geomean=(rr0ij*rr0ik*rr0jk)**(1./3.)
              fdamp=1./(1.+6.*(sr9*geomean)**alp9)
              cosij=(rik2+rjk2-rij2)/(2.*rik*rjk)
              cosik=(rij2+rjk2-rik2)/(2.*rij*rjk)
              cosjk=(rij2+rik2-rjk2)/(2.*rik*rij)
              tmp=c9*(3.*cosij*cosik*cosjk+1)/
     .                 (rij*rik*rjk*rij2*rik2*rjk2)
              eabc=eabc+fdamp*tmp/6.0d0
 
            counter=counter+1
          ENDDO !ktauz
          ENDDO !ktauy
          ENDDO !ktaux
        ENDDO !jtauz
        ENDDO !jtauy
        ENDDO !jtaux


      end if
      pcount = pcount + 1
      ENDDO !iat
c      write(*,*)'counter iii: ',counter

      if (np.gt.1) call GA_DGOP(9+MSGDBL,eabc,1,'+')

      END subroutine pbcthreebody_sh


c     Input Geometry sanity check for pbc (to avoid au/Angtstrom mixups) J.M. 
      subroutine pbccheckrcov_sh(n,iz,rcov,xyz,lat)
      implicit none
      logical check
      integer iz(*),n,i,j,taux,tauy,tauz
      real*8 rcov(94),dist,dx,dy,dz,thr,xyz(3,*),r,lat(3,3),tau(3)
      integer  ga_nodeid
      external ga_nodeid
      check=.false.
      do i=1,n-1
       do j=i+1,n
         do taux=-1,1
         do tauy=-1,1
         do tauz=-1,1
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

            dx=xyz(1,i)-xyz(1,j)+tau(1)
            dy=xyz(2,i)-xyz(2,j)+tau(2)
            dz=xyz(3,i)-xyz(3,j)+tau(3)
 
           r=sqrt(dx*dx+dy*dy+dz*dz)
           thr=0.6*(rcov(iz(i))+rcov(iz(j)))
           if (r.lt.thr) then
             check=.true.
           endif
         enddo !tauz
         enddo !tauy
         enddo !taux
       enddo !j
      enddo !i
      check = check.and.(ga_nodeid().eq.0)
      if (check) then
          write(*,*)'--------------------------------------------------'
          write(*,*)'!! SOME DISTANCES VERY SHORT. CHECK COORDINATES !!'
          write(*,*)'--------------------------------------------------'
      endif
      end subroutine pbccheckrcov_sh

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C compute gradient
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine pbcgdisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .            rcov,s6,s18,rs6,rs8,rs10,alp6,alp8,alp10,noabc,num,
     .                 version,g,disp,gnorm,stress,lat,rep_v,rep_cn,
     .                 crit_vdw,echo,crit_cn)
      
      implicit none  
      !include  'param'

#include "global.fh"
#include "msgtypesf.h"

      real*8 k1,k2,k3

c global ad hoc parameters
      parameter (k1=16.0)
      parameter (k2=4./3.) 

c reasonable choices are between 3 and 5
c this gives smoth curves with maxima around the integer values
c k3=3 give for CN=0 a slightly smaller value than computed
c for the free atom. This also yields to larger CN for atoms
c in larger molecules but with the same chem. environment
c which is physically not right
c values >5 might lead to bumps in the potential
      parameter (k3=-4.) 

      integer n,iz(*),max_elem,maxc,version,mxc(max_elem)
      real*8 xyz(3,*),r0ab(max_elem,max_elem),r2r4(*)
      real*8 c6ab(max_elem,max_elem,maxc,maxc,3)
      real*8 g(3,*),s6,s18,rcov(max_elem)
      real*8 rs6,rs8,rs10,alp10,alp8,alp6        
      real*8 a1,a2 !BJ-parameters
      real*8 bj_dmp6,bj_dmp8 ! precalculated dampingterms
      logical noabc,num,echo
c coversion factors
      REAL*8, parameter ::autoang =0.52917726d0
      REAL*8, parameter ::autokcal=627.509541d0
      REAL*8, parameter ::autoev=27.211652d0   

      integer iat,jat,i,j,kat,my,ny,a,b,idum,tau2
      real*8 R0,C6,alp,R42,disp,x1,y1,z1,x2,y2,z2,rr,e6abc,fdum  
      real*8 dx,dy,dz,r2,r,r4,r6,r8,r10,r12,t6,t8,t10,damp1
      real*8 damp6,damp8,damp10,e6,e8,e10,e12,gnorm,tmp1
      real*8 s10,s8,gC6(3),term,step,dispr,displ,r235,tmp2
      real*8 cn(n),gx1,gy1,gz1,gx2,gy2,gz2,rthr,testsum
      real*8,  DIMENSION(3,3) :: lat,stress,sigma,virialstress,lat_1
      real*8,  DIMENSION(3,3) :: gC6_stress
      integer, DIMENSION(3)   :: rep_v,rep_cn
      real*8 crit_vdw,crit_cn
      integer taux,tauy,tauz,counter
      real*8, DIMENSION(3) :: tau,vec12,dxyz,dxyz0
      real*8,external  ::volume_sh
      real*8           ::outpr(3,3)
      real*8, DIMENSION(3,3):: outerprod

      real*8 rij(3),rik(3),rjk(3),r7,r9
      real*8 rik_dist,rjk_dist
      real*8 drik,drjk
      real*8 rcovij
      real*8 dc6,c6chk !d(C6ij)/d(r_ij)
      real*8 expterm,dcni
      real*8, allocatable,dimension(:,:,:,:) ::  drij  !d(E)/d(r_ij) derivative wrt. dist. iat-jat
      real*8, allocatable,dimension(:,:,:,:) :: dcn    !dCN(iat)/d(r_ij) is equal to
                                                       !dCN(jat)/d(r_ij)     
      real*8, allocatable,dimension(:,:,:,:) :: dc6_rest ! saves (1/r^6*f_dmp + 3*r4r2/r^8*f_dmp) for kat loop
      integer,external :: lin_sh
      real*8,external ::vectorsize_sh
      real*8 vec(3),vec2(3),dummy
      real*8 dc6ij(n,n)       !dC6(iat,jat)/dCN(iat) in dc6ij(i,j)
                              !dC6(iat,jat)/cCN(jat) in dc6ij(j,i)
      real*8 dc6_rest_sum(n*(n+1)/2)
      logical, allocatable,dimension(:,:,:,:) ::  skip  !d(E)/d(r_ij) derivative wrt. dist. iat-jat
      integer linij,linik,linjk
      real*8 abc(3,n)
      double precision expodc,expodc_eps
      parameter (expodc_eps=1d-12)

      integer taskid,np,pcount,count

      np     = GA_Nnodes()
      taskid = GA_Nodeid()
      pcount = 0



c R^2 cut-off 
      rthr=crit_vdw
      counter=0
      sigma=0.0d0
      virialstress=0.0d0
      
c      testsum=0.0d0

      if(echo)write(*,*) 

      if(num) then
      if (echo)
     .  write(*,*) 'doing numerical gradient O(N^3) ...'

      call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_v,crit_cn,rep_cn)
 

          disp=-s6*e6-s18*e8-s6*e6abc

      step=2.d-5

      do i=1,n
        do j=1,3
          xyz(j,i)=xyz(j,i)+step        
          call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_v,crit_cn,rep_cn)
 
          dispr=-s6*e6-s18*e8-s6*e6abc
          xyz(j,i)=xyz(j,i)-2*step      
          call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_v,crit_cn,rep_cn)
 
          displ=-s6*e6-s18*e8-s6*e6abc
          g(j,i)=0.5*(dispr-displ)/step  
          xyz(j,i)=xyz(j,i)+step        
        enddo !jat
      enddo   !iat
      IF (echo) write(*,*)'Doing numerical stresstensor...'

      call xyz_to_abc_sh(xyz,abc,lat,n)
      step=2.d-5
      if (echo) write(*,*)'step: ',step
      do i=1,3
        do j=1,3
          lat(j,i)=lat(j,i)+step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          !call edisp...dum1
          call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_v,crit_cn,rep_cn)

         dispr=-s6*e6-s18*e8-s6*e6abc


          lat(j,i)=lat(j,i)-2*step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          !call edisp...dum2
          call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_v,crit_cn,rep_cn)

         displ=-s6*e6-s18*e8-s6*e6abc
          stress(j,i)=(dispr-displ)/(step*2.0)

          lat(j,i)=lat(j,i)+step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          
        enddo !j
      enddo !i

      sigma=0.0d0
      call inv_cell_sh(lat,lat_1)
      do a=1,3
        do b=1,3
           do my=1,3
              sigma(a,b)=sigma(a,b)-stress(a,my)*lat(b,my)
           enddo
        enddo !b
      enddo !a

      goto 999

      endif !num


      if(version.eq.2)then
      if(echo)write(*,*) 'doing analytical gradient D-old O(N^2) ...'
      disp=0
      stress=0.0d0
      sigma=0.0d0
      do iat=1,n-1
         do jat=iat+1,n
         if (mod(pcount,np).eq.taskid) then
           R0=r0ab(iz(jat),iz(iat))*rs6
           c6=c6ab(iz(jat),iz(iat),1,1,1)*s6
           do taux=-rep_v(1),rep_v(1)
           do tauy=-rep_v(2),rep_v(2)
           do tauz=-rep_v(3),rep_v(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
              dxyz=xyz(:,iat)-xyz(:,jat)+tau            
            r2  =sum(dxyz*dxyz)
           if(r2.gt.rthr) cycle
            r235=r2**3.5                       
            r   =dsqrt(r2)
            damp6=exp(-alp6*(r/R0-1.0d0))
            damp1=1.+damp6           
            tmp1=damp6/(damp1*damp1*r235*R0)
            tmp2=6./(damp1*r*r235)

            term=alp6*tmp1-tmp2
              g(:,iat)=g(:,iat)-term*dxyz*c6
              g(:,jat)=g(:,jat)+term*dxyz*c6
            disp=disp+c6*(1./damp1)/r2**3

            do ny=1,3
            do my=1,3
              sigma(my,ny)=sigma(my,ny)+term*dxyz(ny)*dxyz(my)*c6
!              stress(my,ny)=stress(my,ny)-term*c6*dxyz(my)*tau(ny)
            enddo !my
            enddo !ny
           enddo !tauz
           enddo !tauy
           enddo !taux
         end if
         pcount = pcount + 1
         enddo !jat
      enddo !iat
c and now the self interaction, only for convenient energy in dispersion
      do iat=1,n
      if (mod(pcount,np).eq.taskid) then
         jat=iat
           R0=r0ab(iz(jat),iz(iat))*rs6
           c6=c6ab(iz(jat),iz(iat),1,1,1)*s6
           do taux=-rep_v(1),rep_v(1)
           do tauy=-rep_v(2),rep_v(2)
           do tauz=-rep_v(3),rep_v(3)
            if (taux.eq.0 .and. tauy.eq.0 .and. tauz.eq.0) cycle
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

            dxyz=tau
!             vec12=(/ dx,dy,dz /)
            r2  =sum(dxyz*dxyz)
            if(r2.gt.rthr) cycle
            r235=r2**3.5                       
            r   =dsqrt(r2)
            damp6=exp(-alp6*(r/R0-1.0d0))
            damp1=1.+damp6           
            tmp1=damp6/(damp1*damp1*r235*R0)
            tmp2=6./(damp1*r*r235)
            disp=disp+(c6*(1./damp1)/r2**3)*0.50d0
            term=alp6*tmp1-tmp2
            do ny=1,3
            do my=1,3
             sigma(my,ny)=sigma(my,ny)+term*dxyz(ny)*dxyz(my)*c6*0.5d0
!              stress(my,ny)=stress(my,ny)-term*c6*dxyz(my)*tau(ny)*0.5d0
            enddo !my
            enddo !ny
            

           enddo !tauz
           enddo !tauy
           enddo !taux
      end if
      pcount = pcount + 1
      enddo !iat

      if (np.gt.1) call GA_DGOP(9+MSGDBL,disp,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,g,3*n,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,sigma,9,'+')

      
      call inv_cell_sh(lat,lat_1)
      do a=1,3
        do b=1,3
           do my=1,3
              stress(a,b)=stress(a,b)-sigma(a,my)*lat_1(b,my)
           enddo
        enddo !b
      enddo !a

      disp=-disp
!       sigma=virialstress
      goto 999
      endif !version==2

      if (version.eq.3) then
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!          
!    begin ZERO DAMPING GRADIENT         
!          
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      if (echo)   
     . write(*,*) 'doing analytical gradient O(N^3) ...'
c precompute for analytical part
      call pbcncoord_sh(n,rcov,iz,xyz,cn,lat,rep_cn,crit_cn)


      s8 =s18
      s10=s18
      allocate(drij(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .              -rep_v(1):rep_v(1),n*(n+1)/2))
      allocate(dc6_rest(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .                  -rep_v(1):rep_v(1),n*(n+1)/2))
      allocate(dcn(-rep_cn(3):rep_cn(3),-rep_cn(2):rep_cn(2),
     .             -rep_cn(1):rep_cn(1),n*(n+1)/2))
      allocate(skip(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .              -rep_v(1):rep_v(1),n*(n+1)/2))

      disp=0

      drij=0.0d0
      dc6_rest=0.0d0
      dc6_rest_sum=0.0d0
      dcn=0.0d0
      kat=0
      dc6ij = 0.0d0


      do iat=1,n
        if (mod(pcount,np).eq.taskid) then

        call get_dC6_dCNij_sh(maxc,max_elem,c6ab,mxc(iz(iat)),
     .          mxc(iz(iat)),cn(iat),cn(iat),iz(iat),iz(iat),iat,iat,
     .          c6,dc6ij(iat,iat),fdum)

        r0=r0ab(iz(iat),iz(iat))
        r42=r2r4(iz(iat))*r2r4(iz(iat))
        rcovij=rcov(iz(iat))+rcov(iz(iat))


      counter=0
        do taux=-rep_v(1),rep_v(1)
        do tauy=-rep_v(2),rep_v(2)
        do tauz=-rep_v(3),rep_v(3)
          tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
          counter=counter+1


!first dE/d(tau) saved in drij(i,i,counter)
          rij=tau
          r2=sum(rij*rij)
!          if (r2.gt.rthr) cycle

!          if (r2.gt.0.1) then
          if (r2.gt.0.1.and.r2.lt.rthr) then


          r=dsqrt(r2)
          r6=r2*r2*r2
          r7=r6*r
          r8=r6*r2
          r9=r8*r

!
!  Calculates damping functions:
          t6 = (r/(rs6*R0))**(-alp6)
          damp6 =1.d0/( 1.d0+6.d0*t6 )
          t8 = (r/(rs8*R0))**(-alp8)
          damp8 =1.d0/( 1.d0+6.d0*t8 )

          drij(tauz,tauy,taux,
     >      lin_sh(iat,iat))=drij(tauz,tauy,taux,lin_sh(iat,
     .     iat))
     .        +(-s6*(6.0/(r7)*C6*damp6)  ! d(r^(-6))/d(tau)
     .        -s8*(24.0/(r9)*C6*r42*damp8))*0.5d0


          drij(tauz,tauy,taux,lin_sh(iat,iat))=
     >      drij(tauz,tauy,taux,lin_sh(iat,
     .     iat))
     .        +(s6*C6/r7*6.d0*alp6*t6*damp6*damp6     !d(f_dmp)/d(tau)
     .        +s8*C6*r42/r9*18.d0*alp8*t8*damp8*damp8)*0.5d0
!
!      in dC6_rest all terms BUT C6-term is saved for the kat-loop
!          
          dc6_rest(tauz,tauy,taux,lin_sh(iat,iat))=
     .        (s6/r6*damp6+3.d0*s8*r42/r8*damp8)*0.50d0


          disp=disp-dc6_rest(tauz,tauy,taux,lin_sh(iat,iat))*c6  ! calculate E_disp for sanity check

!          if (r2.lt.crit_cn)
          dc6_rest_sum(lin_sh(iat,iat))=dc6_rest_sum(lin_sh(iat,iat))+
     .     (dc6_rest(tauz,tauy,taux,lin_sh(iat,iat)))


          else !r2 < 0.1>rthr
             drij(tauz,tauy,taux,lin_sh(iat,iat))=0.0d0
          endif


        ENDDO !tauz
        ENDDO !tauy
        ENDDO !taux

        end if
        pcount = pcount + 1

!!!!!!!!!!!!!!!!!!!!!!!!!!
! B E G I N   jat  L O O P 
!!!!!!!!!!!!!!!!!!!!!!!!!!         
        do jat=1,iat-1
        if (mod(pcount,np).eq.taskid) then
!
!      get_dC6_dCNij calculates the derivative dC6(iat,jat)/dCN(iat) and
!      dC6(iat,jat)/dCN(jat). these are saved in dC6ij for the kat loop
!
          call get_dC6_dCNij_sh(maxc,max_elem,c6ab,mxc(iz(iat)),
     .          mxc(iz(jat)),cn(iat),cn(jat),iz(iat),iz(jat),iat,jat,
     .          c6,dc6ij(iat,jat),dc6ij(jat,iat))

          r0=r0ab(iz(jat),iz(iat))
          r42=r2r4(iz(iat))*r2r4(iz(jat))
          rcovij=rcov(iz(iat))+rcov(iz(jat))
          linij=lin_sh(iat,jat)
 
          counter=0
            do taux=-rep_v(1),rep_v(1)
            do tauy=-rep_v(2),rep_v(2)
            do tauz=-rep_v(3),rep_v(3)
              tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
              counter=counter+1
  
  
            rij=xyz(:,jat)-xyz(:,iat)+tau
            r2=sum(rij*rij)
            if (r2.gt.rthr) cycle
  
 
            r=dsqrt(r2)
            r6=r2*r2*r2
            r7=r6*r
            r8=r6*r2
            r9=r8*r
  
!
!  Calculates damping functions:
            t6 = (r/(rs6*R0))**(-alp6)
            damp6 =1.d0/( 1.d0+6.d0*t6 )
            t8 = (r/(rs8*R0))**(-alp8)
            damp8 =1.d0/( 1.d0+6.d0*t8 )
  
            drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,
     .           linij)
     .        -s6*(6.0/(r7)*C6*damp6)  ! d(r^(-6))/d(r_ij)
     .        -s8*(24.0/(r9)*C6*r42*damp8)
  
            drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,
     .           linij)
     .        +s6*C6/r7*6.d0*alp6*t6*damp6*damp6     !d(f_dmp)/d(r_ij)
     .        +s8*C6*r42/r9*18.d0*alp8*t8*damp8*damp8
!
!      in dC6_rest all terms BUT C6-term is saved for the kat-loop
!          
          dc6_rest(tauz,tauy,taux,linij)=
     .        (s6/r6*damp6+3.d0*s8*r42/r8*damp8)

 
            disp=disp-dc6_rest(tauz,tauy,taux,linij)*c6  ! calculate E_disp for sanity check

!            if (r2.lt.crit_cn) 
             dc6_rest_sum(linij)=dc6_rest_sum(linij)
     .        +dc6_rest(tauz,tauy,taux,linij) 


          enddo !tauz
          enddo !tauy
          enddo !taux
  
        end if
        pcount = pcount + 1
        enddo !jat

      enddo !iat
      if (np.gt.1) call GA_DGOP(9+MSGDBL,disp,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dc6ij,n*n,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dc6_rest_sum,n*(n+1)/2,'+')

*     **** compute dcn ****
      do iat=1,n
         if (mod(pcount,np).eq.taskid) then
         rcovij=rcov(iz(iat))+rcov(iz(iat))

         do taux=-rep_cn(1),rep_cn(1)
         do tauy=-rep_cn(2),rep_cn(2)
         do tauz=-rep_cn(3),rep_cn(3)
           tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
           r2=sum(tau*tau)
           if (r2.gt.0.1.and.r2.lt.crit_cn) then
              r=dsqrt(r2)

              expterm = exp(-k1*(rcovij/r-1.d0))
              dcn(tauz,tauy,taux,lin_sh(iat,iat))=-k1*rcovij*expterm/
     >                  (r2*(expterm+1.d0)*(expterm+1.d0))

           end if
         end do
         end do
         end do
         end if
         pcount = pcount + 1

         do jat=1,iat-1
            if (mod(pcount,np).eq.taskid) then
            rcovij = rcov(iz(iat))+rcov(iz(jat))
            linij  = lin_sh(iat,jat)

            do taux=-rep_cn(1),rep_cn(1)
            do tauy=-rep_cn(2),rep_cn(2)
            do tauz=-rep_cn(3),rep_cn(3)
               tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
               rij=xyz(:,jat)-xyz(:,iat)+tau
               r2=sum(rij*rij)
               if (r2.le.crit_cn) then
                  r=dsqrt(r2)
                  expterm=exp(-k1*(rcovij/r-1.d0))
                  dcn(tauz,tauy,taux,linij)=-k1*rcovij*expterm/
     >                     (r2*(expterm+1.d0)*(expterm+1.d0))
               end if
            end do 
            end do 
            end do 

            end if
            pcount = pcount + 1
         end do
      end do
      count=(2*rep_cn(3)+1)*(2*rep_cn(2)+1)*(2*rep_cn(1)+1)*(n*(n+1)/2)
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dcn,count,'+')

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      !B E G I N   d(C6)/dr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      DO iat=1,n
        if (mod(pcount,np).eq.taskid) then

        do taux=-rep_cn(1),rep_cn(1)
        do tauy=-rep_cn(2),rep_cn(2)
        do tauz=-rep_cn(3),rep_cn(3)

          dc6= (dc6ij(iat,iat)+dc6ij(iat,iat))
     >        *dcn(tauz,tauy,taux,lin_sh(iat,iat))
          drij(tauz,tauy,taux,lin_sh(iat,iat)) =
     >         drij(tauz,tauy,taux,lin_sh(iat,iat))
     >         +  dc6_rest_sum(lin_sh(iat,iat))*dc6

        enddo !tauz
        enddo !tauy
        enddo !taux
        end if
        pcount = pcount + 1

        DO jat=1,iat-1
           if (mod(pcount,np).eq.taskid) then
            linij=lin_sh(iat,jat)

            do taux=-rep_cn(1),rep_cn(1)
            do tauy=-rep_cn(2),rep_cn(2)
            do tauz=-rep_cn(3),rep_cn(3)
  
               dc6 = (dc6ij(iat,jat))
     >              *dcn(tauz,tauy,taux,lin_sh(iat,iat))
               drij(tauz,tauy,taux,lin_sh(iat,iat)) =
     >               drij(tauz,tauy,taux,lin_sh(iat,iat))
     >             + dc6_rest_sum(lin_sh(iat,jat))*dc6  
               expodc= dcn(tauz,tauy,taux,lin_sh(jat,jat))
               if(expodc.gt.expodc_eps) then
                  dc6= (dc6ij(jat,iat))**expodc 
               else
                  dc6= dc6ij(jat,iat)
               endif
                  
               drij(tauz,tauy,taux,lin_sh(jat,jat)) =
     >               drij(tauz,tauy,taux,lin_sh(jat,jat))
     >            +  dc6_rest_sum(lin_sh(jat,iat))*dc6    

               dc6= (dc6ij(iat,jat)+dc6ij(jat,iat))
     >             *dcn(tauz,tauy,taux,linij)  
               drij(tauz,tauy,taux,linij) = drij(tauz,tauy,taux,linij)
     >                                    + dc6_rest_sum(linij)*dc6 

               dc6= (dc6ij(iat,iat)+dc6ij(iat,iat))
     >             *dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                            +dc6_rest_sum(lin_sh(iat,iat))*dc6 

               dc6= (dc6ij(jat,jat)+dc6ij(jat,jat))
     >             *dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                             +dc6_rest_sum(lin_sh(jat,jat))*dc6 
            enddo !tauz
            enddo !tauy
            enddo !taux
!
! In the kat loop all the 3rd atom contributions are calculated:
!            1/r_ij^6*f_dmp(ij)  *  d(C6(ij))/d r_ik
!            -------V----------     -------V--------
!             dc6_rest_sum(ij)   *  dc6ij(i,j)*dcn(ik)
!
!   To reduce the kat-loop to only jat-1, on gets 6 contributions
!   
!
          do kat=1,jat-1
            linik=lin_sh(iat,kat)
            linjk=lin_sh(jat,kat)
            do taux=-rep_cn(1),rep_cn(1)
            do tauy=-rep_cn(2),rep_cn(2)
            do tauz=-rep_cn(3),rep_cn(3)

               dc6=dc6ij(iat,kat)*dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)= drij(tauz,tauy,taux,linij)
     >                                    + dc6_rest_sum(linik)*dc6

               dc6=dc6ij(jat,kat)*dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)= drij(tauz,tauy,taux,linij)
     >                                   + dc6_rest_sum(linjk)*dc6

               dc6=dc6ij(kat,iat)*dcn(tauz,tauy,taux,linjk)
               drij(tauz,tauy,taux,linjk)= drij(tauz,tauy,taux,linjk)
     >                                   + dc6_rest_sum(linik)*dc6

               dc6=dc6ij(jat,iat)*dcn(tauz,tauy,taux,linjk)
               drij(tauz,tauy,taux,linjk)= drij(tauz,tauy,taux,linjk)
     >                                   + dc6_rest_sum(linij)*dc6

              dc6=dc6ij(kat,jat)*dcn(tauz,tauy,taux,linik)
              drij(tauz,tauy,taux,linik)= drij(tauz,tauy,taux,linik)
     >                                  + dc6_rest_sum(linjk)*dc6

              dc6=dc6ij(iat,jat)*dcn(tauz,tauy,taux,linik)
              drij(tauz,tauy,taux,linik)= drij(tauz,tauy,taux,linik)
     >                                  + dc6_rest_sum(linij)*dc6

            enddo !tauz
            enddo !tauy
            enddo !taux
          enddo !kat

          end if
          pcount = pcount + 1

        ENDDO !jat
      ENDDO !iat

      count = (2*rep_v(3)+1)*(2*rep_v(2)+1)*(2*rep_v(1)+1)*(n*(n+1)/2)
      if (np.gt.1) call GA_DGOP(9+MSGDBL,drij,count,'+')






! After calculating all derivatives dE/dr_ij w.r.t. distances,
! the grad w.r.t. the coordinates is calculated dE/dr_ij * dr_ij/dxyz_i       
      do iat=2,n
        do jat=1,iat-1
        if (mod(pcount,np).eq.taskid) then
          do taux=-rep_v(1),rep_v(1)
          do tauy=-rep_v(2),rep_v(2)
          do tauz=-rep_v(3),rep_v(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

          rij=xyz(:,jat)-xyz(:,iat)+tau
          r2=sum(rij*rij)  
          if (r2.gt.rthr.or.r2.lt.0.5) cycle

          r=dsqrt(r2)
          vec=drij(tauz,tauy,taux,lin_sh(iat,jat))*rij/r
          g(:,iat)=g(:,iat)+vec
          g(:,jat)=g(:,jat)-vec
          do i=1,3
          do j=1,3
          sigma(j,i)=sigma(j,i)+vec(j)*rij(i)
          enddo !j
          enddo !i


          enddo !tauz
          enddo !tauy
          enddo !taux
        end if
        pcount = pcount + 1
        enddo !jat
      enddo !iat

      do iat=1,n
      if (mod(pcount,np).eq.taskid) then
          do taux=-rep_v(1),rep_v(1)
          do tauy=-rep_v(2),rep_v(2)
          do tauz=-rep_v(3),rep_v(3)
!          if (taux.eq.0.and.tauy.eq.0.and.tauz.eq.0) cycle
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
          r2=sum(tau*tau)  
          if (r2.gt.rthr.or.r2.lt.0.5) cycle
          r=dsqrt(r2)
          vec=drij(tauz,tauy,taux,lin_sh(iat,iat))*tau/r
          do i=1,3
          do j=1,3
          sigma(j,i)=sigma(j,i)+vec(j)*tau(i)
          enddo !j
          enddo !i




          enddo !tauz
          enddo !tauy
          enddo !taux

      end if
      pcount = pcount + 1
      enddo
      if (np.gt.1) call GA_DGOP(9+MSGDBL,g,3*n,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,sigma,9,'+')

      stress=0.0d0
      call inv_cell_sh(lat,lat_1)
      do a=1,3
        do b=1,3
           do my=1,3
              stress(a,b)=stress(a,b)-sigma(a,my)*lat_1(b,my)
           enddo
        enddo !b
      enddo !a



!          write(*,*)'drij:',drij(lin_sh(iat,jat),:)
!          write(*,*)'g:',g(1,1:3)
!          write(*,*)'dcn:',sum(dcn(lin_sh(2,1),:))

      deallocate(drij,dc6_rest,dcn)

      elseif (version.eq.4)  then



!!!!!!!!!!!!!!!!!!!!!!!
! NOW THE BJ Gradient !
!!!!!!!!!!!!!!!!!!!!!!!


      if (echo) write(*,*) 'doing analytical gradient O(N^3) ...'
      call pbcncoord_sh(n,rcov,iz,xyz,cn,lat,rep_cn,crit_cn)


      a1 =rs6
      a2 =rs8
      s8 =s18

      allocate(drij(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .              -rep_v(1):rep_v(1),n*(n+1)/2))
      allocate(dc6_rest(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .                  -rep_v(1):rep_v(1),n*(n+1)/2))

      allocate(dcn(-rep_cn(3):rep_cn(3),-rep_cn(2):rep_cn(2),
     .             -rep_cn(1):rep_cn(1),n*(n+1)/2))

      allocate(skip(-rep_v(3):rep_v(3),-rep_v(2):rep_v(2),
     .              -rep_v(1):rep_v(1),n*(n+1)/2))
      disp=0
      drij=0.0d0
      dc6_rest=0.0d0
      dc6_rest_sum=0.0d0
      dcn=0.0d0
      kat=0
      dc6ij = 0

      do iat=1,n
        if (mod(pcount,np).eq.taskid) then

        call get_dC6_dCNij_sh(maxc,max_elem,c6ab,mxc(iz(iat)),
     .          mxc(iz(iat)),cn(iat),cn(iat),iz(iat),iz(iat),iat,iat,
     .          c6,dc6ij(iat,iat),fdum)

        r42=r2r4(iz(iat))*r2r4(iz(iat))
        rcovij=rcov(iz(iat))+rcov(iz(iat))

        R0=a1*sqrt(3.0d0*r42)+a2

        do taux=-rep_v(1),rep_v(1)
        do tauy=-rep_v(2),rep_v(2)
        do tauz=-rep_v(3),rep_v(3)
          tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
          counter=counter+1

!first dE/d(tau) saved in drij(i,i,counter)
          rij=tau
          r2=sum(rij*rij)
!          if (r2.gt.rthr) cycle

!          if (r2.gt.0.1) then
          if (r2.gt.0.1.and.r2.lt.rthr) then
!
!      get_dC6_dCNij calculates the derivative dC6(iat,jat)/dCN(iat) and
!      dC6(iat,jat)/dCN(jat). these are saved in dC6ij for the kat loop
!
          r=dsqrt(r2)
          r4=r2*r2
          r6=r4*r2
          r7=r6*r
          r8=r6*r2
          r9=r8*r

!
!  Calculates damping functions:
 
          t6=(r6+R0**6)
          t8=(r8+R0**8)

          drij(tauz,tauy,taux,lin_sh(iat,iat))=
     >     drij(tauz,tauy,taux,lin_sh(iat,
     .     iat))
     .        -s6*C6*6.0d0*r4*r/(t6*t6)*0.5d0 ! d(1/(r^(6)+R0^6)/d(r)
     .        -s8*C6*24.0d0*r42*r7/(t8*t8)*0.5d0


!
!      in dC6_rest all terms BUT C6-term is saved for the kat-loop
!          
          dc6_rest(tauz,tauy,taux,lin_sh(iat,iat))=
     .        (s6/t6+3.d0*s8*r42/t8)*0.50d0


          disp=disp-dc6_rest(tauz,tauy,taux,lin_sh(iat,iat))*c6  ! calculate E_disp for sanity check

!          if (r2.lt.crit_cn)
          dc6_rest_sum(lin_sh(iat,iat))=dc6_rest_sum(lin_sh(iat,iat))+
     .     (dc6_rest(tauz,tauy,taux,lin_sh(iat,iat)))


          else !r2 < 0.1>rthr
             drij(tauz,tauy,taux,lin_sh(iat,iat))=0.0d0
          endif


        ENDDO !tauz
        ENDDO !tauy
        ENDDO !taux
        end if
        pcount = pcount + 1

!!!!!!!!!!!!!!!!!!!!!!!!!!
! B E G I N   jat  L O O P 
!!!!!!!!!!!!!!!!!!!!!!!!!!         
        do jat=1,iat-1
        if (mod(pcount,np).eq.taskid) then
!
!      get_dC6_dCNij calculates the derivative dC6(iat,jat)/dCN(iat) and
!      dC6(iat,jat)/dCN(jat). these are saved in dC6ij for the kat loop
!
          call get_dC6_dCNij_sh(maxc,max_elem,c6ab,mxc(iz(iat)),
     .          mxc(iz(jat)),cn(iat),cn(jat),iz(iat),iz(jat),iat,jat,
     .          c6,dc6ij(iat,jat),dc6ij(jat,iat))

          r42=r2r4(iz(iat))*r2r4(iz(jat))
          rcovij=rcov(iz(iat))+rcov(iz(jat))
 
          R0=a1*dsqrt(3.0d0*r42)+a2

            do taux=-rep_v(1),rep_v(1)
            do tauy=-rep_v(2),rep_v(2)
            do tauz=-rep_v(3),rep_v(3)
              tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
  
  
            rij=xyz(:,jat)-xyz(:,iat)+tau
            r2=sum(rij*rij)
            if (r2.gt.rthr) cycle
  
 
            r=dsqrt(r2)
            r4=r2*r2
            r6=r4*r2
            r7=r6*r
            r8=r6*r2
            r9=r8*r
  
!
!  Calculates damping functions:
            t6=(r6+R0**6)
            t8=(r8+R0**8)

 
            drij(tauz,tauy,taux,lin_sh(iat,jat))=drij(tauz,tauy,taux,
     .           lin_sh(iat,jat))
     .        -s6*C6*6.0d0*r4*r/(t6*t6)
     .        -s8*C6*24.0d0*r42*r7/(t8*t8)

!
!      in dC6_rest all terms BUT C6-term is saved for the kat-loop
!          
            dc6_rest(tauz,tauy,taux,lin_sh(iat,jat))=
     .        (s6/t6+3.d0*s8*r42/t8)

 
            disp=disp-dc6_rest(tauz,tauy,taux,lin_sh(iat,jat))*c6  ! calculate E_disp for sanity check

!            if (r2.lt.crit_cn) 
            dc6_rest_sum(lin_sh(iat,jat))=dc6_rest_sum(lin_sh(iat,jat))
     .        +dc6_rest(tauz,tauy,taux,lin_sh(iat,jat)) 


          enddo !tauz
          enddo !tauy
          enddo !taux
  
        end if
        pcount = pcount + 1
        enddo !jat

      enddo !iat

      if (np.gt.1) call GA_DGOP(9+MSGDBL,disp,1,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dc6ij,n*n,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dc6_rest_sum,n*(n+1)/2,'+')

      !write(*,*) "hello,disp=",disp
      !if (taskid.eq.0) write(*,*) "hello,dc6ij=",dc6ij
      !if (taskid.eq.0) write(*,*) "hello,dc6_rest_sum=",dc6_rest_sum


*     **** compute dcn ****
      do iat=1,n
         if (mod(pcount,np).eq.taskid) then
         rcovij=rcov(iz(iat))+rcov(iz(iat))
         do taux=-rep_cn(1),rep_cn(1)
         do tauy=-rep_cn(2),rep_cn(2)
         do tauz=-rep_cn(3),rep_cn(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
            r2=sum(tau*tau)
            if (r2.gt.0.1.and.r2.lt.crit_cn) then
               r=dsqrt(r2)
               expterm=exp(-k1*(rcovij/r-1.d0))
               dcn(tauz,tauy,taux,lin_sh(iat,iat))=-k1*rcovij*expterm/
     >                  (r2*(expterm+1.d0)*(expterm+1.d0))
            end if
         end do
         end do
         end do
         end if
         pcount = pcount + 1

         do jat=1,iat-1
            if (mod(pcount,np).eq.taskid) then
            rcovij=rcov(iz(iat))+rcov(iz(jat))
            linij=lin_sh(iat,jat)

            do taux=-rep_cn(1),rep_cn(1)
            do tauy=-rep_cn(2),rep_cn(2)
            do tauz=-rep_cn(3),rep_cn(3)
               tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
               rij=xyz(:,jat)-xyz(:,iat)+tau
               r2=sum(rij*rij)
               if (r2.le.crit_cn) then
                  r=dsqrt(r2)
                  expterm=exp(-k1*(rcovij/r-1.d0))
                  dcn(tauz,tauy,taux,linij)=-k1*rcovij*expterm/
     >                 (r2*(expterm+1.d0)*(expterm+1.d0))
               end if
            end do
            end do
            end do
            end if 
            pcount = pcount + 1

         end do
      end do
      count=(2*rep_cn(3)+1)*(2*rep_cn(2)+1)*(2*rep_cn(1)+1)*(n*(n+1)/2)
      if (np.gt.1) call GA_DGOP(9+MSGDBL,dcn,count,'+')
      !write(*,*) "hello,count=",count
      !if (taskid.eq.0) write(*,*) "hello,dcn=",dcn


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!      !B E G I N   d(C6)/dr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      do iat=1,n
         if (mod(pcount,np).eq.taskid) then

         do taux=-rep_cn(1),rep_cn(1)
         do tauy=-rep_cn(2),rep_cn(2)
         do tauz=-rep_cn(3),rep_cn(3)

            dc6= (dc6ij(iat,iat)+dc6ij(iat,iat))
     >          *dcn(tauz,tauy,taux,lin_sh(iat,iat))
            drij(tauz,tauy,taux,lin_sh(iat,iat)) = 
     >           drij(tauz,tauy,taux,lin_sh(iat,iat))
     >        +  dc6_rest_sum(lin_sh(iat,iat))*dc6           

         enddo !tauz
         enddo !tauy
         enddo !taux
         end if
         pcount = pcount + 1

         do jat=1,iat-1
            if (mod(pcount,np).eq.taskid) then
            linij=lin_sh(iat,jat)

            do taux=-rep_cn(1),rep_cn(1)
            do tauy=-rep_cn(2),rep_cn(2)
            do tauz=-rep_cn(3),rep_cn(3)

               dc6=(dc6ij(iat,jat))*dcn(tauz,tauy,taux,lin_sh(iat,iat))
               drij(tauz,tauy,taux,lin_sh(iat,iat)) =
     >               drij(tauz,tauy,taux,lin_sh(iat,iat))
     .            +  dc6_rest_sum(lin_sh(iat,jat))*dc6 

               dc6=(dc6ij(jat,iat))*dcn(tauz,tauy,taux,lin_sh(jat,jat))
               drij(tauz,tauy,taux,lin_sh(jat,jat)) =
     >               drij(tauz,tauy,taux,lin_sh(jat,jat))
     >           +  dc6_rest_sum(lin_sh(jat,iat))*dc6

               dc6=(dc6ij(iat,jat)+dc6ij(jat,iat))
     >             *dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)= drij(tauz,tauy,taux,linij)
     >                                   + dc6_rest_sum(linij)*dc6 

               dc6=(dc6ij(iat,iat)+dc6ij(iat,iat))
     >             *dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                             +dc6_rest_sum(lin_sh(iat,iat))*dc6 

               dc6=(dc6ij(jat,jat)+dc6ij(jat,jat))
     >             *dcn(tauz,tauy,taux,linij)
               drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                            +dc6_rest_sum(lin_sh(jat,jat))*dc6 
            enddo !tauz
            enddo !tauy
            enddo !taux
!
! In the kat loop all the 3rd atom contributions are calculated:
!            1/r_ij^6*f_dmp(ij)  *  d(C6(ij))/d r_ik
!            -------V----------     -------V--------
!             dc6_rest_sum(ij)   *  dc6ij(i,j)*dcn(ik)
!
!   To reduce the kat-loop to only jat-1, on gets 6 contributions
!   
!
            do kat=1,jat-1
               linik=lin_sh(iat,kat)
               linjk=lin_sh(jat,kat)

               do taux=-rep_cn(1),rep_cn(1)
               do tauy=-rep_cn(2),rep_cn(2)
               do tauz=-rep_cn(3),rep_cn(3)

                  dc6=dc6ij(iat,kat)*dcn(tauz,tauy,taux,linij)
                  drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                                      +dc6_rest_sum(linik)*dc6

                  dc6=dc6ij(jat,kat)*dcn(tauz,tauy,taux,linij)
                  drij(tauz,tauy,taux,linij)=drij(tauz,tauy,taux,linij)
     >                                      +dc6_rest_sum(linjk)*dc6

                  dc6=dc6ij(kat,iat)*dcn(tauz,tauy,taux,linjk)
                  drij(tauz,tauy,taux,linjk)=drij(tauz,tauy,taux,linjk)
     >                                      +dc6_rest_sum(linik)*dc6

                  dc6=dc6ij(jat,iat)*dcn(tauz,tauy,taux,linjk)
                  drij(tauz,tauy,taux,linjk)=drij(tauz,tauy,taux,linjk)
     >                                      +dc6_rest_sum(linij)*dc6

                  dc6=dc6ij(kat,jat)*dcn(tauz,tauy,taux,linik)
                  drij(tauz,tauy,taux,linik)=drij(tauz,tauy,taux,linik)
     >                                      +dc6_rest_sum(linjk)*dc6

                  dc6=dc6ij(iat,jat)*dcn(tauz,tauy,taux,linik)
                  drij(tauz,tauy,taux,linik)=drij(tauz,tauy,taux,linik)
     >                                      +dc6_rest_sum(linij)*dc6

               end do !tauz
               end do !tauy
               end do !taux
            end do!kat
            end if
            pcount = pcount + 1

         end do!jat
      end do!iat

      count = (2*rep_v(3)+1)*(2*rep_v(2)+1)*(2*rep_v(1)+1)*(n*(n+1)/2)
      if (np.gt.1) call GA_DGOP(9+MSGDBL,drij,count,'+')

      !write(*,*) "hello,count=",count
      !if (taskid.eq.0) write(*,*) "hello,drij=",drij

! After calculating all derivatives dE/dr_ij w.r.t. distances,
! the grad w.r.t. the coordinates is calculated dE/dr_ij * dr_ij/dxyz_i       
      do iat=2,n
        do jat=1,iat-1
        if (mod(pcount,np).eq.taskid) then
          do taux=-rep_v(1),rep_v(1)
          do tauy=-rep_v(2),rep_v(2)
          do tauz=-rep_v(3),rep_v(3)
            tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)

          rij=xyz(:,jat)-xyz(:,iat)+tau
          r=dsqrt(sum(rij*rij))
          vec=drij(tauz,tauy,taux,lin_sh(iat,jat))*rij/r
          vec2(1)=taux
          vec2(2)=tauy
          vec2(3)=tauz
          g(:,iat)=g(:,iat)+vec
          g(:,jat)=g(:,jat)-vec
          do i=1,3
          do j=1,3
          sigma(j,i)=sigma(j,i)+vec(j)*rij(i)
          enddo !j
          enddo !i



          enddo !tauz
          enddo !tauy
          enddo !taux
        end if
        pcount = pcount + 1
        enddo !jat
      enddo !iat

      do iat=1,n
      if (mod(pcount,np).eq.taskid) then
          do taux=-rep_v(1),rep_v(1)
          do tauy=-rep_v(2),rep_v(2)
          do tauz=-rep_v(3),rep_v(3)
          if (taux.eq.0.and.tauy.eq.0.and.tauz.eq.0) cycle

          tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
          r=dsqrt(sum(tau*tau))
          vec=drij(tauz,tauy,taux,lin_sh(iat,iat))*tau/r
          vec2(1)=taux
          vec2(2)=tauy
          vec2(3)=tauz
          do i=1,3
          do j=1,3
            sigma(j,i)=sigma(j,i)+vec(j)*tau(i)
          enddo !j
          enddo !i


          enddo !tauz
          enddo !tauy
          enddo !taux

      end if
      pcount = pcount + 1
      enddo
      if (np.gt.1) call GA_DGOP(9+MSGDBL,g,3*n,'+')
      if (np.gt.1) call GA_DGOP(9+MSGDBL,sigma,9,'+')

      stress=0.0d0
      call inv_cell_sh(lat,lat_1)
      do a=1,3
        do b=1,3
           do my=1,3
              stress(a,b)=stress(a,b)-sigma(a,my)*lat_1(b,my)
           enddo
        enddo !b
      enddo !a



!          write(*,*)'drij:',drij(lin_sh(iat,jat),:)
!          write(*,*)'g:',g(1,1:3)
!          write(*,*)'dcn:',sum(dcn(lin_sh(2,1),:))

      deallocate(drij,dc6_rest,dcn)



      endif ! version


 999  continue
!      do i=1,n
!        write(*,'(83F17.12)') g(1:3,i)
!      enddo
      gnorm=sum(abs(g(1:3,1:n)))
      if(echo)then
c      write(*,*)'testsum:',testsum*autoev/autoang
      write(*,*)'|G(force)| =',gnorm
      gnorm=sum(abs(stress(1:3,1:3)))
      write(*,*)'|G(stress)|=',gnorm
      endif

      end subroutine pbcgdisp_sh


      subroutine pbcwregrad_sh(nat,g,g_lat)
      implicit none
      integer nat,i
      real*8 g(3,nat)
      real*8 g_lat(3,3)

      open(unit=142,file='dftd3_gradient')

!      write(*,*)'Gradient:' !Jonas
!      write(*,*)            !Jonas
      do i=1,nat
         write(142,'(3E22.14)')g(1:3,i)
!         write(*,'(3D22.14)')g(1:3,i) !Jonas
      enddo

      close(142)

      open(unit=143,file='dftd3_cellgradient')

!      write(*,*)'Gradient:' !Jonas
!      write(*,*)            !Jonas
      do i=1,3
         write(143,'(3E22.14)')g_lat(1:3,i)
!         write(*,'(3D22.14)')g(1:3,i) !Jonas
      enddo

      close(143)
      end subroutine pbcwregrad_sh

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C analyse all pairs
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      subroutine pbcadisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,autokcal,
     .           autoang,rthr,rep_v,cn_thr,rep_cn,s6,s18,etot,lat)
      implicit none  
      integer n,iz(*),max_elem,maxc,version,mxc(max_elem) 
      real*8 xyz(3,*),r0ab(max_elem,max_elem),r2r4(*),s6
      real*8 rs6,rs8,rs10,alp6,alp8,alp10,autokcal,etot,s18,autoang
      real*8 c6ab(max_elem,max_elem,maxc,maxc,3),rcov(max_elem)
      real*8 lat(3,3)
      integer rep_v(3),rep_cn(3)
 
      integer iat,jat,i,j,k,nbin,taux,tauy,tauz
      real*8 R0,r,r2,r6,r8,tmp,alp,dx,dy,dz,c6,c8,c10
      real*8 damp6,damp8,damp10,r42,rr,check,rthr,cn_thr,rvdw
      real*8 cn(n),i6,e6,e8,e10,edisp                   
      real*8,allocatable ::  dist(:),li(:,:)
      real*8 xx(500),eg(10000)
      integer grplist(500,20)
      integer grpn(20),at(n)
      integer ngrp,dash
      integer lin_sh, iiii, jjjj, iii, jjj, ii, jj, ni, nj 
      integer iout(500)
      logical ex
      character*80 atmp
      real*8 tau(3)
 
      real*8,dimension(:,:), allocatable :: ed
      allocate(ed(n,n))


c distance bins
      nbin=17
      allocate(dist(0:nbin))
      allocate(li(0:nbin,2))

      li(0,1)=0   
      li(0,2)=1.5 
      li(1,1)=1.5
      li(1,2)=2
      li(2,1)=2
      li(2,2)=2.3333333333
      li(3,1)=2.3333333333
      li(3,2)=2.6666666666
      li(4,1)=2.6666666666
      li(4,2)=3.0
      li(5,1)=3.0          
      li(5,2)=3.3333333333
      li(6,1)=3.3333333333
      li(6,2)=3.6666666666
      li(7,1)=3.6666666666
      li(7,2)=4.0
      li(8,1)=4.0
      li(8,2)=4.5
      li(9,1)=4.5
      li(9,2)=5.0
      li(10,1)=5.0
      li(10,2)=5.5
      li(11,1)=5.5
      li(11,2)=6.0
      li(12,1)=6.0
      li(12,2)=7.0           
      li(13,1)=7.0           
      li(13,2)=8.0           
      li(14,1)=8.0           
      li(14,2)=9.0           
      li(15,1)=9.0           
      li(15,2)=10.0          
      li(16,1)=10.0           
      li(16,2)=20.0          
      li(17,1)=20.0           
      li(17,2)=dsqrt(rthr)*autoang


      call pbcncoord_sh(n,rcov,iz,xyz,cn,lat,rep_cn,cn_thr)

      write(*,*)
      write(*,*)'analysis of pair-wise terms (in kcal/mol)'
      write(*,'(''pair'',2x,''atoms'',9x,''C6'',14x,''C8'',12x,
     .''E6'',7x,''E8'',7x,''Edisp'')')
      e8=0
      ed=0
      dist=0
      check=0
      do iat=1,n
         do jat=iat,n

             do taux=-rep_v(1),rep_v(1)
             do tauy=-rep_v(2),rep_v(2)
             do tauz=-rep_v(3),rep_v(3)
              tau=taux*lat(:,1)+tauy*lat(:,2)+tauz*lat(:,3)
            dx=xyz(1,iat)-xyz(1,jat)+tau(1)
            dy=xyz(2,iat)-xyz(2,jat)+tau(2)
            dz=xyz(3,iat)-xyz(3,jat)+tau(3)
            r2=(dx*dx+dy*dy+dz*dz)
CTHR
            if(r2.gt.rthr.or.r2.lt.0.5) cycle
            r =sqrt(r2)
            R0=r0ab(iz(jat),iz(iat))
            rr=R0/r
            r6=r2**3       

            tmp=rs6*rr   
            damp6 =1.d0/( 1.d0+6.d0*tmp**alp6 )
            tmp=rs8*rr     
            damp8 =1.d0/( 1.d0+6.d0*tmp**alp8 )

            if (version.eq.2)then
              c6=c6ab(iz(jat),iz(iat),1,1,1)
              damp6=1.d0/(1.d0+exp(-alp6*(r/(rs6*R0)-1.0d0)))
              if (iat.eq.jat) then
                e6 =s6*autokcal*c6*damp6/r6
              else
                e6 =s6*autokcal*c6*damp6/r6
              endif
              e8=0.0d0
            else
              call getc6_sh(maxc,max_elem,c6ab,mxc,iz(iat),iz(jat),
     .                                      cn(iat),cn(jat),c6)
            endif

            if(version.eq.3)then
              r8 =r6*r2
              r42=r2r4(iz(iat))*r2r4(iz(jat))
              c8 =3.0d0*c6*r42
              if (iat.eq.jat) then
                e6 =s6*autokcal*c6*damp6/r6*0.5
                e8 =s18*autokcal*c8*damp8/r8*0.5
              else
                e6 =s6*autokcal*c6*damp6/r6
                e8 =s18*autokcal*c8*damp8/r8
              endif
            endif

            if(version.eq.4)then
              r42=r2r4(iz(iat))*r2r4(iz(jat))
              c8 =3.0d0*c6*r42
c use BJ radius
              R0=dsqrt(c8/c6)              
              rvdw=rs6*R0+rs8
              r8 =r6*r2
              if (iat.eq.jat) then
                e6 =s6*autokcal*c6/(r6+rvdw**6)*0.5
                e8 =s18*autokcal*c8/(r8+rvdw**8)*0.5
              else
                e6 =s6*autokcal*c6/(r6+rvdw**6)
                e8 =s18*autokcal*c8/(r8+rvdw**8)
              endif
            endif

            edisp=-(e6+e8)
            ed(iat,jat)=edisp
            ed(jat,iat)=edisp

!           write(*,'(2i4,2x,2i3,2D16.6,2F9.4,F10.5)')
!     .     iat,jat,iz(iat),iz(jat),c6,c8,
!     .    -e6,-e8,edisp

            check=check+edisp
            rr=r*autoang
            do i=0,nbin
               if(rr.gt.li(i,1).and.rr.le.li(i,2)) dist(i)=dist(i)+edisp
            enddo
          enddo !tauz
          enddo !tauy
          enddo !taux
         enddo !jat
      enddo !iat

      write(*,'(/''distance range (Angstroem) analysis'')')
      write(*,'( ''writing histogram data to <histo.dat>'')')
      open(unit=11,file='histo.dat')
      do i=0,nbin
         write(*,'(''R(low,high), Edisp, %tot :'',2f5.1,F12.5,F8.2)')
     .   li(i,1),li(i,2),dist(i),100.*dist(i)/etot
         write(11,*)(li(i,1)+li(i,2))*0.5,dist(i)
      enddo
      close(11)

      write(*,*) 'checksum (Edisp) ',check
      if(abs(check-etot).gt.1.d-3)stop'something is weired in adisp'

      deallocate(dist,li)
      return








      inquire(file='fragment',exist=ex)
      if(ex) return
      write(*,'(/''fragment based analysis'')')
      write(*,'( ''reading file <fragment> ...'')')
      open(unit=55,file='fragment')
      i=0
      at=0
 111  read(55,'(a)',end=222) atmp
      call readfrag_sh(atmp,iout,j)
      if(j.gt.0)then
         i=i+1
         grpn(i)=j
         do k=1,j
            grplist(k,i)=iout(k)      
            at(grplist(k,i))=at(grplist(k,i))+1
         enddo
      endif
      goto 111
 222  continue
      ngrp=i  
      k=0
      do i=1,n
         if(at(i).gt.1) stop 'something is weird in file <fragment>'
         if(at(i).eq.0)then
            k=k+1
            grplist(k,ngrp+1)=i
         endif
      enddo
      if(k.gt.0) then
         ngrp=ngrp+1
         grpn(ngrp)=k
      endif
c Implemented display of atom ranges instead of whole list of atoms
      write(*,*)'group #        atoms '
      dash=0
      do i=1,ngrp
       write(*,'(i4,3x,i4)',advance='no')i,grplist(1,i)
       do j=2,grpn(i)
        if(grplist(j,i).eq.(grplist(j-1,i)+1)) then
         if(dash.eq.0)then
          write(*,'(A1)',advance='no')'-'
          dash=1
         endif
        else
         if(dash.eq.1)then
          write(*,'(i4)',advance='no') grplist(j-1,i)
          dash=0
         endif
         write(*,'(i4)',advance='no') grplist(j,i)
        endif
       enddo 
       if(dash.eq.1)then
        write(*,'(i4)',advance='no') grplist(j-1,i)
        dash=0
       endif
      write(*,*)''
      enddo

c old display list code
c      write(*,*)'group #        atoms '
c      do i=1,ngrp      
c         write(*,'(i4,3x,100i3)')i,(grplist(j,i),j=1,grpn(i))
c      enddo

      eg=0
      iii=0
      do i=1,ngrp
         ni=grpn(i)
         iii=iii+1
         jjj=0
         do j=1,ngrp
            nj=grpn(j)
            jjj=jjj+1
            do ii=1,ni
               iiii=grplist(ii,i)
               do jj=1,nj
                  jjjj=grplist(jj,j)
                  if(jjjj.lt.iiii)cycle
                  eg(lin_sh(iii,jjj))=eg(lin_sh(iii,jjj))+ed(iiii,jjjj)
               enddo
            enddo
         enddo
      enddo

c     call prmat(6,eg,ngrp,0,'intra- + inter-group dispersion energies')
      write(*,*)' group i      j     Edisp'
      k=0
      check=0
      do i=1,ngrp
      do j=1,i    
      k=k+1
      check=check+eg(k) 
      write(*,'(5x,i4,'' --'',i4,F8.2)')i,j,eg(k)
      enddo
      enddo
      write(*,*) 'checksum (Edisp) ',check

      deallocate(dist,li)
      end subroutine pbcadisp_sh
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine SET_CRITERIA_sh(rthr,lat,tau_max)

        REAL*8 :: r_cutoff,rthr
        REAL*8 :: lat(3,3)
        REAL*8 :: tau_max(3)
        REAL*8 :: norm1(3),norm2(3),norm3(3)
        REAL*8 :: cos10,cos21,cos32
        real*8,external :: vectorsize_sh

        r_cutoff=sqrt(rthr)
c          write(*,*) 'lat',lat
          !c find normal to the plane...
        call kreuzprodukt_sh(lat(:,2),lat(:,3),norm1)
        call kreuzprodukt_sh(lat(:,3),lat(:,1),norm2)
        call kreuzprodukt_sh(lat(:,1),lat(:,2),norm3)
c        write(*,*) 'norm2',norm2
        !c ...normalize it...
        norm1=norm1/VECTORSIZE_sh(norm1)
        norm2=norm2/VECTORSIZE_sh(norm2)
        norm3=norm3/VECTORSIZE_sh(norm3)
c        write(*,*) 'norm2_',norm2
          !c cos angles between normals and lattice vectors
        cos10=SUM(norm1*lat(:,1))
        cos21=SUM(norm2*lat(:,2))
        cos32=SUM(norm3*lat(:,3))
          !write(*,*) 'cos32',cos32
          !tau_max(1)=abs(2*r_cutoff/cos10)
          !tau_max(2)=abs(2*r_cutoff/cos21)
          !tau_max(3)=abs(2*r_cutoff/cos32)
          !write(*,*) 'r_cutoff',r_cutoff
        tau_max(1)=abs(r_cutoff/cos10)
        tau_max(2)=abs(r_cutoff/cos21)
        tau_max(3)=abs(r_cutoff/cos32)
c        write(*,'(3f8.4)')tau_max(1),tau_max(2),tau_max(3)
      END subroutine SET_CRITERIA_sh


      subroutine kreuzprodukt_sh(A,B,C)
        IMPLICIT NONE
  
        REAL*8 :: A(3),B(3)
        REAL*8 :: X,Y,Z
        REAL*8 :: C(3)
        
        X=A(2)*B(3)-B(2)*A(3)
        Y=A(3)*B(1)-B(3)*A(1)
        Z=A(1)*B(2)-B(1)*A(2)
        C=(/X,Y,Z/)
      END subroutine kreuzprodukt_sh

       function VECTORSIZE_sh(VECT)

         REAL*8 :: VECT(3)
         REAL*8 :: SVECT(3)
         REAL*8 :: VECTORSIZE_sh

         SVECT=VECT*VECT
         VECTORSIZE_sh=SUM(SVECT)
         VECTORSIZE_sh=VECTORSIZE_sh**(0.5)
       END function VECTORSIZE_sh

      subroutine stresstensor_sh(maxc,max_elem,autoev,s6,s18,xyz,n,iz,
     .     latice,c6ab,mxc,version,num_ex,noabc,echo,r0ab,r2r4,
     .     rcov,rs6,rs8,rs10,alp6,alp8,alp10,rthr,rep_vdw,cn_thr,rep_cn,
     .     stress)
      IMPLICIT NONE
!!! all values in au !!!       
      INTEGER      :: maxc,max_elem
      real*8,intent(in)   :: autoev
      REAL*8,intent(inout):: xyz(3,*) !cartesian coordinates of atoms
      INTEGER,intent(in)  :: n !number of atoms
      REAL*8,intent(in)   :: latice(3,3) !unitcell vectors in cartesian
      INTEGER,intent(in) :: version !2=D2,3=D3-zero, 4=D3-BJ
      real*8, intent(out) :: stress(3,3) !stresstensor
      logical,intent(in)  :: num_ex !true, if numerical grad-routine
      logical,INTENT(in)  :: noabc !true if no threebodycontirbution
      logical,INTENT(in)  :: echo !true if printout on screen is desired
      real*8,INTENT(in)   :: c6ab(max_elem,max_elem,maxc,maxc,3)! C6 for all element pairs 
      integer,INTENT(in)  :: mxc(max_elem)! how many different C6 for one element
      real*8,intent(in)   :: r0ab(max_elem,max_elem)! cut-off radii for all element pairs
      integer,INTENT(in)  :: iz(*) !cardinal number of atoms
      real*8,intent(in)   :: s6,s18 !scalingparameters
      real*8              :: r2r4(max_elem),rcov(max_elem)
      real*8              :: rs6,rs8,rs10,alp6,alp8,alp10 
      real*8              :: rthr,cn_thr
      integer             :: rep_vdw(3),rep_cn(3)

      
      INTEGER        ::i,j,k,iat,my,ny,a,b
      REAL*8,DIMENSION(3,10000)::abc
      REAL*8                ::e6,e8,e10,e12,e6abc,disp
      real*8                ::step,dum1,dum2
      real*8,dimension(3,3) ::lat,lat_1,lat_1t
      real*8,dimension(3,3) :: num_stresstensor,sigma
      real*8                ::grad(3,n),gradnorm
      logical               :: echo2
      real*8,external       :: volume_sh
      logical             :: num !true, if numerical grad-routine
      real*8               :: time1,time2
      
      
      echo2=echo
      lat=latice
      call inv_cell_sh(lat,lat_1)
      lat_1t=transpose(lat_1)
      
      
      sigma=0.0d0
      num=.true.

      call cpu_time(time1)
      call xyz_to_abc_sh(xyz,abc,lat,n)
      IF (num) THEN
      IF (echo2) write(*,*)'Doing numerical stresstensor...'
      step=2.d-5
      do i=1,3
        do j=1,3
          lat(j,i)=lat(j,i)+step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          !call edisp...dum1
       call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_vdw,cn_thr,rep_cn)
         dum1=-s6*e6-s18*e8-s6*e6abc


          lat(j,i)=lat(j,i)-2*step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          !call edisp...dum2
        call pbcedisp_sh(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
     .           rcov,rs6,rs8,rs10,alp6,alp8,alp10,version,noabc,
     .           e6,e8,e10,e12,e6abc,lat,rthr,rep_vdw,cn_thr,rep_cn)
          dum2=-s6*e6-s18*e8-s6*e6abc
          num_stresstensor(j,i)=(dum1-dum2)/(step*2.0)

          lat(j,i)=lat(j,i)+step
          call abc_to_xyz_sh(abc,xyz,lat,n)
          
        enddo !j
      enddo !i
      stress=num_stresstensor
      
      
      ELSE !NOT NUM analytic gradient
      IF (echo2) write(*,*)'Doing analytical stresstensor...'
      
!      write(*,*)'Analytical gradient for cellstress Not jet done!'
!      return
      
!      call pbcgdisp(max_elem,maxc,n,xyz,iz,c6ab,mxc,r2r4,r0ab,
!     .            rcov,s6,s18,rs6,rs8,rs10,alp6,alp8,alp10,noabc,num,
!     .                 version,g,disp,gnorm,sigma,lat,rep_v,rep_cn,
!     .                 crit_vdw,echo,crit_cn)


      sigma=sigma!/(volume(lat))

      do a=1,3
        do b=1,3
          do my=1,3
            stress(a,b)=stress(a,b)+sigma(a,my)*lat_1(b,my)
          enddo          
        enddo !b
      enddo !a
      stress=-stress!*volume(lat)

      ENDIF !num or anal
      call cpu_time(time2)
    

      IF (echo2) THEN 
        write(*,*)'Done!'
        write(*,'('' time  '',f4.1)')time2-time1
!        write(*,*)'Virialstress(eV):'
!        write(*,'(3F12.8)')sigma*autoev
!        write(*,*)''
        write(*,*)'Stress(a.u.):'
        write(*,'(3F12.8)')stress
      ENDIF !echo2
      
      END subroutine stresstensor_sh
      
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine inv_cell_sh(x,a) !x is normal lat, a is lat^(-1)
      IMPLICIT NONE
      real*8, intent(in)   :: x(3,3) !unitcell vectors in direct space
      real*8, intent(out)  :: a(3,3) !unitcell vectors in reciprocal space
      integer i
      real*8 det
      
      a=0.0
      det=x(1,1)*x(2,2)*x(3,3)+x(1,2)*x(2,3)*x(3,1)+x(1,3)*x(2,1)*
     .    x(3,2)-x(1,3)*x(2,2)*x(3,1)-x(1,2)*x(2,1)*x(3,3)-x(1,1)*
     .    x(2,3)*x(3,2)
!      write(*,*)'Det:',det
      a(1,1)=x(2,2)*x(3,3)-x(2,3)*x(3,2)
      a(2,1)=x(2,3)*x(3,1)-x(2,1)*x(3,3)
      a(3,1)=x(2,1)*x(3,2)-x(2,2)*x(3,1)
      a(1,2)=x(1,3)*x(3,2)-x(1,2)*x(3,3)
      a(2,2)=x(1,1)*x(3,3)-x(1,3)*x(3,1)
      a(3,2)=x(1,2)*x(3,1)-x(1,1)*x(3,2)
      a(1,3)=x(1,2)*x(2,3)-x(1,3)*x(2,2)
      a(2,3)=x(1,3)*x(2,1)-x(1,1)*x(2,3)
      a(3,3)=x(1,1)*x(2,2)-x(1,2)*x(2,1)
      a=a/det
      end subroutine inv_cell_sh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine xyz_to_abc_sh(xyz,abc,lat,n)
      IMPLICIT NONE
      real*8, INTENT(in) :: xyz(3,*)
      real*8, intent(in) :: lat(3,3)
      real*8, intent(out) :: abc(3,*)
      integer,intent(in) :: n
      
      real*8 lat_1(3,3)
      integer i,j,k

      call inv_cell_sh(lat,lat_1)
      
      abc(:,:n)=0.0d0
      do i=1,n
        do j=1,3
          do k=1,3
            abc(j,i)=abc(j,i)+lat_1(j,k)*xyz(k,i)            
          enddo !k
          abc(j,i)=dmod(abc(j,i),1.0d0)
        enddo !j
      enddo !i
  
      END subroutine xyz_to_abc_sh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine abc_to_xyz_sh(abc,xyz,lat,n)
      IMPLICIT NONE
      real*8, INTENT(in) :: abc(3,*)
      real*8, intent(in) :: lat(3,3)
      real*8, intent(out) :: xyz(3,*)
      integer,intent(in) :: n
      
      integer i,j,k

      xyz(:,:n)=0.0d0
      do i=1,n
        do j=1,3
          do k=1,3
            xyz(j,i)=xyz(j,i)+lat(j,k)*abc(k,i)            
          enddo !k
        enddo !j
      enddo !i
  
      END subroutine abc_to_xyz_sh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      REAL*8 function volume_sh(lat)
        IMPLICIT NONE
        REAL*8, INTENT(in) ::lat(3,3)
        REAL*8 zwerg
        
        zwerg=lat(1,1)*lat(2,2)*lat(3,3)+lat(1,2)*lat(2,3)*lat(3,1)+
     .       lat(1,3)*lat(2,1)*lat(3,2)-lat(1,3)*lat(2,2)*lat(3,1)-
     .       lat(1,2)*lat(2,1)*lat(3,3)-lat(1,1)*lat(2,3)*lat(3,2)
        volume_sh=abs(zwerg)
      END function volume_sh



ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c       
c            string pars procedures
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c      subroutine parse(str,delims,args,nargs)
c
c! Parses the string 'str' into arguments args(1), ..., args(nargs) based on
c! the delimiters contained in the string 'delims'. Preceding a delimiter in
c! 'str' by a backslash (\) makes this particular instance not a delimiter.
c! The integer output variable nargs contains the number of arguments found.
c      interface 
c        subroutine split(str,delims,before,sep)
c         character(len=*),intent(inout) :: str,before
c         character(len=*),intent(in) :: delims
c         character,optional,intent(inout) :: sep
c       end subroutine split
c      end interface
c
c      character(len=*),intent(inout) :: str
c      character(len=*),intent(in) :: delims
c      character(len=len_trim(str)) :: strsav
c      character(len=*),dimension(:),intent(inout) :: args
c      integer, intent(out) :: nargs
c      
c      strsav=str
c      call compact(str)
c      na=size(args)
c      do i=1,na
c        args(i)=' '
c      end do  
c      nargs=0
c      lenstr=len_trim(str)
c      if(lenstr==0) return
c      k=0
c
c      do
c         if(len_trim(str) == 0) exit
c         nargs=nargs+1
c         call split(str,delims,args(nargs))
c         call removebksl(args(nargs))
c      end do   
c      str=strsav
c
c      end subroutine parse

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

      subroutine compact_sh(str)

! Converts multiple spaces and tabs to single spaces; deletes control characters;
! removes initial spaces.

      character(len=*):: str
      character(len=1):: ch
      character(len=len_trim(str)):: outstr
      
      str=adjustl(str)
      lenstr=len_trim(str)
      outstr=' '
      isp=0
      k=0

      do i=1,lenstr
        ch=str(i:i)
        ich=iachar(ch)
  
        select case(ich)
  
          case(9,32)     ! space or tab character
            if(isp==0) then
              k=k+1
              outstr(k:k)=' '
            end if
            isp=1
            
          case(33:)      ! not a space, quote, or control character
            k=k+1
            outstr(k:k)=ch
            isp=0
      
        end select
        
      end do

      str=adjustl(outstr)

      end subroutine compact_sh

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

      subroutine removesp(str)

      ! Removes spaces, tabs, and control characters in string str

      character(len=*):: str
      character(len=1):: ch
      character(len=len_trim(str))::outstr

      str=adjustl(str)
      lenstr=len_trim(str)
      outstr=' '
      k=0

      do i=1,lenstr
        ch=str(i:i)
        ich=iachar(ch)
        select case(ich)    
          case(0:32)  ! space, tab, or control character
               cycle       
          case(33:)  
            k=k+1
            outstr(k:k)=ch
        end select
      end do
      
      str=adjustl(outstr)
      
      end subroutine removesp



c      subroutine split(str,delims,before,sep)
c
c! Routine finds the first instance of a character from 'delims' in the
c! the string 'str'. The characters before the found delimiter are
c! output in 'before'. The characters after the found delimiter are
c! output in 'str'. The optional output character 'sep' contains the 
c! found delimiter. A delimiter in 'str' is treated like an ordinary 
c! character if it is preceded by a backslash (\). If the backslash 
c! character is desired in 'str', then precede it with another backslash.
c
c      character(len=*),intent(inout) :: str,before
c      character(len=*),intent(in) :: delims
c      character,optional :: sep
c      logical :: pres
c      character :: ch,cha
c
c      pres=present(sep)
c      str=adjustl(str)
c      call compact(str)
c      lenstr=len_trim(str)
c      if(lenstr == 0) return        ! string str is empty
c      k=0
c      ibsl=0                        ! backslash initially inactive
c      before=' '
c      do i=1,lenstr
c         ch=str(i:i)
c         if(ibsl == 1) then          ! backslash active
c            k=k+1
c            before(k:k)=ch
c            ibsl=0
c            cycle
c         end if
c         if(ch == '\') then          ! backslash with backslash inactive
c            k=k+1
c            before(k:k)=ch
c            ibsl=1
c            cycle
c         end if
c         ipos=index(delims,ch)         
c         if(ipos == 0) then          ! character is not a delimiter
c            k=k+1
c            before(k:k)=ch
c            cycle
c         end if
c         if(ch /= ' ') then          ! character is a delimiter that is not a space
c            str=str(i+1:)
c            if(pres) sep=ch
c            exit
c         end if
c         cha=str(i+1:i+1)            ! character is a space delimiter
c         iposa=index(delims,cha)
c         if(iposa > 0) then          ! next character is a delimiter
c            str=str(i+2:)
c            if(pres) sep=cha
c            exit
c         else
c            str=str(i+1:)
c            if(pres) sep=ch
c            exit
c         end if
c      end do
c      if(i >= lenstr) str=''
c      str=adjustl(str)              ! remove initial spaces
c      return
c
c      end subroutine split
c
c!**********************************************************************
c
c      subroutine removebksl(str)
c
c! Removes backslash (\) characters. Double backslashes (\\) are replaced
c! by a single backslash.
c
c      character(len=*):: str
c      character(len=1):: ch
c      character(len=len_trim(str))::outstr
c
c      str=adjustl(str)
c      lenstr=len_trim(str)
c      outstr=' '
c      k=0
c      ibsl=0                        ! backslash initially inactive
c      
c      do i=1,lenstr
c        ch=str(i:i)
c        if(ibsl == 1) then          ! backslash active
c         k=k+1
c         outstr(k:k)=ch
c         ibsl=0
c         cycle
c        end if
c        if(ch == '\') then          ! backslash with backslash inactive
c         ibsl=1
c         cycle
c        end if
c        k=k+1
c        outstr(k:k)=ch              ! non-backslash with backslash inactive
c      end do
c      
c      str=adjustl(outstr)
c      
c      end subroutine removebksl


c $Id: nwxc_vdw3c.F 26344 2014-10-18 00:48:39Z bylaska $
