reductionD.F90

Go to the documentation of this file.

!!
!!  File reductionD.F90 is part of COLLIER
!!  - A Complex One-Loop Library In Extended Regularizations
!!
!!  Copyright (C) 2015, 2016   Ansgar Denner, Stefan Dittmaier, Lars Hofer
!!
!!  COLLIER is licenced under the GNU GPL version 3, see COPYING for details.
!
!
!#define Dredtest
!#define Dpvtest
!#define Dpv1otest
!#define Dpv1test
!#define Dpv2test
!#define Dgtest 
!#define Dgmtest 
!#define Dgrtest
!#define Dgytest
!#define Dgxtest
!#define Dgptest
!#define Dgpftest
#define ALWAYSPV           !   default
!#define USED0
!#define PPEXP00
#define Cutrloop           !   default
!#define USEGM     !  needs changes in CalcDred in select etc
 
!#define TEST
!#define CritPointsCOLI 
#define PVEST2
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  ***********************
!  *  module reductionD  *
!  *    by Lars Hofer    *
!  ***********************
! 
!  functions and subroutines:
!  CalcDuv, CalcDpv, CalcDpv1, CalcDpv2, CalcDg, CalcDgy, CalcDgp, CalcDgr, CalcDgpf, CopyDimp3
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 
 
module globald
 
  double complex :: q10,q21,q32,q30,q20,q31,mm02,mm12,mm22,mm32
! double complex :: q1q2,q1q3,q2q3,detZ,Z(3,3),Zadj(3,3),f(3),Zadjf(3)
  double complex :: detz,z(3,3),zadj(3,3),f(3),zadjf(3)
  double complex :: zadj2f(3,3,3),zadj2ff(3,3),xadj(0:3,0:3),zadjs(3)
  double complex :: zadjff,detzmzadjf
  double complex :: mx(0:3,0:3),mxinv(0:3,0:3),zinv(3,3),detx
  double precision :: q2max,m2max,m2scale,adetz,fmax,maxzadjf,maxzadjfd,azadjff
  double precision :: maxzadj2ff,maxxadj,adetx,maxzadj,maxzadj2f,maxz
  double precision :: fac_g,x_g
  double precision :: fac_gm,x_gm
  double precision :: fac_gy,x_gy,y_gy,v_gy
  double precision :: fac_gp,w_gp
  double precision :: fac_gr
  double precision :: fac_gpf,x_gpf,y_gpf,v_gpf
!  double precision :: pweight(3)
  double precision :: wmaxzadj,wmaxzadjf,wmaxxadj
  double complex, parameter :: undefined_d=1d50
  
end module globald
 
 
 
 
module reductiond
 
  use reductionc
 
  implicit none
 
  ! should not be too small since expansion for large expansion parameters are calculated to early
  ! 1d1 to small for gy exp
  ! 10.08.2017 1d2 to small for gy expansion => adapt exit rloop in gy expansion 
  double precision, parameter :: truncfacd = 1d2
!  double precision, parameter :: truncfacD = 1d0
 
contains
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcD(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,
  !                   rmax,id,Derr1,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcd(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,     &
      rmax,id,Derr1,Derr2)
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr1(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: Daux(:,:,:,:), Duvaux(:,:,:,:), fct(:)
    double precision, allocatable :: Derr1aux(:),Derr2aux(:)
    double complex :: x(10)
    integer :: rank,switch,cnt,n0,n1,n2,n3,r
    logical :: nocalc,wrica
 
!    write(*,*) 'CalcD in'
!    write(*,*)  'CalcD in with Derr'
 
    if (use_cache_system) then
      if ((ncache.gt.0).and.(ncache.le.ncache_max)) then
!        if (use_cache(ncache).ge.4) then
          x(1)=p10
          x(2)=p21
          x(3)=p32
          x(4)=p30
          x(5)=p20
          x(6)=p31
          x(7)=m02
          x(8)=m12
          x(9)=m22
          x(10)=m32
          rank = rmax
          switch = 0
 
          if(rmax.ge.3) then
            allocate(fct(ncoefsg(rmax,4)-ncoefs(rmax-2,4)+ncoefs(rmax-3,4)+2*(rmax+1)))
            call readcache(fct,ncoefsg(rmax,4)-ncoefs(rmax-2,4)+ncoefs(rmax-3,4)+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
          else if(rmax.eq.2) then
            allocate(fct(ncoefsg(rmax,4)-1+2*(rmax+1)))
            call readcache(fct,ncoefsg(rmax,4)-1+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
          else
            allocate(fct(ncoefsg(rmax,4)+2*(rmax+1)))
            call readcache(fct,ncoefsg(rmax,4)+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
          end if
    
          if(nocalc)then
            cnt = 0
            duv(0:min(rmax/2,1),:,:,:) = 0d0
            do r=0,rmax
              do n1=0,r
                do n2=0,r-n1
                  n3=r-n1-n2
                  cnt = cnt+1
                  d(0,n1,n2,n3) = fct(cnt)
                end do
              end do
              do n0=1,(r+1)/2
                do n1=0,r-2*n0+1
                  do n2=0,r-2*n0-n1+1
                    n3=r-2*n0-n1-n2+1
 
                    cnt = cnt+1
                    d(n0,n1,n2,n3) = fct(cnt)
                  end do
                end do
              end do
 
              do n0=2,(r+1)/2
                do n1=0,r-2*n0+1
                  do n2=0,r-2*n0-n1+1
                    n3=r-2*n0-n1-n2+1
 
                    cnt = cnt+1
                    duv(n0,n1,n2,n3) = fct(cnt)
                  end do
                end do
              end do
              cnt = cnt+1
              derr1(r) = real(fct(cnt))
              cnt = cnt+1
              derr2(r) = real(fct(cnt))
            end do
!            write(*,*) 'Dcache', id, rank, D(0,rank,0,0) 
            return
          end if
 
 
          if(rank.eq.rmax) then
 
            call calcdred(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rank,id,derr1,derr2)
!            write(*,*) 'Dcalc', id, rank, D(0,rank,0,0) 
 
            if (wrica) then
              cnt = 0
              do r=0,rank
                do n1=0,r
                  do n2=0,r-n1
                    n3 = r-n1-n2
                    cnt = cnt+1
                    fct(cnt) = d(0,n1,n2,n3)
                  end do
                end do
                do n0=1,(r+1)/2
                  do n1=0,r-2*n0+1
                    do n2=0,r-2*n0-n1+1
                      n3 = r-2*n0-n1-n2+1
                      cnt = cnt+1
                      fct(cnt) = d(n0,n1,n2,n3)
                    end do
                  end do
                end do
                do n0=2,(r+1)/2
                  do n1=0,r-2*n0+1
                    do n2=0,r-2*n0-n1+1
                      n3 = r-2*n0-n1-n2+1
                      cnt = cnt+1
                      fct(cnt) = duv(n0,n1,n2,n3)
                    end do
                  end do
                end do
                cnt = cnt+1
                fct(cnt) = derr1(r)
                cnt = cnt+1
                fct(cnt) = derr2(r)
              end do
   
              if(rank.ge.3) then
                call writecache(fct,ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1),id,4,rank)
              else if(rank.eq.2) then
                call writecache(fct,ncoefsg(rank,4)-1+2*(rank+1),id,4,rank)
              else
                call writecache(fct,ncoefsg(rank,4)+2*(rank+1),id,4,rank)
              end if            
 
            end if
 
            return
          
          
          else
            allocate(daux(0:rank,0:rank,0:rank,0:rank))
            allocate(duvaux(0:rank,0:rank,0:rank,0:rank))
            allocate(derr1aux(0:rank))
            allocate(derr2aux(0:rank))
 
            call calcdred(daux,duvaux,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rank,id,derr1aux,derr2aux)
 
            if (wrica) then
              cnt = 0
              deallocate(fct)
              if(rank.ge.3) then 
                allocate(fct(ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1)))
              else if(rank.eq.2) then 
                allocate(fct(ncoefsg(rank,4)-1+2*(rank+1)))
              else
                allocate(fct(ncoefsg(rank,4)+2*(rank+1)))
              end if
              do r=0,rank
!               do n0=0,r
                do n0=0,r/2+1
                  do n1=0,r-n0
                    do n2=0,r-n0-n1
                      n3 = r-n0-n1-n2
 
                      cnt = cnt+1
                      fct(cnt) = daux(n0,n1,n2,n3)
 
                    end do
                  end do
                end do
                do n0=2,r/2+1
                  do n1=0,r-n0
                    do n2=0,r-n0-n1
                      n3 = r-n0-n1-n2
 
                      cnt = cnt+1
                      fct(cnt) = duvaux(n0,n1,n2,n3)
 
                    end do
                  end do
                end do
                cnt = cnt+1
                fct(cnt) = derr1aux(r)
                cnt = cnt+1
                fct(cnt) = derr2aux(r)
              end do
 
              if(rank.ge.3) then
                call writecache(fct,ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1),id,4,rank)   
              else if(rank.eq.2) then
                call writecache(fct,ncoefsg(rank,4)-1+2*(rank+1),id,4,rank)
              else
                call writecache(fct,ncoefsg(rank,4)+2*(rank+1),id,4,rank)
              end if            
 
            end if
 
            d = daux(0:rmax,0:rmax,0:rmax,0:rmax)
            duv = duvaux(0:rmax,0:rmax,0:rmax,0:rmax)
            derr1 = derr1aux(0:rmax)
            derr2 = derr2aux(0:rmax)
 
            deallocate(daux)
            deallocate(duvaux)
            deallocate(derr1aux)
            deallocate(derr2aux)
 
            return
 
!          end if
        end if
      end if
    end if
      
    call calcdred(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
 
 
  end subroutine calcd
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDred(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr1,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdred(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr1,Derr2)
 
    use globald
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
!    integer :: scheme_C0(rmax-1:rmax_C),scheme_C1(rmax-1:rmax_C)
!    integer :: scheme_C2(rmax-1:rmax_C),scheme_C3(rmax-1,rmax_C)
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex :: elimminf2_coli
    double precision, intent(out)  :: Derr1(0:rmax),Derr2(0:rmax)
    double precision :: D0est,Dtyp
#ifdef USED0
    double complex :: D0_coli
#endif
!    double complex :: detX
    double complex :: chdet
    integer :: rmaxC,r,rid,n0,n1,n2,n3,g,gy,gp,gr,gm,gpf,i,iexp
    integer :: bin,k,nid(0:3)
    logical :: use_pv,use_pv2,use_g,use_gy,use_gp,use_gr,use_gm,use_gpf
 
    integer :: r_alt,Drmethod(0:rmax),DrCalc(0:rmax),DCalc
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex :: D_alt(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex :: Duv_alt(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision :: Derr(0:rmax),Derr_alt(0:rmax),Derr1_alt(0:rmax),Derr2_alt(0:rmax)
    integer :: Drmethod_alt(0:rmax)    
 
    double precision :: err_pv(0:rmax),err_pv2(0:rmax),err_g(0:rmax),err_gy(0:rmax),err_gp(0:rmax)
    double precision :: err_gr(0:rmax),err_gm(0:rmax),err_gpf(0:rmax)
    double precision :: h_pv,w_pv,v_pv,z_pv,h_pv2,w_pv2,v_pv2,z_pv2,hw_pv2
    double precision :: u_g,z_g,err_g_C,err_g_Cr,err_g_exp
    double precision :: u_gm,z_gm,err_gm_C,err_gm_Cr,err_gm_exp
    double precision :: v1_gy,b_gy,err_gy_C,err_gy_Cr,err_gy_exp
    double precision :: v_gp,v1_gp,z_gp,err_gp_C,err_gp_Cr,err_gp_exp
    double precision :: v1_gpf,b_gpf,err_gpf_C,err_gpf_Cr,err_gpf_exp
    double precision :: x_gr,y_gr,y1_gr,a_gr,err_gr_C,err_gr_Cr,err_gr_exp
    double precision :: err_C0,Cerr_i(0:rmax_C,0:3),err_C(0:rmax_C),err_D0,acc_D,errfac(0:3),err_req_D,err_inf,Cerr2_i(0:rmax_C,0:3)
    double precision :: checkest,norm,Dscale2
    logical :: lerr_D0,errorwriteflag
 
    character(len=*),parameter :: fmt1 = "(A7,'dcmplx(',d25.18,' , ',d25.18,' )')"
    character(len=*),parameter :: fmt10 = "(A17,'(',d25.18,' , ',d25.18,' )')"
 
#ifdef CritPointsCOLI
    integer, parameter :: MaxCritPointD=50
#else
    integer, parameter :: MaxCritPointD=0
#endif
    integer, save :: CritPointCntD
    integer ncount
 
    data critpointcntd /0/
 
#ifdef Dredtest
    write(*,*) 'CalcDred in',rmax,id,acc_req_d
    write(*,*) 'CalcDred acc_req',acc_req_d,reqacc_coli
    write(*,*) 'CalcDred in',p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
#endif
 
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! calculate 3-point functions for rank < rmax 
    ! and corresponding accuracy estimates
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    ! allocation of C functions
    ! bad estimate of higher C coefficients leads to bad estimates for expansions -> not tried!
    ! do not involve estimate of C0 in extrapolations!    
    rmaxc = max(rmax-1,3)
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,0:3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,0:3))
 
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! caution: C_i in first call not properly defined!
    call calcc(c_i(:,:,:,0),cuv_i(:,:,:,0),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(0:rmaxc,0),cerr2_i(0:rmaxc,0))
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(0:rmaxc,1),cerr2_i(0:rmaxc,1))
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(0:rmaxc,2),cerr2_i(0:rmaxc,2))
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(0:rmaxc,3),cerr2_i(0:rmaxc,3))
 
#ifdef Dredtest
    write(*,*) 'CalcDred Cerr 0 =',cerr_i(0:rmaxc,0)
    write(*,*) 'CalcDred Cerr 1 =',cerr_i(0:rmaxc,1)
    write(*,*) 'CalcDred Cerr 2 =',cerr_i(0:rmaxc,2)
    write(*,*) 'CalcDred Cerr 3 =',cerr_i(0:rmaxc,3)
    if (abs(c_i(0,0,0,0)).ne.0d0) &
        write(*,*) 'CalcDred Cacc 0 =',cerr_i(0:rmaxc,0)/abs(c_i(0,0,0,0))
    if (abs(c_i(0,0,0,1)).ne.0d0) &
        write(*,*) 'CalcDred Cacc 1 =',cerr_i(0:rmaxc,1)/abs(c_i(0,0,0,1))
    if (abs(c_i(0,0,0,2)).ne.0d0) &
        write(*,*) 'CalcDred Cacc 2 =',cerr_i(0:rmaxc,2)/abs(c_i(0,0,0,2))
    if (abs(c_i(0,0,0,3)).ne.0d0) &
        write(*,*) 'CalcDred Cacc 3 =',cerr_i(0:rmaxc,3)/abs(c_i(0,0,0,3))
#endif
 
!   acc_C(0:rmaxC)=max((Cerr_i(0:rmaxC,0))/abs(C_i(0,0,0,0)),  & 
!                      (Cerr_i(0:rmaxC,1))/abs(C_i(0,0,0,1)),  & 
!                      (Cerr_i(0:rmaxC,2))/abs(C_i(0,0,0,2)),  & 
!                      (Cerr_i(0:rmaxC,3))/abs(C_i(0,0,0,3))) 
 
 
    do i=0,3
! changed 01.07.2015 to avoid bad estimates that excluded expansions
!      errfac(i)=max(Cerr_i(rmaxC,i)/Cerr_i(rmaxC-1,i),sqrt(Cerr_i(rmaxC,i)/Cerr_i(rmaxC-2,i)))
       errfac(i) = 1d0
      do r=rmaxc+1,rmax_c
        cerr_i(r,i)=cerr_i(r-1,i)*errfac(i)
      end do
    end do
 
    do r=0,rmax_c
      err_c(r)=maxval(cerr_i(r,0:3))
    end do
 
    err_c0=err_c(0)
 
#ifdef Dredtest
    write(*,*) 'CalcDred err_C0:',err_c0
    write(*,*) 'CalcDred Cerr 0 =',cerr_i(0:rmax_c,0)
    write(*,*) 'CalcDred Cerr 1 =',cerr_i(0:rmax_c,1)
    write(*,*) 'CalcDred Cerr 2 =',cerr_i(0:rmax_c,2)
    write(*,*) 'CalcDred Cerr 3 =',cerr_i(0:rmax_c,3)
    write(*,*) 'CalcDred Cerr   =', err_c(0:rmax_c)
#endif
 
    
 
 
 
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! choose reduction scheme
    ! by estimating expected errors
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    ! eliminate infinitesimal masses
    mm02 = elimminf2_coli(m02)
    mm12 = elimminf2_coli(m12)
    mm22 = elimminf2_coli(m22)
    mm32 = elimminf2_coli(m32)
    q10  = elimminf2_coli(p10)
    q21  = elimminf2_coli(p21)
    q32  = elimminf2_coli(p32)
    q30  = elimminf2_coli(p30)
    q31  = elimminf2_coli(p31)
    q20  = elimminf2_coli(p20)
 
    ! set mass scales
    q2max = max(abs(q10),abs(q21),abs(q32),abs(q30),abs(q31),abs(q20))
    m2max = max(abs(mm02),abs(mm12),abs(mm22),abs(mm32))
    m2scale = max(q2max,m2max)
 
    ! Gram and related stuff
!   q1q2 = (q10+q20-q21)/2D0
!   q1q3 = (q10+q30-q31)/2D0
!   q2q3 = (q20+q30-q32)/2D0
 
    z(1,1) = 2d0*q10
    z(2,1) = q10+q20-q21
    z(3,1) = q10+q30-q31
    z(1,2) = z(2,1)
    z(2,2) = 2d0*q20
    z(3,2) = q20+q30-q32
    z(1,3) = z(3,1)
    z(2,3) = z(3,2)
    z(3,3) = 2d0*q30
!    write(*,*) 'Zn ',Z
 
    maxz = maxval(abs(z))
 
    detz = chdet(3,z)
    if (detz.ne.0d0) then
      call chinv(3,z,zinv)
      zadj = zinv * detz
    else
!     Zadj(1,1) = 4d0*(q30*q20-q2q3*q2q3)
!     Zadj(2,1) = 4d0*(q1q3*q2q3-q30*q1q2)
!     Zadj(3,1) = 4d0*(q1q2*q2q3-q20*q1q3)
!     Zadj(1,2) = Zadj(2,1)
!     Zadj(2,2) = 4d0*(q10*q30-q1q3*q1q3)
!     Zadj(3,2) = 4d0*(q1q2*q1q3-q10*q2q3)
!     Zadj(1,3) = Zadj(3,1)
!     Zadj(2,3) = Zadj(3,2)
!     Zadj(3,3) = 4d0*(q10*q20-q1q2*q1q2)
 
      zadj(1,1) = (z(3,3)*z(2,2)-z(2,3)*z(2,3))
      zadj(2,1) = (z(1,3)*z(2,3)-z(3,3)*z(1,2))
      zadj(3,1) = (z(1,2)*z(2,3)-z(2,2)*z(1,3))
      zadj(1,2) = zadj(2,1)
      zadj(2,2) = (z(1,1)*z(3,3)-z(1,3)*z(1,3))
      zadj(3,2) = (z(1,2)*z(1,3)-z(1,1)*z(2,3))
      zadj(1,3) = zadj(3,1)
      zadj(2,3) = zadj(3,2)
      zadj(3,3) = (z(1,1)*z(2,2)-z(1,2)*z(1,2))
    endif
!    write(*,*) 'Zadjn ',Zadj
!    write(*,*) 'detZn ',detZ
 
#ifdef Dredtest
    zadjs(1) = q20*(q31+q32-q21) + q31*(q32-q30)   &
         + q30*(q32+q21) - q32*(q32+2d0*q10-q21)
    write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)+zadj(1,3)
    zadjs(3) = q20*(q21+q31-q32) + (q31-q21)*(q21-q10)  &
         - 2d0*q30*q21 + q32*(q10+q21)
    write(*,*) 'Zadjs(3) ',zadjs(3), zadj(3,1)+zadj(3,2)+zadj(3,3)
#endif
 
    zadjs(1) = q32*(-2d0*q10 + q20+q30+q31+q21 - q32) &
         + (q21-q31)*(q30-q20)
    zadjs(2) = q31*(-2d0*q20 + q10+q30+q32+q21 - q31) &
         + (q21-q32)*(q30-q10)
    zadjs(3) = q21*(-2d0*q30 + q10+q20+q32+q31 - q21) &
         + (q31-q32)*(q20-q10)
 
#ifdef Dredtest
    write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)+zadj(1,3)
    write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)+zadj(2,3)
    write(*,*) 'Zadjs(3) ',zadjs(3), zadj(3,1)+zadj(3,2)+zadj(3,3)
#endif
 
    detzmzadjf = -2*q21*q31*q32 + q30*q21*(-q21 + q31 + q32) & 
         + q20*q31*(q21 - q31 + q32) + q10*q32*(q21 + q31 - q32)
         
    adetz = abs(detz)
    maxzadj = max(abs(zadj(1,1)),abs(zadj(2,1)),abs(zadj(3,1)),  &
                  abs(zadj(2,2)),abs(zadj(3,2)),abs(zadj(3,3)))
 
    f(1) = q10+mm02-mm12
    f(2) = q20+mm02-mm22
    f(3) = q30+mm02-mm32
    fmax = max(abs(f(1)),abs(f(2)),abs(f(3)))
      
    mx(0,0) = 2d0*mm02
    mx(1,0) = q10 - mm12 + mm02
    mx(2,0) = q20 - mm22 + mm02
    mx(3,0) = q30 - mm32 + mm02
    mx(0,1) = mx(1,0)
    mx(0,2) = mx(2,0)
    mx(0,3) = mx(3,0)
    mx(1:3,1:3) = z(1:3,1:3)
 
    detx = chdet(4,mx)
 
    if (detx.ne.0d0.and.maxz.ne.0d0) then
      call chinv(4,mx,mxinv)
      xadj = mxinv * detx
 
      zadjf(1:3) = -xadj(0,1:3)
    
      zadj2ff(1:3,1:3) = xadj(1:3,1:3) - 2d0*mm02*zadj(1:3,1:3)
    else
      zadjf(1) = zadj(1,1)*f(1)+zadj(2,1)*f(2)+zadj(3,1)*f(3)
      zadjf(2) = zadj(1,2)*f(1)+zadj(2,2)*f(2)+zadj(3,2)*f(3)
      zadjf(3) = zadj(1,3)*f(1)+zadj(2,3)*f(2)+zadj(3,3)*f(3)
 
      zadj2ff(1,1) = -f(2)*f(2)*z(3,3) - f(3)*f(3)*z(2,2)  &
                   + 2*f(2)*f(3)*z(3,2)
      zadj2ff(2,1) = f(2)*f(1)*z(3,3) - f(3)*f(1)*z(2,3)  &
                   - f(2)*f(3)*z(1,3) + f(3)*f(3)*z(1,2) 
      zadj2ff(3,1) = -f(2)*f(1)*z(3,2) + f(3)*f(1)*z(2,2)  &
                   + f(2)*f(2)*z(3,1) - f(3)*f(2)*z(2,1)
      zadj2ff(1,2) = zadj2ff(2,1)
      zadj2ff(2,2) = -f(1)*f(1)*z(3,3) - f(3)*f(3)*z(1,1)  &
                   + 2*f(1)*f(3)*z(1,3)
      zadj2ff(3,2) = f(1)*f(1)*z(2,3) - f(1)*f(2)*z(1,3)  &
                   - f(3)*f(1)*z(2,1) + f(3)*f(2)*z(1,1)
      zadj2ff(1,3) = zadj2ff(3,1)
      zadj2ff(2,3) = zadj2ff(3,2) 
      zadj2ff(3,3) = -f(1)*f(1)*z(2,2) - f(2)*f(2)*z(1,1)  &
                   + 2*f(1)*f(2)*z(2,1)
 
      xadj(1,1) = 2d0*mm02*zadj(1,1) + zadj2ff(1,1)
      xadj(2,1) = 2d0*mm02*zadj(2,1) + zadj2ff(2,1)
      xadj(3,1) = 2d0*mm02*zadj(3,1) + zadj2ff(3,1)
      xadj(1,2) = xadj(2,1)
      xadj(2,2) = 2d0*mm02*zadj(2,2) + zadj2ff(2,2)
      xadj(3,2) = 2d0*mm02*zadj(3,2) + zadj2ff(3,2)
      xadj(1,3) = xadj(3,1)
      xadj(2,3) = xadj(3,2)
      xadj(3,3) = 2d0*mm02*zadj(3,3) + zadj2ff(3,3)
    endif
 
 
!   write(*,*) 'Xadjn ',Xadj
!   write(*,*) 'detXn ',detX
!   write(*,*) 'Zadjfn',Zadjf
!   write(*,*) 'Zadj2ffn',Zadj2ff
 
    maxzadj2ff = max(abs(zadj2ff(1,1)),abs(zadj2ff(2,1)),abs(zadj2ff(3,1)),  &
                     abs(zadj2ff(2,2)),abs(zadj2ff(3,2)),abs(zadj2ff(3,3)))
    maxzadjf = max(abs(zadjf(1)),abs(zadjf(2)),abs(zadjf(3)))
    maxzadjfd = max(maxzadjf,adetz)
    zadjff = zadjf(1)*f(1)+zadjf(2)*f(2)+zadjf(3)*f(3)
    azadjff = abs(zadjff)
    adetx = abs(2d0*mm02*detz-zadjf(1)*f(1)-zadjf(2)*f(2)-zadjf(3)*f(3))
    
!    write(*,*) 'fs', f(1), f(2), f(3)
!    write(*,*) aZadjff, maxZadjf*fmax
 
    maxxadj = max(abs(xadj(1,1)),abs(xadj(2,1)),abs(xadj(3,1)),  &
                  abs(xadj(2,2)),abs(xadj(3,2)),abs(xadj(3,3)))
 
!    write(*,*) 'CalcDred acc_inf=',acc_inf
!    write(*,*) 'CalcDred Derr=',Derr
 
!    write(*,*) 'CalcDred adetX ',adetX,maxZadjf,maxXadj,adetZ
!    write(*,*) 'CalcDred Zadj2ff',maxZadj2ff
!    write(*,*) 'CalcDred maxZadj',maxZadj
!    write(*,*) 'CalcDred Zadjf',Zadjf
!    write(*,*) 'CalcDred f',f
!    write(*,*) 'CalcDred Zadjff',Zadjff
 
    zadj2f = 0d0
    zadj2f(1,2,1) =  z(3,2)*f(3) - z(3,3)*f(2)
    zadj2f(1,3,1) = -z(2,2)*f(3) + z(2,3)*f(2)
    zadj2f(2,3,1) =  z(1,2)*f(3) - z(1,3)*f(2)
    zadj2f(1,2,2) = -z(3,1)*f(3) + z(3,3)*f(1)
    zadj2f(1,3,2) =  z(2,1)*f(3) - z(2,3)*f(1)
    zadj2f(2,3,2) = -z(1,1)*f(3) + z(1,3)*f(1)
    zadj2f(1,2,3) =  z(3,1)*f(2) - z(3,2)*f(1)
    zadj2f(1,3,3) = -z(2,1)*f(2) + z(2,2)*f(1)
    zadj2f(2,3,3) =  z(1,1)*f(2) - z(1,2)*f(1)
    zadj2f(2,1,1) =  -zadj2f(1,2,1)
    zadj2f(3,1,1) =  -zadj2f(1,3,1)
    zadj2f(3,2,1) =  -zadj2f(2,3,1)
    zadj2f(2,1,2) =  -zadj2f(1,2,2)
    zadj2f(3,1,2) =  -zadj2f(1,3,2)
    zadj2f(3,2,2) =  -zadj2f(2,3,2)
    zadj2f(2,1,3) =  -zadj2f(1,2,3)
    zadj2f(3,1,3) =  -zadj2f(1,3,3)
    zadj2f(3,2,3) =  -zadj2f(2,3,3)
 
    maxzadj2f=maxval(abs(zadj2f))
 
!    write(*,*) 'CalcDred Zadj2f',maxZadj2f
 
!    write(*,*) 'CalcDred m2scale',m2scale
 
    !   1/sqrt(adetX) seems to describe scale of D0 well
    !   scale ratio between D0 and C0's better described by maximal scale (missing in at least one C0 function) 
    !    m2scale = sqrt(adetX)/q2max
 
!    write(*,*) 'CalcDred m2scale',m2scale
!    write(*,*) 'CalcDred 1/sX  ',1/sqrt(adetX)
 
!    Zadj2ff = Zadj2f(:,1,:)*f(1)+Zadj2f(:,2,:)*f(2)+Zadj2f(:,3,:)*f(3)
 
!    write(*,*) 'CalcDred Zadj2ff',Zadj2ff
 
 
    ! quantities for modified error estimates
    ! momentum weights
!    do i = 1,3
!      pweight(i) = max(abs(Z(i,1))/maxval(abs(Z(1:3,1))),  &
!          abs(Z(i,2))/maxval(abs(Z(1:3,2))),               & 
!          abs(Z(i,3))/maxval(abs(Z(1:3,3))))
!    end do
 
!    wmaxZadj = max(pweight(1)*abs(Zadj(1,1)), &
!        pweight(1)*abs(Zadj(1,2)),pweight(1)*abs(Zadj(1,3)),  &
!        pweight(2)*abs(Zadj(2,1)),pweight(3)*abs(Zadj(3,1)),  &
!        pweight(2)*abs(Zadj(2,3)),pweight(3)*abs(Zadj(3,2)),  &
!        pweight(2)*abs(Zadj(2,2)),pweight(3)*abs(Zadj(3,3)))
 
!    wmaxZadjf = max(pweight(1)*abs(Zadjf(1)),pweight(2)*abs(Zadjf(2)),  &
!        pweight(3)*abs(Zadjf(3)))
 
!    wmaxXadj = max(pweight(1)*abs(Xadj(1,1)),   &
!        pweight(1)*abs(Xadj(1,2)),pweight(1)*abs(Xadj(1,3)),  &
!        pweight(2)*abs(Xadj(2,1)),pweight(2)*abs(Xadj(2,3)),  &
!        pweight(3)*abs(Xadj(3,1)),pweight(3)*abs(Xadj(3,2)),  &
!        pweight(2)*abs(Xadj(2,2)),pweight(3)*abs(Xadj(3,3)))
!    wmaxXadj = max(2d0*abs(mm02)*sqrt(adetZ*maxZadj/maxZ),maxZadj2ff*maxZadjf/(maxZadj*fmax))
 
!    write(*,*) 'CalcDred pweight',pweight(1:3)
!    write(*,*) 'CalcDred wmaxZadj',maxZadj,wmaxZadj
!    write(*,*) 'CalcDred wmaxZadjf',maxZadjf,wmaxZadjf
!    write(*,*) 'CalcDred wmaxZadjf',maxXadj,wmaxXadj
 
    ! rough estimate for D0 to set the scale, to be improved
     dscale2 = max(abs(p10*p32),abs(p21*p30),abs(p20*p31),abs(m02*m02), \
              abs(m12*m12),abs(m22*m22),abs(m32*m32))
#ifdef USED0
    d0est = max(abs(d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)),  \
             1d0/dscale2)
    lerr_d0 = .true.
#else
! changed 09.09.16
     if(dscale2.ne.0d0) then 
       d0est = 1d0/dscale2
     else
       d0est = 1d0
     end if
!    if (adetX.ne.0d0) then
!      D0est = 1d0/sqrt(adetX)
!    elseif (m2max.ne.0d0) then
!      D0est = 1d0/m2max**2
!    else if (maxZ.ne.0d0) then
!      D0est = 1d0/maxZ**2
!    else
!      D0est = 1d0 
!    endif
    lerr_d0 = .false.
#endif
    err_inf = acc_inf*d0est
    dtyp = d0est
 
#ifdef Dredtest
    if (adetx.ne.0d0) write(*,*) 'D0est',1d0/sqrt(adetx)
    if (m2max.ne.0d0) write(*,*) 'D0est',1d0/m2max**2
    if (maxz.ne.0d0) write(*,*) 'D0est',1d0/maxz**2
    write(*,*) 'D0est',d0est
#endif
 
    dcalc = 0
    drcalc = 0
    drmethod = 0
    derr1 = err_inf
    derr2 = err_inf
    derr  = err_inf
    acc_d = acc_inf
    dcount(0) = dcount(0)+1
 
    ! error estimate of D0
    if (adetx.ne.0d0) then
      err_d0 = acc_def_d0*max( d0est, 1d0/sqrt(adetx) )
    else
      err_d0 = acc_def_d0*d0est
    endif     
 
 
 
    err_req_d = acc_req_d * d0est
 
!   write(*,*) 'CalcDred err_req ',err_req_D,acc_req_D , D0est
 
    ! estimate accuracy of PV-reduction
!    if (adetZ.eq.0d0) then
!    if (adetZ.lt.dprec_cll*maxZ**3) then
    h_pv = real(undefined_d)
    w_pv = real(undefined_d)
    v_pv = real(undefined_d)
    z_pv = real(undefined_d)
 
!    if (adetZ.lt.dprec_cll*maxZadjf.or.adetZ.eq.0d0) then
!   14.07.2017
    if (adetz.lt.dprec_cll*maxzadjf.or.adetz.lt.dprec_cll*maxz**3.or.adetz.eq.0d0) then
      use_pv = .false.
      err_pv = err_inf
    else
      use_pv = .true.
      if (rmax.eq.0) then
        err_pv(0) = err_d0
      else 
#ifdef PVEST2
        h_pv = sqrt(adetz/(maxz*maxzadj))
        w_pv = max((maxzadjf*h_pv/adetz)**2, abs(mm02)*maxzadj*h_pv/adetz, azadjff*maxzadj*(h_pv/adetz)**2)
        v_pv = maxzadjf*h_pv/adetz
        z_pv = maxzadj*h_pv/adetz
#else
        w_pv = max((maxzadjf/adetz)**2, abs(mm02)*maxzadj/adetz, azadjff*maxzadj/adetz**2)
        v_pv = maxzadjf/adetz
        z_pv = maxzadj/adetz
#endif
        if (mod(rmax,2).eq.1) then
          err_pv(rmax) = max( w_pv**((rmax-1)/2) * v_pv * err_d0,  &
                        w_pv**((rmax-1)/2) * z_pv * err_c0, z_pv * err_c(rmax-1) )
#ifdef Dredtest
          write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,z_pv,err_d0,err_c0,rmax
 
          write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax-1)/2) * v_pv * err_d0,  &
                        w_pv**((rmax-1)/2) * z_pv * err_c0, z_pv * err_c(rmax-1)
#endif
        else
          err_pv(rmax) = max( w_pv**(rmax/2) * err_d0,  &
                        w_pv**(rmax/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(rmax-1) )
#ifdef Dredtest
         write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,z_pv
         write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax)/2) * err_d0,  &
                       w_pv**(rmax/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(rmax-1)
         write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax)/2),err_d0,  &
                       w_pv**(rmax/2-1) * v_pv,err_c0, z_pv,err_c(rmax-1)
#endif
        end if
      end if
    end if
 
 
    ! estimate accuracy of alternative PV-reduction
!    if ((adetZ.eq.0).or.(adetX.eq.0)) then
!    if ((adetZ.lt.dprec_cll*maxZ**3).or.(adetX.lt.dprec_cll*maxval(abs(mx))**4)) then
    w_pv2 = real(undefined_d)
    h_pv2 = real(undefined_d)
    hw_pv2 = real(undefined_d)
    v_pv2 = real(undefined_d)
    z_pv2 = real(undefined_d)
 
!    if ((adetZ.lt.dprec_cll*maxZadjf).or.(adetX.lt.dprec_cll*maxval(abs(mx))*adetZ).or.adetZ.eq.0d0.or.adetX.eq.0d0) then
!    14.07.2017   
    if ((adetz.lt.dprec_cll*maxzadjf).or.(adetx.lt.dprec_cll*maxval(abs(mx))*adetz).or.  &
         (adetz.lt.dprec_cll*maxz**3).or.adetz.eq.0d0.or.adetx.eq.0d0) then
      use_pv2 = .false.
      err_pv2 = err_inf
    else
      use_pv2 = .true.
      if (rmax.eq.0) then
        err_pv2(0) = err_d0
      else
        w_pv2 = maxzadjf/adetz
#ifdef PVEST2
        h_pv2 = sqrt(adetz/(maxz*maxzadj))
        hw_pv2 =  w_pv2*h_pv2
#else
        hw_pv2 =  w_pv2 
#endif
        v_pv2 = maxxadj/adetz
        z_pv2 = adetz/adetx 
 
#ifdef Dredtest
        write(*,*) 'CalcDred w_pv2: ',w_pv2,v_pv2,z_pv2
        write(*,*) 'CalcDred w_pv2: ',mod(rmax,2).eq.1
#endif
 
        if (mod(rmax,2).eq.1) then
! change 21.10.15 for PVEST2
!          err_pv2(rmax) = max( err_D0 * max(w_pv2**rmax,    &
!               w_pv2*v_pv2**((rmax-1)/2) ),  &
!               err_C0 * z_pv2*max(w_pv2**(rmax+1), &
!                                  w_pv2*v_pv2**((rmax-1)/2), & 
!                                  v_pv2**((rmax+1)/2)),  &
!               err_C(rmax-1) * z_pv2 * max(w_pv2,w_pv2**2,v_pv2) )
          err_pv2(rmax) = max( err_d0 * max(hw_pv2**rmax,    &
                               hw_pv2*v_pv2**((rmax-1)/2) ),  &
               err_c0 * z_pv2*max(w_pv2*hw_pv2**(rmax), &
                                  max(1d0,w_pv2)*hw_pv2*v_pv2**((rmax-1)/2), & 
                                  v_pv2**((rmax+1)/2)),  &
               err_c(rmax-1) * z_pv2 * max(hw_pv2,hw_pv2*w_pv2,v_pv2)  )
 
#ifdef Dredtest
        write(*,*) 'CalcDred err_pv2: ',   &
        err_pv2(rmax) ,     err_d0,err_d0*w_pv2**rmax,err_d0*v_pv2**((rmax-1)/2),    &
                                     err_d0*w_pv2*v_pv2**((rmax-1)/2)
       write(*,*) 'CalcDred err_pv2: '  &
       ,err_pv2(rmax) ,     err_d0 * max(1d0,w_pv2**rmax,v_pv2**((rmax-1)/2),    &
                                   w_pv2*v_pv2**((rmax-1)/2) )  &
                     , err_c0 * z_pv2*max(w_pv2**(rmax+1), &
                               w_pv2*v_pv2**((rmax-1)/2), & 
                               v_pv2**((rmax+1)/2))  &
                    ,  err_c(rmax-1) * max(z_pv2*w_pv2, &
                               z_pv2*w_pv2**2,z_pv2*v_pv2) 
        write(*,*) 'CalcDred err_pv2: ',   &
                       err_c0 * z_pv2*w_pv2**(rmax+1), &
                        err_c0 * z_pv2* w_pv2*v_pv2**((rmax-1)/2), & 
                       err_c0 * z_pv2*  v_pv2**((rmax+1)/2)    ,  &
                       err_c0
