reductionC.F90

Go to the documentation of this file.

!!
!!  File reductionC.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 Credtest
!#define Cpvtest
!#define Cpv1test
!#define Cpv1otest
!#define Cpv2test
!#define Cpvshifttest
!#define Cgtest 
!#define Cgytest
!#define Cgrtest
!#define Cgptest
!#define Cgpftest
#define ALWAYSPV                ! default
!#define USEC0
!#define PPEXP00
#define Cutrloop                ! default 
!#define TRACECin
!#define TRACECout
!#define CritPointsCOLI
#define PVEST2                  ! default
 
#define PVSHIFT 
!#define TEST
!#define Cgntest
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!  ***********************
!  *  module reductionC  *
!  *    by Lars Hofer    *
!  * adapted by A Denner *
!  ***********************
! 
!  functions and subroutines:
!  CalcCuv, CalcCpv, CalcCpv2, CalcCg, CalcCgy, CalcCgp, CalcCgr, CalcCgpf, CopyCimp3
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
module globalc
 
  double complex :: q10,q21,q20,mm02,mm12,mm22
  double complex :: detz,z(2,2),zadj(2,2),f(2),zadjf(2),xadj(0:2,0:2),detx
  double precision :: q2max,m2max,m2scale,adetz,adetx,fmax,maxzadjf,maxzadjfd,maxxadj,azadjff,maxz
  double complex :: zinv(2,2),zadjs(2),detzmzadjf
  double complex :: mx(0:2,0:2), mxinv(0:2,0:2)
  double precision :: maxzadj
  double precision :: fac_g,fac_gy,fac_gp,fac_gr,fac_gpf
  double precision :: wmaxzadj,wmaxzadjf,wmaxxadj
 
  double complex :: q10shift,q21shift,q20shift,mm02shift,mm12shift,mm22shift
  double precision :: adetzshift,adetxshift,fmaxshift,maxzadjfshift,azadjffshift,maxzshift
  double complex :: detzshift,zshift(2,2),zadjshift(2,2),fshift(2),zadjfshift(2),xadjshift(0:2,0:2),detxshift
  double complex :: zinvshift(2,2),zadjsshift(2),detzmzadjfshift
  double complex :: mxshift(0:2,0:2), mxinvshift(0:2,0:2)
  double precision ::  maxzadjshift
  
  double complex, parameter :: undefined_c=1d50
  
end module globalc
 
 
 
 
 
module reductionc
 
  use coli_stat
  use reductionab
 
  implicit none
 
 
  !  should not be too small since expansion for large expansion parameters are calculated to early
  double precision, parameter :: truncfacc = 1d2
  ! double precision, parameter :: truncfacC = 1d3   worse than 1d2?
!  double precision, parameter :: acc_C=1d-13
 
contains
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcC(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calcc(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
  
    integer, intent(in) :: rmax, id
    integer, optional, intent(in) :: rbasic
    double precision, optional, intent(in) :: acc_req_Cextra(0:rmax)
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr1(0:rmax),Cerr2(0:rmax)
    double complex, allocatable :: Caux(:,:,:), Cuvaux(:,:,:), fct(:)
    double precision, allocatable :: Cerr1aux(:),Cerr2aux(:)
    double complex :: x(6)
    integer :: rank,switch,cnt,n0,n1,n2,r,rb
    logical :: nocalc,wrica
 
#ifdef TRACECin
    write(*,*) 'CalcC in ',rmax,id
#endif
 
    if (use_cache_system) then
      if ((ncache.gt.0).and.(ncache.le.ncache_max)) then
!        if (use_cache(ncache).ge.3) then
          x(1)=p10
          x(2)=p21
          x(3)=p20
          x(4)=m02
          x(5)=m12
          x(6)=m22
          rank = rmax
          switch = 0
 
          if(rmax.ge.1) then
            allocate(fct(ncoefsg(rmax,3)+ncoefsg(rmax-1,3)+2*(rmax+2)))
            call readcache(fct,ncoefsg(rmax,3)+ncoefsg(rmax-1,3)+2*(rmax+2),x,6,1,id,3,rank,nocalc,wrica)
          else 
            allocate(fct(ncoefsg(rmax,3)+2*(rmax+2)))
            call readcache(fct,ncoefsg(rmax,3)+2*(rmax+2),x,6,1,id,3,rank,nocalc,wrica)
          end if
    
          if(nocalc)then
 
            if(present(rbasic)) then
              rb =rbasic
            else
              rb = rmax
            endif
            if(int(fct(1)).lt.rb) then
! if cached results are for smaller rbasic recalculate and write to cache 
! NOTE: coefficients shifted in cache by one slot
              wrica = .true.
            else
              cnt = 1
              do r=0,rmax
                do n0=0,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    c(n0,n1,n2) = fct(cnt)
 
                  end do
                end do
                do n0=1,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    cuv(n0,n1,n2) = fct(cnt)
 
                  end do
                end do
                cnt = cnt+1
                cerr1(r) = real(fct(cnt))
                cnt = cnt+1
                cerr2(r) = real(fct(cnt))
              end do
 
              return
            endif
          end if
 
          
          if(rank.eq.rmax) then
 
            if(present(rbasic)) then
              call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rank,id,cerr1,cerr2,rbasic+rank-rmax,acc_req_cextra)
            else
              call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rank,id,cerr1,cerr2)
            end if
 
            if (wrica) then
              cnt = 1
              if(present(rbasic)) then
                fct(cnt) = rbasic
              else
                fct(cnt) = rank
              end if 
              do r=0,rank
                do n0=0,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    fct(cnt) = c(n0,n1,n2)
                  end do
                end do
                do n0=1,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    fct(cnt) = cuv(n0,n1,n2)
                  end do
                end do
                cnt = cnt+1
                fct(cnt) = cerr1(r)
                cnt = cnt+1
                fct(cnt) = cerr2(r)
              end do
 
              if(rank.ge.1) then
                call writecache(fct,ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2),id,3,rank)
              else 
                call writecache(fct,ncoefsg(rank,3)+2*(rank+2),id,3,rank)
              end if
 
            end if
 
            return
          
          
          else
            allocate(caux(0:rank,0:rank,0:rank))
            allocate(cuvaux(0:rank,0:rank,0:rank))
            allocate(cerr1aux(0:rank))
            allocate(cerr2aux(0:rank))
 
            if(present(rbasic)) then
              call calccred(caux,cuvaux,p10,p21,p20,m02,m12,m22,rank,id,cerr1aux,cerr2aux,rbasic+rank-rmax,acc_req_cextra)
            else
              call calccred(caux,cuvaux,p10,p21,p20,m02,m12,m22,rank,id,cerr1aux,cerr2aux)
            end if
 
            if (wrica) then
              cnt = 1
              deallocate(fct)
              if(rank.ge.1) then
                allocate(fct(ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2)))
              else 
                allocate(fct(ncoefsg(rank,3)+2*(rank+2)))
              end if
              if(present(rbasic)) then
                fct(cnt) = rbasic+rank-rmax
              else
                fct(cnt) = rank
              end if 
              do r=0,rank
                do n0=0,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    fct(cnt) = caux(n0,n1,n2)
                  end do
                end do
                do n0=1,r
                  do n1=0,r-n0
                    n2 = r-n0-n1
 
                    cnt = cnt+1
                    fct(cnt) = cuvaux(n0,n1,n2)
                  end do
                end do
                cnt = cnt+1
                fct(cnt) = cerr1aux(r)
                cnt = cnt+1
                fct(cnt) = cerr2aux(r)
              end do
 
              if(rank.ge.1) then
                call writecache(fct,ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2),id,3,rank)
              else 
                call writecache(fct,ncoefsg(rank,3)+2*(rank+2),id,3,rank)
              end if
 
            end if
 
            c = caux(0:rmax,0:rmax,0:rmax)
            cuv = cuvaux(0:rmax,0:rmax,0:rmax)
            cerr1 = cerr1aux(0:rmax)
            cerr2 = cerr2aux(0:rmax)
 
            deallocate(caux)
            deallocate(cuvaux)
            deallocate(cerr1aux)
            deallocate(cerr2aux)
 
!           write(*,*) 'Cred Cerr1',Cerr1
!           write(*,*) 'Cred Cerr2',Cerr2
 
            return
 
          end if
!        end if
      end if
    end if
 
    if(present(rbasic))then
      call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2,rbasic,acc_req_cextra)
    else
      call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
    end if
 
!         write(*,*) 'Cred nc Cerr1',Cerr1
!         write(*,*) 'Cred nc Cerr2',Cerr2
 
  end subroutine calcc
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCred(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccred(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
  
    use globalc
 
    integer, intent(in) :: rmax,id
    integer, intent(in), optional :: rbasic
    !   rbasic defines rank of tensors that are needed by mastercall
    !          higher ranks up to rmax are needed for internal iterations
    double precision, intent(in), optional :: acc_req_Cextra(0:rmax)
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out)  ::Cerr1(0:rmax),Cerr2(0:rmax)
    double complex :: C_alt(0:rmax,0:rmax,0:rmax)
    double complex :: Cuv_alt(0:rmax,0:rmax,0:rmax)
    double precision ::  Cerr(0:rmax),Cerr_alt(0:rmax),Cerr1_alt(0:rmax),Cerr2_alt(0:rmax)
    double precision :: C0est,Ctyp
#ifdef USEC0
    double complex :: C0_coli
#endif
    double complex :: C0_coli
!    double complex :: detX,chdet
    double complex :: chdet
 
    double complex :: elimminf2_coli
    integer :: r,rid,n0,n1,n2,g,gy,gp,gr,gpf,i,rdef,iexp
    logical :: use_pv,use_pv2,use_g,use_gy,use_gp,use_gr,use_gpf,use_pvs
 
    integer :: r_alt,Crmethod(0:rmax),Crmethod_alt(0:rmax),CrCalc(0:rmax),CCalc
    double precision :: acc_pv_alt, acc_pv2_alt, acc_Cr_alt
 
    !   CalcC stores methods that have been calculated
    !   Crmethod(r) stores best method=used for rank r 
 
    double precision :: err_pv(0:rmax),err_pv2(0:rmax),err_g(0:rmax),err_gy(0:rmax),  &
                        err_gp(0:rmax),err_gr(0:rmax),err_gpf(0:rmax)
    double precision :: err_pvs(0:rmax)
    double precision :: h_pv,w_pv,v_pv,z_pv,h_pv2,w_pv2,v_pv2,z_pv2,hw_pv2
    double precision :: h_pvs,w_pvs,v_pvs,z_pvs
    double precision :: x_g,u_g,z_g,err_g_B(0:rmax),err_g_exp
    double precision :: x_gy,y_gy,v_gy,v1_gy,b_gy,err_gy_B(0:rmax),err_gy_exp
    double precision :: w_gp,v_gp,z_gp,err_gp_B(0:rmax),err_gp_exp
    double precision :: x_gr,y_gr,y1_gr,a_gr,err_gr_B(0:rmax),err_gr_exp
    double precision :: x_gpf,y_gpf,v_gpf,v1_gpf,b_gpf,err_gpf_B(0:rmax),err_gpf_exp
    double precision :: err_B,err_C0,err_C(0:rmax),err_inf,err_req_Cr(0:rmax),acc_req_Cr(0:rmax),acc_C(0:rmax)
    double precision :: checkest,norm,Cscale
    logical :: lerr_C0,errorwriteflag
 
    character(len=*),parameter :: fmt1 = "(A7,'dcmplx(',d25.18,' , ',d25.18,' )')"
    character(len=*),parameter :: fmt10 = "(A17,'(',d25.18,' , ',d25.18,' )')"
#ifdef CritPointsCOLI    
    integer, parameter :: MaxCritPointC=50
#else
    integer, parameter :: MaxCritPointC=0
#endif
    integer, save :: CritPointCntC
 
    data critpointcntc /0/
 
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! choose reduction scheme
    ! by estimating expected errors
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
#ifdef Credtest
     write(*,*) 'CalcCred in ',rmax,id,p10,p21,p20
#endif
#ifdef TRACECin
     write(*,*) 'CalcCred in ',rmax,id
#endif
 
    if (present(rbasic)) then
      rdef = rbasic
    else
      rdef = rmax
    end if
 
#ifdef Credtest
     write(*,*) 'CalcCred rdef ',rdef
#endif
 
    if (present(acc_req_cextra)) then 
      acc_req_cr = acc_req_cextra
    else
      acc_req_cr = acc_req_c
    end if
 
#ifdef Credtest
     write(*,*) 'CalcCred acc_req_Cr ',acc_req_cr
#endif
 
    ! eliminate infinitesimal masses
    mm02 = elimminf2_coli(m02)
    mm12 = elimminf2_coli(m12)
    mm22 = elimminf2_coli(m22)
    q10  = elimminf2_coli(p10)
    q21  = elimminf2_coli(p21)
    q20  = elimminf2_coli(p20)
 
    ! set mass scales
    q2max = max(abs(q10),abs(q21),abs(q20))
    m2max = max(abs(mm02),abs(mm12),abs(mm22))
    m2scale = max(q2max,m2max)
 
    ! Gram and related stuff
    z(1,1) = 2d0*q10
    z(2,1) = q10+q20-q21   !  = q1q2
    z(1,2) = z(2,1)
    z(2,2) = 2d0*q20
 
    maxz = maxval(abs(z))
 
    detz = chdet(2,z)
 
    if (detz.ne.0d0) then
      call chinv(2,z,zinv)
      zadj = zinv * detz
    else
      zadj(1,1) = z(2,2)
      zadj(2,1) = -z(2,1)
      zadj(1,2) = -z(2,1)
      zadj(2,2) = z(1,1)
    end if
 
    zadjs(1) = q21 + q20 - q10 
    zadjs(2) = q21 + q10 - q20 
 
#ifdef Credtest
    write(*,*) 'Z(1) ',z(1,1), z(1,2),z(2,1),z(2,2),detz
    write(*,*) 'Zadj(1) ',zadj(1,1), zadj(1,2),zadj(2,1),zadj(2,2),detz
    write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)
    write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)
    write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)
#endif
 
    detzmzadjf = q21*z(2,1)
 
!   write(*,*) 'Zn    ',Z   
!   write(*,*) 'Zinvn ',Zinv
!   write(*,*) 'Zadjn ',Zadj
!   write(*,*) 'detZn ',detZ
 
    adetz = abs(detz)
    maxzadj = max(abs(zadj(1,1)),abs(zadj(2,1)),abs(zadj(2,2)))
 
    f(1) = q10+mm02-mm12
    f(2) = q20+mm02-mm22
    fmax = max(abs(f(1)),abs(f(2)))
 
    mx(0,0) = 2d0*mm02
! 25.08.17
!    mx(1,0) = q10 - mm12 + mm02
!    mx(2,0) = q20 - mm22 + mm02
!    mx(2,1) = q10+q20-q21
!    mx(1,1) = 2d0*q10
!    mx(2,2) = 2d0*q20
    mx(1,0) = f(1)
    mx(2,0) = f(2)
    mx(0,1) = mx(1,0)
    mx(0,2) = mx(2,0)
    mx(1:2,1:2) = z(1:2,1:2)
 
    detx = chdet(3,mx)
 
    if (detx.ne.0d0.and.maxz.ne.0d0) then
 
!     write(*,*) 'CalcCred mx=',mx
 
      call chinv(3,mx,mxinv)
 
!     write(*,*) 'CalcCred mxinv=',mxinv
 
      xadj = mxinv * detx
 
!     write(*,*) 'CalcCred Xadj=',Xadj
 
      zadjf(1:2) = -xadj(0,1:2)
 
    else
! 25.08.17
!      mx(0,0) = 2d0*mm02
!      mx(1,0) = q10 - mm12 + mm02
!      mx(2,0) = q20 - mm22 + mm02
!      mx(0,1) = mx(1,0)
!      mx(1,1) = 2d0*q10
!      mx(2,1) = q10+q20-q21
!      mx(0,2) = mx(2,0)
!      mx(1,2) = mx(2,1)
!      mx(2,2) = 2d0*q20
 
      zadjf(1) = zadj(1,1)*f(1)+zadj(2,1)*f(2)
      zadjf(2) = zadj(1,2)*f(1)+zadj(2,2)*f(2)
 
      xadj(2,2) = 2d0*mm02*z(1,1) - f(1)*f(1)
      xadj(1,1) = 2d0*mm02*z(2,2) - f(2)*f(2)
      xadj(2,1) = 2d0*mm02*z(2,1) - f(1)*f(2)
      xadj(1,2) = xadj(2,1)
    end if
 
#ifdef Credtest
!    write(*,*) 'fi ',f(1),f(2)
!    write(*,*) 'm02 ',m02,2*q10,2*q20,2*Z(2,1)
!    write(*,*) 'Xadj11 ',4d0*mm02*q20 - f(1)*f(1),Xadj(1,1)
!    write(*,*) 'Xadj21 ',2d0*mm02*Z(2,1) - f(1)*f(2),Xadj(1,2)
!    write(*,*) 'Xadj22 ',4d0*mm02*q10 - f(2)*f(2),Xadj(2,2)
!    write(*,*) 'detXn ',detX
!    write(*,*) 'Zadjf1',Zadjf(1),Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    write(*,*) 'Zadjf2',Zadjf(2),Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
#endif
 
    maxzadjf = max(abs(zadjf(1)),abs(zadjf(2)))
    maxzadjfd = max(maxzadjf,adetz)
 
    azadjff = abs(zadjf(1)*f(1) + zadjf(2)*f(2))
    adetx = abs(2d0*mm02*detz - zadjf(1)*f(1) - zadjf(2)*f(2))
    maxxadj = max(abs(xadj(1,1)),abs(xadj(2,1)),abs(xadj(2,2)))
 
#ifdef Credtest
    write(*,*) 'maxZ    ',maxz,z
    write(*,*) 'maxZadj ',maxzadj,zadj
    write(*,*) 'maxZadjf ',maxzadjf,zadjf
    write(*,*) 'CalcCred adetX ',adetx,adetz
    write(*,*) 'CalcCred Zadjf ',zadjf
    write(*,*) 'CalcCred Xadj ',xadj(1:2,1:2)
#endif
 
 
    ! quantities for modified error estimates
    ! momentum weights
!    do i = 1,2
!      pweight(i) = max(abs(Z(i,1))/maxval(abs(Z(1:2,1))),  &
!          abs(Z(i,2))/maxval(abs(Z(1:2,2))))
!    end do
 
!    wmaxZadj = max(pweight(1)*abs(Zadj(1,1)),pweight(1)*abs(Zadj(1,2)),  &
!        pweight(2)*abs(Zadj(2,1)),pweight(2)*abs(Zadj(2,2)))
!
!    wmaxZadjf = max(pweight(1)*abs(Zadjf(1)),pweight(2)*abs(Zadjf(2)))
!
!    wmaxXadj = max(pweight(1)*abs(Xadj(1,1)),   &
!        pweight(1)*abs(Xadj(1,2)),pweight(2)*abs(Xadj(2,1)),  &
!        pweight(2)*abs(Xadj(2,2)))
!    wmaxXadj = max(2d0*abs(mm02)*sqrt(adetZ*maxZadj/maxZ),maxZadj2ff*maxZadjf/(maxZadj*fmax))        
 
!    write(*,*) 'CalcCred pweight',pweight(1:2)
!    write(*,*) 'CalcCred wmaxZadj',maxZadj,wmaxZadj
!    write(*,*) 'CalcCred wmaxZadjf',maxZadjf,wmaxZadjf
!    write(*,*) 'CalcCred wmaxZadjf',maxXadj,wmaxXadj
 
 
    ! rough estimate for C0 to set the scale, to be improved
    cscale = max(abs(p10),abs(p21),abs(p20),abs(m02), \
              abs(m12),abs(m22))
#ifdef USEC0
    c0est = max(abs(c0_coli(p10,p21,p20,m02,m12,m22)),1d0/cscale)
    lerr_c0 = .true.
#else
! changed 09.09.16
     if(cscale.ne.0d0) then 
       c0est = 1d0/cscale
     else
       c0est = 1d0
     end if
!    if (adetZ.ne.0d0) then
!      C0est = 1d0/sqrt(adetZ)
!    elseif (m2max.ne.0d0) then
!      C0est = 1d0/m2max
!    else if (maxZ.ne.0d0) then
!      C0est = 1d0/maxZ
!    else
!      C0est = 1d0 
!    end if
    lerr_c0 = .false.
#endif 
 
#ifdef Credtest
    write(*,*) 'CalcCred C0    = ',c0_coli(p10,p21,p20,m02,m12,m22)
    if(adetz.ne.0d0) then
      write(*,*) 'CalcCred C0est = ',c0est,1d0/sqrt(adetz)
    else
      write(*,*) 'CalcCred C0est = ',c0est
    end if
#endif
 
    err_inf = acc_inf*c0est
 
    err_req_cr = acc_req_cr * c0est
 
    ccalc = 0
    crcalc = 0
    crmethod = 0
    cerr = err_inf
    cerr1 = err_inf
    cerr2 = err_inf
    acc_c = acc_inf
    ccount(0) = ccount(0)+1
 
    ! error estimate for C0
    if (adetz.ne.0d0) then
!      err_C0 = acc_def_C0*q2max/sqrt(adetZ) * C0est
      err_c0 = acc_def_c0*max( c0est, 1d0/sqrt(adetz) )
    else
      err_c0 = acc_def_c0 * c0est
    end if
    err_b = acc_def_b
     
 
    ! estimate accuracy of PV-reduction
!    if (adetZ.eq.0d0) then
!    if (adetZ.lt.dprec_cll*maxZ**2) then
    h_pv = real(undefined_c)
    w_pv = real(undefined_c)
    v_pv = real(undefined_c)
    z_pv = real(undefined_c)
!    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**2.or.adetz.eq.0d0) then
      use_pv = .false.
      err_pv = err_inf
    else
      use_pv = .true.
      err_pv(0) = err_c0
      if (rdef.gt.0) then
#ifdef PVEST2
        h_pv = sqrt(adetz)/maxzadj
        w_pv = max((maxzadjf*h_pv/adetz)**2, abs(mm02)*maxz*h_pv/adetz, azadjff*maxz*(h_pv/adetz)**2)
        v_pv = maxzadjf*h_pv/adetz
        z_pv = maxz*h_pv/adetz
#else
        w_pv = max((maxzadjf/adetz)**2, abs(mm02)*maxz/adetz, maxz*azadjff/adetz**2)
        v_pv = maxzadjf/adetz
        z_pv = maxz/adetz
#endif
 
#ifdef Credtest
        write(*,*) 'CalcCred w_pv',(maxzadjf/adetz)**2, abs(mm02)*q2max/adetz, maxz*azadjff/adetz**2
        write(*,*) 'CalcCred w_pv',w_pv,v_pv,z_pv,h_pv
#endif
 
        if (mod(rdef,2).eq.1) then
          err_pv(rdef) = max( w_pv**((rdef-1)/2) * v_pv * err_c0,  &
              max(w_pv**((rdef-1)/2),1d0) * z_pv * err_b )
 
#ifdef Credtest
          write(*,*) 'CalcCred err_pv cont', w_pv**((rdef-1)/2)* v_pv* err_c0, &
                        w_pv**((rdef-1)/2) * z_pv * err_b, err_c0,err_b
          write(*,*) 'CalcCred err_pv cont', w_pv**((rdef-1)/2),v_pv, err_c0
#endif
 
        else
          err_pv(rdef) = max( w_pv**(rdef/2) * err_c0,  &
              max(w_pv**(rdef/2-1) * v_pv, 1d0) * z_pv * err_b )
      
#ifdef Credtest      
          write(*,*) 'CalcCred w_pv', w_pv,err_c0,sqrt(w_pv)
          write(*,*) 'CalcCred err_pv cont', w_pv**(rdef/2) * err_c0, &
                        w_pv**(rdef/2-1) * v_pv * z_pv * err_b, z_pv * err_b, err_c0,err_b
#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**2).or.(adetX.lt.dprec_cll*maxval(abs(mx))**3)) then
    z_pv2 = real(undefined_c)
    v_pv2 = real(undefined_c)
    w_pv2 = real(undefined_c)
    hw_pv2 = real(undefined_c)
!    if ((adetZ.lt.dprec_cll*maxZadjf).or.(adetX.lt.dprec_cll*maxval(abs(mx))*adetZ).or.adetZ.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**2).or.(adetx.lt.dprec_cll*fmax**2*maxz).or.adetz.eq.0d0.or.adetx.eq.0d0) then
      use_pv2 = .false.
      err_pv2 = err_inf
    else
      use_pv2 = .true.
      err_pv2(0) = err_c0
      if (rdef.gt.0) then
        w_pv2 = maxzadjf/adetz
#ifdef PVEST2
        h_pv2 = sqrt(adetz)/maxzadj
        hw_pv2 =  w_pv2*h_pv2
#else
        hw_pv2 =  w_pv2 
#endif
        v_pv2 = maxxadj/adetz
        z_pv2 = adetz/adetx 
 
!        write(*,*) 'CalcCred: w_pv2',w_pv2,v_pv2,z_pv2,err_C0,err_B
 
        if (mod(rdef,2).eq.1) then
! change 21.10.15 for PVEST2
!          err_pv2(rdef) = max( err_C0 * max(w_pv2**rdef,w_pv2*v_pv2**((rdef-1)/2) ),  &
!              err_B * z_pv2 * max(w_pv2**(rdef+1),w_pv2, &
!                              w_pv2*v_pv2**((rdef-1)/2),w_pv2**2, & 
!                              v_pv2**((rdef+1)/2),v_pv2 ) )
 
          err_pv2(rdef) = max( err_c0 * max(hw_pv2**rdef,hw_pv2*v_pv2**((rdef-1)/2) ),  &
              err_b * z_pv2 * max(w_pv2*hw_pv2**(rdef),hw_pv2, &
                              w_pv2*hw_pv2*v_pv2**((rdef-1)/2), &
                              hw_pv2*v_pv2**((rdef-1)/2),w_pv2*hw_pv2, & 
                              v_pv2**((rdef+1)/2),v_pv2 ) )
 
!        write(*,*) 'CalcCred: err_pv2',rdef,err_C0 * max(1d0,w_pv2**rdef,v_pv2**((rdef-1)/2),w_pv2*v_pv2**((rdef-1)/2) ), &
!            err_B * max(1d0,z_pv2*w_pv2**(rdef+1),z_pv2*w_pv2, &
!              z_pv2*w_pv2*v_pv2**((rdef-1)/2),z_pv2*w_pv2**2, & 
!              z_pv2*v_pv2**((rdef+1)/2),z_pv2*v_pv2 ) 
 
        else
! change 21.10.15 for PVEST2
!          err_pv2(rdef) = max( err_C0 * max(w_pv2**rdef,v_pv2**(rdef/2)),  &
!              err_B * z_pv2 * max(w_pv2**(rdef+1),w_pv2,  &
!                                  w_pv2*v_pv2**(rdef/2), w_pv2**2,  &
!                                  v_pv2**(rdef/2),v_pv2) )
          err_pv2(rdef) = max( err_c0 * max(hw_pv2**rdef,v_pv2**(rdef/2)),  &
              err_b * z_pv2 * max(w_pv2*hw_pv2**(rdef),hw_pv2,  &
                                  w_pv2*v_pv2**(rdef/2), w_pv2*hw_pv2,  &
                                  v_pv2**(rdef/2),v_pv2) )
        end if
      end if
    end if 
 
    ! scale estimates down to allow trying other methods
    err_pv(rdef)  = err_pv(rdef)/impest_c
    err_pv2(rdef) = err_pv2(rdef)/impest_c     
 
#ifdef TEST
!   use_pv = .false.     ! TEST switch off PV
   use_pv2 = .false.
!    use_pv = .true.
!    use_pv2 = .true.
!    err_pv(rdef) = 1d50
    err_pv2(rdef) = 1d50
#endif
 
#ifdef Credtest
    write(*,*) 'CalcCred: err_pv',err_pv(rdef),err_pv2(rdef),err_req_cr(rdef)
    write(*,*) 'CalcCred: acc_pv',err_pv(rdef)/c0est,err_pv2(rdef)/c0est,acc_req_c
#endif
 
! changed 16.11.16
!   Ctyp = real(undefined_C)
    ctyp = c0est
 
#ifdef ALWAYSPV
    if(use_pv.or.use_pv2) then
#else
    if (min(err_pv(rdef),err_pv2(rdef)).le.err_req_cr(rdef)) then
#endif
      if (err_pv(rdef).le.err_pv2(rdef)) then
 
#ifdef Credtest
        write(*,*) 'CalcCred: call Cpv 1 ',rmax,id,err_pv(rdef)