#endif
 
        else
! change 21.10.15 for PVEST2
!          err_pv2(rmax) = max( err_D0 * max(w_pv2**rmax,v_pv2**(rmax/2)),  & 
!                err_C0 * z_pv2 * max(w_pv2**(rmax+1),  &
!                         v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
!                err_C(rmax-1) * z_pv2 * max(w_pv2, w_pv2**2, v_pv2) )
          err_pv2(rmax) = max( err_d0 * max(hw_pv2**rmax,v_pv2**(rmax/2)),  & 
                err_c0 * z_pv2 * max(w_pv2*hw_pv2**(rmax),  &
                         v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
                err_c(rmax-1) * z_pv2 * max(hw_pv2,hw_pv2*w_pv2, v_pv2) )
                                  
 
!         write(*,*) 'CalcDred err_pv2: ',   &
!         err_pv2(rmax) , err_D0 * max(1d0,w_pv2**rmax,v_pv2**(rmax/2)),  &
!                        err_C0 * z_pv2 * max(w_pv2**(rmax+1),  &
!                                 v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
!                        err_C(rmax-1) * max(1d0,z_pv2*w_pv2,  &
!                                 z_pv2*w_pv2**2,z_pv2*v_pv2)
!         write(*,*) 'CalcDred err_pv2: ',   &
!                        err_C0 * z_pv2 * w_pv2**(rmax+1),  &
!                        err_C0 * z_pv2 *          v_pv2**(rmax/2), &
!                        err_C0 * z_pv2 * w_pv2*v_pv2**(rmax/2), &
!                        err_C0
        end if
      end if
    end if 
 
    ! scale estimates down to allow trying other methods
    err_pv(rmax)  = err_pv(rmax)/impest_d
    err_pv2(rmax) = err_pv2(rmax)/impest_d     
 
!    write(*,*) 'CalcDred err_pv: ',err_pv, w_pv**((rmax-1)/2) * v_pv * err_D0,  &
!                        w_pv**((rmax-1)/2) * z_pv * err_C0, z_pv * err_C(rmax-1)
 
#ifdef Dredtest
    write(*,*) 'CalcDred: err_pv',err_pv(rmax),err_pv2(rmax),err_req_d
    write(*,*) 'CalcDred: acc_pv',err_pv(rmax)/d0est,err_pv2(rmax)/d0est,acc_req_d
#endif
 
#ifdef TEST
  use_pv = .false.
  use_pv2 = .false.
  use_pv = .true.
!  use_pv2 = .true.
  err_pv2(rmax) = 1d30
!  err_pv(rmax) = 1d30
#endif
 
 
!    Dtyp = real(undefined_D)
    dtyp = d0est
#ifdef ALWAYSPV
    if(use_pv.or.use_pv2) then
#else
    if (min(err_pv(rmax),err_pv2(rmax)).le.err_req_d) then
#endif
      if (err_pv(rmax).le.err_pv2(rmax)) then
 
#ifdef Dredtest
        write(*,*) 'CalcDred: call Dpv 1 ',rmax,id,err_pv(rmax)
#endif
 
        ! use PV-reduction if appropriate
        call calcdpv1(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
#ifdef PVEST2
        derr = derr2
#else
        derr = derr1
#endif
 
        dcount(1) = dcount(1)+1
        drcalc(0:rmax) = drcalc(0:rmax)+1
        dcalc = dcalc+1
        drmethod(0:rmax) = 1
!        err_D = err_pv
 
#ifdef Dredtest
        checkest=derr(rmax)/err_pv(rmax)
        if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
          write(*,*) 'CalcDred: estimate err_pv imprecise',err_pv(rmax),derr(rmax)
        end if
#endif
 
        err_pv=derr
 
      else
 
#ifdef Dredtest
        write(*,*) 'CalcDred: call Dpv2 1',rmax,id,err_pv2(rmax)
#endif
 
        ! use alternative PV-reduction if appropriate
        call calcdpv2(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
#ifdef PVEST2
        derr = derr2
#else
        derr = derr1
#endif
        dcount(2) = dcount(2)+1
        drcalc(0:rmax)=drcalc(0:rmax)+2
        dcalc = dcalc+2
        drmethod(0:rmax)=2
 
#ifdef Dredtest
        checkest=derr(rmax)/err_pv2(rmax)
        if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
          write(*,*) 'CalcDred: estimate err_pv2 imprecise',err_pv2(rmax),derr(rmax)
        end if
#endif
        err_pv2=derr
 
      end if
 
#ifndef USED0
      ! refine error estimate for D0
!      D0est =  abs(D(0,0,0,0))
      err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
      err_req_d = acc_req_d * abs(d(0,0,0,0))
      lerr_d0 = .true.
#endif
 
      if (rmax.ge.1) then
        dtyp =  max(abs(d(0,0,0,0)),        &
               abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
      else
        dtyp =  abs(d(0,0,0,0))
      end if
      if(dtyp.eq.0d0) dtyp = d0est
      err_req_d = acc_req_d * dtyp
 
 
#ifdef Dredtest
      write(*,*) 'CalcDred Derr1 after PV = ',derr1
!      write(*,*) 'CalcDred Dacc1 after PV = ',Derr1/abs(D(0,0,0,0))
      write(*,*) 'CalcDred Dacc1 after PV = ',derr1/dtyp
      write(*,*) 'CalcDred err1_D',derr1(rmax)
      write(*,*) 'CalcDred Derr2 after PV = ',derr2
!      write(*,*) 'CalcDred Dacc2 after PV = ',Derr2/abs(D(0,0,0,0))
      write(*,*) 'CalcDred Dacc2 after PV = ',derr2/dtyp
      write(*,*) 'CalcDred err2_D',derr2(rmax)
#endif
 
!  Derr = Derr2 might lead to imprecise results
      if (derr1(rmax).lt.err_req_d) then
        dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
        return
      end if
 
    else   !  added 14.07.2017
      d = 0d0
      duv = 0d0
      derr1 = err_inf
      derr2 = err_inf
    end if
 
#ifdef Dredtest
!   return
#endif
 
!    allocate(D_alt(0:rmax,0:rmax,0:rmax,0:rmax))
!    allocate(Duv_alt(0:rmax,0:rmax,0:rmax,0:rmax))
!    allocate(Derr1_alt(0:rmax))
!    allocate(Derr2_alt(0:rmax))
!    allocate(Drmethod_alt(0:rmax))
 
    ! choose most promising expansion scheme
    ! Gram expansion    
!    if (maxZadjf.ne.0d0) then
    if (maxzadjf.gt.m2scale**3*dprec_cll) then   !  10.07.2017
      x_g = adetz/maxzadjf
!      u_g = max(1d0,maxZadj2ff/maxZadjf/4d0,abs(mm02)*maxZadj/maxZadjf/4d0)
! 03.03.15   large P counts!
!      u_g = max(1d0,maxZadj2ff/maxZadjf/2d0,abs(mm02)*maxZadj/maxZadjf/2d0)
! 24.04.15  term appear only combined
      u_g = max(1d0,maxxadj/maxzadjf/2d0)
      fac_g = x_g*u_g
      err_g = err_inf
      g = -1
      if (fac_g.ge.1) then
        use_g = .false.
        err_g_exp = err_inf
        err_g_c = err_c(rmax)         ! dummy
        err_g_cr = real(undefined_d)
        z_g = real(undefined_d)
      else
        use_g = .true.
!       z_g = max(1d0,m2scale*maxZadj/maxZadjf)
        z_g = maxzadj/maxzadjf
        err_g_cr = max( err_c(rmax), err_c0 * u_g**rmax ) * z_g 
        err_g_c = err_g_cr
        err_g_exp = u_g**(rmax-1) * dtyp
      end if
    else
      use_g = .false.
      err_g = err_inf
      g = -1
      err_g_exp = err_inf
      err_g_c = err_c(rmax)         ! dummy
      u_g = real(undefined_d)
      z_g = real(undefined_d)
      err_g_cr = real(undefined_d)
    endif
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after Gram pars',use_g,fac_g,x_g,u_g,z_g,err_g_cr,err_c(rmax),err_c0,err_g_exp
!    write(*,*) 'CalcDred: after Gram pars',adetZ,maxZadjf,maxXadj,maxZ
    write(*,*) 'CalcDred: after Gram pars',err_c(rmax), err_c0 * u_g**rmax 
#endif
 
#ifdef USEGM
    ! modified Gram expansion    
!   if (aZadjff.ne.0d0) then
    if (azadjff.gt.m2scale**4*dprec_cll) then   !  10.07.2017
      x_gm = adetz*fmax/azadjff
!      u_gm = max(1d0,maxZadj2ff/maxZadjf/4d0,abs(mm02)*maxZadj/maxZadjf/4d0)
! 03.03.15   large P counts!
!      u_gm = max(1d0,maxZadj2ff/maxZadjf/2d0,abs(mm02)*maxZadj/maxZadjf/2d0)
! 24.04.15  term appear only combined
      u_gm = max(1d0,maxxadj/maxzadjf/2d0)
      fac_gm = x_gm*u_gm
      err_gm = err_inf
      gm = -1
      if (fac_gm.ge.1) then
        use_gm = .false.
        err_gm_exp = err_inf
        err_gm_c = err_c(rmax)         ! dummy
      else
        use_gm = .true.
!       z_gm = max(1d0,m2scale*maxZadj/maxZadjf)
        z_gm = maxzadjf/azadjff
        err_gm_cr = max( err_c(rmax), err_c0 * u_gm**rmax ) * z_gm 
        err_gm_c = err_gm_cr
        err_gm_exp = u_gm**(rmax-1) * dtyp
      end if
    else
      use_gm = .false.
      err_gm = err_inf
      gm = -1
      err_gm_exp = err_inf
      err_gm_c = err_c(rmax)         ! dummy
    endif
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after mod Gram pars',use_gm,fac_gm,x_gm,u_gm,z_gm,err_gm_cr,err_c(rmax),err_c0,err_gm_exp
!    write(*,*) 'CalcDred: after mod Gram pars',1d0,maxZadj2ff/maxZadjf,abs(mm02)*maxZadj/maxZadjf
    write(*,*) 'CalcDred: after mod Gram pars',err_c(rmax), err_c0 * u_gm**rmax 
    write(*,*) 'CalcDred: after mod Gram pars',  adetz,fmax,azadjff
#endif
 
#else
      use_gm = .false.
      err_gm = err_inf
      gm = -1 
      err_gm_exp = err_inf
      err_gm_c = err_c(rmax)         ! dummy
#endif
 
    ! Gram-Cayley expansion
!    if (maxXadj.ne.0d0.and.maxZadj.ne.0) then
    if (maxxadj.gt.m2scale**3*dprec_cll.and.maxzadj.gt.m2scale*dprec_cll) then   !  10.07.2017
      x_gy = maxzadjf/maxxadj
      y_gy = adetz/maxxadj
      v_gy = maxzadj2f/maxzadj
      v1_gy = max(1d0,v_gy)
      fac_gy = max(x_gy,y_gy)*v1_gy
      err_gy = err_inf
      gy = -1
      if (fac_gy.ge.1) then
        use_gy = .false.
        err_gy_exp = err_inf
        err_gy_c = err_c(rmax+1)         ! dummy
        err_gy_cr = real(undefined_d)
        b_gy = real(undefined_d)
      else
        use_gy = .true.
!       b_gy = max(1d0,m2scale*maxZadj/maxXadj)
        b_gy = maxzadj/maxxadj
        err_gy_cr =  max( err_c(rmax) * v1_gy, err_c(rmax+1) ) 
        err_gy_c = err_gy_cr * b_gy
        err_gy_exp = 1d0 * dtyp
      end if
    else
      use_gy = .false.
      err_gy = err_inf
      gy = -1
      err_gy_exp = err_inf
      err_gy_c = err_c(rmax+1)         ! dummy
      v1_gy = real(undefined_d)
      b_gy = real(undefined_d)
      err_gy_cr = real(undefined_d)
    endif
 
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after GramCay pars',use_gy,fac_gy,x_gy,y_gy,v_gy,b_gy,err_gy_cr,err_gy_exp
    if (use_gy) then
      write(*,*)  'CalcDred: after GramCay pars',maxxadj/maxzadj,1/v_gy,1/v_gy*maxxadj/maxzadj,1/v_gy*maxxadj/maxzadj*x_gy
    end if
#endif
 
    ! expansion in small momenta
!    if (fmax.ne.0d0) then
    if (fmax.gt.m2scale*dprec_cll) then   !  10.07.2017
      w_gp = maxz/fmax                        ! was q2max
      v_gp = abs(mm02/fmax)
      v1_gp = max(1d0,v_gp)
      fac_gp = w_gp*v1_gp
      err_gp = err_inf
      gp = -1
      if (fac_gp.ge.1d0) then
        use_gp = .false.
        err_gp_exp = err_inf
        err_gp_c = err_c(rmax)  ! dummy
        err_gp_cr = real(undefined_d)
        z_gp = real(undefined_d)
      else
        use_gp = .true.
!       z_gp = max(1d0,m2scale/fmax)
        z_gp = 1d0/fmax
        err_gp_cr = max(err_c0 * v_gp**rmax , err_c(rmax)) *  z_gp
        err_gp_c = err_gp_cr
        err_gp_exp = v1_gp**(rmax-1) * dtyp
      end if
    else
      use_gp = .false.
      err_gp = err_inf
      gp = -1
      err_gp_exp = err_inf
      err_gp_c = err_c(rmax)  ! dummy
      v1_gp = real(undefined_d)
      v_gp = real(undefined_d)
      z_gp = real(undefined_d)
      err_gp_cr = real(undefined_d)
    endif
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after Mom pars',use_gp,fac_gp,w_gp,v_gp,z_gp,err_gp_cr,err_gp_exp
#endif
 
    ! reversed Gram expansion
!    if (maxZadjf.ne.0d0.and.maxZadj2f.ne.0d0) then
    if (maxzadjf.gt.m2scale**3*dprec_cll.and.maxzadj2f.gt.m2scale**2*dprec_cll) then   !  10.07.2017
      x_gr = adetz/maxzadjf
      y_gr = maxzadj/maxzadj2f              ! c*y    c=2
      y1_gr = max(1d0,y_gr)
      a_gr = maxzadj/maxzadjf
      fac_gr = max(x_gr,y_gr)
      err_gr = err_inf
      gr = -1
      if (fac_gr.ge.1.or.2*rmax.gt.rmax_c) then
        use_gr = .false.
        err_gr_exp = err_inf
        err_gr_c = err_c(rmax)   ! dummy
        err_gr_cr = real(undefined_d)
      else
        use_gr = .true.
        err_gr_cr = err_c(rmax) 
        err_gr_c = err_gr_cr * a_gr
        err_gr_exp = y1_gr * dtyp
      end if
    else
      use_gr = .false.
      err_gr = err_inf
      gr = -1
      err_gr_exp = err_inf
      err_gr_c = err_c(rmax)   ! dummy
      a_gr = real(undefined_d)
      y_gr = real(undefined_d)
      y1_gr = real(undefined_d)
      err_gr_cr = real(undefined_d)
    endif
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after revGram pars',use_gr,fac_gr,x_gr,y_gr,y1_gr,a_gr,err_gr_cr,err_c(rmax),err_c0,err_gr_exp
    write(*,*) 'CalcDred: after revGram pars',err_gr_c,dtyp
#endif
 
    ! expansion in small momenta and f's
!  estimates to be confirmed 16.08.17, r dependence may be different
!  since D_mni... is needed in contrast to Dgy expansion
    if (abs(m02).gt.m2scale*dprec_cll) then 
      x_gpf = fmax/abs(m02)
      y_gpf = maxz/abs(m02)
      v_gpf = 0d0
      v1_gpf = max(1d0,v_gpf)
      fac_gpf = max(x_gpf,y_gpf)
      err_gpf = err_inf
      gpf = -1
      if (fac_gpf.ge.1) then
        use_gpf = .false.
        err_gpf_exp = err_inf
        err_gpf_c = err_c(rmax+1)         ! dummy
        err_gpf_cr = real(undefined_d)
        b_gpf = real(undefined_d)
      else
        use_gpf = .true.
        b_gpf = 1d0/abs(m02)
        err_gpf_cr =  max( err_c(rmax), err_c(rmax+1) ) 
        err_gpf_c = err_gpf_cr * b_gpf
        err_gpf_exp = 1d0 * dtyp
      end if
    else
      use_gpf = .false.
      err_gpf = err_inf
      gpf = -1
      err_gpf_exp = err_inf
      err_gpf_c = err_c(rmax+1)         ! dummy
      b_gpf = real(undefined_d)
      err_gpf_cr = real(undefined_d)
    endif
 
 
#ifdef Dredtest
    write(*,*) 'CalcDred: after pf pars',use_gpf,fac_gpf,x_gpf,y_gpf,v_gpf,b_gpf,err_gpf_cr,err_gpf_exp,err_gpf
    if (use_gpf) then
      write(*,*)  'CalcDred: after pf pars',maxxadj/maxzadj,1/v_gpf,1/v_gpf*maxxadj/maxzadj,1/v_gpf*maxxadj/maxzadj*x_gpf
    end if
#endif
 
! no method works
    if(use_pv.or.use_pv2.or.use_g.or.use_gy.or.use_gp.or.use_gr.or.use_gm.or.use_gpf.eqv..false.) then
      call seterrflag_coli(-6)
      call errout_coli('CalcDred',' no reduction method works',  &
         errorwriteflag)
!      write(nerrout_coli,'((a))')  '  no reduction method works'
      if (errorwriteflag) then
        write(nerrout_coli,fmt10) ' CalcDred: p10 = ',p10
        write(nerrout_coli,fmt10) ' CalcDred: p21 = ',p21
        write(nerrout_coli,fmt10) ' CalcDred: p32 = ',p32
        write(nerrout_coli,fmt10) ' CalcDred: p30 = ',p30
        write(nerrout_coli,fmt10) ' CalcDred: p20 = ',p20
        write(nerrout_coli,fmt10) ' CalcDred: p31 = ',p31
        write(nerrout_coli,fmt10) ' CalcDred: m02 = ',m02
        write(nerrout_coli,fmt10) ' CalcDred: m12 = ',m12
        write(nerrout_coli,fmt10) ' CalcDred: m22 = ',m22   
        write(nerrout_coli,fmt10) ' CalcDred: m32 = ',m32   
      end if 
      d = 0d0
      duv = 0d0
      derr1 = err_inf
      derr2 = err_inf
 
#ifdef Dredtest
      write(*,*) 'CalcDred: exit'
#endif
 
      return
    endif
 
#ifdef TEST
! switched off for testing
    use_g  = .false.
!    use_gy = .false.
    use_gp = .false.
    use_gr = .false.
!    use_gpf= .false.
!    use_g  = .true.
!    use_gy = .true.
!    use_gp = .true.
!    use_gr = .true.
#endif 
 
    iexp = 0
    do i=0,rmax_d-rmax
 
      if (use_g) then
        if (err_g_exp.gt.err_g_c) then
          g = i
          err_g_exp = err_g_exp*fac_g
          err_g_c = max(err_g_cr,err_c(rmax+g)*z_g*x_g**g)
          err_g(rmax) = max(err_g_exp,err_g_c)
          if(err_g(rmax).lt.err_req_d) then
            iexp = 1
            ! increase g by 2 to account for bad estimates
            g = min(max(g+2,3*g/2),rmax_d-rmax)
            exit
          end if
        end if
      end if
 
#ifdef Dredtest
!       write(*,*) 'CalcDred: it g',g, err_g_exp, err_g_C,  err_g(rmax) 
!       write(*,*) 'CalcDred: it g',err_g_Cr,err_C(rmax+g)*z_g*x_g**g
!       write(*,*) 'CalcDred: it g',err_C(rmax+g),z_g,x_g
#endif
 
#ifdef USEGM
      if (use_gm) then
        if (err_gm_exp.gt.err_gm_c) then
          gm = i
          err_gm_exp = err_gm_exp*fac_gm
          err_gm_c = max(err_gm_cr,err_c(rmax+gm)*z_gm*x_gm**gm)
          err_gm(rmax) = max(err_gm_exp,err_gm_c)
          if(err_gm(rmax).lt.err_req_d) then
            iexp = 7
            ! increase gm by 2 to account for bad estimates
            gm = min(max(gm+2,3*gm/2),rmax_d-rmax)
            exit
          end if
        end if
      end if
 
#ifdef Dredtest
!      write(*,*) 'CalcDred: it gm',gm, err_gm_exp, err_gm_C,  err_gm(rmax) 
!      write(*,*) 'CalcDred: it gm',err_gm_Cr,err_C(rmax+gm)*z_gm*x_gm**gm
!      write(*,*) 'CalcDred: it gm',err_C(rmax+gm),z_gm,x_gm
#endif
#endif
 
 
      if (mod(i,2).eq.1) then
 
#ifdef Dredtest
       write(*,*) 'CalcDred: it gy',use_gy,err_gy_exp,err_gy_c,err_gy(rmax),err_req_d
#endif
 
        if (use_gy) then
          if (err_gy_exp.gt.err_gy_c.and.err_gy(rmax).gt.err_req_d) then
            gy = i/2
            err_gy_exp = err_gy_exp*fac_gy
            err_gy_c = b_gy*max(err_gy_cr,                   &
                max(err_c(rmax+2*gy)*v1_gy,err_c(rmax+2*gy+1))*y_gy**gy,      &          
                max(err_c(rmax+gy)*v1_gy,err_c(rmax+gy+1))*(max(x_gy,v_gy*y_gy))**gy) 
            err_gy(rmax) = max(err_gy_exp,err_gy_c)
 
#ifdef Dredtest
         write(*,*) 'CalcDred i gy',i,gy,err_gy_exp,err_gy_c,err_gy(rmax) 
         write(*,*) 'CalcDred i ',err_gy_cr,                   &
               max(err_c(rmax+2*gy)*v1_gy,err_c(rmax+2*gy+1))*y_gy**gy,      &          
               max(err_c(rmax+gy)*v1_gy,err_c(rmax+gy+1))*(max(x_gy,v_gy*y_gy))**gy
          write(*,*) 'CalcDred i ', b_gy*err_c(rmax+2*gy)*v1_gy*y_gy**gy, &
                b_gy*err_c(rmax+2*gy+1)*y_gy**gy
          write(*,*) 'CalcDred i ', & 
                b_gy,err_c(rmax+2*gy+1),y_gy**gy 
          write(*,*) 'CalcDred i ', b_gy*x_gy**gy*err_c(rmax+gy)*v1_gy, &
                b_gy*err_c(rmax+gy+1)*x_gy**gy 
          write(*,*) 'CalcDred i ', & 
                b_gy,err_c(rmax+gy+1),x_gy**gy,x_gy,gy 
#endif
 
            if(err_gy(rmax).lt.err_req_d) then
              iexp = 2
              ! increase gy by 2 to account for bad estimates
              gy = min(max(gy+2,2*gy),(rmax_d-rmax)/2)
              exit
            end if
          end if
        end if
 
#ifdef Dredtest
!       write(*,*) 'CalcDred: it gy',i,gy, err_gy_exp,err_gy_C ,err_gy(rmax)
#endif
 
      end if
 
!      write(*,*) 'CalcDred bef gp it',err_gp(rmax),err_gp_C,err_req_D
 
      if (use_gp) then
        if (err_gp_exp.gt.err_gp_c.and.err_gp(rmax).gt.err_req_d) then
          gp = i
          err_gp_exp = err_gp_exp*fac_gp
          err_gp_c = max(err_c(rmax+gp)*z_gp*w_gp**gp,err_gp_cr)
          err_gp(rmax) = max(err_gp_exp,err_gp_c)
          if(err_gp(rmax).lt.err_req_d) then
            iexp = 3
            ! increase gp by 2 to account for bad estimates
            gp = min(max(gp+2,3*gp/2),rmax_d-rmax)
            exit
          end if
        end if
      end if
 
!        write(*,*) 'CalcDred: it gp',gp,err_gp, err_gp_C,  err_gp(rmax) 
 
      if (mod(i,2).eq.1.and.i.le.rmax_c-2*rmax) then
 
#ifdef Dredtest
!        write(*,*) 'CalcDred: it gr',use_gr,err_gr_exp,err_gr_C,err_gr(rmax),  &
!                                     err_req_D
#endif
 
        if (use_gr) then
          if (err_gr_exp.gt.err_gr_c.and.err_gr(rmax).gt.err_req_d) then
            gr = i/2
            err_gr_exp = err_gr_exp*fac_gr
            err_gr_c = a_gr*max(err_gr_cr,                   &
                max(err_c(rmax+gr),err_c(rmax+gr+1)*y_gr)*fac_gr**gr)
            err_gr(rmax) = max(err_gr_exp,err_gr_c)
#ifdef Dredtest
!          write(*,*) 'CalcDred: it gr',gr,err_gr(rmax),err_req_D
#endif
            if(err_gr(rmax).lt.err_req_d) then
              iexp = 4
              ! increase gy by 2 to account for bad estimates
! changed 25.07.14
!             gr = min(max(gr+2,2*gr),(rmax_D-rmax)/2,(rmax_C-2*rmax)/2)
              gr = min(max(gr+2,2*gr),rmax_d-rmax,max(0,(rmax_c-2*rmax)/2))
              exit
            end if
          end if
        end if
 
#ifdef Dredtest
!      write(*,*) 'CalcDred: it gr',i,gr, err_gr_exp,err_gr_C ,err_gr(rmax)
#endif
 
      if (mod(i,2).eq.1) then
 
#ifdef Dredtest
       write(*,*) 'CalcDred: it gy',use_gy,err_gy_exp,err_gy_c,err_gy(rmax),err_req_d
#endif
 
        if (use_gpf) then
          if (err_gpf_exp.gt.err_gpf_c.and.err_gpf(rmax).gt.err_req_d) then
            gpf = i/2
            err_gpf_exp = err_gpf_exp*fac_gpf
            err_gpf_c = b_gpf*max(err_gpf_cr,                   &
                max(err_c(rmax+2*gpf)*v1_gpf,err_c(rmax+2*gpf+1))*y_gpf**gpf,      &          
                max(err_c(rmax+gpf)*v1_gpf,err_c(rmax+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf) 
            err_gpf(rmax) = max(err_gpf_exp,err_gpf_c)
 
#ifdef Dredtest
         write(*,*) 'CalcDred i gpf',i,gpf,err_gpf_exp,err_gpf_c,err_gpf(rmax) 
         write(*,*) 'CalcDred i ',err_gpf_cr,                   &
               max(err_c(rmax+2*gpf)*v1_gpf,err_c(rmax+2*gpf+1))*y_gpf**gpf,      &          
               max(err_c(rmax+gpf)*v1_gpf,err_c(rmax+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf
          write(*,*) 'CalcDred i ', b_gpf*err_c(rmax+2*gpf)*v1_gpf*y_gpf**gpf, &
                b_gpf*err_c(rmax+2*gpf+1)*y_gpf**gpf
          write(*,*) 'CalcDred i ', & 
                b_gpf,err_c(rmax+2*gpf+1),y_gpf**gpf 
          write(*,*) 'CalcDred i ', b_gpf*x_gpf**gpf*err_c(rmax+gpf)*v1_gpf, &
                b_gpf*err_c(rmax+gpf+1)*x_gpf**gpf 
          write(*,*) 'CalcDred i ', & 
                b_gpf,err_c(rmax+gpf+1),x_gpf**gpf,x_gpf,gpf 
#endif
 
            if(err_gpf(rmax).lt.err_req_d) then
              iexp = 5
              ! increase gpf by 2 to account for bad estimates
              gpf = min(max(gpf+2,2*gpf),(rmax_d-rmax)/2)
              exit
            end if
          end if
        end if
 
#ifdef Dredtest
!       write(*,*) 'CalcDred: it gpf',i,gpf, err_gpf_exp,err_gpf_C ,err_gpf(rmax)
#endif
 
      end if
      end if
 
 
    end do
 
    ! scale estimates down to allow trying other methods
    err_g(rmax)  =  err_g(rmax)/impest_d
    err_gy(rmax) =  err_gy(rmax)/impest_d     
    err_gp(rmax) =  err_gp(rmax)/impest_d
    err_gr(rmax) =  err_gr(rmax)/impest_d     
    err_gm(rmax) =  err_gm(rmax)/impest_d     
    err_gpf(rmax) =  err_gpf(rmax)/impest_d     
 
#ifdef Dredtest
    write(*,*) 'iexp=',iexp
    write(*,*) 'facexp=',fac_g,fac_gy,fac_gp,fac_gr,fac_gm,fac_gpf
    write(*,*) 'errexp=',err_g_exp,err_gy_exp,err_gp_exp,err_gr_exp,err_gm_exp,err_gpf_exp,err_req_d
    write(*,*) 'errexptot=',i,g,err_g(rmax),gy,err_gy(rmax),gp,err_gp(rmax), &
 
        gr,err_gr(rmax),gm,err_gm(rmax),gpf,err_gpf(rmax)
    write(*,*) 'accexptot=',i,g,err_g(rmax)/dtyp,gy,err_gy(rmax)/dtyp, &
        gp,err_gp(rmax)/dtyp,gr,err_gr(rmax)/dtyp,gm,err_gm(rmax)/dtyp, &
        gpf,err_gpf(rmax)/dtyp
#endif
 
! call expansions with estimated order to save CPU time
 
#ifdef TEST
!     iexp = 0
!     iexp = 5
!     gm = 10
!      iexp = 1
!      g = 10
!     iexp = 4
!     gr = 3
      iexp = 2
      gy = 4
#endif
 
    select case (iexp)
 
    case (1)
      call calcdg(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,g,g,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(3) = dcount(3)+1
      drcalc(0:rmax)=drcalc(0:rmax)+4
      dcalc = dcalc+4
      drmethod_alt(0:rmax)=4
        
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_g(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_g imprecise ',err_g(rmax),derr_alt(rmax)
      end if
#endif
 
      err_g=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
              
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
!     write(*,*) 'CalcDred after exp Dacc=',Derr/abs(D(0,0,0,0))
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
 
    case (2)
      call calcdgy(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gy,gy,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(4) = dcount(4)+1
      drcalc(0:rmax)=drcalc(0:rmax)+8
      dcalc = dcalc+8
      drmethod_alt(0:rmax)=8
 
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_gy(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_gy imprecise',err_gy(rmax),derr_alt(rmax),checkest
      end if
#endif
      err_gy=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
#ifdef Dredtest
!      write(*,*) 'after CalcDgy D(1,0,1,0)',D_alt(1,0,1,0),D(1,0,1,0)
#endif
 
 
    case (3)
      call calcdgp(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gp,gp,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(5) = dcount(5)+1
      drcalc(0:rmax)=drcalc(0:rmax)+16
      dcalc = dcalc+16
      drmethod_alt(0:rmax)=16
 
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_gp(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_gp imprecise',err_gp(rmax),derr_alt(rmax)
      end if
#endif
      err_gp=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
 
    case (4)
      call calcdgr(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gr,gr,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(6) = dcount(6)+1
      drcalc(0:rmax)=drcalc(0:rmax)+32
      dcalc = dcalc+32
      drmethod_alt(0:rmax)=32
 
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_gr(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_gr imprecise',err_gr(rmax),derr_alt(rmax)
      end if
#endif
      err_gr=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
 
#ifdef USEGM
    case (7)
      call calcdgm(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gm,gm,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(7) = dcount(7)+1
      drcalc(0:rmax)=drcalc(0:rmax)+64
      dcalc = dcalc+64
      drmethod_alt(0:rmax)=64
 
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_gm(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_gm imprecise',err_gm(rmax),derr_alt(rmax)
      end if
#endif
      err_gm=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
#endif
 
    case (5)
      call calcdgpf(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gpf,gpf,id,derr1_alt,derr2_alt)
#ifdef PVEST2
      derr_alt = derr2_alt
#else
      derr_alt = derr1_alt
#endif
      dcount(7) = dcount(7)+1
      drcalc(0:rmax)=drcalc(0:rmax)+64
      dcalc = dcalc+64
      drmethod_alt(0:rmax)=64
 
#ifdef Dredtest
      checkest=derr_alt(rmax)/err_gpf(rmax)
      if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
        write(*,*) 'CalcDred: estimate err_gpf imprecise',err_gpf(rmax),derr_alt(rmax),checkest
      end if
#endif
      err_gpf=derr_alt
 
      call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
 
#ifdef Dredtest
      write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
      write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
      write(*,*) 'CalcDred after exp method=',drmethod
#endif
 
    end select
 
!   write(*,*) 'CalcDred Calc',DrCalc(rmax)
 
#ifndef USED0
#ifndef ALWAYSPV
    ! refine error estimate for D0
    if(.not.lerr_d0.and.iexp.ne.0) then
!      D0est =  abs(D(0,0,0,0))
      err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
!      err_req_D = acc_req_D * abs(D(0,0,0,0))
      lerr_d0 = .true.
    end if
#endif
#endif
 
    if (iexp.ne.0) then           !  if added 21.11.2016
      if (rmax.ge.1) then
        dtyp =  max(abs(d(0,0,0,0)),        &
            abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))  
      else
        dtyp =  abs(d(0,0,0,0))
      end if
      err_req_d = acc_req_d * dtyp
    
#ifdef Dredtest
      write(*,*) 'CalcDred ',rmax,derr1(rmax),err_req_d
#endif
 
      if (derr1(rmax).le.err_req_d) then
        dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
        return
      end if
    end if
 
#ifdef TEST
    return
#endif
 
#ifdef Dredtest
    write(*,*) 'CalcDred no optimal method'
    write(*,*) 'err_req_D=',err_req_d
    write(*,*) 'err_est=',err_pv(rmax),err_pv2(rmax),err_g(rmax),err_gy(rmax),err_gp(rmax),err_gr(rmax),err_gpf(rmax)
#endif
 
    ! no method does work optimal
    ! use the least problematic (for each rank)
    do r=rmax,0,-1
     
      if(use_pv.and.mod(drcalc(r),2).ne.1) then   
    ! estimate accuracy of PV-reduction
        if (use_pv) then
 
          if (mod(r,2).eq.1) then
            err_pv(r) = max( w_pv**((r-1)/2) * v_pv * err_d0,  &
                w_pv**((r-1)/2) * z_pv * err_c0, z_pv * err_c(r-1) )
            
!            write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,err_D0,r
            
!            write(*,*) 'CalcDred err_pv: ',err_pv(r), w_pv**((r-1)/2) * v_pv * err_D0,  &
!                        w_pv**((r-1)/2) * z_pv * err_C0, z_pv * err_C(r-1)
            
          else if (r.ne.0) then
            err_pv(r) = max( w_pv**(r/2) * err_d0,  &
                w_pv**(r/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(r-1) )
            
!            write(*,*) 'CalcDred err_pv: ',err_pv(r), w_pv**((r)/2) * err_D0,  &
!                        w_pv**(r/2-1) * v_pv * z_pv * err_C0, z_pv * err_C(r-1)
 
          else
            err_pv(r) = err_d0
          end if
        end if
        ! scale estimates down to allow trying other methods
        err_pv(r)  = err_pv(r)/impest_d
      end if
 
      if (use_pv2.and.mod(drcalc(r),4)-mod(drcalc(r),2).ne.2) then
    ! estimate accuracy of alternative PV-reduction
        if (use_pv2) then
 
!         write(*,*) 'CalcDred err_pv2',  r,w_pv2,v_pv2,z_pv2,err_D0,err_C0
 
          if (mod(r,2).eq.1) then
! changed 21.10.15 for PVEST2
!            err_pv2(r) = max( err_D0 * max(w_pv2**r,    &
!                w_pv2*v_pv2**((r-1)/2) ),  &
!                err_C0 * z_pv2* max(w_pv2**(r+1), &
!                                    w_pv2*v_pv2**((r-1)/2), & 
!                                    v_pv2**((r+1)/2)),  &
!                err_C(r-1) * z_pv2 * max(w_pv2,w_pv2**2,v_pv2) )
            err_pv2(r) = max( err_d0 * max(hw_pv2**r,    &
                hw_pv2*v_pv2**((r-1)/2) ),  &
                err_c0 * z_pv2* max(w_pv2*w_pv2**(r), &
                                    hw_pv2*v_pv2**((r-1)/2), & 
                                    w_pv2*hw_pv2*v_pv2**((r-1)/2), & 
                                    v_pv2**((r+1)/2)),  &
                err_c(r-1) * z_pv2 * max(hw_pv2,w_pv2*hw_pv2**2,v_pv2) )
                                  
 
!           write(*,*) 'CalcDred err_pv2: ',   &
!               err_pv2(r) ,     err_D0,err_D0*w_pv2**r,err_D0*v_pv2**((r-1)/2),    &
!                                     err_D0*w_pv2*v_pv2**((r-1)/2),       &
!                                 err_C0 * z_pv2*w_pv2**(r+1), &
!                                  err_C0 * z_pv2*w_pv2*v_pv2**((r-1)/2), & 
!                                  err_C0 * z_pv2*v_pv2**((r+1)/2),     &
!               err_C(r-1),  err_C(r-1)*z_pv2*w_pv2, &
!                                err_C(r-1)*  z_pv2*w_pv2**2, err_C(r-1)*z_pv2*v_pv2
 
 
          else if (r.ne.0) then
! changed 21.10.15 for PVEST2
!            err_pv2(r) = max( err_D0 * max(w_pv2**r,v_pv2**(r/2)),  &
!                err_C0 * z_pv2 * max(w_pv2**(r+1),  &
!                                     v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
!                err_C(r-1) * z_pv2 * max(w_pv2, w_pv2**2, v_pv2) )
            err_pv2(r) = max( err_d0 * max(hw_pv2**r,v_pv2**(r/2)),  &
                err_c0 * z_pv2 * max(w_pv2*hw_pv2**(r),  &
                                     v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
                err_c(r-1) * z_pv2 * max(hw_pv2, w_pv2*hw_pv2**2, v_pv2) )
                                  
 
!         write(*,*) 'CalcDred err_pv2: ',   &
!         err_pv2(r) , err_D0 * max(1d0,w_pv2**r,v_pv2**(r/2)),  &
!                        err_C0 * z_pv2 * max(w_pv2**(r+1),z_pv2*w_pv2,  &
!                                 v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
!                        err_C(r-1) * max(1d0,z_pv2*w_pv2,  &
!                                 z_pv2*w_pv2**2,z_pv2*v_pv2)
 
          else
            err_pv2(r) = err_d0
          end if
        end if
        ! scale estimates down to allow trying other methods
        err_pv2(r) = err_pv2(r)/impest_d     
      end if
 
      if (mod(drcalc(r),8)-mod(drcalc(r),4).ne.4.and.use_g) then
      ! estimate accuracy of alternative Gram expansion
        err_g_cr = max( err_c(r), err_c0 * u_g**r ) * z_g 
        err_g_c = err_g_cr
        err_g_exp = u_g**(r-1) * dtyp
 
      ! determine optimal order of expansion 
        do i=0,rmax_d-r
          g = i
          err_g_exp = err_g_exp*fac_g
          err_g_c = max(err_g_cr,err_c(r+g)*z_g*x_g**g)
          err_g(r) = max(err_g_exp,err_g_c)
          if (err_g_exp.lt.err_g_c.or.err_g(r).lt.err_req_d) exit
        end do
      ! increase g by 2 to account for bad estimates
        g = min(max(g+2,2*g),rmax_d-r)
      ! scale estimates down to allow trying other methods
        err_g(r)  =  err_g(r)/impest_d
      end if
 
      if (mod(drcalc(r),16)-mod(drcalc(r),8).ne.8.and.use_gy) then
      ! estimate accuracy of alternative Gram expansion
        err_gy_cr =  max( err_c(r) * v1_gy, err_c(r+1) ) 
        err_gy_c = err_gy_cr * b_gy
        err_gy_exp = 1d0 * dtyp
 
      ! determine optimal order of expansion 
        gy = 0
        do i=0,rmax_d-r
          if (mod(i,2).eq.1) then
            gy = i/2
            err_gy_exp = err_gy_exp*fac_gy
            err_gy_c = b_gy*max(err_gy_cr,                   &
                max(err_c(r+2*gy)*v1_gy,err_c(r+2*gy+1))*y_gy**gy,      &          
                max(err_c(r+gy)*v1_gy,err_c(r+gy+1))*(max(x_gy,v_gy*y_gy))**gy) 
            err_gy(r) = max(err_gy_exp,err_gy_c)            
            if (err_gy_exp.lt.err_gy_c.or.err_gy(r).lt.err_req_d) exit
          end if
        end do
      ! increase gy to account for bad estimates
        gy = min(max(gy+2,2*gy),(rmax_d-r)/2)
      ! scale estimates down to allow trying other methods
        err_gy(r) =  err_gy(r)/impest_d     
      end if
 
      if (mod(drcalc(r),32)-mod(drcalc(r),16).ne.16.and.use_gp) then
      ! estimate accuracy of small momenta expansion
        err_gp_cr = max(err_c0*v_gp**r,err_c(r))*z_gp
        err_gp_exp = v1_gp**(r-1) * dtyp
 
      ! determine optimal order of expansion 
        do i=0,rmax_d-r
          gp = i
          err_gp_exp = err_gp_exp*fac_gp
          err_gp_c = max(err_c(r+gp)*z_gp*w_gp**gp,err_gp_cr)
          err_gp(r) = max(err_gp_exp,err_gp_c)
          if (err_gp_exp.lt.err_gp_c.or.err_gp(r).lt.err_req_d) exit
        end do
      ! increase gp to account for bad estimates
        gp = min(max(gp+2,3*gp/2),rmax_d-r)
      ! scale estimates down to allow trying other methods
        err_gp(r) =  err_gp(r)/impest_d
      end if
 
      if (mod(drcalc(r),64)-mod(drcalc(r),32).ne.32.and.use_gr) then
      ! estimate accuracy of alternative Gram expansion
        err_gr_cr = err_c(r) 
        err_gr_c = err_gr_cr * a_gr
        err_gr_exp = y1_gr * dtyp
 
      ! determine optimal order of expansion 
        gr = 0
        do i=0,min(rmax_d-r,rmax_c-2*r)
          if (mod(i,2).eq.1) then
            gr = i/2
            err_gr_exp = err_gr_exp*fac_gr
            err_gr_c = a_gr*max(err_gr_cr,                   &
                max(err_c(r+gr),err_c(r+gr+1)*y_gr)*fac_gr**gr)
            err_gr(r) = max(err_gr_exp,err_gr_c)
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr err_gr',i,gr,err_gr_exp,err_gr_c,err_gr(r),err_req_d
#endif
 
            if (err_gr_exp.lt.err_gr_c.or.err_gr(r).lt.err_req_d) exit
          end if
        end do
      ! increase gr to account for bad estimates
! changed 28.07.14
!       gr = min(max(gr+2,2*gr),(rmax_D-r)/2,(rmax_C-2*r)/2)
        gr = min(max(gr+2,2*gr),rmax_d-r,max(0,(rmax_c-2*r)/2))
      ! scale estimates down to allow trying other methods
        err_gr(r) =  err_gr(r)/impest_d     
 
      end if
 
      if (mod(drcalc(r),128)-mod(drcalc(r),64).ne.64.and.use_gpf) then
      ! estimate accuracy of small momenta and f expansion
        err_gpf_cr =  max( err_c(r) * v1_gpf, err_c(r+1) ) 
        err_gpf_c = err_gpf_cr * b_gpf
        err_gpf_exp = 1d0 * dtyp
 
      ! determine optimal order of expansion 
        gpf = 0
        do i=0,rmax_d-r
          if (mod(i,2).eq.1) then
            gpf = i/2
            err_gpf_exp = err_gpf_exp*fac_gpf
            err_gpf_c = b_gpf*max(err_gpf_cr,                   &
                max(err_c(r+2*gpf)*v1_gpf,err_c(r+2*gpf+1))*y_gpf**gpf,      &          
                max(err_c(r+gpf)*v1_gpf,err_c(r+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf) 
            err_gpf(r) = max(err_gpf_exp,err_gpf_c)            
            if (err_gpf_exp.lt.err_gpf_c.or.err_gpf(r).lt.err_req_d) exit
          end if
        end do
      ! increase gpf to account for bad estimates
        gpf = min(max(gpf+2,2*gpf),(rmax_d-r)/2)
      ! scale estimates down to allow trying other methods
        err_gpf(r) =  err_gpf(r)/impest_d     
      end if
 
 
 
#ifdef USEGM
      if (mod(drcalc(r),128)-mod(drcalc(r),64).ne.64.and.use_gm) then
      ! estimate accuracy of modified Gram expansion
        err_gm_cr = max( err_c(r), err_c0 * u_gm**r ) * z_gm 
        err_gm_c = err_gm_cr
        err_gm_exp = u_gm**(r-1) * dtyp
 
      ! determine optimal order of expansion 
        do i=0,rmax_d-r
          gm = i
          err_gm_exp = err_gm_exp*fac_gm
          err_gm_c = max(err_gm_cr,err_c(r+gm)*z_gm*x_gm**gm)
          err_gm(r) = max(err_gm_exp,err_gm_c)
          if (err_gm_exp.lt.err_gm_c.or.err_gm(r).lt.err_req_d) exit
        end do
      ! increase gm by 2 to account for bad estimates
        gm = min(max(gm+2,2*gm),rmax_d-r)
      ! scale estimates down to allow trying other methods
        err_gm(r)  =  err_gm(r)/impest_d
      end if
#endif
 
 
#ifdef Dredtest
      write(*,*) 'CalcDred: bef final loop ord methods',r,g,gy,gp,gr,gm,gpf
      write(*,*) 'CalcDred: bef final loop err methods',r,err_pv(r),err_pv2(r), &
          err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gm(r),err_gpf(r)
      write(*,*) 'CalcDred: bef final loop acc methods',r,err_pv(r)/dtyp,err_pv2(r)/dtyp,   &
          err_g(r)/dtyp,err_gy(r)/dtyp,err_gp(r)/dtyp, &
          err_gr(r)/dtyp,err_gm(r)/dtyp,err_gpf(r)/dtyp
      write(*,*) 'CalcDred: bef final loop method',r,drcalc(r),drmethod(r)
#endif
 
100   continue   ! try other methods if error larger than expected
      if (min(err_pv(r),err_pv2(r)).le.min(err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gpf(r))       &
          .and.min(err_pv(r),err_pv2(r)).lt.err_inf) then
 
        if (use_pv.and.err_pv(r).le.err_pv2(r).and.mod(drcalc(r),2).ne.1) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr1_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr1_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
#ifdef Dredtest
          write(*,*) 'CalcDred: call Dpv 2',r,id
#endif
          
!         write(*,*) 'CalcDred: Dpv r',r,rmax,p10
!         write(*,*) 'CalcDred: Dpv Duv',size(Duv)
!         write(*,*) 'CalcDred: Dpv Duv_alt',size(Duv_alt)
         
 
          if (r.eq.rmax) then
            call calcdpv1(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt,derr2_alt)
          else
            call calcdpv1(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),  &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(11) = dcount(11)+1
          drcalc(0:r)=drcalc(0:r)+1
          dcalc = dcalc+1
          drmethod_alt(0:r)=1
          checkest=derr_alt(r)/err_pv(r)
          
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_pv imprecise',err_pv(r),derr_alt(r)
          end if
#endif
 
#ifdef Dredtest
       write(*,*) 'final loop r Dpv D(1,0,1,0)',r,d_alt(1,0,1,0),d(1,0,1,0)
       write(*,*) 'final loop r Dpv Derr',derr_alt(2),derr(2)
#endif
          err_pv(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),   &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after pv 2nd try Dmethod_alt=',drmethod_alt
          write(*,*) 'CalcDred: after pv 2nd try Derr_alt(r)=',derr_alt
          write(*,*) 'CalcDred: after pv 2nd try Dacc_alt(r)=',derr_alt/dtyp
          write(*,*) 'CalcDred: after pv 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after pv 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after pv 2nd try Dacc(r)=',derr/dtyp
#endif
 
#ifdef Dredtest
!       if(r.gt.2)then
!       write(*,*) 'after CalcDpv D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
!       endif
#endif
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
        elseif (use_pv2.and.err_pv2(r).le.err_pv(r).and.mod(drcalc(r),4)-mod(drcalc(r),2).ne.2) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
#ifdef Dredtest
          write(*,*) 'CalcDred: call Dpv2 2',r,id
#endif
          if (r.eq.rmax) then
            call calcdpv2(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt,derr2_alt)
          else
            call calcdpv2(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),  &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
 
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(12) = dcount(12)+1
          drcalc(0:r)=drcalc(0:r)+2
          dcalc = dcalc+2
          drmethod_alt(0:r)=2
          checkest=derr_alt(r)/err_pv2(r)
          
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_pv2 imprecise',err_pv2(r),derr_alt(r)
          end if
#endif
          err_pv2(0:r)=derr_alt(0:r)
 
#ifdef Dredtest
       if(r.ge.2) then
       write(*,*) 'final loop r Dpv2 D(1,0,1,0)',r,d_alt(1,0,1,0),d(1,0,1,0)
       write(*,*) 'final loop r Dpv2 Derr',derr_alt(2),derr(2)
       endif
#endif
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),   &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
#ifdef Dredtest
          write(*,*) 'CalcDred: after pv 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after pv 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after pv 2nd try Dacc(r)=',derr/dtyp
#endif
 
        end if
 
      else 
 
#ifdef Dredtest
        write(*,*) 'CalcDred: explore exps once more'
#endif
 
        if (use_g.and.err_g(r).le.min(err_gy(r),err_gp(r),err_gr(r),err_gpf(r))        &
            .and.mod(drcalc(r),8)-mod(drcalc(r),4).ne.4) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calcdg(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt,derr2_alt)
          else
            call calcdg(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),  &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(13) = dcount(13)+1
          drcalc(0:r)=drcalc(0:r)+4
          dcalc = dcalc+4
          drmethod_alt(0:r)=4
          checkest=derr_alt(r)/err_g(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_g imprecise ',err_g(r),derr_alt(r)
          end if
#endif
          
          err_g(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),  &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
#ifdef Dredtest
!       if(r.gt.2)then
!       write(*,*) 'after CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
!       endif
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
        else if (use_gy.and.err_gy(r).le.min(err_g(r),err_gp(r),err_gr(r),err_gpf(r))        &
            .and.mod(drcalc(r),16)-mod(drcalc(r),8).ne.8) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calcdgy(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gy,(rmax_d)/2,id,derr1_alt,derr2_alt)
          else
            call calcdgy(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),   &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gy,(rmax_d)/2,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(14) = dcount(14)+1
          drcalc(0:r)=drcalc(0:r)+8
          dcalc = dcalc+8
          drmethod_alt(0:r)=8
          checkest=derr_alt(r)/err_gy(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_gy imprecise',err_gy(r),derr_alt(r)
          end if
#endif
          
          err_gy(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),  &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
#ifdef Dredtest
!       if(rmax.ge.3)then
!       write(*,*) 'after CalcDgy D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
!       endif
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
 
        elseif (use_gp.and.err_gp(r).le.min(err_g(r),err_gy(r),err_gr(r),err_gpf(r))    &
            .and.mod(drcalc(r),32)-mod(drcalc(r),16).ne.16) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calcdgp(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gp,rmax_d,id,derr1_alt,derr2_alt)
          else
            call calcdgp(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),   &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gp,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
          endif
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(15) = dcount(15)+1
          drcalc(0:r)=drcalc(0:r)+16
          dcalc = dcalc+16
          drmethod_alt(0:r)=16
          checkest=derr_alt(r)/err_gp(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_gp imprecise',err_gp(r),derr_alt(r)
          end if
#endif
          
          err_gp(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),   &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
        elseif (use_gr.and.err_gr(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gpf(r))        &
            .and.mod(drcalc(r),64)-mod(drcalc(r),32).ne.32) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calcdgr(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gr,rmax_d,id,derr1_alt,derr2_alt)
          else
            call calcdgr(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),  &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gr,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
          endif
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(16) = dcount(16)+1
          drcalc(0:r)=drcalc(0:r)+32
          dcalc = dcalc+32
          drmethod_alt(0:r)=32
          checkest=derr_alt(r)/err_gr(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_gr imprecise',err_gr(r),derr_alt(r)
          end if
#endif
          
          err_gr(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),    &  
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
 
#ifdef Dredtest
!     if(r.gt.2)then
!       write(*,*) 'CalcDred D(1,0,1,0)',r,D(1,0,1,0)
!     endif
#endif
 
        else if (use_gpf.and.err_gpf(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gr(r))        &
            .and.mod(drcalc(r),128)-mod(drcalc(r),64).ne.64) then
 
          if (r.eq.rmax) then
            call calcdgpf(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gpf,(rmax_d)/2,id,derr1_alt,derr2_alt)
          else
            call calcdgpf(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),   &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gpf,(rmax_d)/2,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(17) = dcount(17)+1
          drcalc(0:r)=drcalc(0:r)+64
          dcalc = dcalc+64
          drmethod_alt(0:r)=64
          checkest=derr_alt(r)/err_gpf(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_gpf imprecise',err_gpf(r),derr_alt(r)
          end if
#endif
          
          err_gpf(0:r)=derr_alt(0:r)
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),  &
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
#ifdef Dredtest
!       if(rmax.ge.3)then
!       write(*,*) 'after CalcDgpf D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
!       endif
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
 
#ifdef USEGM
        else if (use_gm.and.err_gm(r).le.min(err_gy(r),err_gp(r),err_gr(r),err_g(r))        &
            .and.mod(drcalc(r),128)-mod(drcalc(r),64).ne.64) then
 
!          deallocate(D_alt)
!          deallocate(Duv_alt)
!          deallocate(Derr_alt)
!          deallocate(Derr2_alt)
!          deallocate(Drmethod_alt)
!          allocate(D_alt(0:r,0:r,0:r,0:r))
!          allocate(Duv_alt(0:r,0:r,0:r,0:r))
!          allocate(Derr_alt(0:r))
!          allocate(Derr2_alt(0:r))
!          allocate(Drmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calcdgm(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt,derr2_alt)
          else
            call calcdgm(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r),  &
                p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
          end if
#ifdef PVEST2
          derr_alt = derr2_alt
#else
          derr_alt = derr1_alt
#endif
          dcount(17) = dcount(17)+1
          drcalc(0:r)=drcalc(0:r)+64
          dcalc = dcalc+64
          drmethod_alt(0:r)=64
          checkest=derr_alt(r)/err_gm(r)
 
#ifdef Dredtest
          if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
            write(*,*) 'CalcDred: estimate err_g imprecise ',err_gm(r),derr_alt(r)
          end if
#endif
          
          err_gm(0:r)=derr_alt(0:r)
 
          call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r),  &  
              derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            dtyp =  max(abs(d(0,0,0,0)),        &
                abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
          else
            dtyp =  abs(d(0,0,0,0))
          end if
          err_req_d = acc_req_d * dtyp
 
#ifdef Dredtest
          write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
          write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
          write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
#endif
 
#ifdef Dredtest
!       if(r.gt.2)then
!       write(*,*) 'after CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
!       endif
#endif
 
          if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
#endif
          
        end if
      end if
 
#ifndef USED0
#ifndef ALWAYSPV
      ! refine error estimate for D0
      if(.not.lerr_d0) then
!        D0est =  abs(D(0,0,0,0))
        err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
!        err_req_D = acc_req_D * abs(D(0,0,0,0))
        lerr_d0 = .true.
      end if
#endif
#endif
 
#ifdef Dredtest
!       if(r.ge.2) then
!       write(*,*) 'after r CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
!       write(*,*) 'after r CalcDg Derr',Derr_alt(2),Derr(2)
!       endif
#endif
 
 
#ifdef Dredtest
      write(*,*) 'CalcDred: final loop err methods',r,err_pv(r),err_pv2(r), &
          err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gm(r),err_gpf(r)
      write(*,*) 'CalcDred: final loop acc methods',r,err_pv(r)/dtyp,err_pv2(r)/dtyp,   &
          err_g(r)/dtyp,err_gy(r)/dtyp,err_gp(r)/dtyp, &
          err_gr(r)/dtyp,err_gm(r)/dtyp,err_gpf(r)/dtyp
      write(*,*) 'CalcDred: final loop method',r,drcalc(r),drmethod(r)
#endif
 
    end do
 
    norm = abs(d(0,0,0,0))
 
    do r=1,rmax
      do n1=0,rmax
        do n2=0,rmax-n1
          n3 = rmax-n1-n2
          norm =  max(norm,abs(d(0,n1,n2,n3)))
        end do
      end do
    end do
    acc_d = derr(rmax)/norm
 
    dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
 
#ifdef Dredtest
    write(*,*) 'CalcDred final err_D=',derr
    write(*,*) 'CalcDred final acc_D=',derr/norm,critacc_coli
    write(*,*) 'CalcDred final method_D=',drmethod
#endif
 
    if (acc_d.gt.sqrt(reqacc_coli)) then
      dcount(dcalc+dcountoffset3) = dcount(dcalc+dcountoffset3)+1
    end if
 
    if (acc_d.gt.reqacc_coli) then
      dcount(dcalc+dcountoffset1) = dcount(dcalc+dcountoffset1)+1
    end if
 
    if (acc_d.gt.critacc_coli) then
 
      dcount(dcalc+dcountoffset2) = dcount(dcalc+dcountoffset2)+1
 
#ifdef Dredtest
      write(*,*) 'CritPoint D',critacc_coli,acc_d
      write(*,*) 'CritPoint D',critpointcntd,maxcritpointd
#endif      
 
!      call SetErrFlag_coli(-5)
!      call ErrOut_coli('CalcDred',' critical accuracy not reached',  &
!         errorwriteflag)
 
#ifdef CritPointsCOLI 
      critpointcntd = critpointcntd + 1    
 
      if (critpointcntd.le.maxcritpointd.and.monitoring) then
 
        call critpointsout_coli('D_coli',acc_d)
        write(ncpout_coli,*) 'arguments of CalcDred_coli:'
        write(ncpout_coli,*) 'rank = ', rmax
        write(ncpout_coli,fmt1) 'p10 = ', p10
        write(ncpout_coli,fmt1) 'p21 = ', p21
        write(ncpout_coli,fmt1) 'p32 = ', p32
        write(ncpout_coli,fmt1) 'p30 = ', p30
        write(ncpout_coli,fmt1) 'p20 = ', p20
        write(ncpout_coli,fmt1) 'p31 = ', p31
        write(ncpout_coli,fmt1) 'm02 = ', m02
        write(ncpout_coli,fmt1) 'm12 = ', m12
        write(ncpout_coli,fmt1) 'm22 = ', m22
        write(ncpout_coli,fmt1) 'm32 = ', m32
        if (critpointcntd.eq.maxcritpointd) then
          write(ncpout_coli,*)
          write(ncpout_coli,*)
          write(ncpout_coli,*)
          write(ncpout_coli,*) '***********************************************************'
          write(ncpout_coli,*)
          write(ncpout_coli,*) ' Further output of bad D functions will be suppressed '
        end if
      end if
#endif
    end if
 
#ifdef Dredtest
       write(*,*) 'CalcDred exit D(1,0,0,0)',r,d_alt(1,0,0,0),d(1,0,0,0)
#endif
 
  end subroutine calcdred
 
 
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDuv(Duv,Cuv_0,m02,f,rmax,id)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcduv(Duv,Cuv_0,m02,f,rmax,id)
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: m02,f(3)
    double complex, intent(inout) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(in) :: Cuv_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1)
    integer :: r,n0,n1,n2,n3
        
    ! D_(n0,n1,n2,n3) UV-finite for n0<2
    duv(0:min(rmax,1),:,:,:) = 0d0
    
    ! PV reduction (5.10)
!    do r=4,rmax
!      do n0=2,r/2
    do r=4,rmax+1
      do n0=max(2,r-rmax),r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
        
            duv(n0,n1,n2,n3) = (cuv_0(n0-1,n1,n2,n3) + 2*m02*duv(n0-1,n1,n2,n3)  &
                                + f(1)*duv(n0-1,n1+1,n2,n3)  & 
                                + f(2)*duv(n0-1,n1,n2+1,n3)  & 
                                + f(3)*duv(n0-1,n1,n2,n3+1)) / (2*(r-1))
    
          end do
        end do
      end do
    end do
    
  end subroutine calcduv
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDpv1(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  !
  !  new version 10.02.2016   (5.10) with (5.11) inserted
  !              14.09.2016    prefactors of C_0 improved
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdpv1(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex :: C_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1), Cuv_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1)
    double complex :: C_i(0:rmax-1,0:rmax-1,0:rmax-1,3), Cuv_i(0:rmax-1,0:rmax-1,0:rmax-1,3)
    double complex :: D_alt(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision :: Cerr_i(0:rmax-1,0:3),Cerr2_i(0:rmax-1,0:3)
!   double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
!   double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
!   double complex, allocatable :: D_alt(:,:,:,:)
!   double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3)
    double complex :: D0_coli, elimminf2_coli
 !  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
 !  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: D00_err(0:rmax),Dij_err(0:rmax),Cij_err(0:rmax-1)
    double precision :: D00_err2(0:rmax),Dij_err2(0:rmax),Cij_err2(0:rmax-1)
    integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
    integer :: bin,k,nid(0:3)
 
!    if (id.eq.0) write(*,*) 'CalcDpv1 in', rmax, id
        
    ! calculation of scalar coefficient
    d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
    duv(0,0,0,0) = 0d0
 
    ! accuracy estimate for D0 function
    derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
    derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
 
    if (rmax.eq.0) return
 
    ! allocation of C functions
    rmaxc = rmax-1
    ! rmaxC = max(rmax-1,0)
!   allocate(C_0(0:rmaxC,0:rmaxC,0:rmaxC,0:rmaxC))
!   allocate(Cuv_0(0:rmaxC,0:rmaxC,0:rmaxC,0:rmaxC))
!   allocate(C_i(0:rmaxC,0:rmaxC,0:rmaxC,3))
!   allocate(Cuv_i(0:rmaxC,0:rmaxC,0:rmaxC,3))
!   allocate(Cerr_i(0:rmaxC,0:3))
!   allocate(Cerr2_i(0:rmaxC,0:3))
 
    ! allocate arrays for error propagation
!   allocate(D00_err(0:rmax))
!   allocate(Dij_err(0:rmax))
!   allocate(Cij_err(0:rmaxC))
    
!   allocate(D00_err2(0:rmax))
!   allocate(Dij_err2(0:rmax))
!   allocate(Cij_err2(0:rmaxC))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
 
#ifdef Dpv1test
    write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,0)
    write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,1)
    write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,2)
    write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,3)
#endif
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
              -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
 
    ! calculate Duv
    call calcduv(duv,cuv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
 
    dij_err =0d0
    d00_err =0d0
    dij_err(0) = derr(0)
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
    
    dij_err2 =0d0
    d00_err2 =0d0
    dij_err2(0) = derr2(0)
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
    
#ifdef Dpv1test
    write(*,*) 'CalcDpv1 Cij_err=',cij_err
    write(*,*) 'CalcDpv1 Dij_err(0)=',dij_err(0)
    write(*,*) 'CalcDpv1 test :', & 
            (1d0 - (zadjf(1)+zadjf(2)+zadjf(3))/detz), &
            (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
            + zadjs(3)*(mm32-mm02) ) /detz
#endif
 
!   allocate(D_alt(0:rmax,0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
    ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
 
            d(n0,n1,n2,n3) = 4*duv(n0,n1,n2,n3) + detx/detz*d(n0-1,n1,n2,n3) 
 
            d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                + (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
                    + zadjs(3)*(mm32-mm02) ) /detz * c_0(n0-1,n1,n2,n3)
!               + (1d0 - (Zadjf(1)+Zadjf(2)+Zadjf(3))/detZ)* C_0(n0-1,n1,n2,n3)
 
            if (n1.ge.1) then
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  - 2*n1*zadjf(1)/detz*d(n0,n1-1,n2,n3)
            else            
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  + zadjf(1)/detz* c_i(n0-1,n2,n3,1)
            end if
 
            if (n2.ge.1) then
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  - 2*n2*zadjf(2)/detz*d(n0,n1,n2-1,n3)
            else            
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  + zadjf(2)/detz * c_i(n0-1,n1,n3,2)
            end if
 
            if (n3.ge.1) then
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  - 2*n3*zadjf(3)/detz*d(n0,n1,n2,n3-1)
            else            
              d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
                  + zadjf(3)/detz * c_i(n0-1,n1,n2,3)
            end if
 
            d(n0,n1,n2,n3) = d(n0,n1,n2,n3)  / (2*(r-1)) 
 
          end do
        end do
      end do
 
    ! reduction formula (5.11) with (5.10) inserted for n0 = 0
!     do n0=(r-1)/2,0,-1
      n0=0
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
         
            if (n1.ge.1) then
              nn1 = n1-1
              nn2 = n2
              nn3 = n3
              j = 1
            else if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
!            do i=1,3
!              Smod(i) = -C_0(n0,nn1,nn2,nn3)
!            end do
            smod = 0d0  
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d(n0,n1,n2,n3) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2)  &
                           + zadj(3,j)*smod(3) &
                           - zadjs(j)*c_0(n0,nn1,nn2,nn3) &
                           - zadjf(j)*d(n0,nn1,nn2,nn3))/detz
 
         end do
        end do
!     end do
 
      ! determine error from symmetry for n0=0 and n1>1, n2>1 
      derr(r)=derr(r-1)
      derr2(r)=derr2(r-1)
 
!      write(*,*) 'CalcDpv1: Derr(r)',r,Derr(r),Derr2(r)
 
      n0=0
      do n1=0,r-2*n0
        do n2=0,r-2*n0-n1
          n3 = r-2*n0-n1-n2
          if (n1.ge.1.and.n2+n3.ge.1) then
         
            if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
!            do i=1,3
!              Smod(i) = -C_0(n0,nn1,nn2,nn3)
!            end do
            smod = 0d0
             
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d_alt(n0,n1,n2,n3) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2)  &
                           + zadj(3,j)*smod(3) &
                           - zadjs(j)*c_0(n0,nn1,nn2,nn3)  &
                           - zadjf(j)*d(n0,nn1,nn2,nn3))/detz
 
            derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
            derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
 
#ifdef Dpv1test
!            write(*,*) 'CalcDpv1: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
!                        D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
#endif
 
 
          end if
        end do
      end do
 
      if(r.ge.2)then
 
! estimate using insertions of (5.11) in (5.10)
        d00_err(r) = max(2*abs(m02)*dij_err(r-2), cerr_i(r-2,0),    &
              azadjff/adetz*dij_err(r-2),             &
              maxzadjf/adetz*max(2*d00_err(r-1),cij_err(r-2)))/(2*(r-1))
      else
        d00_err(r) = 0d0
      end if
      dij_err(r) = max(maxzadjf*dij_err(r-1),   &
              maxzadj*max(2*d00_err(r),cij_err(r-1)))/adetz
 
      if(r.ge.2)then
! estimate using insertions of (5.11) in (5.10)
        d00_err2(r) = max(2*abs(m02)*dij_err2(r-2), cerr2_i(r-2,0),    &
              azadjff/adetz*dij_err2(r-2),             &
              maxzadjf/adetz*max(2*d00_err2(r-1),cij_err2(r-2)))/(2*(r-1))
      else
        d00_err2(r) = 0d0
      end if
      dij_err2(r) = max(maxzadjf*dij_err2(r-1),   &
              maxzadj*max(2*d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
 
#ifdef Dpv1test
    write(*,*) 'Dij_err(r)', r,dij_err(r),d00_err(r)
    write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
    write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
    write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
    write(*,*) 'factors',maxzadj/adetz,maxzadjf/adetz
    write(*,*) 'Dij_err2(r)', r,dij_err2(r),d00_err2(r)
    write(*,*) 'Dij_err2_jj',maxzadjf*dij_err/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_00',maxzadj*d00_err(1:rmax)/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_cc',maxzadj*cij_err/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'factors2',maxzadj/sqrt(adetz*maxz*maxzadj),maxzadjf/sqrt(adetz*maxz*maxzadj)
#endif
 
    end do
    
      ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
!    do r=rmax+1,2*rmax
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
          end do
        end do
      end do
    end do
 
#ifdef Dpv1test
    write(*,*) 'CalcDpv1 Derrsym',derr
    write(*,*) 'CalcDpv1 Daccsym',derr/abs(d(0,0,0,0))
 
    write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
    write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
    write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
    write(*,*) 'CalcDpv1 Dijerr',dij_err(1:rmax)
    write(*,*) 'CalcDpv1 Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
 
    write(*,*) 'CalcDpv1 Derr2sym',derr2
    write(*,*) 'CalcDpv1 Dacc2sym',derr2/abs(d(0,0,0,0))
 
    write(*,*) 'Dij_err2_jj',maxzadjf*dij_err2/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_00',maxzadj*d00_err2(1:rmax)/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_cc',maxzadj*cij_err2/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'CalcDpv1 Dijerr2',dij_err2(1:rmax)
    write(*,*) 'CalcDpv1 Dijacc2',dij_err2(1:rmax)/abs(d(0,0,0,0))
 
#endif
 
    derr2 = max(derr2,dij_err2(0:rmax))
    derr = max(derr,dij_err(0:rmax))
 
#ifdef Dpv1test
    write(*,*) 'CalcDpv1 D(0,0,0,0) = ',d(0,0,0,0)
    if(rmax.ge.3)then
      write(*,*) 'CalcDpv1 D(0,1,1,1) = ',d(0,1,1,1)
    endif
 
    write(*,*) 'CalcDpv1 Derr',derr
    write(*,*) 'CalcDpv1 Dacc',derr/abs(d(0,0,0,0))
    write(*,*) 'CalcDpv1 Derr2',derr2
    write(*,*) 'CalcDpv1 Dacc2',derr2/abs(d(0,0,0,0))
#endif
 
!    if (id.eq.0) then
!    write(*,*) 'CalcDpv1 Derr ',Derr
!    write(*,*) 'CalcDpv1 Derr2',Derr2
!    end if
    
  end subroutine calcdpv1
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDpv1o(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdpv1o(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3)
    double complex :: D0_coli, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
    integer :: bin,k,nid(0:3)
 
!    if (id.eq.0) write(*,*) 'CalcDpv1o in', rmax, id
        
    ! calculation of scalar coefficient
    d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
    duv(0,0,0,0) = 0d0
 
    ! accuracy estimate for D0 function
    derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
    derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
 
    if (rmax.eq.0) return
 
    ! allocation of C functions
    rmaxc = rmax-1
    ! rmaxC = max(rmax-1,0)
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmax))
    allocate(dij_err(0:rmax))
    allocate(cij_err(0:rmaxc))
    
    allocate(d00_err2(0:rmax))
    allocate(dij_err2(0:rmax))
    allocate(cij_err2(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
 
#ifdef Dpv1otest
    write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,0)
    write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,1)
    write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,2)
    write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,3)
#endif
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
              -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
    
    ! determine inverse Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
 
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
 
!    Zinv(1,1) = (4d0*q30*q20-q2q3*q2q3)/detZ
!    Zinv(2,1) = (q1q3*q2q3-2d0*q30*q1q2)/detZ
!    Zinv(3,1) = (q1q2*q2q3-2d0*q20*q1q3)/detZ
!    Zinv(1,2) = Zinv(2,1)
!    Zinv(2,2) = (4d0*q10*q30-q1q3*q1q3)/detZ
!    Zinv(3,2) = (q1q2*q1q3-2d0*q10*q2q3)/detZ
!    Zinv(1,3) = Zinv(3,1)
!    Zinv(2,3) = Zinv(3,2)
!    Zinv(3,3) = (4d0*q10*q20-q1q2*q1q2)/detZ
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
 
!  commented out 2.9.17
!   Zinv = Zadj/detZ
 
    ! calculate Duv
    call calcduv(duv,cuv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
!    Zadj=Zinv*detZ    
 
!    maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(3,1)),  &
!                  abs(Zadj(2,2)),abs(Zadj(3,2)),abs(Zadj(3,3)))
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
!    maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)),abs(Zadjf(3)))
!
!    aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2)+Zadjf(3)*f(3))
 
!    adetZ = abs(detZ)
!    adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2)-Zadjf(3)*f(3))
 
    dij_err =0d0
    d00_err =0d0
    dij_err(0) = derr(0)
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
    
    dij_err2 =0d0
    d00_err2 =0d0
    dij_err2(0) = derr2(0)
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
    
#ifdef Dpv1otest
    write(*,*) 'CalcDpv1o Cij_err=',cij_err
    write(*,*) 'CalcDpv1o Dij_err(0)=',dij_err(0)
#endif
 
    allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
        ! reduction formula (5.10) for D(r/2,0,0,0)
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
          end do
        end do
      end do
 
 
!     do n0=(r-1)/2,0,-1
      n0=0
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
         
            if (n1.ge.1) then
              nn1 = n1-1
              nn2 = n2
              nn3 = n3
              j = 1
            else if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
            do i=1,3
              smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
            end do
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)  &
                           + zinv(3,j)*smod(3)
 
          end do
        end do
!     end do
 
      ! determine error from symmetry for n0=0 and n1>1, n2>1 
      derr(r)=derr(r-1)
      derr2(r)=derr2(r-1)
      n0=0
      do n1=0,r-2*n0
        do n2=0,r-2*n0-n1
          n3 = r-2*n0-n1-n2
          if (n1.ge.1.and.n2+n3.ge.1) then
         
            if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
            do i=1,3
              smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
            end do
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d_alt(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)  &
                           + zinv(3,j)*smod(3)
 
            derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
            derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
 
#ifdef Dpv1otest
!            write(*,*) 'CalcDpv: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
!                        D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
#endif
 
 
          end if
        end do
      end do
 
      if(r.ge.2)then
! 09.02.2016
! old estimate using insertions of (5.11) in (5.10)
        d00_err(r) = max(2*abs(m02)*dij_err(r-2), cerr_i(r-2,0),    &
              azadjff/adetz*dij_err(r-2),             &
              maxzadjf/adetz*max(2*d00_err(r-1),cij_err(r-2)))/(2*(r-1))
! new estimate 
!       D00_err(r) = max(2*abs(m02)*Dij_err(r-2), Cerr_i(r-2,0),    &
!             fmax*Dij_err(r-1) )/(2*(r-1))
      else
        d00_err(r) = 0d0
      end if
      dij_err(r) = max(maxzadjf*dij_err(r-1),   &
              maxzadj*max(2*d00_err(r),cij_err(r-1)))/adetz
 
      if(r.ge.2)then
! old estimate using insertions of (5.11) in (5.10)
        d00_err2(r) = max(2*abs(m02)*dij_err2(r-2), cerr2_i(r-2,0),    &
              azadjff/adetz*dij_err2(r-2),             &
              maxzadjf/adetz*max(2*d00_err2(r-1),cij_err2(r-2)))/(2*(r-1))
! new estimate 
!       D00_err2(r) = max(2*abs(m02)*Dij_err2(r-2), Cerr2_i(r-2,0),    &
!             fmax*Dij_err2(r-1)  )/(2*(r-1))
      else
        d00_err2(r) = 0d0
      end if
      dij_err2(r) = max(maxzadjf*dij_err2(r-1),   &
              maxzadj*max(2*d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
 
#ifdef Dpv1otest
    write(*,*) 'Dij_err(r)', r,dij_err(r),d00_err(r)
    write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
    write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
    write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
    write(*,*) 'factors',maxzadj/adetz,maxzadjf/adetz
    write(*,*) 'Dij_err2(r)', r,dij_err2(r),d00_err2(r)
    write(*,*) 'Dij_err2_jj',maxzadjf*dij_err/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_00',maxzadj*d00_err(1:rmax)/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_cc',maxzadj*cij_err/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'factors2',maxzadj/sqrt(adetz*maxz*maxzadj),maxzadjf/sqrt(adetz*maxz*maxzadj)
#endif
 
    end do
    
      ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
!    do r=rmax+1,2*rmax
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
          end do
        end do
      end do
    end do
 
#ifdef Dpv1otest
    write(*,*) 'CalcDpv1o Derrsym',derr
    write(*,*) 'CalcDpv1o Daccsym',derr/abs(d(0,0,0,0))
 
    write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
    write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
    write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
    write(*,*) 'CalcDpv1o Dijerr',dij_err(1:rmax)
    write(*,*) 'CalcDpv1o Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
 
    write(*,*) 'CalcDpv1o Derr2sym',derr2
    write(*,*) 'CalcDpv1o Dacc2sym',derr2/abs(d(0,0,0,0))
 
    write(*,*) 'Dij_err2_jj',maxzadjf*dij_err2/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_00',maxzadj*d00_err2(1:rmax)/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'Dij_err2_cc',maxzadj*cij_err2/sqrt(adetz*maxz*maxzadj)
    write(*,*) 'CalcDpv1o Dijerr2',dij_err2(1:rmax)
    write(*,*) 'CalcDpv1o Dijacc2',dij_err2(1:rmax)/abs(d(0,0,0,0))
 
#endif
 
    derr2 = max(derr2,dij_err2(0:rmax))
    derr = max(derr,dij_err(0:rmax))
 
#ifdef Dpv1otest
    write(*,*) 'CalcDpv1o D(0,0,0,0) = ',d(0,0,0,0)
    if(rmax.ge.3)then
      write(*,*) 'CalcDpv1o D(0,1,1,1) = ',d(0,1,1,1)
    endif
 
    write(*,*) 'CalcDpv1o Derr',derr
    write(*,*) 'CalcDpv1o Dacc',derr/abs(d(0,0,0,0))
    write(*,*) 'CalcDpv1o Derr2',derr2
    write(*,*) 'CalcDpv1o Dacc2',derr2/abs(d(0,0,0,0))
#endif
 
!    if (id.eq.0) then
!    write(*,*) 'CalcDpv1o Derr ',Derr
!    write(*,*) 'CalcDpv1o Derr2',Derr2
!    end if
    
  end subroutine calcdpv1o
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDpv(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdpv(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out)  :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3)
    double complex :: D0_coli, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
    integer :: bin,k,nid(0:3)
 
!    if (id.eq.0) write(*,*) 'CalcDpv in', rmax,id
        
    ! calculation of scalar coefficient
    d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
    duv(0,0,0,0) = 0d0
 
    ! accuracy estimate for D0 function
    derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
    derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
 
    if (rmax.eq.0) return
 
    ! allocation of C functions
    rmaxc = rmax-1
    ! rmaxC = max(rmax-1,0)
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmax))
    allocate(dij_err(0:rmax))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmax))
    allocate(dij_err2(0:rmax))
    allocate(cij_err2(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
 
#ifdef Dpvtest
    write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,0)
    write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,1)
    write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,2)
    write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,3)
#endif
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
    
    ! determine inverse Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
 
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
 
!    Zinv(1,1) = (4d0*q30*q20-q2q3*q2q3)/detZ
!    Zinv(2,1) = (q1q3*q2q3-2d0*q30*q1q2)/detZ
!    Zinv(3,1) = (q1q2*q2q3-2d0*q20*q1q3)/detZ
!    Zinv(1,2) = Zinv(2,1)
!    Zinv(2,2) = (4d0*q10*q30-q1q3*q1q3)/detZ
!    Zinv(3,2) = (q1q2*q1q3-2d0*q10*q2q3)/detZ
!    Zinv(1,3) = Zinv(3,1)
!    Zinv(2,3) = Zinv(3,2)
!    Zinv(3,3) = (4d0*q10*q20-q1q2*q1q2)/detZ
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
 
!  commented out 2.9.17
!   Zinv = Zadj/detZ
 
    ! calculate Duv
    call calcduv(duv,cuv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
!    Zadj=Zinv*detZ    
 
!    maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(3,1)),  &
!                  abs(Zadj(2,2)),abs(Zadj(3,2)),abs(Zadj(3,3)))
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
!    maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)),abs(Zadjf(3)))
!
!    aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2)+Zadjf(3)*f(3))
 
!    adetZ = abs(detZ)
!    adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2)-Zadjf(3)*f(3))
 
    dij_err =0d0
    d00_err =0d0
    dij_err(0) = derr(0)
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
    
    dij_err2 =0d0
    d00_err2 =0d0
    dij_err2(0) = derr2(0)
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
    
#ifdef Dpvtest
    write(*,*) 'CalcDpv Cij_err=',cij_err
    write(*,*) 'CalcDpv Dij_err(0)=',dij_err(0)
#endif
 
    allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
      if (mod(r,2).eq.0) then
        ! reduction formula (5.10) for D(r/2,0,0,0)
        n0 = r/2       
        d(n0,0,0,0) = (c_0(n0-1,0,0,0) + 2*mm02*d(n0-1,0,0,0) + 4*duv(n0,0,0,0)  &
                       + f(1)*d(n0-1,1,0,0) + f(2)*d(n0-1,0,1,0)  &
                       + f(3)*d(n0-1,0,0,1)) / (2*(r-1)) 
      end if
 
 
      do n0=(r-1)/2,0,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
         
            if (n1.ge.1) then
              nn1 = n1-1
              nn2 = n2
              nn3 = n3
              j = 1
            else if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
            do i=1,3
              smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
            end do
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)  &
                           + zinv(3,j)*smod(3)
 
          end do
        end do
      end do
 
      ! determine error from symmetry for n0=0 and n1>1, n2>1 
      derr(r)=derr(r-1)
      derr2(r)=derr2(r-1)
      n0=0
      do n1=0,r-2*n0
        do n2=0,r-2*n0-n1
          n3 = r-2*n0-n1-n2
          if (n1.ge.1.and.n2+n3.ge.1) then
         
            if (n2.ge.1) then
              nn1 = n1
              nn2 = n2-1
              nn3 = n3
              j = 2
            else
              nn1 = n1
              nn2 = n2
              nn3 = n3-1
              j = 3
            end if
 
            do i=1,3
              smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
            end do
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
            else            
              smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
            else
              smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
            end if
 
            if (nn3.ge.1) then
              smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
            else
              smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
            end if
          
            d_alt(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)  &
                           + zinv(3,j)*smod(3)
 
            derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
            derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
 