#endif
 
        ! use PV-reduction if appropriate
        call calccpv1(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
#ifdef PVEST2
        cerr = cerr2
#else
        cerr = cerr1
#endif
        ccount(1) = ccount(1)+1
        crcalc(0:rmax)=crcalc(0:rmax)+1
        ccalc=ccalc+1
        crmethod(0:rmax)=1
 
#ifdef Credtest
        checkest=cerr(rdef)/err_pv(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_pv imprecise',err_pv(rdef),cerr(rdef)
        end if
#endif
        err_pv=cerr
 
      else
 
#ifdef Credtest
        write(*,*) 'CalcCred: call Cpv2 1',rdef,id,err_pv2(rdef)
#endif
 
        ! use alternative PV-reduction if appropriate
        call calccpv2(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
#ifdef PVEST2
        cerr = cerr2
#else
        cerr = cerr1
#endif
        ccount(2) = ccount(2)+1
        crcalc(0:rmax)=crcalc(0:rmax)+2
        ccalc=ccalc+2
        crmethod(0:rmax)=2
 
#ifdef Credtest
        checkest=cerr(rdef)/err_pv2(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_pv2 imprecise',err_pv2(rdef),cerr(rdef)
        end if
#endif
 
        err_pv2=cerr
 
      end if
 
#ifndef USEC0
      ! refine error estimate for C0
!      C0est = abs(C(0,0,0))
      err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
!      err_req_Cr = acc_req_Cr * abs(C(0,0,0))
      lerr_c0 = .true.
#endif
 
      if (rmax.ge.1) then
        ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
      else
        ctyp =  abs(c(0,0,0))
      end if
      if(ctyp.eq.0d0) ctyp = c0est
      err_req_cr = acc_req_cr * ctyp
 
 
#ifdef Credtest
      write(*,*) 'CalcCred C0est after PV=',abs(c(0,0,0)),ctyp
      write(*,*) 'CalcCred Cerr after PV =',cerr
      write(*,*) 'CalcCred Cacc after PV =',cerr/ctyp
      write(*,*) 'CalcCred err_req =',err_req_cr
      write(*,*) 'CalcCred Cerr1-req=',cerr1-err_req_cr
      write(*,*) 'CalcCred max(Cerr-req)',maxval(cerr-err_req_cr)
      write(*,*) 'CalcCred max(Cerr1-req)',maxval(cerr1-err_req_cr)
#endif
 
! check with Cerr = Cerr2: exp not tried => larger errors
      if (maxval(cerr1-err_req_cr).lt.0) then
        ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
        return
      end if      
    else   !  added 14.07.2017
      c = 0d0
      cuv = 0d0
      cerr1 = err_inf
      cerr2 = err_inf
    end if
 
#ifdef TEST
!    return          ! use only PV
#endif
 
        
    ! choose most promising expansion scheme
    ! Gram expansion
!    if (maxZadjf.ne.0d0) then
    if (maxzadjf.gt.m2scale**2*dprec_cll) then   !  10.07.2017
      x_g = adetz/maxzadjf
!      u_g = max(1d0,m2scale*m2scale/maxZadjf/6d0,abs(mm02)*q2max/maxZadjf/6d0)
!      u_g = max(1d0,fmax*fmax/maxZadjf/6d0,abs(mm02)*maxZ/maxZadjf/6d0)
! 03.03.15  large P counts!
!      u_g = max(1d0,fmax*fmax/maxZadjf/2d0,abs(mm02)*maxZ/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
        z_g = real(undefined_c)
      else
        use_g = .true.
!       z_g = max(1d0,m2scale*q2max/maxZadjf)
        z_g = maxz/maxzadjf
        err_g_b(rdef) = err_b * u_g**rdef * z_g 
        err_g_exp = u_g**(rdef-1) * ctyp
      end if
    else
      use_g = .false.
      err_g = err_inf
      g = -1
      err_g_exp = err_inf
      u_g = real(undefined_c)
      z_g = real(undefined_c)
    end if
 
#ifdef Credtest
    if(use_g) then
      write(*,*) 'CalcCred: after Gram pars',use_g,fac_g,x_g,u_g,z_g,err_g_b(rdef),err_g_exp
    else
      write(*,*) 'CalcCred: after Gram pars',use_g,err_g_exp
    end if 
#endif
 
    ! Gram-Cayley expansion
!    if (maxXadj.ne.0d0.and.maxZ.ne.0d0) then
    if (maxxadj.gt.m2scale**2*dprec_cll.and.maxz.gt.m2scale*dprec_cll) then   !  10.07.2017
      x_gy = maxzadjf/maxxadj
      y_gy = adetz/maxxadj
!     v_gy = m2scale/q2max
      v_gy = fmax/maxz
      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
        b_gy = real(undefined_c)
      else
        use_gy = .true.
!       b_gy = max(1d0,m2scale*q2max/maxXadj)
        b_gy = maxz/maxxadj
        err_gy_b(rdef) = err_b * b_gy*v1_gy
        err_gy_exp = 1d0 * ctyp
      end if
    else
      use_gy = .false.
      err_gy = err_inf
      gy = -1
      err_gy_exp = err_inf
      v1_gy = real(undefined_c)
      b_gy = real(undefined_c)
    end if 
 
#ifdef Credtest
    if(use_gy) then
      write(*,*) 'CalcCred: after GramCay pars',use_gy,fac_gy,x_gy,y_gy,v_gy,b_gy,err_gy_b(rdef),err_gy_exp
    else
      write(*,*) 'CalcCred: after GramCay pars',use_gy,err_gy_exp
    end if
#endif
 
    ! expansion in small momenta
!    if (fmax.ne.0d0) then
    if (fmax.gt.m2scale*dprec_cll) then   !  10.07.2017
!     w_gp = q2max/fmax
      w_gp = maxz/fmax
      v_gp = max(1d0,abs(mm02)/fmax)
      fac_gp = w_gp*v_gp
      err_gp = err_inf
      gp = -1
      if (fac_gp.ge.1d0) then
        use_gp = .false.
        err_gp_exp = err_inf
        z_gp = real(undefined_c)
      else
        use_gp = .true.
!       z_gp = max(1d0,m2scale/fmax)
        z_gp = 1d0/fmax
        err_gp_b(rdef) = err_b * z_gp*v_gp**rdef
        err_gp_exp = v_gp**(rdef-1) * ctyp
      end if
    else
      use_gp = .false.
      err_gp = err_inf
      gp = -1
      err_gp_exp = err_inf
      z_gp = real(undefined_c)
      v_gp = real(undefined_c)
    end if
 
#ifdef Credtest
    if(use_gp) then
      write(*,*) 'CalcCred: after Mom pars',use_gp,fac_gp,w_gp,v_gp,z_gp,err_gp_b(rdef),err_gp_exp
    else
      write(*,*) 'CalcCred: after Mom pars',use_gp,err_gp_exp
    end if
#endif
 
    ! reversed Gram expansion
!    if (maxZadjf.ne.0d0.and.fmax.ne.0d0) then
    if (maxzadjf.gt.m2scale**2*dprec_cll.and.fmax.gt.m2scale*dprec_cll) then   !  10.07.2017
      x_gr = adetz/maxzadjf
      y_gr = maxzadj/fmax              ! 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_b) then
        use_gr = .false.
        err_gr_exp = err_inf
      else
        use_gr = .true.
        err_gr_b(rdef) = err_b * a_gr
        err_gr_exp = y1_gr * ctyp
      end if
    else
      use_gr = .false.
      err_gr = err_inf
      gr = -1
      err_gr_exp = err_inf
      y1_gr = real(undefined_c)
      a_gr = real(undefined_c)
    end if
 
#ifdef Credtest
    if(use_gr) then
    write(*,*) 'CalcCred: after revGram pars',use_gr,fac_gr,x_gr,y_gr,y1_gr,a_gr,err_gr_b(rdef),err_gr_exp
    else
    write(*,*) 'CalcCred: after revGram pars',use_gr,err_gr_exp
    end if
#endif
 
    !  expansion in small momenta and f's
!  estimates to be confirmed 16.08.17, r dependence may be different
!  since C_mni... is needed in contrast to Cgy 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)*v1_gpf
      err_gpf = err_inf
      gpf = -1
      if (fac_gpf.ge.1) then
        use_gpf = .false.
        err_gpf_exp = err_inf
        b_gpf = real(undefined_c)
      else
        use_gpf = .true.
        b_gpf = 1d0/abs(m02)
        err_gpf_b(rdef) = err_b * b_gpf*v1_gpf
        err_gpf_exp = 1d0 * ctyp
      end if
    else
      use_gpf = .false.
      err_gpf = err_inf
      gpf = -1
      err_gpf_exp = err_inf
      v1_gpf = real(undefined_c)
      b_gpf = real(undefined_c)
    end if 
 
#ifdef Credtest
    if(use_gpf) then
      write(*,*) 'CalcCred: after pf pars',use_gpf,fac_gpf,x_gpf,y_gpf,v_gpf,b_gpf,err_gpf_b(rdef),err_gpf_exp
    else
      write(*,*) 'CalcCred: after pf pars',use_gpf,err_gpf_exp
    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_gpf.eqv..false.) then
      call seterrflag_coli(-6)
      call errout_coli('CalcCred',' no reduction method works', &
           errorwriteflag)
!      write(nerrout_coli,'((a))')  '  no reduction method works'
      if (errorwriteflag) then
        write(nerrout_coli,fmt10) ' CalcCred: p10 = ',p10
        write(nerrout_coli,fmt10) ' CalcCred: p21 = ',p21
        write(nerrout_coli,fmt10) ' CalcCred: p20 = ',p20
        write(nerrout_coli,fmt10) ' CalcCred: m02 = ',m02
        write(nerrout_coli,fmt10) ' CalcCred: m12 = ',m12
        write(nerrout_coli,fmt10) ' CalcCred: m22 = ',m22   
      end if
      c = 0d0
      cuv = 0d0
      cerr = err_inf
      cerr2 = err_inf
 
#ifdef Credtest
      write(*,*) 'CalcCred: 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.
#endif
 
    iexp = 0
    do i=0,rmax_c-rmax
 
      if (use_g) then
        if (err_g_exp.gt.err_g_b(rdef)) then
          g = i
          err_g_exp = err_g_exp*fac_g
          err_g(rdef) = max(err_g_exp,err_g_b(rdef))
          if(err_g(rdef).lt.err_req_cr(rdef)) then
            iexp = 1
            ! increase g by 2 to account for bad estimates
            g = min(max(g+2,2*g),rmax_c-rmax)
            exit
          end if
 
#ifdef Credtest
          write(*,*) 'CalcCred i g',i,g,err_g_exp,err_g_b(rdef),err_g(rdef) 
#endif
 
        end if
      end if
 
      if (mod(i,2).eq.1) then
        if (use_gy) then
          if (err_gy_exp.gt.err_gy_b(rdef)) then
            gy = i/2
            err_gy_exp = err_gy_exp*fac_gy
            err_gy(rdef) = max(err_gy_exp, err_gy_b(rdef))
            if(err_gy(rdef).lt.err_req_cr(rdef)) then
              iexp = 2
              ! increase gy by 2 to account for bad estimates
              gy = min(max(gy+4,2*gy),(rmax_c-rmax)/2)
              exit
            end if
 
#ifdef Credtest
          write(*,*) 'CalcCred i gy',i,gy,err_gy_exp,err_gy_b(rdef),err_gy(rdef) 
#endif
 
          end if
        end if
      end if
 
      if (use_gp) then
        if (err_gp_exp.gt.err_gp_b(rdef)) then
          gp = i
          err_gp_exp = err_gp_exp*fac_gp
          err_gp(rdef) = max(err_gp_exp,err_gp_b(rdef))
          if(err_gp(rdef).lt.err_req_cr(rdef)) then
            iexp = 3
            ! increase gp by 2 to account for bad estimates
            gp = min(max(gp+2,2*gp),rmax_c-rmax)
            exit
          end if
 
#ifdef Credtest
          write(*,*) 'CalcCred i gp',i,gp,err_gp_exp,err_gp_b(rdef),err_gp(rdef) 
#endif
 
        end if
      end if
 
      if (mod(i,2).eq.1) then
 
        if (use_gr) then
 
#ifdef Credtest
          write(*,*) 'CalcCred: it gr',use_gr,err_gr_exp,err_gr_b(rdef),err_gr(rdef),  &
                                     err_req_cr(rdef)
#endif
 
          if (err_gr_exp.gt.err_gr_b(rdef)) then
            gr = i/2
            err_gr_exp = err_gr_exp*fac_gr
            err_gr(rdef) = max(err_gr_exp, err_gr_b(rdef))
            if(err_gr(rdef).lt.err_req_cr(rdef)) then
              iexp = 4
              ! increase gy by 2 to account for bad estimates
! changed 28.07.14
!             gr = min(max(gr+4,2*gr),(rmax_C-rmax)/2)
              gr = min(max(gr+4,2*gr),rmax_c-rmax,max(0,(rmax_b-2*rmax)/2))
              exit
            end if
          end if
 
#ifdef Credtest
      write(*,*) 'CalcCred: it gr',i,gr, err_gr_exp,err_gr_b(rdef) ,err_gr(rdef)
#endif
 
        end if
      end if
 
      if (mod(i,2).eq.1) then
        if (use_gpf) then
          if (err_gpf_exp.gt.err_gpf_b(rdef)) then
            gpf = i/2
            err_gpf_exp = err_gpf_exp*fac_gpf
            err_gpf(rdef) = max(err_gpf_exp, err_gpf_b(rdef))
            if(err_gpf(rdef).lt.err_req_cr(rdef)) then
              iexp = 5
              ! increase gpf by 2 to account for bad estimates
              gpf = min(max(gpf+4,2*gpf),(rmax_c-rmax)/2)
              exit
            end if
 
#ifdef Credtest
          write(*,*) 'CalcCred i gpf',i,gpf,err_gpf_exp,err_gpf_b(rdef),err_gpf(rdef),err_req_cr(rdef)
#endif
 
          end if
        end if
      end if
 
    end do
 
    ! scale estimates down to allow trying other methods
    err_g(rdef)  =  err_g(rdef)/impest_c
    err_gy(rdef) =  err_gy(rdef)/impest_c     
    err_gp(rdef) =  err_gp(rdef)/impest_c
    err_gr(rdef) =  err_gr(rdef)/impest_c     
    err_gpf(rdef)=  err_gpf(rdef)/impest_c     
 
#ifdef Credtest
    write(*,*) 'iexp=',iexp
    write(*,*) 'facexp=',fac_g,fac_gy,fac_gp,fac_gr,fac_gpf
    write(*,*) 'errexp=',err_g_exp,err_gy_exp,err_gp_exp,err_gr_exp,err_gpf_exp,err_req_cr(rdef)
    write(*,*) 'errexptot=',i
    write(*,*) 'g:  errexptot =',g,err_g(rdef)
    write(*,*) 'gy: errexptot =',gy,err_gy(rdef)
    write(*,*) 'gp: errexptot =',gp,err_gp(rdef)
    write(*,*) 'gr: errexptot =',gr,err_gr(rdef)
    write(*,*) 'gpf: errexptot=',gpf,err_gpf(rdef)
    write(*,*) 'errexptot=',i,g,err_g(rdef),gy,err_gy(rdef),gp,err_gp(rdef),gr,err_gr(rdef),gpf,err_gpf(rdef)
    write(*,*) 'accexptot=',i,g,err_g(rdef)/ctyp,gy,err_gy(rdef)/ctyp,gp,err_gp(rdef)/ctyp,      &    
        gr,err_gr(rdef)/ctyp,gpf,err_gpf(rdef)/ctyp
#endif
 
    ! call expansions with estimated order to save CPU time
 
#ifdef TEST
!    iexp = 0   ! TEST: force specific expansion
!    gy = 14
#endif
 
    select case (iexp)
 
#ifdef TEST
!  case only as replacement for CalcCg, not as extra case
      case (7)  
        call calccgn(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,g,g,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(3) = ccount(3)+1
        crcalc(0:rmax)=crcalc(0:rmax)+4
        ccalc=ccalc+4
        crmethod_alt(0:rmax)=4
        
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_g(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(rdef),cerr_alt(rdef)
        end if
#endif
 
        err_g=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
        
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
#endif
 
      case (1)  
        call calccg(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,g,g,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(3) = ccount(3)+1
        crcalc(0:rmax)=crcalc(0:rmax)+4
        ccalc=ccalc+4
        crmethod_alt(0:rmax)=4
        
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_g(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(rdef),cerr_alt(rdef)
        end if
#endif
 
        err_g=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
        
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
 
      case (2)
 
        call calccgy(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gy,gy,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(4) = ccount(4)+1
        crcalc(0:rmax)=crcalc(0:rmax)+8
        ccalc=ccalc+8
        crmethod_alt(0:rmax)=8
 
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_gy(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_gy imprecise',err_gy(rdef),cerr_alt(rdef),checkest
        end if
#endif
 
        err_gy=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
 
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
 
      case (3)  
        call calccgp(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gp,gp,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(5) = ccount(5)+1
        crcalc(0:rmax)=crcalc(0:rmax)+16
        ccalc=ccalc+16
        crmethod_alt(0:rmax)=16
 
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_gp(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_gp imprecise',err_gp(rdef),cerr_alt(rdef)
        end if
#endif
 
        err_gp=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
 
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
 
      case (4)  
        call calccgr(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gr,gr,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(6) = ccount(6)+1
        crcalc(0:rmax)=crcalc(0:rmax)+32
        ccalc=ccalc+32
        crmethod_alt(0:rmax)=32
 
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_gr(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_gr imprecise',err_gr(rdef),cerr_alt(rdef)
        end if
#endif
 
        err_gr=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
 
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
 
      case (5)
 
        call calccgpf(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gpf,gpf,id,cerr1_alt,acc_req_cr,cerr2_alt)
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(4) = ccount(4)+1
        crcalc(0:rmax)=crcalc(0:rmax)+8
        ccalc=ccalc+8
        crmethod_alt(0:rmax)=8
 
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_gpf(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_gpf imprecise',err_gpf(rdef),cerr_alt(rdef),checkest
        end if
#endif
 
        err_gpf=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
 
#ifdef Credtest
        write(*,*) 'CalcCred Cerr after exp =',cerr
        write(*,*) 'CalcCred Cacc=',cerr/ctyp
        write(*,*) 'CalcCred method=',crmethod
#endif
 
    end select
 
#ifndef USEC0
#ifndef ALWAYSPV
    ! refine error estimate for C0
    if(.not.lerr_c0.and.iexp.ne.0) then
!      C0est =  abs(C(0,0,0))
      err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
!      err_req_Cr = acc_req_Cr * abs(C(0,0,0))
      lerr_c0 = .true.
    end if
#endif
#endif
 
    if (iexp.ne.0)  then         !  if added 21.11.2016 
      if (rmax.ge.1) then
        ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
      else
        ctyp =  abs(c(0,0,0))
      end if
      err_req_cr = acc_req_cr * ctyp
      
      if (maxval(cerr1-err_req_cr).lt.0) then
        ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
        return
      end if
    end if    
 
#ifdef Credtest
    write(*,*) 'CalcCred no optimal method bef shift',ctyp,acc_req_cr
    write(*,*) 'err_req=',err_req_cr(rdef),rdef
    write(*,*) 'err_est=',err_pv(rdef),err_pv2(rdef),err_g(rdef)  &
        ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)
#endif
 
#ifdef TEST
    return          ! do not try shifted PV
#endif
 
#ifdef PVSHIFT 
    ! try PV with shifted momentum
    shiftloop: do i=1,2
 
#ifdef Credtest
      write(*,*) 'CalcCred try pv shift i = ',i
#endif    
 
      if (i.eq.1) then
        mm02shift = mm12
        mm12shift = mm02
        mm22shift = mm22
        q10shift = q10
        q21shift = q20
        q20shift = q21
      else 
        mm02shift = mm22
        mm12shift = mm12
        mm22shift = mm02
        q10shift = q21
        q21shift = q10
        q20shift = q20
      end if
 
      zshift(1,1) = 2d0*q10shift
      zshift(2,1) = q10shift+q20shift-q21shift
      zshift(1,2) = zshift(2,1)
      zshift(2,2) = 2d0*q20shift
 
      maxzshift = maxval(abs(zshift))
 
      detzshift = chdet(2,zshift)
 
!      if (detZshift.ne.0d0) then
!        call chinv(2,Zshift,Zinvshift)
!        Zadjshift = Zinvshift * detZshift
!      else
        zadjshift(1,1) = zshift(2,2)
        zadjshift(2,1) = -zshift(1,2)
        zadjshift(1,2) = -zshift(1,2)
        zadjshift(2,2) = zshift(1,1)
!      end if
 
      zadjsshift(1) = q21shift + q20shift - q10shift 
      zadjsshift(2) = q21shift + q10shift - q20shift
 
      detzmzadjfshift = q21shift*zshift(2,1)
 
      adetzshift = abs(detzshift)
      maxzadjshift = max(abs(zadjshift(1,1)),abs(zadjshift(2,1)),abs(zadjshift(2,2)))
 
      fshift(1) = q10shift+mm02shift-mm12shift 
      fshift(2) = q20shift+mm02shift-mm22shift
 
#ifdef Credtestshift
      write(*,*) 'fshift1',q10shift+mm02shift-mm12shift,q10shift,mm02shift,-mm12shift
      write(*,*) 'fshift2',q20shift+mm02shift-mm22shift,q20shift,mm02shift,-mm22shift
#endif
 
      mxshift(0,0) = 2d0*mm02shift
      mxshift(1,0) = fshift(1)
      mxshift(2,0) = fshift(2)
      mxshift(0,1) = mxshift(1,0)
      mxshift(0,2) = mxshift(2,0)
!     mxshift(1,1) = 2d0*q10shift
!     mxshift(2,1) = q10shift+q20shift-q21shift
!     mxshift(2,2) = 2d0*q20shift
!     mxshift(1,2) = mxshift(2,1)
 
      mxshift(1:2,1:2) = zshift(1:2,1:2)
 
      detxshift = chdet(3,mxshift)
 
      if (detxshift.ne.0d0.and.maxzshift.ne.0d0) then
 
!     write(*,*) 'CalcCred mxshift=',mxshift
 
        call chinv(3,mxshift,mxinvshift)
 
!     write(*,*) 'CalcCred mxinvshift=',mxinvshift
 
        xadjshift = mxinvshift * detxshift
 
!     write(*,*) 'CalcCred Xadj=',Xadj
 
        zadjfshift(1:2) = -xadjshift(0,1:2)
 
      else
        zadjfshift(1) = zadjshift(1,1)*fshift(1)+zadjshift(2,1)*fshift(2)
        zadjfshift(2) = zadjshift(1,2)*fshift(1)+zadjshift(2,2)*fshift(2)
        xadjshift(2,2) = 2d0*mm02shift*mxshift(1,1) - fshift(1)*fshift(1)
        xadjshift(1,1) = 2d0*mm02shift*mxshift(2,2) - fshift(2)*fshift(2)
        xadjshift(2,1) = 2d0*mm02shift*mxshift(1,2) - fshift(1)*fshift(2)
        xadjshift(1,2) = xadjshift(2,1)
      end if
 
#ifdef Credtestshift
      write(*,*) 'fishift ',fshift(1),fshift(2)
      write(*,*) 'm02shift ',mm02shift,mxshift(1,1),mxshift(2,2),mxshift(1,2)
      write(*,*) 'Xadjshift11 ', 2d0*mm02shift*mxshift(1,1) - fshift(2)*fshift(2),xadjshift(1,1)
      write(*,*) 'Xadjshift21 ', 2d0*mm02shift*mxshift(1,2) - fshift(1)*fshift(2),xadjshift(1,2)
      write(*,*) 'Xadjshift22 ', 2d0*mm02shift*mxshift(2,2) - fshift(1)*fshift(1),xadjshift(2,2)
      write(*,*) 'detXshiftn ',detxshift
      write(*,*) 'Zadjfshift1',zadjfshift(1),2d0*q20shift*fshift(1)  &  
          +(q21shift-q20shift-q10shift)*fshift(2)
      write(*,*) 'Zadjfshift2',zadjfshift(2), &  
          (q21shift-q20shift-q10shift)*fshift(1)+2d0*q10shift*fshift(2)
#endif
      
      maxzadjfshift = max(abs(zadjfshift(1)),abs(zadjfshift(2)))
!    maxZadjfds = max(maxZadjfshift,adetZshift)
 
      azadjffshift = abs(zadjfshift(1)*fshift(1) + zadjfshift(2)*fshift(2))
!    adetXshift = abs(2d0*mm02*detZshift - Zadjfshift(1)*fshift(1) - Zadjfshift(2)*fshift(2))
!    maxXadjshift = max(abs(Xadjshift(1,1)),abs(Xadjshift(2,1)),abs(Xadjshift(2,2)))
 
      h_pvs = real(undefined_c)
      w_pvs = real(undefined_c)
      v_pvs = real(undefined_c)
      z_pvs = real(undefined_c)
      if (adetzshift.lt.dprec_cll*maxzadjfshift.or.adetzshift.lt.dprec_cll*maxzshift**2.or.adetzshift.eq.0d0) then
        use_pvs = .false.
        err_pvs = err_inf
      else
        use_pvs = .true.
        err_pvs(0) = err_c0
        if (rdef.gt.0) then
#ifdef PVEST2
          h_pvs = sqrt(adetzshift)/maxzadjshift
          w_pvs = max((maxzadjfshift*h_pvs/adetzshift)**2, abs(mm02shift)*maxzshift*h_pv/adetzshift,  &
              azadjffshift*maxzshift*(h_pvs/adetzshift)**2)
          v_pvs = maxzadjfshift*h_pvs/adetzshift
          z_pvs = maxz*h_pvs/adetzshift
#else
          w_pvs = max((maxzadjfshift/adetzshift)**2, abs(mm02shift)*maxzshift/adetzshift,   &
              maxzshift*azadjffshift/adetzshift**2)
          v_pvs = maxzadjfshift/adetzshift
          z_pvs = maxzshift/adetzshift
#endif
 
#ifdef Credtest
          write(*,*) 'CalcCred w_pvs',(maxzadjfshift/adetz)**2, abs(mm02shift)*maxz/adetz, maxz*azadjffshift/adetz**2
          write(*,*) 'CalcCred w_pvs',w_pvs,v_pvs,z_pv,h_pv
#endif
 
          if (mod(rdef,2).eq.1) then
            err_pvs(rdef) = max( w_pvs**((rdef-1)/2) * v_pvs * err_c0,  &
                max(w_pvs**((rdef-1)/2),1d0) * z_pv * err_b )
            
#ifdef Credtest
            write(*,*) 'CalcCred err_pvs', w_pvs**((rdef-1)/2)* v_pvs* err_c0, &
                w_pvs**((rdef-1)/2) * z_pv * err_b, err_c0,err_b
            write(*,*) 'CalcCred err_pvs', w_pvs**((rdef-1)/2),v_pvs, err_c0
#endif
            
          else
            err_pvs(rdef) = max( w_pvs**(rdef/2) * err_c0,  &
                max(w_pvs**(rdef/2-1) * v_pvs, 1d0) * z_pv * err_b )
            
#ifdef Credtest      
            write(*,*) 'CalcCred w_pvs', w_pvs,err_c0,sqrt(w_pvs)
            write(*,*) 'CalcCred w_pvs', (maxzadjfshift/adetzshift)**2,  &
                abs(mm02shift)*maxzshift/adetzshift, maxzshift*azadjffshift/adetzshift**2
            write(*,*) 'CalcCred err_pvs', w_pvs**(rdef/2) * err_c0, &
                w_pvs**(rdef/2-1) * v_pvs * z_pv * err_b, z_pv * err_b, err_c0,err_b
#endif
            
          end if
        end if
      end if
 
#ifdef Credtest
      write(*,*) 'CalcCred use_pvs',use_pvs,err_pvs(rdef).lt.err_pv(rdef),i
      write(*,*) 'CalcCred err_pvs',err_pvs(rdef),err_pv(rdef),i      
#endif
 
      if(use_pvs.and.err_pvs(rdef).lt. min(err_pv(rdef),err_pv2(rdef),err_g(rdef)  &
        ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)) ) then
 
#ifdef Credtest
        write(*,*) 'CalcCred: call Cpvs 1 ',rmax,id,err_pvs(rdef)
#endif
 
        ! use shifted PV-reduction
        if (i.eq.1) then
          call calccpvshift(c_alt,cuv,p10,p20,p21,m12,m02,m22,rmax,id,cerr1_alt,cerr2_alt)
! map coefficients back, order of calculation matters!
          do r=1,rmax
            do n2=0,rmax-r
              do n1=rmax-n2,r,-1
                n0 = rmax-n1-n2
!                write(*,*) 'pvs2',n0,n1,n2,-C_alt(0:n0,n1-1,n2),-C_alt(0:n0,n1,n2),-C_alt(0:n0,n1-1,n2+1)
                c_alt(0:n0,n1,n2) = -c_alt(0:n0,n1-1,n2)-c_alt(0:n0,n1,n2)-c_alt(0:n0,n1-1,n2+1)
!                write(*,*) 'pvs2',n0,n1,n2,C_alt(0:n0,n1,n2)
              end do
            end do
          end do
 
        elseif (i.eq.2) then
          call calccpvshift(c_alt,cuv,p21,p10,p20,m22,m12,m02,rmax,id,cerr1_alt,cerr2_alt)
 
          do r=1,rmax
            do n1=0,rmax-r
              do n2=rmax-n1,r,-1
                n0 = rmax-n1-n2
                c_alt(0:n0,n1,n2) = -c_alt(0:n0,n1,n2-1)-c_alt(0:n0,n1,n2)-c_alt(0:n0,n1+1,n2-1)
!                write(*,*) 'pvs2',n0,n1,n2,C_alt(0:n0,n1,n2),-C_alt(0:n0,n1,n2-1),-C_alt(0:n0,n1,n2),-C_alt(0:n0,n1+1,n2-1)
              end do
            end do
          end do
 
        end if
 
#ifdef PVEST2
        cerr_alt = cerr2_alt
#else
        cerr_alt = cerr1_alt
#endif
        ccount(9) = ccount(9)+1
!        CrCalc(0:rmax)=CrCalc(0:rmax)+1
!        CCalc=CCalc+1
        crmethod_alt(0:rmax)=1
        if (cerr_alt(rmax).lt.cerr(rmax)) then
           ccount(8) = ccount(8)+1
        end if
 
#ifdef Credtest
        checkest=cerr_alt(rdef)/err_pvs(rdef)
        if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
          write(*,*) 'CalcCred: estimate err_pvs imprecise ',err_pvs(rdef),cerr_alt(rdef)
        end if
#endif
 
        err_pvs=cerr_alt
 
        call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
 
        if (rmax.ge.1) then
          ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
        else
          ctyp =  abs(c(0,0,0))
        end if
        err_req_cr = acc_req_cr * ctyp
      
#ifdef Credtest
        write(*,*) 'CalcCred C0est after PVS=',abs(c(0,0,0)),ctyp
        write(*,*) 'CalcCred Cerr after PVS =',cerr
        write(*,*) 'CalcCred Cacc after PVS =',cerr/ctyp
        write(*,*) 'CalcCred err_req =',err_req_cr
        write(*,*) 'CalcCred Cerr1-req=',cerr1-err_req_cr
        write(*,*) 'CalcCred max(Cerr-req)',maxval(cerr-err_req_cr)
        write(*,*) 'CalcCred max(Cerr1-req)',maxval(cerr1-err_req_cr)
#endif
 
! check with Cerr = Cerr2: exp not tried => larger errors
        if (maxval(cerr1-err_req_cr).lt.0) then
          ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
          return
        end if
 
      end if
    end do shiftloop
#endif
 
#ifdef Credtest
    write(*,*) 'CalcCred no optimal method aft shift',ctyp,acc_req_cr
    write(*,*) 'err_req=',err_req_cr(rdef),rdef
    write(*,*) 'err_est=',err_pv(rdef),err_pv2(rdef),err_g(rdef)  &
        ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)
#endif
 
#ifdef TEST
    return      !  TEST: no improvement by other methods
#endif
 
    ! no method does work optimal
    ! use the least problematic (for each rank)
 
    do r=rmax,0,-1
     
 
      if(use_pv.and.mod(crcalc(r),2).ne.1) then   
    ! estimate accuracy of PV-reduction if not yet calculated
        if (use_pv) then
 
!          write(*,*) 'CalcCred err_pv',  r,w_pv,v_pv,z_pv,err_C0,err_B
 
          if (mod(r,2).eq.1) then
            err_pv(r) = max( w_pv**((r-1)/2) * v_pv * err_c0,  &
                max(w_pv**((r-1)/2),1d0) * z_pv * err_b )
 
!          write(*,*) 'CalcCred err_pv',  w_pv**((r-1)/2) * v_pv * err_C0,  &
!                w_pv**((r-1)/2) * z_pv * err_B, err_C0,err_B
 
          else if (r.ne.0) then
            err_pv(r) = max( w_pv**(r/2) * err_c0,  &
                max(w_pv**(r/2-1) * v_pv , 1d0) * z_pv * err_b )
                
!          write(*,*) 'CalcCred err_pv', w_pv**(rmax/2) * err_C0, &
!                        w_pv**(rmax/2-1) * v_pv * z_pv * err_B, err_C0,err_B
          else
            err_pv(r) = err_c0
          end if
        else
          err_pv(r) = err_inf
        end if
      ! scale estimates down to allow trying other methods
        err_pv(r)  = err_pv(r)/impest_c
      end if
 
      if (use_pv2.and.mod(crcalc(r),4)-mod(crcalc(r),2).ne.2) then
    ! estimate accuracy of alternative PV-reduction if not yet calculated
        if (use_pv2) then
          if (mod(r,2).eq.1) then
! change 21.10.15 for PVEST2
!            err_pv2(r) = max( err_C0 * max(w_pv2**r,w_pv2*v_pv2**((r-1)/2) ),  &
!                err_B * z_pv2 * max(w_pv2**(r+1),w_pv2, &
!                                    w_pv2*v_pv2**((r-1)/2),w_pv2**2, & 
!                                    v_pv2**((r+1)/2),v_pv2) )
            err_pv2(r) = max( err_c0 * max(hw_pv2**r,hw_pv2*v_pv2**((r-1)/2) ),  &
                err_b * z_pv2 * max(w_pv2*hw_pv2**(r),hw_pv2, &
                                    hw_pv2*v_pv2**((r-1)/2),w_pv2*hw_pv2, & 
                                    w_pv2*hw_pv2*v_pv2**((r-1)/2), & 
                                    v_pv2**((r+1)/2),v_pv2) )
 
!            write(*,*) 'CalcC err_pv2 ',r, err_pv2(r), &
!                 err_C0 * max(1d0,w_pv2**r,v_pv2**((r-1)/2),w_pv2*v_pv2**((r-1)/2) )  ,  &
!                 err_B * max(1d0,z_pv2*w_pv2**(r+1),z_pv2*w_pv2, &
!                z_pv2*w_pv2*v_pv2**((r-1)/2),z_pv2*w_pv2**2, & 
!                z_pv2*v_pv2**((r+1)/2),z_pv2*v_pv2)
 
          else
! change 21.10.15 for PVEST2
!            err_pv2(r) = max( err_C0 * max(w_pv2**r,v_pv2**(r/2)),  &
!                err_B * z_pv2 * max(w_pv2**(r+1),w_pv2,  &
!                                    w_pv2*v_pv2**(r/2), w_pv2**2,  &
!                                    v_pv2**(r/2),v_pv2) )
            err_pv2(r) = max( err_c0 * max(hw_pv2**r,v_pv2**(r/2)),  &
                err_b * z_pv2 * max(w_pv2*hw_pv2**(r),hw_pv2,  &
                                    hw_pv2*v_pv2**(r/2), w_pv2*hw_pv2,  &
                                    v_pv2**(r/2),v_pv2) )
          end if
        else
          err_pv2(r) = err_inf
        end if
      ! scale estimates down to allow trying other methods
        err_pv2(r) = err_pv2(r)/impest_c     
      end if
 
      if (use_g.and.mod(crcalc(r),8)-mod(crcalc(r),4).ne.4) then
      ! estimate accuracy of alternative Gram expansion if not yet calculated
        err_g_b(r) = err_b * u_g**r * z_g
        err_g_exp = u_g**(r-1) * ctyp
        err_g(r) = err_inf 
 
      ! determine optimal order of expansion 
        do i=0,rmax_c-r
          g = i
          err_g_exp = err_g_exp*fac_g
          err_g(r) = max(err_g_exp,err_g_b(r))
 
!          write(*,*) 'CalcCred gi',i,g,err_g_exp,err_g(r),err_g_B(r),err_req_Cr(r)
 
          if (err_g_exp.lt.err_g_b(r).or.err_g(r).lt.err_req_cr(r)) exit
        end do
      ! increase gp by 2 to account for bad estimates
        g = min(max(g+2,2*g),rmax_c-r)
      ! scale estimates down to allow trying other methods
        err_g(r)  =  err_g(r)/impest_c
      end if
 
      if (use_gy.and.mod(crcalc(r),16)-mod(crcalc(r),8).ne.8) then
      ! estimate accuracy of alternative Gram-Cayley expansion if not yet calculated
        err_gy_b(r) = err_b * b_gy*v1_gy
        err_gy_exp = 1d0 * ctyp
 
      ! determine optimal order of expansion 
        gy = 0
        do i=0,rmax_c-r
          if (mod(i,2).eq.1) then
            gy = i/2
            err_gy_exp = err_gy_exp*fac_gy
            err_gy(r) = max(err_gy_exp, err_gy_b(r))
            if (err_gy_exp.lt.err_gy_b(r).or.err_gy(r).lt.err_req_cr(r)) exit
          end if
        end do
      ! increase gy by 2 to account for bad estimates
        gy = min(max(gy+4,2*gy),(rmax_c-r)/2)
      ! scale estimates down to allow trying other methods
        err_gy(r) =  err_gy(r)/impest_c     
      end if
 
      if (use_gp.and.mod(crcalc(r),32)-mod(crcalc(r),16).ne.16) then
      ! estimate accuracy of small momentum expansion if not yet calculated
        err_gp_b(r) = err_b * z_gp*v_gp**r
        err_gp_exp = v_gp**(r-1) * ctyp 
 
      ! determine optimal order of expansion 
        do i=0,rmax_c-r
          gp = i
          err_gp_exp = err_gp_exp*fac_gp
          err_gp(r) = max(err_gp_exp,err_gp_b(r))
          if (err_gp_exp.lt.err_gp_b(r).or.err_gp(r).lt.err_req_cr(r)) exit
        end do
      ! increase gp by 2 to account for bad estimates
        gp = min(max(gp+2,2*gp),rmax_c-r)
      ! scale estimates down to allow trying other methods
        err_gp(r) =  err_gp(r)/impest_c
      end if
 
      if (mod(crcalc(r),64)-mod(crcalc(r),32).ne.32.and.use_gr) then
      ! estimate accuracy of alternative Gram expansion
        err_gr_b(r) = err_b * a_gr
        err_gr_exp = y1_gr * ctyp
 
      ! determine optimal order of expansion 
        gr = 0
        do i=0,rmax_c-r
          if (mod(i,2).eq.1) then
            gr = i/2
            err_gr_exp = err_gr_exp*fac_gr
            err_gr(r) = max(err_gr_exp,err_gr_b(r))
 
#ifdef Cgrtest
            write(*,*) 'CalcCgr err_gr',i,gr,err_gr_exp,err_gr_b(r),err_gr(r),err_req_cr(r)
#endif
 
            if (err_gr_exp.lt.err_gr_b(r).or.err_gr(r).lt.err_req_cr(r)) exit
          end if
        end do
      ! increase gr to account for bad estimates
! changed 28.07.14
!       gr = min(max(gr+2,2*gr),(rmax_C-r)/2)
        gr = min(max(gr+2,2*gr),rmax_c-r,max(0,(rmax_b-2*r)/2))
      ! scale estimates down to allow trying other methods
        err_gr(r) =  err_gr(r)/impest_c     
 
      end if
 
      if (use_gpf.and.mod(crcalc(r),128)-mod(crcalc(r),64).ne.64) then
      ! estimate accuracy of alternative Gram-Cayley expansion if not yet calculated
        err_gpf_b(r) = err_b * b_gpf*v1_gpf
        err_gpf_exp = 1d0 * ctyp
 
      ! determine optimal order of expansion 
        gpf = 0
        do i=0,rmax_c-r
          if (mod(i,2).eq.1) then
            gpf = i/2
            err_gpf_exp = err_gpf_exp*fac_gpf
            err_gpf(r) = max(err_gpf_exp, err_gpf_b(r))
            if (err_gpf_exp.lt.err_gpf_b(r).or.err_gpf(r).lt.err_req_cr(r)) exit
          end if
        end do
      ! increase gpf by 2 to account for bad estimates
        gpf = min(max(gpf+4,2*gpf),(rmax_c-r)/2)
      ! scale estimates down to allow trying other methods
        err_gpf(r) =  err_gpf(r)/impest_c     
      end if
 
 
#ifdef Credtest
      write(*,*) 'CalcCred: bef final loop expansion depth',r,g,gy,gp,gr,gpf
      write(*,*) 'CalcCred: 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_gp(r),err_gpf(r)
      write(*,*) 'CalcCred: bef final loop acc methods',r,err_pv(r)/ctyp,err_pv2(r)/ctyp,    &
             err_g(r)/ctyp,err_gy(r)/ctyp,err_gp(r)/ctyp,err_gr(r)/ctyp,err_gpf(r)/ctyp
      write(*,*) 'CalcCred: bef final loop',r,crcalc(r),crmethod(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(crcalc(r),2).ne.1) then
 
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
#ifdef Credtest
          write(*,*) 'CalcCred: call Cpv 2',r,id
#endif
          if (r.eq.rmax) then
            call calccpv1(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,id,cerr1_alt,cerr2_alt)
          else
            call calccpv1(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),  &
                p10,p21,p20,m02,m12,m22,r,id,cerr1_alt(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(11) = ccount(11)+1
          crcalc(0:r)=crcalc(0:r)+1
          ccalc=ccalc+1
          crmethod_alt(0:r)=1
          checkest=cerr_alt(r)/(err_pv(r)*abs(c_alt(0,0,0)))
          
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate acc_pv imprecise',err_pv(r),cerr_alt(r)/abs(c_alt(0,0,0))
          end if
#endif
 
          err_pv(0:r)=cerr_alt(0:r)
 
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after pv 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after pv 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after pv 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.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(crcalc(r),4)-mod(crcalc(r),2).ne.2) then
 
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccpv2(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,id,cerr1_alt,cerr2_alt)
          else
            call calccpv2(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),p10,p21,p20,m02,m12,m22,r,id,cerr1_alt(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(12) = ccount(12)+1
          crcalc(0:r)=crcalc(0:r)+2
          ccalc=ccalc+2
          crmethod_alt(0:r)=2
          checkest=cerr_alt(r)/(err_pv(r)*abs(c_alt(0,0,0)))
          
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_pv2 imprecise',err_pv2(r),cerr_alt(r)
          end if
#endif
 
          err_pv2(0:r)=cerr_alt(0:r)
 
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after pv 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after pv 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after pv 2nd try Cacc(r)',cerr/ctyp
#endif
          
          if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
 
        end if
 
      else 
 
#ifdef Credtest
        write(*,*) 'CalcCred: 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(crcalc(r),8)-mod(crcalc(r),4).ne.4) then
 
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccg(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,g,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
          else
            call calccg(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),   &
                p10,p21,p20,m02,m12,m22,r,g,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(13) = ccount(13)+1
          crcalc(0:r)=crcalc(0:r)+4
          ccalc=ccalc+4
          crmethod_alt(0:r)=4
          checkest=cerr_alt(r)/err_g(r)
 
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(r),cerr_alt(r)
          end if
#endif
          
          err_g(0:r)=cerr_alt(0:r)
 
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.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(crcalc(r),16)-mod(crcalc(r),8).ne.8) then
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccgy(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gy,(rmax_c)/2,id,cerr1_alt,acc_req_cr,cerr2_alt)
          else
            call calccgy(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),  &
                p10,p21,p20,m02,m12,m22,r,gy,(rmax_c)/2,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(14) = ccount(14)+1
          crcalc(0:r)=crcalc(0:r)+8
          ccalc=ccalc+8
          crmethod_alt(0:r)=8
          checkest=cerr_alt(r)/err_gy(r)
 
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_gy imprecise',err_gy(r),cerr_alt(r)
          end if
#endif
          err_gy(0:r)=cerr_alt(0:r)
          
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
  
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.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(crcalc(r),32)-mod(crcalc(r),16).ne.16) then
 
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccgp(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gp,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
          else
            call calccgp(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),   &
                p10,p21,p20,m02,m12,m22,r,gp,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(15) = ccount(15)+1
          crcalc(0:r)=crcalc(0:r)+16
          ccalc=ccalc+16
          crmethod_alt(0:r)=16
          checkest=cerr_alt(r)/err_gp(r)
 
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_gp imprecise',err_gp(r),cerr_alt(r)
          end if
#endif
 
          err_gp(0:r)=cerr_alt(0:r)
          
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.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(crcalc(r),64)-mod(crcalc(r),32).ne.32) then
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccgr(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gr,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
          else
            call calccgr(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),   &
                p10,p21,p20,m02,m12,m22,r,gr,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(16) = ccount(16)+1
          crcalc(0:r)=crcalc(0:r)+32
          ccalc=ccalc+32
          crmethod_alt(0:r)=32
          checkest=cerr_alt(r)/err_gr(r)
 
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_gr imprecise',err_gr(r),cerr_alt(r)
          end if
#endif
 
          err_gr(0:r)=cerr_alt(0:r)
          
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
 
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods          
 
        else if (use_gpf.and.err_gpf(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gr(r))        &
            .and.mod(crcalc(r),128)-mod(crcalc(r),64).ne.64) then
!          deallocate(C_alt)
!          deallocate(Cuv_alt)
!          deallocate(Cerr_alt)
!          deallocate(Cerr2_alt)
!          deallocate(Crmethod_alt)
!          allocate(C_alt(0:r,0:r,0:r))
!          allocate(Cuv_alt(0:r,0:r,0:r))
!          allocate(Cerr_alt(0:r))
!          allocate(Cerr2_alt(0:r))
!          allocate(Crmethod_alt(0:r))
 
          if (r.eq.rmax) then
            call calccgpf(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gpf,(rmax_c)/2,id,cerr1_alt,acc_req_cr,cerr2_alt)
          else
            call calccgpf(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),  &
                p10,p21,p20,m02,m12,m22,r,gpf,(rmax_c)/2,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
          end if
#ifdef PVEST2
          cerr_alt = cerr2_alt
#else
          cerr_alt = cerr1_alt
#endif
          ccount(17) = ccount(17)+1
          crcalc(0:r)=crcalc(0:r)+64
          ccalc=ccalc+64
          crmethod_alt(0:r)=64
          checkest=cerr_alt(r)/err_gpf(r)
 
#ifdef Credtest
          if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
            write(*,*) 'CalcCred: estimate err_gpf imprecise',err_gpf(r),cerr_alt(r)
          end if
#endif
          err_gpf(0:r)=cerr_alt(0:r)
          
          call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r),   &   
              cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
  
          if (rmax.ge.1) then
            ctyp =  max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
          else
            ctyp =  abs(c(0,0,0))
          end if
          err_req_cr = acc_req_cr * ctyp
 
#ifdef Credtest
          write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
          write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
          write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
#endif
 
          if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100     ! error larger than expected: try other methods
          
        end if
 
      end if
 
#ifndef USEC0
#ifndef ALWAYSPV
      ! refine error estimate for C0
      if(.not.lerr_c0) then
!        C0est =  abs(C(0,0,0))
        err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
!        err_req_Cr = acc_req_Cr * abs(C(0,0,0))
        lerr_c0 = .true.
      end if
#endif
#endif
 
#ifdef Credtest
      write(*,*) 'CalcCred: final loop err methods',r,err_pv(r),err_pv2(r),    &
          err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gpf(r)
      write(*,*) 'CalcCred: final loop acc methods',r,err_pv(r)/ctyp,err_pv2(r)/ctyp,    &
             err_g(r)/ctyp,err_gy(r)/ctyp,err_gp(r)/ctyp,err_gr(r)/ctyp,err_gpf(r)/ctyp
      write(*,*) 'CalcCred: final loop',r,crcalc(r),crmethod(r)
#endif
    end do
 
    norm = abs(c(0,0,0))
    do r=1,rdef
      do n1=0,rdef
        n2 = rdef-n1
       norm =  max(norm,abs(c(0,n1,n2)))
      end do
    end do
    acc_c(0:rdef) = cerr(0:rdef)/norm
 
    ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
 
    if (maxval(acc_c(0:rdef)-sqrt(reqacc_coli)).gt.0) then
      ccount(ccalc+ccountoffset3) = ccount(ccalc+ccountoffset3)+1
    end if
 
    if (maxval(acc_c(0:rdef)-reqacc_coli).gt.0) then
      ccount(ccalc+ccountoffset1) = ccount(ccalc+ccountoffset1)+1
    end if
 
#ifdef Credtest              
    write(*,*) 'CalcCred final acc_C=',cerr/norm,critacc_coli
    write(*,*) 'CalcCred final method C=',crmethod
#endif              
 
    if (maxval(acc_c(0:rdef)-critacc_coli).gt.0) then
 
      ccount(ccalc+ccountoffset2) = ccount(ccalc+ccountoffset2)+1
 
#ifdef Credtest
      write(*,*) 'CritPoint C',critacc_coli,acc_c
      write(*,*) 'CritPoint C',maxval(acc_c(0:rdef)-critacc_coli),maxval(acc_c(0:rdef)),rdef,acc_c(rdef)
#endif      
 
!      call SetErrFlag_coli(-5)
!      call ErrOut_coli('CalcCred',' critical accuracy not reached', &
!           errorwriteflag)
 
#ifdef CritPointsCOLI 
      critpointcntc = critpointcntc + 1    
 
      if (critpointcntc.le.maxcritpointc.and.monitoring) then
        call critpointsout_coli('C_coli',acc_c(rdef))
        write(ncpout_coli,*) 'arguments of CalcCred_coli:'
        write(ncpout_coli,*) 'rank = ', rmax
        if(present(rbasic)) write(ncpout_coli,*) 'rbas = ', rbasic
        write(ncpout_coli,fmt1) 'p10 = ', p10
        write(ncpout_coli,fmt1) 'p21 = ', p21
        write(ncpout_coli,fmt1) 'p20 = ', p20
        write(ncpout_coli,fmt1) 'm02 = ', m02
        write(ncpout_coli,fmt1) 'm12 = ', m12
        write(ncpout_coli,fmt1) 'm22 = ', m22
        if (critpointcntc.eq.maxcritpointc) then
          write(ncpout_coli,*)
          write(ncpout_coli,*)
          write(ncpout_coli,*)
          write(ncpout_coli,*) '***********************************************************'
          write(ncpout_coli,*)
          write(ncpout_coli,*) ' Further output of bad C functions will be suppressed '
        end if
      end if
#endif
    end if
 
#ifdef Credtest
    write(*,*) 'CalcCred out'
#endif
 
  end subroutine calccred
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCuv(Cuv,Buv_0,m02,f,rmax,id)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccuv(Cuv,Buv_0,m02,f,rmax,id)
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: m02,f(2)
!   double complex, intent(inout) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(in) :: Buv_0(0:rmax-1,0:rmax-1,0:rmax-1)
    integer :: r,n0,n1,n2,r0
        
    ! C_(0,n1,n2) UV-finite
    cuv(0,:,:) = 0d0
    
!    do r=2,rmax
!      do n0=1,rmax/2
!        do n1=0,r-2*n0
!          n2 = r-2*n0-n1
    do r=2,2*rmax
      do n0=max(1,r-rmax),r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
        
          cuv(n0,n1,n2) = (buv_0(n0-1,n1,n2) + 2*m02*cuv(n0-1,n1,n2)  &
                          + f(1)*cuv(n0-1,n1+1,n2)  & 
                          + f(2)*cuv(n0-1,n1,n2+1)) / (2*r) 
 
        end do
      end do
    end do
    
  end subroutine calccuv
 
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCpv1(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
  !
  !  new version 10.02.2016 (5.10) with (5.11) inserted
  !              27.09.2016    prefactors of B_0 improved
  !              02.09.2017    allocate and q1q2 removed  
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccpv1(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
!   double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
!   double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
!   double complex, allocatable :: C_alt(:,:,:)
    double complex :: B_0(0:rmax-1,0:rmax-1,0:rmax-1), Buv_0(0:rmax-1,0:rmax-1,0:rmax-1)
    double complex :: B_i(0:rmax-1,0:rmax-1,2), Buv_i(0:rmax-1,0:rmax-1,2)
    double complex :: C_alt(0:rmax,0:rmax,0:rmax)
    double complex :: Smod(2)
    double complex :: C0_coli, elimminf2_coli
!   double precision, allocatable :: C00_err(:),Cij_err(:)
!   double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: C00_err(0:rmax),Cij_err(0:rmax)
    double precision :: C00_err2(0:rmax),Cij_err2(0:rmax)
    double precision :: B_err,B_max
    integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
    integer :: bin,k,nid(0:2)
 
#ifdef Cpv1test
!    write(*,*) 'CalcCpv1 p in ',p10,p21,p20
!    write(*,*) 'CalcCpv1 m in ',m02,m12,m22
    write(*,*) 'CalcCpv1 in ',rmax,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCpv1 in ',rmax,id
#endif
 
    ! calculation of scalar coefficient
    c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
    cuv(0,0,0) = 0d0
 
    ! accuracy estimate for C0 function
    cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
    cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
 
    if (rmax.eq.0) return
    
    ! allocation and calculation of B functions
    rmaxb = rmax-1
    ! rmaxB = max(rmax-1,0)
!   allocate(B_0(0:rmaxB,0:rmaxB,0:rmaxB))
!   allocate(Buv_0(0:rmaxB,0:rmaxB,0:rmaxB))
!   allocate(B_i(0:rmaxB,0:rmaxB,2))
!   allocate(Buv_i(0:rmaxB,0:rmaxB,2))
 
    ! allocate arrays for error propagation
!   allocate(C00_err(0:rmax))
!   allocate(Cij_err(0:rmax))
!   allocate(C00_err2(0:rmax))
!   allocate(Cij_err2(0:rmax))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0 and calculate maximal B(0,...)
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
 
!    write(*,*) 'B_max=',B_max
 
    b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
 
    ! determine inverse Gram matrix
    ! commented out 2.9.2017
    ! Zinv = Zadj/detZ
 
    ! calculate Cuv
    call calccuv(cuv,buv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
    cij_err =0d0
    c00_err =0d0
    cij_err(0) = cerr(0)
    b_err = acc_def_b*b_max
 
    cij_err2 =0d0
    c00_err2 =0d0
    cij_err2(0) = cerr2(0)
 
 
#ifdef Cpv1test
!    write(*,*) 'CalcCpv1: B_err= ',B_err,acc_def_B,B_max
    write(*,*) 'CalcDpv1 Cij_err(0)=',cij_err(0)
!    write(*,*) 'CalcCpv1 test :', & 
!            (1d0 - (Zadjf(1)+Zadjf(2))/detZ), &
!            (detZmZadjf + Zadjs(1)*(mm12-mm02) + Zadjs(2)*(mm22-mm02)) /detZ
#endif
 
!   allocate(C_alt(0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
    ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = + 4*cuv(n0,n1,n2) + detx/detz*c(n0-1,n1,n2)
            c(n0,n1,n2) = c(n0,n1,n2) &
                + (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
                  ) /detz * b_0(n0-1,n1,n2)
!                + (1d0 - (Zadjf(1)+Zadjf(2))/detZ)* B_0(n0-1,n1,n2)
 
            if (n1.ge.1) then
              c(n0,n1,n2) = c(n0,n1,n2) &
                  - 2*n1*zadjf(1)/detz*c(n0,n1-1,n2)
            else            
              c(n0,n1,n2) = c(n0,n1,n2) &
                  + zadjf(1)/detz* b_i(n0-1,n2,1)
            end if
            if (n2.ge.1) then
              c(n0,n1,n2) = c(n0,n1,n2) &
                  - 2*n2*zadjf(2)/detz*c(n0,n1,n2-1)
            else            
              c(n0,n1,n2) = c(n0,n1,n2) &
                  + zadjf(2)/detz * b_i(n0-1,n1,2)
            end if
 
            c(n0,n1,n2) = c(n0,n1,n2)  / (2*r) 
 
!        if(n0.eq.1) then
!          write(*,*) 'Ca(1,n1,n2)=',n1,n2, 4*Cuv(n0,n1,n2) + detX/detZ*C(n0-1,n1,n2)
!          write(*,*) 'Ca(1,n1,n2)=', (detZmZadjf + Zadjs(1)*(mm12-mm02) + Zadjs(2)*(mm22-mm02) &
!                  ) /detZ * B_0(n0-1,n1,n2)
!          write(*,*) 'Ca(1,n1,n2)=', detZmZadjf , Zadjs(1)*(mm12-mm02) , Zadjs(2)*(mm22-mm02) &
!                  ,detZ , B_0(n0-1,n1,n2)
!          write(*,*) 'Ca(1,n1,n2)=', (1d0 - (Zadjf(1)+Zadjf(2))/detZ)* B_0(n0-1,n1,n2)
!          write(*,*) 'Ca(1,n1,n2)=',  + Zadjf(1)/detZ* B_i(n0-1,n2,1)
!          write(*,*) 'Ca(1,n1,n2)=',   + Zadjf(2)/detZ * B_i(n0-1,n1,2)
!        end if
 
         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
          n2 = r-2*n0-n1
 
          if (n1.ge.1) then
            nn1 = n1-1
            nn2 = n2
            j = 1
          else
            nn1 = n1
            nn2 = n2-1
            j = 2
          end if
         
!          do i=1,2
!            Smod(i) = -B_0(n0,nn1,nn2)
!          end do
          smod = 0d0
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
          
          c(n0,n1,n2) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2)  &
                           - zadjs(j)*b_0(n0,nn1,nn2) &
                           - zadjf(j)*c(n0,nn1,nn2))/detz
 
#ifdef Cpv1test
        if(n0.eq.0) then
          write(*,*) 'Ca(0,n1,n2)=',n1,n2,c(0,n1,n2),nn1,nn2,j
          write(*,*) 'Ca(0,n1,n2)=',zadj(1,j),smod(1),zadj(2,j),smod(2)
          write(*,*) 'Ca(0,n1,n2)=',zadjs(j),b_0(n0,nn1,nn2),zadjf(j),c(n0,nn1,nn2)
          write(*,*) 'Ca(0,n1,n2)=',zadj(1,j)*smod(1),zadj(2,j)*smod(2)
          write(*,*) 'Ca(0,n1,n2)=',-zadjs(j)*b_0(n0,nn1,nn2),-zadjf(j)*c(n0,nn1,nn2)
        end if
#endif 
 
        end do
!      end do
 
      ! determine error from symmetry for n0=0 and n1>=1, n2>=1 
      cerr(r)=cerr(r-1)
      cerr2(r)=cerr2(r-1)
      n0=0
        do n1=1,r-2*n0-1
          n2 = r-2*n0-n1
 
          nn1 = n1
          nn2 = n2-1
          j = 2
         
!          do i=1,2
!            Smod(i) = -B_0(n0,nn1,nn2)
!          end do
          smod = 0
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
           
          c_alt(n0,n1,n2) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2)  &
                           - zadjs(j)*b_0(n0,nn1,nn2) &
                           - zadjf(j)*c(n0,nn1,nn2))/detz
 
          cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
          cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
 
#ifdef Cpv1test
        if(n0.eq.0) then
          write(*,*) 'Cb(0,n1,n2)=',n1,n2,c_alt(0,n1,n2),nn1,nn2,j
          write(*,*) 'Cb(0,n1,n2)=',zadj(1,j),smod(1),zadj(2,j),smod(2)
          write(*,*) 'Cb(0,n1,n2)=',zadjs(j),b_0(n0,nn1,nn2),zadjf(j),c(n0,nn1,nn2)
        end if
#endif 
!            write(*,*) 'CalcCpv1 Cerr',n0,n1,n2, Cerr(r), abs(C(n0,n1,n2)),abs(C_alt(n0,n1,n2))
 
        end do
 
      if(r.ge.2)then
! estimate using insertions of (5.11) in (5.10)
        c00_err(r) = max(2*abs(m02)*cij_err(r-2), b_err,    &
              azadjff/adetz*cij_err(r-2),             &
              maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err(r-2),             &
!              maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
!              C00_err(r)
 
      else
        c00_err(r) = 0d0
      end if
! estimate using insertions of (5.10) in (5.11)
      cij_err(r) = max(maxzadjf*cij_err(r-1),   &
              maxzadj*max(2*c00_err(r),b_err))/adetz
 
      if(r.ge.2)then
        c00_err2(r) = max(2*abs(m02)*cij_err2(r-2), b_err,    &
              azadjff/adetz*cij_err2(r-2),             &
              maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err2(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err2(r-2),             &
!              maxZadjf/adetZ*C00_err2(r-1),maxZadjf/adetZ*B_err, &
!              C00_err2(r)
 
      else
        c00_err2(r) = 0d0
      end if
      cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetz)
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
 
#ifdef Cpv1test
    write(*,*) 'CalcCpv1 Cerrsym',cerr
    write(*,*) 'CalcCpv1 Caccsym',cerr/abs(c(0,0,0))
 
    write(*,*) 'CalcCpv1 Cijerr',cij_err(1:rmax)
    write(*,*) 'CalcCpv1 Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
#endif
 
    cerr2 = max(cerr2,cij_err2(0:rmax))
    cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cpv1test
    write(*,*) 'CalcCpv1 Cerr',cerr
    write(*,*) 'CalcCpv1 Cacc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCpv1 out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
 
!    write(*,*) 'CalcCpv1 Cerr ',Cerr
!    write(*,*) 'CalcCpv1 Cerr2',Cerr2
 
#ifdef Cpv1test
!    write(*,*) 'CalcCpv1 C',C(0,0,0)
!    write(*,*) 'CalcCpv1 C1',C(0,1,0)
!    write(*,*) 'CalcCpv1 C2',C(0,0,1)
#endif
 
  end subroutine calccpv1
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCpv1o(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccpv1o(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
    double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
    double complex, allocatable :: C_alt(:,:,:)
    double complex :: Smod(2)
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
    integer :: bin,k,nid(0:2)
 
#ifdef Cpv1otest
    write(*,*) 'CalcCpv1o in ',rmax,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCpv1o in ',rmax,id
#endif
 
    ! calculation of scalar coefficient
    c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
    cuv(0,0,0) = 0d0
 
    ! accuracy estimate for C0 function
    cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
    cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
 
    if (rmax.eq.0) return
    
    ! allocation and calculation of B functions
    rmaxb = rmax-1
    ! rmaxB = max(rmax-1,0)
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmax))
    allocate(cij_err(0:rmax))
    allocate(c00_err2(0:rmax))
    allocate(cij_err2(0:rmax))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0 and calculate maximal B(0,...)
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
 
!    write(*,*) 'B_max=',B_max
 
    b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
 
    ! determine inverse Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
! 
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
!    Zinv(1,1) = 2d0*q20/detZ
!    Zinv(2,1) = -q1q2/detZ
!    Zinv(1,2) = Zinv(2,1)
!    Zinv(2,2) = 2d0*q10/detZ
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
 
    ! commented out 2.9.2017
    ! Zinv = Zadj/detZ
 
    ! calculate Cuv
    call calccuv(cuv,buv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
!    Zadj=Zinv*detZ    
 
!    maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(2,2)))
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
!    maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)))
 
!    aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2))
 
!    adetZ = abs(detZ)
!    adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2))
 
!    write(*,*) 'adZ=',maxZadj,adetZ
 
 
    cij_err =0d0
    c00_err =0d0
    cij_err(0) = cerr(0)
    b_err = acc_def_b*b_max
 
    cij_err2 =0d0
    c00_err2 =0d0
    cij_err2(0) = cerr2(0)
 
!    write(*,*) 'CalcCpv1o: B_err= ',B_err,acc_def_B,B_max
 
    allocate(c_alt(0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
      ! reduction formula (5.10) for C(r/2,0,0)
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
 
!     do n0=(r-1)/2,0,-1
      n0=0 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
 
          if (n1.ge.1) then
            nn1 = n1-1
            nn2 = n2
            j = 1
          else
            nn1 = n1
            nn2 = n2-1
            j = 2
          end if
         
          ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
          do i=1,2
            smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
          end do
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
          
          c(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
 
!        if(n0.eq.0) then
!          write(*,*) 'Ca(0,n1,n2)=',n1,n2,C(0,n1,n2),nn1,nn2,j
!          write(*,*) 'Ca(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
!        end if
 
        end do
!      end do
 
      ! determine error from symmetry for n0=0 and n1>=1, n2>=1 
      cerr(r)=cerr(r-1)
      cerr2(r)=cerr2(r-1)
      n0=0
        do n1=1,r-2*n0-1
          n2 = r-2*n0-n1
 
          nn1 = n1
          nn2 = n2-1
          j = 2
         
          ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
          do i=1,2
            smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
          end do
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
           
          c_alt(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
 
          cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
          cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
 
!            if(n0.eq.0) then
!              write(*,*) 'Cb(0,n1,n2)=',n1,n2,C_alt(0,n1,n2),nn1,nn2,j
!              write(*,*) 'Cb(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
!            end if
!            write(*,*) 'CalcCpv1o Cerr',n0,n1,n2, Cerr(r), abs(C(n0,n1,n2)),abs(C_alt(n0,n1,n2))
 
        end do
 
      if(r.ge.2)then
        c00_err(r) = max(2*abs(m02)*cij_err(r-2), b_err,    &
              azadjff/adetz*cij_err(r-2),             &
              maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err(r-2),             &
!              maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
!              C00_err(r)
 
      else
        c00_err(r) = 0d0
      end if
      cij_err(r) = max(maxzadjf*cij_err(r-1),   &
              maxzadj*max(2*c00_err(r),b_err))/adetz
 
      if(r.ge.2)then
        c00_err2(r) = max(2*abs(m02)*cij_err2(r-2), b_err,    &
              azadjff/adetz*cij_err2(r-2),             &
              maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err2(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err2(r-2),             &
!              maxZadjf/adetZ*C00_err2(r-1),maxZadjf/adetZ*B_err, &
!              C00_err2(r)
 
      else
        c00_err2(r) = 0d0
      end if
      cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetz)
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
 
#ifdef Cpv1otest
    write(*,*) 'CalcCpv1o Cerrsym',cerr
    write(*,*) 'CalcCpv1o Caccsym',cerr/abs(c(0,0,0))
 
    write(*,*) 'CalcCpv1o Cijerr',cij_err(1:rmax)
    write(*,*) 'CalcCpv1o Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
#endif
 
    cerr2 = max(cerr2,cij_err2(0:rmax))
    cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cpv1otest
    write(*,*) 'CalcCpv1o Cerr',cerr
    write(*,*) 'CalcCpv1o Cacc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCpv1o out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
 
!    write(*,*) 'CalcCpv1o Cerr ',Cerr
!    write(*,*) 'CalcCpv1o Cerr2',Cerr2
 
  end subroutine calccpv1o   
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCpv(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccpv(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double precision, intent(out)  :: Cerr(0:rmax),Cerr2(0:rmax)
    double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
    double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
    double complex, allocatable :: C_alt(:,:,:)
    double complex :: Smod(2)
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
    integer :: bin,k,nid(0:2)
 
#ifdef Cpvtest
    write(*,*) 'CalcCpv in ', id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCpv !n ', id
#endif
 
    ! calculation of scalar coefficient
    c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
    cuv(0,0,0) = 0d0
 
    ! accuracy estimate for C0 function
    cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
    cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))   
 
!    write(*,*) 'CalcCpv: Cerr(0)= ',Cerr(0),Cerr(0)/abs(C(0,0,0)),abs(C(0,0,0))
 
    if (rmax.eq.0) return
    
    ! allocation and calculation of B functions
    rmaxb = rmax-1
    ! rmaxB = max(rmax-1,0)
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmax))
    allocate(cij_err(0:rmax))
    allocate(c00_err2(0:rmax))
    allocate(cij_err2(0:rmax))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0 and calculate maximal B(0,...)
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
 
!    write(*,*) 'B_max=',B_max
 
    b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
 
    ! determine inverse Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
! 
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
!    Zinv(1,1) = 2d0*q20/detZ
!    Zinv(2,1) = -q1q2/detZ
!    Zinv(1,2) = Zinv(2,1)
!    Zinv(2,2) = 2d0*q10/detZ
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
 
    ! commented out 2.9.2017
    ! Zinv = Zadj/detZ
 
    ! calculate Cuv
    call calccuv(cuv,buv_0,mm02,f,rmax,id)
 
    ! initialization of error propagation
!    Zadj=Zinv*detZ    
 
!    maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(2,2)))
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
!    maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)))
 
!    aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2))
 
!    adetZ = abs(detZ)
!    adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2))
 
!    write(*,*) 'adZ=',maxZadj,adetZ
 
 
    cij_err =0d0
    c00_err =0d0
    cij_err(0) = cerr(0)
    b_err = acc_def_b*b_max
 
    cij_err2 =0d0
    c00_err2 =0d0
    cij_err2(0) = cerr2(0)
 
!    write(*,*) 'CalcCpv: B_err= ',B_err,acc_B,B_max
 
    allocate(c_alt(0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
      if (mod(r,2).eq.0) then
        ! reduction formula (5.10) for C(r/2,0,0)
        n0 = r/2        
        c(n0,0,0) = (b_0(n0-1,0,0) + 2*mm02*c(n0-1,0,0) + 4*cuv(n0,0,0) &
                        + f(1)*c(n0-1,1,0) + f(2)*c(n0-1,0,1)) / (2*r)
      end if
 
      do n0=(r-1)/2,0,-1
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
 
          if (n1.ge.1) then
            nn1 = n1-1
            nn2 = n2
            j = 1
          else
            nn1 = n1
            nn2 = n2-1
            j = 2
          end if
         
          ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
          do i=1,2
            smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
          end do
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
          
          c(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
 
!        if(n0.eq.0) then
!          write(*,*) 'Ca(0,n1,n2)=',n1,n2,C(0,n1,n2),nn1,nn2
!          write(*,*) 'Ca(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
!        end if
 
        end do
      end do
 
      ! determine error from symmetry for n0=0 and n1>1, n2>1 
      cerr(r)=cerr(r-1)
      cerr2(r)=cerr2(r-1)
      n0=0
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
 
          if (n1.ge.1.and.n2.ge.1) then
            nn1 = n1
            nn2 = n2-1
            j = 2
         
            ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
            do i=1,2
              smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
            end do
          
            if (nn1.ge.1) then
              smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
            else          
              smod(1) = smod(1) + b_i(n0,nn2,1)
            end if
 
            if (nn2.ge.1) then
              smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
            else
              smod(2) = smod(2) + b_i(n0,nn1,2)
            end if
           
            c_alt(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
 
            cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
            cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
 
          end if
        end do
 
      if(r.ge.2)then
        c00_err(r) = max(abs(m02)*cij_err(r-2), b_err,    &
              azadjff/adetz*cij_err(r-2),             &
              maxzadjf/adetz*max(c00_err(r-1),b_err))
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err(r-2),             &
!              maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
!              C00_err(r)
 
      else
        c00_err(r) = 0d0
      end if
      cij_err(r) = max(maxzadjf*cij_err(r-1),   &
              maxzadj*max(c00_err(r),b_err))/adetz
 
      if(r.ge.2)then
        c00_err2(r) = max(abs(m02)*cij_err(r-2), b_err,    &
              azadjff/adetz*cij_err2(r-2),             &
              maxzadjf/adetz*max(c00_err2(r-1),b_err))
 
!        write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err,    &
!              aZadjff/adetZ*Cij_err(r-2),             &
!              maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
!              C00_err(r)
 
      else
        c00_err2(r) = 0d0
      end if
      cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1),   &
                        max(c00_err2(r),b_err))/sqrt(adetz)
 
!      write(*,*) 'CalcCpv r',r, Cij_err(r),maxZadjf*Cij_err(r-1)/adetZ,  &
!              maxZadj*(C00_err(r))/adetZ,  &          
!              maxZadj*(B_err)/adetZ
 
    end do
 
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    ! PV reduction (5.10)
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
#ifdef Cpvtest
    write(*,*) 'CalcCpv Cerrsym',cerr
    write(*,*) 'CalcCpv Caccsym',cerr/abs(c(0,0,0))
 
    write(*,*) 'CalcCpv Cijerr',cij_err(1:rmax)
    write(*,*) 'CalcCpv Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
#endif
 
    cerr2 = max(cerr2,cij_err2(0:rmax))
    cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cpvtest
    write(*,*) 'CalcCpv Cerr',cerr
    write(*,*) 'CalcCpv Cacc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCpv out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
 
  end subroutine calccpv
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCpv2(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccpv2(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex, allocatable :: C_alt(:,:,:)
    double complex :: C0_coli, elimminf2_coli
!   double complex :: Caux(1:rmax/2+1,0:rmax-1,0:rmax-1), Smod(2)
    double complex :: Caux(1:rmax,0:rmax-1,0:rmax-1), Smod(2)
    double complex :: chdet
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    integer :: rmaxB,r,n0,n1,n2,k
    integer :: bin,nid(0:3)
 
#ifdef Cpv2test
    write(*,*) 'CalcCpv2 in '
#endif
#ifdef TRACECin
    write(*,*) 'CalcCpv2 in '
#endif
 
    ! calculation of scalar coefficient
    c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
    cuv(0,0,0) = 0d0
 
    ! accuracy estimate for C0 function
    cerr(0) = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
    cerr2(0) = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
 
!   write(*,*) 'CalcCpv2: Cerr(0)= ',Cerr(0),Cerr(0)/abs(C(0,0,0)),abs(C(0,0,0))
 
    if (rmax.eq.0) return
 
 
    ! calculation of B-coefficients
    rmaxb = rmax-1
    ! rmaxB = max(rmax-1,0)
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmax+1))
    allocate(cij_err(0:rmax))
    allocate(c00_err2(0:rmax+1))
    allocate(cij_err2(0:rmax))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0 and calculate maximal B(0,...)
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
    b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    
    ! determine inverse modified Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
 
 
    ! calculate Cuv
    call calccuv(cuv,buv_0,mm02,mx(1:2,0),rmax,id)
 
    ! initialization of error propagation
 
!    adetX = abs(chdet(3,mx))
!    maxZadjf=maxval(abs(mxinv(0,1:2)))*adetX
!    maxXadj=maxval(abs(mxinv(1:2,1:2)))*adetX
!    adetZ=abs(mxinv(0,0))*adetX
 
!   write(*,*) 'CalcCpv2 adetX ',adetX,maxZadjf,maxXadj,adetZ
 
    cij_err =0d0
    c00_err =0d0
    cij_err(0) = cerr(0)
    b_err = acc_def_b*b_max
 
    cij_err2 =0d0
    c00_err2 =0d0
    cij_err2(0) = cerr2(0)
 
!    write(*,*) 'CalcCpv: B_err= ',B_err,acc_B,B_max
 
    allocate(c_alt(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
          n2 = r-2*n0-n1
 
          do k=1,2
            smod(k) = -b_0(n0-1,n1,n2)
          end do
 
          if (n1.ge.1) then
            smod(1) = smod(1) - 2*n1*c(n0,n1-1,n2)
          else
            smod(1) = smod(1) + b_i(n0-1,n2,1)
          end if
 
          if (n2.ge.1) then
            smod(2) = smod(2) - 2*n2*c(n0,n1,n2-1)
          else
            smod(2) = smod(2) + b_i(n0-1,n1,2)
          end if
 
          caux(n0,n1,n2) = (c(n0-1,n1,n2) - mxinv(1,0)*smod(1)  &
                             - mxinv(2,0)*smod(2))/mxinv(0,0)
 
        end do
      end do
 
      
      do n0=1,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
 
          c(n0,n1,n2) = (caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2)  &
                         + b_0(n0-1,n1,n2))/r/2d0    
 
        end do
      end do
 
      
 
      ! calculate C and determine error from symmetry for n0=0 and n1>0, n2>0 
      cerr(r)=cerr(r-1)
      cerr2(r)=cerr2(r-1)
 
      do n1=0,r-1
        n2 = r-1-n1
 
        do k=1,2
          smod(k) = -b_0(0,n1,n2)
        end do
 
        if (n1.ge.1) then
          smod(1) = smod(1) - 2*n1*c(1,n1-1,n2)
        else
          smod(1) = smod(1) + b_i(0,n2,1)
        end if
 
        if (n2.ge.1) then
          smod(2) = smod(2) - 2*n2*c(1,n1,n2-1)
        else
          smod(2) = smod(2) + b_i(0,n1,2)
        end if
 
        caux(1,n1,n2) = (c(0,n1,n2) - mxinv(1,0)*smod(1)  &
                           - mxinv(2,0)*smod(2))/mxinv(0,0)
 
        c(0,n1+1,n2) = mxinv(0,1)*caux(1,n1,n2)  &
                       + mxinv(1,1)*smod(1) + mxinv(2,1)*smod(2)
        c_alt(0,n1,n2+1) = mxinv(0,2)*caux(1,n1,n2)  &
                       + mxinv(1,2)*smod(1) + mxinv(2,2)*smod(2)
 
        if(n1.eq.0) then
          c(0,0,r) = c_alt(0,0,r)          
        else
          cerr(r)=max(cerr(r),abs(c(0,n1,n2+1)-c_alt(0,n1,n2+1)))
          cerr2(r)=max(cerr2(r),abs(c(0,n1,n2+1)-c_alt(0,n1,n2+1)))
        end if
 
      end do 
 
      c00_err(r+1) = max(b_err,adetx/adetz*cij_err(r-1),      &
              maxzadjf/adetz*max(b_err,c00_err(r)))/(2*(r+1))
 
!      write(*,*) 'CalcCpv2 00 r',r, B_err,adetX/adetZ*Cij_err(r-1),      &
!              maxZadjf/adetZ*B_err, maxZadjf/adetZ*C00_err(r)
 
      cij_err(r) = max(maxzadjf*max(2*(r+1)*c00_err(r+1),b_err),   &
              maxxadj*max(2*c00_err(r),b_err))/adetx
 
      c00_err2(r+1) = max(b_err,adetx/adetz*cij_err2(r-1),      &
              maxzadjf/adetz*max(b_err,c00_err2(r)))/(2*(r+1))
 
!      write(*,*) 'CalcCpv2 00 r',r, B_err,adetX/adetZ*Cij_err(r-1),      &
!              maxZadjf/adetZ*B_err, maxZadjf/adetZ*C00_err(r)
 
      cij_err2(r) = max(maxzadjf*max(2*(r+1)*c00_err2(r+1),b_err),   &
              maxxadj*max(2*c00_err2(r),b_err))/adetx*(sqrt(adetz)/maxzadj)
 
!      write(*,*) 'CalcCpv2 ij r',r, maxZadjf*C00_err(r+1)/adetX,B_err*maxZadjf/adetX, &
!               maxXadj*C00_err(r)/adetX, maxXadj*B_err/adetX
      
    end do
    
 
    ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
 
#ifdef Cpv2test
! pv1 version might get unstable for some cases!
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
 
          write(*,*) 'C1(n0+1)',n0,n1,n2
          write(*,*) 'C1(n0+1)',(b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
 
        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
          n2 = r-2*n0-n1
 
          do k=1,2
            smod(k) = -b_0(n0-1,n1,n2)
          end do
 
          if (n1.ge.1) then
            smod(1) = smod(1) - 2*n1*c(n0,n1-1,n2)
          else
            smod(1) = smod(1) + b_i(n0-1,n2,1)
          end if
 
          if (n2.ge.1) then
            smod(2) = smod(2) - 2*n2*c(n0,n1,n2-1)
          else
            smod(2) = smod(2) + b_i(n0-1,n1,2)
          end if
 
          caux(n0,n1,n2) = (c(n0-1,n1,n2) - mxinv(1,0)*smod(1)  &
                             - mxinv(2,0)*smod(2))/mxinv(0,0)
 
        end do
      end do
 
      
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
 
          c(n0,n1,n2) = (caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2)  &
                         + b_0(n0-1,n1,n2))/r/2d0    
 
#ifdef Cpv2test
          write(*,*) 'C2(n0+1)',n0,n1,n2
          write(*,*) 'C2(n0+1)',(caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2)  &
                         + b_0(n0-1,n1,n2))/r/2d0
#endif
 
        end do
      end do
 
    end do
 
#ifdef Cpv2test
    write(*,*) 'CalcCpv2 Cerrsym',cerr
    write(*,*) 'CalcCpv2 Caccsym',cerr/abs(c(0,0,0))
 
    write(*,*) 'CalcCpv2 Cijerr',cij_err
    write(*,*) 'CalcCpv2 Cijacc',cij_err/abs(c(0,0,0))
#endif
    
    cerr2 = max(cerr2,cij_err2(0:rmax))
    cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cpv2test
    write(*,*) 'CalcCpv2 Cerr',cerr
    write(*,*) 'CalcCpv2 Cacc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCpv2 out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
 
!    write(*,*) 'CalcCpv2 Cerr ',Cerr
!    write(*,*) 'CalcCpv2 Cerr2',Cerr2
 
  end subroutine calccpv2
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCpvshift(Cshift,Cuvshift,p10shift,p21shift,p20shift,m02shift,m12shift,m22shift,rmax,Cerr,Cerr2)
  !
  !  Based on CalcCpv1
  !  uses shifted momenta and global shifted quantities
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccpvshift(Cshift,Cuvshift,p10shift,p21shift,p20shift,m02shift,m12shift,m22shift,rmax,id,Cerr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,id
    double complex, intent(in) :: p10shift,p21shift,p20shift,m02shift,m12shift,m22shift
    double complex, intent(out) :: Cuvshift(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cshift(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
    double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
    double complex, allocatable :: Cshift_alt(:,:,:)
    double complex :: Smod(2)
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
    integer :: bin,k,nid(0:2)
    logical :: use_cache_system_save
 
#ifdef Cpvshifttest
    write(*,*) 'CalcCpvshift p in ',p10shift,p21shift,p20shift
    write(*,*) 'CalcCpvshift m in ',m02shift,m12shift,m22shift
    write(*,*) 'CalcCpvshift in ',rmax,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCpvshift in ',rmax,id
#endif
 
    ! calculation of scalar coefficient
    cshift(0,0,0) = c0_coli(p10shift,p21shift,p20shift,m02shift,m12shift,m22shift)
    cuvshift(0,0,0) = 0d0
 
    ! accuracy estimate for C0 function
    cerr(0) = acc_def_c0*max(1d0/sqrt(adetzshift),abs(cshift(0,0,0)))   
    cerr2(0) = acc_def_c0*max(1d0/sqrt(adetzshift),abs(cshift(0,0,0)))   
 
    if (rmax.eq.0) return
    
    ! allocation and calculation of B functions
    rmaxb = rmax-1
    ! rmaxB = max(rmax-1,0)
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmax))
    allocate(cij_err(0:rmax))
    allocate(c00_err2(0:rmax))
    allocate(cij_err2(0:rmax))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
!   call CalcB(B_0(:,0,:),Buv_0(:,0,:),p21shift,m12shift,m22shift,rmaxB,nid(0))
!   call CalcB(B_i(:,:,1),Buv_i(:,:,1),p20shift,m02shift,m22shift,rmaxB,nid(1))
!   call CalcB(B_i(:,:,2),Buv_i(:,:,2),p10shift,m02shift,m12shift,rmaxB,nid(2))
    use_cache_system_save = use_cache_system
    use_cache_system = .false.
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21shift,m12shift,m22shift,rmaxb,0)
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20shift,m02shift,m22shift,rmaxb,0)
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10shift,m02shift,m12shift,rmaxb,0)
    use_cache_system = use_cache_system_save