!            write(*,*) 'CalcDpv: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
!                        D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
 
 
          end if
        end do
      end do
 
      if(r.ge.2)then
        d00_err(r) = max(abs(m02)*dij_err(r-2), cerr_i(r-2,0),    &
              azadjff/adetz*dij_err(r-2),             &
              maxzadjf/adetz*max(d00_err(r-1),cij_err(r-2)))
      else
        d00_err(r) = 0d0
      end if
      dij_err(r) = max(maxzadjf*dij_err(r-1),   &
              maxzadj*max(d00_err(r),cij_err(r-1)))/adetz
 
      if(r.ge.2)then
        d00_err2(r) = max(abs(m02)*dij_err2(r-2), cerr2_i(r-2,0),    &
              azadjff/adetz*dij_err2(r-2),             &
              maxzadjf/adetz*max(d00_err2(r-1),cij_err2(r-2)))
      else
        d00_err2(r) = 0d0
      end if
      dij_err2(r) = max(maxzadjf*dij_err2(r-1),   &
              maxzadj*max(d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
    end do
    
      ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
!    do r=rmax+1,2*rmax
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
          end do
        end do
      end do
    end do
 
#ifdef Dpvtest
    write(*,*) 'CalcDpv Derrsym',derr
    write(*,*) 'CalcDpv Daccsym',derr/abs(d(0,0,0,0))
 
!    write(*,*) 'Dij_err_jj',maxZadjf*Dij_err/adetZ
!    write(*,*) 'Dij_err_00',maxZadj*D00_err(1:rmax)/adetZ
!    write(*,*) 'Dij_err_cc',maxZadj*Cij_err/adetZ
 
    write(*,*) 'CalcDpv Dijerr',dij_err(1:rmax)
    write(*,*) 'CalcDpv Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
#endif
 
    derr2 = max(derr2,dij_err2(0:rmax))
    derr = max(derr,dij_err(0:rmax))
 
#ifdef Dpvtest
    write(*,*) 'CalcDpv Derr',derr
    write(*,*) 'CalcDpv Dacc',derr/abs(d(0,0,0,0))
#endif
 
    if (id.eq.0) then
    write(*,*) 'CalcDpv Derr ',derr
    write(*,*) 'CalcDpv Derr2',derr2
    end if
    
  end subroutine calcdpv
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDpv2(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
  subroutine calcdpv2(D,Duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,Derr,Derr2)
 
    use globald
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out)  :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: D0_coli, elimminf2_coli
    double complex :: Daux(1:rmax/2+1,0:rmax-1,0:rmax-1,0:rmax-1), Smod(3)
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    integer :: rmaxC,r,n0,n1,n2,n3,k
    integer :: bin,nid(0:3)
 
#ifdef Dpv2test
    write(*,*) 'CalcDpv2 in'
#endif
!    write(*,*) 'CalcDpv2 in', rmax, id
 
    ! calculation of scalar coefficient
    d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
    duv(0,0,0,0) = 0d0
 
    ! accuracy estimate for D0 function
    derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
    derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
 
    if (rmax.eq.0) return
 
    ! allocation of C functions
    rmaxc = rmax-1
    ! rmaxC = max(rmax-1,0)
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmax+1))
    allocate(dij_err(0:rmax))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmax+1))
    allocate(dij_err2(0:rmax))
    allocate(cij_err2(0:rmaxc))
   
 
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
    
    ! determine inverse modified Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
    ! calculate Duv
    call calcduv(duv,cuv_0,mm02,mx(1:3,0),rmax,id)    
 
    ! initialization of error propagation
 