!   call SwitchOnCacheSystem_cll
 
 
    ! shift of integration momentum in B_0 and calculate maximal B(0,...)
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
 
!    write(*,*) 'B_max=',B_max
 
    b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
 
    ! determine inverse Gram matrix
!    Zinvshift = Zadjshift/detZshift
 
    ! calculate Cuv
    call calccuv(cuvshift,buv_0,mm02shift,fshift,rmax,id)
 
    ! initialization of error propagation
    cij_err =0d0
    c00_err =0d0
    cij_err(0) = cerr(0)
    b_err = acc_def_b*b_max
 
    cij_err2 =0d0
    c00_err2 =0d0
    cij_err2(0) = cerr2(0)
 
 
#ifdef Cpvshifttest
!    write(*,*) 'CalcCpvshift: B_err= ',B_err,acc_def_B,B_max
    write(*,*) 'CalcDpvshift Cij_err(0)=',cij_err(0)
!    write(*,*) 'CalcCpvshift test :', & 
!            (1d0 - (Zadjf(1)+Zadjf(2))/detZshift), &
!            (detZmZadjf + Zadjs(1)*(mm12shift-mm02shift) + Zadjs(2)*(mm22shift-mm02shift)) /detZshift
#endif
 
    allocate(cshift_alt(0:rmax,0:rmax,0:rmax))
 
    ! PV reduction
    do r=1,rmax
 
    ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          cshift(n0,n1,n2) = + 4*cuvshift(n0,n1,n2) + detxshift/detzshift*cshift(n0-1,n1,n2)
            cshift(n0,n1,n2) = cshift(n0,n1,n2) &
                + (detzmzadjfshift + zadjsshift(1)*(mm12shift-mm02shift) + zadjsshift(2)*(mm22shift-mm02shift) &
                  ) /detzshift * b_0(n0-1,n1,n2)
!                + (1d0 - (Zadjfshift(1)+Zadjfshift(2))/detZshift)* B_0(n0-1,n1,n2)
 
            if (n1.ge.1) then
              cshift(n0,n1,n2) = cshift(n0,n1,n2) &
                  - 2*n1*zadjfshift(1)/detzshift*cshift(n0,n1-1,n2)
            else            
              cshift(n0,n1,n2) = cshift(n0,n1,n2) &
                  + zadjfshift(1)/detzshift* b_i(n0-1,n2,1)
            end if
            if (n2.ge.1) then
              cshift(n0,n1,n2) = cshift(n0,n1,n2) &
                  - 2*n2*zadjfshift(2)/detzshift*cshift(n0,n1,n2-1)
            else            
              cshift(n0,n1,n2) = cshift(n0,n1,n2) &
                  + zadjfshift(2)/detzshift * b_i(n0-1,n1,2)
            end if
 
            cshift(n0,n1,n2) = cshift(n0,n1,n2)  / (2*r) 
 
!        if(n0.eq.1) then
!          write(*,*) 'Cas(1,n1,n2)=',n1,n2, 4*Cuvshift(n0,n1,n2) + detXshift/detZshift*Cshift(n0-1,n1,n2)
!          write(*,*) 'Cas(1,n1,n2)=', (detZmZadjfshift + Zadjsshift(1)*(mm12shift-mm02shift) + Zadjsshift(2)*(mm22shift-mm02shift) &
!                  ) /detZshift * B_0(n0-1,n1,n2)
!          write(*,*) 'Cas(1,n1,n2)=', detZmZadjfshift,Zadjsshift(1)*(mm12shift-mm02shift),Zadjsshift(2)*(mm22shift-mm02shift) &
!                  ,detZshift ,B_0(n0-1,n1,n2)
!          write(*,*) 'Cas(1,n1,n2)=', (1d0 - (Zadjfshift(1)+Zadjfshift(2))/detZshift)* B_0(n0-1,n1,n2)
!          write(*,*) 'Cas(1,n1,n2)=',  + Zadjfshift(1)/detZshift* B_i(n0-1,n2,1)
!          write(*,*) 'Cas(1,n1,n2)=',   + Zadjfshift(2)/detZshift * B_i(n0-1,n1,2)
!        end if
 
         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
          n2 = r-2*n0-n1
 
          if (n1.ge.1) then
            nn1 = n1-1
            nn2 = n2
            j = 1
          else
            nn1 = n1
            nn2 = n2-1
            j = 2
          end if
         
!          do i=1,2
!            Smod(i) = -B_0(n0,nn1,nn2)
!          end do
          smod = 0d0
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*cshift(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*cshift(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
          
          cshift(n0,n1,n2) = (zadjshift(1,j)*smod(1) + zadjshift(2,j)*smod(2)  &
                           - zadjsshift(j)*b_0(n0,nn1,nn2) &
                           - zadjfshift(j)*cshift(n0,nn1,nn2))/detzshift
 
!          if(n0.eq.0) then
!            write(*,*) 'Cas(0,n1,n2)=',n1,n2,Cshift(0,n1,n2),nn1,nn2,j
!            write(*,*) 'Cas(0,n1,n2)=',Zadjshift(1,j),Smod(1),Zadjshift(2,j),Smod(2)
!            write(*,*) 'Cas(0,n1,n2)=',Zadjsshift(j),B_0(n0,nn1,nn2),Zadjfshift(j),Cshift(n0,nn1,nn2)
!            write(*,*) 'Cas(0,n1,n2)=',Zadjshift(1,j)*Smod(1),Zadjshift(2,j)*Smod(2)
!            write(*,*) 'Cas(0,n1,n2)=',-Zadjsshift(j)*B_0(n0,nn1,nn2),-Zadjfshift(j)*Cshift(n0,nn1,nn2)
!          end if
          
        end do
!      end do
 
      ! determine error from symmetry for n0=0 and n1>=1, n2>=1 
      cerr(r)=cerr(r-1)
      cerr2(r)=cerr2(r-1)
      n0=0
        do n1=1,r-2*n0-1
          n2 = r-2*n0-n1
 
          nn1 = n1
          nn2 = n2-1
          j = 2
         
!          do i=1,2
!            Smod(i) = -B_0(n0,nn1,nn2)
!          end do
          smod = 0
          
          if (nn1.ge.1) then
            smod(1) = smod(1) - 2d0*nn1*cshift(n0+1,nn1-1,nn2)
          else          
            smod(1) = smod(1) + b_i(n0,nn2,1)
          end if
 
          if (nn2.ge.1) then
            smod(2) = smod(2) - 2d0*nn2*cshift(n0+1,nn1,nn2-1)
          else
            smod(2) = smod(2) + b_i(n0,nn1,2)
          end if
           
          cshift_alt(n0,n1,n2) = (zadjshift(1,j)*smod(1) + zadjshift(2,j)*smod(2)  &
                           - zadjsshift(j)*b_0(n0,nn1,nn2) &
                           - zadjfshift(j)*cshift(n0,nn1,nn2))/detzshift
 
          cerr(r)=max(cerr(r),abs(cshift(n0,n1,n2)-cshift_alt(n0,n1,n2)))
          cerr2(r)=max(cerr2(r),abs(cshift(n0,n1,n2)-cshift_alt(n0,n1,n2)))
 
!          if(n0.eq.0) then
!            write(*,*) 'Cbs(0,n1,n2)=',n1,n2,Cshift_alt(0,n1,n2),nn1,nn2,j
!            write(*,*) 'Cbs(0,n1,n2)=',Zadjshift(1,j),Smod(1),Zadjshift(2,j),Smod(2)
!            write(*,*) 'Cbs(0,n1,n2)=',Zadjsshift(j),B_0(n0,nn1,nn2),Zadjfshift(j),Cshift(n0,nn1,nn2)
!          end if
!            write(*,*) 'CalcCpvshift Cerr',n0,n1,n2, Cerr(r), abs(Cshift(n0,n1,n2)),abs(Cshift_alt(n0,n1,n2))
 
        end do
 
      if(r.ge.2)then
! estimate using insertions of (5.11) in (5.10)
        c00_err(r) = max(2*abs(m02shift)*cij_err(r-2), b_err,    &
              azadjffshift/adetzshift*cij_err(r-2),             &
              maxzadjfshift/adetzshift*max(2*c00_err(r-1),b_err))/(2*r)
 
      else
        c00_err(r) = 0d0
      end if
! estimate using insertions of (5.10) in (5.11)
      cij_err(r) = max(maxzadjfshift*cij_err(r-1),   &
              maxzadjshift*max(2*c00_err(r),b_err))/adetzshift
 
      if(r.ge.2)then
        c00_err2(r) = max(2*abs(m02shift)*cij_err2(r-2), b_err,    &
              azadjffshift/adetzshift*cij_err2(r-2),             &
              maxzadjfshift/adetzshift*max(2*c00_err(r-1),b_err))/(2*r)
 
      else
        c00_err2(r) = 0d0
      end if
      cij_err2(r) = max((maxzadjfshift/maxzadjshift)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetzshift)
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          cshift(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02shift*cshift(n0-1,n1,n2) + 4*cuvshift(n0,n1,n2) &
                        + fshift(1)*cshift(n0-1,n1+1,n2) + fshift(2)*cshift(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
 
#ifdef Cpvshifttest
    write(*,*) 'CalcCpvshift Cerrsym',cerr
    write(*,*) 'CalcCpvshift Caccsym',cerr/abs(cshift(0,0,0))
 
    write(*,*) 'CalcCpvshift Cijerr',cij_err(1:rmax)
    write(*,*) 'CalcCpvshift Cijacc',cij_err(1:rmax)/abs(cshift(0,0,0))
#endif
 
    cerr2 = max(cerr2,cij_err2(0:rmax))
    cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cpvshifttest
    write(*,*) 'CalcCpvshift Cerr',cerr
    write(*,*) 'CalcCpvshift Cacc',cerr/abs(cshift(0,0,0))
!    write(*,*) 'CalcCpvshift Cerr2',Cerr2
#endif
 
 
 
#ifdef Cpvshifttest
    write(*,*) 'CalcCpvshift C',cshift(0,0,0)
    write(*,*) 'CalcCpvshift C1',cshift(0,1,0)
    write(*,*) 'CalcCpvshift C2',cshift(0,0,1)
    write(*,*) 'CalcCpvshift C11',cshift(0,2,0)
    write(*,*) 'CalcCpvshift C12',cshift(0,1,1)
    write(*,*) 'CalcCpvshift C22',cshift(0,0,2)
#endif
 
  end subroutine calccpvshift
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !   Version derived from CalcDg     AD 28.11.2014
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgn(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccgn(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
 
    integer, intent(in) :: rmax,ordg_min,ordg_max,id
    double complex, intent(in) ::  p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex :: Xtilde,Zkl,Zadjfj,Zadj2,Zadjkl
    double complex, allocatable :: Cexpg(:,:,:,:), CuvExpg(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex :: Smod(2), Skl, CexpgAux
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    double precision :: maxCexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,i,j,m,n,sgn,g,rg
    integer :: inds0(2), inds(2), inds2(2), ktlt(2)
    integer :: bin,nid(0:2)
 
    double complex, allocatable :: D_alt(:,:,:,:)
 
#ifdef Cgntest
    write(*,*) 'CalcCgn in ',rmax,ordg_min,ordg_max
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgn in ',rmax,ordg_min,ordg_max
#endif
 
    ! allocation of B functions
    rmaxb = rmax + ordg_min
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
    
 
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
    ! error estimate for B's
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_max
 
 
    ! determine (adjugated) Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
 
!    if (abs(detZ/( 4d0*q10*q20 + q1q2*q1q2)).lt.1d-4) then
!      if (abs(q10-q20).lt.abs(q10-q21).and.  &
!          abs(q10-q20).lt.abs(q20-q21)) then
!        detZ  =  4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
!      end if
!    end if
 
!   write(*,*) 'Z = ',Z
 
!    Zadj(1,1) = 2d0*q20
!    Zadj(2,1) = -q1q2
!    Zadj(1,2) = -q1q2
!    Zadj(2,2) = 2d0*q10
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
 
!    maxZadj=maxval(abs(Zadj))
!    fmax   =maxval(abs(f))
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.abs(zadjf(2))) then
      j = 1
    else 
      j = 2
    end if
 
    maxzadj = 0d0                 ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
                                  ! Zadj2(n,m) ==  Zadf2(k,n,l,m)
    if (abs(zadj(1,1)).gt.maxzadj) then
      maxzadj = abs(zadj(1,1))
      k = 1
      l = 1
      inds2 = (/2,2/)
      zadj2 = -1d0
    end if
    if (abs(zadj(1,2)).gt.maxzadj) then
      maxzadj = abs(zadj(1,2))
      k = 1
      l = 2
      inds2 = (/2,1/)
      zadj2 =  1d0
    end if
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
    xtilde = xadj(k,l)
 
!    write(*,*) 'CalcCgn Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpg(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordg_max))
 
    ! calculate Cuv
    allocate(cuvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpg,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpg(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
     
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
#ifdef Cgntest
    write(*,*) 'CalcCgn rmax = ',rmax,rmaxexp
    write(*,*) 'CalcCgn Cij_err = ',cij_err 
    write(*,*) 'CalcCgn B0 = ', b_0(0,0,0),b_i(0,0,1),b_i(0,0,2)
#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) * truncfacc
    gtrunc = ordg_max 
 
! calculate C(n0,n1,n2) up to rank r for n0>0 and up to rank r-1 for n0=0
    rloop: do r=1,rmaxexp
 
#ifdef Cgntest
!      write(*,*) 'CalcCgn rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
#ifdef Cgntest
      write(*,*) 'CalcCgn rloop',r
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
      ! exploiting eq. (5.40)
      maxcexpg(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2=r-2*n0-n1
 
          inds0(1) = n1
          inds0(2) = n2
          
          cexpgaux = 2d0*zadj(k,l)*b_0(n0-1,n1,n2)  & 
              + xtilde*cexpg(n0-1,n1,n2,0)  &
              + 4d0*zadj(k,l)*cuvexpg(n0,n1,n2)
          
          inds = inds0
          inds(k) = inds(k)+1
          do i=1,2
            cexpgaux = cexpgaux + zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
          end do
          
          do i=1,2
            inds = inds0
            inds(i) = inds(i)+1
            cexpgaux = cexpgaux - zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
          end do
          
          n = inds2(1)
          m = inds2(2)
          
          skl = f(n)*shat(n0-1,inds0(1),inds0(2),m)
          
          inds = inds0
          if (inds(m).ge.1) then
            inds(m) = inds(m)-1
            skl = skl - 2d0*f(n)*inds0(m)*cexpg(n0,inds(1),inds(2),0)
            if (inds(n).ge.1) then
              inds(n) = inds(n)-1
              skl = skl - 4d0*inds0(m)*(inds(n)+1)*cexpg(n0+1,inds(1),inds(2),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),m)  &
                - 2d0*f(m)*inds0(n)*cexpg(n0,inds(1),inds(2),0)
          end if
          
          cexpgaux = cexpgaux - zadj2*skl
          
          cexpg(n0,n1,n2,0) = cexpgaux/(2d0*zadjkl)/(2d0*(r-n0)+1)
          
          if (n0.eq.1) then
            maxcexpg(1,r,0) =  maxcexpg(1,r,0) + abs(cexpg(n0,n1,n2,0) )
          end if
          
          if (r-n0.le.rmax) then
            c(n0,n1,n2) = cexpg(n0,n1,n2,0)
          end if
 
        end do
      end do
 
      ! calculate
      ! C_00ijkl.. --> C_aijkl..
      ! exploiting eq. (5.38)
      maxcexpg(0,r-1,0)=0d0
      do n1=0,r-1
        n2=r-1-n1
 
          smod = shat(0,n1,n2,:)
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,0)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,0)
          end if
 
          cexpg(0,n1,n2,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2))/zadjfj
          maxcexpg(0,r-1,0) =  maxcexpg(0,r-1,0) + abs(cexpg(0,n1,n2,0))
          if (r-n0.le.rmax+1) then
            c(0,n1,n2) = cexpg(0,n1,n2,0)
          end if
 
#ifdef Cgntest
!          if(n0.eq.0.and.n1.eq.0.and.n2.eq.3) then 
!            write(*,*) 'C2(0,0,3,0)= ',0,C(n0,n1,n2)
!          end if
#endif
 
      end do
 
#ifdef Cgntest
!      write(*,*) 'CalcCgn maxCexpg 0',r-1, maxCexpg(0,r-1,0)
#endif
 
      if(r.le.rmax+1) then
!       Cerr(r-1) =  abs(detZ/Zadjfj)*maxCexpg(0,r-1,0)
        cerr(r-1) =  fac_g*maxcexpg(0,r-1,0)
      end if
 
      ! error propagation from B's
      c00_err(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zadjkl),b_err)  &
                   /(2*(2*r-1))        
      cij_err(r-1)=maxzadj*max(b_err,2*c00_err(r))/abs(zadjfj)
 
      c00_err2(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zadjkl),b_err)  &
                   /(2*(2*r-1))        
      cij_err2(r-1)=maxzadj*max(b_err,2*c00_err2(r))/abs(zadjfj)
 
#ifdef Cgntest
      write(*,*) 'CalcCgn C00_err',r,  maxzadj,fmax,abs(zadjkl),b_err,abs(zadjfj)
      write(*,*) 'CalcCgn C00_err',r,  c00_err(r), cij_err(r-1)
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
 
!        write(*,*) 'gloop ',g,rg
 
        ! calculating
        ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
        ! exploiting eq. (5.40)
        maxcexpg(1,rg,g) = 0d0
        do n0=rg/2,1,-1
          do n1=0,rg-2*n0
            n2=rg-2*n0-n1
 
            inds0(1) = n1
            inds0(2) = n2
            
            inds = inds0
            inds(k) = inds(k)+1
            inds(l) = inds(l)+1
            cexpgaux = xtilde*cexpg(n0-1,n1,n2,g)  &
                - detz*cexpg(n0-1,inds(1),inds(2),g-1)
            
            
            n = inds2(1)
            m = inds2(2)
            
            skl = 0d0
            
            inds = inds0
            if (inds(m).ge.1) then
              inds(m) = inds(m)-1
              skl = skl - 2d0*f(n)*inds0(m)*cexpg(n0,inds(1),inds(2),g)
              if (inds(n).ge.1) then
                inds(n) = inds(n)-1
                skl = skl - 4d0*inds0(m)*(inds(n)+1)*cexpg(n0+1,inds(1),inds(2),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)*cexpg(n0,inds(1),inds(2),g)
            end if
            
            cexpgaux = cexpgaux - zadj2*skl
            
            cexpg(n0,n1,n2,g) = cexpgaux/(2d0*zadjkl)/(2d0*(rg-n0)+1)
            
            
            if(n0.eq.1) then
              maxcexpg(1,rg,g) =  maxcexpg(1,rg,g) + abs(cexpg(n0,n1,n2,g))
              
              if (g.eq.1.and.abs(cexpg(n0,n1,n2,g)).gt.          & 
                  truncfacexp*max(1d0,maxcexpg(1,rg,g-1)) .or.   &
                  g.ge.2.and.abs(cexpg(n0,n1,n2,g)).gt.          &
                  truncfacexp*maxcexpg(1,rg,g-1)) then
 
#ifdef Cgntest
                write(*,*) 'CalcCgn exit gloop',n0,n1,n2,g,abs(cexpg(n0,n1,n2,g)),maxcexpg(1,rg,g-1),truncfacexp
#endif      
                
                gtrunc = g-1
                exit gloop
              end if
            end if
            
          end do
        end do
 
#ifndef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
            end do
          end if
        end do
#endif
!        write(*,*) 'CalcCgn after it1 ',rg
 
        ! calculate
        ! C_00ijkl.. --> C_aijkl..
        ! exploiting eq. (5.38)
 
!        write(*,*) 'CalcCgn maxCexp',rg-1,g-1,maxCexpg(0,rg-1,g-1)
 
        maxcexpg(0,rg-1,g) = 0d0
        do n1=0,rg-1
          n2=rg-1-n1
 
          smod = 0d0
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,g)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,g)
          end if
          
          inds(1) = n1
          inds(2) = n2
          inds(j) = inds(j)+1
          cexpg(0,n1,n2,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
              - detz*cexpg(0,inds(1),inds(2),g-1))/zadjfj
          
          maxcexpg(0,rg-1,g) =  maxcexpg(0,rg-1,g) + abs(cexpg(0,n1,n2,g))
          
!              if(n1.eq.0.and.n2.eq.1) then 
!                write(*,*) 'C2(2,3)= ',g,Cexpg(0,n1,n2,g)
!                write(*,*) 'C2(2,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                - detZ*Cexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
!                write(*,*) 'C2(2,3)= ',inds(1),inds(2),         &
!                                - detZ/Zadjfj,Cexpg(0,inds(1),inds(2),g-1)
!              end if
          
          if (g.eq.1.and.abs(cexpg(0,n1,n2,g)).gt.                     &
              truncfacexp*max(1/m2max,maxcexpg(0,rg-1,g-1))    .or.    &
              g.ge.2.and.abs(cexpg(0,n1,n2,g)).gt.                     &
              truncfacexp*maxcexpg(0,rg-1,g-1)) then
            
#ifdef Cgntest
            write(*,*) 'CalcCgn exit gloop',0,n1,n2,g,abs(cexpg(0,n1,n2,g)),maxcexpg(0,rg-1,g-1),truncfacexp
#endif      
            gtrunc = g-1
            exit gloop
          end if
 
        end do
 
        ! error propagation from B's
        if(rg.gt.1)then
          c00_err(rg) = max(c00_err(rg),                    &
              max( abs(m02)*cij_err(rg-2),                             &
              max(adetz*cij_err(rg),fmax**2*cij_err(rg-2),fmax*c00_err(rg-1))/abs(zadjkl) ) &
                   /(2*(2*rg-1))     )   
        end if
        cij_err(rg-1) = max(cij_err(rg-1),max(2*maxzadj*c00_err(rg),adetz*cij_err(rg))/abs(zadjfj) ) 
 
        if(rg.gt.1)then
          c00_err2(rg) = max(c00_err2(rg),                    &
              max( abs(m02)*cij_err2(rg-2),                             &
              max(adetz*cij_err2(rg),fmax**2*cij_err2(rg-2),fmax*c00_err2(rg-1))/abs(zadjkl) ) &
                   /(2*(2*rg-1))     )   
        end if
        cij_err2(rg-1) = max(cij_err2(rg-1),max(2*maxzadj*c00_err2(rg),adetz*cij_err2(rg))/abs(zadjfj) ) 
 
!      write(*,*) 'CalcCg g: ',r,adetZ/abs(Zadjfj),C00_err(rg),B_err
!      write(*,*) 'CalcCg g: Cij_err=',rg-1,Cij_err(rg-1)
 
#ifdef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
            end do
          end if
        end do
#endif
 
!        write(*,*) 'CalcCgn after it1 ',rg
        if ((rg.le.rmax+1)) then
          cerr(rg-1) = 0d0
          do n1=0,rg-1
            n2 = rg-1-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpg(0,n1,n2,g)
            if(abs(cexpg(0,n1,n2,g-1)).ne.0d0) then
!             Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)))
              cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g))*min(1d0,abs(cexpg(0,n1,n2,g))/abs(cexpg(0,n1,n2,g-1))))
            else
              cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g)))
            end if
 
!             write(*,*) 'CalcCg err',r,rg,n1,n2,Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)) &
!                     ,abs(Cexpg(0,n1,n2,g)),abs(Cexpg(0,n1,n2,g-1))
 
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg-1).gt.cerr(rg-1)) then
             gtrunc = min(g,gtrunc)
             
#ifdef Cgtest
             write(*,*) 'CalcCgn exit err',r,g,gtrunc  &
             ,cij_err(rg-1),cerr(rg-1)
#endif
 
          end if
        end if
 
      end do gloop
 
#ifdef Cgntest
      write(*,*) 'CalcCgn C(0,0,0) = ',r,c(0,0,0)
    if(r.gt.1)then
      write(*,*) 'CalcCgn C(1,0,0) = ',r,c(1,0,0)
      write(*,*) 'CalcCgn C(0,1,0) = ',r,c(0,1,0)
      write(*,*) 'CalcCgn C(0,0,1) = ',r,c(0,0,1)
    end if
    if(r.gt.2.and.rmax.ge.2)then
      write(*,*) 'CalcCgn C(0,2,0) = ',r,c(0,2,0)
!      write(*,*) 'CalcCgn C(0,1,1) = ',r,C(0,1,1)
      write(*,*) 'CalcCgn C(0,0,2) = ',r,c(0,0,2)
    end if
    if(r.gt.3.and.rmax.ge.3)then
      write(*,*) 'CalcCgn C(1,0,1) = ',r,c(1,0,1)
      write(*,*) 'CalcCgn C(1,1,0) = ',r,c(1,1,0)
      write(*,*) 'CalcCgn C(1,0,1) = ',r,c(1,0,1)
!      write(*,*) 'CalcCgn C(1,2,0) = ',r,C(1,2,0)
      write(*,*) 'CalcCgn C(0,3,0) = ',r,c(0,3,0)
      write(*,*) 'CalcCgn C(0,2,1) = ',r,c(0,2,1)
      write(*,*) 'CalcCgn C(0,0,3) = ',r,c(0,0,3)
    end if
      write(*,*) 'CalcCgn Cij_err',r,cij_err
      write(*,*) 'CalcCgn Cij_acc',r,cij_err/abs(c(0,0,0))
 
      write(*,*) 'CalcCgn err',r,cerr
      write(*,*) 'CalcCgn acc',r,cerr/abs(c(0,0,0))
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgntest
!      write(*,*) 'CalcCgn exit r',r,maxval(Cerr),acc_req_C*abs(C(0,0,0))
#endif
 
!      if(maxval(Cerr).le.acc_req_C*abs(C(0,0,0))) exit       ! changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
 
!          write(*,*) 'CalcCgn exit rloop  =',rg,r,rmax
 
          do n0=0,rg/2
            do n1=0,rg-2*n0
              c(n0,n1,rg-2*n0-n1)=0d0
            end do
          end do
        end do
        if(r.le.rmax) then
          do n1=0,r
            c(0,n1,r-n1)=0d0
          end do
        end if
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
#endif
       exit rloop
      end if
 
    end do rloop
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
 
#ifdef Cgntest
!    write(*,*) 'CalcCgn C(0,0,0,0) = ',C(0,0,0)
!    if(rmax.ge.3)then
!      write(*,*) 'CalcCgn C(0,1,1,1) = ',C(0,1,1)
!    end if
 
    write(*,*) 'CalcCgn final err',cerr
    write(*,*) 'CalcCgn final acc',cerr/abs(c(0,0,0))
#endif      
                           
!   write(*,*) 'CalcCgn out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
#ifdef TRACECout
    write(*,*) 'CalcCgn rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgn out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!    write(*,*) 'CalcCgn Cerr ',Cerr
!    write(*,*) 'CalcCgn Cerr2',Cerr2
 
  end subroutine calccgn
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCg(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccg(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,ordg_min,ordg_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex :: Xtilde,Zkl,Zadjfj
    double complex, allocatable :: Cexpg(:,:,:,:), CuvExpg(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex :: Smod(2), Skl
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    double precision :: maxCexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,j,sgn,g,rg,mr
    integer :: inds0(2), inds(2), ktlt(2)
    integer :: bin,nid(0:2)
 
#ifdef Cgtest
    write(*,*) 'CalcCg in ',rmax,ordg_min,ordg_max,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCg in ',rmax,ordg_min,ordg_max,id
!   write(*,*) 'CalcCg in acc',acc_req_Cr
#endif
 
    ! write(*,*) 'LH: CalcCg, ord', ordg_min 
    ! calculation B-coefficients
    rmaxb = rmax + ordg_min
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
    ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
      end do
    end do
    ! error estimate for B's
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_max
    
    ! determine (adjugated) Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
 
!    if (abs(detZ/( 4d0*q10*q20 + q1q2*q1q2)).lt.1d-4) then
!      if (abs(q10-q20).lt.abs(q10-q21).and.  &
!          abs(q10-q20).lt.abs(q20-q21)) then
!        detZ  =  4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
!      end if
!    end if
 
!   write(*,*) 'Z = ',Z
 
!    Zadj(1,1) = 2d0*q20
!    Zadj(2,1) = -q1q2
!    Zadj(1,2) = -q1q2
!    Zadj(2,2) = 2d0*q10
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
 
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
 
!    commented out 2.9.2017
!    maxZadj=maxval(abs(Zadj))
!    fmax   =maxval(abs(f))
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.abs(zadjf(2))) then
      j = 1
    else 
      j = 2
    end if
 
    if (abs(z(1,1)).ge.abs(z(2,2))) then
      if (abs(z(1,1)).ge.abs(z(1,2))) then
        k = 1
        l = 1
        sgn = 1
        ktlt = (/ 0,2 /)
      else
        k = 1
        l = 2
        sgn = -1
        ktlt = (/ 1,1 /)
      end if
    else        
      if (abs(z(2,2)).ge.abs(z(1,2))) then
        k = 2
        l = 2
        sgn = 1
        ktlt = (/ 2,0 /)
      else 
        k = 1
        l = 2
        sgn = -1
        ktlt = (/ 1,1 /)
      end if
    end if
 
    zadjfj = zadjf(j)
    zkl = z(k,l)
    if(k.eq.l) then
      xtilde = xadj(3-k,3-l)      ! subroutine uses Z instead of Zadj
    else                          ! -> exchange indices 1 and 2
      xtilde = -xadj(3-k,3-l)     ! -> minus sign for k \ne l
    end if
 
!   write(*,*) 'CalcCg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
 
!   write(*,*) 'Xtilde =',Xtilde,k,l
 
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpg(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordg_max))
   
 
    ! calculate Cuv
    allocate(cuvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpg,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpg(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
    
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err = 0d0
    c00_err = 0d0
 
    cerr2 = acc_inf
    cij_err2 = 0d0
    c00_err2 = 0d0
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(abs(detZ/Zadjfj)) * truncfacC
    truncfacexp = sqrt(fac_g) * truncfacc
    gtrunc = ordg_max 
 
! calculate C(n0,n1,n2) 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
 
!     write(*,*) 'CalcCg rloop',r,rmaxExp,gtrunc
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
      ! exploiting eq. (5.40)
      maxcexpg(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2=r-2*n0-n1
 
          inds0(1) = n1
          inds0(2) = n2
          skl = 0d0
          inds = inds0
          if (inds(k).ge.1) then
            inds(k) = inds(k)-1
            skl = skl - 2d0*f(l)*inds0(k)*cexpg(n0,inds(1),inds(2),0)
            if (inds(l).ge.1) then
              inds(l) = inds(l)-1
              skl = skl - 4d0*inds0(k)*(inds(l)+1)*cexpg(n0+1,inds(1),inds(2),0)
            end if
          end if
          inds = inds0
          if (inds(l).ge.1) then
            inds(l) = inds(l)-1
            skl = skl + 2d0*inds0(l)*shat(n0,inds(1),inds(2),k)  &
                      - 2d0*f(k)*inds0(l)*cexpg(n0,inds(1),inds(2),0)
          end if
 
          cexpg(n0,n1,n2,0) = (2d0*zkl*b_0(n0-1,n1,n2) + xtilde*cexpg(n0-1,n1,n2,0)  &
                                 - z(1,k)*shat(n0-1,n1+1,n2,l) - z(2,k)*shat(n0-1,n1,n2+1,l)  &
                                 + f(l)*shat(n0-1,n1,n2,k) + 4d0*zkl*cuvexpg(n0,n1,n2) + skl)  &
                                 /(2d0*zkl)/(2d0*(r-n0)+1d0)
 
          if (n0.eq.1) then
            maxcexpg(1,r,0) =  maxcexpg(1,r,0) + abs(cexpg(n0,n1,n2,0))
          end if
 
          if (r-n0.le.rmax) then
            c(n0,n1,n2) = cexpg(n0,n1,n2,0)
          end if
 
        end do
      end do
 
      ! calculate
      ! C_00ijkl.. --> C_aijkl..
      ! exploiting eq. (5.38)
      maxcexpg(0,r-1,0)=0d0
      do n1=0,r-1
        n2 = r-1-n1
 
        smod = shat(0,n1,n2,:)
        if (n1.ge.1) then
          smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,0)
        end if
        if (n2.ge.1) then
          smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,0)
        end if
 
        cexpg(0,n1,n2,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2))/zadjfj
        
        maxcexpg(0,r-1,0) =  maxcexpg(0,r-1,0) + abs(cexpg(0,n1,n2,0))
        if (r-n0.le.rmax+1) then
          c(0,n1,n2) = cexpg(0,n1,n2,0)
        end if
 
      end do
 
      if(r.le.rmax+1) then
!       Cerr(r-1) =  abs(detZ/Zadjfj)*maxCexpg(0,r-1,0)
        cerr(r-1) =  fac_g*maxcexpg(0,r-1,0)
      end if
 
      ! error propagation from B's
      c00_err(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zkl),b_err)  &
                   /(2*(2*r-1))        
      cij_err(r-1)=maxzadj*max(b_err,2*c00_err(r))/abs(zadjfj)
 
      c00_err2(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zkl),b_err)  &
                   /(2*(2*r-1))        
      cij_err2(r-1)=maxzadj*max(b_err,2*c00_err2(r))/abs(zadjfj)
 
!      write(*,*) 'CalcCg after 0: ',maxZadj/abs(Zadjfj),C00_err(r),B_err
!      write(*,*) 'CalcCg after 0: Cij_err=',r-1,Cij_err(r-1)
 
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
!       write(*,*) 'CalcCg gloop',g,rg
 
        ! calculating for rank=rmaxB+1
        ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
        ! exploiting eq. (5.40)
        maxcexpg(1,rg,g) = 0d0
        do n0=rg/2,1,-1
          do n1=0,rg-2*n0
            n2=rg-2*n0-n1
 
            inds0(1) = n1
            inds0(2) = n2
            skl = 0d0
            inds = inds0
            if (inds(k).ge.1) then
              inds(k) = inds(k)-1
              skl = skl - 2d0*f(l)*inds0(k)*cexpg(n0,inds(1),inds(2),g)
              if (inds(l).ge.1) then
                inds(l) = inds(l)-1
                skl = skl - 4d0*inds0(k)*(inds(l)+1)*cexpg(n0+1,inds(1),inds(2),g)
              end if
              inds = inds0
            end if
            if (inds(l).ge.1) then
              inds(l) = inds(l)-1
              skl = skl - 2d0*f(k)*inds0(l)*cexpg(n0,inds(1),inds(2),g)
            end if
         
            inds = inds0 + ktlt
            cexpg(n0,n1,n2,g) = (xtilde*cexpg(n0-1,n1,n2,g) + skl  &
                                   - detz*sgn*cexpg(n0-1,inds(1),inds(2),g-1))  &
                                     /(2d0*zkl)/(2d0*(rg-n0)+1d0)           
            if(n0.eq.1) then
              maxcexpg(1,rg,g) =  maxcexpg(1,rg,g) + abs(cexpg(n0,n1,n2,g))
              
              if (g.eq.1.and.abs(cexpg(n0,n1,n2,g)).gt.        &
                  truncfacexp*max(1d0,maxcexpg(1,rg,g-1)).or.  &
                  g.ge.2.and.abs(cexpg(n0,n1,n2,g)).gt.        &  
                  truncfacexp*maxcexpg(1,rg,g-1)) then
 
#ifdef Cgtest
                write(*,*) 'CalcCg exit gloop',n0,n1,n2,g,abs(cexpg(n0,n1,n2,g)),maxcexpg(1,rg,g-1)
#endif
!               write(*,*) 'CalcCg exit gloop',n0,n1,n2,g,abs(Cexpg(n0,n1,n2,g)),maxCexpg(1,rg,g-1)
 
                gtrunc = g-1
                exit gloop
              end if
            end if
          end do
        end do
 
!        write(*,*) 'Calcg: rg,g,acc',rg,g,acc
 
#ifndef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
            end do
          end if
        end do
#endif
 
        ! calculate
        ! C_000000..00 --> C_i0000..00 --> C_ij00..00 --> ... --> C_ijk..
        ! exploiting eq. (5.38)
        maxcexpg(0,rg-1,g) = 0d0
        do n1=0,rg-1
          n2 = rg-1-n1
          
          smod = 0d0
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,g)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,g)
          end if
          
          inds(1) = n1
          inds(2) = n2
          inds(j) = inds(j)+1
          
          cexpg(0,n1,n2,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
              - detz*cexpg(0,inds(1),inds(2),g-1))/zadjfj
          
          maxcexpg(0,rg-1,g) =  maxcexpg(0,rg-1,g) + abs(cexpg(0,n1,n2,g))
 
          if (g.eq.1.and.abs(cexpg(0,n1,n2,g)).gt.                     &
              truncfacexp*max(1/m2max,maxcexpg(0,rg-1,g-1))    .or.    &
              g.ge.2.and.abs(cexpg(0,n1,n2,g)).gt.                     &
              truncfacexp*maxcexpg(0,rg-1,g-1)) then
 
#ifdef Cgtest
            write(*,*) 'CalcCg exit gloop',0,n1,n2,g,abs(cexpg(0,n1,n2,g)),maxcexpg(0,rg-1,g-1)
            write(*,*) 'CalcCg exit gloop',abs(cexpg(0,n1,n2,g)).gt.truncfacexp*maxcexpg(0,rg-1,g-1),truncfacexp
            write(*,*) 'CalcCg exit gloop',zadj(1,j)*smod(1)/zadjfj ,  zadj(2,j)*smod(2)/zadjfj,  &
                - detz*cexpg(0,inds(1),inds(2),g-1)/zadjfj
#endif
            
            gtrunc = g-1
 
#ifdef Cgtest
            write(*,*) 'CalcCg exit gloop',rmax,g,rmaxexp
#endif
!           write(*,*) 'CalcCg exit gloop',rmax,g,rmaxExp
 
            exit gloop
          end if
 
        end do
 
        ! error propagation from B's
        if(rg.gt.1)then
!          C00_err(rg) = max(C00_err(rg),                    &
!              max( abs(m02)*Cij_err(rg-2),             &     
!              max(adetZ*Cij_err(rg),fmax**2*Cij_err(rg-2),fmax*C00_err(rg-1))/abs(Zkl) ) &
!                   /(2*(2*rg-1))     )   
!24.04.15 ->
!          C00_err(rg) = max(C00_err(rg),                    &
!              max( abs(m02)*Cij_err(rg-2),             &     
!              max(adetZ*Cij_err(rg),abs(Xtilde)*Cij_err(rg-2),fmax*C00_err(rg-1))/abs(Zkl) ) &
!                   /(2*(2*rg-1))     )   
!06.05.15 -> 
          c00_err(rg) = max(c00_err(rg),                    &
              max(adetz*cij_err(rg),abs(xtilde)*cij_err(rg-2),fmax*c00_err(rg-1))/abs(zkl)  &
                   /(2*(2*rg-1))     )   
        end if
        cij_err(rg-1) = max(cij_err(rg-1),max(2*maxzadj*c00_err(rg),adetz*cij_err(rg))/abs(zadjfj) ) 
 
        if(rg.gt.1)then
          c00_err2(rg) = max(c00_err2(rg),                    &
              max(adetz*cij_err2(rg),abs(xtilde)*cij_err2(rg-2),fmax*c00_err2(rg-1))/abs(zkl)  &
                   /(2*(2*rg-1))     )   
        end if
        cij_err2(rg-1) = max(cij_err2(rg-1),max(2*maxzadj*c00_err2(rg),adetz*cij_err2(rg))/abs(zadjfj) ) 
 
!      write(*,*) 'CalcCg g: ',r,adetZ/abs(Zadjfj),C00_err(rg),B_err
!      write(*,*) 'CalcCg g: Cij_err=',rg-1,Cij_err(rg-1)
 
 
#ifdef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
            end do
          end if
        end do
#endif
 
        if ((rg.le.rmax+1)) then
          cerr(rg-1) = 0d0
          do n1=0,rg-1
            n2 = rg-1-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpg(0,n1,n2,g)
            if(abs(cexpg(0,n1,n2,g-1)).ne.0d0) then
!             Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)))
              cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g))*min(1d0,abs(cexpg(0,n1,n2,g))/abs(cexpg(0,n1,n2,g-1))))
            else
              cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g)))
            end if
 
!            write(*,*) 'CalcCg err',r,rg,n1,n2,Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)) &
!                     ,abs(Cexpg(0,n1,n2,g)),abs(Cexpg(0,n1,n2,g-1))
 
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg-1).gt.cerr(rg-1)) then
             gtrunc = min(g,gtrunc)
             
#ifdef Cgtest
             write(*,*) 'CalcCg exit err',r,g,gtrunc