!    adetX = abs(chdet(4,mx))
!    maxZadjf=maxval(abs(mxinv(0,1:3)))*adetX
!    maxXadj=maxval(abs(mxinv(1:3,1:3)))*adetX
!    adetZ=abs(mxinv(0,0))*adetX
 
!    write(*,*) 'CalcDpv adetX ',adetX,maxZadjf,maxXadj,adetZ
 
    dij_err =0d0
    d00_err =0d0
    dij_err(0) = derr(0)
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    dij_err2 =0d0
    d00_err2 =0d0
    dij_err2(0) = derr2(0)
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
!   write(*,*) 'CalcDpv2 Cerr _i0=',Cerr_i(:,0)
!   write(*,*) 'CalcDpv2 Cerr2_i0=',Cerr2_i(:,0)
!   write(*,*) 'CalcDpv2 Cerr _i1=',Cerr_i(:,1)
!   write(*,*) 'CalcDpv2 Cerr2_i1=',Cerr2_i(:,1)
!   write(*,*) 'CalcDpv2 Cerr _i2=',Cerr_i(:,2)
!   write(*,*) 'CalcDpv2 Cerr2_i2=',Cerr2_i(:,2)
!   write(*,*) 'CalcDpv2 Cerr _i3=',Cerr_i(:,3)
!   write(*,*) 'CalcDpv2 Cerr2_i3=',Cerr2_i(:,3)
!   write(*,*) 'CalcDpv2 Cij_err=',Cij_err
!   write(*,*) 'CalcDpv2 Cij_err2=',Cij_err2
#ifdef Dpv2test
    write(*,*) 'CalcDpv2 Dij_err(0)=',dij_err(0)
    write(*,*) 'CalcDpv2 Dij_acc(0)=',dij_err(0)/d(0,0,0,0)
    write(*,*) 'CalcDpv2 Cij_err=',cij_err
#endif
    
    allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
 
    ! alternative PV-like reduction
    do r=1,rmax
 
      do n0=2,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            do k=1,3
              smod(k) = -c_0(n0-1,n1,n2,n3)
            end do
 
            if (n1.ge.1) then
              smod(1) = smod(1) - 2*n1*d(n0,n1-1,n2,n3)
            else
              smod(1) = smod(1) + c_i(n0-1,n2,n3,1)
            end if
 
            if (n2.ge.1) then
              smod(2) = smod(2) - 2*n2*d(n0,n1,n2-1,n3)
            else
              smod(2) = smod(2) + c_i(n0-1,n1,n3,2)
            end if
 
            if (n3.ge.1) then
              smod(3) = smod(3) - 2*n3*d(n0,n1,n2,n3-1)
            else
              smod(3) = smod(3) + c_i(n0-1,n1,n2,3)
            end if
 
            daux(n0,n1,n2,n3) = (d(n0-1,n1,n2,n3) - mxinv(1,0)*smod(1)  &
                              - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
 
          end do
        end do
      end do
 
      
      do n0=1,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (daux(n0,n1,n2,n3) + 4d0*duv(n0,n1,n2,n3)  &
                             + c_0(n0-1,n1,n2,n3))/(r-1)/2d0    
 
          end do
        end do
      end do
 
!      do n1=0,r-1
!        do n2=0,r-1-n1
!          n3 = r-1-n1-n2
!
!          do k=1,3
!            Smod(k) = -C_0(0,n1,n2,n3)
!          end do
!
!          if (n1.ge.1) then
!            Smod(1) = Smod(1) - 2*n1*D(1,n1-1,n2,n3)
!          else
!            Smod(1) = Smod(1) + C_i(0,n2,n3,1)
!          end if
!
!          if (n2.ge.1) then
!            Smod(2) = Smod(2) - 2*n2*D(1,n1,n2-1,n3)
!          else
!            Smod(2) = Smod(2) + C_i(0,n1,n3,2)
!          end if
!
!          if (n3.ge.1) then
!            Smod(3) = Smod(3) - 2*n3*D(1,n1,n2,n3-1)
!          else
!            Smod(3) = Smod(3) + C_i(0,n1,n2,3)
!          end if
!
!          Daux(1,n1,n2,n3) = (D(0,n1,n2,n3) - mxinv(1,0)*Smod(1)  &
!                             - mxinv(2,0)*Smod(2) - mxinv(3,0)*Smod(3))/mxinv(0,0)
!
!          D(0,n1+1,n2,n3) = mxinv(0,1)*Daux(1,n1,n2,n3)  &
!                          + mxinv(1,1)*Smod(1) + mxinv(2,1)*Smod(2) + mxinv(3,1)*Smod(3)
!          D(0,n1,n2+1,n3) = mxinv(0,2)*Daux(1,n1,n2,n3)  &
!                          + mxinv(1,2)*Smod(1) + mxinv(2,2)*Smod(2) + mxinv(3,2)*Smod(3)
!          D(0,n1,n2,n3+1) = mxinv(0,3)*Daux(1,n1,n2,n3)  &
!                          + mxinv(1,3)*Smod(1) + mxinv(2,3)*Smod(2) + mxinv(3,3)*Smod(3)
!
!        end do
!      end do 
      
      ! calculate D and determine error from symmetry for n0=0 and n1>0, n2>0, n3>0 
      derr(r)=derr(r-1)
      derr2(r)=derr2(r-1)
 
      do n1=0,r-1
        do n2=0,r-1-n1
          n3 = r-1-n1-n2
 
          do k=1,3
            smod(k) = -c_0(0,n1,n2,n3)
          end do
 
          if (n1.ge.1) then
            smod(1) = smod(1) - 2*n1*d(1,n1-1,n2,n3)
          else
            smod(1) = smod(1) + c_i(0,n2,n3,1)
          end if
 
          if (n2.ge.1) then
            smod(2) = smod(2) - 2*n2*d(1,n1,n2-1,n3)
          else
            smod(2) = smod(2) + c_i(0,n1,n3,2)
          end if
 
          if (n3.ge.1) then
            smod(3) = smod(3) - 2*n3*d(1,n1,n2,n3-1)
          else
            smod(3) = smod(3) + c_i(0,n1,n2,3)
          end if
 
          daux(1,n1,n2,n3) = (d(0,n1,n2,n3) - mxinv(1,0)*smod(1)  &
                             - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
 
          d(0,n1+1,n2,n3) = mxinv(0,1)*daux(1,n1,n2,n3)  &
                          + mxinv(1,1)*smod(1) + mxinv(2,1)*smod(2) + mxinv(3,1)*smod(3)
          d(0,n1,n2+1,n3) = mxinv(0,2)*daux(1,n1,n2,n3)  &
                          + mxinv(1,2)*smod(1) + mxinv(2,2)*smod(2) + mxinv(3,2)*smod(3)
          d_alt(0,n1,n2,n3+1) = mxinv(0,3)*daux(1,n1,n2,n3)  &
                          + mxinv(1,3)*smod(1) + mxinv(2,3)*smod(2) + mxinv(3,3)*smod(3)
 
          if(n3.eq.r-1) then
             d(0,0,0,r) = d_alt(0,0,0,r)          
          else
!             write(*,*) 'errsym=',abs(D(0,n1,n2,n3+1)-D_alt(0,n1,n2,n3+1)),  &
!                     D(0,n1,n2,n3+1),D_alt(0,n1,n2,n3+1)
 
             derr(r)=max(derr(r),abs(d(0,n1,n2,n3+1)-d_alt(0,n1,n2,n3+1)))
             derr2(r)=max(derr2(r),abs(d(0,n1,n2,n3+1)-d_alt(0,n1,n2,n3+1)))
          end if
 
!          write(*,*) 'Da(0,n1,n2,n3)=',n1+1,n2,n3,D(0,n1+1,n2,n3)
!          write(*,*) 'Da(0,n1,n2,n3)=',n1,n2+1,n3,D(0,n1,n2+1,n3)
!          write(*,*) 'Db(0,n1,n2,n3)=',n1,n2,n3+1,D_alt(0,n1,n2,n3+1)
 
        end do
      end do 
 
      d00_err(r+1) = max(cerr_i(r-1,0),adetx/adetz*dij_err(r-1),      &
                             maxzadjf/adetz*max(cij_err(r-1),2*d00_err(r)))/(2*r)
      dij_err(r) = max(maxzadjf*max(2*r*d00_err(r+1),cerr_i(r-1,0)),   &
              maxxadj*max(2*d00_err(r),cij_err(r-1)))/adetx
      
      d00_err2(r+1) = max(cerr2_i(r-1,0),adetx/adetz*dij_err2(r-1),      &
                             maxzadjf/adetz*max(cij_err2(r-1),2*d00_err2(r)))/(2*r)
      dij_err2(r) = max(maxzadjf*max(2*r*d00_err2(r+1),cerr2_i(r-1,0)),   &
              maxxadj*max(2*d00_err2(r),cij_err2(r-1)))/adetx*sqrt(adetz/(maxz*maxzadj))
      
#ifdef Dpv2test
      write(*,*) 'CalcDpv2 Cerr_i  ',r-1, cerr_i(r-1,0)
      write(*,*) 'CalcDpv2 Cij_err ',r-1, cij_err(r-1)
      write(*,*) 'CalcDpv2 D00_err ',r+1, d00_err(r+1)
      write(*,*) 'CalcDpv2 Dij_err ',r, dij_err(r)
      write(*,*) 'CalcDpv2 Cerr2_i ',r-1, cerr2_i(r-1,0)
      write(*,*) 'CalcDpv2 Cij_err2',r-1, cij_err2(r-1)
      write(*,*) 'CalcDpv2 D00_err2',r+1, d00_err2(r+1)
      write(*,*) 'CalcDpv2 Dij_err2',r, dij_err2(r)
#endif
 
    end do
 
      ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
!    do r=rmax+1,2*rmax
    do r=rmax+1,rmax+1
 
#ifdef Dpv2test
! pv1 version gets unstable for some cases!
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
!            write(*,*) 'D1(n0+1)',n0,n1,n2,n3
!            write(*,*) 'D1(n0+1)',(C_0(n0-1,n1,n2,n3) + 2*mm02*D(n0-1,n1,n2,n3)  &
!                + 4*Duv(n0,n1,n2,n3)  &
!                + f(1)*D(n0-1,n1+1,n2,n3) + f(2)*D(n0-1,n1,n2+1,n3)  &
!                + f(3)*D(n0-1,n1,n2,n3+1)) / (2*(r-1))
 
          end do
        end do
      end do
#endif
 
! pv2 formulas added 24.01.2016
      do n0=max(2,r-rmax),r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            do k=1,3
              smod(k) = -c_0(n0-1,n1,n2,n3)
            end do
 
            if (n1.ge.1) then
              smod(1) = smod(1) - 2*n1*d(n0,n1-1,n2,n3)
            else
              smod(1) = smod(1) + c_i(n0-1,n2,n3,1)
            end if
 
            if (n2.ge.1) then
              smod(2) = smod(2) - 2*n2*d(n0,n1,n2-1,n3)
            else
              smod(2) = smod(2) + c_i(n0-1,n1,n3,2)
            end if
 
            if (n3.ge.1) then
              smod(3) = smod(3) - 2*n3*d(n0,n1,n2,n3-1)
            else
              smod(3) = smod(3) + c_i(n0-1,n1,n2,3)
            end if
 
            daux(n0,n1,n2,n3) = (d(n0-1,n1,n2,n3) - mxinv(1,0)*smod(1)  &
                              - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
 
          end do
        end do
      end do
 
      
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (daux(n0,n1,n2,n3) + 4d0*duv(n0,n1,n2,n3)  &
                             + c_0(n0-1,n1,n2,n3))/(r-1)/2d0    
 
#ifdef Dpv2test
!            write(*,*) 'D2(n0+1)',n0,n1,n2,n3
!            write(*,*) 'D2(n0+1)',(Daux(n0,n1,n2,n3) + 4d0*Duv(n0,n1,n2,n3)  &
!                             + C_0(n0-1,n1,n2,n3))/(r-1)/2d0
#endif
          end do
        end do
      end do
 
    end do
 
#ifdef Dpv2test
    write(*,*) 'CalcDpv2 Derrsym',derr
    write(*,*) 'CalcDpv2 Daccsym',derr/abs(d(0,0,0,0))
    write(*,*) 'CalcDpv2 Derr2sym',derr2
    write(*,*) 'CalcDpv2 Dacc2sym',derr2/abs(d(0,0,0,0))
 
    write(*,*) 'CalcDpv2 Dijerr',dij_err
    write(*,*) 'CalcDpv2 Dijacc',dij_err/abs(d(0,0,0,0))
#endif
    
    derr2 = max(derr2,dij_err2(0:rmax))
    derr = max(derr,dij_err(0:rmax))
 
#ifdef Dpv2test
!    write(*,*) 'CalcDpv2 D(0,0,0,0) = ',D(0,0,0,0)
!    if(rmax.ge.2)then
!      write(*,*) 'CalcDpv2 D(1,0,1,0) = ',D(1,0,1,0)
!    endif
!    if(rmax.ge.3)then
!      write(*,*) 'CalcDpv2 D(0,1,1,1) = ',D(0,1,1,1)
!    endif
 
    write(*,*) 'CalcDpv2 Derr ',derr
    write(*,*) 'CalcDpv2 Dacc ',derr/abs(d(0,0,0,0))
    write(*,*) 'CalcDpv2 Derr2',derr2
    write(*,*) 'CalcDpv2 Dacc2',derr2/abs(d(0,0,0,0))
#endif
 
!    write(*,*) 'CalcDpv2 Derr ',Derr
!    write(*,*) 'CalcDpv2 Derr2',Derr2
    
  end subroutine calcdpv2
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDg(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordg_min,ordg_max,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdg(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordg_min,ordg_max,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,ordg_min,ordg_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex :: Zadjfj,Zadj2(4), Zadjkl, Xtilde
    double complex, allocatable :: Dexpg(:,:,:,:,:), DuvExpg(:,:,:,:)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3), Skl, DexpgAux
    double complex :: cC0f, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg
    integer :: inds0(3), inds(3), inds2(2,4)
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgtest
    write(*,*) 'CalcDg in, ord',rmax,ordg_min,ordg_max
#endif
 
    ! allocation of C functions
    rmaxc = rmax + ordg_min
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax) = acc_req_cind
    if (x_g.ne.0d0) then
      do r=rmax+1,rmaxc
        acc_req_cextra(r)= acc_req_cextra(r-1)/x_g
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+1:rmaxc) = acc_inf
    end if
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
 
    ! calculate adjugated Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q10+q20-q21
!    Z(3,1) = q10+q30-q31
!    Z(1,2) = Z(2,1)
!    Z(2,2) = 2d0*q20
!    Z(3,2) = q20+q30-q32
!    Z(1,3) = Z(3,1)
!    Z(2,3) = Z(3,2)
!    Z(3,3) = 2d0*q30
 
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
 
!    Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
!    Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
!    Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
!    Zadj(1,2) = Zadj(2,1)
!    Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
!    Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
!    Zadj(1,3) = Zadj(3,1)
!    Zadj(2,3) = Zadj(3,2)
!    Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
      
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
            end if
 
            if(n3.eq.0) then
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
            end if
 
          end do
        end do
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
      j = 1
    else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
      j = 2
    else
      j = 3
    end if
 
    maxzadj = 0d0
    if (abs(zadj(1,1)).gt.maxzadj) then
      maxzadj = abs(zadj(1,1))
      k = 1
      l = 1
      inds2 = reshape((/2,2,2,3,3,2,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,2)
      zadj2(3) = z(2,3)
      zadj2(4) = -z(2,2)
    end if
    if (abs(zadj(2,2)).gt.maxzadj) then
      maxzadj = abs(zadj(2,2))
      k = 2
      l = 2
      inds2 = reshape((/1,1,1,3,3,1,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,1)
      zadj2(3) = z(1,3)
      zadj2(4) = -z(1,1)
    end if
    if (abs(zadj(3,3)).gt.maxzadj) then
      maxzadj = abs(zadj(3,3))
      k = 3
      l = 3
      inds2 = reshape((/1,1,1,2,2,1,2,2/),shape(inds2))
      zadj2(1) = -z(2,2)
      zadj2(2) = z(2,1)
      zadj2(3) = z(1,2)
      zadj2(4) = -z(1,1)
    end if
    if (abs(zadj(1,2)).gt.maxzadj) then
      maxzadj = abs(zadj(1,2))
      k = 1
      l = 2
      inds2 = reshape((/2,1,2,3,3,1,3,3/),shape(inds2))
      zadj2(1) = z(3,3)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(2,3)
      zadj2(4) = z(2,1)
    end if
    if (abs(zadj(1,3)).gt.maxzadj) then
      maxzadj = abs(zadj(1,3))
      k = 1
      l = 3
      inds2 = reshape((/2,1,2,2,3,1,3,2/),shape(inds2))
      zadj2(1) = -z(3,2)
      zadj2(2) = z(3,1)
      zadj2(3) = z(2,2)
      zadj2(4) = -z(2,1)
    end if
    if (abs(zadj(2,3)).gt.maxzadj) then
      k = 2
      l = 3
      inds2 = reshape((/1,1,1,2,3,1,3,2/),shape(inds2))
      zadj2(1) = z(3,2)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(1,2)
      zadj2(4) = z(1,1)
    end if
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
    xtilde = xadj(k,l)
 
!    write(*,*) 'CalcDg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpg(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordg_max))
 
 
    ! calculate Duv
    allocate(duvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpg,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpg(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
     
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
     
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
#ifdef Dgtest
    write(*,*) 'CalcDg Cij_err = ',cij_err 
    write(*,*) 'CalcDg C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
    write(*,*) 'CalcDg C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
#endif
 
!    maxZadj = maxval(abs(Zadj))
!    maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
    truncfacexp = sqrt(fac_g) * truncfacd
    gtrunc = ordg_max 
 
! calculate D(n0,n1,n2,n3) up to rank r for n0>0 and up to rank r-1 for n0=0
    rloop: do r=1,rmaxexp
 
#ifdef Dgtest
!      write(*,*) 'CalcDg rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
#ifdef Dgtest
      write(*,*) 'CalcDg rloop',r
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
      ! exploiting eq. (5.40)
      maxdexpg(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3=r-2*n0-n1-n2
 
            inds0(1) = n1
            inds0(2) = n2
            inds0(3) = n3
 
            dexpgaux = 2d0*zadj(k,l)*c_0(n0-1,n1,n2,n3)  & 
                     + xtilde*dexpg(n0-1,n1,n2,n3,0)  &
                     + 4d0*zadj(k,l)*duvexpg(n0,n1,n2,n3)
 
            inds = inds0
            inds(k) = inds(k)+1
            do i=1,3
              dexpgaux = dexpgaux + zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
            end do
 
            do i=1,3
              inds = inds0
              inds(i) = inds(i)+1
              dexpgaux = dexpgaux - zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
            end do
 
            do i=1,4
              n = inds2(1,i)
              m = inds2(2,i)
 
              skl = f(n)*shat(n0-1,inds0(1),inds0(2),inds0(3),m)
 
              inds = inds0
              if (inds(m).ge.1) then
                inds(m) = inds(m)-1
                skl = skl - 2d0*f(n)*inds0(m)*dexpg(n0,inds(1),inds(2),inds(3),0)
                if (inds(n).ge.1) then
                  inds(n) = inds(n)-1
                  skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpg(n0+1,inds(1),inds(2),inds(3),0)
                end if
              end if
              inds = inds0
              if (inds(n).ge.1) then
                inds(n) = inds(n)-1
                skl = skl + 2d0*inds0(n)*shat(n0,inds(1),inds(2),inds(3),m)  &
                          - 2d0*f(m)*inds0(n)*dexpg(n0,inds(1),inds(2),inds(3),0)
              end if
 
              dexpgaux = dexpgaux - zadj2(i)*skl
 
            end do
 
            dexpg(n0,n1,n2,n3,0) = dexpgaux/(2d0*zadjkl)/(2d0*(r-n0))
 
            if (n0.eq.1) then
              maxdexpg(1,r,0) =  maxdexpg(1,r,0) + abs(dexpg(n0,n1,n2,n3,0) )
            end if
 
            if (r-n0.le.rmax) then
              d(n0,n1,n2,n3) = dexpg(n0,n1,n2,n3,0)
            end if
 
          end do
        end do
      end do
 
      ! calculate
      ! D_00ijkl.. --> D_aijkl..
      ! exploiting eq. (5.38)
      maxdexpg(0,r-1,0)=0d0
      do n1=0,r-1
        do n2=0,r-1-n1
          n3 = r-1-n1-n2
 
          smod = shat(0,n1,n2,n3,:)
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*dexpg(1,n1-1,n2,n3,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*dexpg(1,n1,n2-1,n3,0)
          end if
          if (n3.ge.1) then
            smod(3) = smod(3) - 2d0*n3*dexpg(1,n1,n2,n3-1,0)
          end if
 
          dexpg(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                              +  zadj(3,j)*smod(3))/zadjfj
          maxdexpg(0,r-1,0) =  maxdexpg(0,r-1,0) + abs(dexpg(0,n1,n2,n3,0))
          if (r.le.rmax+1) then
            d(0,n1,n2,n3) = dexpg(0,n1,n2,n3,0)
          end if
 
 
#ifdef Dgtest
          if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) then 
            write(*,*) 'D2(0,0,0,0)= ',0,d(n0,n1,n2,n3),detz/zadjfj
!            write(*,*) 'D2(0,0,0,0)= ',Smod
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,j),Zadjfj
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,j)/Zadjfj
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,j)/Zadjfj, &
!               Smod(2)*Zadj(2,j)/Zadjfj, Smod(3)*Zadj(3,j)/Zadjfj
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,j)/Zadjfj+ &
!               Smod(2)*Zadj(2,j)/Zadjfj+ Smod(3)*Zadj(3,j)/Zadjfj
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,1),Zadjf(1)
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,1)/Zadjf(1)
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,1)/Zadjf(1), &
!               Smod(2)*Zadj(2,1)/Zadjfj, Smod(3)*Zadj(3,1)/Zadjf(1)
!             write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,1)/Zadjf(1)+ &
!               Smod(2)*Zadj(2,1)/Zadjfj+ Smod(3)*Zadj(3,1)/Zadjf(1)
!             write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,2),Zadjf(2)
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,2)/Zadjf(2)
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,2)/Zadjf(2), &
!               Smod(2)*Zadj(2,2)/Zadjfj, Smod(3)*Zadj(3,2)/Zadjf(2)
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,2)/Zadjf(2)+ &
!               Smod(2)*Zadj(2,2)/Zadjfj+ Smod(3)*Zadj(3,2)/Zadjf(2)
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,3),Zadjf(3)
!            write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,3)/Zadjf(3)
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,3)/Zadjf(3), &
!               Smod(2)*Zadj(2,3)/Zadjfj, Smod(3)*Zadj(3,3)/Zadjf(3)
!            write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,3)/Zadjf(3)+ &
!               Smod(2)*Zadj(2,3)/Zadjfj+ Smod(3)*Zadj(3,3)/Zadjf(3)
          end if
#endif
 
        end do
      end do
 
#ifdef Dgtest
      write(*,*) 'CalcDg maxDexpg 0',r-1, maxdexpg(0,r-1,0)
#endif
 
      if(r.le.rmax+1) then
!       Derr(r-1) =  abs(detZ/Zadjfj)*maxDexpg(0,r-1,0)
        derr(r-1) =  fac_g*maxdexpg(0,r-1,0)
      endif
 
 
      ! error propagation from C's
      if(r.gt.1)then
        d00_err(r) = max(cij_err(r-1),cij_err(r-2),        &
            max(maxzadj*cij_err(r-1),maxzadj2f*cij_err(r-2))/abs(zadjkl)) &
            /(4*(r-1))
      end if
      dij_err(r-1)=maxzadj*max(cij_err(r-1),2*d00_err(r))/abs(zadjfj)
 
      if(r.gt.1)then
        d00_err2(r) = max(cij_err2(r-1),cij_err2(r-2),        &
            max(maxzadj*cij_err2(r-1),maxzadj2f*cij_err2(r-2))/abs(zadjkl)) &
            /(4*(r-1))
 
      end if
      dij_err2(r-1)=maxzadj*max(cij_err2(r-1),2*d00_err2(r))/abs(zadjfj)
 
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
 
#ifdef  Dgtest
        write(*,*) 'gloop ',g,rg
#endif
 
        ! calculating
        ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
        ! exploiting eq. (5.40)
        maxdexpg(1,rg,g) = 0d0
        do n0=rg/2,1,-1
          do n1=0,rg-2*n0
            do n2=0,rg-2*n0-n1
              n3=rg-2*n0-n1-n2
 
              inds0(1) = n1
              inds0(2) = n2
              inds0(3) = n3
 
              inds = inds0
              inds(k) = inds(k)+1
              inds(l) = inds(l)+1
              dexpgaux = xtilde*dexpg(n0-1,n1,n2,n3,g)  &
                       - detz*dexpg(n0-1,inds(1),inds(2),inds(3),g-1)
 
 
              do i=1,4
                n = inds2(1,i)
                m = inds2(2,i)
 
                skl = 0d0
 
                inds = inds0
                if (inds(m).ge.1) then
                  inds(m) = inds(m)-1
                  skl = skl - 2d0*f(n)*inds0(m)*dexpg(n0,inds(1),inds(2),inds(3),g)
                  if (inds(n).ge.1) then
                    inds(n) = inds(n)-1
                    skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpg(n0+1,inds(1),inds(2),inds(3),g)
                  end if
                end if
                inds = inds0
                if (inds(n).ge.1) then
                  inds(n) = inds(n)-1
                  skl = skl - 2d0*f(m)*inds0(n)*dexpg(n0,inds(1),inds(2),inds(3),g)
                end if
 
                dexpgaux = dexpgaux - zadj2(i)*skl
 
              end do
 
              dexpg(n0,n1,n2,n3,g) = dexpgaux/(2d0*zadjkl)/(2d0*(rg-n0))
 
               
              if(n0.eq.1) then
                maxdexpg(1,rg,g) =  maxdexpg(1,rg,g) + abs(dexpg(n0,n1,n2,n3,g))
 
                if (g.eq.1.and.abs(dexpg(1,n1,n2,n3,g)).gt.            &
                    truncfacexp*max(1/m2scale,maxdexpg(1,rg,g-1)) .or. &
                    g.ge.2.and.abs(dexpg(1,n1,n2,n3,g)).gt.            &
                    truncfacexp*maxdexpg(1,rg,g-1)) then
 
#ifdef Dgtest
                  write(*,*) 'CalcDg exit gloop',n0,n1,n2,n3,g,abs(dexpg(n0,n1,n2,n3,g)),maxdexpg(1,rg,g-1),truncfacexp
#endif      
 
                  gtrunc = g-1
                  exit gloop
                end if
              end if
 
            end do
          end do
        end do
 
#ifndef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              do n2=0,rg-2*n0-n1
                n3=rg-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpg(n0,n1,n2,n3,g)
              end do
            end do
          end if
        end do
#endif
!        write(*,*) 'CalcDg after it1 ',rg
 
        ! calculate
        ! D_00ijkl.. --> D_aijkl..
        ! exploiting eq. (5.38)
 
!        write(*,*) 'CalcDg maxDexp',rg-1,g-1,maxDexpg(0,rg-1,g-1)
 
        maxdexpg(0,rg-1,g) = 0d0
        do n1=0,rg-1
          do n2=0,rg-1-n1
            n3 = rg-1-n1-n2
 
            smod = 0d0
            if (n1.ge.1) then
              smod(1) = smod(1) - 2d0*n1*dexpg(1,n1-1,n2,n3,g)
            end if
            if (n2.ge.1) then
              smod(2) = smod(2) - 2d0*n2*dexpg(1,n1,n2-1,n3,g)
            end if
            if (n3.ge.1) then
              smod(3) = smod(3) - 2d0*n3*dexpg(1,n1,n2,n3-1,g)
            end if
 
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
            inds(j) = inds(j)+1
            dexpg(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                                +  zadj(3,j)*smod(3)  &
                                - detz*dexpg(0,inds(1),inds(2),inds(3),g-1))/zadjfj
 
            maxdexpg(0,rg-1,g) =  maxdexpg(0,rg-1,g) + abs(dexpg(0,n1,n2,n3,g))
 
!              if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then 
!                write(*,*) 'D2(2,3,3)= ',g,Dexpg(0,n1,n2,n3,g)
!                write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                +  Zadj(3,j)*Smod(3)/Zadjfj,  &
!                                - detZ*Dexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
!                write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3),         &
!                                - detZ/Zadjfj,Dexpg(0,inds(1),inds(2),inds(3),g-1)
!              end if
 
            if (g.eq.1.and.abs(dexpg(0,n1,n2,n3,g)).gt.                  &
                truncfacexp*max(1/m2scale**2,maxdexpg(0,rg-1,g-1)) .or.  &
                g.ge.2.and.abs(dexpg(0,n1,n2,n3,g)).gt.                  &
                truncfacexp*maxdexpg(0,rg-1,g-1)) then
 
#ifdef Dgtest
                  write(*,*) 'CalcDg exit gloop',0,n1,n2,n3,g,abs(dexpg(0,n1,n2,n3,g)),maxdexpg(0,rg-1,g-1),truncfacexp
#endif      
              gtrunc = g-1
              exit gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.1)then