#endif
!            write(*,*) 'CalcCg exit err',r,g,gtrunc
 
          end if
        end if
 
      end do gloop
 
#ifdef Cgtest
      write(*,*) 'CalcCg C(0,0,0) = ',r,c(0,0,0)
      write(*,*) 'CalcCg C(2,0,0) = ',r,c(1,0,0)
      write(*,*) 'CalcCg C(0,1,0) = ',r,c(0,1,0)
      write(*,*) 'CalcCg C(0,0,1) = ',r,c(0,0,1)
      if(r.ge.5.and.rmax.ge.5) then 
      write(*,*) 'CalcCg C(2,1,0) = ',r,c(2,1,0)
      endif
#endif
 
#ifdef Cgtest
      write(*,*) 'CalcCg Cerr r =',r,cerr
      write(*,*) 'CalcCg Cij_err =',r,cij_err
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgtest
      write(*,*) 'CalcCg Cerr =',r,cerr,maxval(cerr)
#endif
!     write(*,*) 'CalcCg Cerr =',r,Cerr,maxval(Cerr)
!     write(*,*) 'CalcCg areq =',acc_req_Cr*abs(C(0,0,0))
!     write(*,*) 'CalcCg Cex  =',maxval(Cerr-acc_req_Cr*abs(C(0,0,0)))
 
!       do mr = 15,min(r,rmax)
!         do n0=mr/2,1,-1
!           do n1=0,mr-2*n0
!             n2=mr-2*n0-n1
!               write(*,*) 'CalcCg n5 order  ',r,rg,mr,n0,n1,n2
!               write(*,*) 'CalcCg n5 order C',C(n0,n1,n2)
!           end do
!         end do 
!       end do
!       do mr = 15,min(r-1,rmax)
!         n0=0
!           do n1=0,mr
!             n2=mr-n1
!               write(*,*) 'CalcCg n5 order  ',r,rg,mr,n0,n1,n2
!               write(*,*) 'CalcCg n5 order C',C(n0,n1,n2)
!           end do
!       end do
 
      ! check if target precision already reached
!      if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit         ! changed 28.01.15
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
 
!          write(*,*) 'CalcCg exit rloop  =',rg,r,rmax
 
          do n0=0,rg/2
            do n1=0,rg-2*n0
              c(n0,n1,rg-2*n0-n1)=0d0
            end do
          end do
        end do
        if(r.le.rmax) then
          do n1=0,r
            c(0,n1,r-n1)=0d0
          end do
        end if
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
#endif
!       write(*,*) 'CalcCg exit rloop  =',r,rmax,rg
 
        exit rloop
      end if
 
    end do rloop
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
!       do mr = 15,rmax
!         do n0=mr/2,1,-1
!           do n1=0,mr-2*n0
!             n2=mr-2*n0-n1
!               write(*,*) 'CalcCg n6 order  ',r,rg,mr,n0,n1,n2
!               write(*,*) 'CalcCg n6 order C',C(n0,n1,n2)
!           end do
!         end do 
!       end do
!       do mr = 15,rmax
!         n0=0
!           do n1=0,mr
!             n2=mr-n1
!               write(*,*) 'CalcCg n6 order  ',r,rg,mr,n0,n1,n2
!               write(*,*) 'CalcCg n6 order C',C(n0,n1,n2)
!           end do
!       end do
 
#ifdef Cgtest
    write(*,*) 'CalcCg final err',cerr
    write(*,*) 'CalcCg final acc',cerr/abs(c(0,0,0))
#endif
                 
#ifdef TRACECout
    write(*,*) 'CalcCg rmax',rmax
    do r=15,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCg out  ',r,n0,n1,r-2*n0-n1
    write(*,*) 'CalcCg out C',c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!    write(*,*) 'CalcCg Cerr ',Cerr
!    write(*,*) 'CalcCg Cerr2',Cerr2
 
  end subroutine calccg
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgr(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgr_min,ordgr_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccgr(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgr_min,ordgr_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
 
    integer, intent(in) :: rmax,ordgr_min,ordgr_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double precision :: B_err,B_max
    double complex :: Zadjfj,Zadj2(2,2), Zadjkl, Zadj2f(2,2,2)
    double complex, allocatable :: Cexpgr(:,:,:,:), CuvExpgr(:,:,:)
    double complex :: Smod(2), Skl, Caux
    double complex :: elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: maxZadj2f
    double precision :: maxCexpgr(0:1,0:2*(rmax+ordgr_min),0:ordgr_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,i,j,m,n,g,rg,lt,ltt,nn,nntt
    integer :: inds0(2), inds1(2), inds(2)
    integer :: bin,nid(0:2)
 
#ifdef Cgrtest
    write(*,*) 'CalcCgr in ',rmax,ordgr_min,ordgr_max
    write(*,*) 'CalcCgr in, f  ',f
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgr in ',rmax,ordgr_min,ordgr_max
#endif
 
    ! allocation of B functions
    rmaxb = 2*rmax + 2*ordgr_min
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
    
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
   ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
      end do
    end do
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_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
 
!    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:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(zadjf(1)).ge.abs(zadjf(2))) then
      j = 1
    else 
      j = 2
    end if
 
    zadj2f(1,2,1) = -f(2)
    zadj2f(1,2,2) =  f(1)
 
    maxzadj2f = 0d0                ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
                                   ! Zadj2(m) ==  Zadf2(k,n,l,m)
                                   ! maxZadj2f = fmax!!
    if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,1))
      k = 1
      n = 2
      l = 1
      m = 2
      zadj2(2,2) = -1d0
    end if
    if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
      maxzadj2f = abs(zadj2f(1,2,2))
      k = 1
      n = 2
      l = 2
      m = 1
      zadj2(2,1) =  1d0
    end if
 
#ifdef Cgrtest
    write(*,*) 'CalcCgr maxZadj2f ',maxzadj2f,maxval(abs(zadj2f(:,:,:)))
    write(*,*) 'CalcCgr Zadj2f ',zadj2f
    write(*,*) 'CalcCgr Zadj2f ',zadj2f(1,2,1),zadj2f(1,2,1)
    write(*,*) 'CalcCgr f      ',f
#endif
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
 
#ifdef Cgrtest
    write(*,*) 'CalcCgr k,n,nt,l',k,n,l,m
    write(*,*) 'CalcCgr pars', maxzadj2f,zadj2f(k,n,l),zadj(k,l),maxzadj
    write(*,*) 'CalcCgr pars', abs(zadjf(l)),abs(detz)
    write(*,*) 'CalcCgr pars',  abs(zadjf(l)/ maxzadj2f),abs(detz/maxzadj2f)
#endif
 
    zadjfj = zadjf(j)
    zadjkl = zadj(k,l)
 
    ! allocation of array for expanded C-coefficients
    rmaxexp = rmaxb
    allocate(cexpgr(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:ordgr_max))
 
    ! calculate Cuv
    allocate(cuvexpgr(0:(rmaxexp+1),0:rmaxexp+1,0:rmaxexp+1))
    call calccuv(cuvexpgr,buv_0,mm02,f,rmaxexp+1,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpgr(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
     
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
!    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) * truncfacc
    gtrunc = ordgr_max 
 
! calculate C(n0,n1,n2) up to rank r+n0
    rloop: do r=0,rmaxexp/2
 
#ifdef Cgrtest
!      write(*,*) 'CalcCgr rloop',r,rmax,gtrunc
#endif
 
      if (r.gt.rmax+gtrunc) exit rloop
 
#ifdef Cgrtest
      write(*,*) 'CalcCgr rloop',r,rmaxexp,rmaxb
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
      ! exploiting eq. (5.40) - (5.53) solved for C_00i1..<ir>...iP
      maxcexpgr(1,r,0)=0d0
      do n0=r,1,-1
        do nn=r-n0,0,-1
          nntt = r-n0-nn
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr rloop',n0,nn,zadj2f(k,n,l)
#endif
 
          inds0(n) = nn
          inds0(k) = nntt
            
#ifdef Cgrtest
          write(*,*) 'CalcCgr inds0',n0,inds0
#endif
 
          inds1(n) = nn+1
          inds1(k) = nntt
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr inds1',n0,inds1
#endif
 
          caux = -zadj(k,l)*b_0(n0-1,inds1(1),inds1(2))
 
!            Caux = 2*Zadj(k,l) * (1+r-2*n0) * Cexpgr(n0,inds1(1),inds1(2),0)
 
!            inds = inds1
!            inds(k) = inds(k) + 1
!            inds(l) = inds(l) + 1
!            Caux = Caux + detZ * Cexpgr(n0-1,inds(1),inds(2),0)
!
!            inds = inds1
!            inds(k) = inds(k) + 1
!            Caux = Caux + Zadjf(l) * Cexpgr(n0-1,inds(1),inds(2),0)
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr Caux 1c',-zadj(k,l)*b_0(n0-1,inds1(1),inds1(2))
          write(*,*) 'CalcCgr Caux 1s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
          
          inds = inds1
          inds(k) = inds(k)+1
          do i=1,2
            caux = caux - zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
#ifdef Cgrtest
            write(*,*) 'CalcCgr Caux 2ci', -zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
#endif
          end do
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr Caux 2s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
          do i=1,2
            inds = inds1
            inds(i) = inds(i)+1
            caux = caux + zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
#ifdef Cgrtest
            write(*,*) 'CalcCgr Caux 3ci',zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
#endif
          end do
 
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr Caux 3s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
          caux = caux + 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),m)
 
 
#ifdef Cgrtest
          write(*,*) 'CalcCgr Caux 4ca', 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),m) 
          write(*,*) 'CalcCgr Caux 4s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
 
!            Caux = Caux - 2*(nn+1)* Zadj2f(k,n,l)*Cexpgr(n0,inds0(1),inds0(2),0) 
 
          inds = inds1
          if(m.eq.n) then
            if (inds(n).gt.1) then
              inds(n) = inds(n)-2
              caux = caux - 4*(nn+1)*nn * zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),0) 
#ifdef Cgrtest
              write(*,*) 'CalcCgr Caux 6c',4*(nn+1)*nn* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),0) 
              write(*,*) 'CalcCgr Caux 6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
            end if
          else
            if (inds(n).gt.0.and.inds(m).gt.0) then
              inds(n) = inds(n)-1
              inds(m) = inds(m)-1
              caux = caux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),0) 
#ifdef Cgrtest
              write(*,*) 'CalcCgr Caux 6c',-4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),0) 
              write(*,*) 'CalcCgr Caux 6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif
            end if
          end if
          
          cexpgr(n0,inds0(1),inds0(2),0) = caux/(2*(nn+1)* zadj2f(k,n,l))
          
          if (n0.eq.1) then
            maxcexpgr(1,r,0) =  maxcexpgr(1,r,0) + abs(cexpgr(n0,inds0(1),inds0(2),0) )
          end if
          
!          if (r+n0.le.rmax) then             !  for fixed rank
          if (r.le.rmax) then
            c(n0,inds0(1),inds0(2)) = cexpgr(n0,inds0(1),inds0(2),0)
          end if
          
        end do
      end do
 
      ! calculate
      ! C_00ijkl.. --> C_aijkl..
      ! exploiting eq. (5.38)
      maxcexpgr(0,r,0)=0d0
      do n1=0,r
        n2 = r-n1
 
        smod = shat(0,n1,n2,:)
        if (n1.ge.1) then
          smod(1) = smod(1) - 2d0*n1*cexpgr(1,n1-1,n2,0)
        end if
        if (n2.ge.1) then
          smod(2) = smod(2) - 2d0*n2*cexpgr(1,n1,n2-1,0)
        end if
 
        cexpgr(0,n1,n2,0) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
            )/zadjfj
        maxcexpgr(0,r,0) =  maxcexpgr(0,r,0) + abs(cexpgr(0,n1,n2,0))
        if (r.le.rmax) then
          c(0,n1,n2) = cexpgr(0,n1,n2,0)
        end if
 
 
#ifdef Cgrtest
        if(r.le.rmax) then
          write(*,*) 'CalcCgr C(0,n1,n2,0)=',n1,n2,c(0,n1,n2)
        end if
        
        if(n0.eq.0.and.n1.eq.0.and.n2.eq.3) then 
          write(*,*) 'C(0,0,3)= ',0,c(n0,n1,n2)
        end if
#endif
 
      end do
 
#ifdef Cgrtest
!      write(*,*) 'CalcCgr maxCexpgr 0',r-1, maxCexpgr(0,r-1,0)
#endif
 
      if(r.le.rmax) then
!       Cerr(r) =  abs(detZ/Zadjfj)*maxCexpgr(0,r,0)
        cerr(r) =  fac_gr*maxcexpgr(0,r,0)
      end if
 
      ! error propagation from C's
      if(r.gt.0)then
        c00_err(r+1) = maxzadj*b_err/(2*maxzadj2f)
      end if
      cij_err(r)=maxzadj*max(b_err,2*c00_err(r+1))/abs(zadjfj)
 
      if(r.gt.0)then
        c00_err2(r+1) = maxzadj*b_err/(2*maxzadj2f)
      end if
      cij_err2(r)=maxzadj*max(b_err,2*c00_err2(r+1))/abs(zadjfj)
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r)
        rg = rg-1
 
#ifdef Cgrtest
        write(*,*) 'CalcCgr: gloop ',r,rg,g
#endif
 
        ! calculating
        ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
       ! exploiting eq. (5.40) - (5.53) solved for C_00i1..<ir>...iP
        maxcexpgr(1,rg,g) = 0d0
        do n0=rg,1,-1                      !  note rank of tensor = rg+n0
          do nn=rg-n0,0,-1
            nntt = rg-n0-nn
            inds0(n) = nn
            inds0(k) = nntt
              
            inds1(n) = nn+1
            inds1(k) = nntt
              
#ifdef Cgrtest
            write(*,*) 'CalcCgr Caux r inds=',n0,inds0
#endif      
 
            caux = 2*zadj(k,l) * (2+rg-n0) * cexpgr(n0,inds1(1),inds1(2),g-1)
              
#ifdef Cgrtest
            write(*,*) 'CalcCgr Caux r1c',2*zadj(k,l)*(2+rg-n0)* cexpgr(n0,inds1(1),inds1(2),g-1)
            write(*,*) 'CalcCgr Caux r1c',2*zadj(k,l)*(2+rg-n0),cexpgr(n0,inds1(1),inds1(2),g-1) &
                ,n0,inds1(1),inds1(2)
            write(*,*) 'CalcCgr Caux r1s',caux,caux/(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
              caux = caux + detz * cexpgr(n0-1,inds(1),inds(2),g-2)
                
#ifdef Cgrtest
              write(*,*) 'CalcCgr Caux r2c',detz * cexpgr(n0-1,inds(1),inds(2),g-2)
              write(*,*) 'CalcCgr Caux r2s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif      
            end if
 
            inds = inds1
            inds(k) = inds(k) + 1
            caux = caux + zadjf(l) * cexpgr(n0-1,inds(1),inds(2),g-1)
            
#ifdef Cgrtest
            write(*,*) 'CalcCgr Caux r3c',zadjf(l)* cexpgr(n0-1,inds(1),inds(2),g-1)
            write(*,*) 'CalcCgr Caux r3c',zadjf(l),cexpgr(n0-1,inds(1),inds(2),g-1),n0-1,inds(1),inds(2)
            write(*,*) 'CalcCgr Caux r3s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif      
 
!            Caux = Caux - 2*nn* Zadj2f(k,n,l)*Cexpgr(n0,inds0(1),inds0(2),g) 
 
            inds = inds1
            if(m.eq.n) then
              if (inds(n).gt.1) then
                inds(n) = inds(n)-2
                caux = caux - 4*(nn+1)*nn * zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),g) 
#ifdef Cgrtest
                write(*,*) 'CalcCgr Caux r6c',4*(nn+1)*nn* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),g) 
                write(*,*) 'CalcCgr Caux r6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif      
              end if
            else
              if (inds(n).gt.0.and.inds(m).gt.0) then
                inds(n) = inds(n)-1
                inds(m) = inds(m)-1
                caux = caux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),g) 
#ifdef Cgrtest
                write(*,*) 'CalcCgr Caux r6c',4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),g) 
                write(*,*) 'CalcCgr Caux r6c',n,m,nn,4*(nn+1)*(inds(m)+1),zadj2(n,m ),cexpgr(n0+1,inds(1),inds(2),g) 
                write(*,*) 'CalcCgr Caux r6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
#endif      
              end if
            end if
              
 
            cexpgr(n0,inds0(1),inds0(2),g) = caux/(2*(nn+1)* zadj2f(k,n,l))
                             
            if(n0.eq.1) then
              maxcexpgr(1,rg,g) =  maxcexpgr(1,rg,g) + abs(cexpgr(n0,inds0(1),inds0(2),g))
              
              if (g.eq.1.and.abs(cexpgr(n0,inds0(1),inds0(2),g)).gt.   & 
                  truncfacexp*max(1d0,maxcexpgr(1,rg,g-1)) .or.        &
                  g.ge.2.and.abs(cexpgr(n0,inds0(1),inds0(2),g)).gt.   &
                  truncfacexp*maxcexpgr(1,rg,g-1)) then
 
#ifdef Cgrtest
                write(*,*) 'CalcCgr exit gloop',n0,inds0(1),inds0(2),g,rg,  &
                    abs(cexpgr(n0,inds0(1),inds0(2),g)),maxcexpgr(1,rg,g-1),truncfacexp
#endif      
                
                gtrunc = g-1
                exit gloop
              end if
            end if
 
          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
                n2=rg-n0-n1
                c(n0,n1,n2) = c(n0,n1,n2) + cexpgr(n0,n1,n2,g)
              end do
            end if
          end do
        end if
#endif
!        write(*,*) 'CalcCgr after it1 ',rg
 
        ! calculate
        ! C_00ijkl.. --> C_aijkl..
        ! exploiting eq. (5.38)
 
!        write(*,*) 'CalcCgr maxCexp',rg,g-1,maxCexpgr(0,rg,g-1)
 
        maxcexpgr(0,rg,g) = 0d0
        do n1=0,rg
          n2 = rg-n1
          
          smod = 0d0
          if (n1.ge.1) then
            smod(1) = smod(1) - 2d0*n1*cexpgr(1,n1-1,n2,g)
          end if
          if (n2.ge.1) then
            smod(2) = smod(2) - 2d0*n2*cexpgr(1,n1,n2-1,g)
          end if
 
          inds(1) = n1
          inds(2) = n2
          inds(j) = inds(j)+1
          cexpgr(0,n1,n2,g) = (zadj(1,j)*smod(1) +  zadj(2,j)*smod(2)  &
              - detz*cexpgr(0,inds(1),inds(2),g-1))/zadjfj
 
          maxcexpgr(0,rg,g) =  maxcexpgr(0,rg,g) + abs(cexpgr(0,n1,n2,g))
 
!              if(n1.eq.0.and.n2.eq.1) then 
!                write(*,*) 'C2(2,3)= ',g,Cexpgr(0,n1,n2,g)
!                write(*,*) 'C2(2,3)= ',Zadj(1,j)*Smod(1)/Zadjfj,  Zadj(2,j)*Smod(2)/Zadjfj,  &
!                                - detZ*Cexpgr(0,inds(1),inds(2),g-1)/Zadjfj
!                write(*,*) 'C2(2,3)= ',inds(1),inds(2),         &
!                                - detZ/Zadjfj,Cexpgr(0,inds(1),inds(2),g-1)
!              end if
 
          if (g.eq.1.and.abs(cexpgr(0,n1,n2,g)).gt.        &
              truncfacexp*max(1d0/m2scale,maxcexpgr(0,rg,g-1)).or.     &
              g.ge.2.and.abs(cexpgr(0,n1,n2,g)).gt.        &
              truncfacexp*maxcexpgr(0,rg,g-1)) then
 
#ifdef Cgrtest
            write(*,*) 'CalcCgr exit gloop',0,n1,n2,g,abs(cexpgr(0,n1,n2,g)),maxcexpgr(0,rg,g-1),truncfacexp
#endif      
            gtrunc = g-1
            exit gloop
          end if
 
        end do
 
        ! error propagation from C's
        if(rg.gt.0)then
          c00_err(rg+1) = max( c00_err(rg+1),                   &
              max( maxzadj*(2+rg-2*n0)*c00_err(rg+2),       &
                    abs(detz)*cij_err(rg+2),                &
                    maxzadjf*cij_err(rg+1)                   &
                 ) / (2*maxzadj2f)  ) 
        end if
        cij_err(rg)=max(cij_err(rg),                &
            max(2*maxzadj*c00_err(rg+1),abs(detz)*cij_err(rg))/abs(zadjfj) )
 
        if(rg.gt.0)then
          c00_err2(rg+1) = max( c00_err2(rg+1),                   &
              max( maxzadj*(2+rg-2*n0)*c00_err2(rg+2),       &
                    abs(detz)*cij_err2(rg+2),                &
                    maxzadjf*cij_err2(rg+1)                   &
                 ) / (2*maxzadj2f)  ) 
        end if
        cij_err2(rg)=max(cij_err2(rg),                &
            max(2*maxzadj*c00_err2(rg+1),abs(detz)*cij_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
                n2=rg-n0-n1
                c(n0,n1,n2) = c(n0,n1,n2) + cexpgr(n0,n1,n2,g)
              end do
            end if
          end do
        end if
#endif
 
        if (rg.le.rmax) then
          cerr(rg) = 0d0
          do n1=0,rg
              n2 = rg-n1
              c(0,n1,n2) = c(0,n1,n2) + cexpgr(0,n1,n2,g)
            if(abs(cexpgr(0,n1,n2,g-1)).ne.0d0) then
!             Cerr(rg)=max(Cerr(rg),abs(Cexpgr(0,n1,n2,g))**2/abs(Cexpgr(0,n1,n2,g-1)))
              cerr(rg)=max(cerr(rg),abs(cexpgr(0,n1,n2,g))*min(1d0,abs(cexpgr(0,n1,n2,g))/abs(cexpgr(0,n1,n2,g-1))))
            else
              cerr(rg)=max(cerr(rg),abs(cexpgr(0,n1,n2,g)))
            end if
 
#ifdef Cgrtest
              write(*,*) 'CalcCgr Cerr calc',rg,cerr(rg),n1,n2,abs(cexpgr(0,n1,n2,g)),abs(cexpgr(0,n1,n2,g-1))
#endif
 
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg).gt.3d0*cerr(rg)) then
            gtrunc = min(g,gtrunc)
             
#ifdef Cgrtest
             write(*,*) 'CalcCgr exit err',r,rg,g,gtrunc,cij_err(rg),cerr(rg)
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Cgrtest
      write(*,*) 'CalcCgr C(0,0,0) = ',r,c(0,0,0)
    if(r.ge.1)then
      write(*,*) 'CalcCgr C(1,0,0) = ',r,c(1,0,0)
      write(*,*) 'CalcCgr C(0,1,0) = ',r,c(0,1,0)
      write(*,*) 'CalcCgr C(0,0,1) = ',r,c(0,0,1)
      write(*,*) 'CalcCgr C(0,0,0) = ',r,c(0,0,0)
    end if
    if(r.ge.2.and.rmax.ge.2)then
      write(*,*) 'CalcCgr C(1,1,0) = ',r,c(1,1,0)
      write(*,*) 'CalcCgr C(1,0,1) = ',r,c(1,0,1)
      write(*,*) 'CalcCgr C(1,0,0) = ',r,c(1,0,0)
!      write(*,*) 'CalcCgr C(0,2,0) = ',r,C(0,2,0)
!      write(*,*) 'CalcCgr C(0,1,1) = ',r,C(0,1,1)
      write(*,*) 'CalcCgr C(0,0,2) = ',r,c(0,0,2)
    end if
    if(r.ge.3.and.rmax.ge.2)then
!      write(*,*) 'CalcCgr C(3,0,0) = ',r,C(3,0,0)
!      write(*,*) 'CalcCgr C(2,0,1) = ',r,C(2,0,1)
      write(*,*) 'CalcCgr C(1,0,2) = ',r,c(1,0,2)
      write(*,*) 'CalcCgr C(0,3,0) = ',r,c(0,3,0)
      write(*,*) 'CalcCgr C(0,2,1) = ',r,c(0,2,1)
      write(*,*) 'CalcCgr C(0,0,3) = ',r,c(0,0,3)
      write(*,*) 'CalcCgr C(0,1,1) = ',r,c(0,1,1)
      write(*,*) 'CalcCgr C(0,0,2) = ',r,c(0,0,2)
    end if
      write(*,*) 'CalcCgr Cij_err',r,cij_err
      write(*,*) 'CalcCgr Cij_acc',r,cij_err/abs(c(0,0,0))
 
      write(*,*) 'CalcCgr err',r,cerr
      write(*,*) 'CalcCgr acc',r,cerr/abs(c(0,0,0))
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgrtest
!      write(*,*) 'CalcCgr exit r',r,maxval(Cerr),acc_req_C*abs(C(0,0,0))
#endif
 
!      if(maxval(Cerr).le.acc_req_C*abs(C(0,0,0))) exit           changed 28.01.15
      ! check if target precision already reached
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
        do n0=0,rg/2
        do n1=0,rg-n0
          c(n0,n1,rg-n0-n1)=0d0
        end do
        end do
        end do
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
#ifdef Cgrtest
!    write(*,*) 'CalcCgr C(0,0,0) = ',C(0,0,0)
!    if(rmax.ge.3)then
!      write(*,*) 'CalcCgr C(0,1,1,1) = ',C(0,1,1,1)
!    end if
 
    write(*,*) 'CalcCgr final err',cerr
    write(*,*) 'CalcCgr final acc',cerr /abs(c(0,0,0))
#endif      
                           
!   write(*,*) 'CalcCgr out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
#ifdef TRACECout
    write(*,*) 'CalcCgr rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgr out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!    write(*,*) 'CalcCgr Cerr ',Cerr
!    write(*,*) 'CalcCgr Cerr2',Cerr2
 
  end subroutine calccgr
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgy(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
  ! modified version of Ansgar  (similar to CalcDgy)
  
  subroutine calccgy(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex, allocatable :: Cexpgy(:,:,:,:), CuvExpgy(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex :: Smod, Caux, Zadj2f
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max,aZadj2f
    double precision :: maxCexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,i,j,jt,g,rg
    integer :: inds0(2),inds(2),k,l,lt,nl,nlt
    integer :: bin,nid(0:2)
 
#ifdef Cgytest
    write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
    write(*,*) 'CalcCgy in ',p10,p21,p20,m02,m12,m22
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
#endif
 
    ! write(*,*) 'LH: CalcCgy, ord', ordgy_min
    ! calculation of B-coefficients
    rmaxb = rmax + 2*ordgy_min + 1
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
   ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
      end do
    end do
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_max
 
    ! determine (adjugated) Gram and Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
 
    if (abs(detz).lt.abs(4d0*q10*q20 + z(2,1)*z(2,1))*1d-4) then
      if (abs(q10-q20).lt.abs(q10-q21).and.  &
          abs(q10-q20).lt.abs(q20-q21)) then
        detz  =  4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
      end if
    end if
 
!    Zadj(1,1) = 2d0*q20
!    Zadj(2,1) = -q1q2
!    Zadj(1,2) = -q1q2
!    Zadj(2,2) = 2d0*q10
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
!
! Xadj(1,1) and Xadj(2,2) exchanged!!!
!    Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
!    Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
!    Xadj(1,2) = Xadj(2,1)
!    Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
    ! choose reduction formulas with biggest denominators
    if (abs(xadj(1,1)).ge.abs(xadj(2,2))) then
      if (abs(xadj(1,1)).ge.abs(xadj(1,2))) then
        i = 1
        j = 1
        jt = 2
        zadj2f = -f(2)  
      else
        i = 1
        j = 2
        jt = 1
        zadj2f = f(2)
      end if
    else        
      if (abs(xadj(2,2)).ge.abs(xadj(1,2))) then
        i = 2
        j = 2
        jt = 1
        zadj2f = -f(1)
      else 
        i = 1
        j = 2
        jt = 2
        zadj2f = -f(2) 
      end if
    end if
    azadj2f = abs(zadj2f)
 
    if (abs(zadj(1,1)).ge.abs(zadj(2,2))) then
      if (abs(zadj(1,1)).ge.abs(zadj(1,2))) then
        k = 1
        l = 1
        lt = 2
      else
        k = 1
        l = 2
        lt = 1
      end if
    else        
      if (abs(zadj(2,2)).ge.abs(zadj(1,2))) then
        k = 2
        l = 2
        lt = 1
      else 
        k = 1
        l = 2
        lt = 1
      end if
    end if
 
#ifdef Cgytest
    write(*,*) 'CalcCgy: Zadj',k,l,zadj(k,l)
    write(*,*) 'CalcCgy: Xadj',i,j,xadj(i,j)
    write(*,*) 'CalcCgy: Zadjf',j,zadjf(j),maxzadjf
#endif
 
!   write(*,*)  'CalcCgy Zadj(i,j)=',i,j,Zadj(i,j),Xadj(i,j)
        
    ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
   
    ! calculate Cuv
    allocate(cuvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpgy,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpgy(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
 
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
!    maxZadjf = maxval(abs(Zadjf))
!    fmax = maxval(abs(f))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(i,j))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
    truncfacexp = sqrt(fac_gy) * truncfacc
    gtrunc = ordgy_max 
 
#ifdef Cgytest            
    write(*,*) 'CalcCgy gtrunc orig=',gtrunc
    write(*,*) 'CalcCgy rmaxExp-2=',rmaxexp-2
#endif
 
! calculate C(1,n1,n2) up to rank r+2
! calculate C(0,n1,n2) up to rank r  
    rloop: do r=0,rmaxexp-2
 
#ifdef Cgytest            
      write(*,*) 'CalcCgy rloop=',r,rmaxexp-2,rmax+2*gtrunc+2
      write(*,*) 'CalcCgy rloop=',rmax,gtrunc
#endif
 
      if (r.gt.rmax+2*gtrunc+2) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating C_00ijk.. exploiting eq. (5.49)
      maxcexpgy(1,r,0)=0d0
      do nl=r,0,-1
        nlt=r-nl
        inds0(l) = nl
        inds0(lt) = nlt
 
        inds(l) = nl+1
        inds(lt) = nlt
        caux = zadj(k,1)*shat(0,inds(1),inds(2),1)  &
             + zadj(k,2)*shat(0,inds(1),inds(2),2)
 
        if (nlt.ge.1) then
          inds(lt) = nlt-1
          caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),0)
        end if
 
        cexpgy(1,inds0(1),inds0(2),0) = caux/(2*(nl+1)*zadj(k,l))
        maxcexpgy(1,r,0) =  maxcexpgy(1,r,0) + abs(cexpgy(1,inds0(1),inds0(2),0) )
!        if (r+2.le.rmax) then             !  for fixed rank
        if (r+1.le.rmax) then
          c(1,inds0(1),inds0(2)) = cexpgy(1,inds0(1),inds0(2),0)
        end if
 
      end do
 
      ! calculate C_ijkl.. exploiting eq. (5.53)
      maxcexpgy(0,r,0)=0d0
      do n1=0,r
        n2 = r-n1
        inds(1) = n1
        inds(2) = n2
      
        caux = (2*(2+r)*cexpgy(1,n1,n2,0) - 4*cuvexpgy(1,n1,n2)  &
             - b_0(0,n1,n2))*zadj(i,j)
 
!     write(*,*) 'CalcCred Caux',Caux,Zadj(i,j),f(i),f(j)
 
        smod = shat(0,n1,n2,jt)
 
        if (inds(jt).ge.1) then
          inds(jt) = inds(jt)-1
          smod = smod - 2d0*(inds(jt)+1)*cexpgy(1,inds(1),inds(2),0)
        end if
 
        caux = caux + zadj2f*smod
 
!       write(*,*) 'CalcCgy maxadjf',maxZadjf,Xadj(i,j),Caux
 
        cexpgy(0,n1,n2,0) = caux/xadj(i,j)
        maxcexpgy(0,r,0) =  maxcexpgy(0,r,0) + abs(cexpgy(0,n1,n2,0))
        if (r.le.rmax) then
          c(0,n1,n2) = cexpgy(0,n1,n2,0)
        end if
 
      end do
 
      if (r.le.rmax) then
!       Cerr(r) =  abs(maxZadjf/Xadj(i,j))*maxCexpgy(0,r,0)
        cerr(r) =  fac_gy*maxcexpgy(0,r,0)
 
!        write(*,*) 'CalcCgy Cerr,0 ',r,Cerr(r),fac_gy,maxCexpgy(0,r,0)
 
      end if
 
 ! error propagation from B's
      c00_err(r+2) = b_err /2d0               
      cij_err(r)=max(abs(zadj(i,j))/abs(xadj(i,j))*max(b_err,2*(r+2)*c00_err(r+2)),  &
                  fmax/abs(xadj(i,j))*max(b_err,2*c00_err(r+1)))
 
      c00_err2(r+2) = b_err /2d0               
      cij_err2(r)=max(abs(zadj(i,j))/abs(xadj(i,j))*max(b_err,2*(r+2)*c00_err2(r+2)),  &
                  fmax/abs(xadj(i,j))*max(b_err,2*c00_err2(r+1)))
 
      
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r/2)
        rg = rg-2
 
!       write(*,*) 'CalcCgy gtrunc gloop=',gtrunc,r,g,rg
 
        ! calculating C_00ijk.. exploiting eq. (5.49)
        maxcexpgy(1,rg,g) = 0d0
        do nl=rg,0,-1
          nlt=rg-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = -zadjf(k)*cexpgy(0,inds(1),inds(2),g-1)
 
          inds(k) = inds(k)+1
          caux = caux - detz*cexpgy(0,inds(1),inds(2),g-1)
 
          if (nlt.ge.1) then
            inds(l) = nl+1
            inds(lt) = nlt-1
            caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),g)
          end if
 
          cexpgy(1,inds0(1),inds0(2),g) = caux/(2*(nl+1)*zadj(k,l))
          maxcexpgy(1,rg,g) =  maxcexpgy(1,rg,g) + abs(cexpgy(1,inds0(1),inds0(2),g) )
 
          if (g.eq.1.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt.      &
                  truncfacexp*max(1d0,maxcexpgy(1,rg,g-1))    .or.   &
                  g.ge.2.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt.  &
                  truncfacexp*maxcexpgy(1,rg,g-1)) then
#ifdef Cgytest            
            write(*,*) 'CalcCgy exit gloop',n1,n2,g,abs(cexpgy(1,inds0(1),inds0(2),g)),maxcexpgy(1,rg,g-1)
            write(*,*) 'CalcCgy exit gloop',g,rg,inds0(1),inds0(2)
#endif
 
            gtrunc = g-1
            exit gloop
 
          end if 
        
        end do
 
#ifndef PPEXP00
!        if (rg+2.le.rmax) then            !  for fixed rank
        if (rg+1.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgy(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        ! calculate C_ijkl.. exploiting eq. (5.53)
        maxcexpgy(0,rg,g) = 0d0
        do n1=0,rg
          n2 = rg-n1
          inds0(1) = n1
          inds0(2) = n2
          
          caux = 2*(2+rg)*cexpgy(1,n1,n2,g)*zadj(i,j)
          
!          write(*,*) 'CalcCgy g Caux 1',rg,g,Caux
 
          if (inds0(jt).ge.1) then
            inds = inds0
            inds(jt) = inds(jt)-1
            caux = caux - 2d0*zadj2f*inds0(jt)*cexpgy(1,inds(1),inds(2),g)
          end if
          
!          write(*,*) 'CalcCgy g Caux 2',rg,g,Caux
 
          inds0(i) = inds0(i)+1
          caux = caux - zadjf(j)*cexpgy(0,inds0(1),inds0(2),g-1)
          
!          write(*,*) 'CalcCgy g Caux 3',rg,g,Caux
 
          cexpgy(0,n1,n2,g) = caux/xadj(i,j)
 
!          write(*,*) 'CalcCgy g Cexpgy',rg,g,n1,n2,Cexpgy(0,n1,n2,g)
 
          maxcexpgy(0,rg,g) =  maxcexpgy(0,rg,g) + abs(cexpgy(0,n1,n2,g))
          
          if (g.eq.1.and.abs(cexpgy(0,n1,n2,g)).gt.        &
              truncfacexp*max(1d0/m2scale,maxcexpgy(0,rg,g-1)).or.     &
              g.ge.2.and.abs(cexpgy(0,n1,n2,g)).gt.        &
              truncfacexp*maxcexpgy(0,rg,g-1)) then
 
#ifdef Cgytest            
            write(*,*) 'CalcCgy exit gloop',n1,n2,g,rg
            write(*,*) 'CalcCgy exit gloop',abs(cexpgy(0,n1,n2,g)),maxcexpgy(0,rg,g-1),1d0/m2scale
            write(*,*) 'CalcCgy exit gloop',truncfacexp
#endif
 
            gtrunc = g-1
            exit gloop
 
          end if
 
!            if ((g.ge.2).and.(abs(Cexpgy(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgy(0,n1,n2,g-1)))) then
!              gtrunc = g-1
!            end if
 
        end do
 
        ! error propagation from B's
        if(rg.gt.1)then
          c00_err(rg+2) =max(c00_err(rg+2),                                       &
              max(abs(zadjf(k))/2d0*cij_err(rg+1),                                &
                  abs(detz)/2d0*cij_err(rg+2))/abs(zadj(k,l)))   
        end if
 
#ifdef Cgytest
        write(*,*) 'CalcCgy test2',rg,i,j,cij_err(rg)
        write(*,*) 'CalcCgy test2',rg,cij_err(rg+1),c00_err(rg+1)
        write(*,*) 'CalcCgy test2',rg,abs(zadj(i,j))
        write(*,*) 'CalcCgy test2',rg,abs(zadj2f)
        write(*,*) 'CalcCgy test2',rg,abs(zadjf(j))
        write(*,*) 'CalcCgy test2',rg,abs(xadj(i,j))
#endif
 
        cij_err(rg)= max( cij_err(rg),                                &
            max(2*(rg+2)*abs(zadj(i,j))*c00_err(rg+2),                &
                2*abs(zadj2f)*c00_err(rg+1),       &
                abs(zadjf(j))*cij_err(rg+1))/abs(xadj(i,j)))
 
        if(rg.gt.1)then
          c00_err2(rg+2) =max(c00_err2(rg+2),                                       &
              max(abs(zadjf(k))/2d0*cij_err2(rg+1),                                &
                  abs(detz)/2d0*cij_err2(rg+2))/abs(zadj(k,l)))   
        end if
 
        cij_err2(rg)= max( cij_err2(rg),                                &
            max(2*(rg+2)*abs(zadj(i,j))*c00_err2(rg+2),                &
                2*abs(zadj2f)*c00_err2(rg+1),       &
                abs(zadjf(j))*cij_err2(rg+1))/abs(xadj(i,j)))
 
#ifdef PPEXP00
!        if (rg+2.le.rmax) then             !   for fixed rank
        if (rg+1.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgy(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        if ((rg.le.rmax)) then
          cerr(rg) = 0d0
          do n1=0,rg
            n2=rg-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpgy(0,n1,n2,g)
 
#ifdef Cgytest
            write(*,*) 'CalcCgy test1',rg,n1,n2,cerr(rg)
            write(*,*) 'CalcCgy test1',cexpgy(0,n1,n2,g)
            write(*,*) 'CalcCgy test1',cexpgy(0,n1,n2,g-1)
#endif
 
            if(abs(cexpgy(0,n1,n2,g-1)).ne.0d0) then
              cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g))*min(1d0,abs(cexpgy(0,n1,n2,g))/abs(cexpgy(0,n1,n2,g-1))))
            else
              cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g)))
            end if
 
#ifdef Cgytest
            write(*,*) 'CalcCgy test1',cerr(rg)            
#endif
 
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg).gt.cerr(rg)) then
             gtrunc = min(g,gtrunc)
!            gtrunc = min(g+1,gtrunc)
             
#ifdef Cgytest
             write(*,*) 'CalcCgy adjust gtrunc',r,g,gtrunc
#endif
 
          end if
 
        end if
        
        
      end do gloop
 
!     write(*,*) 'CalcCgy gtrunc aft gloop=',gtrunc,r
 
#ifdef Cgytest
      write(*,*) 'CalcCgy Cerr r =',r
      write(*,*) 'CalcCgy Cerr r =',r,cerr
      write(*,*) 'CalcCgy Cacc r =',r,cerr/abs(c(0,0,0))
      write(*,*) 'CalcCgy Cij_err =',r,cij_err
      write(*,*) 'CalcCgy C(0,0,0)=',r,c(0,0,0)
      if(rmax.ge.1.and.r.ge.1) then
      write(*,*) 'CalcCgy C(0,1,0)=',r,c(0,1,0)
      if(rmax.ge.2.and.r.ge.2) then
      write(*,*) 'CalcCgy C(0,1,1)=',r,c(0,1,1)
      if(rmax.ge.3.and.r.ge.3) then
      write(*,*) 'CalcCgy C(0,1,2)=',r,c(0,1,2)
      if(rmax.ge.4) then
      write(*,*) 'CalcCgy C(0,0,4)=',r,c(0,0,4)
      endif
      endif
      endif
      endif
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgytest
      write(*,*) 'CalcCgy Cerr =',r,cerr,maxval(cerr)
#endif
 
      ! check if target precision already reached
!      if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit         ! changed 28.01.15
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
          do n1=0,rg
            c(0,n1,rg-n1)=0d0
          end do
        end do   
        do rg=r+1,rmax
          do n1=0,rg-2
            c(1,n1,rg-2-n1)=0d0
          end do
        end do   
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
 
#ifdef Cgytest
        write(*,*) 'CalcCgy exit rloop',r,cerr,maxval(cerr)
#endif
 
        exit rloop 
 
      end if
 
    end do rloop
 
 
    ! calculating C_0000ijk.. exploiting eq. (5.49)
    do r=4,rmax
!      do n0=2,rmax/2     !     for fixed rank
      do n0=2,rmax
        do nl=r-2*n0,0,-1
          nlt=r-2*n0-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = zadj(k,1)*shat(n0-1,inds(1),inds(2),1)  &
               + zadj(k,2)*shat(n0-1,inds(1),inds(2),2)  &
               - zadjf(k)*c(n0-1,inds(1),inds(2))
 
          inds(k) = inds(k)+1
          caux = caux - detz*c(n0-1,inds(1),inds(2))
 
          if (nlt.ge.1) then
            inds(l) = nl+1
            inds(lt) = nlt-1
            caux = caux - 2*nlt*zadj(k,lt)*c(n0,inds(1),inds(2))
          end if
 
          c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1)*zadj(k,l))
 
        end do
      end do
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
#ifdef Cgytest
    write(*,*) 'CalcCgy final err',cerr
    write(*,*) 'CalcCgy final acc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCgy out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
#ifdef TRACECout
    write(*,*) 'CalcCgy rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgy out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!    write(*,*) 'CalcCgy Cerr ',Cerr
!    write(*,*) 'CalcCgy Cerr2',Cerr2
 
  end subroutine calccgy
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgyo(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
  ! version of Lars
  
  subroutine calccgyo(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex, allocatable :: Cexpgy(:,:,:,:), CuvExpgy(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex :: Smod, Caux
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    double precision :: maxCexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,a,b,j,sgnab,g,rg
    integer :: inds0(2),inds(2),at,bt,k,l,lt,nl,nlt
    integer :: bin,nid(0:2)
 
#ifdef Cgytest
    write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
#endif
 
    ! write(*,*) 'LH: CalcCgy, ord', ordgy_min
    ! calculation of B-coefficients
    rmaxb = rmax + 2*ordgy_min + 1
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
   ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
      end do
    end do
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_max
 
    ! determine (adjugated) Gram and Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
 
    if (abs(detz/( 4d0*q10*q20 + z(2,1)*z(2,1))).lt.1d-4) then
      if (abs(q10-q20).lt.abs(q10-q21).and.  &
          abs(q10-q20).lt.abs(q20-q21)) then
        detz  =  4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
      end if
    end if
 
!    Zadj(1,1) = 2d0*q20
!    Zadj(2,1) = -q1q2
!    Zadj(1,2) = -q1q2
!    Zadj(2,2) = 2d0*q10
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
!
! Xadj(1,1) and Xadj(2,2) exchanged!!!
!    Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
!    Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
!    Xadj(1,2) = Xadj(2,1)
!    Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
    ! choose reduction formulas with biggest denominators
    if (abs(xadj(1,1)).ge.abs(xadj(2,2))) then
      if (abs(xadj(1,1)).ge.abs(xadj(1,2))) then
        a = 1
        b = 1
        at = 2
        bt = 2
        sgnab = 1
      else
        a = 1
        b = 2
        at = 2
        bt = 1
        sgnab = -1
      end if
    else        
      if (abs(xadj(2,2)).ge.abs(xadj(1,2))) then
        a = 2
        b = 2
        at = 1
        bt = 1
        sgnab = 1
      else 
        a = 1
        b = 2
        at = 2
        bt = 1
        sgnab = -1
      end if
    end if
 
    if (abs(zadj(1,1)).ge.abs(zadj(2,2))) then
      if (abs(zadj(1,1)).ge.abs(zadj(1,2))) then
        k = 1
        l = 1
        lt = 2
      else
        k = 1
        l = 2
        lt = 1
      end if
    else        
      if (abs(zadj(2,2)).ge.abs(zadj(1,2))) then
        k = 2
        l = 2
        lt = 1
      else 
        k = 1
        l = 2
        lt = 1
      end if
    end if
 
    ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
   
    ! calculate Cuv
    allocate(cuvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpgy,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpgy(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
 
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
!    maxZadjf = maxval(abs(Zadjf))
!    fmax = maxval(abs(f))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(a,b))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
    truncfacexp = sqrt(fac_gy) * truncfacc
 
    gtrunc = ordgy_max 
 
! calculate C(1,n1,n2) up to rank r+2
! calculate C(0,n1,n2) up to rank r  
    rloop: do r=0,rmaxexp-2
 
      if (r.gt.rmax+2*gtrunc+2) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating C_00ijk.. exploiting eq. (5.49)
      maxcexpgy(1,r,0)=0d0
      do nl=r,0,-1
        nlt=r-nl
        inds0(l) = nl
        inds0(lt) = nlt
 
        inds(l) = nl+1
        inds(lt) = nlt
        caux = zadj(k,1)*shat(0,inds(1),inds(2),1)  &
             + zadj(k,2)*shat(0,inds(1),inds(2),2)
 
        if (nlt.ge.1) then
          inds(lt) = nlt-1
          caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),0)
        end if
 
        cexpgy(1,inds0(1),inds0(2),0) = caux/(2*(nl+1)*zadj(k,l))
        maxcexpgy(1,r,0) =  maxcexpgy(1,r,0) + abs(cexpgy(1,inds0(1),inds0(2),0) )
        if (r+2.le.rmax) then
          c(1,inds0(1),inds0(2)) = cexpgy(1,inds0(1),inds0(2),0)
        end if
 
      end do
 
      ! calculate C_ijkl.. exploiting eq. (5.53)
      maxcexpgy(0,r,0)=0d0
      do n1=0,r
        n2 = r-n1
        inds(1) = n1
        inds(2) = n2
      
        caux = (2*(2+r)*cexpgy(1,n1,n2,0) - 4*cuvexpgy(1,n1,n2)  &
             - b_0(0,n1,n2))*z(a,b)
 
!     write(*,*) 'CalcCred Caux',Caux,Z(a,b),f(a),f(b)
 
        smod = shat(0,n1,n2,a)
 
        if (inds(a).ge.1) then
          inds(a) = inds(a)-1
          smod = smod - 2d0*(inds(a)+1)*cexpgy(1,inds(1),inds(2),0)
 
        end if
 
        caux = caux - f(b)*smod
 
!       write(*,*) 'CalcCgy maxadjf',maxZadjf,Xadj(a,b),Caux
 
        cexpgy(0,n1,n2,0) = caux/xadj(a,b)
        maxcexpgy(0,r,0) =  maxcexpgy(0,r,0) + abs(cexpgy(0,n1,n2,0))
        if (r.le.rmax) then
          c(0,n1,n2) = cexpgy(0,n1,n2,0)
          cerr(r) =  abs(maxzadjf/xadj(a,b)*cexpgy(0,n1,n2,0))
        end if
 
      end do
 
      if (r.le.rmax) then
!       Cerr(r-1) =  abs(maxZadjf/Xadj(a,b))*maxCexpgy(0,r,0)
        cerr(r-1) =  fac_gy*maxcexpgy(0,r,0)
      end if
 
 ! error propagation from B's
      c00_err(r+2) = b_err           
      cij_err(r)=max(abs(zadj(a,b))/abs(xadj(a,b))*max(b_err,c00_err(r+2)),  &
                  fmax/abs(xadj(a,b))*max(b_err,c00_err(r+1)))
 
      c00_err2(r+2) = b_err           
      cij_err2(r)=max(abs(zadj(a,b))/abs(xadj(a,b))*max(b_err,c00_err(r+2)),  &
                  fmax/abs(xadj(a,b))*max(b_err,c00_err2(r+1)))
 
      
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r/2)
        rg = rg-2
 
!        write(*,*) 'CalcCgy gtrunc gloop=',gtrunc,r,g,rg
 
        ! calculating C_00ijk.. exploiting eq. (5.49)
        maxcexpgy(1,rg,g) = 0d0
        do nl=rg,0,-1
          nlt=rg-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = -zadjf(k)*cexpgy(0,inds(1),inds(2),g-1)
 
          inds(k) = inds(k)+1
          caux = caux - detz*cexpgy(0,inds(1),inds(2),g-1)
 
          if (nlt.ge.1) then
            inds(l) = nl+1
            inds(lt) = nlt-1
            caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),g)
          end if
 
          cexpgy(1,inds0(1),inds0(2),g) = caux/(2*(nl+1)*zadj(k,l))
          maxcexpgy(1,rg,g) =  maxcexpgy(1,rg,g) + abs(cexpgy(1,inds0(1),inds0(2),g) )
 
 
          if (g.eq.1.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt.      &
              truncfacexp*max(1d0,maxcexpgy(1,rg,g-1))    .or.   &
              g.ge.2.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt.  &
              truncfacexp*maxcexpgy(1,rg,g-1)) then
 
#ifdef Cgytest            
            write(*,*) 'CalcCgy cycle loop',n1,n2,g,abs(cexpgy(1,inds0(1),inds0(2),g)),maxcexpgy(1,rg,g-1)
#endif
 
                gtrunc = g-1
                exit gloop
!                gtrunc = g
!                cycle gloop
 
          end if 
        
        end do
 
#ifndef PPEXP00
        if (rg+2.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgy(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        ! calculate C_ijkl.. exploiting eq. (5.53)
        maxcexpgy(0,rg,g) = 0d0
        do n1=0,rg
          n2 = rg-n1
          inds0(1) = n1
          inds0(2) = n2
          
          caux = 2*(2+rg)*cexpgy(1,n1,n2,g)*z(a,b)
          
!         write(*,*) 'CalcCgy g Caux 1',rg,g,Caux
 
          if (inds0(a).ge.1) then
            inds = inds0
            inds(a) = inds(a)-1
            caux = caux + 2d0*f(b)*inds0(a)*cexpgy(1,inds(1),inds(2),g)
          end if
          
!         write(*,*) 'CalcCgy g Caux 2',rg,g,Caux
 
          inds0(at) = inds0(at)+1
          caux = caux - sgnab*zadjf(bt)*cexpgy(0,inds0(1),inds0(2),g-1)
          
!         write(*,*) 'CalcCgy g Caux 3',rg,g,Caux
 
          cexpgy(0,n1,n2,g) = caux/xadj(a,b)
 
!         write(*,*) 'CalcCgyo g Cexpgy',rg,g,n1,n2,Cexpgy(0,n1,n2,g)
 
          maxcexpgy(0,rg,g) =  maxcexpgy(0,rg,g) + abs(cexpgy(0,n1,n2,g))
          
          if (g.eq.1.and.abs(cexpgy(0,n1,n2,g)).gt.        &
              truncfacexp*max(1d0/m2scale,maxcexpgy(0,rg,g-1)).or.     &
              g.ge.2.and.abs(cexpgy(0,n1,n2,g)).gt.        &
              truncfacexp*maxcexpgy(0,rg,g-1)) then
 
#ifdef Cgytest            
            write(*,*) 'CalcCgy cycle loop',n1,n2,g,abs(cexpgy(0,n1,n2,g)),maxcexpgy(0,rg,g-1)
#endif
 
            gtrunc = g-1
            exit gloop
!           gtrunc = g
!           cycle gloop
          end if
 
!            if ((g.ge.2).and.(abs(Cexpgy(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgy(0,n1,n2,g-1)))) then
!              gtrunc = g-1
!            end if
 
        end do
 
        ! error propagation from B's
        if(rg.gt.1)then
          c00_err(rg+2) =max(c00_err(rg+2),                                       &
              max(abs(zadjf(k))*cij_err(rg+1),abs(detz)*cij_err(rg+2))/abs(zadj(k,l)))   
        end if
        cij_err(rg)= max( cij_err(rg),                                          &
            max(abs(z(a,b))*c00_err(rg+2),abs(f(b))*c00_err(rg+1),       &
            abs(zadjf(b))*cij_err(rg+1))/abs(xadj(a,b)))
 
        if(rg.gt.1)then
          c00_err2(rg+2) =max(c00_err2(rg+2),                                       &
              max(abs(zadjf(k))*cij_err2(rg+1),abs(detz)*cij_err2(rg+2))/abs(zadj(k,l)))   
        end if
        cij_err2(rg)= max( cij_err2(rg),                                          &
            max(abs(z(a,b))*c00_err2(rg+2),abs(f(b))*c00_err2(rg+1),       &
            abs(zadjf(b))*cij_err2(rg+1))/abs(xadj(a,b)))
 
#ifdef PPEXP00
        if (rg+2.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgy(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        if ((rg.le.rmax)) then
          cerr(rg) = 0d0
          do n1=0,rg
            n2=rg-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpgy(0,n1,n2,g)
            if(abs(cexpgy(0,n1,n2,g-1)).ne.0d0) then
              cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g))*min(1d0,abs(cexpgy(0,n1,n2,g))/abs(cexpgy(0,n1,n2,g-1))))
            else
              cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g)))
            end if
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg).gt.cerr(rg)) then
             gtrunc = min(g,gtrunc)
!            gtrunc = min(g+1,gtrunc)
             
#ifdef Cgytest
             write(*,*) 'CalcCgy exit err',r,g,gtrunc
#endif
 
          end if
 
        end if
        
        
      end do gloop
 
!     write(*,*) 'CalcCgy gtrunc after gloop=',gtrunc,r
 
#ifdef Cgytest
      write(*,*) 'CalcCgy Cerr r =',r
      write(*,*) 'CalcCgy Cerr r =',r,cerr
      write(*,*) 'CalcCgy Cacc r =',r,cerr/abs(c(0,0,0))
      write(*,*) 'CalcCgy Cij_err =',r,cij_err
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgytest
      write(*,*) 'CalcCgy Cerr =',r,cerr,maxval(cerr)
#endif
 
      ! check if target precision already reached
!      if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit         ! changed 28.01.15
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
          do n1=0,rg
            c(0,n1,rg-n1)=0d0
          end do
        end do
        do rg=r+1,rmax
          do n1=0,rg-2
            c(1,n1,rg-2-n1)=0d0
          end do
        end do
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
        exit rloop
      end if
 
    end do rloop
 
 
    ! calculating C_0000ijk.. exploiting eq. (5.49)
    do r=4,rmax
      do n0=2,rmax/2
        do nl=r-2*n0,0,-1
          nlt=r-2*n0-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = zadj(k,1)*shat(n0-1,inds(1),inds(2),1)  &
               + zadj(k,2)*shat(n0-1,inds(1),inds(2),2)  &
               - zadjf(k)*c(n0-1,inds(1),inds(2))
 
          inds(k) = inds(k)+1
          caux = caux - detz*c(n0-1,inds(1),inds(2))
 
          if (nlt.ge.1) then
            inds(l) = nl+1
            inds(lt) = nlt-1
            caux = caux - 2*nlt*zadj(k,lt)*c(n0,inds(1),inds(2))
          end if
 
          c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1)*zadj(k,l))
 
        end do
      end do
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
#ifdef Cgytest
    write(*,*) 'CalcCgy final err',cerr
    write(*,*) 'CalcCgy final acc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCgyo out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