!          D00_err(rg) = max( D00_err(rg),                                &
!              max( abs(m02)*Dij_err(rg-2),                               &
!              max( abs(detZ)*Dij_err(rg),abs(Xtilde)*Dij_err(rg-2),      &
!              maxZadj2f*D00_err(rg-1) ) / abs(Zadjkl) )                  &
!              /(4*(rg-1))   )
! 06.05.15 ->
          d00_err(rg) = max( d00_err(rg),                                &
              max( abs(detz)*dij_err(rg),abs(xtilde)*dij_err(rg-2),      &
              maxzadj2f*d00_err(rg-1) ) / abs(zadjkl)                   &
              /(4*(rg-1))   )
        end if
        dij_err(rg-1)=max(dij_err(rg-1),                &
            max(2*maxzadj*d00_err(rg),abs(detz)*dij_err(rg))/abs(zadjfj) )
 
        if(rg.gt.1)then
          d00_err2(rg) = max( d00_err2(rg),                                &
              max( abs(detz)*dij_err2(rg),abs(xtilde)*dij_err2(rg-2),      &
              maxzadj2f*d00_err2(rg-1) ) / abs(zadjkl)                   &
              /(4*(rg-1))   )
        end if
        dij_err2(rg-1)=max(dij_err2(rg-1),                &
            max(2*maxzadj*d00_err2(rg),abs(detz)*dij_err2(rg))/abs(zadjfj) )
 
#ifdef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              do n2=0,rg-2*n0-n1
                n3=rg-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpg(n0,n1,n2,n3,g)
              end do
            end do
          end if
        end do
#endif
!        write(*,*) 'CalcDg after it1 ',rg
        if ((rg.le.rmax+1)) then
          derr(rg-1) = 0d0
          do n1=0,rg-1
            do n2=0,rg-1-n1
              n3 = rg-1-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpg(0,n1,n2,n3,g)
!              Derr(rg-1)=max(Derr(rg-1),abs(Dexpg(0,n1,n2,n3,g))**2/abs(Dexpg(0,n1,n2,n3,g-1)))
              if(abs(dexpg(0,n1,n2,n3,g-1)).ne.0d0) then
                derr(rg-1)=max(derr(rg-1),abs(dexpg(0,n1,n2,n3,g))*min(1d0,abs(dexpg(0,n1,n2,n3,g))/abs(dexpg(0,n1,n2,n3,g-1))))
              else
                derr(rg-1)=max(derr(rg-1),abs(dexpg(0,n1,n2,n3,g)))
              endif
 