#ifdef TRACECout
    write(*,*) 'CalcCgyo rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgyo out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
 
  end subroutine calccgyo
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgp(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgp_min,ordgp_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine calccgp(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgp_min,ordgp_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,ordgp_min,ordgp_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex, allocatable :: Cexpgp(:,:,:,:), CuvExpgp(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_k(:,:), Shat(:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_k(:,:)
    double complex :: Smod, fk, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max
    double precision :: maxCexpgp(0:1,0:rmax+ordgp_min+1,0:ordgp_max),truncfacexp
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,g,rg
    integer :: bin,nid(0:2),i
 
#ifdef Cgptest
    write(*,*) 'CalcCgp in ',rmax,ordgp_min,ordgp_max,id
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgp in ',rmax,ordgp_min,ordgp_max,id
#endif
 
    ! determine Gram matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
! commented out 2.9.17
!    Z(1,1) = 2d0*q10
!    Z(2,1) = q1q2
!    Z(1,2) = q1q2
!    Z(2,2) = 2d0*q20
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
 
 
    ! choose reduction formulas with biggest denominators
    if (abs(f(1)).ge.abs(f(2))) then
      k = 1
    else 
      k = 2
    end if
    fk = f(k)
 
 
    ! calculations of B-coefficients
    rmaxb = rmax + ordgp_min
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_k(0:rmaxb,0:rmaxb))
    allocate(buv_k(0:rmaxb,0:rmaxb))
 
    ! determine binaries for B-coefficients
    i=0
    bin = 1
    do while (i.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(i) = id+bin
        i = i+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    if (k.eq.1) then
      call calcb(b_k(:,:),buv_k(:,:),p20,m02,m22,rmaxb,nid(1))
    else
      call calcb(b_k(:,:),buv_k(:,:),p10,m02,m12,rmaxb,nid(2))
    end if
 
    ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
        b_max = max(b_max,abs(b_0(0,n1,n2)))
     end do
    end do
    b_max = max(b_max,maxval(abs(b_k(0,0:rmaxb))))
    b_err = acc_def_b*b_max
 
#ifdef Cgptest
    write(*,*) 'CalcCgp B_max ', b_max
#endif
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2) = -b_0(n0,n1,n2)
        end do
 
        l = r-2*n0
        if (k.eq.1) then
          shat(n0,0,l) = shat(n0,0,l) + b_k(n0,l)
        else
          shat(n0,l,0) = shat(n0,l,0) + b_k(n0,l)
        end if
 
      end do
    end do
 
        
    ! allocation of array for det(Z)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpgp(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordgp_max))
   
 
    ! calculate Cuv
    allocate(cuvexpgp(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpgp,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpgp(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
 
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
!    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))) * truncfacC
    truncfacexp = sqrt(fac_gp) * truncfacc
    gtrunc = ordgp_max 
 
#ifdef Cgptest
    write(*,*) 'CalcCgp rmaxExp',rmaxexp,rmax,gtrunc
#endif
 
! calculate C(n0,n1,n2) up to rank r for n0>0 and up to rank r-1 for n0=0
    rloop: do r=1,rmaxexp
 
#ifdef Cgptest
    write(*,*) 'CalcCgp r',r,rmax+gtrunc+1
#endif
 
 
      if (r.gt.rmax+gtrunc+1) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating
      ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
      ! exploiting eq. (5.63)
      maxcexpgp(1,r,0)=0d0
      do n0=r/2,1,-1
        do n1=0,r-2*n0
          n2=r-2*n0-n1
 
          cexpgp(n0,n1,n2,0) = (2d0*cuvexpgp(n0,n1,n2) + b_0(n0-1,n1,n2)  &
               + mm02*cexpgp(n0-1,n1,n2,0))/((r-n0)+1d0)/2d0
 
          if (n0.eq.1) then
            maxcexpgp(1,r,0) =  maxcexpgp(1,r,0) + abs(cexpgp(n0,n1,n2,0) )
          end if
 
          if (r-n0.le.rmax) then
            c(n0,n1,n2) = cexpgp(n0,n1,n2,0)
          end if
 
        end do
      end do
 
      ! calculate
      ! C_00ijkl.. --> C_aijkl..
      ! exploiting eq. (5.62)
      maxcexpgp(0,r-1,0)=0d0
      do n1=0,r-1
        n2 = r-1-n1
 
        smod = shat(0,n1,n2)
        if ((k.eq.1).and.(n1.ge.1)) then
          smod = smod - 2d0*n1*cexpgp(1,n1-1,n2,0)
        else if ((k.eq.2).and.(n2.ge.1)) then
          smod = smod - 2d0*n2*cexpgp(1,n1,n2-1,0)
        end if
 
        cexpgp(0,n1,n2,0) = smod/fk
        maxcexpgp(0,r-1,0) =  maxcexpgp(0,r-1,0) + abs(cexpgp(0,n1,n2,0))
        
        if (r.le.rmax+1) then
          c(0,n1,n2) = cexpgp(0,n1,n2,0)
        end if
 
      end do
 
      if (r.le.rmax+1) then
!       Cerr(r-1) =  abs(maxZ/fk)*maxCexpgp(0,r-1,0)
        cerr(r-1) =  fac_gp*maxcexpgp(0,r-1,0)
      end if
 
      ! error propagation from B's
      if(r.gt.1)then
        c00_err(r) = b_err/(2*r)
      end if
      cij_err(r-1) = b_err/abs(fk)
 
      if(r.gt.1)then
        c00_err2(r) = b_err/(2*r)
      end if
      cij_err2(r-1) = b_err/abs(fk)
 
#ifdef Cgptest
      write(*,*) 'CalcCgp B_err',b_err,abs(fk), cij_err(r-1),r
#endif
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r-1)
        rg = rg-1
 
        ! calculating for rank=rmaxB+1
        ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
        ! exploiting eq. (5.63)
        maxcexpgp(1,rg,g) = 0d0
        do n0=rg/2,1,-1
          do n1=0,rg-2*n0
            n2=rg-2*n0-n1
 
            cexpgp(n0,n1,n2,g) = (2d0*mm02*cexpgp(n0-1,n1,n2,g)  &
               - z(1,1)*cexpgp(n0-1,n1+2,n2,g-1) - 2d0*z(2,1)*cexpgp(n0-1,n1+1,n2+1,g-1)  &
               - z(2,2)*cexpgp(n0-1,n1,n2+2,g-1))/((rg-n0)+1d0)/4d0
 
            if(n0.eq.1) then
              maxcexpgp(1,rg,g) =  maxcexpgp(1,rg,g) + abs(cexpgp(n0,n1,n2,g))
              
 
              if (g.eq.1.and.abs(cexpgp(1,n1,n2,g)).gt.          &
                  truncfacexp*max(1d0,maxcexpgp(1,rg,g-1)) .or.  &
                  g.ge.2.and.abs(cexpgp(1,n1,n2,g)).gt.          &
                  truncfacexp*maxcexpgp(1,rg,g-1)) then
 
#ifdef Cgptest
                write(*,*) 'CalcCg exit rloop',n0,n1,n2,g,abs(cexpgp(n0,n1,n2,g)),maxcexpgp(1,rg,g-1)
#endif
 
                gtrunc = g-1
                exit gloop
              end if
            end if
 
!            if ((g.ge.2).and.(abs(Cexpgp(n0,n1,n2,g)).gt.truncfacexp*abs(Cexpgp(n0,n1,n2,g-1)))) then
!              gtrunc = g-1
!            end if
 
          end do
        end do
 
#ifndef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpgp(n0,n1,n2,g)
            end do
          end if
        end do
#endif
 
        ! calculate
        ! C_000000..00 --> C_i0000..00 --> C_ij00..00 --> ... --> C_ijk..
        ! exploiting eq. (5.62)
        maxcexpgp(0,rg-1,g) = 0d0
        do n1=0,rg-1
          n2 = rg-1-n1
          
          smod = -z(1,k)*cexpgp(0,n1+1,n2,g-1)  &
              -z(2,k)*cexpgp(0,n1,n2+1,g-1)
          if ((k.eq.1).and.(n1.ge.1)) then
            smod = smod - 2d0*n1*cexpgp(1,n1-1,n2,g)
          else if ((k.eq.2).and.(n2.ge.1)) then
            smod = smod - 2d0*n2*cexpgp(1,n1,n2-1,g)
          end if
          
          cexpgp(0,n1,n2,g) = smod/fk
          
          maxcexpgp(0,rg-1,g) =  maxcexpgp(0,rg-1,g) + abs(cexpgp(0,n1,n2,g))
          
          if (g.eq.1.and.abs(cexpgp(0,n1,n2,g)).gt.                     &
              truncfacexp*max(1/m2max,maxcexpgp(0,rg-1,g-1))    .or.    &
              g.ge.2.and.abs(cexpgp(0,n1,n2,g)).gt.                     &
              truncfacexp*maxcexpgp(0,rg-1,g-1)) then
 
#ifdef Cgptest
            write(*,*) 'CalcCgp exit gloop',0,n1,n2,g,abs(cexpgp(0,n1,n2,g)),maxcexpgp(0,rg,g-1)
#endif
            gtrunc = g-1
            exit gloop
          end if
          
        end do
 
        ! error propagation from B's
        if(rg.gt.1)then
          c00_err(rg) = max(c00_err(rg),max(2*abs(m02)*cij_err(rg-2),maxz*cij_err(rg))/(4*r) )
        end if
        cij_err(rg-1) = max(cij_err(rg-1),max(2*c00_err(rg),maxz*cij_err(rg))/abs(fk) )
 
        if(rg.gt.1)then
          c00_err2(rg) = max(c00_err2(rg),max(2*abs(m02)*cij_err2(rg-2),maxz*cij_err2(rg))/(4*r) )
        end if
        cij_err2(rg-1) = max(cij_err2(rg-1),max(2*c00_err2(rg),maxz*cij_err2(rg))/abs(fk) )
 
#ifdef PPEXP00
        do n0=rg/2,1,-1
          if (rg-n0.le.rmax) then
            do n1=0,rg-2*n0
              n2=rg-2*n0-n1
              c(n0,n1,n2) = c(n0,n1,n2) + cexpgp(n0,n1,n2,g)
            end do
          end if
        end do
#endif
 
        if ((rg.le.rmax+1)) then
          cerr(rg-1) = 0d0
          do n1=0,rg-1
            n2=rg-1-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpgp(0,n1,n2,g)
!            Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpgp(0,n1,n2,g))**2/abs(Cexpgp(0,n1,n2,g-1)))
            if(abs(cexpgp(0,n1,n2,g-1)).ne.0d0) then
              cerr(rg-1)=max(cerr(rg-1),abs(cexpgp(0,n1,n2,g))*min(1d0,abs(cexpgp(0,n1,n2,g))/abs(cexpgp(0,n1,n2,g-1))))
            else
              cerr(rg-1)=max(cerr(rg-1),abs(cexpgp(0,n1,n2,g)))
            end if
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg-1).gt.cerr(rg-1)) then
             gtrunc = min(g,gtrunc)
             
#ifdef Cgptest
             write(*,*) 'CalcCgp exit err',r,g,gtrunc
#endif
 
          end if
 
        end if
 
      end do gloop
 
#ifdef Cgptest
      write(*,*) 'CalcCgp Cerr r =',r,cerr
      write(*,*) 'CalcCgp Cacc r =',r,cerr/abs(c(0,0,0))
      write(*,*) 'CalcCgp Cij_err =',r,cij_err
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
      
#ifdef Cgptest
      write(*,*) 'CalcCgp Cerr =',r,cerr,maxval(cerr)
      write(*,*) 'CalcCgp accr =',r,acc_req_cr*abs(c(0,0,0)),maxval(acc_req_cr*abs(c(0,0,0)))
      write(*,*) 'CalcCgp C-ar =',r,cerr-acc_req_cr*abs(c(0,0,0)),maxval(cerr-acc_req_cr*abs(c(0,0,0)))
#endif
 
      ! check if target precision already reached
!      if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit    ! changed 28.01.15
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
          do n0=0,rg/2
            do n1=0,rg-2*n0
              c(n0,n1,rg-2*n0-n1)=0d0
            end do
          end do
        end do
        if(r.le.rmax) then
          do n1=0,r
            c(0,n1,r-n1)=0d0
          end do
        end if   
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
#endif
!       write(*,*) 'CalcCg exit rloop  =',r,rmax,rg
 
        exit rloop
      end if
 
!      write(*,*) 'CalcCgp after exit'
 
    end do rloop
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
#ifdef Cgptest
    write(*,*) 'CalcCgp final err',cerr
    write(*,*) 'CalcCgp final acc',cerr/abs(c(0,0,0))
#endif
              
#ifdef TRACECout
    write(*,*) 'CalcCgp rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgp out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!   write(*,*) 'CalcCgp rmax',rmax
!   do r=14,rmax
!    do r=0,rmax
!   do n0=0,r/2
!   do n1=0,r-2*n0
!   write(*,*) 'CalcCgp out',r,n0,n1,r-2*n0-n1,C(n0,n1,r-2*n0-n1)
!   end do
!   end do
!   end do
 
!    write(*,*) 'CalcCgp Cerr ',Cerr
!    write(*,*) 'CalcCgp Cerr2',Cerr2
 
  end subroutine calccgp
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CalcCgpf(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgpf_min,ordgpf_max,id,Cerr,acc_req_Cr,Cerr2)
  !
  !  added by AD  16.08.2017
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
  subroutine calccgpf(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgpf_min,ordgpf_max,id,Cerr,acc_req_Cr,Cerr2)
  
    use globalc
  
    integer, intent(in) :: rmax,ordgpf_min,ordgpf_max,id
    double complex, intent(in) :: p10,p21,p20,m02,m12,m22
    double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
    double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
    double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
    double precision, intent(in) :: acc_req_Cr(0:rmax)
    double complex, allocatable :: Cexpgpf(:,:,:,:), CuvExpgpf(:,:,:)
    double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
    double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
    double complex :: Smod, Caux, Zadj2f
    double complex :: C0_coli, elimminf2_coli
    double precision, allocatable :: C00_err(:),Cij_err(:)
    double precision, allocatable :: C00_err2(:),Cij_err2(:)
    double precision :: B_err,B_max,aZadj2f
    double precision :: maxCexpgpf(0:1,0:rmax+2*ordgpf_min,0:ordgpf_max),truncfacexp
    double precision :: minZk 
    integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,i,j,jt,g,rg
    integer :: inds0(2),inds(2),k,l,lt,nl,nlt
    integer :: bin,nid(0:2)
 
#ifdef Cgpftest
    write(*,*) 'CalcCgpf in ',rmax,ordgpf_min,ordgpf_max,id
    write(*,*) 'CalcCgpf in ',p10,p21,p20,m02,m12,m22
#endif
#ifdef TRACECin
    write(*,*) 'CalcCgpf in ',rmax,ordgpf_min,ordgpf_max,id
#endif
 
    ! write(*,*) 'LH: CalcCgpf, ord', ordgpf_min
    ! calculation of B-coefficients
    rmaxb = rmax + 2*ordgpf_min + 1
    allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
    allocate(b_i(0:rmaxb,0:rmaxb,2))
    allocate(buv_i(0:rmaxb,0:rmaxb,2))
 
    ! determine binaries for B-coefficients
    k=0
    bin = 1
    do while (k.le.2)
      if (mod(id/bin,2).eq.0) then
        nid(k) = id+bin
        k = k+1
      end if
      bin = 2*bin
    end do
 
    call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
    call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
    call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
 
   ! shift of integration momentum in B_0
    b_max=0d0
    do n1=1,rmaxb
      do n2=0,rmaxb-n1
        n0 = (rmaxb-n1-n2)
        b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
        buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
      end do
    end do
    b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
    b_err = acc_def_b*b_max
 
    ! determine (adjugated) Gram and Cayley matrix
!    mm02 = elimminf2_coli(m02)
!    mm12 = elimminf2_coli(m12)
!    mm22 = elimminf2_coli(m22)
!    q10  = elimminf2_coli(p10)
!    q21  = elimminf2_coli(p21)
!    q20  = elimminf2_coli(p20)
!
!    q1q2 = (q10+q20-q21)
!    detZ = 4d0*q10*q20-q1q2*q1q2
 
    if (abs(detz).lt.abs(4d0*q10*q20 + z(2,1)*z(2,1))*1d-4) then
      if (abs(q10-q20).lt.abs(q10-q21).and.  &
          abs(q10-q20).lt.abs(q20-q21)) then
        detz  =  4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
      end if
    end if
 
!    Zadj(1,1) = 2d0*q20
!    Zadj(2,1) = -q1q2
!    Zadj(1,2) = -q1q2
!    Zadj(2,2) = 2d0*q10
!    f(1) = q10+mm02-mm12
!    f(2) = q20+mm02-mm22
!
!    Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
!    Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
!
! Xadj(1,1) and Xadj(2,2) exchanged!!!
!    Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
!    Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
!    Xadj(1,2) = Xadj(2,1)
!    Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
 
 
    ! coefficients Shat defined in (5.13)
    allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
 
    do r=0,rmaxb
      do n0=0,r/2
 
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
        end do
 
        k = r-2*n0
        shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
        shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
 
      end do
    end do
 
    ! choose reduction formulas with smallest expansion terms
    minzk = maxz
    if (maxval(abs(z(1,1:2))).le.minzk) then
      minzk = maxval(abs(z(1,1:2)))
      k = 1
      l = 1
      lt = 2
    end if
    if (maxval(abs(z(2,1:2))).lt.minzk) then
      minzk = maxval(abs(z(2,1:2)))
      k = 2
      l = 2
      lt = 1 
    end if
 
#ifdef Cgpftest
    write(*,*) 'CalcCgpf: minZk',k,minzk
#endif
 
!   write(*,*)  'CalcCgpf Zadj(i,j)=',i,j,Zadj(i,j),Xadj(i,j)
        
    ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
    rmaxexp = rmaxb+1
    allocate(cexpgpf(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgpf_max))
   
    ! calculate Cuv
    allocate(cuvexpgpf(0:rmaxexp,0:rmaxexp,0:rmaxexp))
    call calccuv(cuvexpgpf,buv_0,mm02,f,rmaxexp,id)
    cuv(0:rmax,0:rmax,0:rmax) = cuvexpgpf(0:rmax,0:rmax,0:rmax)
 
    ! allocate arrays for error propagation
    allocate(c00_err(0:rmaxexp))
    allocate(cij_err(0:rmaxexp))
    allocate(c00_err2(0:rmaxexp))
    allocate(cij_err2(0:rmaxexp))
 
    ! initialize accuracy estimates
    cerr = acc_inf
    cij_err =0d0
    c00_err =0d0
 
    cerr2 = acc_inf
    cij_err2 =0d0
    c00_err2 =0d0
 
!    maxZadjf = maxval(abs(Zadjf))
!    fmax = maxval(abs(f))
 
    ! truncation of expansion if calculated term larger than truncfacexp * previous term
    ! crucial for expansion parameters between 0.1 and 1 !!!
!    truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(i,j))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
    truncfacexp = sqrt(fac_gpf) * truncfacc
    gtrunc = ordgpf_max 
 
#ifdef Cgpftest            
    write(*,*) 'CalcCgpf: gtrunc orig=',gtrunc
    write(*,*) 'CalcCgpf: rmaxExp-2=',rmaxexp-2
#endif
 
! calculate C(1,n1,n2) up to rank r+2
! calculate C(0,n1,n2) up to rank r  
    rloop: do r=0,rmaxexp-2
 
#ifdef Cgpftest            
      write(*,*) 'CalcCgpf: rloop=',r,rmaxexp-2,rmax+2*gtrunc+2
      write(*,*) 'CalcCgpf: rloop=',rmax,gtrunc
#endif
 
      if (r.gt.rmax+2*gtrunc+2) exit rloop
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! 0th-order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      ! calculating C_00ijk.. exploiting eq. (5.71)
      maxcexpgpf(1,r,0)=0d0
      do nl=r,0,-1
        nlt=r-nl
        inds0(l) = nl
        inds0(lt) = nlt
 
        inds(l) = nl+1
        inds(lt) = nlt
 
        caux = shat(0,inds(1),inds(2),k)
 
        cexpgpf(1,inds0(1),inds0(2),0) = caux/(2*(nl+1))
        maxcexpgpf(1,r,0) =  maxcexpgpf(1,r,0) + abs(cexpgpf(1,inds0(1),inds0(2),0) )
!        if (r+2.le.rmax) then             !  for fixed rank
        if (r+1.le.rmax) then
          c(1,inds0(1),inds0(2)) = cexpgpf(1,inds0(1),inds0(2),0)
        end if
 
      end do
 
      ! calculate C_ijkl.. exploiting eq. (5.72)
      maxcexpgpf(0,r,0)=0d0
      do n1=0,r
        n2 = r-n1
        inds(1) = n1
        inds(2) = n2
      
        caux = 2*(4+r+r)*cexpgpf(1,n1,n2,0) - 4*cuvexpgpf(1,n1,n2)  &
             - 2*b_0(0,n1,n2)
 
        cexpgpf(0,n1,n2,0) = caux/(2d0*m02)
 
        maxcexpgpf(0,r,0) =  maxcexpgpf(0,r,0) + abs(cexpgpf(0,n1,n2,0))
        if (r.le.rmax) then
          c(0,n1,n2) = cexpgpf(0,n1,n2,0)
        end if
 
      end do
 
      if (r.le.rmax) then
!       Cerr(r) =  abs(maxZadjf/Xadj(i,j))*maxCexpgpf(0,r,0)
        cerr(r) =  fac_gpf*maxcexpgpf(0,r,0)
 
!        write(*,*) 'CalcCgpf Cerr,0 ',r,Cerr(r),fac_gpf,maxCexpgpf(0,r,0)
 
      end if
 
 ! error propagation from B's
      c00_err(r+2) = b_err /2d0               
      cij_err(r) = max(b_err,2*(r+2)*c00_err(r+2))/abs(m02)
 
      c00_err2(r+2) = b_err /2d0               
      cij_err2(r) = max(b_err,2*(r+2)*c00_err2(r+2))/abs(m02)
      
 
#ifdef Cgpftest
      write(*,*) 'CalcCgpf leading terms r =',r
      write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:r)
      write(*,*) 'CalcCgpf Cexp0(1,0,0)=',r,c(1,0,0),cexpgpf(1,0,0,0)
      write(*,*) 'CalcCgpf Cexp0(0,0,0)=',r,c(0,0,0),cexpgpf(0,0,0,0)
#endif
 
 
 
 
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      ! higher order coefficients
      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
      rg = r
      gloop: do g=1,min(gtrunc,r/2)
        rg = rg-2
 
        ! calculating C_00ijk.. exploiting eq. (5.71)
        maxcexpgpf(1,rg,g) = 0d0
        do nl=rg,0,-1
          nlt=rg-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = -f(k)*cexpgpf(0,inds(1),inds(2),g-1)
 
          inds(l) = inds(l)+1
          caux = caux - z(k,l)*cexpgpf(0,inds(1),inds(2),g-1)
 
          inds(l) =  inds(l)-1
          inds(lt) =  inds(lt)+1
          caux = caux - z(k,lt)*cexpgpf(0,inds(1),inds(2),g-1)
 
          cexpgpf(1,inds0(1),inds0(2),g) = caux/(2*(nl+1))
 
          maxcexpgpf(1,rg,g) =  maxcexpgpf(1,rg,g) + abs(cexpgpf(1,inds0(1),inds0(2),g) )
 
          if (g.eq.1.and.abs(cexpgpf(1,inds0(1),inds0(2),g)).gt.      &
                  truncfacexp*max(1d0,maxcexpgpf(1,rg,g-1))    .or.   &
                  g.ge.2.and.abs(cexpgpf(1,inds0(1),inds0(2),g)).gt.  &
                  truncfacexp*maxcexpgpf(1,rg,g-1)) then
#ifdef Cgpftest            
            write(*,*) 'CalcCgpf exit gloop',n1,n2,g,abs(cexpgpf(1,inds0(1),inds0(2),g)),maxcexpgpf(1,rg,g-1)
            write(*,*) 'CalcCgpf exit gloop',g,rg,inds0(1),inds0(2)
#endif
 
            gtrunc = g-1
            exit gloop
 
          end if 
        
        end do
 
#ifndef PPEXP00
!        if (rg+2.le.rmax) then            !  for fixed rank
        if (rg+1.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgpf(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        ! calculate C_ijkl.. exploiting eq. (5.72)
        maxcexpgpf(0,rg,g) = 0d0
        do n1=0,rg
          n2 = rg-n1
          inds(1) = n1
          inds(2) = n2
          
          caux = 2*(4+rg+rg)*cexpgpf(1,n1,n2,g)
          
          do i=1,2
          do j=1,2
            inds(i)=inds(i)+1
            inds(j)=inds(j)+1 
            caux = caux + z(i,j)*cexpgpf(0,inds(1),inds(2),g-1)
            inds(i)=inds(i)-1
            inds(j)=inds(j)-1  
          end do
          end do
 
          cexpgpf(0,n1,n2,g) = caux/(2*m02)
 
          maxcexpgpf(0,rg,g) =  maxcexpgpf(0,rg,g) + abs(cexpgpf(0,n1,n2,g))
          
          if (g.eq.1.and.abs(cexpgpf(0,n1,n2,g)).gt.        &
              truncfacexp*max(1d0/m2scale,maxcexpgpf(0,rg,g-1)).or.     &
              g.ge.2.and.abs(cexpgpf(0,n1,n2,g)).gt.        &
              truncfacexp*maxcexpgpf(0,rg,g-1)) then
 
#ifdef Cgpftest            
            write(*,*) 'CalcCgpf exit gloop',n1,n2,g,rg
            write(*,*) 'CalcCgpf exit gloop',abs(cexpgpf(0,n1,n2,g)),maxcexpgpf(0,rg,g-1),1d0/m2scale
            write(*,*) 'CalcCgpf exit gloop',truncfacexp
#endif
 
            gtrunc = g-1
            exit gloop
 
          end if
 
!            if ((g.ge.2).and.(abs(Cexpgpf(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgpf(0,n1,n2,g-1)))) then
!              gtrunc = g-1
!            end if
 
        end do
 
#ifdef Cgpftest
        write(*,*) 'CalcCgpf expansion terms r =',r,g,rg
        write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:r)
        write(*,*) 'CalcCgpf Cexp(1,0,0)=',r,g,cexpgpf(1,0,0,g)
        write(*,*) 'CalcCgpf Cexp(0,0,0)=',r,g,cexpgpf(0,0,0,g)
#endif
 
        ! error propagation from B's
        if(rg.gt.1)then
          c00_err(rg+2) =max(c00_err(rg+2),                           &
              fmax/2d0*cij_err(rg+1),                                 &
              maxz/2d0*cij_err(rg+2))   
        end if
 
#ifdef Cgpftest
        write(*,*) 'CalcCgpf test2',rg,i,j,cij_err(rg)
        write(*,*) 'CalcCgpf test2',rg,cij_err(rg+1),c00_err(rg+1)
#endif
 
        cij_err(rg)= max( cij_err(rg),                                &
            2*(rg+2)/abs(m02)*c00_err(rg+2),                          &
            maxz/(2*abs(m02))*cij_err(rg+2))
 
        if(rg.gt.1)then
          c00_err2(rg+2) =max(c00_err2(rg+2),                         &
              fmax/2d0*cij_err(rg+1),                                 &
              maxz/2d0*cij_err(rg+2))   
        end if
 
        cij_err2(rg)= max( cij_err2(rg),                              &
            2*(rg+2)/abs(m02)*c00_err2(rg+2),                         &
            maxz/(2*abs(m02))*cij_err2(rg+2))
 
#ifdef PPEXP00
!        if (rg+2.le.rmax) then             !   for fixed rank
        if (rg+1.le.rmax) then
          do nl=rg,0,-1
            nlt=rg-nl
            inds0(l) = nl
            inds0(lt) = nlt
            c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2))  &
                + cexpgpf(1,inds0(1),inds0(2),g)
          end do
        end if
#endif
 
        if ((rg.le.rmax)) then
          cerr(rg) = 0d0
          do n1=0,rg
            n2=rg-n1
            c(0,n1,n2) = c(0,n1,n2) + cexpgpf(0,n1,n2,g)
 
#ifdef Cgpftest
            write(*,*) 'CalcCgpf test1',rg,n1,n2,cerr(rg)
            write(*,*) 'CalcCgpf test1',cexpgpf(0,n1,n2,g)
            write(*,*) 'CalcCgpf test1',cexpgpf(0,n1,n2,g-1)
#endif
 
            if(abs(cexpgpf(0,n1,n2,g-1)).ne.0d0) then
              cerr(rg)=max(cerr(rg),abs(cexpgpf(0,n1,n2,g))*min(1d0,abs(cexpgpf(0,n1,n2,g))/abs(cexpgpf(0,n1,n2,g-1))))
            else
              cerr(rg)=max(cerr(rg),abs(cexpgpf(0,n1,n2,g)))
            end if
 
#ifdef Cgpftest
            write(*,*) 'CalcCgpf test1',cerr(rg)            
#endif
 
#ifdef Cgpftest
            write(*,*) 'CalcCgpf expansion terms r =',r,g,rg
            write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:min(r,rmax))
            write(*,*) 'CalcCgpf Cerr    =',r,cerr(0:min(r,rmax))
            write(*,*) 'CalcCgpf C(1,0,0)=',r,c(1,0,0)
            write(*,*) 'CalcCgpf C(0,0,0)=',r,c(0,0,0)
#endif
 
          end do
 
          ! if error from B's larger than error from expansion stop expansion
          if(cij_err(rg).gt.cerr(rg)) then
             gtrunc = min(g,gtrunc)
!            gtrunc = min(g+1,gtrunc)
             
#ifdef Cgpftest
             write(*,*) 'CalcCgpf adjust gtrunc',r,g,gtrunc
#endif
 
          end if
 
        end if
        
      end do gloop
 
!     write(*,*) 'CalcCgpf gtrunc aft gloop=',gtrunc,r
 
#ifdef Cgpftest
      write(*,*) 'CalcCgpf Cerr r =',r
      write(*,*) 'CalcCgpf Cerr r =',r,cerr(0:min(r,rmax))
      write(*,*) 'CalcCgpf Cacc r =',r,cerr/abs(c(0,0,0))
      write(*,*) 'CalcCgpf Cij_err =',r,cij_err
      write(*,*) 'CalcCgpf C(1,0,0)=',r,c(1,0,0)
      write(*,*) 'CalcCgpf C(0,0,0)=',r,c(0,0,0)
      if(rmax.ge.1.and.r.ge.1) then
      write(*,*) 'CalcCgpf C(0,1,0)=',r,c(0,1,0)
      if(rmax.ge.2.and.r.ge.2) then
      write(*,*) 'CalcCgpf C(0,1,1)=',r,c(0,1,1)
      if(rmax.ge.3.and.r.ge.3) then
      write(*,*) 'CalcCgpf C(0,1,2)=',r,c(0,1,2)
      if(rmax.ge.4) then
      write(*,*) 'CalcCgpf C(0,0,4)=',r,c(0,0,4)
      endif
      endif
      endif
      endif
#endif
 
      cerr2 = max(cerr,cij_err2(0:rmax))
      cerr = max(cerr,cij_err(0:rmax))
 
#ifdef Cgpftest
      write(*,*) 'CalcCgpf Cerr =',r,cerr,maxval(cerr)
#endif
 
      ! check if target precision already reached
!      if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit         ! changed 28.01.15
#ifdef Cutrloop
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
        do rg=r+1,rmax
          do n1=0,rg
            c(0,n1,rg-n1)=0d0
          end do
        end do   
        do rg=r+1,rmax
          do n1=0,rg-2
            c(1,n1,rg-2-n1)=0d0
          end do
        end do   
#else
      if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
#endif
 
#ifdef Cgpftest
        write(*,*) 'CalcCgpf exit rloop',r,cerr,maxval(cerr)
#endif
 
        exit rloop 
 
      end if
 
    end do rloop
 
 
    ! calculating C_0000ijk.. exploiting eq. (5.71)
    do r=4,rmax
!      do n0=2,rmax/2     !     for fixed rank
      do n0=2,rmax
        do nl=r-2*n0,0,-1
          nlt=r-2*n0-nl
          inds0(l) = nl
          inds0(lt) = nlt
 
          inds(l) = nl+1
          inds(lt) = nlt
          caux = shat(n0-1,inds(1),inds(2),k)            &
                 - f(k)*c(n0-1,inds(1),inds(2))          &
                 - z(k,1)*c(n0-1,inds(1)+1,inds(2))      &
                 - z(k,2)*c(n0-1,inds(1),inds(2)+1)        
 
          c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1))
 
        end do
      end do
    end do
 
      ! reduction formula (5.10) for n0+n1+n2=r, n0>0 
    do r=rmax+1,2*rmax
      do n0=r-rmax,r/2
        do n1=0,r-2*n0
          n2 = r-2*n0-n1
          c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
                        + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
        end do
      end do
    end do
 
#ifdef Cgpftest
    write(*,*) 'CalcCgpf final err',cerr
    write(*,*) 'CalcCgpf final acc',cerr/abs(c(0,0,0))
#endif
 
!   write(*,*) 'CalcCgpf out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
#ifdef TRACECout
    write(*,*) 'CalcCgpf rmax',rmax
    do r=14,rmax
    do n0=0,r/2
    do n1=0,r-2*n0
    write(*,*) 'CalcCgpf out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
    end do
    end do
    end do   
#endif
 
!    write(*,*) 'CalcCgpf Cerr ',Cerr
!    write(*,*) 'CalcCgpf Cerr2',Cerr2
 
  end subroutine calccgpf
 
 
 
 
 
 
 
 
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !  subroutine CopyCimp3(C,C_alt,Cerr,Cerr_alt,Cerr1,Cerr1_alt,Cerr2,Cerr2_alt,Crmethod,Crmethod_alt,rmax)
  !
  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
  subroutine copycimp3(C,C_alt,Cerr,Cerr_alt,Cerr1,Cerr1_alt,Cerr2,Cerr2_alt,Crmethod,Crmethod_alt,rmax,r_alt)
 
    integer,   intent(in) :: rmax,r_alt
    double complex, intent(inout) :: C(0:rmax,0:rmax,0:rmax)
    double precision, intent(inout) :: Cerr(0:rmax),Cerr1(0:rmax),Cerr2(0:rmax)
    integer, intent(inout) :: Crmethod(0:rmax)
    double complex, intent(in) :: C_alt(0:r_alt,0:r_alt,0:r_alt)
    double precision, intent(in) :: Cerr_alt(0:r_alt),Cerr2_alt(0:r_alt),Cerr1_alt(0:r_alt)
    integer, intent(in) :: Crmethod_alt(0:rmax)
 
    integer :: r,n1,n0
 
!    write(*,*) 'CopyCimp3: Cerr =',Cerr
!    write(*,*) 'CopyCimp3: Cerr_alt =',Cerr_alt
 
    do r=0,r_alt
      if (cerr_alt(r).lt.cerr(r)) then
        crmethod(r)=crmethod_alt(r)
        cerr(r)=cerr_alt(r)
        cerr1(r)=cerr1_alt(r)
        cerr2(r)=cerr2_alt(r)
        forall (n0=0:r)
          forall (n1=0:r-n0)
            c(n0,n1,r-n0-n1) = c_alt(n0,n1,r-n0-n1)
          end forall
        end forall
!        forall (n1=0:r)
!          forall (n2=0:r-n1)
!            C((r-n1-n2)/2,n1,n2) = C_alt((r-n1-n2)/2,n1,n2)
!          end forall
!        end forall
      end if
    end do
 
   end subroutine copycimp3
 
 
end module reductionc