#ifdef Dgtest
!              write(*,*) 'CalcDg Derr calc',rg-1,Derr(rg-1),n1,n2,n3,abs(Dexpg(0,n1,n2,n3,g)),abs(Dexpg(0,n1,n2,n3,g-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
#ifdef PVEST2
          if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
#else
          if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
#endif
            gtrunc = min(g,gtrunc)
             
#ifdef Dgtest
             write(*,*) 'CalcDg exit err',r,rg-1,g,gtrunc,dij_err(rg-1),derr(rg-1)
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgtest
      write(*,*) 'CalcDg D(0,0,0,0) = ',r,d(0,0,0,0)
    if(r.gt.1)then
!      write(*,*) 'CalcDg D(0,1,0,0) = ',r,D(0,1,0,0)
      write(*,*) 'CalcDg D(0,0,1,0) = ',r,d(0,0,1,0)
    endif
    if(r.gt.2.and.rmax.ge.2)then
      write(*,*) 'CalcDg D(1,0,0,0) = ',r,d(1,0,0,0)
      write(*,*) 'CalcDg D(0,2,0,0) = ',r,d(0,2,0,0)
      write(*,*) 'CalcDg D(0,0,1,1) = ',r,d(0,0,1,1)
!      write(*,*) 'CalcDg D(0,1,1,0) = ',r,D(0,1,1,0)
      write(*,*) 'CalcDg D(0,0,2,0) = ',r,d(0,0,2,0)
    endif
    if(r.gt.3.and.rmax.ge.3)then
      write(*,*) 'CalcDg D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDg D(1,1,0,0) = ',r,d(1,1,0,0)
      write(*,*) 'CalcDg D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDg D(1,0,0,1) = ',r,d(1,0,0,1)
!      write(*,*) 'CalcDg D(1,2,0,0) = ',r,D(1,2,0,0)
      write(*,*) 'CalcDg D(0,3,0,0) = ',r,d(0,3,0,0)
      write(*,*) 'CalcDg D(0,2,1,0) = ',r,d(0,2,1,0)
      write(*,*) 'CalcDg D(0,2,0,1) = ',r,d(0,2,0,1)
      write(*,*) 'CalcDg D(0,0,3,0) = ',r,d(0,0,3,0)
      write(*,*) 'CalcDg D(0,1,1,1) = ',r,d(0,1,1,1)
      write(*,*) 'CalcDg D(0,0,2,1) = ',r,d(0,0,2,1)
    endif
      write(*,*) 'CalcDg Dij_err',r,dij_err
      write(*,*) 'CalcDg Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDg err',r,derr
      write(*,*) 'CalcDg acc',r,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
#ifdef Dgtest
      write(*,*) 'CalcDg exit r',r,maxval(derr),maxval(derr2),acc_req_d*abs(d(0,0,0,0))
#endif
 
!     if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit   ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
 
        if (r.lt.rmax) then
          do rg=r+1,rmax
!          write(*,*) 'CalcDg exit rloop  =',rg,r,rmax
            do n0=0,rg/2
              do n1=0,rg-2*n0
                do n2=0,rg-2*n0-n1
                  d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
                end do
              end do
            end do
          end do
          if(r.le.rmax) then
            do n1=0,r
              do n2=0,r-n1
                d(0,n1,n2,r-n1-n2)=0d0
              end do
            end do
          end if
 
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDg',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDg:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDg: p10 = ',p10
            write(nerrout_coli,111)' CalcDg: p21 = ',p21
            write(nerrout_coli,111)' CalcDg: p32 = ',p32
            write(nerrout_coli,111)' CalcDg: p30 = ',p30
            write(nerrout_coli,111)' CalcDg: p20 = ',p20
            write(nerrout_coli,111)' CalcDg: p31 = ',p31
            write(nerrout_coli,111)' CalcDg: m02 = ',m02
            write(nerrout_coli,111)' CalcDg: m12 = ',m12
            write(nerrout_coli,111)' CalcDg: m22 = ',m22
            write(nerrout_coli,111)' CalcDg: m32 = ',m32
          end if
        end if
 
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
 
    ! reduction formula (5.10) for n0+n1+n2+N3=r, n0>=1 only!!!!!! 
    ! already calculated for rmax+1
!    do r=rmax+1,2*rmax 
#ifdef notneeded
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            write(*,*) 'CalcDg exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
            write(*,*) 'CalcDg dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
          end do
        end do
      end do
    end do
#endif
 
#ifdef Dgtest
    write(*,*) 'CalcDg D(0,0,0,0) = ',d(0,0,0,0)
    if(rmax.ge.3)then
      write(*,*) 'CalcDg D(1,0,1,0) = ',d(1,0,1,0)
    endif
 
    write(*,*) 'CalcDg final err ',derr
    write(*,*) 'CalcDg final acc ',derr/abs(d(0,0,0,0))
    write(*,*) 'CalcDg final err2',derr2
    write(*,*) 'CalcDg final acc2',derr2/abs(d(0,0,0,0))
#endif      
       
!    write(*,*) 'CalcDg Derr ',Derr
!    write(*,*) 'CalcDg Derr2',Derr2
           
  end subroutine calcdg
 
 
#ifdef USEGM
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgm(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordgm_min,ordgm_max,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgm(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgm_min,ordgm_max,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,ordgm_min,ordgm_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax) 
    double complex :: Zadjfj,Zadj2(4), Zadjkl, Xtilde
    double complex, allocatable :: Dexpgm(:,:,:,:,:), DuvExpgm(:,:,:,:)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:), Cerr2_i(:,:)
    double complex :: Smod(3), Skl, DexpgmAux
    double complex :: cC0f, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpgm(0:1,0:rmax+ordgm_min+1,0:ordgm_max),truncfacexp
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,gm,rgm
    integer :: inds0(3), inds(3), inds2(2,4)
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgmtest
    write(*,*) 'CalcDgm in, ord',rmax,ordgm_min,ordgm_max
#endif
 
    ! allocation of C functions
    rmaxc = rmax + ordgm_min
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax) = acc_req_cind
    if (x_gm.ne.0d0) then
      do r=rmax+1,rmaxc
        acc_req_cextra(r)= acc_req_cextra(r-1)/x_gm
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+1,rmaxc) = acc_inf
    end if
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
            end if
 
            if(n3.eq.0) then
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
            end if
 
          end do
        end do
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
!    if (abs(Zadjf(1)).ge.max(abs(Zadjf(2)),abs(Zadjf(3)))) then
!      j = 1
!    else if (abs(Zadjf(2)).ge.max(abs(Zadjf(1)),abs(Zadjf(3)))) then
!      j = 2
!    else
!      j = 3
!    end if
 
    zadjff = zadjf(1)*f(1)+  zadjf(2)*f(2)+ zadjf(3)*f(3) 
 
    maxzadj = 0d0
    if (abs(zadj(1,1)).gt.maxzadj) then
      maxzadj = abs(zadj(1,1))
      k = 1
      l = 1
      inds2 = reshape((/2,2,2,3,3,2,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,2)
      zadj2(3) = z(2,3)
      zadj2(4) = -z(2,2)
    end if
    if (abs(zadj(2,2)).gt.maxzadj) then
      maxzadj = abs(zadj(2,2))
      k = 2
      l = 2
      inds2 = reshape((/1,1,1,3,3,1,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,1)
      zadj2(3) = z(1,3)
      zadj2(4) = -z(1,1)
    end if
    if (abs(zadj(3,3)).gt.maxzadj) then
      maxzadj = abs(zadj(3,3))
      k = 3
      l = 3
      inds2 = reshape((/1,1,1,2,2,1,2,2/),shape(inds2))
      zadj2(1) = -z(2,2)
      zadj2(2) = z(2,1)
      zadj2(3) = z(1,2)
      zadj2(4) = -z(1,1)
    end if
    if (abs(zadj(1,2)).gt.maxzadj) then
      maxzadj = abs(zadj(1,2))
      k = 1
      l = 2
      inds2 = reshape((/2,1,2,3,3,1,3,3/),shape(inds2))
      zadj2(1) = z(3,3)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(2,3)
      zadj2(4) = z(2,1)
    end if
    if (abs(zadj(1,3)).gt.maxzadj) then
      maxzadj = abs(zadj(1,3))
      k = 1
      l = 3
      inds2 = reshape((/2,1,2,2,3,1,3,2/),shape(inds2))
      zadj2(1) = -z(3,2)
      zadj2(2) = z(3,1)
      zadj2(3) = z(2,2)
      zadj2(4) = -z(2,1)
    end if
    if (abs(zadj(2,3)).gt.maxzadj) then
      k = 2
      l = 3
      inds2 = reshape((/1,1,1,2,3,1,3,2/),shape(inds2))
      zadj2(1) = z(3,2)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(1,2)
      zadj2(4) = z(1,1)
    end if
 
!    Zadjfj = Zadjf(j)
    zadjkl = zadj(k,l)
    xtilde = xadj(k,l)
 
!    write(*,*) 'CalcDgm Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpgm(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgm_max))
 
 
    ! calculate Duv
    allocate(duvexpgm(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpgm,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgm(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
     
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
#ifdef Dgmtest
    write(*,*) 'CalcDgm Cij_err = ',cij_err 
    write(*,*) 'CalcDgm C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
    write(*,*) 'CalcDgm C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
#endif
 
!    maxZadj = maxval(abs(Zadj))
!    maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
    truncfacexp = sqrt(fac_gm) * truncfacd
    gtrunc = ordgm_max 
 
! calculate D(n0,n1,n2,n3) up to rank r for n0>0 and up to rank r-1 for n0=0
    rloop: do r=1,rmaxexp
 
#ifdef Dgmtest
!      write(*,*) 'CalcDgm rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
#ifdef Dgmtest
      write(*,*) 'CalcDgm rloop',r
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
      ! exploiting eq. (5.40)
      maxdexpgm(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3=r-2*n0-n1-n2
 
            inds0(1) = n1
            inds0(2) = n2
            inds0(3) = n3
 
            dexpgmaux = 2d0*zadj(k,l)*c_0(n0-1,n1,n2,n3)  & 
                     + xtilde*dexpgm(n0-1,n1,n2,n3,0)  &
                     + 4d0*zadj(k,l)*duvexpgm(n0,n1,n2,n3)
 
            inds = inds0
            inds(k) = inds(k)+1
            do i=1,3
              dexpgmaux = dexpgmaux + zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
            end do
 
            do i=1,3
              inds = inds0
              inds(i) = inds(i)+1
              dexpgmaux = dexpgmaux - zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
            end do
 
            do i=1,4
              n = inds2(1,i)
              m = inds2(2,i)
 
              skl = f(n)*shat(n0-1,inds0(1),inds0(2),inds0(3),m)
 
              inds = inds0
              if (inds(m).ge.1) then
                inds(m) = inds(m)-1
                skl = skl - 2d0*f(n)*inds0(m)*dexpgm(n0,inds(1),inds(2),inds(3),0)
                if (inds(n).ge.1) then
                  inds(n) = inds(n)-1
                  skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpgm(n0+1,inds(1),inds(2),inds(3),0)
                end if
              end if
              inds = inds0
              if (inds(n).ge.1) then
                inds(n) = inds(n)-1
                skl = skl + 2d0*inds0(n)*shat(n0,inds(1),inds(2),inds(3),m)  &
                          - 2d0*f(m)*inds0(n)*dexpgm(n0,inds(1),inds(2),inds(3),0)
              end if
 
              dexpgmaux = dexpgmaux - zadj2(i)*skl
 
            end do
 
            dexpgm(n0,n1,n2,n3,0) = dexpgmaux/(2d0*zadjkl)/(2d0*(r-n0))
 
            if (n0.eq.1) then
              maxdexpgm(1,r,0) =  maxdexpgm(1,r,0) + abs(dexpgm(n0,n1,n2,n3,0) )
            end if
 
            if (r-n0.le.rmax) then
              d(n0,n1,n2,n3) = dexpgm(n0,n1,n2,n3,0)
            end if
 
          end do
        end do
      end do
 
      ! calculate
      ! D_00ijkl.. --> D_aijkl..
      ! exploiting eq. (5.38) contracted with f(j)
      maxdexpgm(0,r-1,0)=0d0
      do n1=0,r-1
        do n2=0,r-1-n1
          n3 = r-1-n1-n2
 
          smod = shat(0,n1,n2,n3,:)
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*dexpgm(1,n1-1,n2,n3,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*dexpgm(1,n1,n2-1,n3,0)
          end if
          if (n3.ge.1) then
            smod(3) = smod(3) - 2d0*n3*dexpgm(1,n1,n2,n3-1,0)
          end if
 
          dexpgm(0,n1,n2,n3,0) = (zadjf(1)*smod(1) +  zadjf(2)*smod(2)  &
                              +  zadjf(3)*smod(3))/zadjff
          maxdexpgm(0,r-1,0) =  maxdexpgm(0,r-1,0) + abs(dexpgm(0,n1,n2,n3,0))
          if (r.le.rmax+1) then
            d(0,n1,n2,n3) = dexpgm(0,n1,n2,n3,0)
          end if
 
 
#ifdef Dgmtest
          if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) then 
            write(*,*) 'D2(0,0,0,0)= ',0,d(n0,n1,n2,n3),detz*fmax/zadjff
            write(*,*) 'D2(0,0,0,0)= ',detz,fmax,zadjff
            write(*,*) 'D2(0,0,0,0)= ',smod
            write(*,*) 'D2(0,0,0,0)= ',zadjf(1:3),zadjff
            write(*,*) 'D2(0,0,0,0)= ',zadjf(1:3)/zadjff
            write(*,*) 'D2(0,0,0,0)= ',smod(1)*zadjf(1)/zadjff, &
               smod(2)*zadjf(2)/zadjff, smod(3)*zadjf(3)/zadjff
          end if
#endif
 
        end do
      end do
 
#ifdef Dgmtest
!      write(*,*) 'CalcDgm maxDexpgm 0',r-1, maxDexpgm(0,r-1,0)
#endif
 
      if(r.le.rmax+1) then
!       Derr(r-1) =  abs(detZ/Zadjfj)*maxDexpgm(0,r-1,0)
        derr(r-1) =  fac_gm*maxdexpgm(0,r-1,0)
      endif
 
      ! error propagation from C's
      if(r.gt.1)then
        d00_err(r) = max(cij_err(r-1),cij_err(r-2),        &
            max(maxzadj*cij_err(r-1),maxzadj2f*cij_err(r-2))/abs(zadjkl)) &
            /(4*(r-1))
      end if
      dij_err(r-1)=maxzadjf*max(cij_err(r-1),2*d00_err(r))/abs(zadjff)
 
      if(r.gt.1)then
        d00_err2(r) = max(cij_err2(r-1),cij_err2(r-2),        &
            max(maxzadj*cij_err2(r-1),maxzadj2f*cij_err2(r-2))/abs(zadjkl)) &
            /(4*(r-1))
      end if
      dij_err2(r-1)=maxzadjf*max(cij_err2(r-1),2*d00_err2(r))/abs(zadjff)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rgm = r
      gloop: do gm=1,min(gtrunc,r-1)
        rgm = rgm-1
 
!        write(*,*) 'gloop ',gm,rgm
 
        ! calculating
        ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
        ! exploiting eq. (5.40)
        maxdexpgm(1,rgm,gm) = 0d0
        do n0=rgm/2,1,-1
          do n1=0,rgm-2*n0
            do n2=0,rgm-2*n0-n1
              n3=rgm-2*n0-n1-n2
 
              inds0(1) = n1
              inds0(2) = n2
              inds0(3) = n3
 
              inds = inds0
              inds(k) = inds(k)+1
              inds(l) = inds(l)+1
              dexpgmaux = xtilde*dexpgm(n0-1,n1,n2,n3,gm)  &
                       - detz*dexpgm(n0-1,inds(1),inds(2),inds(3),gm-1)
 
 
              do i=1,4
                n = inds2(1,i)
                m = inds2(2,i)
 
                skl = 0d0
 
                inds = inds0
                if (inds(m).ge.1) then
                  inds(m) = inds(m)-1
                  skl = skl - 2d0*f(n)*inds0(m)*dexpgm(n0,inds(1),inds(2),inds(3),gm)
                  if (inds(n).ge.1) then
                    inds(n) = inds(n)-1
                    skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpgm(n0+1,inds(1),inds(2),inds(3),gm)
                  end if
                end if
                inds = inds0
                if (inds(n).ge.1) then
                  inds(n) = inds(n)-1
                  skl = skl - 2d0*f(m)*inds0(n)*dexpgm(n0,inds(1),inds(2),inds(3),gm)
                end if
 
                dexpgmaux = dexpgmaux - zadj2(i)*skl
 
              end do
 
              dexpgm(n0,n1,n2,n3,gm) = dexpgmaux/(2d0*zadjkl)/(2d0*(rgm-n0))
 
               
              if(n0.eq.1) then
                maxdexpgm(1,rgm,gm) =  maxdexpgm(1,rgm,gm) + abs(dexpgm(n0,n1,n2,n3,gm))
 
                if (gm.eq.1.and.abs(dexpgm(1,n1,n2,n3,gm)).gt.            &
                    truncfacexp*max(1/m2scale,maxdexpgm(1,rgm,gm-1)) .or. &
                    gm.ge.2.and.abs(dexpgm(1,n1,n2,n3,gm)).gt.            &
                    truncfacexp*maxdexpgm(1,rgm,gm-1)) then
 
#ifdef Dgmtest
                  write(*,*) 'CalcDgm exit gloop',n0,n1,n2,n3,gm,abs(dexpgm(n0,n1,n2,n3,gm)),maxdexpgm(1,rgm,gm-1),truncfacexp
#endif      
 
                  gtrunc = gm-1
                  exit gloop
                end if
              end if
 
            end do
          end do
        end do
 
#ifndef PPEXP00
        do n0=rgm/2,1,-1
          if (rgm-n0.le.rmax) then
            do n1=0,rgm-2*n0
              do n2=0,rgm-2*n0-n1
                n3=rgm-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgm(n0,n1,n2,n3,gm)
              end do
            end do
          end if
        end do
#endif
!        write(*,*) 'CalcDgm after it1 ',rgm
 
        ! calculate
        ! D_00ijkl.. --> D_aijkl..
        ! exploiting eq. (5.38) contracted with f(j)
 
!        write(*,*) 'CalcDgm maxDexp',rgm-1,gm-1,maxDexpgm(0,rgm-1,gm-1)
 
        maxdexpgm(0,rgm-1,gm) = 0d0
        do n1=0,rgm-1
          do n2=0,rgm-1-n1
            n3 = rgm-1-n1-n2
 
            smod = 0d0
            if (n1.ge.1) then
              smod(1) = smod(1) - 2d0*n1*dexpgm(1,n1-1,n2,n3,gm)
            end if
            if (n2.ge.1) then
              smod(2) = smod(2) - 2d0*n2*dexpgm(1,n1,n2-1,n3,gm)
            end if
            if (n3.ge.1) then
              smod(3) = smod(3) - 2d0*n3*dexpgm(1,n1,n2,n3-1,gm)
            end if
 
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
!            inds(j) = inds(j)+1
            dexpgm(0,n1,n2,n3,gm) = (zadjf(1)*smod(1) +  zadjf(2)*smod(2)  &
                +  zadjf(3)*smod(3)  &
                - detz*(          &
                f(1)*dexpgm(0,inds(1)+1,inds(2),inds(3),gm-1)   &
                +f(2)*dexpgm(0,inds(1),inds(2)+1,inds(3),gm-1)   &
                +f(3)*dexpgm(0,inds(1),inds(2),inds(3)+1,gm-1))   &
            )/zadjff
 
            maxdexpgm(0,rgm-1,gm) =  maxdexpgm(0,rgm-1,gm) + abs(dexpgm(0,n1,n2,n3,gm))
 
!              if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then 
!                write(*,*) 'D2(2,3,3)= ',gm,Dexpgm(0,n1,n2,n3,gm)
!                write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                +  Zadj(3,j)*Smod(3)/Zadjfj,  &
!                                - detZ*Dexpgm(0,inds(1),inds(2),inds(3),gm-1)/Zadjfj
!                write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3),         &
!                                - detZ/Zadjfj,Dexpgm(0,inds(1),inds(2),inds(3),gm-1)
!              end if
 
            if (gm.eq.1.and.abs(dexpgm(0,n1,n2,n3,gm)).gt.                  &
                truncfacexp*max(1/m2scale**2,maxdexpgm(0,rgm-1,gm-1)) .or.  &
                gm.ge.2.and.abs(dexpgm(0,n1,n2,n3,gm)).gt.                  &
                truncfacexp*maxdexpgm(0,rgm-1,gm-1)) then
 
#ifdef Dgmtest
                  write(*,*) 'CalcDgm exit gloop',0,n1,n2,n3,gm,abs(dexpgm(0,n1,n2,n3,gm)),maxdexpgm(0,rgm-1,gm-1),truncfacexp
#endif      
              gtrunc = gm-1
              exit gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rgm.gt.1)then
          d00_err(rgm) = max( d00_err(rgm),                                &
              max( abs(m02)*dij_err(rgm-2),                               &
              max( abs(detz)*dij_err(rgm),abs(xtilde)*dij_err(rgm-2),      &
              maxzadj2f*d00_err(rgm-1) ) / abs(zadjkl) )                  &
              /(4*(rgm-1))   )
        end if
        dij_err(rgm-1)=max(dij_err(rgm-1),                &
            max(2*maxzadjf*d00_err(rgm),abs(detz*fmax)*dij_err(rgm))/abs(zadjff) )
       if(rgm.gt.1)then
          d00_err2(rgm) = max( d00_err2(rgm),                                &
              max( abs(m02)*dij_err2(rgm-2),                               &
              max( abs(detz)*dij_err2(rgm),abs(xtilde)*dij_err2(rgm-2),      &
              maxzadj2f*d00_err2(rgm-1) ) / abs(zadjkl) )                  &
              /(4*(rgm-1))   )
        end if
        dij_err2(rgm-1)=max(dij_err2(rgm-1),                &
            max(2*maxzadjf*d00_err2(rgm),abs(detz*fmax)*dij_err2(rgm))/abs(zadjff) )
 
#ifdef PPEXP00
        do n0=rgm/2,1,-1
          if (rgm-n0.le.rmax) then
            do n1=0,rgm-2*n0
              do n2=0,rgm-2*n0-n1
                n3=rgm-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgm(n0,n1,n2,n3,gm)
              end do
            end do
          end if
        end do
#endif
!        write(*,*) 'CalcDgm after it1 ',rgm
        if ((rgm.le.rmax+1)) then
          derr(rgm-1) = 0d0
          do n1=0,rgm-1
            do n2=0,rgm-1-n1
              n3 = rgm-1-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgm(0,n1,n2,n3,gm)
!              Derr(rgm-1)=max(Derr(rgm-1),abs(Dexpgm(0,n1,n2,n3,gm))**2 & 
!              /abs(Dexpgm(0,n1,n2,n3,gm-1)))
              if(abs(dexpgm(0,n1,n2,n3,gm-1)).ne.0d0) then
                derr(rgm-1)=max(derr(rgm-1),abs(dexpgm(0,n1,n2,n3,gm)) &
                    *min(1d0,abs(dexpgm(0,n1,n2,n3,gm))/abs(dexpgm(0,n1,n2,n3,gm-1))))
              else
                derr(rgm-1)=max(derr(rgm-1),abs(dexpgm(0,n1,n2,n3,gm)))
              endif
 
#ifdef Dgmtest
!              write(*,*) 'CalcDgm Derr calc',rgm-1,Derr(rgm-1),n1,n2,n3,abs(Dexpgm(0,n1,n2,n3,gm)),abs(Dexpgm(0,n1,n2,n3,gm-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
#ifdef PVEST2
          if(dij_err2(rgm-1).gt.3d0*derr(rgm-1)) then
#else
          if(dij_err(rgm-1).gt.3d0*derr(rgm-1)) then
#endif
            gtrunc = min(gm,gtrunc)
             
#ifdef Dgmtest
             write(*,*) 'CalcDgm exit err',r,rgm-1,gm,gtrunc,dij_err(rgm-1),derr(rgm-1)
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgmtest
      write(*,*) 'CalcDgm D(0,0,0,0) = ',r,d(0,0,0,0)
    if(r.gt.1)then
!      write(*,*) 'CalcDgm D(0,1,0,0) = ',r,D(0,1,0,0)
      write(*,*) 'CalcDgm D(0,0,1,0) = ',r,d(0,0,1,0)
    endif
    if(r.gt.2.and.rmax.ge.2)then
      write(*,*) 'CalcDgm D(1,0,0,0) = ',r,d(1,0,0,0)
      write(*,*) 'CalcDgm D(0,2,0,0) = ',r,d(0,2,0,0)
      write(*,*) 'CalcDgm D(0,0,1,1) = ',r,d(0,0,1,1)
!      write(*,*) 'CalcDgm D(0,1,1,0) = ',r,D(0,1,1,0)
      write(*,*) 'CalcDgm D(0,0,2,0) = ',r,d(0,0,2,0)
    endif
    if(r.gt.3.and.rmax.ge.3)then
      write(*,*) 'CalcDgm D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDgm D(1,1,0,0) = ',r,d(1,1,0,0)
      write(*,*) 'CalcDgm D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDgm D(1,0,0,1) = ',r,d(1,0,0,1)
!      write(*,*) 'CalcDgm D(1,2,0,0) = ',r,D(1,2,0,0)
      write(*,*) 'CalcDgm D(0,3,0,0) = ',r,d(0,3,0,0)
      write(*,*) 'CalcDgm D(0,2,1,0) = ',r,d(0,2,1,0)
      write(*,*) 'CalcDgm D(0,2,0,1) = ',r,d(0,2,0,1)
      write(*,*) 'CalcDgm D(0,0,3,0) = ',r,d(0,0,3,0)
      write(*,*) 'CalcDgm D(0,1,1,1) = ',r,d(0,1,1,1)
      write(*,*) 'CalcDgm D(0,0,2,1) = ',r,d(0,0,2,1)
    endif
      write(*,*) 'CalcDgm Dij_err',r,dij_err
      write(*,*) 'CalcDgm Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgm err',r,derr
      write(*,*) 'CalcDgm acc',r,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
#ifdef Dgmtest
!      write(*,*) 'CalcDgm exit r',r,maxval(Derr),acc_req_D*abs(D(0,0,0,0))
#endif
 
!     if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit   ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
 
        if (r.lt.rmax) then
          do rgm=r+1,rmax
!            write(*,*) 'CalcDgm exit rloop  =',rgm,r,rmax
            do n0=0,rgm/2
              do n1=0,rgm-2*n0
                do n2=0,rgm-2*n0-n1
                  d(n0,n1,n2,rgm-2*n0-n1-n2)=0d0
                end do
              end do
            end do
          end do
          if(r.le.rmax) then
            do n1=0,r
              do n2=0,r-n1
                d(0,n1,n2,r-n1-n2)=0d0
              end do
            end do
          end if
 
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDgm',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDgm:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDgm: p10 = ',p10
            write(nerrout_coli,111)' CalcDgm: p21 = ',p21
            write(nerrout_coli,111)' CalcDgm: p32 = ',p32
            write(nerrout_coli,111)' CalcDgm: p30 = ',p30
            write(nerrout_coli,111)' CalcDgm: p20 = ',p20
            write(nerrout_coli,111)' CalcDgm: p31 = ',p31
            write(nerrout_coli,111)' CalcDgm: m02 = ',m02
            write(nerrout_coli,111)' CalcDgm: m12 = ',m12
            write(nerrout_coli,111)' CalcDgm: m22 = ',m22
            write(nerrout_coli,111)' CalcDgm: m32 = ',m32
          end if
        end if
 
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
 
      ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
!    do r=rmax+1,2*rmax
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
          end do
        end do
      end do
    end do
 
#ifdef Dgmtest
!    write(*,*) 'CalcDgm D(0,0,0,0) = ',D(0,0,0,0)
!    if(rmax.ge.3)then
!      write(*,*) 'CalcDgm D(0,1,1,1) = ',D(0,1,1,1)
!    endif
 
!    write(*,*) 'CalcDgm final err',Derr
!    write(*,*) 'CalcDgm final acc',Derr/abs(D(0,0,0,0))
#endif      
                           
  end subroutine calcdgm
#endif  
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgr(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordgr_min,ordgr_max,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgr(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgr_min,ordgr_max,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,ordgr_min,ordgr_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex :: Zadjfj,Zadj2(3,3), Zadjkl, Xtilde
    double complex, allocatable :: Dexpgr(:,:,:,:,:), DuvExpgr(:,:,:,:)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3), Skl, Daux
    double complex :: cC0f, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
!    double precision :: maxDexpgr(0:1,0:rmax+ordgr_min+1,0:ordgr_max),truncfacexp
    double precision :: maxDexpgr(0:1,0:2*(rmax+ordgr_min),0:ordgr_max),truncfacexp
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg,nt,mt,nn,nnt,nntt
    integer :: inds0(3), inds1(3), inds(3)
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgrtest
    write(*,*) 'CalcDgr in, ord',rmax,ordgr_min,ordgr_max
#endif
 
    ! allocation of C functions
    rmaxc = 2*rmax + 2*ordgr_min
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax) = acc_req_cind
    if (fac_gr.ne.0d0) then
      do r=rmax+1,rmaxc
!        acc_req_Cextra(r)= acc_req_Cextra(r-1)/x_g
! 09.03.15
        acc_req_cextra(r)= acc_req_cextra(r-1)/fac_gr
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+1:rmaxc) = acc_inf
    end if
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
#ifdef Dgrtest
    write(*,*) 'CalcDgr Cerr 0 =',cerr_i(0:rmaxc,0)
    write(*,*) 'CalcDgr Cerr 1 =',cerr_i(0:rmaxc,1)
    write(*,*) 'CalcDgr Cerr 2 =',cerr_i(0:rmaxc,2)
    write(*,*) 'CalcDgr Cerr 3 =',cerr_i(0:rmaxc,3)
    write(*,*) 'CalcDgr Cacc 0 =',cerr_i(0:rmaxc,0)/abs(c_0(0,0,0,0))
    write(*,*) 'CalcDgr Cacc 1 =',cerr_i(0:rmaxc,1)/abs(c_i(0,0,0,1))
    write(*,*) 'CalcDgr Cacc 2 =',cerr_i(0:rmaxc,2)/abs(c_i(0,0,0,2))
    write(*,*) 'CalcDgr Cacc 3 =',cerr_i(0:rmaxc,3)/abs(c_i(0,0,0,3))
#endif
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
 
    ! calculate adjugated Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q10+q20-q21
!    Z(3,1) = q10+q30-q31
!    Z(1,2) = Z(2,1)
!    Z(2,2) = 2d0*q20
!    Z(3,2) = q20+q30-q32
!    Z(1,3) = Z(3,1)
!    Z(2,3) = Z(3,2)
!    Z(3,3) = 2d0*q30
 
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
 
!    Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
!    Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
!    Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
!    Zadj(1,2) = Zadj(2,1)
!    Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
!    Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
!    Zadj(1,3) = Zadj(3,1)
!    Zadj(2,3) = Zadj(3,2)
!    Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
      
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
 
              if(n0.eq.3.and.r.eq.6) then
!             write(*,*) 'CalcDgr test ',n0,n2,n3,C_i(n0,n2,n3,1),Shat(n0,n1,n2,n3,1)
              endif
      
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
 
              if(n0.eq.3.and.r.eq.6) then
!             write(*,*) 'CalcDgr test ',n0,n1,n3,C_i(n0,n1,n3,2),Shat(n0,n1,n2,n3,2)
              endif
 
            end if
 
            if(n3.eq.0) then
 
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
 
              if(n0.eq.3.and.r.eq.6) then
!            write(*,*) 'CalcDgr test ',n0,n1,n2,C_i(n0,n1,n2,3), Shat(n0,n1,n2,n3,3) 
              endif
 
            end if
 
          end do
        end do
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
      j = 1
    else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
      j = 2
    else
      j = 3
    end if
 
    maxzadj2f = 0d0                ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
                                   ! Zadj2(n,m) ==  Zadf2(k,n,l,m)
    if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,1))
      k = 1
      n = 2
      nt = 3
      l = 1
      m = 2
      mt = 3
      zadj2(2,2) = -z(3,3)
      zadj2(2,3) =  z(3,2)
      zadj2(3,2) =  z(2,3)
      zadj2(3,3) = -z(2,2)
    end if
    if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,2))
      k = 1
      n = 2
      nt = 3
      l = 2
      m = 3
      mt = 1
      zadj2(2,1) =  z(3,3)
      zadj2(2,3) = -z(3,1)
      zadj2(3,1) = -z(2,3)
      zadj2(3,3) =  z(2,1)
!      if(abs(Zadj(n,l)).gt.abs(Zadj(k,l))) then
!        k = 2
!        n = 1
!        nt = 3
!        Zadj2(1,1) = -Z(3,3)
!        Zadj2(1,3) =  Z(3,1)
!        Zadj2(3,1) =  Z(1,3)
!        Zadj2(3,3) = -Z(1,1)
!      endif
    end if
    if (abs(zadj2f(1,2,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,3))
      k = 1
      n = 2
      nt = 3
      l = 3
      m = 1
      mt = 2
      zadj2(2,1) = -z(3,2)
      zadj2(2,2) =  z(3,1)
      zadj2(3,1) =  z(2,2)
      zadj2(3,2) = -z(2,1)
    end if
 
    if (abs(zadj2f(1,3,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,1))
      k = 1
      n = 3
      nt = 2
      l = 1
      m = 2
      mt = 3
      zadj2(3,2) =  z(2,3)
      zadj2(3,3) = -z(2,2)
      zadj2(2,2) = -z(3,3)
      zadj2(2,3) =  z(3,2)
    end if
    if (abs(zadj2f(1,3,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,2))
      k = 1
      n = 3
      nt = 2
      l = 2
      m = 3
      mt = 1
      zadj2(3,1) = -z(2,3)
      zadj2(3,3) =  z(2,1)
      zadj2(2,1) =  z(3,3)
      zadj2(2,3) = -z(3,1)
    end if
    if (abs(zadj2f(1,3,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,3))
      k = 1
      n = 3
      nt = 2
      l = 3
      m = 1
      mt = 2
      zadj2(3,1) =  z(2,2)
      zadj2(3,2) = -z(2,1)
      zadj2(2,1) = -z(3,2)
      zadj2(2,2) =  z(3,1)
    end if
 
    if (abs(zadj2f(2,3,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,1))
      k = 2
      n = 3
      nt = 1
      l = 1
      m = 2
      mt = 3
      zadj2(3,2) = -z(1,3)
      zadj2(3,3) =  z(1,2)
      zadj2(1,2) =  z(3,3)
      zadj2(1,3) = -z(3,2)
    end if
    if (abs(zadj2f(2,3,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,2))
      k = 2
      n = 3
      nt = 1
      l = 2
      m = 3
      mt = 1
      zadj2(3,1) =  z(1,3)
      zadj2(3,3) = -z(1,1)
      zadj2(1,1) = -z(3,3)
      zadj2(1,3) =  z(3,1)
    end if
    if (abs(zadj2f(2,3,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,3))
      k = 2
      n = 3
      nt = 1
      l = 3
      m = 1
      mt = 2
      zadj2(3,1) = -z(1,2)
      zadj2(3,2) =  z(1,1)
      zadj2(1,1) =  z(3,2)
      zadj2(1,2) = -z(3,1)
    end if
 
#ifdef Dgrtest
    write(*,*) 'CalcDgr maxZadj2f ',maxzadj2f,maxval(abs(zadj2f(:,:,:)))
!    write(*,*) 'CalcDgr Zadj2f ',Zadj2f
!    write(*,*) 'CalcDgr Zadj2f ',Zadj2f(1,1,2),Zadj2f(2,1,1)
#endif
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
!    Xtilde = Xadj(k,l)
 
!    write(*,*) 'CalcDg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
 
#ifdef Dgrtest
!    write(*,*) 'CalcDgr k,n,nt,l',k,n,nt,l,m,mt
!    write(*,*) 'CalcDgr pars', maxZadj2f,Zadj2f(k,n,l),Zadj(k,l),maxZadj
!    write(*,*) 'CalcDgr pars', abs(Zadjf(l)),abs(detZ)
!    write(*,*) 'CalcDgr pars',  abs(Zadjf(l)/ maxZadj2f),abs(detZ/maxZadj2f)
#endif
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
 
    ! allocation of array for expanded D-coefficients
    rmaxexp = rmaxc
    allocate(dexpgr(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgr_max))
 
    ! calculate Duv
    allocate(duvexpgr(0:(rmaxexp+1),0:rmaxexp+1,0:rmaxexp+1,0:rmaxexp+1))
 
!   if(rmaxexp.ge.16)then
!   write(*,*) 'CalcDgr Cuv_0',Cuv_0(1,3,3,3)
!   endif
 
    call calcduv(duvexpgr,cuv_0,mm02,f,rmaxexp+1,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgr(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
     
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
     
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
#ifdef Dgrtest
    write(*,*) 'CalcDgr Cij_err = ',cij_err 
    write(*,*) 'CalcDgr C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
    write(*,*) 'CalcDgr C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
#endif
 
!    maxZadj = maxval(abs(Zadj))
!    maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
    truncfacexp = sqrt(fac_gr) * truncfacd
    gtrunc = ordgr_max 
 
! calculate D(n0,n1,n2,n3) up to rank r+n0
    rloop: do r=0,rmaxexp/2
 
#ifdef Dgrtest
!      write(*,*) 'CalcDgr rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc) exit rloop
 
#ifdef Dgrtest
      write(*,*) 'CalcDgr rloop',r,rmaxexp,rmaxc
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
      ! exploiting eq. (5.40) - (5.53) solved for D_00i1..<ir>...iP
      maxdexpgr(1,r,0)=0d0
 
! Note r is not the rank!  r= n0+n1+n2+n3    rank=2*n0+n1+n2+n3
      do n0=r,1,-1
        do nn=r-n0,0,-1
          do nnt=r-n0-nn,0,-1
            nntt = r-n0-nn-nnt
 
#ifdef Dgrtest
!            write(*,*) 'CalcDgr rloop',n0,nn,nnt,nntt,Zadj2f(k,n,l)
#endif
 
            inds0(n) = nn
            inds0(nt) = nnt
            inds0(k) = nntt
            
#ifdef Dgrtest
            write(*,*) 'CalcDgr inds0',n0,inds0
#endif
 
            inds1(n) = nn+1
            inds1(nt) = nnt
            inds1(k) = nntt
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr inds1',n0,inds1
#endif
 
!            Daux = 0d0
            daux = -zadj(k,l)*c_0(n0-1,inds1(1),inds1(2),inds1(3))
 
!            Daux = 2*Zadj(k,l) * (1+r-2*n0) * Dexpgr(n0,inds1(1),inds1(2),inds1(3),0)
 
!            inds = inds1
!            inds(k) = inds(k) + 1
!            inds(l) = inds(l) + 1
!            Daux = Daux + detZ * Dexpgr(n0-1,inds(1),inds(2),inds(3),0)
!
!            inds = inds1
!            inds(k) = inds(k) + 1
!            Daux = Daux + Zadjf(l) * Dexpgr(n0-1,inds(1),inds(2),inds(3),0)
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr C_0 1c',n0-1,inds1(1),inds1(2),inds1(3),c_0(n0-1,inds1(1),inds1(2),inds1(3))
            write(*,*) 'CalcDgr Daux 1c',-zadj(k,l)*c_0(n0-1,inds1(1),inds1(2),inds1(3))
            write(*,*) 'CalcDgr Daux 1s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
            inds = inds1
            inds(k) = inds(k)+1
            do i=1,3
              daux = daux - zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
#ifdef Dgrtest
            write(*,*) 'CalcDgr Daux 2ci', -zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
#endif
            end do
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr Daux 2s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
            do i=1,3
              inds = inds1
              inds(i) = inds(i)+1
              daux = daux + zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
#ifdef Dgrtest
              write(*,*) 'CalcDgr Daux 3ci',zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
#endif
            end do
 
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr Daux 3s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
            daux = daux + 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),inds0(3),m)  &
                        + 2*(nn+1) *zadj2(n ,mt)*shat(n0,inds0(1),inds0(2),inds0(3),mt)
 
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr Daux 4ca', 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),inds0(3),m) 
            write(*,*) 'CalcDgr Daux 4cb', 2*(nn+1) *zadj2(n ,mt)*shat(n0,inds0(1),inds0(2),inds0(3),mt)
            write(*,*) 'CalcDgr Daux 4s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
!            Daux = Daux - 2*(nn+1)* Zadj2f(k,n,l)*Dexpgr(n0,inds0(1),inds0(2),inds0(3),0) 
 
            if (nnt.gt.0) then
              inds = inds1
              inds(nt) = inds(nt)-1
              daux = daux + 2*nnt*zadj2(nt,m )*shat(n0,inds(1),inds(2),inds(3),m)  &
                          + 2*nnt*zadj2(nt,mt)*shat(n0,inds(1),inds(2),inds(3),mt)
              daux = daux - 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),0) 
 
#ifdef Dgrtest
            write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2(nt,m )*shat(n0,inds(1),inds(2),inds(3),m) 
            write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2(nt,mt)*shat(n0,inds(1),inds(2),inds(3),mt) 
            write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),0) 
            write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2(nt,m ),shat(n0,inds(1),inds(2),inds(3),m) 
            write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2(nt,mt),shat(n0,inds(1),inds(2),inds(3),mt) 
            write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2f(k,nt,l),dexpgr(n0,inds(1),inds(2),inds(3),0) 
            write(*,*) 'CalcDgr Daux 5s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
            endif
 
 
            inds = inds1
            if(m.eq.n) then
              if (inds(n).gt.1) then
                inds(n) = inds(n)-2
                daux = daux - 4*(nn+1)*nn * zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 6c',4*(nn+1)*nn* zadj2(n,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
                write(*,*) 'CalcDgr Daux 6s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            else
              if (inds(n).gt.0.and.inds(m).gt.0) then
                inds(n) = inds(n)-1
                inds(m) = inds(m)-1
                daux = daux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 6c',-4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
                write(*,*) 'CalcDgr Daux 6s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            endif
 
 
            inds = inds1
            if(m.eq.nt) then
              if (inds(nt).gt.1) then
                inds(nt) = inds(nt)-2
                daux = daux - 4*nnt*(nnt-1) * zadj2(nt,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 7c',4*nnt*(nnt-1) * zadj2(nt,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
                write(*,*) 'CalcDgr Daux 7s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            else
              if (inds(nt).gt.0.and.inds(m).gt.0) then
                inds(nt) = inds(nt)-1
                inds(m) = inds(m)-1
                daux = daux - 4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 7c',4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0,inds(1),inds(2),inds(3),0)
                write(*,*) 'CalcDgr Daux 7s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            endif
 
 
            inds = inds1
            if(mt.eq.n) then
              if (inds(n).gt.1) then
                inds(n) = inds(n)-2
                daux = daux - 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 8c',- 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)  &
             , n0+1,inds(1),inds(2),inds(3)
                write(*,*) 'CalcDgr Daux 8s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            else
              if (inds(n).gt.0.and.inds(mt).gt.0) then
                inds(n) = inds(n)-1
                inds(mt) = inds(mt)-1
                daux = daux - 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 8c',- 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)   &
             ,n0+1,inds(1),inds(2),inds(3)
                write(*,*) 'CalcDgr Daux 8s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            endif
 
 
            inds = inds1
            if(mt.eq.nt) then
              if (inds(nt).gt.1) then
                inds(nt) = inds(nt)-2
                daux = daux - 4*nnt*(nnt-1)  * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 9c', - 4*nnt*(nnt-1)  * zadj2(nt,mt) * dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
                write(*,*) 'CalcDgr Daux 9s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            else
              if (inds(nt).gt.0.and.inds(mt).gt.0) then
                inds(nt) = inds(nt)-1
                inds(mt) = inds(mt)-1
                daux = daux - 4*nnt*(inds(mt)+1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Daux 9c',- 4*nnt*(inds(mt)+1) * zadj2(nt,mt) * dexpgr(n0+1,inds(1),inds(2),inds(3),0) 
                write(*,*) 'CalcDgr Daux 9s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
#endif
              endif
            endif
 
            dexpgr(n0,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nn+1)* zadj2f(k,n,l))
 
#ifdef Dgrtest
                write(*,*) 'CalcDgr Dexpgr',n0,inds0(1),inds0(2),inds0(3),dexpgr(n0,inds0(1),inds0(2),inds0(3),0)
#endif
 
            if (n0.eq.1) then
              maxdexpgr(1,r,0) =  maxdexpgr(1,r,0) + abs(dexpgr(n0,inds0(1),inds0(2),inds0(3),0) )
            end if
 
!            if (r+n0.le.rmax) then          !  for fixed rank
            if (r.le.rmax) then
              d(n0,inds0(1),inds0(2),inds0(3)) = dexpgr(n0,inds0(1),inds0(2),inds0(3),0)
            end if
 
          end do
        end do
      end do
 
      ! calculate
      ! D_00ijkl.. --> D_aijkl..
      ! exploiting eq. (5.38)
      maxdexpgr(0,r,0)=0d0
      do n1=0,r
        do n2=0,r-n1
          n3 = r-n1-n2
 
          smod = shat(0,n1,n2,n3,:)
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*dexpgr(1,n1-1,n2,n3,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*dexpgr(1,n1,n2-1,n3,0)
          end if
          if (n3.ge.1) then
            smod(3) = smod(3) - 2d0*n3*dexpgr(1,n1,n2,n3-1,0)
          end if
 
          dexpgr(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                              +  zadj(3,j)*smod(3))/zadjfj
          maxdexpgr(0,r,0) =  maxdexpgr(0,r,0) + abs(dexpgr(0,n1,n2,n3,0))
          if (r.le.rmax) then
            d(0,n1,n2,n3) = dexpgr(0,n1,n2,n3,0)
!            Derr(r-1) =  abs(detZ/Zadjfj*Dexpgr(0,n1,n2,n3,0))
          end if
 
 
#ifdef Dgrtest
          if(r.le.rmax) then
!            write(*,*) 'CalcDgr D(0,n1,n2,n3,0)=',n1,n2,n3,D(0,n1,n2,n3)
          endif
 
          if(n0.eq.0.and.n1.eq.3.and.n2.eq.0.and.n3.eq.0) then 
            write(*,*) 'Smod(0,3,0,0,1)= ',shat(0,n1,n2,n3,1)
            write(*,*) 'Smod(0,3,0,0,2)= ',shat(0,n1,n2,n3,2)
            write(*,*) 'Smod(0,3,0,0,3)= ',shat(0,n1,n2,n3,3)
            write(*,*) 'D(1,2,0,0)= ',0,dexpgr(1,2,n2,n3,0)
            write(*,*) 'D(0,3,0,0)= ',0,d(n0,n1,n2,n3)
          end if
#endif
 
        end do
      end do
 
#ifdef Dgrtest
!      write(*,*) 'CalcDgr maxDexpgr 0',r-1, maxDexpgr(0,r-1,0)
#endif
 
      if(r.le.rmax) then
!       Derr(r) =  abs(detZ/Zadjfj)*maxDexpgr(0,r,0)
        derr(r) =  fac_gr*maxdexpgr(0,r,0)
      endif
 
      ! error propagation from C's
      if(r.gt.0)then
        d00_err(r+1) = maxzadj*cij_err(r+1)/(2*maxzadj2f)
      end if
      dij_err(r)=maxzadj*max(cij_err(r),2*d00_err(r+1))/abs(zadjfj)
 
      if(r.gt.0)then
        d00_err2(r+1) = maxzadj*cij_err2(r+1)/(2*maxzadj2f)
      end if
      dij_err2(r)=maxzadj*max(cij_err2(r),2*d00_err2(r+1))/abs(zadjfj)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r)
        rg = rg-1
 
#ifdef Dgrtest
        write(*,*) 'CalcDgr: gloop ',r,rg,g
#endif
 
        ! calculating
        ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
       ! exploiting eq. (5.40) - (5.53) solved for D_00i1..<ir>...iP
        maxdexpgr(1,rg,g) = 0d0
        do n0=rg,1,-1                      !  note rank of tensor = rg+n0
          do nn=rg-n0,0,-1
            do nnt=rg-n0-nn,0,-1
              nntt = rg-n0-nn-nnt
              inds0(n) = nn
              inds0(nt) = nnt
              inds0(k) = nntt
              
              inds1(n) = nn+1
              inds1(nt) = nnt
              inds1(k) = nntt
              
#ifdef Dgrtest
!              write(*,*) 'CalcDgr Daux r inds=',n0,inds0
#endif      
 
              daux = 2*zadj(k,l) * (2+rg-n0) * dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1)
              
#ifdef Dgrtest
!              write(*,*) 'CalcDgr Daux r1c',2*Zadj(k,l)*(2+rg-n0)* Dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1)
!              write(*,*) 'CalcDgr Daux r1c',2*Zadj(k,l)*(2+rg-n0),Dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1) &
!                   ,n0,inds1(1),inds1(2),inds1(3)
!              write(*,*) 'CalcDgr Daux r1s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
 
              if (g.gt.1) then
                inds = inds1
                inds(k) = inds(k) + 1
                inds(l) = inds(l) + 1
                daux = daux + detz * dexpgr(n0-1,inds(1),inds(2),inds(3),g-2)
                
#ifdef Dgrtest
!                write(*,*) 'CalcDgr Daux r2c',detZ * Dexpgr(n0-1,inds(1),inds(2),inds(3),g-2)
!                write(*,*) 'CalcDgr Daux r2s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
              endif
 
              inds = inds1
              inds(k) = inds(k) + 1
              daux = daux + zadjf(l) * dexpgr(n0-1,inds(1),inds(2),inds(3),g-1)
              
#ifdef Dgrtest
!              write(*,*) 'CalcDgr Daux r3c',Zadjf(l)* Dexpgr(n0-1,inds(1),inds(2),inds(3),g-1)
!              write(*,*) 'CalcDgr Daux r3c',Zadjf(l),Dexpgr(n0-1,inds(1),inds(2),inds(3),g-1),n0-1,inds(1),inds(2),inds(3)
!              write(*,*) 'CalcDgr Daux r3s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
 
!            Daux = Daux - 2*nn* Zadj2f(k,n,l)*Dexpgr(n0,inds0(1),inds0(2),inds0(3),g) 
 
              if (nnt.gt.0) then
                inds = inds1
                inds(nt) = inds(nt)-1
                daux = daux - 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!              write(*,*) 'CalcDgr Daux r4c',- 2*nnt*Zadj2f(k,nt,l)*Dexpgr(n0,inds(1),inds(2),inds(3),g) 
!              write(*,*) 'CalcDgr Daux r4c',- 2*nnt,Zadj2f(k,nt,l),Dexpgr(n0,inds(1),inds(2),inds(3),g),n0,inds(1),inds(2),inds(3) 
!              write(*,*) 'CalcDgr Daux r4s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
              endif
 
 
              inds = inds1
              if(m.eq.n) then
                if (inds(n).gt.1) then
                  inds(n) = inds(n)-2
                  daux = daux - 4*(nn+1)*nn * zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r6c',4*(nn+1)*nn* Zadj2(n,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r6s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              else
                if (inds(n).gt.0.and.inds(m).gt.0) then
                  inds(n) = inds(n)-1
                  inds(m) = inds(m)-1
                  daux = daux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r6c',4*(nn+1)*(inds(m)+1)* Zadj2(n,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r6c',n,m,nn,4*(nn+1)*(inds(m)+1),Zadj2(n,m ),Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r6s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              endif
              
              inds = inds1
              if(m.eq.nt) then
                if (inds(nt).gt.1) then
                  inds(nt) = inds(nt)-2
                  daux = daux - 4*nnt*(nnt-1) * zadj2(nt,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r7c',4*nnt*(nnt-1) * Zadj2(nt,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r7s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              else
                if (inds(nt).gt.0.and.inds(m).gt.0) then
                  inds(nt) = inds(nt)-1
                  inds(m) = inds(m)-1
                  daux = daux - 4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r7c',4*nnt*(inds(m)+1)* Zadj2(nt,m )* Dexpgr(n0,inds(1),inds(2),inds(3),g)
!                  write(*,*) 'CalcDgr Daux r7s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              endif
 
              inds = inds1
              if(mt.eq.n) then
                if (inds(n).gt.1) then
                  inds(n) = inds(n)-2
                  daux = daux - 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r8c',- 4*(nn+1)*nn * Zadj2(n ,mt)* Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r8c',n,mt,nn,- 4*(nn+1)*nn,Zadj2(n ,mt),Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r8s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              else
                if (inds(n).gt.0.and.inds(mt).gt.0) then
                  inds(n) = inds(n)-1
                  inds(mt) = inds(mt)-1
                  daux = daux - 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r8c',- 4*(nn+1)*(inds(mt)+1)* Zadj2(n ,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
!                  write(*,*) 'CalcDgr Daux r8s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              endif
 
              inds = inds1
              if(mt.eq.nt) then
                if (inds(nt).gt.1) then
                  inds(nt) = inds(nt)-2
                  daux = daux - 4*nnt*(nnt-1)  * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r9c', - 4*nnt*(nnt-1)  * Zadj2(nt,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r9s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              else
                if (inds(nt).gt.0.and.inds(mt).gt.0) then
                  inds(nt) = inds(nt)-1
                  inds(mt) = inds(mt)-1
                  daux = daux - 4*nnt*(inds(mt)+1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr Daux r9c',- 4*nnt*(inds(mt)+1) * Zadj2(nt,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r9c',nt,mt,nnt,- 4*nnt*(inds(mt)+1) , Zadj2(nt,mt) , &
!                          Dexpgr(n0+1,inds(1),inds(2),inds(3),g) 
!                  write(*,*) 'CalcDgr Daux r9s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
#endif      
                endif
              endif
 
              dexpgr(n0,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nn+1)* zadj2f(k,n,l))
                             
              if(n0.eq.1) then
                maxdexpgr(1,rg,g) =  maxdexpgr(1,rg,g) + abs(dexpgr(n0,inds0(1),inds0(2),inds0(3),g))
 
 
                if (g.eq.1.and.abs(dexpgr(1,inds0(1),inds0(2),inds0(3),g)).gt.  &
                    truncfacexp*max(1/m2scale,maxdexpgr(1,rg,g-1)) .or. &
                    g.ge.2.and.abs(dexpgr(1,inds0(1),inds0(2),inds0(3),g)).gt.  &
                    truncfacexp*maxdexpgr(1,rg,g-1)) then
 
 
#ifdef Dgrtest
!                  write(*,*) 'CalcDgr exit gloop',n0,inds0(1),inds0(2),inds0(3),g,rg,  &
!                         abs(Dexpgr(n0,inds0(1),inds0(2),inds0(3),g)),maxDexpgr(1,rg,g-1),truncfacexp
#endif      
 
                  gtrunc = g-1
                  exit gloop
                end if
              end if
 
            end do
          end do
        end do
 
#ifndef PPEXP00
        if (rg.le.rmax) then
          do n0=rg,1,-1
!            if (rg+n0.le.rmax) then             ! for fixed rank!
            if (rg.le.rmax) then
              do n1=0,rg-n0
                do n2=0,rg-n0-n1
                  n3=rg-n0-n1-n2
                  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgr(n0,n1,n2,n3,g)
                end do
              end do
            end if
          end do
        end if
#endif
!        write(*,*) 'CalcDgr after it1 ',rg
 
        ! calculate
        ! D_00ijkl.. --> D_aijkl..
        ! exploiting eq. (5.38)
 
!        write(*,*) 'CalcDgr maxDexp',rg,g-1,maxDexpgr(0,rg,g-1)
 
        maxdexpgr(0,rg,g) = 0d0
        do n1=0,rg
          do n2=0,rg-n1
            n3 = rg-n1-n2
 
            smod = 0d0
            if (n1.ge.1) then
              smod(1) = smod(1) - 2d0*n1*dexpgr(1,n1-1,n2,n3,g)
            end if
            if (n2.ge.1) then
              smod(2) = smod(2) - 2d0*n2*dexpgr(1,n1,n2-1,n3,g)
            end if
            if (n3.ge.1) then
              smod(3) = smod(3) - 2d0*n3*dexpgr(1,n1,n2,n3-1,g)
            end if
 
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
            inds(j) = inds(j)+1
            dexpgr(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                                +  zadj(3,j)*smod(3)  &
                                - detz*dexpgr(0,inds(1),inds(2),inds(3),g-1))/zadjfj
 
            maxdexpgr(0,rg,g) =  maxdexpgr(0,rg,g) + abs(dexpgr(0,n1,n2,n3,g))
 
!              if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then 
!                write(*,*) 'D2(2,3,3)= ',g,Dexpgr(0,n1,n2,n3,g)
!                write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                +  Zadj(3,j)*Smod(3)/Zadjfj,  &
!                                - detZ*Dexpgr(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
!                write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3),         &
!                                - detZ/Zadjfj,Dexpgr(0,inds(1),inds(2),inds(3),g-1)
!              end if
 
            if (g.eq.1.and.abs(dexpgr(0,n1,n2,n3,g)).gt.            &
                truncfacexp*max(1/m2scale,maxdexpgr(0,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgr(0,n1,n2,n3,g)).gt.           &
                truncfacexp*maxdexpgr(0,rg,g-1)) then
 
#ifdef Dgrtest
                  write(*,*) 'CalcDgr exit gloop',0,n1,n2,n3,g,abs(dexpgr(0,n1,n2,n3,g)),maxdexpgr(0,rg,g-1),truncfacexp
#endif      
              gtrunc = g-1
              exit gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.0)then
          d00_err(rg+1) = max( d00_err(rg+1),                   &
              max( maxzadj*(2+rg-2*n0)*d00_err(rg+2),       &
                    abs(detz)*dij_err(rg+2),                &
                    maxzadjf*dij_err(rg+1)                   &
                 ) / (2*maxzadj2f)  ) 
        end if
        dij_err(rg)=max(dij_err(rg),                &
            max(2*maxzadj*d00_err(rg+1),abs(detz)*dij_err(rg))/abs(zadjfj) )
 
        if(rg.gt.0)then
          d00_err2(rg+1) = max( d00_err2(rg+1),                   &
              max( maxzadj*(2+rg-2*n0)*d00_err2(rg+2),       &
                    abs(detz)*dij_err2(rg+2),                &
                    maxzadjf*dij_err2(rg+1)                   &
                 ) / (2*maxzadj2f)  ) 
        end if
        dij_err2(rg)=max(dij_err2(rg),                &
            max(2*maxzadj*d00_err2(rg+1),abs(detz)*dij_err2(rg))/abs(zadjfj) )
 
#ifdef PPEXP00
        if (rg.le.rmax) then
          do n0=rg,1,-1
!            if (rg+n0.le.rmax) then             !  for fixed rank
            if (rg.le.rmax) then
              do n1=0,rg-n0
                do n2=0,rg-n0-n1
                  n3=rg-n0-n1-n2
                  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgr(n0,n1,n2,n3,g)
                end do
              end do
            end if
          end do
        end if
#endif
 
        if (rg.le.rmax) then
          derr(rg) = 0d0
          do n1=0,rg
            do n2=0,rg-n1
              n3 = rg-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgr(0,n1,n2,n3,g)
              if(abs(dexpgr(0,n1,n2,n3,g-1)).ne.0d0) then
!                Derr(rg)=max(Derr(rg),abs(Dexpgr(0,n1,n2,n3,g))**2/abs(Dexpgr(0,n1,n2,n3,g-1)))
                derr(rg)=max(derr(rg),abs(dexpgr(0,n1,n2,n3,g))*min(1d0,abs(dexpgr(0,n1,n2,n3,g))/abs(dexpgr(0,n1,n2,n3,g-1))))
              else
                derr(rg)=max(derr(rg),abs(dexpgr(0,n1,n2,n3,g)))
              endif
 
#ifdef Dgrtest
!              write(*,*) 'CalcDgr Derr calc',rg,Derr(rg),n1,n2,n3,abs(Dexpgr(0,n1,n2,n3,g)),abs(Dexpgr(0,n1,n2,n3,g-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
#ifdef PVEST2
          if(dij_err2(rg).gt.3d0*derr(rg)) then
#else
          if(dij_err(rg).gt.3d0*derr(rg)) then
#endif
            gtrunc = min(g,gtrunc)
             
#ifdef Dgrtest
             write(*,*) 'CalcDgr exit err',r,rg,g,gtrunc,dij_err(rg),derr(rg)
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgrtest
      write(*,*) 'CalcDgr D(0,0,0,0) = ',r,d(0,0,0,0)
    if(r.ge.1)then
      write(*,*) 'CalcDgr D(1,0,0,0) = ',r,d(1,0,0,0)
      write(*,*) 'CalcDgr D(0,1,0,0) = ',r,d(0,1,0,0)
      write(*,*) 'CalcDgr D(0,0,1,0) = ',r,d(0,0,1,0)
      write(*,*) 'CalcDgr D(0,0,0,1) = ',r,d(0,0,0,1)
    endif
    if(r.ge.2.and.rmax.ge.2)then
      write(*,*) 'CalcDgr D(1,1,0,0) = ',r,d(1,1,0,0)
      write(*,*) 'CalcDgr D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDgr D(1,0,0,1) = ',r,d(1,0,0,1)
      write(*,*) 'CalcDgr D(0,2,0,0) = ',r,d(0,2,0,0)
!      write(*,*) 'CalcDgr D(0,1,1,0) = ',r,D(0,1,1,0)
      write(*,*) 'CalcDgr D(0,0,2,0) = ',r,d(0,0,2,0)
    endif
    if(r.ge.3.and.rmax.ge.2)then
!      write(*,*) 'CalcDgr D(3,0,0,0) = ',r,D(3,0,0,0)
!      write(*,*) 'CalcDgr D(2,0,1,0) = ',r,D(2,0,1,0)
      write(*,*) 'CalcDgr D(1,2,0,0) = ',r,d(1,2,0,0)
      write(*,*) 'CalcDgr D(1,0,2,0) = ',r,d(1,0,2,0)
      write(*,*) 'CalcDgr D(0,3,0,0) = ',r,d(0,3,0,0)
      write(*,*) 'CalcDgr D(0,2,1,0) = ',r,d(0,2,1,0)
      write(*,*) 'CalcDgr D(0,0,3,0) = ',r,d(0,0,3,0)
      write(*,*) 'CalcDgr D(0,1,1,1) = ',r,d(0,1,1,1)
      write(*,*) 'CalcDgr D(0,0,2,1) = ',r,d(0,0,2,1)
    endif
      write(*,*) 'CalcDgr Dij_err',r,dij_err
      write(*,*) 'CalcDgr Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgr err',r,derr
      write(*,*) 'CalcDgr acc',r,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
#ifdef Dgrtest
!      write(*,*) 'CalcDgr exit r',r,maxval(Derr),acc_req_D*abs(D(0,0,0,0))
#endif
 
!      if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit    ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
        if (r.lt.rmax) then
          do rg=r+1,rmax
            do n0=0,rg/2
              do n1=0,rg-n0
                do n2=0,rg-n0-n1
                  d(n0,n1,n2,rg-n0-n1-n2)=0d0
                enddo
              enddo
            enddo
          enddo
 
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDgr',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDgr:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDgr: p10 = ',p10
            write(nerrout_coli,111)' CalcDgr: p21 = ',p21
            write(nerrout_coli,111)' CalcDgr: p32 = ',p32
            write(nerrout_coli,111)' CalcDgr: p30 = ',p30
            write(nerrout_coli,111)' CalcDgr: p20 = ',p20
            write(nerrout_coli,111)' CalcDgr: p31 = ',p31
            write(nerrout_coli,111)' CalcDgr: m02 = ',m02
            write(nerrout_coli,111)' CalcDgr: m12 = ',m12
            write(nerrout_coli,111)' CalcDgr: m22 = ',m22
            write(nerrout_coli,111)' CalcDgr: m32 = ',m32
          end if
        endif
        
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
 
#ifdef Dgrtest
!    write(*,*) 'CalcDgr D(0,0,0,0) = ',D(0,0,0,0)
!    if(rmax.ge.3)then
!      write(*,*) 'CalcDgr D(0,1,1,1) = ',D(0,1,1,1)
!    endif
 
    write(*,*) 'CalcDgr final err',derr
    write(*,*) 'CalcDgr final acc',derr/abs(d(0,0,0,0))
#endif      
       
!    write(*,*) 'CalcDgr Derr ',Derr
!    write(*,*) 'CalcDgr Derr2',Derr2
                    
  end subroutine calcdgr
 
 
 
! CalcDgx not finished!
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgx(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordg_min,ordg_max,id,Derr,Derrr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgx(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgx_min,ordgx_max,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,ordgx_min,ordgx_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex :: Zadjfj,Zadj2(4), Zadjkl, Xtilde
    double complex, allocatable :: Dexpgx(:,:,:,:,:), DuvExpgx(:,:,:,:)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3), Skl, Daux, DexpgAux
    double complex :: cC0f, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpgx(0:1,0:rmax+ordgx_min+1,0:ordgx_max),truncfacexp
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg,lt,ltt,nl,nlt,nltt
    integer :: inds0(3), inds(3), inds2(2,4)
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgxtest
    write(*,*) 'CalcDgx in, ord',rmax,ordgx_min,ordgx_max
#endif
 
    ! allocation of C functions
    rmaxc = rmax + ordgx_min
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax) = acc_req_cind
    if (x_g.ne.0d0) then
      do r=rmax+1,rmaxc
        acc_req_cextra(r)= acc_req_cextra(r-1)/x_g
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+1:rmaxc) = acc_inf
    end if
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
 
    ! calculate adjugated Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
 
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q10+q20-q21
!    Z(3,1) = q10+q30-q31
!    Z(1,2) = Z(2,1)
!    Z(2,2) = 2d0*q20
!    Z(3,2) = q20+q30-q32
!    Z(1,3) = Z(3,1)
!    Z(2,3) = Z(3,2)
!    Z(3,3) = 2d0*q30
 
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
 
!    Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
!    Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
!    Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
!    Zadj(1,2) = Zadj(2,1)
!    Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
!    Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
!    Zadj(1,3) = Zadj(3,1)
!    Zadj(2,3) = Zadj(3,2)
!    Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
      
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
            end if
 
            if(n3.eq.0) then
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
            end if
 
          end do
        end do
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
      j = 1
    else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
      j = 2
    else
      j = 3
    end if
 
    maxzadj2f = 0d0
    if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,1))
      i = 1
      j = 2
      l = 1
      lt = 2
      ltt = 3
    end if
    if (abs(zadj2f(1,3,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,1))
      i = 1
      j = 3
      l = 1
      lt = 2
      ltt = 3
    end if
    if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,2))
      i = 1
      j = 2
      l = 2
      lt = 3
      ltt = 1
    end if
    if (abs(zadj2f(1,3,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,2))
      i = 1
      j = 3
      l = 2
      lt = 3
      ltt = 1
    end if
    if (abs(zadj2f(1,2,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,3))
      i = 1
      j = 2
      l = 3
      lt = 1
      ltt = 2
    end if
    if (abs(zadj2f(1,3,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,3,3))
      i = 1
      j = 3
      l = 3
      lt = 1
      ltt = 2
    end if
    if (abs(zadj2f(2,3,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,1))
      i = 2
      j = 3
      l = 1
      lt = 2
      ltt = 3
    end if
    if (abs(zadj2f(2,3,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,2))
      i = 2
      j = 3
      l = 2
      lt = 3
      ltt = 1
    end if
    if (abs(zadj2f(2,3,3)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(2,3,3))
      i = 2
      j = 3
      l = 3
      lt = 1
      ltt = 2
    end if
 
#ifdef Dgxtest
    write(*,*) 'CalcDgx i,j,l',i,j,l,lt,ltt
    write(*,*) 'CalcDgx pars', maxzadj2f,zadj2f(i,j,l),zadj(i,j),maxzadj
    write(*,*) 'CalcDgx pars', abs(zadjf(j)),abs(xadj(i,j))
    write(*,*) 'CalcDgx pars',  abs(zadjf(j)/ maxzadj2f),abs(xadj(i,j)/maxzadj2f)
#endif
 
    zadjfj = zadjf(j)
 
    xtilde = xadj(k,l)
 
!    write(*,*) 'CalcDgx Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpgx(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgx_max))
 
 
    ! calculate Duv
    allocate(duvexpgx(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpgx,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgx(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
     
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
     
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
#ifdef Dgxtest
    write(*,*) 'CalcDgx Cij_err = ',cij_err 
    write(*,*) 'CalcDgx C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
    write(*,*) 'CalcDgx C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
#endif
 
!    maxZadj = maxval(abs(Zadj))
!    maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
    truncfacexp = sqrt(fac_g) * truncfacd
    gtrunc = ordgx_max 
 
! calculate D(1,n1,n2,n3) up to rank r
! calculate D(0,n1,n2,n3) up to rank r-1
    rloop: do r=1,rmaxexp
 
#ifdef Dgxtest
!      write(*,*) 'CalcDgx rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
#ifdef Dgxtest
      write(*,*) 'CalcDgx rloop',r
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating D_00ijk.. exploiting eq. (5.53)
      maxdexpgx(1,r,0)=0d0
      do nl=r-2,0,-1
        do nlt=r-2-nl,0,-1
          nltt = r-2-nl-nlt
          inds0(l) = nl
          inds0(lt) = nlt
          inds0(ltt) = nltt
 
          inds(l) = nl+1
          inds(lt) = nlt
          inds(ltt) = nltt
          daux = zadj2f(i,j,1)*shat(0,inds(1),inds(2),inds(3),1)  &
               + zadj2f(i,j,2)*shat(0,inds(1),inds(2),inds(3),2)  &
               + zadj2f(i,j,3)*shat(0,inds(1),inds(2),inds(3),3)  
 
          inds = inds0
          inds(l) = inds(l)+1
          daux = daux - zadj(i,j)*(c_0(0,inds(1),inds(2),inds(3))      &
                             +4*duvexpgx(1,inds(1),inds(2),inds(3))) 
 
          if (nlt.ge.1) then
            inds(lt) = nlt-1
            daux = daux - 2*nlt*zadj2f(i,j,lt)*dexpgx(1,inds(1),inds(2),inds(3),0)
          end if
          if (nltt.ge.1) then
            inds(lt) = nlt
            inds(ltt) = nltt-1
            daux = daux - 2*nltt*zadj2f(i,j,ltt)*dexpgx(1,inds(1),inds(2),inds(3),0)
          end if
 
          dexpgx(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1)*zadj2f(i,j,l))
 
          maxdexpgx(1,r,0) =  maxdexpgx(1,r,0) + abs(dexpgx(1,inds0(1),inds0(2),inds0(3),0) )
 
          if (r.le.rmax) then
            d(1,inds0(1),inds0(2),inds0(3)) = dexpgx(1,inds0(1),inds0(2),inds0(3),0)
          end if
      
        end do
      end do
 
      ! calculate
      ! D_00ijkl.. --> D_aijkl..
      ! exploiting eq. (5.38)
      maxdexpgx(0,r-1,0)=0d0
      do n1=0,r-1
        do n2=0,r-1-n1
          n3 = r-1-n1-n2
 
          smod = shat(0,n1,n2,n3,:)
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*dexpgx(1,n1-1,n2,n3,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*dexpgx(1,n1,n2-1,n3,0)
          end if
          if (n3.ge.1) then
            smod(3) = smod(3) - 2d0*n3*dexpgx(1,n1,n2,n3-1,0)
          end if
 
          dexpgx(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                              +  zadj(3,j)*smod(3))/zadjfj
          maxdexpgx(0,r-1,0) =  maxdexpgx(0,r-1,0) + abs(dexpgx(0,n1,n2,n3,0))
          if (r.le.rmax+1) then
            d(0,n1,n2,n3) = dexpgx(0,n1,n2,n3,0)
          end if
 
 
#ifdef Dgxtest
!          if(n0.eq.0.and.n1.eq.0.and.n2.eq.3.and.n3.eq.0) then 
!            write(*,*) 'D2(0,0,3,0)= ',0,D(n0,n1,n2,n3)
!          end if
#endif
 
        end do
      end do
 
#ifdef Dgxtest
!      write(*,*) 'CalcDgx maxDexpg 0',r-1, maxDexpg(0,r-1,0)
#endif
 
      if(r-1.le.rmax) then
!       Derr(r-1) =  abs(detZ/Zadjfj)*maxDexpg(0,r-1,0)
        derr(r-1) =  fac_g*maxdexpgx(0,r-1,0)
      endif
 
      ! error propagation from C's
      if(r.gt.1)then
        d00_err(r) = max(cij_err(r-1),maxzadj/maxzadj2f*cij_err(r-1))/2d0
      end if
      dij_err(r-1)=maxzadj*max(cij_err(r-1),2*d00_err(r))/abs(zadjfj)
 
      if(r.gt.1)then
        d00_err2(r) = max(cij_err2(r-1),maxzadj/maxzadj2f*cij_err2(r-1))/2d0
      end if
      dij_err2(r-1)=maxzadj*max(cij_err2(r-1),2*d00_err2(r))/abs(zadjfj)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
 
        write(*,*) 'gloop ',g,rg
 
        ! calculating D_00ijk.. exploiting eq. (5.53)
        maxdexpgx(1,rg,g) = 0d0
        do nl=rg-2,0,-1
          do nlt=rg-2-nl,0,-1
            nltt = rg-2-nl-nlt
            inds0(l) = nl
            inds0(lt) = nlt
            inds0(ltt) = nltt
 
            inds = inds0
            inds(l) = inds(l)+1
            daux = -xadj(i,j)*dexpgx(0,inds(1),inds(2),inds(3),g-1)   &
                   +zadj(i,j)*2*rg*dexpgx(1,inds(1),inds(2),inds(3),g-1) 
 
            write(*,*) 'CalcDgx con Xij',-xadj(i,j)*dexpgx(0,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))  
            write(*,*) 'CalcDgx con Zij',+zadj(i,j)*2*(1+rg)*dexpgx(1,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))
 
            inds(i) = inds(i)+1
            daux = daux - zadjfj*dexpgx(0,inds(1),inds(2),inds(3),g-1)
            write(*,*) 'CalcDgx con Zadj2f', - zadjfj*dexpgx(0,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))  
 
            if (nlt.ge.1) then
              inds(l) = nl+1
              inds(lt) = nlt-1
              inds(ltt) = nltt
              daux = daux - 2*nlt*zadj2f(i,j,lt)*dexpgx(1,inds(1),inds(2),inds(3),g)
            end if
            if (nltt.ge.1) then
              inds(l) = nl+1
              inds(lt) = nlt
              inds(ltt) = nltt-1
              daux = daux - 2*nltt*zadj2f(i,j,ltt)*dexpgx(1,inds(1),inds(2),inds(3),g)
            end if
 
            dexpgx(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1)*zadj2f(i,j,l))
 
            maxdexpgx(1,rg,g) =  maxdexpgx(1,rg,g) + abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g) )
 
            write(*,*) 'CalcDgx gloop 00',g,rg,nl,nlt,nltt,dexpgx(1,inds0(1),inds0(2),inds0(3),g)
 
 
            if (g.eq.1.and.abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)).gt.           &
                truncfacexp*max(1/m2scale,maxdexpgx(1,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)).gt.           &
                truncfacexp*maxdexpgx(1,rg,g-1)) then
 
#ifdef Dgxtest
              write(*,*) 'CalcDgx cycle loop',1,inds0(1),inds0(2),inds0(3),g, &
                  abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgx(1,rg,g-1)
#endif
              
              gtrunc = g-1
              exit gloop
            end if
       
          end do
        end do
 
#ifndef PPEXP00
        if (rg.le.rmax) then
          do n1=0,rg-2
            do n2=0,rg-2-n1
              n3=rg-2-n1-n2
              d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgx(1,n1,n2,n3,g)
            end do
          end do
        end if
#endif
 
 
        ! calculate
        ! D_00ijkl.. --> D_aijkl..
        ! exploiting eq. (5.38)
 
!        write(*,*) 'CalcDgx maxDexp',rg-1,g-1,maxDexpg(0,rg-1,g-1)
 
        maxdexpgx(0,rg-1,g) = 0d0
        do n1=0,rg-1
          do n2=0,rg-1-n1
            n3 = rg-1-n1-n2
 
            smod = 0d0
            if (n1.ge.1) then
              smod(1) = smod(1) - 2d0*n1*dexpgx(1,n1-1,n2,n3,g)
            end if
            if (n2.ge.1) then
              smod(2) = smod(2) - 2d0*n2*dexpgx(1,n1,n2-1,n3,g)
            end if
            if (n3.ge.1) then
              smod(3) = smod(3) - 2d0*n3*dexpgx(1,n1,n2,n3-1,g)
            end if
 
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
            inds(j) = inds(j)+1
            dexpgx(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
                                +  zadj(3,j)*smod(3)  &
                                - detz*dexpgx(0,inds(1),inds(2),inds(3),g-1))/zadjfj
 
            maxdexpgx(0,rg-1,g) =  maxdexpgx(0,rg-1,g) + abs(dexpgx(0,n1,n2,n3,g))
 
!              if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then 
!                write(*,*) 'D2(2,3,3)= ',g,Dexpg(0,n1,n2,n3,g)
!                write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                +  Zadj(3,j)*Smod(3)/Zadjfj,  &
!                                - detZ*Dexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
!                write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3),         &
!                                - detZ/Zadjfj,Dexpg(0,inds(1),inds(2),inds(3),g-1)
!              end if
 
            if (g.eq.1.and.abs(dexpgx(0,n1,n2,n3,g)).gt.               &
                truncfacexp*max(1/m2scale**2,maxdexpgx(0,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgx(0,n1,n2,n3,g)).gt.              &
                truncfacexp*maxdexpgx(0,rg,g-1)) then
 
#ifdef Dgxtest
                  write(*,*) 'CalcDgx exit gloop',0,n1,n2,n3,g,abs(dexpgx(0,n1,n2,n3,g)),maxdexpgx(0,rg-1,g-1),truncfacexp
#endif      
              gtrunc = g-1
              exit gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.1)then
          d00_err(rg) = max( d00_err(rg),                                   &
              max( abs(m02)*dij_err(rg-2),            &
              max( maxzadjf*dij_err(rg),abs(xtilde)*dij_err(rg-1),         &
              maxzadj*d00_err(rg+1) ) / abs(2d0*maxzadj2f) )                        &
              /(4*(rg-1))   )
        end if
        dij_err(rg-1)=max(dij_err(rg-1),                &
            max(2*maxzadj*d00_err(rg),abs(detz)*dij_err(rg))/abs(zadjfj) )
 
        if(rg.gt.1)then
          d00_err2(rg) = max( d00_err2(rg),                                   &
              max( abs(m02)*dij_err2(rg-2),            &
              max( maxzadjf*dij_err2(rg),abs(xtilde)*dij_err2(rg-1),         &
              maxzadj*d00_err(rg+1) ) / abs(2d0*maxzadj2f) )                        &
              /(4*(rg-1))   )
        end if
        dij_err2(rg-1)=max(dij_err2(rg-1),                &
            max(2*maxzadj*d00_err2(rg),abs(detz)*dij_err2(rg))/abs(zadjfj) )
 
#ifdef PPEXP00
        if (rg.le.rmax) then
          do n1=0,rg-1
            do n2=0,rg-1-n1
              n3=rg-1-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgx(0,n1,n2,n3,g)
            end do
          end do
        end if
#endif
!        write(*,*) 'CalcDgx after it1 ',rg
        if ((rg.le.rmax+1)) then
          derr(rg-1) = 0d0
          do n1=0,rg-1
            do n2=0,rg-1-n1
              n3 = rg-1-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgx(0,n1,n2,n3,g)
              if(abs(dexpgx(0,n1,n2,n3,g-1)).ne.0d0) then
!              Derr(rg-1)=max(Derr(rg-1),abs(Dexpgx(0,n1,n2,n3,g))**2/abs(Dexpgx(0,n1,n2,n3,g-1)))
                derr(rg-1)=max(derr(rg-1),abs(dexpgx(0,n1,n2,n3,g))*min(1d0,abs(dexpgx(0,n1,n2,n3,g))/abs(dexpgx(0,n1,n2,n3,g-1))))
              else
                derr(rg-1)=max(derr(rg-1),abs(dexpgx(0,n1,n2,n3,g)))
              endif
 
#ifdef Dgxtest
!              write(*,*) 'CalcDgx Derr calc',rg-1,Derr(rg-1),n1,n2,n3,abs(Dexpg(0,n1,n2,n3,g)),abs(Dexpg(0,n1,n2,n3,g-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
#ifdef PVEST2
          if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
#else
          if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
#endif
            gtrunc = min(g,gtrunc)
             
#ifdef Dgxtest
             write(*,*) 'CalcDgx exit err',r,rg-1,g,gtrunc,dij_err(rg-1),derr(rg-1)
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgxtest
      write(*,*) 'CalcDgx D(0,0,0,0) = ',r,d(0,0,0,0)
    if(r.gt.1)then
      write(*,*) 'CalcDgx D(1,0,0,0) = ',r,d(1,0,0,0)
      write(*,*) 'CalcDgx D(0,1,0,0) = ',r,d(0,1,0,0)
      write(*,*) 'CalcDgx D(0,0,1,0) = ',r,d(0,0,1,0)
    endif
    if(r.gt.2.and.rmax.ge.2)then
      write(*,*) 'CalcDgx D(1,1,0,0) = ',r,d(1,1,0,0)
!      write(*,*) 'CalcDgx D(0,2,0,0) = ',r,D(0,2,0,0)
!      write(*,*) 'CalcDgx D(0,1,1,0) = ',r,D(0,1,1,0)
      write(*,*) 'CalcDgx D(0,0,2,0) = ',r,d(0,0,2,0)
    endif
    if(r.gt.3.and.rmax.ge.2)then
      write(*,*) 'CalcDgx D(1,0,1,0) = ',r,d(1,0,1,0)
      write(*,*) 'CalcDgx D(1,1,0,0) = ',r,d(1,1,0,0)
!      write(*,*) 'CalcDgx D(1,2,0,0) = ',r,D(1,2,0,0)
      write(*,*) 'CalcDgx D(0,3,0,0) = ',r,d(0,3,0,0)
      write(*,*) 'CalcDgx D(0,2,1,0) = ',r,d(0,2,1,0)
      write(*,*) 'CalcDgx D(0,0,3,0) = ',r,d(0,0,3,0)
      write(*,*) 'CalcDgx D(0,1,1,1) = ',r,d(0,1,1,1)
      write(*,*) 'CalcDgx D(0,0,2,1) = ',r,d(0,0,2,1)
    endif
      write(*,*) 'CalcDgx Dij_err',r,dij_err
      write(*,*) 'CalcDgx Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgx err',r,derr
      write(*,*) 'CalcDgx acc',r,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
#ifdef Dgxtest
!      write(*,*) 'CalcDgx exit r',r,maxval(Derr),acc_req_D*abs(D(0,0,0,0))
#endif
 
!      if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit    ! changed 28.01.15
      ! check if target precision already reached
! NEEDS UPDATE
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        do rg=r+1,rmax
        do n0=0,rg/2
        do n1=0,rg-2*n0
        do n2=0,rg-2*n0-n1
          d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
        enddo
        enddo
        enddo
        enddo
 
        exit rloop
 
      end if
 
    end do rloop
 
 
#ifdef Dgxtest
!    write(*,*) 'CalcDgx D(0,0,0,0) = ',D(0,0,0,0)
!    if(rmax.ge.3)then
!      write(*,*) 'CalcDgx D(0,1,1,1) = ',D(0,1,1,1)
!    endif
 
    write(*,*) 'CalcDgx final err',derr
    write(*,*) 'CalcDgx final acc',derr/abs(d(0,0,0,0))
#endif      
       
!    write(*,*) 'CalcDgx Derr ',Derr
!    write(*,*) 'CalcDgx Derr2',Derr2
                    
  end subroutine calcdgx
 
 
 
 
 
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgy(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordgy_min,ordgy_max,id,Derr,Derr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgy(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgy_min,ordgy_max,id,Derr,Derr2)  
  
    use globald
 
    integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex ::Zadj2(4)
    double complex, allocatable :: Dexpgy(:,:,:,:,:), DuvExpgy(:,:,:,:)
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: C_0(:,:,:,:), C_i(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: Cuv_0(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3), Daux, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp,acc_aux
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,a,b,i,g,rg,m,n
    integer :: inds0(3),inds(3),inds2(2,4),at,bt,k,l,lt,ltt,nl,nlt,nltt
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgytest
    write(*,*) 'CalcDgy in, ord',rmax,ordgy_min,ordgy_max
#endif
 
    ! allocation of C functions
    rmaxc = rmax + 2*ordgy_min + 1
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax+1) = acc_req_cind
    acc_aux = acc_req_c
    if (y_gy.ne.0d0) then
      do g=1,ordgy_min
        acc_req_cextra(rmax+2*g) = acc_req_cextra(rmax+2*g-2)/y_gy
        acc_req_cextra(rmax+2*g+1) = acc_req_cextra(rmax+2*g-1)/y_gy
        acc_aux = acc_aux/max(x_gy,v_gy*y_gy)
        acc_req_cextra(rmax+g+1) = min(acc_req_cextra(rmax+g+1),acc_aux)
      end do
    else if(x_gy.ne.0d0) then ! 10.07.2017
      do g=1,ordgy_min
        acc_aux = acc_aux/x_gy
        acc_req_cextra(rmax+g+1) = acc_aux
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+2:rmax+2*ordgy_min+1) = acc_inf
    end if
   
 
 
#ifdef Dgytest
    write(*,*) 'CalcDgy: accreq_Cextra',acc_req_cextra
#endif
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
#ifdef Dgytest
    write(*,*) 'CalcDgy Cerr 0',cerr_i(:,0)
    write(*,*) 'CalcDgy Cerr 1',cerr_i(:,1)
    write(*,*) 'CalcDgy Cerr 2',cerr_i(:,2)
    write(*,*) 'CalcDgy Cerr 3',cerr_i(:,3)
#endif
 
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
      
 
    ! calculate adjugated Gram and Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
!
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q10+q20-q21
!    Z(3,1) = q10+q30-q31
!    Z(1,2) = Z(2,1)
!    Z(2,2) = 2d0*q20
!    Z(3,2) = q20+q30-q32
!    Z(1,3) = Z(3,1)
!    Z(2,3) = Z(3,2)
!    Z(3,3) = 2d0*q30
!
!    q1q2 = (q10+q20-q21)
!    q1q3 = (q10+q30-q31)
!    q2q3 = (q20+q30-q32)
!    detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3  &
!     &    -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
!
!    Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
!    Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
!    Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
!    Zadj(1,2) = Zadj(2,1)
!    Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
!    Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
!    Zadj(1,3) = Zadj(3,1)
!    Zadj(2,3) = Zadj(3,2)
!    Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
!      
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
!    Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
 
!    Xadj(1,1) = 2d0*mm02*Zadj(1,1) - f(2)*f(2)*Z(3,3)  &
!              + 2d0*f(2)*f(3)*Z(2,3) - f(3)*f(3)*Z(2,2)
!    Xadj(2,1) = 2d0*mm02*Zadj(2,1) + f(1)*f(2)*Z(3,3)  &
!              - f(1)*f(3)*Z(2,3) - f(2)*f(3)*Z(1,3) + f(3)*f(3)*Z(2,1)
!    Xadj(3,1) = 2d0*mm02*Zadj(3,1) - f(1)*f(2)*Z(3,2)  &
!              + f(2)*f(2)*Z(3,1) + f(1)*f(3)*Z(2,2) - f(2)*f(3)*Z(1,2)
!    Xadj(1,2) = Xadj(2,1)
!    Xadj(2,2) = 2d0*mm02*Zadj(2,2) - f(1)*f(1)*Z(3,3)  &
!              + 2d0*f(1)*f(3)*Z(1,3) - f(3)*f(3)*Z(1,1)
!    Xadj(3,2) = 2d0*mm02*Zadj(3,2) + f(1)*f(1)*Z(3,2)  &
!              - f(1)*f(2)*Z(3,1) - f(1)*f(3)*Z(2,1) + f(2)*f(3)*Z(1,1)
!    Xadj(1,3) = Xadj(3,1)
!    Xadj(2,3) = Xadj(3,2)
!    Xadj(3,3) = 2d0*mm02*Zadj(3,3) - f(1)*f(1)*Z(2,2)  &
!              + 2d0*f(1)*f(2)*Z(2,1) - f(2)*f(2)*Z(1,1)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
            end if
 
            if(n3.eq.0) then
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
            end if
 
#ifdef Dgytest
          if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.1)then
            write(*,*) 'CalcDgy 0 C_0',c_0(n0,n1,n2,n3)
            write(*,*) 'CalcDgy 0 C_1',c_i(n0,n2,n3,1)
            write(*,*) 'CalcDgy 0 C_2',c_i(n0,n1,n3,2)
            write(*,*) 'CalcDgy 0 C_3',c_i(n0,n1,n2,3)
            write(*,*) 'CalcDgy 0 Sh1',shat(n0,n1,n2,n3,1)
            write(*,*) 'CalcDgy 0 Sh2',shat(n0,n1,n2,n3,2)
            write(*,*) 'CalcDgy 0 Sh3',shat(n0,n1,n2,n3,3)
          endif
#endif
 
          end do
        end do
      end do
    end do
 
    ! choose reduction formulas with biggest denominators
    maxxadj = 0d0
    if (abs(xadj(1,1)).gt.maxxadj) then
      maxxadj = abs(xadj(1,1))
      a = 1
      b = 1
      inds2 = reshape((/2,2,2,3,3,2,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,2)
      zadj2(3) = z(2,3)
      zadj2(4) = -z(2,2)
    end if
    if (abs(xadj(2,2)).gt.maxxadj) then
      maxxadj = abs(xadj(2,2))
      a = 2
      b = 2
      inds2 = reshape((/1,1,1,3,3,1,3,3/),shape(inds2))
      zadj2(1) = -z(3,3)
      zadj2(2) = z(3,1)
      zadj2(3) = z(1,3)
      zadj2(4) = -z(1,1)
    end if
    if (abs(xadj(3,3)).gt.maxxadj) then
      maxxadj = abs(xadj(3,3))
      a = 3
      b = 3
      inds2 = reshape((/1,1,1,2,2,1,2,2/),shape(inds2))
      zadj2(1) = -z(2,2)
      zadj2(2) = z(2,1)
      zadj2(3) = z(1,2)
      zadj2(4) = -z(1,1)
    end if
    if (abs(xadj(1,2)).gt.maxxadj) then
      maxxadj = abs(xadj(1,2))
      a = 1
      b = 2
      inds2 = reshape((/2,1,2,3,3,1,3,3/),shape(inds2))
      zadj2(1) = z(3,3)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(2,3)
      zadj2(4) = z(2,1)
    end if
    if (abs(xadj(1,3)).gt.maxxadj) then
      maxxadj = abs(xadj(1,3))
      a = 1
      b = 3
      inds2 = reshape((/2,1,2,2,3,1,3,2/),shape(inds2))
      zadj2(1) = -z(3,2)
      zadj2(2) = z(3,1)
      zadj2(3) = z(2,2)
      zadj2(4) = -z(2,1)
    end if
    if (abs(xadj(2,3)).gt.maxxadj) then
      a = 2
      b = 3
      inds2 = reshape((/1,1,1,2,3,1,3,2/),shape(inds2))
      zadj2(1) = z(3,2)
      zadj2(2) = -z(3,1)
      zadj2(3) = -z(1,2)
      zadj2(4) = z(1,1)
    end if
 
    maxzadj = 0d0
    if (abs(zadj(1,1)).gt.maxzadj) then
      maxzadj = abs(zadj(1,1))
      k = 1
      l = 1
      lt = 2
      ltt = 3
    end if
    if (abs(zadj(2,2)).gt.maxzadj) then
      maxzadj = abs(zadj(2,2))
      k = 2
      l = 2
      lt = 1
      ltt = 3
    end if
    if (abs(zadj(3,3)).gt.maxzadj) then
      maxzadj = abs(zadj(3,3))
      k = 3
      l = 3
      lt = 1
      ltt = 2
    end if
    if (abs(zadj(1,2)).gt.maxzadj) then
      maxzadj = abs(zadj(1,2))
      k = 1
      l = 2
      lt = 1
      ltt = 3
    end if
    if (abs(zadj(1,3)).gt.maxzadj) then
      maxzadj = abs(zadj(1,3))
      k = 1
      l = 3
      lt = 1
      ltt = 2
    end if
    if (abs(zadj(2,3)).gt.maxzadj) then
      k = 2
      l = 3
      lt = 1
      ltt = 2
    end if
 
#ifdef Dgytest
    write(*,*) 'CalcDgy: Zadj',k,l,zadj(k,l)
    write(*,*) 'CalcDgy: Xadj',a,b,xadj(a,b)
#endif
 
        
    ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
   
 
    ! calculate Cuv
    allocate(duvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpgy,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgy(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
 
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
!    maxZadj = maxval(abs(Zadj))
!    maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
!    maxZadjf = maxval(abs(Zadjf))
!    adetZ = abs(detZ)
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(max(maxZadjf,adetZ)/maxXadj*max(1d0,maxZadj2f/maxZadj)) * truncfacD
    truncfacexp = sqrt(fac_gy) * truncfacd
    gtrunc = ordgy_max 
 
! calculate D(1,n1,n2,n3) up to rank r+2
! calculate D(0,n1,n2,n3) up to rank r  
    rloop: do r=0,rmaxexp-2
 
      if (r.gt.rmax+2*gtrunc+2) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating D_00ijk.. exploiting eq. (5.49)
      maxdexpgy(1,r,0)=0d0
      do nl=r,0,-1
        do nlt=r-nl,0,-1
          nltt = r-nl-nlt
          inds0(l) = nl
          inds0(lt) = nlt
          inds0(ltt) = nltt
 
          inds(l) = nl+1
          inds(lt) = nlt
          inds(ltt) = nltt
 
          daux = zadj(k,1)*shat(0,inds(1),inds(2),inds(3),1)  &
               + zadj(k,2)*shat(0,inds(1),inds(2),inds(3),2)  &
               + zadj(k,3)*shat(0,inds(1),inds(2),inds(3),3)
 
          if (nlt.ge.1) then
            inds(lt) = nlt-1
            daux = daux - 2*nlt*zadj(k,lt)*dexpgy(1,inds(1),inds(2),inds(3),0)
          end if
 
          if (nltt.ge.1) then
            inds(lt) = nlt
            inds(ltt) = nltt-1
            daux = daux - 2*nltt*zadj(k,ltt)*dexpgy(1,inds(1),inds(2),inds(3),0)
          end if
 
          dexpgy(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1)*zadj(k,l))
 
          maxdexpgy(1,r,0) =  maxdexpgy(1,r,0) + abs(dexpgy(1,inds0(1),inds0(2),inds0(3),0) )
 
!          if (r+2.le.rmax) then          !  for fixed rank
          if (r+1.le.rmax) then
            d(1,inds0(1),inds0(2),inds0(3)) = dexpgy(1,inds0(1),inds0(2),inds0(3),0)
          end if
      
 
 
        end do
      end do
 
      ! calculate D_ijkl.. exploiting eq. (5.53)
      maxdexpgy(0,r,0)=0d0
      do n1=0,r
        do n2=0,r-n1
          n3 = r-n1-n2
 
! Duv added 16.05.14      
!          Daux = (2d0*(1+r)*Dexpgy(1,n1,n2,n3,0) - C_0(0,n1,n2,n3))*Zadj(a,b)
          daux = (2d0*(1+r)*dexpgy(1,n1,n2,n3,0)  - 4*duvexpgy(1,n1,n2,n3)  &
            - c_0(0,n1,n2,n3))*zadj(a,b)
 
          smod = shat(0,n1,n2,n3,:)
 
#ifdef Dgytest
          if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
            write(*,*) 'CalcDgy 0 Smod',smod
            write(*,*) 'CalcDgy 0 Daux',daux
          endif
#endif
 
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*dexpgy(1,n1-1,n2,n3,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*dexpgy(1,n1,n2-1,n3,0)
          end if
          if (n3.ge.1) then
            smod(3) = smod(3) - 2d0*n3*dexpgy(1,n1,n2,n3-1,0)
          end if
 
#ifdef Dgytest
          if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
            write(*,*) 'CalcDgy 0',r,a,b,zadjf(b)/xadj(a,b)
            write(*,*) 'CalcDgy 0',k,l,detz/zadj(k,l),zadjf(k)/zadj(k,l)
            write(*,*) 'CalcDgy 0 line1',r,daux/xadj(a,b)
          endif
#endif
 
          do i=1,4
            n = inds2(1,i)
            m = inds2(2,i)
            daux = daux + zadj2(i)*f(n)*smod(m)
 
#ifdef Dgytest
           if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
             write(*,*) 'CalcDgy 0 2f',r,i,zadj2(i)*f(n)*smod(m)/xadj(a,b)
           endif
#endif
 
          end do
 
          dexpgy(0,n1,n2,n3,0) = daux/xadj(a,b)
 
#ifdef Dgytest
          if(n1.eq.1.and.n2.eq.1.and.n3.eq.1)then
            write(*,*) 'CalcDgy D_0',r,dexpgy(0,n1,n2,n3,0) 
          endif
#endif
 
          maxdexpgy(0,r,0) =  maxdexpgy(0,r,0) + abs(dexpgy(0,n1,n2,n3,0))
          if (r.le.rmax) then
            d(0,n1,n2,n3) = dexpgy(0,n1,n2,n3,0)
!            Derr(r) =  abs(maxZadjf/maxXadj*Dexpgy(0,n1,n2,n3,0))
          end if
      
        end do
      end do
 
      if (r.le.rmax) then
!       Derr(r) =  abs(maxZadjf/Xadj(a,b))*maxDexpgy(0,r,0)
        derr(r) =  fac_gy*maxdexpgy(0,r,0)
      endif
 
      ! error propagation from C's
      d00_err(r+2) = cij_err(r+1)/2d0 
      dij_err(r)=max(maxzadj/maxxadj*max(2*(r+1)*d00_err(r+2),cerr_i(r,0)), &
                 maxzadj2f/maxxadj*max(2*d00_err(r+1),cij_err(r)))
 
      d00_err2(r+2) = cij_err2(r+1)/2d0 
      dij_err2(r)=max(maxzadj/maxxadj*max(2*(r+1)*d00_err2(r+2),cerr2_i(r,0)), &
                 maxzadj2f/maxxadj*max(2*d00_err2(r+1),cij_err2(r)))
      
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r/2)
        rg = rg-2
 
        ! calculating D_00ijk.. exploiting eq. (5.49)
        maxdexpgy(1,rg,g) = 0d0
        do nl=rg,0,-1
          do nlt=rg-nl,0,-1
            nltt = rg-nl-nlt
            inds0(l) = nl
            inds0(lt) = nlt
            inds0(ltt) = nltt
 
            inds = inds0
            inds(l) = inds(l)+1
            daux = -zadjf(k)*dexpgy(0,inds(1),inds(2),inds(3),g-1)
 
            inds(k) = inds(k)+1
            daux = daux - detz*dexpgy(0,inds(1),inds(2),inds(3),g-1)
 
            if (nlt.ge.1) then
              inds(l) = nl+1
              inds(lt) = nlt-1
              inds(ltt) = nltt
              daux = daux - 2*nlt*zadj(k,lt)*dexpgy(1,inds(1),inds(2),inds(3),g)
            end if
            if (nltt.ge.1) then
              inds(l) = nl+1
              inds(lt) = nlt
              inds(ltt) = nltt-1
              daux = daux - 2*nltt*zadj(k,ltt)*dexpgy(1,inds(1),inds(2),inds(3),g)
            end if
 
            dexpgy(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1)*zadj(k,l))
 
            maxdexpgy(1,rg,g) =  maxdexpgy(1,rg,g) + abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g) )
!            if (rg+2.le.rmax) then
!              D(1,inds0(1),inds0(2),inds0(3)) = D(1,inds0(1),inds0(2),inds0(3))  &
!                                              + Dexpgy(1,inds0(1),inds0(2),inds0(3),g)
!            end if
 
            
!  10.08.2017  factor 1d1 added for g=1 since first terms can cancel for certain cases
            if (g.eq.1.and.abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)).gt.   &
                1d1*truncfacexp*max(1/m2scale,maxdexpgy(1,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)).gt.   &
                truncfacexp*maxdexpgy(1,rg,g-1)) then
 
#ifdef Dgytest
                write(*,*) 'CalcDgy exit gloop',1,inds0(1),inds0(2),inds0(3),g, &
                abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgy(1,rg,g-1)
#endif
 
                gtrunc = g-1
                exit gloop
!               gtrunc = g
!               cycle gloop               ! worsens results !?
              end if
       
          end do
        end do
 
#ifndef PPEXP00
!          if (rg+2.le.rmax) then        ! for fixed rank
        if (rg+1.le.rmax) then
          do n1=0,rg
            do n2=0,rg-n1
              n3=rg-n1-n2
              d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgy(1,n1,n2,n3,g)
            end do
          end do
        end if
#endif
 
        ! calculate D_ijkl.. exploiting eq. (5.53)
        maxdexpgy(0,rg,g) = 0d0
        do n1=0,rg
          do n2=0,rg-n1
            n3 = rg-n1-n2
      
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
            inds(a) = inds(a)+1
            daux = 2*(1+rg)*dexpgy(1,n1,n2,n3,g)*zadj(a,b)  &
                 - zadjf(b)*dexpgy(0,inds(1),inds(2),inds(3),g-1)
 
            smod = 0d0
            if (n1.ge.1) then
              smod(1) = smod(1) - 2d0*n1*dexpgy(1,n1-1,n2,n3,g)
            end if
            if (n2.ge.1) then
              smod(2) = smod(2) - 2d0*n2*dexpgy(1,n1,n2-1,n3,g)
            end if
            if (n3.ge.1) then
              smod(3) = smod(3) - 2d0*n3*dexpgy(1,n1,n2,n3-1,g)
            end if
 
            do i=1,4
              n = inds2(1,i)
              m = inds2(2,i)
              daux = daux + zadj2(i)*f(n)*smod(m)
            end do
 
            dexpgy(0,n1,n2,n3,g) = daux/xadj(a,b)
 
            maxdexpgy(0,rg,g) =  maxdexpgy(0,rg,g) + abs(dexpgy(0,n1,n2,n3,g))
 
!            if (rg.le.rmax) then
!              D(0,n1,n2,n3) = D(0,n1,n2,n3) + Dexpgy(0,n1,n2,n3,g)
!            end if
 
            if (g.eq.1.and.abs(dexpgy(0,n1,n2,n3,g)).gt.               &
                truncfacexp*max(1/m2scale**2,maxdexpgy(0,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgy(0,n1,n2,n3,g)).gt.              &
                truncfacexp*maxdexpgy(0,rg,g-1)) then
 
#ifdef Dgytest
            write(*,*) 'CalcDgy cycle loop',n1,n2,n3,g,abs(dexpgy(0,n1,n2,n3,g)),abs(dexpgy(0,n1,n2,n3,g-1)),maxdexpgy(0,rg,g-1)
#endif
 
              gtrunc = g-1
              exit gloop
!             gtrunc = g
!             cycle gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.1)then
          d00_err(rg+2) = max(d00_err(rg+2),                      &
                              maxzadjf/maxzadj/2d0*dij_err(rg+1),         &
                              abs(detz)/maxzadj/2d0*dij_err(rg+2))
        end if
        dij_err(rg)=max(dij_err(rg),maxzadjf/maxxadj*dij_err(rg+1),     &
               2*(rg+1)*maxzadj/maxxadj*d00_err(rg+2),                  &
               2*maxzadj2f/maxxadj*d00_err(rg+1))
 
        if(rg.gt.1)then
          d00_err2(rg+2) = max(d00_err2(rg+2),                      &
                              maxzadjf/maxzadj/2d0*dij_err2(rg+1),         &
                              abs(detz)/maxzadj/2d0*dij_err2(rg+2))
        end if
        dij_err2(rg)=max(dij_err2(rg),maxzadjf/maxxadj*dij_err2(rg+1),     &
               2*(rg+1)*maxzadj/maxxadj*d00_err2(rg+2),                  &
               2*maxzadj2f/maxxadj*d00_err2(rg+1))
 
#ifdef PPEXP00
!          if (rg+2.le.rmax) then          !  for fixed rank
        if (rg+2.le.rmax) then
          do n1=0,rg
            do n2=0,rg-n1
              n3=rg-n1-n2
              d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgy(1,n1,n2,n3,g)
            end do
          end do
        end if
#endif
 
        if ((rg.le.rmax)) then
          derr(rg) = 0d0
          do n1=0,rg
            do n2=0,rg-n1
              n3 = rg-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgy(0,n1,n2,n3,g)
              if(abs(dexpgy(0,n1,n2,n3,g-1)).ne.0d0) then
!             Derr(rg)=max(Derr(rg),abs(Dexpgy(0,n1,n2,n3,g))**2/abs(Dexpgy(0,n1,n2,n3,g-1)))
                derr(rg)=max(derr(rg),abs(dexpgy(0,n1,n2,n3,g))*min(1d0,abs(dexpgy(0,n1,n2,n3,g))/abs(dexpgy(0,n1,n2,n3,g-1))))
              else
                derr(rg)=max(derr(rg),abs(dexpgy(0,n1,n2,n3,g)))
              endif
 
#ifdef Dgytest
!              write(*,*) 'CalcDgy Derr calc',rg,Derr(rg),n1,n2,n3,g,abs(Dexpgy(0,n1,n2,n3,g)),abs(Dexpgy(0,n1,n2,n3,g-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
          ! allow for one more term, as each step involves only even or odd ranks
#ifdef PVEST2
          if(dij_err2(rg).gt.3d0*derr(rg)) then
#else
          if(dij_err(rg).gt.3d0*derr(rg)) then
#endif
            gtrunc = min(g,gtrunc)
!           gtrunc = min(g+1,gtrunc)
             
#ifdef Dgytest
            write(*,*) 'CalcDgy exit err',rg,g,gtrunc
            write(*,*) 'CalcDgy exit err',dij_err(rg),derr(rg)
#endif
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgytest
 
      write(*,*) 'CalcDgy D(1,0,0,0)',r,d(1,0,0,0)
      write(*,*) 'CalcDgy D(0,0,0,0)',r,d(0,0,0,0)
      write(*,*) 'CalcDgy D(0,0,0,1)',r,d(0,0,0,1)
      if (r.ge.2.and.rmax.ge.2) then
      write(*,*) 'CalcDgy D(0,0,0,2)',r,d(0,0,0,2)
      endif
      if (r.ge.3.and.rmax.ge.3)then
      write(*,*) 'CalcDgy D(1,0,0,1)',r,d(1,0,0,1)
      write(*,*) 'CalcDgy D(0,1,0,2)',r,d(0,1,0,2)
      write(*,*) 'CalcDgy D(0,0,0,3)',r,d(0,0,0,3)
      write(*,*) 'CalcDgy D(0,1,1,1)',r,d(0,1,1,1)
      write(*,*) 'CalcDgy D(0,2,1,0)',r,d(0,2,1,0)
      endif
 
      write(*,*) 'CalcDgy Dij_err',r,dij_err
      write(*,*) 'CalcDgy Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgy err',r,g,derr
      write(*,*) 'CalcDgy acc',r,g,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
!     if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit     ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
        if (r.lt.rmax) then
          do rg=r+1,rmax
            do n1=0,rg
              do n2=0,rg-n1
                d(0,n1,n2,rg-n1-n2)=0d0
              end do
            end do
          end do
          do rg=r+1,rmax
            do n1=0,rg-2
              do n2=0,rg-2-n1
                d(1,n1,n2,rg-2-n1-n2)=0d0
              end do
            end do
          end do
          
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDgy',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDgy:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDgy: p10 = ',p10
            write(nerrout_coli,111)' CalcDgy: p21 = ',p21
            write(nerrout_coli,111)' CalcDgy: p32 = ',p32
            write(nerrout_coli,111)' CalcDgy: p30 = ',p30
            write(nerrout_coli,111)' CalcDgy: p20 = ',p20
            write(nerrout_coli,111)' CalcDgy: p31 = ',p31
            write(nerrout_coli,111)' CalcDgy: m02 = ',m02
            write(nerrout_coli,111)' CalcDgy: m12 = ',m12
            write(nerrout_coli,111)' CalcDgy: m22 = ',m22
            write(nerrout_coli,111)' CalcDgy: m32 = ',m32
          end if
        end if
 
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
 
        exit rloop
 
      end if
 
    end do rloop
 
 
    ! calculating D_0000ijk.. exploiting eq. (5.49)
!    do r=4,rmax
!!      do n0=2,rmax/2            !   for fixed rank
!      do n0=2,rmax
    do r=4,rmax+1                 !  includes rmax+1  24.01.16
      do n0=2,max(rmax,r/2)       !  includes rmax+1  24.01.16
        do nl=r-2*n0,0,-1
          do nlt=r-2*n0-nl,0,-1
            nltt = r-2*n0-nl-nlt
            inds0(l) = nl
            inds0(lt) = nlt
            inds0(ltt) = nltt
 
            inds(l) = nl+1
            inds(lt) = nlt
            inds(ltt) = nltt
            daux = zadj(k,1)*shat(n0-1,inds(1),inds(2),inds(3),1)  &
                 + zadj(k,2)*shat(n0-1,inds(1),inds(2),inds(3),2)  &
                 + zadj(k,3)*shat(n0-1,inds(1),inds(2),inds(3),3)  &
                 - zadjf(k)*d(n0-1,inds(1),inds(2),inds(3))
 
            inds(k) = inds(k)+1
            daux = daux - detz*d(n0-1,inds(1),inds(2),inds(3))
            inds(k) = inds(k)-1
 
            if (nlt.ge.1) then
              inds(lt) = nlt-1
              daux = daux - 2*nlt*zadj(k,lt)*d(n0,inds(1),inds(2),inds(3))
            end if
            if (nltt.ge.1) then
              inds(lt) = nlt
              inds(ltt) = nltt-1
              daux = daux - 2*nltt*zadj(k,ltt)*d(n0,inds(1),inds(2),inds(3))
            end if
 
            d(n0,inds0(1),inds0(2),inds0(3)) = daux/(2*(nl+1)*zadj(k,l))
 
          end do
        end do
      end do
    end do
 
    ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
    ! already calculated for rmax+1 with extension of 24.01.16 above
!    do r=rmax+1,2*rmax
#ifdef notneeded
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            write(*,*) 'CalcDgy exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
            write(*,*) 'CalcDgy dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
          end do
        end do
      end do
    end do
#endif
 
#ifdef Dgytest
      if(rmax.ge.2) then
      write(*,*) 'CalcDgy D(1,0,0,0) fin',d(1,0,0,0)
      write(*,*) 'CalcDgy D(0,0,2,0) fin',d(0,0,2,0)
      write(*,*) 'CalcDgy D(0,0,0,2) fin',d(0,0,0,2)
      if(rmax.ge.3) then
      write(*,*) 'CalcDgy D(1,0,1,0) fin',d(1,0,1,0)
      write(*,*) 'CalcDgy D(0,1,1,1) fin',d(0,1,1,1)
      write(*,*) 'CalcDgy D(0,0,3,0) fin',d(0,0,3,0)
      endif
      endif
 
    write(*,*) 'CalcDgy final err',derr
    write(*,*) 'CalcDgy final acc',derr/abs(d(0,0,0,0))
#endif
 
!    write(*,*) 'CalcDgy Derr ',Derr
!    write(*,*) 'CalcDgy Derr2',Derr2
 
  end subroutine calcdgy
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgp(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordgp_min,ordgp_max,id,Derr,Derr2
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgp(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgp_min,ordgp_max,id,Derr,Derr2)
  
    use globald
 
    integer, intent(in) :: rmax,ordgp_min,ordgp_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: Dexpgp(:,:,:,:,:), DuvExpgp(:,:,:,:)
    double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:)
    double complex, allocatable :: C_k(:,:,:), Cuv_k(:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod, fk, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpgp(0:1,0:rmax+ordgp_min+1,0:ordgp_max),truncfacexp
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,g,rg
    integer :: bin,nid(0:3),i
    logical :: errorwriteflag
 
#ifdef Dgtest
    write(*,*) 'CalcDgp in, ord',rmax,ordgp_min,ordgp_max
#endif
!   write(*,*) 'CalcDgp in, ',rmax,ordgp_min,ordgp_max
 
    ! calculate adjugated Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    mm32 = elimminf2_coli(m32)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q32  = elimminf2_coli(p32)
!    q30  = elimminf2_coli(p30)
!    q31  = elimminf2_coli(p31)
!    q20  = elimminf2_coli(p20)
!
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q10+q20-q21
!    Z(3,1) = q10+q30-q31
!    Z(1,2) = Z(2,1)
!    Z(2,2) = 2d0*q20
!    Z(3,2) = q20+q30-q32
!    Z(1,3) = Z(3,1)
!    Z(2,3) = Z(3,2)
!    Z(3,3) = 2d0*q30
!
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!    f(3) = q30+mm02-mm32
      
 
    ! choose reduction formulas with biggest denominators
    if (abs(f(1)).ge.max(abs(f(2)),abs(f(3)))) then
      k = 1
    else if (abs(f(2)).ge.max(abs(f(1)),abs(f(3)))) then
      k = 2
    else
      k = 3
    end if
    fk = f(k)
 
 
    ! allocation of C functions
    rmaxc = rmax + ordgp_min
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_k(0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_k(0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
 
    ! determine binaries for C-coefficients
    i=0
    bin = 1
    do while (i.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(i) = id+bin
        i = i+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax) =  acc_req_cind
    if(w_gp.ne.0d0) then
      do r=rmax+1,rmaxc
        acc_req_cextra(r)= acc_req_cextra(r-1)/w_gp
      end do
    else ! 10.07.2017
      acc_req_cextra(rmax+1:rmaxc)=acc_inf
    endif
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    if (k.eq.1) then
      call calcc(c_k(:,:,:),cuv_k(:,:,:),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    else if (k.eq.2) then
      call calcc(c_k(:,:,:),cuv_k(:,:,:),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    else if (k.eq.3) then
      call calcc(c_k(:,:,:),cuv_k(:,:,:),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
    end if
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc))
 
    do r=0,rmaxc
      do n1=0,r
        do n2=0,r-n1
          n3 = r-n1-n2
 
          shat(n1,n2,n3) = -c_0(0,n1,n2,n3)
 
          if ((k.eq.1).and.(n1.eq.0)) then
            shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n2,n3)
          else if ((k.eq.2).and.(n2.eq.0)) then
            shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n1,n3)
          else if ((k.eq.3).and.(n3.eq.0)) then
            shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n1,n2)
          end if
 
        end do
      end do
    end do
 
           
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpgp(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgp_max))
 
    ! calculate Duv
    allocate(duvexpgp(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpgp,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgp(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
 
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
 
!   write(*,*) 'Dgp Cerr 0 ',Cerr_i(:,0)
!   write(*,*) 'Dgp Cerr k ',Cerr_i(:,k)
 
    cij_err = max(cerr_i(:,0),cerr_i(:,k))
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,k))
 
!    maxZ = maxval(abs(Z))
!    maxZ=2d0*q2max 
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(abs(maxZ/abs(fk))) * truncfacD
    truncfacexp = sqrt(fac_gp) * truncfacd
    gtrunc = ordgp_max 
 
! calculate D(n0,n1,n2,n3) up to rank r for n0>0 and up to rank r-1 for n0=0
    rloop: do r=1,rmaxexp
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
      ! exploiting eq. (5.63)
      maxdexpgp(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3=r-2*n0-n1-n2
 
            dexpgp(n0,n1,n2,n3,0) = (2d0*duvexpgp(n0,n1,n2,n3) + c_0(n0-1,n1,n2,n3)  &
               + mm02*dexpgp(n0-1,n1,n2,n3,0))/((r-n0)+1)/2d0
 
            if (n0.eq.1) then
              maxdexpgp(1,r,0) =  maxdexpgp(1,r,0) + abs(dexpgp(n0,n1,n2,n3,0) )
            end if
 
            if (r-n0.le.rmax) then
              d(n0,n1,n2,n3) = dexpgp(n0,n1,n2,n3,0)
            end if
 
          end do
        end do
      end do
 
#ifdef Dgptest      
      write(*,*) 'CalcDgp 0 D(1,0,1,0)= ',r,d(1,0,1,0)
#endif
 
 
      ! calculate
      ! D_00ijkl.. --> D_aijkl..
      ! exploiting eq. (5.62)
      maxdexpgp(0,r-1,0)=0d0
      do n1=0,r-1
        do n2=0,r-1-n1
          n3 = r-1-n1-n2
 
          smod = shat(n1,n2,n3)
          if ((k.eq.1).and.(n1.ge.1)) then
            smod = smod - 2d0*n1*dexpgp(1,n1-1,n2,n3,0)
          else if ((k.eq.2).and.(n2.ge.1)) then
            smod = smod - 2d0*n2*dexpgp(1,n1,n2-1,n3,0)
          else if ((k.eq.3).and.(n3.ge.1)) then
            smod = smod - 2d0*n3*dexpgp(1,n1,n2,n3-1,0)
          end if
 
          dexpgp(0,n1,n2,n3,0) = smod/fk
          maxdexpgp(0,r-1,0) =  maxdexpgp(0,r-1,0) + abs(dexpgp(0,n1,n2,n3,0))
        
          if (r.le.rmax+1) then
            d(0,n1,n2,n3) = dexpgp(0,n1,n2,n3,0)
!            Derr(r-1) =  abs(maxZ/fk*Dexpgp(0,n1,n2,n3,0))
          end if
 
        end do
      end do
   
      if (r.le.rmax+1) then
!       Derr(r-1) =  abs(maxZ/fk)*maxDexpgp(0,r-1,0)
        derr(r-1) =  fac_gp*maxdexpgp(0,r-1,0)
      endif
 
      ! error propagation from C's
      if(r.gt.1)then
        d00_err(r) = cij_err(r-2)/(2*r)
      end if
      dij_err(r-1)=max(cij_err(r-1),2*d00_err(r))/abs(fk)
 
      if(r.gt.1)then
        d00_err2(r) = cij_err2(r-2)/(2*r)
      end if
      dij_err2(r-1)=max(cij_err2(r-1),2*d00_err2(r))/abs(fk)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
 
        ! calculating
        ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
        ! exploiting eq. (5.63)
        maxdexpgp(1,rg,g) = 0d0
        do n0=rg/2,1,-1
          do n1=0,rg-2*n0
            do n2=0,rg-2*n0-n1
              n3=rg-2*n0-n1-n2
 
              dexpgp(n0,n1,n2,n3,g) = (2d0*mm02*dexpgp(n0-1,n1,n2,n3,g)  &
               - z(1,1)*dexpgp(n0-1,n1+2,n2,n3,g-1) - 2d0*z(2,1)*dexpgp(n0-1,n1+1,n2+1,n3,g-1)  &
               - 2d0*z(3,1)*dexpgp(n0-1,n1+1,n2,n3+1,g-1) - z(2,2)*dexpgp(n0-1,n1,n2+2,n3,g-1)  &
               - 2d0*z(3,2)*dexpgp(n0-1,n1,n2+1,n3+1,g-1) - z(3,3)*dexpgp(n0-1,n1,n2,n3+2,g-1))  &
               /((rg-n0)+1d0)/4d0
 
              if(n0.eq.1) then
                maxdexpgp(1,rg,g) =  maxdexpgp(1,rg,g) + abs(dexpgp(n0,n1,n2,n3,g))
 
#ifdef Dgptest
                if(n0.eq.1.and.n1.eq.0.and.n2.eq.1.and.n3.eq.0) then
                  write(*,*) 'CalcDgp  Dexp(1,0,1,0,g)',r,rg,g,dexpgp(1,0,1,0,g)
                  write(*,*) 'CalcDgp  D(1,0,1,0)',r,rg,g,d(1,0,1,0)
                  write(*,*) 'CalcDgp  maxDexpgp(1,rg,g)',r,rg,g,maxdexpgp(1,rg,g)
                  if(g.gt.0) write(*,*) 'CalcDgp  trunc',abs(dexpgp(n0,n1,n2,n3,g)),   &
                      truncfacexp*maxdexpgp(1,rg,g-1),truncfacexp,maxdexpgp(1,rg,g-1)
                endif
#endif
 
                if (g.eq.1.and.abs(dexpgp(1,n1,n2,n3,g)).gt.            &
                    truncfacexp*max(1/m2scale,maxdexpgp(1,rg,g-1)) .or. &
                    g.ge.2.and.abs(dexpgp(1,n1,n2,n3,g)).gt.            &
                    truncfacexp*maxdexpgp(1,rg,g-1)) then
 
                  gtrunc = g-1
                  exit gloop
                end if
              end if
 
 
            end do
          end do
        end do
 
#ifndef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              do n2=0,rg-2*n0-n1
                n3=rg-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgp(n0,n1,n2,n3,g)
              end do
            end do
          end if
        end do
#endif
 
        ! calculate
        ! D_00ijkl.. --> D_aijkl..
        ! exploiting eq. (5.62)
        maxdexpgp(0,rg-1,g) = 0d0
        do n1=0,rg-1
          do n2=0,rg-1-n1
            n3 = rg-1-n1-n2
 
            smod = -z(1,k)*dexpgp(0,n1+1,n2,n3,g-1)  &
                   -z(2,k)*dexpgp(0,n1,n2+1,n3,g-1)  &
                   -z(3,k)*dexpgp(0,n1,n2,n3+1,g-1)
            if ((k.eq.1).and.(n1.ge.1)) then
              smod = smod - 2d0*n1*dexpgp(1,n1-1,n2,n3,g)
            else if ((k.eq.2).and.(n2.ge.1)) then
              smod = smod - 2d0*n2*dexpgp(1,n1,n2-1,n3,g)
            else if ((k.eq.3).and.(n3.ge.1)) then
              smod = smod - 2d0*n3*dexpgp(1,n1,n2,n3-1,g)
            end if
 
            dexpgp(0,n1,n2,n3,g) = smod/fk
        
            maxdexpgp(0,rg-1,g) =  maxdexpgp(0,rg-1,g) + abs(dexpgp(0,n1,n2,n3,g))
 
            if (g.eq.1.and.abs(dexpgp(0,n1,n2,n3,g)).gt.                  &
                truncfacexp*max(1/m2scale**2,maxdexpgp(0,rg-1,g-1)) .or.  &
                g.ge.2.and.abs(dexpgp(0,n1,n2,n3,g)).gt.                  &
                truncfacexp*maxdexpgp(0,rg-1,g-1)) then
 
              gtrunc = g-1
              exit gloop
            end if
        
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.1)then
          d00_err(rg) = max(d00_err(rg),max(2*abs(m02)*dij_err(rg-2),maxz*dij_err(rg))/(4*r))
        end if
        dij_err(rg-1) = max(dij_err(rg-1),max(2*d00_err(rg),maxz*dij_err(rg))/abs(fk))
 
        if(rg.gt.1)then
          d00_err2(rg) = max(d00_err2(rg),max(2*abs(m02)*dij_err2(rg-2),maxz*dij_err2(rg))/(4*r))
        end if
        dij_err2(rg-1) = max(dij_err2(rg-1),max(2*d00_err2(rg),maxz*dij_err2(rg))/abs(fk))
 
#ifdef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              do n2=0,rg-2*n0-n1
                n3=rg-2*n0-n1-n2
                d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgp(n0,n1,n2,n3,g)
              end do
            end do
          end if
        end do
#endif
 
        if ((rg.le.rmax+1)) then
          derr(rg-1) = 0d0
          do n1=0,rg-1
            do n2=0,rg-1-n1
              n3 = rg-1-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgp(0,n1,n2,n3,g)
              if(abs(dexpgp(0,n1,n2,n3,g-1)).ne.0d0) then
!              Derr(rg-1)=max(Derr(rg-1),abs(Dexpgp(0,n1,n2,n3,g))**2/abs(Dexpgp(0,n1,n2,n3,g-1)))
                derr(rg-1)=max(derr(rg-1),abs(dexpgp(0,n1,n2,n3,g))*min(1d0,abs(dexpgp(0,n1,n2,n3,g))/abs(dexpgp(0,n1,n2,n3,g-1))))
              else
                derr(rg-1)=max(derr(rg-1),abs(dexpgp(0,n1,n2,n3,g)))
              end if
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
#ifdef PVEST2
          if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
#else
          if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
#endif
             gtrunc = min(g,gtrunc)
             
#ifdef Dgptest
             write(*,*) 'CalcDgp exit err',r,g,gtrunc
#endif
          end if  
 
        end if
 
      end do gloop
 
#ifdef Dgptest
      write(*,*) 'CalcDgp D(0,0,0,0)',r,d(0,0,0,0)
      write(*,*) 'CalcDgp D(0,0,1,0)',r,d(0,0,1,0)
      write(*,*) 'CalcDgp D(1,0,0,0)',r,d(1,0,0,0)
      write(*,*) 'CalcDgp D(1,0,1,0)',r,d(1,0,1,0)
      write(*,*) 'CalcDgp D(0,0,3,0)',r,d(0,0,3,0)
 
      write(*,*) 'CalcDgp Dij_err',r,dij_err
      write(*,*) 'CalcDgp Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgp err',r,derr
      write(*,*) 'CalcDgp acc',r,derr/abs(d(0,0,0,0))
#endif              
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
!     if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit     ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
        if (r.lt.rmax) then
          do rg=r+1,rmax
!            write(*,*) 'CalcDg exit rloop  =',rg,r,rmax
            do n0=0,rg/2
              do n1=0,rg-2*n0
                do n2=0,rg-2*n0-n1
                  d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
                end do
              end do
            end do
          end do
          if(r.le.rmax) then
            do n1=0,r
              do n2=0,rg-n1
                d(0,n1,n2,r-n1-n2)=0d0
              end do
            end do
          end if
          
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDgp',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDgp:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDgp: p10 = ',p10
            write(nerrout_coli,111)' CalcDgp: p21 = ',p21
            write(nerrout_coli,111)' CalcDgp: p32 = ',p32
            write(nerrout_coli,111)' CalcDgp: p30 = ',p30
            write(nerrout_coli,111)' CalcDgp: p20 = ',p20
            write(nerrout_coli,111)' CalcDgp: p31 = ',p31
            write(nerrout_coli,111)' CalcDgp: m02 = ',m02
            write(nerrout_coli,111)' CalcDgp: m12 = ',m12
            write(nerrout_coli,111)' CalcDgp: m22 = ',m22
            write(nerrout_coli,111)' CalcDgp: m32 = ',m32
          end if
        end if
 
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
    ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
    ! already calculated for rmax+1
!    do r=rmax+1,2*rmax
#ifdef notneeded
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            write(*,*) 'CalcDgp exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
            write(*,*) 'CalcDgp exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
          end do
        end do
      end do
    end do
#endif
 
#ifdef Dgptest
      write(*,*) 'CalcDgp D(1,0,0,0) fin',d(1,0,0,0)
      write(*,*) 'CalcDgp D(1,0,1,0) fin',d(1,0,1,0)
      write(*,*) 'CalcDgp D(0,0,3,0) fin',d(0,0,3,0)
      write(*,*) 'CalcDgp D(0,1,1,1) fin',d(0,1,1,1)
 
    write(*,*) 'CalcDgp final err',derr
    write(*,*) 'CalcDgp final acc',derr/abs(d(0,0,0,0))
#endif                    
   
 
!    write(*,*) 'CalcDp Derr ',Derr
!    write(*,*) 'CalcDp Derr2',Derr2
 
  end subroutine calcdgp
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcDgpf(D,Duv,p10,p21,p32,p30,p20,p31,
  !                          m02,m12,m22,m32,rmax,ordgpf_min,ordgpf_max,id,Derr,Derr2)
  !  added by AD  16.08.2017
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcdgpf(D,Duv,p10,p21,p32,p30,p20,p31,  &
                          m02,m12,m22,m32,rmax,ordgpf_min,ordgpf_max,id,Derr,Derr2)  
  
    use globald
 
    integer, intent(in) :: rmax,ordgpf_min,ordgpf_max,id
    double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
    double complex ::Zadj2(4)
    double complex, allocatable :: Dexpgpf(:,:,:,:,:), DuvExpgpf(:,:,:,:)
    double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
    double complex, allocatable :: C_0(:,:,:,:), C_i(:,:,:,:), Shat(:,:,:,:,:)
    double complex, allocatable :: Cuv_0(:,:,:,:), Cuv_i(:,:,:,:)
    double complex, allocatable :: D_alt(:,:,:,:)
    double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
    double complex :: Smod(3), Daux, elimminf2_coli
    double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
    double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
    double precision :: maxDexpgpf(0:1,0:rmax+2*ordgpf_min,0:ordgpf_max),truncfacexp,acc_aux
    double precision :: minZk 
    integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,a,b,i,j,g,rg,m,n
    integer :: inds0(3),inds(3),inds2(2,4),at,bt,k,l,lt,ltt,nl,nlt,nltt
    integer :: bin,nid(0:3)
    logical :: errorwriteflag
 
#ifdef Dgpftest
    write(*,*) 'CalcDgpf in, ord',rmax,ordgpf_min,ordgpf_max
#endif
 
    ! allocation of C functions
    rmaxc = rmax + 2*ordgpf_min + 1
    allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
    allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
    allocate(cerr_i(0:rmaxc,0:3))
    allocate(cerr2_i(0:rmaxc,0:3))
    allocate(acc_req_cextra(0:rmaxc))
    
    ! determine binaries for C-coefficients
    k=0
    bin = 1
    do while (k.le.3)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
    ! by estimated suppression factors that are multiplied in expansion
    acc_req_cextra(0:rmax+1) = acc_req_cind
    acc_aux = acc_req_c
    if (y_gpf.ne.0d0) then
      do g=1,ordgpf_min
        acc_req_cextra(rmax+2*g) = acc_req_cextra(rmax+2*g-2)/y_gpf
        acc_req_cextra(rmax+2*g+1) = acc_req_cextra(rmax+2*g-1)/y_gpf
        acc_aux = acc_aux/max(x_gpf,v_gpf*y_gpf)
        acc_req_cextra(rmax+g+1) = min(acc_req_cextra(rmax+g+1),acc_aux)
      end do
    else if(x_gpf.ne.0d0) then ! 10.07.2017
      do g=1,ordgpf_min
        acc_aux = acc_aux/x_gpf
        acc_req_cextra(rmax+g+1) = acc_aux
      end do
    else ! 10.07.2017
       acc_req_cextra(rmax+2:rmax+2*ordgpf_min+1) = acc_inf
    end if
   
 
 
#ifdef Dgpftest
    write(*,*) 'CalcDgpf: accreq_Cextra',acc_req_cextra
#endif
 
    call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
    call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
 
#ifdef Dgpftest
    write(*,*) 'CalcDgpf Cerr 0',cerr_i(:,0)
    write(*,*) 'CalcDgpf Cerr 1',cerr_i(:,1)
    write(*,*) 'CalcDgpf Cerr 2',cerr_i(:,2)
    write(*,*) 'CalcDgpf Cerr 3',cerr_i(:,3)
#endif
 
 
    ! shift of integration momentum in C\{0}
    do n1=1,rmaxc
      do n2=0,rmaxc-n1
        do n3=0,rmaxc-n1-n2
          n0 = (rmaxc-n1-n2-n3)
          c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3)  &
                            -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
          cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3)  &
                              -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
        end do
      end do
    end do
      
 
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
 
    do r=0,rmaxc
      do n0=0,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
 
            if(n1.eq.0) then
              shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
            end if
 
            if(n2.eq.0) then
              shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
            end if
 
            if(n3.eq.0) then
              shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
            end if
 
#ifdef Dgpftest
          if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.1)then
            write(*,*) 'CalcDgpf 0 C_0',c_0(n0,n1,n2,n3)
            write(*,*) 'CalcDgpf 0 C_1',c_i(n0,n2,n3,1)
            write(*,*) 'CalcDgpf 0 C_2',c_i(n0,n1,n3,2)
            write(*,*) 'CalcDgpf 0 C_3',c_i(n0,n1,n2,3)
            write(*,*) 'CalcDgpf 0 Sh1',shat(n0,n1,n2,n3,1)
            write(*,*) 'CalcDgpf 0 Sh2',shat(n0,n1,n2,n3,2)
            write(*,*) 'CalcDgpf 0 Sh3',shat(n0,n1,n2,n3,3)
          endif
#endif
 
          end do
        end do
      end do
    end do
 
    ! choose reduction formulas with smallest expansion terms
    minzk = maxz
    if (maxval(abs(z(1,1:3))).le.minzk) then
      minzk = maxval(abs(z(1,1:3)))
      k = 1
      l = 1
      lt = 2
      ltt = 3 
    end if
    if (maxval(abs(z(2,1:3))).lt.minzk) then
      minzk = maxval(abs(z(2,1:3)))
      k = 2
      l = 2
      lt = 3
      ltt = 1 
    end if
    if (maxval(abs(z(3,1:3))).lt.minzk) then
      minzk = maxval(abs(z(3,1:3)))
      k = 3
      l = 3
      lt = 1
      ltt = 2 
    end if
 
#ifdef Dgpftest
    write(*,*) 'CalcDgpf: Z',k, maxval(abs(z(k,1:3)))
#endif
 
        
    ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
    rmaxexp = rmaxc+1
    allocate(dexpgpf(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:rmaxexp-2,0:ordgpf_max))
   
 
    ! calculate Cuv
    allocate(duvexpgpf(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calcduv(duvexpgpf,cuv_0,mm02,f,rmaxexp,id)
    duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgpf(0:rmax,0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(d00_err(0:rmaxexp))
    allocate(dij_err(0:rmaxexp))
    allocate(cij_err(0:rmaxc))
 
    allocate(d00_err2(0:rmaxexp))
    allocate(dij_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxc))
 
    ! initialize accuracy estimates
    derr = acc_inf
    dij_err =0d0
    d00_err =0d0
    cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
 
    derr2 = acc_inf
    dij_err2 =0d0
    d00_err2 =0d0
    cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
    truncfacexp = sqrt(fac_gpf) * truncfacd
    gtrunc = ordgpf_max 
 
! calculate D(1,n1,n2,n3) up to rank r+2
! calculate D(0,n1,n2,n3) up to rank r  
    rloop: do r=0,rmaxexp-2
 
      if (r.gt.rmax+2*gtrunc+2) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating D_00ijk.. exploiting eq. (5.71)
      maxdexpgpf(1,r,0)=0d0
      do nl=r,0,-1
        do nlt=r-nl,0,-1
          nltt = r-nl-nlt
          inds0(l) = nl
          inds0(lt) = nlt
          inds0(ltt) = nltt
 
          inds(l) = nl+1
          inds(lt) = nlt
          inds(ltt) = nltt
 
          daux = shat(0,inds(1),inds(2),inds(3),k) 
 
          dexpgpf(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1))
 
          maxdexpgpf(1,r,0) =  maxdexpgpf(1,r,0) + abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),0) )
 
!          if (r+2.le.rmax) then          !  for fixed rank
          if (r+1.le.rmax) then
            d(1,inds0(1),inds0(2),inds0(3)) = dexpgpf(1,inds0(1),inds0(2),inds0(3),0)
          end if
      
 
 
        end do
      end do
 
      ! calculate D_ijkl.. exploiting eq. (5.72)
      maxdexpgpf(0,r,0)=0d0
      do n1=0,r
        do n2=0,r-n1
          n3 = r-n1-n2
 
          daux = 2d0*(4+r+r)*dexpgpf(1,n1,n2,n3,0) - 4*duvexpgpf(1,n1,n2,n3)  &
            - 2*c_0(0,n1,n2,n3)
 
#ifdef Dgpftest
          if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
            write(*,*) 'CalcDgpf 0 Daux',daux
          endif
#endif
 
          dexpgpf(0,n1,n2,n3,0) = daux/(2d0*m02)
 
#ifdef Dgpftest
          if(n1.eq.1.and.n2.eq.1.and.n3.eq.1)then
            write(*,*) 'CalcDgpf D_0',r,dexpgpf(0,n1,n2,n3,0) 
          endif
#endif
 
          maxdexpgpf(0,r,0) =  maxdexpgpf(0,r,0) + abs(dexpgpf(0,n1,n2,n3,0))
          if (r.le.rmax) then
            d(0,n1,n2,n3) = dexpgpf(0,n1,n2,n3,0)
!            Derr(r) =  abs(maxZadjf/maxXadj*Dexpgpf(0,n1,n2,n3,0))
          end if
      
        end do
      end do
 
      if (r.le.rmax) then
!       Derr(r) =  abs(maxZadjf/Xadj(a,b))*maxDexpgpf(0,r,0)
        derr(r) =  fac_gpf*maxdexpgpf(0,r,0)
      endif
 
      ! error propagation from C's
      d00_err(r+2) = cij_err(r+1)/2d0 
      dij_err(r)=1d0/abs(m02)*max((2*r+4)*d00_err(r+2),cerr_i(r,0))
 
      d00_err2(r+2) = cij_err2(r+1)/2d0 
      dij_err2(r)=1d0/abs(m02)*max((2*r+4)*d00_err2(r+2),cerr2_i(r,0))
      
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r/2)
        rg = rg-2
 
        ! calculating D_00ijk.. exploiting eq. (5.71)
        maxdexpgpf(1,rg,g) = 0d0
        do nl=rg,0,-1
          do nlt=rg-nl,0,-1
            nltt = rg-nl-nlt
            inds0(l) = nl
            inds0(lt) = nlt
            inds0(ltt) = nltt
 
            inds = inds0
            inds(l) = inds(l)+1
            daux = -f(k)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
 
            inds(l) = inds(l)+1
            daux = daux - z(k,l)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
 
            inds(l) =  inds(l)-1
            inds(lt) =  inds(lt)+1
            daux = daux - z(k,lt)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
 
            inds(lt) =  inds(lt)-1
            inds(ltt) =  inds(ltt)+1
            daux = daux - z(k,ltt)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
 
            dexpgpf(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1))
 
            maxdexpgpf(1,rg,g) =  maxdexpgpf(1,rg,g) + abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g) )
!            if (rg+2.le.rmax) then
!              D(1,inds0(1),inds0(2),inds0(3)) = D(1,inds0(1),inds0(2),inds0(3))  &
!                                              + Dexpgpf(1,inds0(1),inds0(2),inds0(3),g)
!            end if
 
            
            if (g.eq.1.and.abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)).gt.   &
                1d1*truncfacexp*max(1/m2scale,maxdexpgpf(1,rg,g-1)) .or.      &
                g.ge.2.and.abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)).gt.   &
                truncfacexp*maxdexpgpf(1,rg,g-1)) then
 
#ifdef Dgpftest
                write(*,*) 'CalcDgpf exit gloop',1,inds0(1),inds0(2),inds0(3),g, &
                abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgpf(1,rg,g-1)
#endif
 
                gtrunc = g-1
                exit gloop
!               gtrunc = g
!               cycle gloop               ! worsens results for Dgy ??
              end if
       
          end do
        end do
 
#ifndef PPEXP00
!          if (rg+2.le.rmax) then        ! for fixed rank
        if (rg+1.le.rmax) then
          do n1=0,rg
            do n2=0,rg-n1
              n3=rg-n1-n2
              d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgpf(1,n1,n2,n3,g)
            end do
          end do
        end if
#endif
 
        ! calculate D_ijkl.. exploiting eq. (5.72)
        maxdexpgpf(0,rg,g) = 0d0
        do n1=0,rg
          do n2=0,rg-n1
            n3 = rg-n1-n2
      
            inds(1) = n1
            inds(2) = n2
            inds(3) = n3
            daux = 2*(4+rg+rg)*dexpgpf(1,n1,n2,n3,g)
 
            do i=1,3
            do j=1,3
              inds(i)=inds(i)+1
              inds(j)=inds(j)+1 
              daux = daux + z(i,j)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
              inds(i)=inds(i)-1
              inds(j)=inds(j)-1  
            end do
            end do
 
            dexpgpf(0,n1,n2,n3,g) = daux/(2*m02)
 
            maxdexpgpf(0,rg,g) =  maxdexpgpf(0,rg,g) + abs(dexpgpf(0,n1,n2,n3,g))
 
!            if (rg.le.rmax) then
!              D(0,n1,n2,n3) = D(0,n1,n2,n3) + Dexpgpf(0,n1,n2,n3,g)
!            end if
 
            if (g.eq.1.and.abs(dexpgpf(0,n1,n2,n3,g)).gt.               &
                truncfacexp*max(1/m2scale**2,maxdexpgpf(0,rg,g-1)) .or. &
                g.ge.2.and.abs(dexpgpf(0,n1,n2,n3,g)).gt.               &
                truncfacexp*maxdexpgpf(0,rg,g-1)) then
 
#ifdef Dgpftest
            write(*,*) 'CalcDgpf exit gloop',n1,n2,n3,g,abs(dexpgpf(0,n1,n2,n3,g)),abs(dexpgpf(0,n1,n2,n3,g-1)),maxdexpgpf(0,rg,g-1)
#endif
 
              gtrunc = g-1
              exit gloop
!             gtrunc = g
!             cycle gloop
            end if
 
          end do
        end do
 
        ! error propagation from C's
        if(rg.gt.1)then
          d00_err(rg+2) = max(d00_err(rg+2),                  &
                              fmax/2d0*dij_err(rg+1),         &
                              maxz/2d0*dij_err(rg+2))
        end if
        dij_err(rg)=max(dij_err(rg),maxz/(2*abs(m02))*dij_err(rg+2), &
               (2*rg+4)/abs(m02)*d00_err(rg+2))
 
        if(rg.gt.1)then
          d00_err2(rg+2) = max(d00_err2(rg+2),                     &
                              fmax/2d0*dij_err2(rg+1),     &
                              maxz/2d0*dij_err2(rg+2))
        end if
        dij_err2(rg)=max(dij_err2(rg),maxz/(2*abs(m02))*dij_err2(rg+2), &
               (2*rg+4)/abs(m02)*d00_err2(rg+2))
 
#ifdef PPEXP00
        if (rg+2.le.rmax) then
          do n1=0,rg
            do n2=0,rg-n1
              n3=rg-n1-n2
              d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgpf(1,n1,n2,n3,g)
            end do
          end do
        end if
#endif
 
        if (rg.le.rmax) then
          derr(rg) = 0d0
          do n1=0,rg
            do n2=0,rg-n1
              n3 = rg-n1-n2
              d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgpf(0,n1,n2,n3,g)
              if(abs(dexpgpf(0,n1,n2,n3,g-1)).ne.0d0) then
                derr(rg)=max(derr(rg),abs(dexpgpf(0,n1,n2,n3,g))*min(1d0,abs(dexpgpf(0,n1,n2,n3,g))/abs(dexpgpf(0,n1,n2,n3,g-1))))
              else
                derr(rg)=max(derr(rg),abs(dexpgpf(0,n1,n2,n3,g)))
              endif
 
#ifdef Dgpftest
!              write(*,*) 'CalcDgpf Derr calc',rg,Derr(rg),n1,n2,n3,g,abs(Dexpgpf(0,n1,n2,n3,g)),abs(Dexpgpf(0,n1,n2,n3,g-1))
#endif
 
            end do
          end do
 
          ! if error from C's larger than error from expansion stop expansion
          ! allow for one more term, as each step involves only even or odd ranks
#ifdef PVEST2
          if(dij_err2(rg).gt.3d0*derr(rg)) then
#else
          if(dij_err(rg).gt.3d0*derr(rg)) then
#endif
            gtrunc = min(g,gtrunc)
!           gtrunc = min(g+1,gtrunc)
             
#ifdef Dgpftest
            write(*,*) 'CalcDgpf exit err',rg,g,gtrunc
            write(*,*) 'CalcDgpf exit err',dij_err(rg),derr(rg)
#endif
          end if
 
        end if
 
      end do gloop
 
#ifdef Dgpftest
 
      write(*,*) 'CalcDgpf D(1,0,0,0)',r,d(1,0,0,0)
      write(*,*) 'CalcDgpf D(0,0,0,0)',r,d(0,0,0,0)
      write(*,*) 'CalcDgpf D(0,0,0,1)',r,d(0,0,0,1)
      if (r.ge.2.and.rmax.ge.2) then
      write(*,*) 'CalcDgpf D(0,0,0,2)',r,d(0,0,0,2)
      endif
      if (r.ge.3.and.rmax.ge.3)then
      write(*,*) 'CalcDgpf D(1,0,0,1)',r,d(1,0,0,1)
      write(*,*) 'CalcDgpf D(0,1,0,2)',r,d(0,1,0,2)
      write(*,*) 'CalcDgpf D(0,0,0,3)',r,d(0,0,0,3)
      write(*,*) 'CalcDgpf D(0,1,1,1)',r,d(0,1,1,1)
      write(*,*) 'CalcDgpf D(0,2,1,0)',r,d(0,2,1,0)
      endif
 
      write(*,*) 'CalcDgpf Dij_err',r,dij_err
      write(*,*) 'CalcDgpf Dij_acc',r,dij_err/abs(d(0,0,0,0))
 
      write(*,*) 'CalcDgpf err',r,g,derr
      write(*,*) 'CalcDgpf acc',r,g,derr/abs(d(0,0,0,0))
#endif
 
      derr2 = max(derr,dij_err2(0:rmax))
      derr = max(derr,dij_err(0:rmax))
 
!     if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit     ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
        if (r.lt.rmax) then
          do rg=r+1,rmax
            do n1=0,rg
              do n2=0,rg-n1
                d(0,n1,n2,rg-n1-n2)=0d0
              end do
            end do
          end do
          do rg=r+1,rmax
            do n1=0,rg-2
              do n2=0,rg-2-n1
                d(1,n1,n2,rg-2-n1-n2)=0d0
              end do
            end do
          end do
          
100       format(((a)))
111       format(a22,2('(',g24.17,',',g24.17,') ':))
          call seterrflag_coli(-5)
          call errout_coli('CalcDgpf',' exit rloop for D', &
          errorwriteflag)
          if (errorwriteflag) then
            write(nerrout_coli,100)' CalcDgpf:  exit rloop for D ', &
            '    should not appear'
            write(nerrout_coli,111)' CalcDgpf: p10 = ',p10
            write(nerrout_coli,111)' CalcDgpf: p21 = ',p21
            write(nerrout_coli,111)' CalcDgpf: p32 = ',p32
            write(nerrout_coli,111)' CalcDgpf: p30 = ',p30
            write(nerrout_coli,111)' CalcDgpf: p20 = ',p20
            write(nerrout_coli,111)' CalcDgpf: p31 = ',p31
            write(nerrout_coli,111)' CalcDgpf: m02 = ',m02
            write(nerrout_coli,111)' CalcDgpf: m12 = ',m12
            write(nerrout_coli,111)' CalcDgpf: m22 = ',m22
            write(nerrout_coli,111)' CalcDgpf: m32 = ',m32
          end if
        end if
 
#else
      if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
 
        exit rloop
 
      end if
 
    end do rloop
 
 
    ! calculating D_0000ijk.. exploiting eq. (5.71)
    do r=4,rmax+1                 !  includes rmax+1  24.01.16
      do n0=2,max(rmax,r/2)       !  includes rmax+1  24.01.16
        do nl=r-2*n0,0,-1
          do nlt=r-2*n0-nl,0,-1
            nltt = r-2*n0-nl-nlt
            inds0(l) = nl
            inds0(lt) = nlt
            inds0(ltt) = nltt
 
            inds(l) = nl+1
            inds(lt) = nlt
            inds(ltt) = nltt
            daux = shat(n0-1,inds(1),inds(2),inds(3),k)            &
                 - f(k)*d(n0-1,inds(1),inds(2),inds(3))            &
                 - z(k,1)*d(n0-1,inds(1)+1,inds(2),inds(3))        &
                 - z(k,2)*d(n0-1,inds(1),inds(2)+1,inds(3))        &  
                 - z(k,3)*d(n0-1,inds(1),inds(2),inds(3)+1)
 
            d(n0,inds0(1),inds0(2),inds0(3)) = daux/(2*(nl+1))
 
          end do
        end do
      end do
    end do
 
    ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!! 
    ! already calculated for rmax+1 with extension of 24.01.16 above
!    do r=rmax+1,2*rmax
#ifdef notneeded
    do r=rmax+1,rmax+1
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          do n2=0,r-2*n0-n1
            n3 = r-2*n0-n1-n2
 
            write(*,*) 'CalcDgpf exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
            d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3)  &
                + 4*duv(n0,n1,n2,n3)  &
                + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3)  &
                + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1)) 
 
            write(*,*) 'CalcDgpf dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
 
          end do
        end do
      end do
    end do
#endif
 
#ifdef Dgpftest
      if(rmax.ge.2) then
      write(*,*) 'CalcDgpf D(1,0,0,0) fin',d(1,0,0,0)
      write(*,*) 'CalcDgpf D(0,0,0,2) fin',d(0,0,0,2)
      if(rmax.ge.3) then
      write(*,*) 'CalcDgpf D(1,0,1,0) fin',d(1,0,1,0)
      write(*,*) 'CalcDgpf D(0,1,1,1) fin',d(0,1,1,1)
      endif
      endif
 
    write(*,*) 'CalcDgpf final err',derr
    write(*,*) 'CalcDgpf final acc',derr/abs(d(0,0,0,0))
#endif
 
!    write(*,*) 'CalcDgpf Derr ',Derr
!    write(*,*) 'CalcDgpf Derr2',Derr2
 
  end subroutine calcdgpf
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CopyDimp3(D,D_alt,Derr,Derr_alt,Derr1,Derr1_alt,Derr2,Derr2_alt,Drmethod,Drmethod_alt,rmax)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  subroutine copydimp3(D,D_alt,Derr,Derr_alt,Derr1,Derr1_alt,Derr2,Derr2_alt,Drmethod,Drmethod_alt,rmax,r_alt)
  
    integer,   intent(in) :: rmax,r_alt
    double complex, intent(inout) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
    double precision, intent(inout) :: Derr(0:rmax),Derr1(0:rmax),Derr2(0:rmax)
    integer, intent(inout) :: Drmethod(0:rmax)
    double complex, intent(in) :: D_alt(0:r_alt,0:r_alt,0:r_alt,0:r_alt)
    double precision, intent(in) :: Derr_alt(0:r_alt),Derr1_alt(0:r_alt),Derr2_alt(0:r_alt)
    integer, intent(in) :: Drmethod_alt(0:r_alt)
 
    integer :: r,n1,n2,n0
 
    do r=0,r_alt
      if (derr_alt(r).lt.derr(r)) then
        drmethod(r)=drmethod_alt(r)
        derr(r)=derr_alt(r)
        derr1(r)=derr1_alt(r)
        derr2(r)=derr2_alt(r)
        forall (n0=0:r/2)
          forall (n1=0:2*r-n0)
            forall (n2=0:r-2*n0-n1)
              d(n0,n1,n2,r-2*n0-n1-n2) = d_alt(n0,n1,n2,r-2*n0-n1-n2)
            end forall
          end forall
        end forall
        forall (n0=1:(r+1)/2)
          forall (n1=0:r+1-2*n0)
            forall (n2=0:r+1-2*n0-n1)
              d(n0,n1,n2,r+1-2*n0-n1-n2) = d_alt(n0,n1,n2,r+1-2*n0-n1-n2)
            end forall
          end forall
        end forall
!       forall (n0=0:r)
!         forall (n1=0:r-n0)
!           forall (n2=0:r-n0-n1)
!             D(n0,n1,n2,r-n0-n1-n2) = D_alt(n0,n1,n2,r-n0-n1-n2)
!           end forall
!         end forall
!       end forall
!        forall (n1=0:r)
!          forall (n2=0:r-n1)
!            forall (n3=0:r-n1-n2)
!              D((r-n1-n2-n3)/2,n1,n2,n3) = D_alt((r-n1-n2-n3)/2,n1,n2,n3)
!            end forall
!          end forall
!        end forall
      end if
    end do
 
   end subroutine copydimp3
 
 
 
end module reductiond