JHUGen MELA  JHUGen v7.5.6, MELA v2.4.2
Matrix element calculations as used in JHUGen.
Functions/Subroutines | Variables
reductiond Module Reference

Functions/Subroutines

subroutine calcd (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr1, Derr2)
 
subroutine calcdred (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr1, Derr2)
 
subroutine calcduv (Duv, Cuv_0, m02, f, rmax, id)
 
subroutine calcdpv1 (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr, Derr2)
 
subroutine calcdpv1o (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr, Derr2)
 
subroutine calcdpv (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr, Derr2)
 
subroutine calcdpv2 (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, id, Derr, Derr2)
 
subroutine calcdg (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordg_min, ordg_max, id, Derr, Derr2)
 
subroutine calcdgr (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordgr_min, ordgr_max, id, Derr, Derr2)
 
subroutine calcdgx (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordgx_min, ordgx_max, id, Derr, Derr2)
 
subroutine calcdgy (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordgy_min, ordgy_max, id, Derr, Derr2)
 
subroutine calcdgp (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordgp_min, ordgp_max, id, Derr, Derr2)
 
subroutine calcdgpf (D, Duv, p10, p21, p32, p30, p20, p31, m02, m12, m22, m32, rmax, ordgpf_min, ordgpf_max, id, Derr, Derr2)
 
subroutine copydimp3 (D, D_alt, Derr, Derr_alt, Derr1, Derr1_alt, Derr2, Derr2_alt, Drmethod, Drmethod_alt, rmax, r_alt)
 

Variables

double precision, parameter truncfacd = 1d2
 

Function/Subroutine Documentation

◆ calcd()

subroutine reductiond::calcd ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr1,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 94 of file reductionD.F90.

94 
95  integer, intent(in) :: rmax,id
96  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
97  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
98  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
99  double precision, intent(out) :: Derr1(0:rmax),Derr2(0:rmax)
100  double complex, allocatable :: Daux(:,:,:,:), Duvaux(:,:,:,:), fct(:)
101  double precision, allocatable :: Derr1aux(:),Derr2aux(:)
102  double complex :: x(10)
103  integer :: rank,switch,cnt,n0,n1,n2,n3,r
104  logical :: nocalc,wrica
105 
106 ! write(*,*) 'CalcD in'
107 ! write(*,*) 'CalcD in with Derr'
108 
109  if (use_cache_system) then
110  if ((ncache.gt.0).and.(ncache.le.ncache_max)) then
111 ! if (use_cache(ncache).ge.4) then
112  x(1)=p10
113  x(2)=p21
114  x(3)=p32
115  x(4)=p30
116  x(5)=p20
117  x(6)=p31
118  x(7)=m02
119  x(8)=m12
120  x(9)=m22
121  x(10)=m32
122  rank = rmax
123  switch = 0
124 
125  if(rmax.ge.3) then
126  allocate(fct(ncoefsg(rmax,4)-ncoefs(rmax-2,4)+ncoefs(rmax-3,4)+2*(rmax+1)))
127  call readcache(fct,ncoefsg(rmax,4)-ncoefs(rmax-2,4)+ncoefs(rmax-3,4)+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
128  else if(rmax.eq.2) then
129  allocate(fct(ncoefsg(rmax,4)-1+2*(rmax+1)))
130  call readcache(fct,ncoefsg(rmax,4)-1+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
131  else
132  allocate(fct(ncoefsg(rmax,4)+2*(rmax+1)))
133  call readcache(fct,ncoefsg(rmax,4)+2*(rmax+1),x,10,1,id,4,rank,nocalc,wrica)
134  end if
135 
136  if(nocalc)then
137  cnt = 0
138  duv(0:min(rmax/2,1),:,:,:) = 0d0
139  do r=0,rmax
140  do n1=0,r
141  do n2=0,r-n1
142  n3=r-n1-n2
143  cnt = cnt+1
144  d(0,n1,n2,n3) = fct(cnt)
145  end do
146  end do
147  do n0=1,(r+1)/2
148  do n1=0,r-2*n0+1
149  do n2=0,r-2*n0-n1+1
150  n3=r-2*n0-n1-n2+1
151 
152  cnt = cnt+1
153  d(n0,n1,n2,n3) = fct(cnt)
154  end do
155  end do
156  end do
157 
158  do n0=2,(r+1)/2
159  do n1=0,r-2*n0+1
160  do n2=0,r-2*n0-n1+1
161  n3=r-2*n0-n1-n2+1
162 
163  cnt = cnt+1
164  duv(n0,n1,n2,n3) = fct(cnt)
165  end do
166  end do
167  end do
168  cnt = cnt+1
169  derr1(r) = real(fct(cnt))
170  cnt = cnt+1
171  derr2(r) = real(fct(cnt))
172  end do
173 ! write(*,*) 'Dcache', id, rank, D(0,rank,0,0)
174  return
175  end if
176 
177 
178  if(rank.eq.rmax) then
179 
180  call calcdred(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rank,id,derr1,derr2)
181 ! write(*,*) 'Dcalc', id, rank, D(0,rank,0,0)
182 
183  if (wrica) then
184  cnt = 0
185  do r=0,rank
186  do n1=0,r
187  do n2=0,r-n1
188  n3 = r-n1-n2
189  cnt = cnt+1
190  fct(cnt) = d(0,n1,n2,n3)
191  end do
192  end do
193  do n0=1,(r+1)/2
194  do n1=0,r-2*n0+1
195  do n2=0,r-2*n0-n1+1
196  n3 = r-2*n0-n1-n2+1
197  cnt = cnt+1
198  fct(cnt) = d(n0,n1,n2,n3)
199  end do
200  end do
201  end do
202  do n0=2,(r+1)/2
203  do n1=0,r-2*n0+1
204  do n2=0,r-2*n0-n1+1
205  n3 = r-2*n0-n1-n2+1
206  cnt = cnt+1
207  fct(cnt) = duv(n0,n1,n2,n3)
208  end do
209  end do
210  end do
211  cnt = cnt+1
212  fct(cnt) = derr1(r)
213  cnt = cnt+1
214  fct(cnt) = derr2(r)
215  end do
216 
217  if(rank.ge.3) then
218  call writecache(fct,ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1),id,4,rank)
219  else if(rank.eq.2) then
220  call writecache(fct,ncoefsg(rank,4)-1+2*(rank+1),id,4,rank)
221  else
222  call writecache(fct,ncoefsg(rank,4)+2*(rank+1),id,4,rank)
223  end if
224 
225  end if
226 
227  return
228 
229 
230  else
231  allocate(daux(0:rank,0:rank,0:rank,0:rank))
232  allocate(duvaux(0:rank,0:rank,0:rank,0:rank))
233  allocate(derr1aux(0:rank))
234  allocate(derr2aux(0:rank))
235 
236  call calcdred(daux,duvaux,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rank,id,derr1aux,derr2aux)
237 
238  if (wrica) then
239  cnt = 0
240  deallocate(fct)
241  if(rank.ge.3) then
242  allocate(fct(ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1)))
243  else if(rank.eq.2) then
244  allocate(fct(ncoefsg(rank,4)-1+2*(rank+1)))
245  else
246  allocate(fct(ncoefsg(rank,4)+2*(rank+1)))
247  end if
248  do r=0,rank
249 ! do n0=0,r
250  do n0=0,r/2+1
251  do n1=0,r-n0
252  do n2=0,r-n0-n1
253  n3 = r-n0-n1-n2
254 
255  cnt = cnt+1
256  fct(cnt) = daux(n0,n1,n2,n3)
257 
258  end do
259  end do
260  end do
261  do n0=2,r/2+1
262  do n1=0,r-n0
263  do n2=0,r-n0-n1
264  n3 = r-n0-n1-n2
265 
266  cnt = cnt+1
267  fct(cnt) = duvaux(n0,n1,n2,n3)
268 
269  end do
270  end do
271  end do
272  cnt = cnt+1
273  fct(cnt) = derr1aux(r)
274  cnt = cnt+1
275  fct(cnt) = derr2aux(r)
276  end do
277 
278  if(rank.ge.3) then
279  call writecache(fct,ncoefsg(rank,4)-ncoefs(rank-2,4)+ncoefs(rank-3,4)+2*(rank+1),id,4,rank)
280  else if(rank.eq.2) then
281  call writecache(fct,ncoefsg(rank,4)-1+2*(rank+1),id,4,rank)
282  else
283  call writecache(fct,ncoefsg(rank,4)+2*(rank+1),id,4,rank)
284  end if
285 
286  end if
287 
288  d = daux(0:rmax,0:rmax,0:rmax,0:rmax)
289  duv = duvaux(0:rmax,0:rmax,0:rmax,0:rmax)
290  derr1 = derr1aux(0:rmax)
291  derr2 = derr2aux(0:rmax)
292 
293  deallocate(daux)
294  deallocate(duvaux)
295  deallocate(derr1aux)
296  deallocate(derr2aux)
297 
298  return
299 
300 ! end if
301  end if
302  end if
303  end if
304 
305  call calcdred(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
306 
307 

◆ calcdg()

subroutine reductiond::calcdg ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordg_min,
integer, intent(in)  ordg_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 4319 of file reductionD.F90.

4319 
4320  use globald
4321 
4322  integer, intent(in) :: rmax,ordg_min,ordg_max,id
4323  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
4324  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
4325  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
4326  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
4327  double complex :: Zadjfj,Zadj2(4), Zadjkl, Xtilde
4328  double complex, allocatable :: Dexpg(:,:,:,:,:), DuvExpg(:,:,:,:)
4329  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
4330  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
4331  double complex, allocatable :: D_alt(:,:,:,:)
4332  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
4333  double complex :: Smod(3), Skl, DexpgAux
4334  double complex :: cC0f, elimminf2_coli
4335  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
4336  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
4337  double precision :: maxDexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
4338  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg
4339  integer :: inds0(3), inds(3), inds2(2,4)
4340  integer :: bin,nid(0:3)
4341  logical :: errorwriteflag
4342 
4343 #ifdef Dgtest
4344  write(*,*) 'CalcDg in, ord',rmax,ordg_min,ordg_max
4345 #endif
4346 
4347  ! allocation of C functions
4348  rmaxc = rmax + ordg_min
4349  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
4350  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
4351  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
4352  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
4353  allocate(cerr_i(0:rmaxc,0:3))
4354  allocate(cerr2_i(0:rmaxc,0:3))
4355  allocate(acc_req_cextra(0:rmaxc))
4356 
4357  ! determine binaries for C-coefficients
4358  k=0
4359  bin = 1
4360  do while (k.le.3)
4361  if (mod(id/bin,2).eq.0) then
4362  nid(k) = id+bin
4363  k = k+1
4364  end if
4365  bin = 2*bin
4366  end do
4367 
4368  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
4369  ! by estimated suppression factors that are multiplied in expansion
4370  acc_req_cextra(0:rmax) = acc_req_cind
4371  if (x_g.ne.0d0) then
4372  do r=rmax+1,rmaxc
4373  acc_req_cextra(r)= acc_req_cextra(r-1)/x_g
4374  end do
4375  else ! 10.07.2017
4376  acc_req_cextra(rmax+1:rmaxc) = acc_inf
4377  end if
4378 
4379  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
4380  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
4381  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
4382  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
4383 
4384  ! shift of integration momentum in C\{0}
4385  do n1=1,rmaxc
4386  do n2=0,rmaxc-n1
4387  do n3=0,rmaxc-n1-n2
4388  n0 = (rmaxc-n1-n2-n3)
4389  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
4390  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
4391  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
4392  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
4393  end do
4394  end do
4395  end do
4396 
4397 
4398  ! calculate adjugated Gram matrix
4399 ! mm02 = elimminf2_coli(m02)
4400 ! mm12 = elimminf2_coli(m12)
4401 ! mm22 = elimminf2_coli(m22)
4402 ! mm32 = elimminf2_coli(m32)
4403 ! q10 = elimminf2_coli(p10)
4404 ! q21 = elimminf2_coli(p21)
4405 ! q32 = elimminf2_coli(p32)
4406 ! q30 = elimminf2_coli(p30)
4407 ! q31 = elimminf2_coli(p31)
4408 ! q20 = elimminf2_coli(p20)
4409 
4410 ! Z(1,1) = 2d0*q10
4411 ! Z(2,1) = q10+q20-q21
4412 ! Z(3,1) = q10+q30-q31
4413 ! Z(1,2) = Z(2,1)
4414 ! Z(2,2) = 2d0*q20
4415 ! Z(3,2) = q20+q30-q32
4416 ! Z(1,3) = Z(3,1)
4417 ! Z(2,3) = Z(3,2)
4418 ! Z(3,3) = 2d0*q30
4419 
4420 ! q1q2 = (q10+q20-q21)
4421 ! q1q3 = (q10+q30-q31)
4422 ! q2q3 = (q20+q30-q32)
4423 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
4424 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
4425 
4426 ! Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
4427 ! Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
4428 ! Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
4429 ! Zadj(1,2) = Zadj(2,1)
4430 ! Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
4431 ! Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
4432 ! Zadj(1,3) = Zadj(3,1)
4433 ! Zadj(2,3) = Zadj(3,2)
4434 ! Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
4435 !
4436 ! f(1) = q10+mm02-mm12
4437 ! f(2) = q20+mm02-mm22
4438 ! f(3) = q30+mm02-mm32
4439 
4440 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
4441 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
4442 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
4443 
4444 
4445  ! coefficients Shat defined in (5.13)
4446  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
4447 
4448  do r=0,rmaxc
4449  do n0=0,r/2
4450  do n1=0,r-2*n0
4451  do n2=0,r-2*n0-n1
4452  n3 = r-2*n0-n1-n2
4453 
4454  shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
4455 
4456  if(n1.eq.0) then
4457  shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
4458  end if
4459 
4460  if(n2.eq.0) then
4461  shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
4462  end if
4463 
4464  if(n3.eq.0) then
4465  shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
4466  end if
4467 
4468  end do
4469  end do
4470  end do
4471  end do
4472 
4473 
4474  ! choose reduction formulas with biggest denominators
4475  if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
4476  j = 1
4477  else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
4478  j = 2
4479  else
4480  j = 3
4481  end if
4482 
4483  maxzadj = 0d0
4484  if (abs(zadj(1,1)).gt.maxzadj) then
4485  maxzadj = abs(zadj(1,1))
4486  k = 1
4487  l = 1
4488  inds2 = reshape((/2,2,2,3,3,2,3,3/),shape(inds2))
4489  zadj2(1) = -z(3,3)
4490  zadj2(2) = z(3,2)
4491  zadj2(3) = z(2,3)
4492  zadj2(4) = -z(2,2)
4493  end if
4494  if (abs(zadj(2,2)).gt.maxzadj) then
4495  maxzadj = abs(zadj(2,2))
4496  k = 2
4497  l = 2
4498  inds2 = reshape((/1,1,1,3,3,1,3,3/),shape(inds2))
4499  zadj2(1) = -z(3,3)
4500  zadj2(2) = z(3,1)
4501  zadj2(3) = z(1,3)
4502  zadj2(4) = -z(1,1)
4503  end if
4504  if (abs(zadj(3,3)).gt.maxzadj) then
4505  maxzadj = abs(zadj(3,3))
4506  k = 3
4507  l = 3
4508  inds2 = reshape((/1,1,1,2,2,1,2,2/),shape(inds2))
4509  zadj2(1) = -z(2,2)
4510  zadj2(2) = z(2,1)
4511  zadj2(3) = z(1,2)
4512  zadj2(4) = -z(1,1)
4513  end if
4514  if (abs(zadj(1,2)).gt.maxzadj) then
4515  maxzadj = abs(zadj(1,2))
4516  k = 1
4517  l = 2
4518  inds2 = reshape((/2,1,2,3,3,1,3,3/),shape(inds2))
4519  zadj2(1) = z(3,3)
4520  zadj2(2) = -z(3,1)
4521  zadj2(3) = -z(2,3)
4522  zadj2(4) = z(2,1)
4523  end if
4524  if (abs(zadj(1,3)).gt.maxzadj) then
4525  maxzadj = abs(zadj(1,3))
4526  k = 1
4527  l = 3
4528  inds2 = reshape((/2,1,2,2,3,1,3,2/),shape(inds2))
4529  zadj2(1) = -z(3,2)
4530  zadj2(2) = z(3,1)
4531  zadj2(3) = z(2,2)
4532  zadj2(4) = -z(2,1)
4533  end if
4534  if (abs(zadj(2,3)).gt.maxzadj) then
4535  k = 2
4536  l = 3
4537  inds2 = reshape((/1,1,1,2,3,1,3,2/),shape(inds2))
4538  zadj2(1) = z(3,2)
4539  zadj2(2) = -z(3,1)
4540  zadj2(3) = -z(1,2)
4541  zadj2(4) = z(1,1)
4542  end if
4543 
4544  zadjfj = zadjf(j)
4545  zadjkl = zadj(k,l)
4546  xtilde = xadj(k,l)
4547 
4548 ! write(*,*) 'CalcDg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
4549 
4550 
4551  ! allocation of array for det(Z)-expanded C-coefficients
4552  rmaxexp = rmaxc+1
4553  allocate(dexpg(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordg_max))
4554 
4555 
4556  ! calculate Duv
4557  allocate(duvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
4558  call calcduv(duvexpg,cuv_0,mm02,f,rmaxexp,id)
4559  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpg(0:rmax,0:rmax,0:rmax,0:rmax)
4560 
4561  ! allocate arrays for error propagation
4562  allocate(d00_err(0:rmaxexp))
4563  allocate(dij_err(0:rmaxexp))
4564  allocate(cij_err(0:rmaxc))
4565 
4566  allocate(d00_err2(0:rmaxexp))
4567  allocate(dij_err2(0:rmaxexp))
4568  allocate(cij_err2(0:rmaxc))
4569 
4570  ! initialize accuracy estimates
4571  derr = acc_inf
4572  dij_err =0d0
4573  d00_err =0d0
4574  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
4575 
4576  derr2 = acc_inf
4577  dij_err2 =0d0
4578  d00_err2 =0d0
4579  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
4580 
4581 #ifdef Dgtest
4582  write(*,*) 'CalcDg Cij_err = ',cij_err
4583  write(*,*) 'CalcDg C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
4584  write(*,*) 'CalcDg C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
4585 #endif
4586 
4587 ! maxZadj = maxval(abs(Zadj))
4588 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
4589 
4590  ! truncation of expansion if calculated term larger than truncfacexp * previous term
4591  ! crucial for expansion parameters between 0.1 and 1 !!!
4592  truncfacexp = sqrt(fac_g) * truncfacd
4593  gtrunc = ordg_max
4594 
4595 ! calculate D(n0,n1,n2,n3) up to rank r for n0>0 and up to rank r-1 for n0=0
4596  rloop: do r=1,rmaxexp
4597 
4598 #ifdef Dgtest
4599 ! write(*,*) 'CalcDg rloop',r,rmax,gtrunc
4600 #endif
4601 
4602  if (r.gt.rmax+gtrunc+1) exit rloop
4603 
4604 #ifdef Dgtest
4605  write(*,*) 'CalcDg rloop',r
4606 #endif
4607 
4608  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4609  ! 0th-order coefficients
4610  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4611 
4612  ! calculating
4613  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
4614  ! exploiting eq. (5.40)
4615  maxdexpg(1,r,0)=0d0
4616  do n0=r/2,1,-1
4617  do n1=0,r-2*n0
4618  do n2=0,r-2*n0-n1
4619  n3=r-2*n0-n1-n2
4620 
4621  inds0(1) = n1
4622  inds0(2) = n2
4623  inds0(3) = n3
4624 
4625  dexpgaux = 2d0*zadj(k,l)*c_0(n0-1,n1,n2,n3) &
4626  + xtilde*dexpg(n0-1,n1,n2,n3,0) &
4627  + 4d0*zadj(k,l)*duvexpg(n0,n1,n2,n3)
4628 
4629  inds = inds0
4630  inds(k) = inds(k)+1
4631  do i=1,3
4632  dexpgaux = dexpgaux + zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
4633  end do
4634 
4635  do i=1,3
4636  inds = inds0
4637  inds(i) = inds(i)+1
4638  dexpgaux = dexpgaux - zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
4639  end do
4640 
4641  do i=1,4
4642  n = inds2(1,i)
4643  m = inds2(2,i)
4644 
4645  skl = f(n)*shat(n0-1,inds0(1),inds0(2),inds0(3),m)
4646 
4647  inds = inds0
4648  if (inds(m).ge.1) then
4649  inds(m) = inds(m)-1
4650  skl = skl - 2d0*f(n)*inds0(m)*dexpg(n0,inds(1),inds(2),inds(3),0)
4651  if (inds(n).ge.1) then
4652  inds(n) = inds(n)-1
4653  skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpg(n0+1,inds(1),inds(2),inds(3),0)
4654  end if
4655  end if
4656  inds = inds0
4657  if (inds(n).ge.1) then
4658  inds(n) = inds(n)-1
4659  skl = skl + 2d0*inds0(n)*shat(n0,inds(1),inds(2),inds(3),m) &
4660  - 2d0*f(m)*inds0(n)*dexpg(n0,inds(1),inds(2),inds(3),0)
4661  end if
4662 
4663  dexpgaux = dexpgaux - zadj2(i)*skl
4664 
4665  end do
4666 
4667  dexpg(n0,n1,n2,n3,0) = dexpgaux/(2d0*zadjkl)/(2d0*(r-n0))
4668 
4669  if (n0.eq.1) then
4670  maxdexpg(1,r,0) = maxdexpg(1,r,0) + abs(dexpg(n0,n1,n2,n3,0) )
4671  end if
4672 
4673  if (r-n0.le.rmax) then
4674  d(n0,n1,n2,n3) = dexpg(n0,n1,n2,n3,0)
4675  end if
4676 
4677  end do
4678  end do
4679  end do
4680 
4681  ! calculate
4682  ! D_00ijkl.. --> D_aijkl..
4683  ! exploiting eq. (5.38)
4684  maxdexpg(0,r-1,0)=0d0
4685  do n1=0,r-1
4686  do n2=0,r-1-n1
4687  n3 = r-1-n1-n2
4688 
4689  smod = shat(0,n1,n2,n3,:)
4690  if (n1.ge.1) then
4691  smod(1) = smod(1) - 2d0*n1*dexpg(1,n1-1,n2,n3,0)
4692  end if
4693  if (n2.ge.1) then
4694  smod(2) = smod(2) - 2d0*n2*dexpg(1,n1,n2-1,n3,0)
4695  end if
4696  if (n3.ge.1) then
4697  smod(3) = smod(3) - 2d0*n3*dexpg(1,n1,n2,n3-1,0)
4698  end if
4699 
4700  dexpg(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
4701  + zadj(3,j)*smod(3))/zadjfj
4702  maxdexpg(0,r-1,0) = maxdexpg(0,r-1,0) + abs(dexpg(0,n1,n2,n3,0))
4703  if (r.le.rmax+1) then
4704  d(0,n1,n2,n3) = dexpg(0,n1,n2,n3,0)
4705  end if
4706 
4707 
4708 #ifdef Dgtest
4709  if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) then
4710  write(*,*) 'D2(0,0,0,0)= ',0,d(n0,n1,n2,n3),detz/zadjfj
4711 ! write(*,*) 'D2(0,0,0,0)= ',Smod
4712 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,j),Zadjfj
4713 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,j)/Zadjfj
4714 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,j)/Zadjfj, &
4715 ! Smod(2)*Zadj(2,j)/Zadjfj, Smod(3)*Zadj(3,j)/Zadjfj
4716 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,j)/Zadjfj+ &
4717 ! Smod(2)*Zadj(2,j)/Zadjfj+ Smod(3)*Zadj(3,j)/Zadjfj
4718 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,1),Zadjf(1)
4719 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,1)/Zadjf(1)
4720 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,1)/Zadjf(1), &
4721 ! Smod(2)*Zadj(2,1)/Zadjfj, Smod(3)*Zadj(3,1)/Zadjf(1)
4722 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,1)/Zadjf(1)+ &
4723 ! Smod(2)*Zadj(2,1)/Zadjfj+ Smod(3)*Zadj(3,1)/Zadjf(1)
4724 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,2),Zadjf(2)
4725 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,2)/Zadjf(2)
4726 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,2)/Zadjf(2), &
4727 ! Smod(2)*Zadj(2,2)/Zadjfj, Smod(3)*Zadj(3,2)/Zadjf(2)
4728 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,2)/Zadjf(2)+ &
4729 ! Smod(2)*Zadj(2,2)/Zadjfj+ Smod(3)*Zadj(3,2)/Zadjf(2)
4730 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,3),Zadjf(3)
4731 ! write(*,*) 'D2(0,0,0,0)= ',Zadj(1:3,3)/Zadjf(3)
4732 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,3)/Zadjf(3), &
4733 ! Smod(2)*Zadj(2,3)/Zadjfj, Smod(3)*Zadj(3,3)/Zadjf(3)
4734 ! write(*,*) 'D2(0,0,0,0)= ',Smod(1)*Zadj(1,3)/Zadjf(3)+ &
4735 ! Smod(2)*Zadj(2,3)/Zadjfj+ Smod(3)*Zadj(3,3)/Zadjf(3)
4736  end if
4737 #endif
4738 
4739  end do
4740  end do
4741 
4742 #ifdef Dgtest
4743  write(*,*) 'CalcDg maxDexpg 0',r-1, maxdexpg(0,r-1,0)
4744 #endif
4745 
4746  if(r.le.rmax+1) then
4747 ! Derr(r-1) = abs(detZ/Zadjfj)*maxDexpg(0,r-1,0)
4748  derr(r-1) = fac_g*maxdexpg(0,r-1,0)
4749  endif
4750 
4751 
4752  ! error propagation from C's
4753  if(r.gt.1)then
4754  d00_err(r) = max(cij_err(r-1),cij_err(r-2), &
4755  max(maxzadj*cij_err(r-1),maxzadj2f*cij_err(r-2))/abs(zadjkl)) &
4756  /(4*(r-1))
4757  end if
4758  dij_err(r-1)=maxzadj*max(cij_err(r-1),2*d00_err(r))/abs(zadjfj)
4759 
4760  if(r.gt.1)then
4761  d00_err2(r) = max(cij_err2(r-1),cij_err2(r-2), &
4762  max(maxzadj*cij_err2(r-1),maxzadj2f*cij_err2(r-2))/abs(zadjkl)) &
4763  /(4*(r-1))
4764 
4765  end if
4766  dij_err2(r-1)=maxzadj*max(cij_err2(r-1),2*d00_err2(r))/abs(zadjfj)
4767 
4768 
4769  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4770  ! higher order coefficients
4771  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4772 
4773  rg = r
4774  gloop: do g=1,min(gtrunc,r-1)
4775  rg = rg-1
4776 
4777 #ifdef Dgtest
4778  write(*,*) 'gloop ',g,rg
4779 #endif
4780 
4781  ! calculating
4782  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
4783  ! exploiting eq. (5.40)
4784  maxdexpg(1,rg,g) = 0d0
4785  do n0=rg/2,1,-1
4786  do n1=0,rg-2*n0
4787  do n2=0,rg-2*n0-n1
4788  n3=rg-2*n0-n1-n2
4789 
4790  inds0(1) = n1
4791  inds0(2) = n2
4792  inds0(3) = n3
4793 
4794  inds = inds0
4795  inds(k) = inds(k)+1
4796  inds(l) = inds(l)+1
4797  dexpgaux = xtilde*dexpg(n0-1,n1,n2,n3,g) &
4798  - detz*dexpg(n0-1,inds(1),inds(2),inds(3),g-1)
4799 
4800 
4801  do i=1,4
4802  n = inds2(1,i)
4803  m = inds2(2,i)
4804 
4805  skl = 0d0
4806 
4807  inds = inds0
4808  if (inds(m).ge.1) then
4809  inds(m) = inds(m)-1
4810  skl = skl - 2d0*f(n)*inds0(m)*dexpg(n0,inds(1),inds(2),inds(3),g)
4811  if (inds(n).ge.1) then
4812  inds(n) = inds(n)-1
4813  skl = skl - 4d0*inds0(m)*(inds(n)+1)*dexpg(n0+1,inds(1),inds(2),inds(3),g)
4814  end if
4815  end if
4816  inds = inds0
4817  if (inds(n).ge.1) then
4818  inds(n) = inds(n)-1
4819  skl = skl - 2d0*f(m)*inds0(n)*dexpg(n0,inds(1),inds(2),inds(3),g)
4820  end if
4821 
4822  dexpgaux = dexpgaux - zadj2(i)*skl
4823 
4824  end do
4825 
4826  dexpg(n0,n1,n2,n3,g) = dexpgaux/(2d0*zadjkl)/(2d0*(rg-n0))
4827 
4828 
4829  if(n0.eq.1) then
4830  maxdexpg(1,rg,g) = maxdexpg(1,rg,g) + abs(dexpg(n0,n1,n2,n3,g))
4831 
4832  if (g.eq.1.and.abs(dexpg(1,n1,n2,n3,g)).gt. &
4833  truncfacexp*max(1/m2scale,maxdexpg(1,rg,g-1)) .or. &
4834  g.ge.2.and.abs(dexpg(1,n1,n2,n3,g)).gt. &
4835  truncfacexp*maxdexpg(1,rg,g-1)) then
4836 
4837 #ifdef Dgtest
4838  write(*,*) 'CalcDg exit gloop',n0,n1,n2,n3,g,abs(dexpg(n0,n1,n2,n3,g)),maxdexpg(1,rg,g-1),truncfacexp
4839 #endif
4840 
4841  gtrunc = g-1
4842  exit gloop
4843  end if
4844  end if
4845 
4846  end do
4847  end do
4848  end do
4849 
4850 #ifndef PPEXP00
4851  do n0=rg/2,1,-1
4852  if (rg-n0.le.rmax) then
4853  do n1=0,rg-2*n0
4854  do n2=0,rg-2*n0-n1
4855  n3=rg-2*n0-n1-n2
4856  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpg(n0,n1,n2,n3,g)
4857  end do
4858  end do
4859  end if
4860  end do
4861 #endif
4862 ! write(*,*) 'CalcDg after it1 ',rg
4863 
4864  ! calculate
4865  ! D_00ijkl.. --> D_aijkl..
4866  ! exploiting eq. (5.38)
4867 
4868 ! write(*,*) 'CalcDg maxDexp',rg-1,g-1,maxDexpg(0,rg-1,g-1)
4869 
4870  maxdexpg(0,rg-1,g) = 0d0
4871  do n1=0,rg-1
4872  do n2=0,rg-1-n1
4873  n3 = rg-1-n1-n2
4874 
4875  smod = 0d0
4876  if (n1.ge.1) then
4877  smod(1) = smod(1) - 2d0*n1*dexpg(1,n1-1,n2,n3,g)
4878  end if
4879  if (n2.ge.1) then
4880  smod(2) = smod(2) - 2d0*n2*dexpg(1,n1,n2-1,n3,g)
4881  end if
4882  if (n3.ge.1) then
4883  smod(3) = smod(3) - 2d0*n3*dexpg(1,n1,n2,n3-1,g)
4884  end if
4885 
4886  inds(1) = n1
4887  inds(2) = n2
4888  inds(3) = n3
4889  inds(j) = inds(j)+1
4890  dexpg(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
4891  + zadj(3,j)*smod(3) &
4892  - detz*dexpg(0,inds(1),inds(2),inds(3),g-1))/zadjfj
4893 
4894  maxdexpg(0,rg-1,g) = maxdexpg(0,rg-1,g) + abs(dexpg(0,n1,n2,n3,g))
4895 
4896 ! if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then
4897 ! write(*,*) 'D2(2,3,3)= ',g,Dexpg(0,n1,n2,n3,g)
4898 ! write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj, Zadj(2,j)*Smod(2)/Zadjfj, &
4899 ! + Zadj(3,j)*Smod(3)/Zadjfj, &
4900 ! - detZ*Dexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
4901 ! write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3), &
4902 ! - detZ/Zadjfj,Dexpg(0,inds(1),inds(2),inds(3),g-1)
4903 ! end if
4904 
4905  if (g.eq.1.and.abs(dexpg(0,n1,n2,n3,g)).gt. &
4906  truncfacexp*max(1/m2scale**2,maxdexpg(0,rg-1,g-1)) .or. &
4907  g.ge.2.and.abs(dexpg(0,n1,n2,n3,g)).gt. &
4908  truncfacexp*maxdexpg(0,rg-1,g-1)) then
4909 
4910 #ifdef Dgtest
4911  write(*,*) 'CalcDg exit gloop',0,n1,n2,n3,g,abs(dexpg(0,n1,n2,n3,g)),maxdexpg(0,rg-1,g-1),truncfacexp
4912 #endif
4913  gtrunc = g-1
4914  exit gloop
4915  end if
4916 
4917  end do
4918  end do
4919 
4920  ! error propagation from C's
4921  if(rg.gt.1)then
4922 ! D00_err(rg) = max( D00_err(rg), &
4923 ! max( abs(m02)*Dij_err(rg-2), &
4924 ! max( abs(detZ)*Dij_err(rg),abs(Xtilde)*Dij_err(rg-2), &
4925 ! maxZadj2f*D00_err(rg-1) ) / abs(Zadjkl) ) &
4926 ! /(4*(rg-1)) )
4927 ! 06.05.15 ->
4928  d00_err(rg) = max( d00_err(rg), &
4929  max( abs(detz)*dij_err(rg),abs(xtilde)*dij_err(rg-2), &
4930  maxzadj2f*d00_err(rg-1) ) / abs(zadjkl) &
4931  /(4*(rg-1)) )
4932  end if
4933  dij_err(rg-1)=max(dij_err(rg-1), &
4934  max(2*maxzadj*d00_err(rg),abs(detz)*dij_err(rg))/abs(zadjfj) )
4935 
4936  if(rg.gt.1)then
4937  d00_err2(rg) = max( d00_err2(rg), &
4938  max( abs(detz)*dij_err2(rg),abs(xtilde)*dij_err2(rg-2), &
4939  maxzadj2f*d00_err2(rg-1) ) / abs(zadjkl) &
4940  /(4*(rg-1)) )
4941  end if
4942  dij_err2(rg-1)=max(dij_err2(rg-1), &
4943  max(2*maxzadj*d00_err2(rg),abs(detz)*dij_err2(rg))/abs(zadjfj) )
4944 
4945 #ifdef PPEXP00
4946  do n0=rg/2,1,-1
4947  if (rg-n0.le.rmax) then
4948  do n1=0,rg-2*n0
4949  do n2=0,rg-2*n0-n1
4950  n3=rg-2*n0-n1-n2
4951  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpg(n0,n1,n2,n3,g)
4952  end do
4953  end do
4954  end if
4955  end do
4956 #endif
4957 ! write(*,*) 'CalcDg after it1 ',rg
4958  if ((rg.le.rmax+1)) then
4959  derr(rg-1) = 0d0
4960  do n1=0,rg-1
4961  do n2=0,rg-1-n1
4962  n3 = rg-1-n1-n2
4963  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpg(0,n1,n2,n3,g)
4964 ! Derr(rg-1)=max(Derr(rg-1),abs(Dexpg(0,n1,n2,n3,g))**2/abs(Dexpg(0,n1,n2,n3,g-1)))
4965  if(abs(dexpg(0,n1,n2,n3,g-1)).ne.0d0) then
4966  derr(rg-1)=max(derr(rg-1),abs(dexpg(0,n1,n2,n3,g))*min(1d0,abs(dexpg(0,n1,n2,n3,g))/abs(dexpg(0,n1,n2,n3,g-1))))
4967  else
4968  derr(rg-1)=max(derr(rg-1),abs(dexpg(0,n1,n2,n3,g)))
4969  endif
4970 
4971 #ifdef Dgtest
4972 ! write(*,*) 'CalcDg Derr calc',rg-1,Derr(rg-1),n1,n2,n3,abs(Dexpg(0,n1,n2,n3,g)),abs(Dexpg(0,n1,n2,n3,g-1))
4973 #endif
4974 
4975  end do
4976  end do
4977 
4978  ! if error from C's larger than error from expansion stop expansion
4979 #ifdef PVEST2
4980  if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
4981 #else
4982  if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
4983 #endif
4984  gtrunc = min(g,gtrunc)
4985 
4986 #ifdef Dgtest
4987  write(*,*) 'CalcDg exit err',r,rg-1,g,gtrunc,dij_err(rg-1),derr(rg-1)
4988 #endif
4989 
4990  end if
4991 
4992  end if
4993 
4994  end do gloop
4995 
4996 #ifdef Dgtest
4997  write(*,*) 'CalcDg D(0,0,0,0) = ',r,d(0,0,0,0)
4998  if(r.gt.1)then
4999 ! write(*,*) 'CalcDg D(0,1,0,0) = ',r,D(0,1,0,0)
5000  write(*,*) 'CalcDg D(0,0,1,0) = ',r,d(0,0,1,0)
5001  endif
5002  if(r.gt.2.and.rmax.ge.2)then
5003  write(*,*) 'CalcDg D(1,0,0,0) = ',r,d(1,0,0,0)
5004  write(*,*) 'CalcDg D(0,2,0,0) = ',r,d(0,2,0,0)
5005  write(*,*) 'CalcDg D(0,0,1,1) = ',r,d(0,0,1,1)
5006 ! write(*,*) 'CalcDg D(0,1,1,0) = ',r,D(0,1,1,0)
5007  write(*,*) 'CalcDg D(0,0,2,0) = ',r,d(0,0,2,0)
5008  endif
5009  if(r.gt.3.and.rmax.ge.3)then
5010  write(*,*) 'CalcDg D(1,0,1,0) = ',r,d(1,0,1,0)
5011  write(*,*) 'CalcDg D(1,1,0,0) = ',r,d(1,1,0,0)
5012  write(*,*) 'CalcDg D(1,0,1,0) = ',r,d(1,0,1,0)
5013  write(*,*) 'CalcDg D(1,0,0,1) = ',r,d(1,0,0,1)
5014 ! write(*,*) 'CalcDg D(1,2,0,0) = ',r,D(1,2,0,0)
5015  write(*,*) 'CalcDg D(0,3,0,0) = ',r,d(0,3,0,0)
5016  write(*,*) 'CalcDg D(0,2,1,0) = ',r,d(0,2,1,0)
5017  write(*,*) 'CalcDg D(0,2,0,1) = ',r,d(0,2,0,1)
5018  write(*,*) 'CalcDg D(0,0,3,0) = ',r,d(0,0,3,0)
5019  write(*,*) 'CalcDg D(0,1,1,1) = ',r,d(0,1,1,1)
5020  write(*,*) 'CalcDg D(0,0,2,1) = ',r,d(0,0,2,1)
5021  endif
5022  write(*,*) 'CalcDg Dij_err',r,dij_err
5023  write(*,*) 'CalcDg Dij_acc',r,dij_err/abs(d(0,0,0,0))
5024 
5025  write(*,*) 'CalcDg err',r,derr
5026  write(*,*) 'CalcDg acc',r,derr/abs(d(0,0,0,0))
5027 #endif
5028 
5029  derr2 = max(derr,dij_err2(0:rmax))
5030  derr = max(derr,dij_err(0:rmax))
5031 
5032 #ifdef Dgtest
5033  write(*,*) 'CalcDg exit r',r,maxval(derr),maxval(derr2),acc_req_d*abs(d(0,0,0,0))
5034 #endif
5035 
5036 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
5037  ! check if target precision already reached
5038 #ifdef Cutrloop
5039  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
5040 
5041  if (r.lt.rmax) then
5042  do rg=r+1,rmax
5043 ! write(*,*) 'CalcDg exit rloop =',rg,r,rmax
5044  do n0=0,rg/2
5045  do n1=0,rg-2*n0
5046  do n2=0,rg-2*n0-n1
5047  d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
5048  end do
5049  end do
5050  end do
5051  end do
5052  if(r.le.rmax) then
5053  do n1=0,r
5054  do n2=0,r-n1
5055  d(0,n1,n2,r-n1-n2)=0d0
5056  end do
5057  end do
5058  end if
5059 
5060 100 format(((a)))
5061 111 format(a22,2('(',g24.17,',',g24.17,') ':))
5062  call seterrflag_coli(-5)
5063  call errout_coli('CalcDg',' exit rloop for D', &
5064  errorwriteflag)
5065  if (errorwriteflag) then
5066  write(nerrout_coli,100)' CalcDg: exit rloop for D ', &
5067  ' should not appear'
5068  write(nerrout_coli,111)' CalcDg: p10 = ',p10
5069  write(nerrout_coli,111)' CalcDg: p21 = ',p21
5070  write(nerrout_coli,111)' CalcDg: p32 = ',p32
5071  write(nerrout_coli,111)' CalcDg: p30 = ',p30
5072  write(nerrout_coli,111)' CalcDg: p20 = ',p20
5073  write(nerrout_coli,111)' CalcDg: p31 = ',p31
5074  write(nerrout_coli,111)' CalcDg: m02 = ',m02
5075  write(nerrout_coli,111)' CalcDg: m12 = ',m12
5076  write(nerrout_coli,111)' CalcDg: m22 = ',m22
5077  write(nerrout_coli,111)' CalcDg: m32 = ',m32
5078  end if
5079  end if
5080 
5081 #else
5082  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
5083 #endif
5084  exit rloop
5085  end if
5086 
5087  end do rloop
5088 
5089 
5090  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0>=1 only!!!!!!
5091  ! already calculated for rmax+1
5092 ! do r=rmax+1,2*rmax
5093 #ifdef notneeded
5094  do r=rmax+1,rmax+1
5095  do n0=r-rmax,r/2
5096  do n1=0,r-2*n0
5097  do n2=0,r-2*n0-n1
5098  n3 = r-2*n0-n1-n2
5099 
5100  write(*,*) 'CalcDg exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
5101 
5102  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
5103  + 4*duv(n0,n1,n2,n3) &
5104  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
5105  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
5106 
5107  write(*,*) 'CalcDg dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
5108 
5109  end do
5110  end do
5111  end do
5112  end do
5113 #endif
5114 
5115 #ifdef Dgtest
5116  write(*,*) 'CalcDg D(0,0,0,0) = ',d(0,0,0,0)
5117  if(rmax.ge.3)then
5118  write(*,*) 'CalcDg D(1,0,1,0) = ',d(1,0,1,0)
5119  endif
5120 
5121  write(*,*) 'CalcDg final err ',derr
5122  write(*,*) 'CalcDg final acc ',derr/abs(d(0,0,0,0))
5123  write(*,*) 'CalcDg final err2',derr2
5124  write(*,*) 'CalcDg final acc2',derr2/abs(d(0,0,0,0))
5125 #endif
5126 
5127 ! write(*,*) 'CalcDg Derr ',Derr
5128 ! write(*,*) 'CalcDg Derr2',Derr2
5129 

◆ calcdgp()

subroutine reductiond::calcdgp ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordgp_min,
integer, intent(in)  ordgp_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 8622 of file reductionD.F90.

8622 
8623  use globald
8624 
8625  integer, intent(in) :: rmax,ordgp_min,ordgp_max,id
8626  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
8627  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
8628  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
8629  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
8630  double complex, allocatable :: Dexpgp(:,:,:,:,:), DuvExpgp(:,:,:,:)
8631  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:)
8632  double complex, allocatable :: C_k(:,:,:), Cuv_k(:,:,:)
8633  double complex, allocatable :: D_alt(:,:,:,:)
8634  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
8635  double complex :: Smod, fk, elimminf2_coli
8636  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
8637  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
8638  double precision :: maxDexpgp(0:1,0:rmax+ordgp_min+1,0:ordgp_max),truncfacexp
8639  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,g,rg
8640  integer :: bin,nid(0:3),i
8641  logical :: errorwriteflag
8642 
8643 #ifdef Dgtest
8644  write(*,*) 'CalcDgp in, ord',rmax,ordgp_min,ordgp_max
8645 #endif
8646 ! write(*,*) 'CalcDgp in, ',rmax,ordgp_min,ordgp_max
8647 
8648  ! calculate adjugated Gram matrix
8649 ! mm02 = elimminf2_coli(m02)
8650 ! mm12 = elimminf2_coli(m12)
8651 ! mm22 = elimminf2_coli(m22)
8652 ! mm32 = elimminf2_coli(m32)
8653 ! q10 = elimminf2_coli(p10)
8654 ! q21 = elimminf2_coli(p21)
8655 ! q32 = elimminf2_coli(p32)
8656 ! q30 = elimminf2_coli(p30)
8657 ! q31 = elimminf2_coli(p31)
8658 ! q20 = elimminf2_coli(p20)
8659 !
8660 ! Z(1,1) = 2d0*q10
8661 ! Z(2,1) = q10+q20-q21
8662 ! Z(3,1) = q10+q30-q31
8663 ! Z(1,2) = Z(2,1)
8664 ! Z(2,2) = 2d0*q20
8665 ! Z(3,2) = q20+q30-q32
8666 ! Z(1,3) = Z(3,1)
8667 ! Z(2,3) = Z(3,2)
8668 ! Z(3,3) = 2d0*q30
8669 !
8670 ! f(1) = q10+mm02-mm12
8671 ! f(2) = q20+mm02-mm22
8672 ! f(3) = q30+mm02-mm32
8673 
8674 
8675  ! choose reduction formulas with biggest denominators
8676  if (abs(f(1)).ge.max(abs(f(2)),abs(f(3)))) then
8677  k = 1
8678  else if (abs(f(2)).ge.max(abs(f(1)),abs(f(3)))) then
8679  k = 2
8680  else
8681  k = 3
8682  end if
8683  fk = f(k)
8684 
8685 
8686  ! allocation of C functions
8687  rmaxc = rmax + ordgp_min
8688  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
8689  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
8690  allocate(c_k(0:rmaxc,0:rmaxc,0:rmaxc))
8691  allocate(cuv_k(0:rmaxc,0:rmaxc,0:rmaxc))
8692  allocate(cerr_i(0:rmaxc,0:3))
8693  allocate(cerr2_i(0:rmaxc,0:3))
8694  allocate(acc_req_cextra(0:rmaxc))
8695 
8696  ! determine binaries for C-coefficients
8697  i=0
8698  bin = 1
8699  do while (i.le.3)
8700  if (mod(id/bin,2).eq.0) then
8701  nid(i) = id+bin
8702  i = i+1
8703  end if
8704  bin = 2*bin
8705  end do
8706 
8707  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
8708  ! by estimated suppression factors that are multiplied in expansion
8709  acc_req_cextra(0:rmax) = acc_req_cind
8710  if(w_gp.ne.0d0) then
8711  do r=rmax+1,rmaxc
8712  acc_req_cextra(r)= acc_req_cextra(r-1)/w_gp
8713  end do
8714  else ! 10.07.2017
8715  acc_req_cextra(rmax+1:rmaxc)=acc_inf
8716  endif
8717 
8718  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
8719  if (k.eq.1) then
8720  call calcc(c_k(:,:,:),cuv_k(:,:,:),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
8721  else if (k.eq.2) then
8722  call calcc(c_k(:,:,:),cuv_k(:,:,:),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
8723  else if (k.eq.3) then
8724  call calcc(c_k(:,:,:),cuv_k(:,:,:),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
8725  end if
8726 
8727  ! shift of integration momentum in C\{0}
8728  do n1=1,rmaxc
8729  do n2=0,rmaxc-n1
8730  do n3=0,rmaxc-n1-n2
8731  n0 = (rmaxc-n1-n2-n3)
8732  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
8733  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
8734  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
8735  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
8736  end do
8737  end do
8738  end do
8739 
8740 
8741  ! coefficients Shat defined in (5.13)
8742  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc))
8743 
8744  do r=0,rmaxc
8745  do n1=0,r
8746  do n2=0,r-n1
8747  n3 = r-n1-n2
8748 
8749  shat(n1,n2,n3) = -c_0(0,n1,n2,n3)
8750 
8751  if ((k.eq.1).and.(n1.eq.0)) then
8752  shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n2,n3)
8753  else if ((k.eq.2).and.(n2.eq.0)) then
8754  shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n1,n3)
8755  else if ((k.eq.3).and.(n3.eq.0)) then
8756  shat(n1,n2,n3) = shat(n1,n2,n3) + c_k(0,n1,n2)
8757  end if
8758 
8759  end do
8760  end do
8761  end do
8762 
8763 
8764 
8765  ! allocation of array for det(Z)-expanded C-coefficients
8766  rmaxexp = rmaxc+1
8767  allocate(dexpgp(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgp_max))
8768 
8769  ! calculate Duv
8770  allocate(duvexpgp(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
8771  call calcduv(duvexpgp,cuv_0,mm02,f,rmaxexp,id)
8772  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgp(0:rmax,0:rmax,0:rmax,0:rmax)
8773 
8774  ! allocate arrays for error propagation
8775  allocate(d00_err(0:rmaxexp))
8776  allocate(dij_err(0:rmaxexp))
8777  allocate(cij_err(0:rmaxc))
8778 
8779  allocate(d00_err2(0:rmaxexp))
8780  allocate(dij_err2(0:rmaxexp))
8781  allocate(cij_err2(0:rmaxc))
8782 
8783  ! initialize accuracy estimates
8784  derr = acc_inf
8785  dij_err =0d0
8786  d00_err =0d0
8787 
8788  derr2 = acc_inf
8789  dij_err2 =0d0
8790  d00_err2 =0d0
8791 
8792 ! write(*,*) 'Dgp Cerr 0 ',Cerr_i(:,0)
8793 ! write(*,*) 'Dgp Cerr k ',Cerr_i(:,k)
8794 
8795  cij_err = max(cerr_i(:,0),cerr_i(:,k))
8796  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,k))
8797 
8798 ! maxZ = maxval(abs(Z))
8799 ! maxZ=2d0*q2max
8800 
8801  ! truncation of expansion if calculated term larger than truncfacexp * previous term
8802  ! crucial for expansion parameters between 0.1 and 1 !!!
8803 ! truncfacexp = sqrt(abs(maxZ/abs(fk))) * truncfacD
8804  truncfacexp = sqrt(fac_gp) * truncfacd
8805  gtrunc = ordgp_max
8806 
8807 ! calculate D(n0,n1,n2,n3) up to rank r for n0>0 and up to rank r-1 for n0=0
8808  rloop: do r=1,rmaxexp
8809 
8810  if (r.gt.rmax+gtrunc+1) exit rloop
8811 
8812  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
8813  ! 0th-order coefficients
8814  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
8815 
8816  ! calculating
8817  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
8818  ! exploiting eq. (5.63)
8819  maxdexpgp(1,r,0)=0d0
8820  do n0=r/2,1,-1
8821  do n1=0,r-2*n0
8822  do n2=0,r-2*n0-n1
8823  n3=r-2*n0-n1-n2
8824 
8825  dexpgp(n0,n1,n2,n3,0) = (2d0*duvexpgp(n0,n1,n2,n3) + c_0(n0-1,n1,n2,n3) &
8826  + mm02*dexpgp(n0-1,n1,n2,n3,0))/((r-n0)+1)/2d0
8827 
8828  if (n0.eq.1) then
8829  maxdexpgp(1,r,0) = maxdexpgp(1,r,0) + abs(dexpgp(n0,n1,n2,n3,0) )
8830  end if
8831 
8832  if (r-n0.le.rmax) then
8833  d(n0,n1,n2,n3) = dexpgp(n0,n1,n2,n3,0)
8834  end if
8835 
8836  end do
8837  end do
8838  end do
8839 
8840 #ifdef Dgptest
8841  write(*,*) 'CalcDgp 0 D(1,0,1,0)= ',r,d(1,0,1,0)
8842 #endif
8843 
8844 
8845  ! calculate
8846  ! D_00ijkl.. --> D_aijkl..
8847  ! exploiting eq. (5.62)
8848  maxdexpgp(0,r-1,0)=0d0
8849  do n1=0,r-1
8850  do n2=0,r-1-n1
8851  n3 = r-1-n1-n2
8852 
8853  smod = shat(n1,n2,n3)
8854  if ((k.eq.1).and.(n1.ge.1)) then
8855  smod = smod - 2d0*n1*dexpgp(1,n1-1,n2,n3,0)
8856  else if ((k.eq.2).and.(n2.ge.1)) then
8857  smod = smod - 2d0*n2*dexpgp(1,n1,n2-1,n3,0)
8858  else if ((k.eq.3).and.(n3.ge.1)) then
8859  smod = smod - 2d0*n3*dexpgp(1,n1,n2,n3-1,0)
8860  end if
8861 
8862  dexpgp(0,n1,n2,n3,0) = smod/fk
8863  maxdexpgp(0,r-1,0) = maxdexpgp(0,r-1,0) + abs(dexpgp(0,n1,n2,n3,0))
8864 
8865  if (r.le.rmax+1) then
8866  d(0,n1,n2,n3) = dexpgp(0,n1,n2,n3,0)
8867 ! Derr(r-1) = abs(maxZ/fk*Dexpgp(0,n1,n2,n3,0))
8868  end if
8869 
8870  end do
8871  end do
8872 
8873  if (r.le.rmax+1) then
8874 ! Derr(r-1) = abs(maxZ/fk)*maxDexpgp(0,r-1,0)
8875  derr(r-1) = fac_gp*maxdexpgp(0,r-1,0)
8876  endif
8877 
8878  ! error propagation from C's
8879  if(r.gt.1)then
8880  d00_err(r) = cij_err(r-2)/(2*r)
8881  end if
8882  dij_err(r-1)=max(cij_err(r-1),2*d00_err(r))/abs(fk)
8883 
8884  if(r.gt.1)then
8885  d00_err2(r) = cij_err2(r-2)/(2*r)
8886  end if
8887  dij_err2(r-1)=max(cij_err2(r-1),2*d00_err2(r))/abs(fk)
8888 
8889  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8890  ! higher order coefficients
8891  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8892 
8893  rg = r
8894  gloop: do g=1,min(gtrunc,r-1)
8895  rg = rg-1
8896 
8897  ! calculating
8898  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
8899  ! exploiting eq. (5.63)
8900  maxdexpgp(1,rg,g) = 0d0
8901  do n0=rg/2,1,-1
8902  do n1=0,rg-2*n0
8903  do n2=0,rg-2*n0-n1
8904  n3=rg-2*n0-n1-n2
8905 
8906  dexpgp(n0,n1,n2,n3,g) = (2d0*mm02*dexpgp(n0-1,n1,n2,n3,g) &
8907  - z(1,1)*dexpgp(n0-1,n1+2,n2,n3,g-1) - 2d0*z(2,1)*dexpgp(n0-1,n1+1,n2+1,n3,g-1) &
8908  - 2d0*z(3,1)*dexpgp(n0-1,n1+1,n2,n3+1,g-1) - z(2,2)*dexpgp(n0-1,n1,n2+2,n3,g-1) &
8909  - 2d0*z(3,2)*dexpgp(n0-1,n1,n2+1,n3+1,g-1) - z(3,3)*dexpgp(n0-1,n1,n2,n3+2,g-1)) &
8910  /((rg-n0)+1d0)/4d0
8911 
8912  if(n0.eq.1) then
8913  maxdexpgp(1,rg,g) = maxdexpgp(1,rg,g) + abs(dexpgp(n0,n1,n2,n3,g))
8914 
8915 #ifdef Dgptest
8916  if(n0.eq.1.and.n1.eq.0.and.n2.eq.1.and.n3.eq.0) then
8917  write(*,*) 'CalcDgp Dexp(1,0,1,0,g)',r,rg,g,dexpgp(1,0,1,0,g)
8918  write(*,*) 'CalcDgp D(1,0,1,0)',r,rg,g,d(1,0,1,0)
8919  write(*,*) 'CalcDgp maxDexpgp(1,rg,g)',r,rg,g,maxdexpgp(1,rg,g)
8920  if(g.gt.0) write(*,*) 'CalcDgp trunc',abs(dexpgp(n0,n1,n2,n3,g)), &
8921  truncfacexp*maxdexpgp(1,rg,g-1),truncfacexp,maxdexpgp(1,rg,g-1)
8922  endif
8923 #endif
8924 
8925  if (g.eq.1.and.abs(dexpgp(1,n1,n2,n3,g)).gt. &
8926  truncfacexp*max(1/m2scale,maxdexpgp(1,rg,g-1)) .or. &
8927  g.ge.2.and.abs(dexpgp(1,n1,n2,n3,g)).gt. &
8928  truncfacexp*maxdexpgp(1,rg,g-1)) then
8929 
8930  gtrunc = g-1
8931  exit gloop
8932  end if
8933  end if
8934 
8935 
8936  end do
8937  end do
8938  end do
8939 
8940 #ifndef PPEXP00
8941  do n0=rg/2,1,-1
8942  if (rg-n0.le.rmax) then
8943  do n1=0,rg-2*n0
8944  do n2=0,rg-2*n0-n1
8945  n3=rg-2*n0-n1-n2
8946  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgp(n0,n1,n2,n3,g)
8947  end do
8948  end do
8949  end if
8950  end do
8951 #endif
8952 
8953  ! calculate
8954  ! D_00ijkl.. --> D_aijkl..
8955  ! exploiting eq. (5.62)
8956  maxdexpgp(0,rg-1,g) = 0d0
8957  do n1=0,rg-1
8958  do n2=0,rg-1-n1
8959  n3 = rg-1-n1-n2
8960 
8961  smod = -z(1,k)*dexpgp(0,n1+1,n2,n3,g-1) &
8962  -z(2,k)*dexpgp(0,n1,n2+1,n3,g-1) &
8963  -z(3,k)*dexpgp(0,n1,n2,n3+1,g-1)
8964  if ((k.eq.1).and.(n1.ge.1)) then
8965  smod = smod - 2d0*n1*dexpgp(1,n1-1,n2,n3,g)
8966  else if ((k.eq.2).and.(n2.ge.1)) then
8967  smod = smod - 2d0*n2*dexpgp(1,n1,n2-1,n3,g)
8968  else if ((k.eq.3).and.(n3.ge.1)) then
8969  smod = smod - 2d0*n3*dexpgp(1,n1,n2,n3-1,g)
8970  end if
8971 
8972  dexpgp(0,n1,n2,n3,g) = smod/fk
8973 
8974  maxdexpgp(0,rg-1,g) = maxdexpgp(0,rg-1,g) + abs(dexpgp(0,n1,n2,n3,g))
8975 
8976  if (g.eq.1.and.abs(dexpgp(0,n1,n2,n3,g)).gt. &
8977  truncfacexp*max(1/m2scale**2,maxdexpgp(0,rg-1,g-1)) .or. &
8978  g.ge.2.and.abs(dexpgp(0,n1,n2,n3,g)).gt. &
8979  truncfacexp*maxdexpgp(0,rg-1,g-1)) then
8980 
8981  gtrunc = g-1
8982  exit gloop
8983  end if
8984 
8985  end do
8986  end do
8987 
8988  ! error propagation from C's
8989  if(rg.gt.1)then
8990  d00_err(rg) = max(d00_err(rg),max(2*abs(m02)*dij_err(rg-2),maxz*dij_err(rg))/(4*r))
8991  end if
8992  dij_err(rg-1) = max(dij_err(rg-1),max(2*d00_err(rg),maxz*dij_err(rg))/abs(fk))
8993 
8994  if(rg.gt.1)then
8995  d00_err2(rg) = max(d00_err2(rg),max(2*abs(m02)*dij_err2(rg-2),maxz*dij_err2(rg))/(4*r))
8996  end if
8997  dij_err2(rg-1) = max(dij_err2(rg-1),max(2*d00_err2(rg),maxz*dij_err2(rg))/abs(fk))
8998 
8999 #ifdef PPEXP00
9000  do n0=rg/2,1,-1
9001  if (rg-n0.le.rmax) then
9002  do n1=0,rg-2*n0
9003  do n2=0,rg-2*n0-n1
9004  n3=rg-2*n0-n1-n2
9005  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgp(n0,n1,n2,n3,g)
9006  end do
9007  end do
9008  end if
9009  end do
9010 #endif
9011 
9012  if ((rg.le.rmax+1)) then
9013  derr(rg-1) = 0d0
9014  do n1=0,rg-1
9015  do n2=0,rg-1-n1
9016  n3 = rg-1-n1-n2
9017  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgp(0,n1,n2,n3,g)
9018  if(abs(dexpgp(0,n1,n2,n3,g-1)).ne.0d0) then
9019 ! Derr(rg-1)=max(Derr(rg-1),abs(Dexpgp(0,n1,n2,n3,g))**2/abs(Dexpgp(0,n1,n2,n3,g-1)))
9020  derr(rg-1)=max(derr(rg-1),abs(dexpgp(0,n1,n2,n3,g))*min(1d0,abs(dexpgp(0,n1,n2,n3,g))/abs(dexpgp(0,n1,n2,n3,g-1))))
9021  else
9022  derr(rg-1)=max(derr(rg-1),abs(dexpgp(0,n1,n2,n3,g)))
9023  end if
9024  end do
9025  end do
9026 
9027  ! if error from C's larger than error from expansion stop expansion
9028 #ifdef PVEST2
9029  if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
9030 #else
9031  if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
9032 #endif
9033  gtrunc = min(g,gtrunc)
9034 
9035 #ifdef Dgptest
9036  write(*,*) 'CalcDgp exit err',r,g,gtrunc
9037 #endif
9038  end if
9039 
9040  end if
9041 
9042  end do gloop
9043 
9044 #ifdef Dgptest
9045  write(*,*) 'CalcDgp D(0,0,0,0)',r,d(0,0,0,0)
9046  write(*,*) 'CalcDgp D(0,0,1,0)',r,d(0,0,1,0)
9047  write(*,*) 'CalcDgp D(1,0,0,0)',r,d(1,0,0,0)
9048  write(*,*) 'CalcDgp D(1,0,1,0)',r,d(1,0,1,0)
9049  write(*,*) 'CalcDgp D(0,0,3,0)',r,d(0,0,3,0)
9050 
9051  write(*,*) 'CalcDgp Dij_err',r,dij_err
9052  write(*,*) 'CalcDgp Dij_acc',r,dij_err/abs(d(0,0,0,0))
9053 
9054  write(*,*) 'CalcDgp err',r,derr
9055  write(*,*) 'CalcDgp acc',r,derr/abs(d(0,0,0,0))
9056 #endif
9057 
9058  derr2 = max(derr,dij_err2(0:rmax))
9059  derr = max(derr,dij_err(0:rmax))
9060 
9061 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
9062  ! check if target precision already reached
9063 #ifdef Cutrloop
9064  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
9065  if (r.lt.rmax) then
9066  do rg=r+1,rmax
9067 ! write(*,*) 'CalcDg exit rloop =',rg,r,rmax
9068  do n0=0,rg/2
9069  do n1=0,rg-2*n0
9070  do n2=0,rg-2*n0-n1
9071  d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
9072  end do
9073  end do
9074  end do
9075  end do
9076  if(r.le.rmax) then
9077  do n1=0,r
9078  do n2=0,rg-n1
9079  d(0,n1,n2,r-n1-n2)=0d0
9080  end do
9081  end do
9082  end if
9083 
9084 100 format(((a)))
9085 111 format(a22,2('(',g24.17,',',g24.17,') ':))
9086  call seterrflag_coli(-5)
9087  call errout_coli('CalcDgp',' exit rloop for D', &
9088  errorwriteflag)
9089  if (errorwriteflag) then
9090  write(nerrout_coli,100)' CalcDgp: exit rloop for D ', &
9091  ' should not appear'
9092  write(nerrout_coli,111)' CalcDgp: p10 = ',p10
9093  write(nerrout_coli,111)' CalcDgp: p21 = ',p21
9094  write(nerrout_coli,111)' CalcDgp: p32 = ',p32
9095  write(nerrout_coli,111)' CalcDgp: p30 = ',p30
9096  write(nerrout_coli,111)' CalcDgp: p20 = ',p20
9097  write(nerrout_coli,111)' CalcDgp: p31 = ',p31
9098  write(nerrout_coli,111)' CalcDgp: m02 = ',m02
9099  write(nerrout_coli,111)' CalcDgp: m12 = ',m12
9100  write(nerrout_coli,111)' CalcDgp: m22 = ',m22
9101  write(nerrout_coli,111)' CalcDgp: m32 = ',m32
9102  end if
9103  end if
9104 
9105 #else
9106  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
9107 #endif
9108  exit rloop
9109  end if
9110 
9111  end do rloop
9112 
9113  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
9114  ! already calculated for rmax+1
9115 ! do r=rmax+1,2*rmax
9116 #ifdef notneeded
9117  do r=rmax+1,rmax+1
9118  do n0=r-rmax,r/2
9119  do n1=0,r-2*n0
9120  do n2=0,r-2*n0-n1
9121  n3 = r-2*n0-n1-n2
9122 
9123  write(*,*) 'CalcDgp exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
9124 
9125  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
9126  + 4*duv(n0,n1,n2,n3) &
9127  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
9128  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
9129 
9130  write(*,*) 'CalcDgp exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
9131 
9132  end do
9133  end do
9134  end do
9135  end do
9136 #endif
9137 
9138 #ifdef Dgptest
9139  write(*,*) 'CalcDgp D(1,0,0,0) fin',d(1,0,0,0)
9140  write(*,*) 'CalcDgp D(1,0,1,0) fin',d(1,0,1,0)
9141  write(*,*) 'CalcDgp D(0,0,3,0) fin',d(0,0,3,0)
9142  write(*,*) 'CalcDgp D(0,1,1,1) fin',d(0,1,1,1)
9143 
9144  write(*,*) 'CalcDgp final err',derr
9145  write(*,*) 'CalcDgp final acc',derr/abs(d(0,0,0,0))
9146 #endif
9147 
9148 
9149 ! write(*,*) 'CalcDp Derr ',Derr
9150 ! write(*,*) 'CalcDp Derr2',Derr2
9151 

◆ calcdgpf()

subroutine reductiond::calcdgpf ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordgpf_min,
integer, intent(in)  ordgpf_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 9166 of file reductionD.F90.

9166 
9167  use globald
9168 
9169  integer, intent(in) :: rmax,ordgpf_min,ordgpf_max,id
9170  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
9171  double complex ::Zadj2(4)
9172  double complex, allocatable :: Dexpgpf(:,:,:,:,:), DuvExpgpf(:,:,:,:)
9173  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
9174  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
9175  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
9176  double complex, allocatable :: C_0(:,:,:,:), C_i(:,:,:,:), Shat(:,:,:,:,:)
9177  double complex, allocatable :: Cuv_0(:,:,:,:), Cuv_i(:,:,:,:)
9178  double complex, allocatable :: D_alt(:,:,:,:)
9179  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
9180  double complex :: Smod(3), Daux, elimminf2_coli
9181  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
9182  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
9183  double precision :: maxDexpgpf(0:1,0:rmax+2*ordgpf_min,0:ordgpf_max),truncfacexp,acc_aux
9184  double precision :: minZk
9185  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,a,b,i,j,g,rg,m,n
9186  integer :: inds0(3),inds(3),inds2(2,4),at,bt,k,l,lt,ltt,nl,nlt,nltt
9187  integer :: bin,nid(0:3)
9188  logical :: errorwriteflag
9189 
9190 #ifdef Dgpftest
9191  write(*,*) 'CalcDgpf in, ord',rmax,ordgpf_min,ordgpf_max
9192 #endif
9193 
9194  ! allocation of C functions
9195  rmaxc = rmax + 2*ordgpf_min + 1
9196  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
9197  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
9198  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
9199  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
9200  allocate(cerr_i(0:rmaxc,0:3))
9201  allocate(cerr2_i(0:rmaxc,0:3))
9202  allocate(acc_req_cextra(0:rmaxc))
9203 
9204  ! determine binaries for C-coefficients
9205  k=0
9206  bin = 1
9207  do while (k.le.3)
9208  if (mod(id/bin,2).eq.0) then
9209  nid(k) = id+bin
9210  k = k+1
9211  end if
9212  bin = 2*bin
9213  end do
9214 
9215  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
9216  ! by estimated suppression factors that are multiplied in expansion
9217  acc_req_cextra(0:rmax+1) = acc_req_cind
9218  acc_aux = acc_req_c
9219  if (y_gpf.ne.0d0) then
9220  do g=1,ordgpf_min
9221  acc_req_cextra(rmax+2*g) = acc_req_cextra(rmax+2*g-2)/y_gpf
9222  acc_req_cextra(rmax+2*g+1) = acc_req_cextra(rmax+2*g-1)/y_gpf
9223  acc_aux = acc_aux/max(x_gpf,v_gpf*y_gpf)
9224  acc_req_cextra(rmax+g+1) = min(acc_req_cextra(rmax+g+1),acc_aux)
9225  end do
9226  else if(x_gpf.ne.0d0) then ! 10.07.2017
9227  do g=1,ordgpf_min
9228  acc_aux = acc_aux/x_gpf
9229  acc_req_cextra(rmax+g+1) = acc_aux
9230  end do
9231  else ! 10.07.2017
9232  acc_req_cextra(rmax+2:rmax+2*ordgpf_min+1) = acc_inf
9233  end if
9234 
9235 
9236 
9237 #ifdef Dgpftest
9238  write(*,*) 'CalcDgpf: accreq_Cextra',acc_req_cextra
9239 #endif
9240 
9241  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
9242  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
9243  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
9244  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
9245 
9246 #ifdef Dgpftest
9247  write(*,*) 'CalcDgpf Cerr 0',cerr_i(:,0)
9248  write(*,*) 'CalcDgpf Cerr 1',cerr_i(:,1)
9249  write(*,*) 'CalcDgpf Cerr 2',cerr_i(:,2)
9250  write(*,*) 'CalcDgpf Cerr 3',cerr_i(:,3)
9251 #endif
9252 
9253 
9254  ! shift of integration momentum in C\{0}
9255  do n1=1,rmaxc
9256  do n2=0,rmaxc-n1
9257  do n3=0,rmaxc-n1-n2
9258  n0 = (rmaxc-n1-n2-n3)
9259  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
9260  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
9261  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
9262  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
9263  end do
9264  end do
9265  end do
9266 
9267 
9268 
9269 
9270  ! coefficients Shat defined in (5.13)
9271  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
9272 
9273  do r=0,rmaxc
9274  do n0=0,r/2
9275  do n1=0,r-2*n0
9276  do n2=0,r-2*n0-n1
9277  n3 = r-2*n0-n1-n2
9278 
9279  shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
9280 
9281  if(n1.eq.0) then
9282  shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
9283  end if
9284 
9285  if(n2.eq.0) then
9286  shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
9287  end if
9288 
9289  if(n3.eq.0) then
9290  shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
9291  end if
9292 
9293 #ifdef Dgpftest
9294  if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.1)then
9295  write(*,*) 'CalcDgpf 0 C_0',c_0(n0,n1,n2,n3)
9296  write(*,*) 'CalcDgpf 0 C_1',c_i(n0,n2,n3,1)
9297  write(*,*) 'CalcDgpf 0 C_2',c_i(n0,n1,n3,2)
9298  write(*,*) 'CalcDgpf 0 C_3',c_i(n0,n1,n2,3)
9299  write(*,*) 'CalcDgpf 0 Sh1',shat(n0,n1,n2,n3,1)
9300  write(*,*) 'CalcDgpf 0 Sh2',shat(n0,n1,n2,n3,2)
9301  write(*,*) 'CalcDgpf 0 Sh3',shat(n0,n1,n2,n3,3)
9302  endif
9303 #endif
9304 
9305  end do
9306  end do
9307  end do
9308  end do
9309 
9310  ! choose reduction formulas with smallest expansion terms
9311  minzk = maxz
9312  if (maxval(abs(z(1,1:3))).le.minzk) then
9313  minzk = maxval(abs(z(1,1:3)))
9314  k = 1
9315  l = 1
9316  lt = 2
9317  ltt = 3
9318  end if
9319  if (maxval(abs(z(2,1:3))).lt.minzk) then
9320  minzk = maxval(abs(z(2,1:3)))
9321  k = 2
9322  l = 2
9323  lt = 3
9324  ltt = 1
9325  end if
9326  if (maxval(abs(z(3,1:3))).lt.minzk) then
9327  minzk = maxval(abs(z(3,1:3)))
9328  k = 3
9329  l = 3
9330  lt = 1
9331  ltt = 2
9332  end if
9333 
9334 #ifdef Dgpftest
9335  write(*,*) 'CalcDgpf: Z',k, maxval(abs(z(k,1:3)))
9336 #endif
9337 
9338 
9339  ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
9340  rmaxexp = rmaxc+1
9341  allocate(dexpgpf(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:rmaxexp-2,0:ordgpf_max))
9342 
9343 
9344  ! calculate Cuv
9345  allocate(duvexpgpf(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
9346  call calcduv(duvexpgpf,cuv_0,mm02,f,rmaxexp,id)
9347  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgpf(0:rmax,0:rmax,0:rmax,0:rmax)
9348 
9349  ! allocate arrays for error propagation
9350  allocate(d00_err(0:rmaxexp))
9351  allocate(dij_err(0:rmaxexp))
9352  allocate(cij_err(0:rmaxc))
9353 
9354  allocate(d00_err2(0:rmaxexp))
9355  allocate(dij_err2(0:rmaxexp))
9356  allocate(cij_err2(0:rmaxc))
9357 
9358  ! initialize accuracy estimates
9359  derr = acc_inf
9360  dij_err =0d0
9361  d00_err =0d0
9362  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
9363 
9364  derr2 = acc_inf
9365  dij_err2 =0d0
9366  d00_err2 =0d0
9367  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
9368 
9369  ! truncation of expansion if calculated term larger than truncfacexp * previous term
9370  ! crucial for expansion parameters between 0.1 and 1 !!!
9371  truncfacexp = sqrt(fac_gpf) * truncfacd
9372  gtrunc = ordgpf_max
9373 
9374 ! calculate D(1,n1,n2,n3) up to rank r+2
9375 ! calculate D(0,n1,n2,n3) up to rank r
9376  rloop: do r=0,rmaxexp-2
9377 
9378  if (r.gt.rmax+2*gtrunc+2) exit rloop
9379 
9380  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
9381  ! 0th-order coefficients
9382  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
9383 
9384  ! calculating D_00ijk.. exploiting eq. (5.71)
9385  maxdexpgpf(1,r,0)=0d0
9386  do nl=r,0,-1
9387  do nlt=r-nl,0,-1
9388  nltt = r-nl-nlt
9389  inds0(l) = nl
9390  inds0(lt) = nlt
9391  inds0(ltt) = nltt
9392 
9393  inds(l) = nl+1
9394  inds(lt) = nlt
9395  inds(ltt) = nltt
9396 
9397  daux = shat(0,inds(1),inds(2),inds(3),k)
9398 
9399  dexpgpf(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1))
9400 
9401  maxdexpgpf(1,r,0) = maxdexpgpf(1,r,0) + abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),0) )
9402 
9403 ! if (r+2.le.rmax) then ! for fixed rank
9404  if (r+1.le.rmax) then
9405  d(1,inds0(1),inds0(2),inds0(3)) = dexpgpf(1,inds0(1),inds0(2),inds0(3),0)
9406  end if
9407 
9408 
9409 
9410  end do
9411  end do
9412 
9413  ! calculate D_ijkl.. exploiting eq. (5.72)
9414  maxdexpgpf(0,r,0)=0d0
9415  do n1=0,r
9416  do n2=0,r-n1
9417  n3 = r-n1-n2
9418 
9419  daux = 2d0*(4+r+r)*dexpgpf(1,n1,n2,n3,0) - 4*duvexpgpf(1,n1,n2,n3) &
9420  - 2*c_0(0,n1,n2,n3)
9421 
9422 #ifdef Dgpftest
9423  if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
9424  write(*,*) 'CalcDgpf 0 Daux',daux
9425  endif
9426 #endif
9427 
9428  dexpgpf(0,n1,n2,n3,0) = daux/(2d0*m02)
9429 
9430 #ifdef Dgpftest
9431  if(n1.eq.1.and.n2.eq.1.and.n3.eq.1)then
9432  write(*,*) 'CalcDgpf D_0',r,dexpgpf(0,n1,n2,n3,0)
9433  endif
9434 #endif
9435 
9436  maxdexpgpf(0,r,0) = maxdexpgpf(0,r,0) + abs(dexpgpf(0,n1,n2,n3,0))
9437  if (r.le.rmax) then
9438  d(0,n1,n2,n3) = dexpgpf(0,n1,n2,n3,0)
9439 ! Derr(r) = abs(maxZadjf/maxXadj*Dexpgpf(0,n1,n2,n3,0))
9440  end if
9441 
9442  end do
9443  end do
9444 
9445  if (r.le.rmax) then
9446 ! Derr(r) = abs(maxZadjf/Xadj(a,b))*maxDexpgpf(0,r,0)
9447  derr(r) = fac_gpf*maxdexpgpf(0,r,0)
9448  endif
9449 
9450  ! error propagation from C's
9451  d00_err(r+2) = cij_err(r+1)/2d0
9452  dij_err(r)=1d0/abs(m02)*max((2*r+4)*d00_err(r+2),cerr_i(r,0))
9453 
9454  d00_err2(r+2) = cij_err2(r+1)/2d0
9455  dij_err2(r)=1d0/abs(m02)*max((2*r+4)*d00_err2(r+2),cerr2_i(r,0))
9456 
9457  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9458  ! higher order coefficients
9459  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
9460 
9461  rg = r
9462  gloop: do g=1,min(gtrunc,r/2)
9463  rg = rg-2
9464 
9465  ! calculating D_00ijk.. exploiting eq. (5.71)
9466  maxdexpgpf(1,rg,g) = 0d0
9467  do nl=rg,0,-1
9468  do nlt=rg-nl,0,-1
9469  nltt = rg-nl-nlt
9470  inds0(l) = nl
9471  inds0(lt) = nlt
9472  inds0(ltt) = nltt
9473 
9474  inds = inds0
9475  inds(l) = inds(l)+1
9476  daux = -f(k)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
9477 
9478  inds(l) = inds(l)+1
9479  daux = daux - z(k,l)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
9480 
9481  inds(l) = inds(l)-1
9482  inds(lt) = inds(lt)+1
9483  daux = daux - z(k,lt)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
9484 
9485  inds(lt) = inds(lt)-1
9486  inds(ltt) = inds(ltt)+1
9487  daux = daux - z(k,ltt)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
9488 
9489  dexpgpf(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1))
9490 
9491  maxdexpgpf(1,rg,g) = maxdexpgpf(1,rg,g) + abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g) )
9492 ! if (rg+2.le.rmax) then
9493 ! D(1,inds0(1),inds0(2),inds0(3)) = D(1,inds0(1),inds0(2),inds0(3)) &
9494 ! + Dexpgpf(1,inds0(1),inds0(2),inds0(3),g)
9495 ! end if
9496 
9497 
9498  if (g.eq.1.and.abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)).gt. &
9499  1d1*truncfacexp*max(1/m2scale,maxdexpgpf(1,rg,g-1)) .or. &
9500  g.ge.2.and.abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)).gt. &
9501  truncfacexp*maxdexpgpf(1,rg,g-1)) then
9502 
9503 #ifdef Dgpftest
9504  write(*,*) 'CalcDgpf exit gloop',1,inds0(1),inds0(2),inds0(3),g, &
9505  abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgpf(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgpf(1,rg,g-1)
9506 #endif
9507 
9508  gtrunc = g-1
9509  exit gloop
9510 ! gtrunc = g
9511 ! cycle gloop ! worsens results for Dgy ??
9512  end if
9513 
9514  end do
9515  end do
9516 
9517 #ifndef PPEXP00
9518 ! if (rg+2.le.rmax) then ! for fixed rank
9519  if (rg+1.le.rmax) then
9520  do n1=0,rg
9521  do n2=0,rg-n1
9522  n3=rg-n1-n2
9523  d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgpf(1,n1,n2,n3,g)
9524  end do
9525  end do
9526  end if
9527 #endif
9528 
9529  ! calculate D_ijkl.. exploiting eq. (5.72)
9530  maxdexpgpf(0,rg,g) = 0d0
9531  do n1=0,rg
9532  do n2=0,rg-n1
9533  n3 = rg-n1-n2
9534 
9535  inds(1) = n1
9536  inds(2) = n2
9537  inds(3) = n3
9538  daux = 2*(4+rg+rg)*dexpgpf(1,n1,n2,n3,g)
9539 
9540  do i=1,3
9541  do j=1,3
9542  inds(i)=inds(i)+1
9543  inds(j)=inds(j)+1
9544  daux = daux + z(i,j)*dexpgpf(0,inds(1),inds(2),inds(3),g-1)
9545  inds(i)=inds(i)-1
9546  inds(j)=inds(j)-1
9547  end do
9548  end do
9549 
9550  dexpgpf(0,n1,n2,n3,g) = daux/(2*m02)
9551 
9552  maxdexpgpf(0,rg,g) = maxdexpgpf(0,rg,g) + abs(dexpgpf(0,n1,n2,n3,g))
9553 
9554 ! if (rg.le.rmax) then
9555 ! D(0,n1,n2,n3) = D(0,n1,n2,n3) + Dexpgpf(0,n1,n2,n3,g)
9556 ! end if
9557 
9558  if (g.eq.1.and.abs(dexpgpf(0,n1,n2,n3,g)).gt. &
9559  truncfacexp*max(1/m2scale**2,maxdexpgpf(0,rg,g-1)) .or. &
9560  g.ge.2.and.abs(dexpgpf(0,n1,n2,n3,g)).gt. &
9561  truncfacexp*maxdexpgpf(0,rg,g-1)) then
9562 
9563 #ifdef Dgpftest
9564  write(*,*) 'CalcDgpf exit gloop',n1,n2,n3,g,abs(dexpgpf(0,n1,n2,n3,g)),abs(dexpgpf(0,n1,n2,n3,g-1)),maxdexpgpf(0,rg,g-1)
9565 #endif
9566 
9567  gtrunc = g-1
9568  exit gloop
9569 ! gtrunc = g
9570 ! cycle gloop
9571  end if
9572 
9573  end do
9574  end do
9575 
9576  ! error propagation from C's
9577  if(rg.gt.1)then
9578  d00_err(rg+2) = max(d00_err(rg+2), &
9579  fmax/2d0*dij_err(rg+1), &
9580  maxz/2d0*dij_err(rg+2))
9581  end if
9582  dij_err(rg)=max(dij_err(rg),maxz/(2*abs(m02))*dij_err(rg+2), &
9583  (2*rg+4)/abs(m02)*d00_err(rg+2))
9584 
9585  if(rg.gt.1)then
9586  d00_err2(rg+2) = max(d00_err2(rg+2), &
9587  fmax/2d0*dij_err2(rg+1), &
9588  maxz/2d0*dij_err2(rg+2))
9589  end if
9590  dij_err2(rg)=max(dij_err2(rg),maxz/(2*abs(m02))*dij_err2(rg+2), &
9591  (2*rg+4)/abs(m02)*d00_err2(rg+2))
9592 
9593 #ifdef PPEXP00
9594  if (rg+2.le.rmax) then
9595  do n1=0,rg
9596  do n2=0,rg-n1
9597  n3=rg-n1-n2
9598  d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgpf(1,n1,n2,n3,g)
9599  end do
9600  end do
9601  end if
9602 #endif
9603 
9604  if (rg.le.rmax) then
9605  derr(rg) = 0d0
9606  do n1=0,rg
9607  do n2=0,rg-n1
9608  n3 = rg-n1-n2
9609  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgpf(0,n1,n2,n3,g)
9610  if(abs(dexpgpf(0,n1,n2,n3,g-1)).ne.0d0) then
9611  derr(rg)=max(derr(rg),abs(dexpgpf(0,n1,n2,n3,g))*min(1d0,abs(dexpgpf(0,n1,n2,n3,g))/abs(dexpgpf(0,n1,n2,n3,g-1))))
9612  else
9613  derr(rg)=max(derr(rg),abs(dexpgpf(0,n1,n2,n3,g)))
9614  endif
9615 
9616 #ifdef Dgpftest
9617 ! write(*,*) 'CalcDgpf Derr calc',rg,Derr(rg),n1,n2,n3,g,abs(Dexpgpf(0,n1,n2,n3,g)),abs(Dexpgpf(0,n1,n2,n3,g-1))
9618 #endif
9619 
9620  end do
9621  end do
9622 
9623  ! if error from C's larger than error from expansion stop expansion
9624  ! allow for one more term, as each step involves only even or odd ranks
9625 #ifdef PVEST2
9626  if(dij_err2(rg).gt.3d0*derr(rg)) then
9627 #else
9628  if(dij_err(rg).gt.3d0*derr(rg)) then
9629 #endif
9630  gtrunc = min(g,gtrunc)
9631 ! gtrunc = min(g+1,gtrunc)
9632 
9633 #ifdef Dgpftest
9634  write(*,*) 'CalcDgpf exit err',rg,g,gtrunc
9635  write(*,*) 'CalcDgpf exit err',dij_err(rg),derr(rg)
9636 #endif
9637  end if
9638 
9639  end if
9640 
9641  end do gloop
9642 
9643 #ifdef Dgpftest
9644 
9645  write(*,*) 'CalcDgpf D(1,0,0,0)',r,d(1,0,0,0)
9646  write(*,*) 'CalcDgpf D(0,0,0,0)',r,d(0,0,0,0)
9647  write(*,*) 'CalcDgpf D(0,0,0,1)',r,d(0,0,0,1)
9648  if (r.ge.2.and.rmax.ge.2) then
9649  write(*,*) 'CalcDgpf D(0,0,0,2)',r,d(0,0,0,2)
9650  endif
9651  if (r.ge.3.and.rmax.ge.3)then
9652  write(*,*) 'CalcDgpf D(1,0,0,1)',r,d(1,0,0,1)
9653  write(*,*) 'CalcDgpf D(0,1,0,2)',r,d(0,1,0,2)
9654  write(*,*) 'CalcDgpf D(0,0,0,3)',r,d(0,0,0,3)
9655  write(*,*) 'CalcDgpf D(0,1,1,1)',r,d(0,1,1,1)
9656  write(*,*) 'CalcDgpf D(0,2,1,0)',r,d(0,2,1,0)
9657  endif
9658 
9659  write(*,*) 'CalcDgpf Dij_err',r,dij_err
9660  write(*,*) 'CalcDgpf Dij_acc',r,dij_err/abs(d(0,0,0,0))
9661 
9662  write(*,*) 'CalcDgpf err',r,g,derr
9663  write(*,*) 'CalcDgpf acc',r,g,derr/abs(d(0,0,0,0))
9664 #endif
9665 
9666  derr2 = max(derr,dij_err2(0:rmax))
9667  derr = max(derr,dij_err(0:rmax))
9668 
9669 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
9670  ! check if target precision already reached
9671 #ifdef Cutrloop
9672  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
9673  if (r.lt.rmax) then
9674  do rg=r+1,rmax
9675  do n1=0,rg
9676  do n2=0,rg-n1
9677  d(0,n1,n2,rg-n1-n2)=0d0
9678  end do
9679  end do
9680  end do
9681  do rg=r+1,rmax
9682  do n1=0,rg-2
9683  do n2=0,rg-2-n1
9684  d(1,n1,n2,rg-2-n1-n2)=0d0
9685  end do
9686  end do
9687  end do
9688 
9689 100 format(((a)))
9690 111 format(a22,2('(',g24.17,',',g24.17,') ':))
9691  call seterrflag_coli(-5)
9692  call errout_coli('CalcDgpf',' exit rloop for D', &
9693  errorwriteflag)
9694  if (errorwriteflag) then
9695  write(nerrout_coli,100)' CalcDgpf: exit rloop for D ', &
9696  ' should not appear'
9697  write(nerrout_coli,111)' CalcDgpf: p10 = ',p10
9698  write(nerrout_coli,111)' CalcDgpf: p21 = ',p21
9699  write(nerrout_coli,111)' CalcDgpf: p32 = ',p32
9700  write(nerrout_coli,111)' CalcDgpf: p30 = ',p30
9701  write(nerrout_coli,111)' CalcDgpf: p20 = ',p20
9702  write(nerrout_coli,111)' CalcDgpf: p31 = ',p31
9703  write(nerrout_coli,111)' CalcDgpf: m02 = ',m02
9704  write(nerrout_coli,111)' CalcDgpf: m12 = ',m12
9705  write(nerrout_coli,111)' CalcDgpf: m22 = ',m22
9706  write(nerrout_coli,111)' CalcDgpf: m32 = ',m32
9707  end if
9708  end if
9709 
9710 #else
9711  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
9712 #endif
9713 
9714  exit rloop
9715 
9716  end if
9717 
9718  end do rloop
9719 
9720 
9721  ! calculating D_0000ijk.. exploiting eq. (5.71)
9722  do r=4,rmax+1 ! includes rmax+1 24.01.16
9723  do n0=2,max(rmax,r/2) ! includes rmax+1 24.01.16
9724  do nl=r-2*n0,0,-1
9725  do nlt=r-2*n0-nl,0,-1
9726  nltt = r-2*n0-nl-nlt
9727  inds0(l) = nl
9728  inds0(lt) = nlt
9729  inds0(ltt) = nltt
9730 
9731  inds(l) = nl+1
9732  inds(lt) = nlt
9733  inds(ltt) = nltt
9734  daux = shat(n0-1,inds(1),inds(2),inds(3),k) &
9735  - f(k)*d(n0-1,inds(1),inds(2),inds(3)) &
9736  - z(k,1)*d(n0-1,inds(1)+1,inds(2),inds(3)) &
9737  - z(k,2)*d(n0-1,inds(1),inds(2)+1,inds(3)) &
9738  - z(k,3)*d(n0-1,inds(1),inds(2),inds(3)+1)
9739 
9740  d(n0,inds0(1),inds0(2),inds0(3)) = daux/(2*(nl+1))
9741 
9742  end do
9743  end do
9744  end do
9745  end do
9746 
9747  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
9748  ! already calculated for rmax+1 with extension of 24.01.16 above
9749 ! do r=rmax+1,2*rmax
9750 #ifdef notneeded
9751  do r=rmax+1,rmax+1
9752  do n0=r-rmax,r/2
9753  do n1=0,r-2*n0
9754  do n2=0,r-2*n0-n1
9755  n3 = r-2*n0-n1-n2
9756 
9757  write(*,*) 'CalcDgpf exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
9758 
9759  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
9760  + 4*duv(n0,n1,n2,n3) &
9761  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
9762  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
9763 
9764  write(*,*) 'CalcDgpf dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
9765 
9766  end do
9767  end do
9768  end do
9769  end do
9770 #endif
9771 
9772 #ifdef Dgpftest
9773  if(rmax.ge.2) then
9774  write(*,*) 'CalcDgpf D(1,0,0,0) fin',d(1,0,0,0)
9775  write(*,*) 'CalcDgpf D(0,0,0,2) fin',d(0,0,0,2)
9776  if(rmax.ge.3) then
9777  write(*,*) 'CalcDgpf D(1,0,1,0) fin',d(1,0,1,0)
9778  write(*,*) 'CalcDgpf D(0,1,1,1) fin',d(0,1,1,1)
9779  endif
9780  endif
9781 
9782  write(*,*) 'CalcDgpf final err',derr
9783  write(*,*) 'CalcDgpf final acc',derr/abs(d(0,0,0,0))
9784 #endif
9785 
9786 ! write(*,*) 'CalcDgpf Derr ',Derr
9787 ! write(*,*) 'CalcDgpf Derr2',Derr2
9788 

◆ calcdgr()

subroutine reductiond::calcdgr ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordgr_min,
integer, intent(in)  ordgr_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 5883 of file reductionD.F90.

5883 
5884  use globald
5885 
5886  integer, intent(in) :: rmax,ordgr_min,ordgr_max,id
5887  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
5888  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
5889  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
5890  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
5891  double complex :: Zadjfj,Zadj2(3,3), Zadjkl, Xtilde
5892  double complex, allocatable :: Dexpgr(:,:,:,:,:), DuvExpgr(:,:,:,:)
5893  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
5894  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
5895  double complex, allocatable :: D_alt(:,:,:,:)
5896  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
5897  double complex :: Smod(3), Skl, Daux
5898  double complex :: cC0f, elimminf2_coli
5899  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
5900  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
5901 ! double precision :: maxDexpgr(0:1,0:rmax+ordgr_min+1,0:ordgr_max),truncfacexp
5902  double precision :: maxDexpgr(0:1,0:2*(rmax+ordgr_min),0:ordgr_max),truncfacexp
5903  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg,nt,mt,nn,nnt,nntt
5904  integer :: inds0(3), inds1(3), inds(3)
5905  integer :: bin,nid(0:3)
5906  logical :: errorwriteflag
5907 
5908 #ifdef Dgrtest
5909  write(*,*) 'CalcDgr in, ord',rmax,ordgr_min,ordgr_max
5910 #endif
5911 
5912  ! allocation of C functions
5913  rmaxc = 2*rmax + 2*ordgr_min
5914  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
5915  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
5916  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
5917  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
5918  allocate(cerr_i(0:rmaxc,0:3))
5919  allocate(cerr2_i(0:rmaxc,0:3))
5920  allocate(acc_req_cextra(0:rmaxc))
5921 
5922  ! determine binaries for C-coefficients
5923  k=0
5924  bin = 1
5925  do while (k.le.3)
5926  if (mod(id/bin,2).eq.0) then
5927  nid(k) = id+bin
5928  k = k+1
5929  end if
5930  bin = 2*bin
5931  end do
5932 
5933  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
5934  ! by estimated suppression factors that are multiplied in expansion
5935  acc_req_cextra(0:rmax) = acc_req_cind
5936  if (fac_gr.ne.0d0) then
5937  do r=rmax+1,rmaxc
5938 ! acc_req_Cextra(r)= acc_req_Cextra(r-1)/x_g
5939 ! 09.03.15
5940  acc_req_cextra(r)= acc_req_cextra(r-1)/fac_gr
5941  end do
5942  else ! 10.07.2017
5943  acc_req_cextra(rmax+1:rmaxc) = acc_inf
5944  end if
5945 
5946  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
5947  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
5948  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
5949  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
5950 
5951 #ifdef Dgrtest
5952  write(*,*) 'CalcDgr Cerr 0 =',cerr_i(0:rmaxc,0)
5953  write(*,*) 'CalcDgr Cerr 1 =',cerr_i(0:rmaxc,1)
5954  write(*,*) 'CalcDgr Cerr 2 =',cerr_i(0:rmaxc,2)
5955  write(*,*) 'CalcDgr Cerr 3 =',cerr_i(0:rmaxc,3)
5956  write(*,*) 'CalcDgr Cacc 0 =',cerr_i(0:rmaxc,0)/abs(c_0(0,0,0,0))
5957  write(*,*) 'CalcDgr Cacc 1 =',cerr_i(0:rmaxc,1)/abs(c_i(0,0,0,1))
5958  write(*,*) 'CalcDgr Cacc 2 =',cerr_i(0:rmaxc,2)/abs(c_i(0,0,0,2))
5959  write(*,*) 'CalcDgr Cacc 3 =',cerr_i(0:rmaxc,3)/abs(c_i(0,0,0,3))
5960 #endif
5961 
5962  ! shift of integration momentum in C\{0}
5963  do n1=1,rmaxc
5964  do n2=0,rmaxc-n1
5965  do n3=0,rmaxc-n1-n2
5966  n0 = (rmaxc-n1-n2-n3)
5967  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
5968  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
5969  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
5970  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
5971  end do
5972  end do
5973  end do
5974 
5975 
5976  ! calculate adjugated Gram matrix
5977 ! mm02 = elimminf2_coli(m02)
5978 ! mm12 = elimminf2_coli(m12)
5979 ! mm22 = elimminf2_coli(m22)
5980 ! mm32 = elimminf2_coli(m32)
5981 ! q10 = elimminf2_coli(p10)
5982 ! q21 = elimminf2_coli(p21)
5983 ! q32 = elimminf2_coli(p32)
5984 ! q30 = elimminf2_coli(p30)
5985 ! q31 = elimminf2_coli(p31)
5986 ! q20 = elimminf2_coli(p20)
5987 
5988 ! Z(1,1) = 2d0*q10
5989 ! Z(2,1) = q10+q20-q21
5990 ! Z(3,1) = q10+q30-q31
5991 ! Z(1,2) = Z(2,1)
5992 ! Z(2,2) = 2d0*q20
5993 ! Z(3,2) = q20+q30-q32
5994 ! Z(1,3) = Z(3,1)
5995 ! Z(2,3) = Z(3,2)
5996 ! Z(3,3) = 2d0*q30
5997 
5998 ! q1q2 = (q10+q20-q21)
5999 ! q1q3 = (q10+q30-q31)
6000 ! q2q3 = (q20+q30-q32)
6001 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
6002 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
6003 
6004 ! Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
6005 ! Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
6006 ! Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
6007 ! Zadj(1,2) = Zadj(2,1)
6008 ! Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
6009 ! Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
6010 ! Zadj(1,3) = Zadj(3,1)
6011 ! Zadj(2,3) = Zadj(3,2)
6012 ! Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
6013 !
6014 ! f(1) = q10+mm02-mm12
6015 ! f(2) = q20+mm02-mm22
6016 ! f(3) = q30+mm02-mm32
6017 
6018 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
6019 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
6020 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
6021 
6022 
6023  ! coefficients Shat defined in (5.13)
6024  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
6025 
6026  do r=0,rmaxc
6027  do n0=0,r/2
6028  do n1=0,r-2*n0
6029  do n2=0,r-2*n0-n1
6030  n3 = r-2*n0-n1-n2
6031 
6032  shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
6033 
6034  if(n1.eq.0) then
6035  shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
6036 
6037  if(n0.eq.3.and.r.eq.6) then
6038 ! write(*,*) 'CalcDgr test ',n0,n2,n3,C_i(n0,n2,n3,1),Shat(n0,n1,n2,n3,1)
6039  endif
6040 
6041  end if
6042 
6043  if(n2.eq.0) then
6044  shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
6045 
6046  if(n0.eq.3.and.r.eq.6) then
6047 ! write(*,*) 'CalcDgr test ',n0,n1,n3,C_i(n0,n1,n3,2),Shat(n0,n1,n2,n3,2)
6048  endif
6049 
6050  end if
6051 
6052  if(n3.eq.0) then
6053 
6054  shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
6055 
6056  if(n0.eq.3.and.r.eq.6) then
6057 ! write(*,*) 'CalcDgr test ',n0,n1,n2,C_i(n0,n1,n2,3), Shat(n0,n1,n2,n3,3)
6058  endif
6059 
6060  end if
6061 
6062  end do
6063  end do
6064  end do
6065  end do
6066 
6067 
6068  ! choose reduction formulas with biggest denominators
6069  if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
6070  j = 1
6071  else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
6072  j = 2
6073  else
6074  j = 3
6075  end if
6076 
6077  maxzadj2f = 0d0 ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
6078  ! Zadj2(n,m) == Zadf2(k,n,l,m)
6079  if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
6080  maxzadj2f = abs(zadj2f(1,2,1))
6081  k = 1
6082  n = 2
6083  nt = 3
6084  l = 1
6085  m = 2
6086  mt = 3
6087  zadj2(2,2) = -z(3,3)
6088  zadj2(2,3) = z(3,2)
6089  zadj2(3,2) = z(2,3)
6090  zadj2(3,3) = -z(2,2)
6091  end if
6092  if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
6093  maxzadj2f = abs(zadj2f(1,2,2))
6094  k = 1
6095  n = 2
6096  nt = 3
6097  l = 2
6098  m = 3
6099  mt = 1
6100  zadj2(2,1) = z(3,3)
6101  zadj2(2,3) = -z(3,1)
6102  zadj2(3,1) = -z(2,3)
6103  zadj2(3,3) = z(2,1)
6104 ! if(abs(Zadj(n,l)).gt.abs(Zadj(k,l))) then
6105 ! k = 2
6106 ! n = 1
6107 ! nt = 3
6108 ! Zadj2(1,1) = -Z(3,3)
6109 ! Zadj2(1,3) = Z(3,1)
6110 ! Zadj2(3,1) = Z(1,3)
6111 ! Zadj2(3,3) = -Z(1,1)
6112 ! endif
6113  end if
6114  if (abs(zadj2f(1,2,3)).gt.maxzadj2f) then
6115  maxzadj2f = abs(zadj2f(1,2,3))
6116  k = 1
6117  n = 2
6118  nt = 3
6119  l = 3
6120  m = 1
6121  mt = 2
6122  zadj2(2,1) = -z(3,2)
6123  zadj2(2,2) = z(3,1)
6124  zadj2(3,1) = z(2,2)
6125  zadj2(3,2) = -z(2,1)
6126  end if
6127 
6128  if (abs(zadj2f(1,3,1)).gt.maxzadj2f) then
6129  maxzadj2f = abs(zadj2f(1,3,1))
6130  k = 1
6131  n = 3
6132  nt = 2
6133  l = 1
6134  m = 2
6135  mt = 3
6136  zadj2(3,2) = z(2,3)
6137  zadj2(3,3) = -z(2,2)
6138  zadj2(2,2) = -z(3,3)
6139  zadj2(2,3) = z(3,2)
6140  end if
6141  if (abs(zadj2f(1,3,2)).gt.maxzadj2f) then
6142  maxzadj2f = abs(zadj2f(1,3,2))
6143  k = 1
6144  n = 3
6145  nt = 2
6146  l = 2
6147  m = 3
6148  mt = 1
6149  zadj2(3,1) = -z(2,3)
6150  zadj2(3,3) = z(2,1)
6151  zadj2(2,1) = z(3,3)
6152  zadj2(2,3) = -z(3,1)
6153  end if
6154  if (abs(zadj2f(1,3,3)).gt.maxzadj2f) then
6155  maxzadj2f = abs(zadj2f(1,3,3))
6156  k = 1
6157  n = 3
6158  nt = 2
6159  l = 3
6160  m = 1
6161  mt = 2
6162  zadj2(3,1) = z(2,2)
6163  zadj2(3,2) = -z(2,1)
6164  zadj2(2,1) = -z(3,2)
6165  zadj2(2,2) = z(3,1)
6166  end if
6167 
6168  if (abs(zadj2f(2,3,1)).gt.maxzadj2f) then
6169  maxzadj2f = abs(zadj2f(2,3,1))
6170  k = 2
6171  n = 3
6172  nt = 1
6173  l = 1
6174  m = 2
6175  mt = 3
6176  zadj2(3,2) = -z(1,3)
6177  zadj2(3,3) = z(1,2)
6178  zadj2(1,2) = z(3,3)
6179  zadj2(1,3) = -z(3,2)
6180  end if
6181  if (abs(zadj2f(2,3,2)).gt.maxzadj2f) then
6182  maxzadj2f = abs(zadj2f(2,3,2))
6183  k = 2
6184  n = 3
6185  nt = 1
6186  l = 2
6187  m = 3
6188  mt = 1
6189  zadj2(3,1) = z(1,3)
6190  zadj2(3,3) = -z(1,1)
6191  zadj2(1,1) = -z(3,3)
6192  zadj2(1,3) = z(3,1)
6193  end if
6194  if (abs(zadj2f(2,3,3)).gt.maxzadj2f) then
6195  maxzadj2f = abs(zadj2f(2,3,3))
6196  k = 2
6197  n = 3
6198  nt = 1
6199  l = 3
6200  m = 1
6201  mt = 2
6202  zadj2(3,1) = -z(1,2)
6203  zadj2(3,2) = z(1,1)
6204  zadj2(1,1) = z(3,2)
6205  zadj2(1,2) = -z(3,1)
6206  end if
6207 
6208 #ifdef Dgrtest
6209  write(*,*) 'CalcDgr maxZadj2f ',maxzadj2f,maxval(abs(zadj2f(:,:,:)))
6210 ! write(*,*) 'CalcDgr Zadj2f ',Zadj2f
6211 ! write(*,*) 'CalcDgr Zadj2f ',Zadj2f(1,1,2),Zadj2f(2,1,1)
6212 #endif
6213 
6214  zadjfj = zadjf(j)
6215  zadjkl = zadj(k,l)
6216 ! Xtilde = Xadj(k,l)
6217 
6218 ! write(*,*) 'CalcDg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
6219 
6220 
6221 #ifdef Dgrtest
6222 ! write(*,*) 'CalcDgr k,n,nt,l',k,n,nt,l,m,mt
6223 ! write(*,*) 'CalcDgr pars', maxZadj2f,Zadj2f(k,n,l),Zadj(k,l),maxZadj
6224 ! write(*,*) 'CalcDgr pars', abs(Zadjf(l)),abs(detZ)
6225 ! write(*,*) 'CalcDgr pars', abs(Zadjf(l)/ maxZadj2f),abs(detZ/maxZadj2f)
6226 #endif
6227 
6228  zadjfj = zadjf(j)
6229  zadjkl = zadj(k,l)
6230 
6231  ! allocation of array for expanded D-coefficients
6232  rmaxexp = rmaxc
6233  allocate(dexpgr(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgr_max))
6234 
6235  ! calculate Duv
6236  allocate(duvexpgr(0:(rmaxexp+1),0:rmaxexp+1,0:rmaxexp+1,0:rmaxexp+1))
6237 
6238 ! if(rmaxexp.ge.16)then
6239 ! write(*,*) 'CalcDgr Cuv_0',Cuv_0(1,3,3,3)
6240 ! endif
6241 
6242  call calcduv(duvexpgr,cuv_0,mm02,f,rmaxexp+1,id)
6243  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgr(0:rmax,0:rmax,0:rmax,0:rmax)
6244 
6245  ! allocate arrays for error propagation
6246  allocate(d00_err(0:rmaxexp))
6247  allocate(dij_err(0:rmaxexp))
6248  allocate(cij_err(0:rmaxc))
6249 
6250  allocate(d00_err2(0:rmaxexp))
6251  allocate(dij_err2(0:rmaxexp))
6252  allocate(cij_err2(0:rmaxc))
6253 
6254  ! initialize accuracy estimates
6255  derr = acc_inf
6256  dij_err =0d0
6257  d00_err =0d0
6258  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
6259 
6260  derr2 = acc_inf
6261  dij_err2 =0d0
6262  d00_err2 =0d0
6263  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
6264 
6265 #ifdef Dgrtest
6266  write(*,*) 'CalcDgr Cij_err = ',cij_err
6267  write(*,*) 'CalcDgr C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
6268  write(*,*) 'CalcDgr C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
6269 #endif
6270 
6271 ! maxZadj = maxval(abs(Zadj))
6272 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
6273 
6274  ! truncation of expansion if calculated term larger than truncfacexp * previous term
6275  ! crucial for expansion parameters between 0.1 and 1 !!!
6276  truncfacexp = sqrt(fac_gr) * truncfacd
6277  gtrunc = ordgr_max
6278 
6279 ! calculate D(n0,n1,n2,n3) up to rank r+n0
6280  rloop: do r=0,rmaxexp/2
6281 
6282 #ifdef Dgrtest
6283 ! write(*,*) 'CalcDgr rloop',r,rmax,gtrunc
6284 #endif
6285 
6286  if (r.gt.rmax+gtrunc) exit rloop
6287 
6288 #ifdef Dgrtest
6289  write(*,*) 'CalcDgr rloop',r,rmaxexp,rmaxc
6290 #endif
6291 
6292  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6293  ! 0th-order coefficients
6294  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6295 
6296  ! calculating
6297  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
6298  ! exploiting eq. (5.40) - (5.53) solved for D_00i1..<ir>...iP
6299  maxdexpgr(1,r,0)=0d0
6300 
6301 ! Note r is not the rank! r= n0+n1+n2+n3 rank=2*n0+n1+n2+n3
6302  do n0=r,1,-1
6303  do nn=r-n0,0,-1
6304  do nnt=r-n0-nn,0,-1
6305  nntt = r-n0-nn-nnt
6306 
6307 #ifdef Dgrtest
6308 ! write(*,*) 'CalcDgr rloop',n0,nn,nnt,nntt,Zadj2f(k,n,l)
6309 #endif
6310 
6311  inds0(n) = nn
6312  inds0(nt) = nnt
6313  inds0(k) = nntt
6314 
6315 #ifdef Dgrtest
6316  write(*,*) 'CalcDgr inds0',n0,inds0
6317 #endif
6318 
6319  inds1(n) = nn+1
6320  inds1(nt) = nnt
6321  inds1(k) = nntt
6322 
6323 #ifdef Dgrtest
6324  write(*,*) 'CalcDgr inds1',n0,inds1
6325 #endif
6326 
6327 ! Daux = 0d0
6328  daux = -zadj(k,l)*c_0(n0-1,inds1(1),inds1(2),inds1(3))
6329 
6330 ! Daux = 2*Zadj(k,l) * (1+r-2*n0) * Dexpgr(n0,inds1(1),inds1(2),inds1(3),0)
6331 
6332 ! inds = inds1
6333 ! inds(k) = inds(k) + 1
6334 ! inds(l) = inds(l) + 1
6335 ! Daux = Daux + detZ * Dexpgr(n0-1,inds(1),inds(2),inds(3),0)
6336 !
6337 ! inds = inds1
6338 ! inds(k) = inds(k) + 1
6339 ! Daux = Daux + Zadjf(l) * Dexpgr(n0-1,inds(1),inds(2),inds(3),0)
6340 
6341 #ifdef Dgrtest
6342  write(*,*) 'CalcDgr C_0 1c',n0-1,inds1(1),inds1(2),inds1(3),c_0(n0-1,inds1(1),inds1(2),inds1(3))
6343  write(*,*) 'CalcDgr Daux 1c',-zadj(k,l)*c_0(n0-1,inds1(1),inds1(2),inds1(3))
6344  write(*,*) 'CalcDgr Daux 1s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6345 #endif
6346 
6347  inds = inds1
6348  inds(k) = inds(k)+1
6349  do i=1,3
6350  daux = daux - zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
6351 #ifdef Dgrtest
6352  write(*,*) 'CalcDgr Daux 2ci', -zadj(i,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
6353 #endif
6354  end do
6355 
6356 #ifdef Dgrtest
6357  write(*,*) 'CalcDgr Daux 2s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6358 #endif
6359 
6360  do i=1,3
6361  inds = inds1
6362  inds(i) = inds(i)+1
6363  daux = daux + zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
6364 #ifdef Dgrtest
6365  write(*,*) 'CalcDgr Daux 3ci',zadj(k,l)*shat(n0-1,inds(1),inds(2),inds(3),i)
6366 #endif
6367  end do
6368 
6369 
6370 #ifdef Dgrtest
6371  write(*,*) 'CalcDgr Daux 3s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6372 #endif
6373 
6374  daux = daux + 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),inds0(3),m) &
6375  + 2*(nn+1) *zadj2(n ,mt)*shat(n0,inds0(1),inds0(2),inds0(3),mt)
6376 
6377 
6378 #ifdef Dgrtest
6379  write(*,*) 'CalcDgr Daux 4ca', 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),inds0(3),m)
6380  write(*,*) 'CalcDgr Daux 4cb', 2*(nn+1) *zadj2(n ,mt)*shat(n0,inds0(1),inds0(2),inds0(3),mt)
6381  write(*,*) 'CalcDgr Daux 4s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6382 #endif
6383 
6384 ! Daux = Daux - 2*(nn+1)* Zadj2f(k,n,l)*Dexpgr(n0,inds0(1),inds0(2),inds0(3),0)
6385 
6386  if (nnt.gt.0) then
6387  inds = inds1
6388  inds(nt) = inds(nt)-1
6389  daux = daux + 2*nnt*zadj2(nt,m )*shat(n0,inds(1),inds(2),inds(3),m) &
6390  + 2*nnt*zadj2(nt,mt)*shat(n0,inds(1),inds(2),inds(3),mt)
6391  daux = daux - 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),0)
6392 
6393 #ifdef Dgrtest
6394  write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2(nt,m )*shat(n0,inds(1),inds(2),inds(3),m)
6395  write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2(nt,mt)*shat(n0,inds(1),inds(2),inds(3),mt)
6396  write(*,*) 'CalcDgr Daux 5ci', 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),0)
6397  write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2(nt,m ),shat(n0,inds(1),inds(2),inds(3),m)
6398  write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2(nt,mt),shat(n0,inds(1),inds(2),inds(3),mt)
6399  write(*,*) 'CalcDgr Daux 5cii', 2*nnt*zadj2f(k,nt,l),dexpgr(n0,inds(1),inds(2),inds(3),0)
6400  write(*,*) 'CalcDgr Daux 5s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6401 #endif
6402  endif
6403 
6404 
6405  inds = inds1
6406  if(m.eq.n) then
6407  if (inds(n).gt.1) then
6408  inds(n) = inds(n)-2
6409  daux = daux - 4*(nn+1)*nn * zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6410 #ifdef Dgrtest
6411  write(*,*) 'CalcDgr Daux 6c',4*(nn+1)*nn* zadj2(n,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6412  write(*,*) 'CalcDgr Daux 6s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6413 #endif
6414  endif
6415  else
6416  if (inds(n).gt.0.and.inds(m).gt.0) then
6417  inds(n) = inds(n)-1
6418  inds(m) = inds(m)-1
6419  daux = daux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6420 #ifdef Dgrtest
6421  write(*,*) 'CalcDgr Daux 6c',-4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6422  write(*,*) 'CalcDgr Daux 6s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6423 #endif
6424  endif
6425  endif
6426 
6427 
6428  inds = inds1
6429  if(m.eq.nt) then
6430  if (inds(nt).gt.1) then
6431  inds(nt) = inds(nt)-2
6432  daux = daux - 4*nnt*(nnt-1) * zadj2(nt,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6433 #ifdef Dgrtest
6434  write(*,*) 'CalcDgr Daux 7c',4*nnt*(nnt-1) * zadj2(nt,m ) *dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6435  write(*,*) 'CalcDgr Daux 7s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6436 #endif
6437  endif
6438  else
6439  if (inds(nt).gt.0.and.inds(m).gt.0) then
6440  inds(nt) = inds(nt)-1
6441  inds(m) = inds(m)-1
6442  daux = daux - 4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6443 #ifdef Dgrtest
6444  write(*,*) 'CalcDgr Daux 7c',4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0,inds(1),inds(2),inds(3),0)
6445  write(*,*) 'CalcDgr Daux 7s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6446 #endif
6447  endif
6448  endif
6449 
6450 
6451  inds = inds1
6452  if(mt.eq.n) then
6453  if (inds(n).gt.1) then
6454  inds(n) = inds(n)-2
6455  daux = daux - 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6456 #ifdef Dgrtest
6457  write(*,*) 'CalcDgr Daux 8c',- 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) &
6458  , n0+1,inds(1),inds(2),inds(3)
6459  write(*,*) 'CalcDgr Daux 8s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6460 #endif
6461  endif
6462  else
6463  if (inds(n).gt.0.and.inds(mt).gt.0) then
6464  inds(n) = inds(n)-1
6465  inds(mt) = inds(mt)-1
6466  daux = daux - 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6467 #ifdef Dgrtest
6468  write(*,*) 'CalcDgr Daux 8c',- 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0) &
6469  ,n0+1,inds(1),inds(2),inds(3)
6470  write(*,*) 'CalcDgr Daux 8s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6471 #endif
6472  endif
6473  endif
6474 
6475 
6476  inds = inds1
6477  if(mt.eq.nt) then
6478  if (inds(nt).gt.1) then
6479  inds(nt) = inds(nt)-2
6480  daux = daux - 4*nnt*(nnt-1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6481 #ifdef Dgrtest
6482  write(*,*) 'CalcDgr Daux 9c', - 4*nnt*(nnt-1) * zadj2(nt,mt) * dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6483  write(*,*) 'CalcDgr Daux 9s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6484 #endif
6485  endif
6486  else
6487  if (inds(nt).gt.0.and.inds(mt).gt.0) then
6488  inds(nt) = inds(nt)-1
6489  inds(mt) = inds(mt)-1
6490  daux = daux - 4*nnt*(inds(mt)+1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6491 #ifdef Dgrtest
6492  write(*,*) 'CalcDgr Daux 9c',- 4*nnt*(inds(mt)+1) * zadj2(nt,mt) * dexpgr(n0+1,inds(1),inds(2),inds(3),0)
6493  write(*,*) 'CalcDgr Daux 9s',daux,daux/(2*(nn+1)* zadj2f(k,n,l))
6494 #endif
6495  endif
6496  endif
6497 
6498  dexpgr(n0,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nn+1)* zadj2f(k,n,l))
6499 
6500 #ifdef Dgrtest
6501  write(*,*) 'CalcDgr Dexpgr',n0,inds0(1),inds0(2),inds0(3),dexpgr(n0,inds0(1),inds0(2),inds0(3),0)
6502 #endif
6503 
6504  if (n0.eq.1) then
6505  maxdexpgr(1,r,0) = maxdexpgr(1,r,0) + abs(dexpgr(n0,inds0(1),inds0(2),inds0(3),0) )
6506  end if
6507 
6508 ! if (r+n0.le.rmax) then ! for fixed rank
6509  if (r.le.rmax) then
6510  d(n0,inds0(1),inds0(2),inds0(3)) = dexpgr(n0,inds0(1),inds0(2),inds0(3),0)
6511  end if
6512 
6513  end do
6514  end do
6515  end do
6516 
6517  ! calculate
6518  ! D_00ijkl.. --> D_aijkl..
6519  ! exploiting eq. (5.38)
6520  maxdexpgr(0,r,0)=0d0
6521  do n1=0,r
6522  do n2=0,r-n1
6523  n3 = r-n1-n2
6524 
6525  smod = shat(0,n1,n2,n3,:)
6526  if (n1.ge.1) then
6527  smod(1) = smod(1) - 2d0*n1*dexpgr(1,n1-1,n2,n3,0)
6528  end if
6529  if (n2.ge.1) then
6530  smod(2) = smod(2) - 2d0*n2*dexpgr(1,n1,n2-1,n3,0)
6531  end if
6532  if (n3.ge.1) then
6533  smod(3) = smod(3) - 2d0*n3*dexpgr(1,n1,n2,n3-1,0)
6534  end if
6535 
6536  dexpgr(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
6537  + zadj(3,j)*smod(3))/zadjfj
6538  maxdexpgr(0,r,0) = maxdexpgr(0,r,0) + abs(dexpgr(0,n1,n2,n3,0))
6539  if (r.le.rmax) then
6540  d(0,n1,n2,n3) = dexpgr(0,n1,n2,n3,0)
6541 ! Derr(r-1) = abs(detZ/Zadjfj*Dexpgr(0,n1,n2,n3,0))
6542  end if
6543 
6544 
6545 #ifdef Dgrtest
6546  if(r.le.rmax) then
6547 ! write(*,*) 'CalcDgr D(0,n1,n2,n3,0)=',n1,n2,n3,D(0,n1,n2,n3)
6548  endif
6549 
6550  if(n0.eq.0.and.n1.eq.3.and.n2.eq.0.and.n3.eq.0) then
6551  write(*,*) 'Smod(0,3,0,0,1)= ',shat(0,n1,n2,n3,1)
6552  write(*,*) 'Smod(0,3,0,0,2)= ',shat(0,n1,n2,n3,2)
6553  write(*,*) 'Smod(0,3,0,0,3)= ',shat(0,n1,n2,n3,3)
6554  write(*,*) 'D(1,2,0,0)= ',0,dexpgr(1,2,n2,n3,0)
6555  write(*,*) 'D(0,3,0,0)= ',0,d(n0,n1,n2,n3)
6556  end if
6557 #endif
6558 
6559  end do
6560  end do
6561 
6562 #ifdef Dgrtest
6563 ! write(*,*) 'CalcDgr maxDexpgr 0',r-1, maxDexpgr(0,r-1,0)
6564 #endif
6565 
6566  if(r.le.rmax) then
6567 ! Derr(r) = abs(detZ/Zadjfj)*maxDexpgr(0,r,0)
6568  derr(r) = fac_gr*maxdexpgr(0,r,0)
6569  endif
6570 
6571  ! error propagation from C's
6572  if(r.gt.0)then
6573  d00_err(r+1) = maxzadj*cij_err(r+1)/(2*maxzadj2f)
6574  end if
6575  dij_err(r)=maxzadj*max(cij_err(r),2*d00_err(r+1))/abs(zadjfj)
6576 
6577  if(r.gt.0)then
6578  d00_err2(r+1) = maxzadj*cij_err2(r+1)/(2*maxzadj2f)
6579  end if
6580  dij_err2(r)=maxzadj*max(cij_err2(r),2*d00_err2(r+1))/abs(zadjfj)
6581 
6582  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6583  ! higher order coefficients
6584  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6585 
6586  rg = r
6587  gloop: do g=1,min(gtrunc,r)
6588  rg = rg-1
6589 
6590 #ifdef Dgrtest
6591  write(*,*) 'CalcDgr: gloop ',r,rg,g
6592 #endif
6593 
6594  ! calculating
6595  ! D_00(a)0000..00 --> D_00(a)ij00..00 --> D_00(a)ijkl00..00 --> ... --> D_00(a)ijklmn..
6596  ! exploiting eq. (5.40) - (5.53) solved for D_00i1..<ir>...iP
6597  maxdexpgr(1,rg,g) = 0d0
6598  do n0=rg,1,-1 ! note rank of tensor = rg+n0
6599  do nn=rg-n0,0,-1
6600  do nnt=rg-n0-nn,0,-1
6601  nntt = rg-n0-nn-nnt
6602  inds0(n) = nn
6603  inds0(nt) = nnt
6604  inds0(k) = nntt
6605 
6606  inds1(n) = nn+1
6607  inds1(nt) = nnt
6608  inds1(k) = nntt
6609 
6610 #ifdef Dgrtest
6611 ! write(*,*) 'CalcDgr Daux r inds=',n0,inds0
6612 #endif
6613 
6614  daux = 2*zadj(k,l) * (2+rg-n0) * dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1)
6615 
6616 #ifdef Dgrtest
6617 ! write(*,*) 'CalcDgr Daux r1c',2*Zadj(k,l)*(2+rg-n0)* Dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1)
6618 ! write(*,*) 'CalcDgr Daux r1c',2*Zadj(k,l)*(2+rg-n0),Dexpgr(n0,inds1(1),inds1(2),inds1(3),g-1) &
6619 ! ,n0,inds1(1),inds1(2),inds1(3)
6620 ! write(*,*) 'CalcDgr Daux r1s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6621 #endif
6622 
6623  if (g.gt.1) then
6624  inds = inds1
6625  inds(k) = inds(k) + 1
6626  inds(l) = inds(l) + 1
6627  daux = daux + detz * dexpgr(n0-1,inds(1),inds(2),inds(3),g-2)
6628 
6629 #ifdef Dgrtest
6630 ! write(*,*) 'CalcDgr Daux r2c',detZ * Dexpgr(n0-1,inds(1),inds(2),inds(3),g-2)
6631 ! write(*,*) 'CalcDgr Daux r2s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6632 #endif
6633  endif
6634 
6635  inds = inds1
6636  inds(k) = inds(k) + 1
6637  daux = daux + zadjf(l) * dexpgr(n0-1,inds(1),inds(2),inds(3),g-1)
6638 
6639 #ifdef Dgrtest
6640 ! write(*,*) 'CalcDgr Daux r3c',Zadjf(l)* Dexpgr(n0-1,inds(1),inds(2),inds(3),g-1)
6641 ! write(*,*) 'CalcDgr Daux r3c',Zadjf(l),Dexpgr(n0-1,inds(1),inds(2),inds(3),g-1),n0-1,inds(1),inds(2),inds(3)
6642 ! write(*,*) 'CalcDgr Daux r3s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6643 #endif
6644 
6645 ! Daux = Daux - 2*nn* Zadj2f(k,n,l)*Dexpgr(n0,inds0(1),inds0(2),inds0(3),g)
6646 
6647  if (nnt.gt.0) then
6648  inds = inds1
6649  inds(nt) = inds(nt)-1
6650  daux = daux - 2*nnt*zadj2f(k,nt,l)*dexpgr(n0,inds(1),inds(2),inds(3),g)
6651 #ifdef Dgrtest
6652 ! write(*,*) 'CalcDgr Daux r4c',- 2*nnt*Zadj2f(k,nt,l)*Dexpgr(n0,inds(1),inds(2),inds(3),g)
6653 ! write(*,*) 'CalcDgr Daux r4c',- 2*nnt,Zadj2f(k,nt,l),Dexpgr(n0,inds(1),inds(2),inds(3),g),n0,inds(1),inds(2),inds(3)
6654 ! write(*,*) 'CalcDgr Daux r4s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6655 #endif
6656  endif
6657 
6658 
6659  inds = inds1
6660  if(m.eq.n) then
6661  if (inds(n).gt.1) then
6662  inds(n) = inds(n)-2
6663  daux = daux - 4*(nn+1)*nn * zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6664 #ifdef Dgrtest
6665 ! write(*,*) 'CalcDgr Daux r6c',4*(nn+1)*nn* Zadj2(n,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6666 ! write(*,*) 'CalcDgr Daux r6s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6667 #endif
6668  endif
6669  else
6670  if (inds(n).gt.0.and.inds(m).gt.0) then
6671  inds(n) = inds(n)-1
6672  inds(m) = inds(m)-1
6673  daux = daux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6674 #ifdef Dgrtest
6675 ! write(*,*) 'CalcDgr Daux r6c',4*(nn+1)*(inds(m)+1)* Zadj2(n,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6676 ! write(*,*) 'CalcDgr Daux r6c',n,m,nn,4*(nn+1)*(inds(m)+1),Zadj2(n,m ),Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6677 ! write(*,*) 'CalcDgr Daux r6s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6678 #endif
6679  endif
6680  endif
6681 
6682  inds = inds1
6683  if(m.eq.nt) then
6684  if (inds(nt).gt.1) then
6685  inds(nt) = inds(nt)-2
6686  daux = daux - 4*nnt*(nnt-1) * zadj2(nt,m ) * dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6687 #ifdef Dgrtest
6688 ! write(*,*) 'CalcDgr Daux r7c',4*nnt*(nnt-1) * Zadj2(nt,m ) *Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6689 ! write(*,*) 'CalcDgr Daux r7s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6690 #endif
6691  endif
6692  else
6693  if (inds(nt).gt.0.and.inds(m).gt.0) then
6694  inds(nt) = inds(nt)-1
6695  inds(m) = inds(m)-1
6696  daux = daux - 4*nnt*(inds(m)+1)* zadj2(nt,m )* dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6697 #ifdef Dgrtest
6698 ! write(*,*) 'CalcDgr Daux r7c',4*nnt*(inds(m)+1)* Zadj2(nt,m )* Dexpgr(n0,inds(1),inds(2),inds(3),g)
6699 ! write(*,*) 'CalcDgr Daux r7s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6700 #endif
6701  endif
6702  endif
6703 
6704  inds = inds1
6705  if(mt.eq.n) then
6706  if (inds(n).gt.1) then
6707  inds(n) = inds(n)-2
6708  daux = daux - 4*(nn+1)*nn * zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6709 #ifdef Dgrtest
6710 ! write(*,*) 'CalcDgr Daux r8c',- 4*(nn+1)*nn * Zadj2(n ,mt)* Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6711 ! write(*,*) 'CalcDgr Daux r8c',n,mt,nn,- 4*(nn+1)*nn,Zadj2(n ,mt),Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6712 ! write(*,*) 'CalcDgr Daux r8s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6713 #endif
6714  endif
6715  else
6716  if (inds(n).gt.0.and.inds(mt).gt.0) then
6717  inds(n) = inds(n)-1
6718  inds(mt) = inds(mt)-1
6719  daux = daux - 4*(nn+1)*(inds(mt)+1)* zadj2(n ,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6720 #ifdef Dgrtest
6721 ! write(*,*) 'CalcDgr Daux r8c',- 4*(nn+1)*(inds(mt)+1)* Zadj2(n ,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6722 ! write(*,*) 'CalcDgr Daux r8s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6723 #endif
6724  endif
6725  endif
6726 
6727  inds = inds1
6728  if(mt.eq.nt) then
6729  if (inds(nt).gt.1) then
6730  inds(nt) = inds(nt)-2
6731  daux = daux - 4*nnt*(nnt-1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6732 #ifdef Dgrtest
6733 ! write(*,*) 'CalcDgr Daux r9c', - 4*nnt*(nnt-1) * Zadj2(nt,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6734 ! write(*,*) 'CalcDgr Daux r9s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6735 #endif
6736  endif
6737  else
6738  if (inds(nt).gt.0.and.inds(mt).gt.0) then
6739  inds(nt) = inds(nt)-1
6740  inds(mt) = inds(mt)-1
6741  daux = daux - 4*nnt*(inds(mt)+1) * zadj2(nt,mt)* dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6742 #ifdef Dgrtest
6743 ! write(*,*) 'CalcDgr Daux r9c',- 4*nnt*(inds(mt)+1) * Zadj2(nt,mt) * Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6744 ! write(*,*) 'CalcDgr Daux r9c',nt,mt,nnt,- 4*nnt*(inds(mt)+1) , Zadj2(nt,mt) , &
6745 ! Dexpgr(n0+1,inds(1),inds(2),inds(3),g)
6746 ! write(*,*) 'CalcDgr Daux r9s',Daux,Daux/(2*(nn+1)* Zadj2f(k,n,l))
6747 #endif
6748  endif
6749  endif
6750 
6751  dexpgr(n0,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nn+1)* zadj2f(k,n,l))
6752 
6753  if(n0.eq.1) then
6754  maxdexpgr(1,rg,g) = maxdexpgr(1,rg,g) + abs(dexpgr(n0,inds0(1),inds0(2),inds0(3),g))
6755 
6756 
6757  if (g.eq.1.and.abs(dexpgr(1,inds0(1),inds0(2),inds0(3),g)).gt. &
6758  truncfacexp*max(1/m2scale,maxdexpgr(1,rg,g-1)) .or. &
6759  g.ge.2.and.abs(dexpgr(1,inds0(1),inds0(2),inds0(3),g)).gt. &
6760  truncfacexp*maxdexpgr(1,rg,g-1)) then
6761 
6762 
6763 #ifdef Dgrtest
6764 ! write(*,*) 'CalcDgr exit gloop',n0,inds0(1),inds0(2),inds0(3),g,rg, &
6765 ! abs(Dexpgr(n0,inds0(1),inds0(2),inds0(3),g)),maxDexpgr(1,rg,g-1),truncfacexp
6766 #endif
6767 
6768  gtrunc = g-1
6769  exit gloop
6770  end if
6771  end if
6772 
6773  end do
6774  end do
6775  end do
6776 
6777 #ifndef PPEXP00
6778  if (rg.le.rmax) then
6779  do n0=rg,1,-1
6780 ! if (rg+n0.le.rmax) then ! for fixed rank!
6781  if (rg.le.rmax) then
6782  do n1=0,rg-n0
6783  do n2=0,rg-n0-n1
6784  n3=rg-n0-n1-n2
6785  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgr(n0,n1,n2,n3,g)
6786  end do
6787  end do
6788  end if
6789  end do
6790  end if
6791 #endif
6792 ! write(*,*) 'CalcDgr after it1 ',rg
6793 
6794  ! calculate
6795  ! D_00ijkl.. --> D_aijkl..
6796  ! exploiting eq. (5.38)
6797 
6798 ! write(*,*) 'CalcDgr maxDexp',rg,g-1,maxDexpgr(0,rg,g-1)
6799 
6800  maxdexpgr(0,rg,g) = 0d0
6801  do n1=0,rg
6802  do n2=0,rg-n1
6803  n3 = rg-n1-n2
6804 
6805  smod = 0d0
6806  if (n1.ge.1) then
6807  smod(1) = smod(1) - 2d0*n1*dexpgr(1,n1-1,n2,n3,g)
6808  end if
6809  if (n2.ge.1) then
6810  smod(2) = smod(2) - 2d0*n2*dexpgr(1,n1,n2-1,n3,g)
6811  end if
6812  if (n3.ge.1) then
6813  smod(3) = smod(3) - 2d0*n3*dexpgr(1,n1,n2,n3-1,g)
6814  end if
6815 
6816  inds(1) = n1
6817  inds(2) = n2
6818  inds(3) = n3
6819  inds(j) = inds(j)+1
6820  dexpgr(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
6821  + zadj(3,j)*smod(3) &
6822  - detz*dexpgr(0,inds(1),inds(2),inds(3),g-1))/zadjfj
6823 
6824  maxdexpgr(0,rg,g) = maxdexpgr(0,rg,g) + abs(dexpgr(0,n1,n2,n3,g))
6825 
6826 ! if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then
6827 ! write(*,*) 'D2(2,3,3)= ',g,Dexpgr(0,n1,n2,n3,g)
6828 ! write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj, Zadj(2,j)*Smod(2)/Zadjfj, &
6829 ! + Zadj(3,j)*Smod(3)/Zadjfj, &
6830 ! - detZ*Dexpgr(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
6831 ! write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3), &
6832 ! - detZ/Zadjfj,Dexpgr(0,inds(1),inds(2),inds(3),g-1)
6833 ! end if
6834 
6835  if (g.eq.1.and.abs(dexpgr(0,n1,n2,n3,g)).gt. &
6836  truncfacexp*max(1/m2scale,maxdexpgr(0,rg,g-1)) .or. &
6837  g.ge.2.and.abs(dexpgr(0,n1,n2,n3,g)).gt. &
6838  truncfacexp*maxdexpgr(0,rg,g-1)) then
6839 
6840 #ifdef Dgrtest
6841  write(*,*) 'CalcDgr exit gloop',0,n1,n2,n3,g,abs(dexpgr(0,n1,n2,n3,g)),maxdexpgr(0,rg,g-1),truncfacexp
6842 #endif
6843  gtrunc = g-1
6844  exit gloop
6845  end if
6846 
6847  end do
6848  end do
6849 
6850  ! error propagation from C's
6851  if(rg.gt.0)then
6852  d00_err(rg+1) = max( d00_err(rg+1), &
6853  max( maxzadj*(2+rg-2*n0)*d00_err(rg+2), &
6854  abs(detz)*dij_err(rg+2), &
6855  maxzadjf*dij_err(rg+1) &
6856  ) / (2*maxzadj2f) )
6857  end if
6858  dij_err(rg)=max(dij_err(rg), &
6859  max(2*maxzadj*d00_err(rg+1),abs(detz)*dij_err(rg))/abs(zadjfj) )
6860 
6861  if(rg.gt.0)then
6862  d00_err2(rg+1) = max( d00_err2(rg+1), &
6863  max( maxzadj*(2+rg-2*n0)*d00_err2(rg+2), &
6864  abs(detz)*dij_err2(rg+2), &
6865  maxzadjf*dij_err2(rg+1) &
6866  ) / (2*maxzadj2f) )
6867  end if
6868  dij_err2(rg)=max(dij_err2(rg), &
6869  max(2*maxzadj*d00_err2(rg+1),abs(detz)*dij_err2(rg))/abs(zadjfj) )
6870 
6871 #ifdef PPEXP00
6872  if (rg.le.rmax) then
6873  do n0=rg,1,-1
6874 ! if (rg+n0.le.rmax) then ! for fixed rank
6875  if (rg.le.rmax) then
6876  do n1=0,rg-n0
6877  do n2=0,rg-n0-n1
6878  n3=rg-n0-n1-n2
6879  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) + dexpgr(n0,n1,n2,n3,g)
6880  end do
6881  end do
6882  end if
6883  end do
6884  end if
6885 #endif
6886 
6887  if (rg.le.rmax) then
6888  derr(rg) = 0d0
6889  do n1=0,rg
6890  do n2=0,rg-n1
6891  n3 = rg-n1-n2
6892  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgr(0,n1,n2,n3,g)
6893  if(abs(dexpgr(0,n1,n2,n3,g-1)).ne.0d0) then
6894 ! Derr(rg)=max(Derr(rg),abs(Dexpgr(0,n1,n2,n3,g))**2/abs(Dexpgr(0,n1,n2,n3,g-1)))
6895  derr(rg)=max(derr(rg),abs(dexpgr(0,n1,n2,n3,g))*min(1d0,abs(dexpgr(0,n1,n2,n3,g))/abs(dexpgr(0,n1,n2,n3,g-1))))
6896  else
6897  derr(rg)=max(derr(rg),abs(dexpgr(0,n1,n2,n3,g)))
6898  endif
6899 
6900 #ifdef Dgrtest
6901 ! write(*,*) 'CalcDgr Derr calc',rg,Derr(rg),n1,n2,n3,abs(Dexpgr(0,n1,n2,n3,g)),abs(Dexpgr(0,n1,n2,n3,g-1))
6902 #endif
6903 
6904  end do
6905  end do
6906 
6907  ! if error from C's larger than error from expansion stop expansion
6908 #ifdef PVEST2
6909  if(dij_err2(rg).gt.3d0*derr(rg)) then
6910 #else
6911  if(dij_err(rg).gt.3d0*derr(rg)) then
6912 #endif
6913  gtrunc = min(g,gtrunc)
6914 
6915 #ifdef Dgrtest
6916  write(*,*) 'CalcDgr exit err',r,rg,g,gtrunc,dij_err(rg),derr(rg)
6917 #endif
6918 
6919  end if
6920 
6921  end if
6922 
6923  end do gloop
6924 
6925 #ifdef Dgrtest
6926  write(*,*) 'CalcDgr D(0,0,0,0) = ',r,d(0,0,0,0)
6927  if(r.ge.1)then
6928  write(*,*) 'CalcDgr D(1,0,0,0) = ',r,d(1,0,0,0)
6929  write(*,*) 'CalcDgr D(0,1,0,0) = ',r,d(0,1,0,0)
6930  write(*,*) 'CalcDgr D(0,0,1,0) = ',r,d(0,0,1,0)
6931  write(*,*) 'CalcDgr D(0,0,0,1) = ',r,d(0,0,0,1)
6932  endif
6933  if(r.ge.2.and.rmax.ge.2)then
6934  write(*,*) 'CalcDgr D(1,1,0,0) = ',r,d(1,1,0,0)
6935  write(*,*) 'CalcDgr D(1,0,1,0) = ',r,d(1,0,1,0)
6936  write(*,*) 'CalcDgr D(1,0,0,1) = ',r,d(1,0,0,1)
6937  write(*,*) 'CalcDgr D(0,2,0,0) = ',r,d(0,2,0,0)
6938 ! write(*,*) 'CalcDgr D(0,1,1,0) = ',r,D(0,1,1,0)
6939  write(*,*) 'CalcDgr D(0,0,2,0) = ',r,d(0,0,2,0)
6940  endif
6941  if(r.ge.3.and.rmax.ge.2)then
6942 ! write(*,*) 'CalcDgr D(3,0,0,0) = ',r,D(3,0,0,0)
6943 ! write(*,*) 'CalcDgr D(2,0,1,0) = ',r,D(2,0,1,0)
6944  write(*,*) 'CalcDgr D(1,2,0,0) = ',r,d(1,2,0,0)
6945  write(*,*) 'CalcDgr D(1,0,2,0) = ',r,d(1,0,2,0)
6946  write(*,*) 'CalcDgr D(0,3,0,0) = ',r,d(0,3,0,0)
6947  write(*,*) 'CalcDgr D(0,2,1,0) = ',r,d(0,2,1,0)
6948  write(*,*) 'CalcDgr D(0,0,3,0) = ',r,d(0,0,3,0)
6949  write(*,*) 'CalcDgr D(0,1,1,1) = ',r,d(0,1,1,1)
6950  write(*,*) 'CalcDgr D(0,0,2,1) = ',r,d(0,0,2,1)
6951  endif
6952  write(*,*) 'CalcDgr Dij_err',r,dij_err
6953  write(*,*) 'CalcDgr Dij_acc',r,dij_err/abs(d(0,0,0,0))
6954 
6955  write(*,*) 'CalcDgr err',r,derr
6956  write(*,*) 'CalcDgr acc',r,derr/abs(d(0,0,0,0))
6957 #endif
6958 
6959  derr2 = max(derr,dij_err2(0:rmax))
6960  derr = max(derr,dij_err(0:rmax))
6961 
6962 #ifdef Dgrtest
6963 ! write(*,*) 'CalcDgr exit r',r,maxval(Derr),acc_req_D*abs(D(0,0,0,0))
6964 #endif
6965 
6966 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
6967  ! check if target precision already reached
6968 #ifdef Cutrloop
6969  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
6970  if (r.lt.rmax) then
6971  do rg=r+1,rmax
6972  do n0=0,rg/2
6973  do n1=0,rg-n0
6974  do n2=0,rg-n0-n1
6975  d(n0,n1,n2,rg-n0-n1-n2)=0d0
6976  enddo
6977  enddo
6978  enddo
6979  enddo
6980 
6981 100 format(((a)))
6982 111 format(a22,2('(',g24.17,',',g24.17,') ':))
6983  call seterrflag_coli(-5)
6984  call errout_coli('CalcDgr',' exit rloop for D', &
6985  errorwriteflag)
6986  if (errorwriteflag) then
6987  write(nerrout_coli,100)' CalcDgr: exit rloop for D ', &
6988  ' should not appear'
6989  write(nerrout_coli,111)' CalcDgr: p10 = ',p10
6990  write(nerrout_coli,111)' CalcDgr: p21 = ',p21
6991  write(nerrout_coli,111)' CalcDgr: p32 = ',p32
6992  write(nerrout_coli,111)' CalcDgr: p30 = ',p30
6993  write(nerrout_coli,111)' CalcDgr: p20 = ',p20
6994  write(nerrout_coli,111)' CalcDgr: p31 = ',p31
6995  write(nerrout_coli,111)' CalcDgr: m02 = ',m02
6996  write(nerrout_coli,111)' CalcDgr: m12 = ',m12
6997  write(nerrout_coli,111)' CalcDgr: m22 = ',m22
6998  write(nerrout_coli,111)' CalcDgr: m32 = ',m32
6999  end if
7000  endif
7001 
7002 #else
7003  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
7004 #endif
7005  exit rloop
7006  end if
7007 
7008  end do rloop
7009 
7010 
7011 #ifdef Dgrtest
7012 ! write(*,*) 'CalcDgr D(0,0,0,0) = ',D(0,0,0,0)
7013 ! if(rmax.ge.3)then
7014 ! write(*,*) 'CalcDgr D(0,1,1,1) = ',D(0,1,1,1)
7015 ! endif
7016 
7017  write(*,*) 'CalcDgr final err',derr
7018  write(*,*) 'CalcDgr final acc',derr/abs(d(0,0,0,0))
7019 #endif
7020 
7021 ! write(*,*) 'CalcDgr Derr ',Derr
7022 ! write(*,*) 'CalcDgr Derr2',Derr2
7023 

◆ calcdgx()

subroutine reductiond::calcdgx ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordgx_min,
integer, intent(in)  ordgx_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 7037 of file reductionD.F90.

7037 
7038  use globald
7039 
7040  integer, intent(in) :: rmax,ordgx_min,ordgx_max,id
7041  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
7042  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
7043  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
7044  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
7045  double complex :: Zadjfj,Zadj2(4), Zadjkl, Xtilde
7046  double complex, allocatable :: Dexpgx(:,:,:,:,:), DuvExpgx(:,:,:,:)
7047  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:), Shat(:,:,:,:,:)
7048  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
7049  double complex, allocatable :: D_alt(:,:,:,:)
7050  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
7051  double complex :: Smod(3), Skl, Daux, DexpgAux
7052  double complex :: cC0f, elimminf2_coli
7053  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
7054  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
7055  double precision :: maxDexpgx(0:1,0:rmax+ordgx_min+1,0:ordgx_max),truncfacexp
7056  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,k,l,i,j,m,n,g,rg,lt,ltt,nl,nlt,nltt
7057  integer :: inds0(3), inds(3), inds2(2,4)
7058  integer :: bin,nid(0:3)
7059  logical :: errorwriteflag
7060 
7061 #ifdef Dgxtest
7062  write(*,*) 'CalcDgx in, ord',rmax,ordgx_min,ordgx_max
7063 #endif
7064 
7065  ! allocation of C functions
7066  rmaxc = rmax + ordgx_min
7067  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
7068  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
7069  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
7070  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
7071  allocate(cerr_i(0:rmaxc,0:3))
7072  allocate(cerr2_i(0:rmaxc,0:3))
7073  allocate(acc_req_cextra(0:rmaxc))
7074 
7075  ! determine binaries for C-coefficients
7076  k=0
7077  bin = 1
7078  do while (k.le.3)
7079  if (mod(id/bin,2).eq.0) then
7080  nid(k) = id+bin
7081  k = k+1
7082  end if
7083  bin = 2*bin
7084  end do
7085 
7086  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
7087  ! by estimated suppression factors that are multiplied in expansion
7088  acc_req_cextra(0:rmax) = acc_req_cind
7089  if (x_g.ne.0d0) then
7090  do r=rmax+1,rmaxc
7091  acc_req_cextra(r)= acc_req_cextra(r-1)/x_g
7092  end do
7093  else ! 10.07.2017
7094  acc_req_cextra(rmax+1:rmaxc) = acc_inf
7095  end if
7096 
7097  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
7098  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
7099  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
7100  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
7101 
7102  ! shift of integration momentum in C\{0}
7103  do n1=1,rmaxc
7104  do n2=0,rmaxc-n1
7105  do n3=0,rmaxc-n1-n2
7106  n0 = (rmaxc-n1-n2-n3)
7107  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
7108  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
7109  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
7110  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
7111  end do
7112  end do
7113  end do
7114 
7115 
7116  ! calculate adjugated Gram matrix
7117 ! mm02 = elimminf2_coli(m02)
7118 ! mm12 = elimminf2_coli(m12)
7119 ! mm22 = elimminf2_coli(m22)
7120 ! mm32 = elimminf2_coli(m32)
7121 ! q10 = elimminf2_coli(p10)
7122 ! q21 = elimminf2_coli(p21)
7123 ! q32 = elimminf2_coli(p32)
7124 ! q30 = elimminf2_coli(p30)
7125 ! q31 = elimminf2_coli(p31)
7126 ! q20 = elimminf2_coli(p20)
7127 
7128 ! Z(1,1) = 2d0*q10
7129 ! Z(2,1) = q10+q20-q21
7130 ! Z(3,1) = q10+q30-q31
7131 ! Z(1,2) = Z(2,1)
7132 ! Z(2,2) = 2d0*q20
7133 ! Z(3,2) = q20+q30-q32
7134 ! Z(1,3) = Z(3,1)
7135 ! Z(2,3) = Z(3,2)
7136 ! Z(3,3) = 2d0*q30
7137 
7138 ! q1q2 = (q10+q20-q21)
7139 ! q1q3 = (q10+q30-q31)
7140 ! q2q3 = (q20+q30-q32)
7141 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
7142 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
7143 
7144 ! Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
7145 ! Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
7146 ! Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
7147 ! Zadj(1,2) = Zadj(2,1)
7148 ! Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
7149 ! Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
7150 ! Zadj(1,3) = Zadj(3,1)
7151 ! Zadj(2,3) = Zadj(3,2)
7152 ! Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
7153 !
7154 ! f(1) = q10+mm02-mm12
7155 ! f(2) = q20+mm02-mm22
7156 ! f(3) = q30+mm02-mm32
7157 
7158 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
7159 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
7160 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
7161 
7162 
7163  ! coefficients Shat defined in (5.13)
7164  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
7165 
7166  do r=0,rmaxc
7167  do n0=0,r/2
7168  do n1=0,r-2*n0
7169  do n2=0,r-2*n0-n1
7170  n3 = r-2*n0-n1-n2
7171 
7172  shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
7173 
7174  if(n1.eq.0) then
7175  shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
7176  end if
7177 
7178  if(n2.eq.0) then
7179  shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
7180  end if
7181 
7182  if(n3.eq.0) then
7183  shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
7184  end if
7185 
7186  end do
7187  end do
7188  end do
7189  end do
7190 
7191 
7192  ! choose reduction formulas with biggest denominators
7193  if (abs(zadjf(1)).ge.max(abs(zadjf(2)),abs(zadjf(3)))) then
7194  j = 1
7195  else if (abs(zadjf(2)).ge.max(abs(zadjf(1)),abs(zadjf(3)))) then
7196  j = 2
7197  else
7198  j = 3
7199  end if
7200 
7201  maxzadj2f = 0d0
7202  if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
7203  maxzadj2f = abs(zadj2f(1,2,1))
7204  i = 1
7205  j = 2
7206  l = 1
7207  lt = 2
7208  ltt = 3
7209  end if
7210  if (abs(zadj2f(1,3,1)).gt.maxzadj2f) then
7211  maxzadj2f = abs(zadj2f(1,3,1))
7212  i = 1
7213  j = 3
7214  l = 1
7215  lt = 2
7216  ltt = 3
7217  end if
7218  if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
7219  maxzadj2f = abs(zadj2f(1,2,2))
7220  i = 1
7221  j = 2
7222  l = 2
7223  lt = 3
7224  ltt = 1
7225  end if
7226  if (abs(zadj2f(1,3,2)).gt.maxzadj2f) then
7227  maxzadj2f = abs(zadj2f(1,3,2))
7228  i = 1
7229  j = 3
7230  l = 2
7231  lt = 3
7232  ltt = 1
7233  end if
7234  if (abs(zadj2f(1,2,3)).gt.maxzadj2f) then
7235  maxzadj2f = abs(zadj2f(1,2,3))
7236  i = 1
7237  j = 2
7238  l = 3
7239  lt = 1
7240  ltt = 2
7241  end if
7242  if (abs(zadj2f(1,3,3)).gt.maxzadj2f) then
7243  maxzadj2f = abs(zadj2f(1,3,3))
7244  i = 1
7245  j = 3
7246  l = 3
7247  lt = 1
7248  ltt = 2
7249  end if
7250  if (abs(zadj2f(2,3,1)).gt.maxzadj2f) then
7251  maxzadj2f = abs(zadj2f(2,3,1))
7252  i = 2
7253  j = 3
7254  l = 1
7255  lt = 2
7256  ltt = 3
7257  end if
7258  if (abs(zadj2f(2,3,2)).gt.maxzadj2f) then
7259  maxzadj2f = abs(zadj2f(2,3,2))
7260  i = 2
7261  j = 3
7262  l = 2
7263  lt = 3
7264  ltt = 1
7265  end if
7266  if (abs(zadj2f(2,3,3)).gt.maxzadj2f) then
7267  maxzadj2f = abs(zadj2f(2,3,3))
7268  i = 2
7269  j = 3
7270  l = 3
7271  lt = 1
7272  ltt = 2
7273  end if
7274 
7275 #ifdef Dgxtest
7276  write(*,*) 'CalcDgx i,j,l',i,j,l,lt,ltt
7277  write(*,*) 'CalcDgx pars', maxzadj2f,zadj2f(i,j,l),zadj(i,j),maxzadj
7278  write(*,*) 'CalcDgx pars', abs(zadjf(j)),abs(xadj(i,j))
7279  write(*,*) 'CalcDgx pars', abs(zadjf(j)/ maxzadj2f),abs(xadj(i,j)/maxzadj2f)
7280 #endif
7281 
7282  zadjfj = zadjf(j)
7283 
7284  xtilde = xadj(k,l)
7285 
7286 ! write(*,*) 'CalcDgx Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
7287 
7288 
7289  ! allocation of array for det(Z)-expanded C-coefficients
7290  rmaxexp = rmaxc+1
7291  allocate(dexpgx(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:rmaxexp,0:ordgx_max))
7292 
7293 
7294  ! calculate Duv
7295  allocate(duvexpgx(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
7296  call calcduv(duvexpgx,cuv_0,mm02,f,rmaxexp,id)
7297  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgx(0:rmax,0:rmax,0:rmax,0:rmax)
7298 
7299  ! allocate arrays for error propagation
7300  allocate(d00_err(0:rmaxexp))
7301  allocate(dij_err(0:rmaxexp))
7302  allocate(cij_err(0:rmaxc))
7303 
7304  allocate(d00_err2(0:rmaxexp))
7305  allocate(dij_err2(0:rmaxexp))
7306  allocate(cij_err2(0:rmaxc))
7307 
7308  ! initialize accuracy estimates
7309  derr = acc_inf
7310  dij_err =0d0
7311  d00_err =0d0
7312  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
7313 
7314  derr2 = acc_inf
7315  dij_err2 =0d0
7316  d00_err2 =0d0
7317  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
7318 
7319 #ifdef Dgxtest
7320  write(*,*) 'CalcDgx Cij_err = ',cij_err
7321  write(*,*) 'CalcDgx C0_err = ', cerr_i(0,0),cerr_i(0,1),cerr_i(0,2),cerr_i(0,3)
7322  write(*,*) 'CalcDgx C0 = ', c_0(0,0,0,0),c_i(0,0,0,1),c_i(0,0,0,2),c_i(0,0,0,3)
7323 #endif
7324 
7325 ! maxZadj = maxval(abs(Zadj))
7326 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
7327 
7328  ! truncation of expansion if calculated term larger than truncfacexp * previous term
7329  ! crucial for expansion parameters between 0.1 and 1 !!!
7330  truncfacexp = sqrt(fac_g) * truncfacd
7331  gtrunc = ordgx_max
7332 
7333 ! calculate D(1,n1,n2,n3) up to rank r
7334 ! calculate D(0,n1,n2,n3) up to rank r-1
7335  rloop: do r=1,rmaxexp
7336 
7337 #ifdef Dgxtest
7338 ! write(*,*) 'CalcDgx rloop',r,rmax,gtrunc
7339 #endif
7340 
7341  if (r.gt.rmax+gtrunc+1) exit rloop
7342 
7343 #ifdef Dgxtest
7344  write(*,*) 'CalcDgx rloop',r
7345 #endif
7346 
7347  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7348  ! 0th-order coefficients
7349  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7350 
7351  ! calculating D_00ijk.. exploiting eq. (5.53)
7352  maxdexpgx(1,r,0)=0d0
7353  do nl=r-2,0,-1
7354  do nlt=r-2-nl,0,-1
7355  nltt = r-2-nl-nlt
7356  inds0(l) = nl
7357  inds0(lt) = nlt
7358  inds0(ltt) = nltt
7359 
7360  inds(l) = nl+1
7361  inds(lt) = nlt
7362  inds(ltt) = nltt
7363  daux = zadj2f(i,j,1)*shat(0,inds(1),inds(2),inds(3),1) &
7364  + zadj2f(i,j,2)*shat(0,inds(1),inds(2),inds(3),2) &
7365  + zadj2f(i,j,3)*shat(0,inds(1),inds(2),inds(3),3)
7366 
7367  inds = inds0
7368  inds(l) = inds(l)+1
7369  daux = daux - zadj(i,j)*(c_0(0,inds(1),inds(2),inds(3)) &
7370  +4*duvexpgx(1,inds(1),inds(2),inds(3)))
7371 
7372  if (nlt.ge.1) then
7373  inds(lt) = nlt-1
7374  daux = daux - 2*nlt*zadj2f(i,j,lt)*dexpgx(1,inds(1),inds(2),inds(3),0)
7375  end if
7376  if (nltt.ge.1) then
7377  inds(lt) = nlt
7378  inds(ltt) = nltt-1
7379  daux = daux - 2*nltt*zadj2f(i,j,ltt)*dexpgx(1,inds(1),inds(2),inds(3),0)
7380  end if
7381 
7382  dexpgx(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1)*zadj2f(i,j,l))
7383 
7384  maxdexpgx(1,r,0) = maxdexpgx(1,r,0) + abs(dexpgx(1,inds0(1),inds0(2),inds0(3),0) )
7385 
7386  if (r.le.rmax) then
7387  d(1,inds0(1),inds0(2),inds0(3)) = dexpgx(1,inds0(1),inds0(2),inds0(3),0)
7388  end if
7389 
7390  end do
7391  end do
7392 
7393  ! calculate
7394  ! D_00ijkl.. --> D_aijkl..
7395  ! exploiting eq. (5.38)
7396  maxdexpgx(0,r-1,0)=0d0
7397  do n1=0,r-1
7398  do n2=0,r-1-n1
7399  n3 = r-1-n1-n2
7400 
7401  smod = shat(0,n1,n2,n3,:)
7402  if (n1.ge.1) then
7403  smod(1) = smod(1) - 2d0*n1*dexpgx(1,n1-1,n2,n3,0)
7404  end if
7405  if (n2.ge.1) then
7406  smod(2) = smod(2) - 2d0*n2*dexpgx(1,n1,n2-1,n3,0)
7407  end if
7408  if (n3.ge.1) then
7409  smod(3) = smod(3) - 2d0*n3*dexpgx(1,n1,n2,n3-1,0)
7410  end if
7411 
7412  dexpgx(0,n1,n2,n3,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
7413  + zadj(3,j)*smod(3))/zadjfj
7414  maxdexpgx(0,r-1,0) = maxdexpgx(0,r-1,0) + abs(dexpgx(0,n1,n2,n3,0))
7415  if (r.le.rmax+1) then
7416  d(0,n1,n2,n3) = dexpgx(0,n1,n2,n3,0)
7417  end if
7418 
7419 
7420 #ifdef Dgxtest
7421 ! if(n0.eq.0.and.n1.eq.0.and.n2.eq.3.and.n3.eq.0) then
7422 ! write(*,*) 'D2(0,0,3,0)= ',0,D(n0,n1,n2,n3)
7423 ! end if
7424 #endif
7425 
7426  end do
7427  end do
7428 
7429 #ifdef Dgxtest
7430 ! write(*,*) 'CalcDgx maxDexpg 0',r-1, maxDexpg(0,r-1,0)
7431 #endif
7432 
7433  if(r-1.le.rmax) then
7434 ! Derr(r-1) = abs(detZ/Zadjfj)*maxDexpg(0,r-1,0)
7435  derr(r-1) = fac_g*maxdexpgx(0,r-1,0)
7436  endif
7437 
7438  ! error propagation from C's
7439  if(r.gt.1)then
7440  d00_err(r) = max(cij_err(r-1),maxzadj/maxzadj2f*cij_err(r-1))/2d0
7441  end if
7442  dij_err(r-1)=maxzadj*max(cij_err(r-1),2*d00_err(r))/abs(zadjfj)
7443 
7444  if(r.gt.1)then
7445  d00_err2(r) = max(cij_err2(r-1),maxzadj/maxzadj2f*cij_err2(r-1))/2d0
7446  end if
7447  dij_err2(r-1)=maxzadj*max(cij_err2(r-1),2*d00_err2(r))/abs(zadjfj)
7448 
7449  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7450  ! higher order coefficients
7451  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7452 
7453  rg = r
7454  gloop: do g=1,min(gtrunc,r-1)
7455  rg = rg-1
7456 
7457  write(*,*) 'gloop ',g,rg
7458 
7459  ! calculating D_00ijk.. exploiting eq. (5.53)
7460  maxdexpgx(1,rg,g) = 0d0
7461  do nl=rg-2,0,-1
7462  do nlt=rg-2-nl,0,-1
7463  nltt = rg-2-nl-nlt
7464  inds0(l) = nl
7465  inds0(lt) = nlt
7466  inds0(ltt) = nltt
7467 
7468  inds = inds0
7469  inds(l) = inds(l)+1
7470  daux = -xadj(i,j)*dexpgx(0,inds(1),inds(2),inds(3),g-1) &
7471  +zadj(i,j)*2*rg*dexpgx(1,inds(1),inds(2),inds(3),g-1)
7472 
7473  write(*,*) 'CalcDgx con Xij',-xadj(i,j)*dexpgx(0,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))
7474  write(*,*) 'CalcDgx con Zij',+zadj(i,j)*2*(1+rg)*dexpgx(1,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))
7475 
7476  inds(i) = inds(i)+1
7477  daux = daux - zadjfj*dexpgx(0,inds(1),inds(2),inds(3),g-1)
7478  write(*,*) 'CalcDgx con Zadj2f', - zadjfj*dexpgx(0,inds(1),inds(2),inds(3),g-1)/(2*(nl+1)*zadj2f(i,j,l))
7479 
7480  if (nlt.ge.1) then
7481  inds(l) = nl+1
7482  inds(lt) = nlt-1
7483  inds(ltt) = nltt
7484  daux = daux - 2*nlt*zadj2f(i,j,lt)*dexpgx(1,inds(1),inds(2),inds(3),g)
7485  end if
7486  if (nltt.ge.1) then
7487  inds(l) = nl+1
7488  inds(lt) = nlt
7489  inds(ltt) = nltt-1
7490  daux = daux - 2*nltt*zadj2f(i,j,ltt)*dexpgx(1,inds(1),inds(2),inds(3),g)
7491  end if
7492 
7493  dexpgx(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1)*zadj2f(i,j,l))
7494 
7495  maxdexpgx(1,rg,g) = maxdexpgx(1,rg,g) + abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g) )
7496 
7497  write(*,*) 'CalcDgx gloop 00',g,rg,nl,nlt,nltt,dexpgx(1,inds0(1),inds0(2),inds0(3),g)
7498 
7499 
7500  if (g.eq.1.and.abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)).gt. &
7501  truncfacexp*max(1/m2scale,maxdexpgx(1,rg,g-1)) .or. &
7502  g.ge.2.and.abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)).gt. &
7503  truncfacexp*maxdexpgx(1,rg,g-1)) then
7504 
7505 #ifdef Dgxtest
7506  write(*,*) 'CalcDgx cycle loop',1,inds0(1),inds0(2),inds0(3),g, &
7507  abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgx(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgx(1,rg,g-1)
7508 #endif
7509 
7510  gtrunc = g-1
7511  exit gloop
7512  end if
7513 
7514  end do
7515  end do
7516 
7517 #ifndef PPEXP00
7518  if (rg.le.rmax) then
7519  do n1=0,rg-2
7520  do n2=0,rg-2-n1
7521  n3=rg-2-n1-n2
7522  d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgx(1,n1,n2,n3,g)
7523  end do
7524  end do
7525  end if
7526 #endif
7527 
7528 
7529  ! calculate
7530  ! D_00ijkl.. --> D_aijkl..
7531  ! exploiting eq. (5.38)
7532 
7533 ! write(*,*) 'CalcDgx maxDexp',rg-1,g-1,maxDexpg(0,rg-1,g-1)
7534 
7535  maxdexpgx(0,rg-1,g) = 0d0
7536  do n1=0,rg-1
7537  do n2=0,rg-1-n1
7538  n3 = rg-1-n1-n2
7539 
7540  smod = 0d0
7541  if (n1.ge.1) then
7542  smod(1) = smod(1) - 2d0*n1*dexpgx(1,n1-1,n2,n3,g)
7543  end if
7544  if (n2.ge.1) then
7545  smod(2) = smod(2) - 2d0*n2*dexpgx(1,n1,n2-1,n3,g)
7546  end if
7547  if (n3.ge.1) then
7548  smod(3) = smod(3) - 2d0*n3*dexpgx(1,n1,n2,n3-1,g)
7549  end if
7550 
7551  inds(1) = n1
7552  inds(2) = n2
7553  inds(3) = n3
7554  inds(j) = inds(j)+1
7555  dexpgx(0,n1,n2,n3,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
7556  + zadj(3,j)*smod(3) &
7557  - detz*dexpgx(0,inds(1),inds(2),inds(3),g-1))/zadjfj
7558 
7559  maxdexpgx(0,rg-1,g) = maxdexpgx(0,rg-1,g) + abs(dexpgx(0,n1,n2,n3,g))
7560 
7561 ! if(n1.eq.0.and.n2.eq.1.and.n3.eq.2) then
7562 ! write(*,*) 'D2(2,3,3)= ',g,Dexpg(0,n1,n2,n3,g)
7563 ! write(*,*) 'D2(2,3,3)= ',Zadj(1,j)*Smod(1)/Zadjfj, Zadj(2,j)*Smod(2)/Zadjfj, &
7564 ! + Zadj(3,j)*Smod(3)/Zadjfj, &
7565 ! - detZ*Dexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
7566 ! write(*,*) 'D2(2,3,3)= ',inds(1),inds(2),inds(3), &
7567 ! - detZ/Zadjfj,Dexpg(0,inds(1),inds(2),inds(3),g-1)
7568 ! end if
7569 
7570  if (g.eq.1.and.abs(dexpgx(0,n1,n2,n3,g)).gt. &
7571  truncfacexp*max(1/m2scale**2,maxdexpgx(0,rg,g-1)) .or. &
7572  g.ge.2.and.abs(dexpgx(0,n1,n2,n3,g)).gt. &
7573  truncfacexp*maxdexpgx(0,rg,g-1)) then
7574 
7575 #ifdef Dgxtest
7576  write(*,*) 'CalcDgx exit gloop',0,n1,n2,n3,g,abs(dexpgx(0,n1,n2,n3,g)),maxdexpgx(0,rg-1,g-1),truncfacexp
7577 #endif
7578  gtrunc = g-1
7579  exit gloop
7580  end if
7581 
7582  end do
7583  end do
7584 
7585  ! error propagation from C's
7586  if(rg.gt.1)then
7587  d00_err(rg) = max( d00_err(rg), &
7588  max( abs(m02)*dij_err(rg-2), &
7589  max( maxzadjf*dij_err(rg),abs(xtilde)*dij_err(rg-1), &
7590  maxzadj*d00_err(rg+1) ) / abs(2d0*maxzadj2f) ) &
7591  /(4*(rg-1)) )
7592  end if
7593  dij_err(rg-1)=max(dij_err(rg-1), &
7594  max(2*maxzadj*d00_err(rg),abs(detz)*dij_err(rg))/abs(zadjfj) )
7595 
7596  if(rg.gt.1)then
7597  d00_err2(rg) = max( d00_err2(rg), &
7598  max( abs(m02)*dij_err2(rg-2), &
7599  max( maxzadjf*dij_err2(rg),abs(xtilde)*dij_err2(rg-1), &
7600  maxzadj*d00_err(rg+1) ) / abs(2d0*maxzadj2f) ) &
7601  /(4*(rg-1)) )
7602  end if
7603  dij_err2(rg-1)=max(dij_err2(rg-1), &
7604  max(2*maxzadj*d00_err2(rg),abs(detz)*dij_err2(rg))/abs(zadjfj) )
7605 
7606 #ifdef PPEXP00
7607  if (rg.le.rmax) then
7608  do n1=0,rg-1
7609  do n2=0,rg-1-n1
7610  n3=rg-1-n1-n2
7611  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgx(0,n1,n2,n3,g)
7612  end do
7613  end do
7614  end if
7615 #endif
7616 ! write(*,*) 'CalcDgx after it1 ',rg
7617  if ((rg.le.rmax+1)) then
7618  derr(rg-1) = 0d0
7619  do n1=0,rg-1
7620  do n2=0,rg-1-n1
7621  n3 = rg-1-n1-n2
7622  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgx(0,n1,n2,n3,g)
7623  if(abs(dexpgx(0,n1,n2,n3,g-1)).ne.0d0) then
7624 ! Derr(rg-1)=max(Derr(rg-1),abs(Dexpgx(0,n1,n2,n3,g))**2/abs(Dexpgx(0,n1,n2,n3,g-1)))
7625  derr(rg-1)=max(derr(rg-1),abs(dexpgx(0,n1,n2,n3,g))*min(1d0,abs(dexpgx(0,n1,n2,n3,g))/abs(dexpgx(0,n1,n2,n3,g-1))))
7626  else
7627  derr(rg-1)=max(derr(rg-1),abs(dexpgx(0,n1,n2,n3,g)))
7628  endif
7629 
7630 #ifdef Dgxtest
7631 ! write(*,*) 'CalcDgx Derr calc',rg-1,Derr(rg-1),n1,n2,n3,abs(Dexpg(0,n1,n2,n3,g)),abs(Dexpg(0,n1,n2,n3,g-1))
7632 #endif
7633 
7634  end do
7635  end do
7636 
7637  ! if error from C's larger than error from expansion stop expansion
7638 #ifdef PVEST2
7639  if(dij_err2(rg-1).gt.3d0*derr(rg-1)) then
7640 #else
7641  if(dij_err(rg-1).gt.3d0*derr(rg-1)) then
7642 #endif
7643  gtrunc = min(g,gtrunc)
7644 
7645 #ifdef Dgxtest
7646  write(*,*) 'CalcDgx exit err',r,rg-1,g,gtrunc,dij_err(rg-1),derr(rg-1)
7647 #endif
7648 
7649  end if
7650 
7651  end if
7652 
7653  end do gloop
7654 
7655 #ifdef Dgxtest
7656  write(*,*) 'CalcDgx D(0,0,0,0) = ',r,d(0,0,0,0)
7657  if(r.gt.1)then
7658  write(*,*) 'CalcDgx D(1,0,0,0) = ',r,d(1,0,0,0)
7659  write(*,*) 'CalcDgx D(0,1,0,0) = ',r,d(0,1,0,0)
7660  write(*,*) 'CalcDgx D(0,0,1,0) = ',r,d(0,0,1,0)
7661  endif
7662  if(r.gt.2.and.rmax.ge.2)then
7663  write(*,*) 'CalcDgx D(1,1,0,0) = ',r,d(1,1,0,0)
7664 ! write(*,*) 'CalcDgx D(0,2,0,0) = ',r,D(0,2,0,0)
7665 ! write(*,*) 'CalcDgx D(0,1,1,0) = ',r,D(0,1,1,0)
7666  write(*,*) 'CalcDgx D(0,0,2,0) = ',r,d(0,0,2,0)
7667  endif
7668  if(r.gt.3.and.rmax.ge.2)then
7669  write(*,*) 'CalcDgx D(1,0,1,0) = ',r,d(1,0,1,0)
7670  write(*,*) 'CalcDgx D(1,1,0,0) = ',r,d(1,1,0,0)
7671 ! write(*,*) 'CalcDgx D(1,2,0,0) = ',r,D(1,2,0,0)
7672  write(*,*) 'CalcDgx D(0,3,0,0) = ',r,d(0,3,0,0)
7673  write(*,*) 'CalcDgx D(0,2,1,0) = ',r,d(0,2,1,0)
7674  write(*,*) 'CalcDgx D(0,0,3,0) = ',r,d(0,0,3,0)
7675  write(*,*) 'CalcDgx D(0,1,1,1) = ',r,d(0,1,1,1)
7676  write(*,*) 'CalcDgx D(0,0,2,1) = ',r,d(0,0,2,1)
7677  endif
7678  write(*,*) 'CalcDgx Dij_err',r,dij_err
7679  write(*,*) 'CalcDgx Dij_acc',r,dij_err/abs(d(0,0,0,0))
7680 
7681  write(*,*) 'CalcDgx err',r,derr
7682  write(*,*) 'CalcDgx acc',r,derr/abs(d(0,0,0,0))
7683 #endif
7684 
7685  derr2 = max(derr,dij_err2(0:rmax))
7686  derr = max(derr,dij_err(0:rmax))
7687 
7688 #ifdef Dgxtest
7689 ! write(*,*) 'CalcDgx exit r',r,maxval(Derr),acc_req_D*abs(D(0,0,0,0))
7690 #endif
7691 
7692 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
7693  ! check if target precision already reached
7694 ! NEEDS UPDATE
7695 #ifdef Cutrloop
7696  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
7697 #else
7698  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
7699 #endif
7700  do rg=r+1,rmax
7701  do n0=0,rg/2
7702  do n1=0,rg-2*n0
7703  do n2=0,rg-2*n0-n1
7704  d(n0,n1,n2,rg-2*n0-n1-n2)=0d0
7705  enddo
7706  enddo
7707  enddo
7708  enddo
7709 
7710  exit rloop
7711 
7712  end if
7713 
7714  end do rloop
7715 
7716 
7717 #ifdef Dgxtest
7718 ! write(*,*) 'CalcDgx D(0,0,0,0) = ',D(0,0,0,0)
7719 ! if(rmax.ge.3)then
7720 ! write(*,*) 'CalcDgx D(0,1,1,1) = ',D(0,1,1,1)
7721 ! endif
7722 
7723  write(*,*) 'CalcDgx final err',derr
7724  write(*,*) 'CalcDgx final acc',derr/abs(d(0,0,0,0))
7725 #endif
7726 
7727 ! write(*,*) 'CalcDgx Derr ',Derr
7728 ! write(*,*) 'CalcDgx Derr2',Derr2
7729 

◆ calcdgy()

subroutine reductiond::calcdgy ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  ordgy_min,
integer, intent(in)  ordgy_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 7749 of file reductionD.F90.

7749 
7750  use globald
7751 
7752  integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
7753  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
7754  double complex ::Zadj2(4)
7755  double complex, allocatable :: Dexpgy(:,:,:,:,:), DuvExpgy(:,:,:,:)
7756  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
7757  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
7758  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
7759  double complex, allocatable :: C_0(:,:,:,:), C_i(:,:,:,:), Shat(:,:,:,:,:)
7760  double complex, allocatable :: Cuv_0(:,:,:,:), Cuv_i(:,:,:,:)
7761  double complex, allocatable :: D_alt(:,:,:,:)
7762  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
7763  double complex :: Smod(3), Daux, elimminf2_coli
7764  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:),acc_req_Cextra(:)
7765  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
7766  double precision :: maxDexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp,acc_aux
7767  integer :: rmaxC,rmaxExp,gtrunc,r,n0,n1,n2,n3,a,b,i,g,rg,m,n
7768  integer :: inds0(3),inds(3),inds2(2,4),at,bt,k,l,lt,ltt,nl,nlt,nltt
7769  integer :: bin,nid(0:3)
7770  logical :: errorwriteflag
7771 
7772 #ifdef Dgytest
7773  write(*,*) 'CalcDgy in, ord',rmax,ordgy_min,ordgy_max
7774 #endif
7775 
7776  ! allocation of C functions
7777  rmaxc = rmax + 2*ordgy_min + 1
7778  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
7779  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
7780  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
7781  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
7782  allocate(cerr_i(0:rmaxc,0:3))
7783  allocate(cerr2_i(0:rmaxc,0:3))
7784  allocate(acc_req_cextra(0:rmaxc))
7785 
7786  ! determine binaries for C-coefficients
7787  k=0
7788  bin = 1
7789  do while (k.le.3)
7790  if (mod(id/bin,2).eq.0) then
7791  nid(k) = id+bin
7792  k = k+1
7793  end if
7794  bin = 2*bin
7795  end do
7796 
7797  ! reduce required accuracy of higher rank C's that appear only in expansion by dividing
7798  ! by estimated suppression factors that are multiplied in expansion
7799  acc_req_cextra(0:rmax+1) = acc_req_cind
7800  acc_aux = acc_req_c
7801  if (y_gy.ne.0d0) then
7802  do g=1,ordgy_min
7803  acc_req_cextra(rmax+2*g) = acc_req_cextra(rmax+2*g-2)/y_gy
7804  acc_req_cextra(rmax+2*g+1) = acc_req_cextra(rmax+2*g-1)/y_gy
7805  acc_aux = acc_aux/max(x_gy,v_gy*y_gy)
7806  acc_req_cextra(rmax+g+1) = min(acc_req_cextra(rmax+g+1),acc_aux)
7807  end do
7808  else if(x_gy.ne.0d0) then ! 10.07.2017
7809  do g=1,ordgy_min
7810  acc_aux = acc_aux/x_gy
7811  acc_req_cextra(rmax+g+1) = acc_aux
7812  end do
7813  else ! 10.07.2017
7814  acc_req_cextra(rmax+2:rmax+2*ordgy_min+1) = acc_inf
7815  end if
7816 
7817 
7818 
7819 #ifdef Dgytest
7820  write(*,*) 'CalcDgy: accreq_Cextra',acc_req_cextra
7821 #endif
7822 
7823  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0),rmax,acc_req_cextra)
7824  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1),rmax,acc_req_cextra)
7825  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2),rmax,acc_req_cextra)
7826  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3),rmax,acc_req_cextra)
7827 
7828 #ifdef Dgytest
7829  write(*,*) 'CalcDgy Cerr 0',cerr_i(:,0)
7830  write(*,*) 'CalcDgy Cerr 1',cerr_i(:,1)
7831  write(*,*) 'CalcDgy Cerr 2',cerr_i(:,2)
7832  write(*,*) 'CalcDgy Cerr 3',cerr_i(:,3)
7833 #endif
7834 
7835 
7836  ! shift of integration momentum in C\{0}
7837  do n1=1,rmaxc
7838  do n2=0,rmaxc-n1
7839  do n3=0,rmaxc-n1-n2
7840  n0 = (rmaxc-n1-n2-n3)
7841  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
7842  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
7843  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
7844  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
7845  end do
7846  end do
7847  end do
7848 
7849 
7850  ! calculate adjugated Gram and Cayley matrix
7851 ! mm02 = elimminf2_coli(m02)
7852 ! mm12 = elimminf2_coli(m12)
7853 ! mm22 = elimminf2_coli(m22)
7854 ! mm32 = elimminf2_coli(m32)
7855 ! q10 = elimminf2_coli(p10)
7856 ! q21 = elimminf2_coli(p21)
7857 ! q32 = elimminf2_coli(p32)
7858 ! q30 = elimminf2_coli(p30)
7859 ! q31 = elimminf2_coli(p31)
7860 ! q20 = elimminf2_coli(p20)
7861 !
7862 ! Z(1,1) = 2d0*q10
7863 ! Z(2,1) = q10+q20-q21
7864 ! Z(3,1) = q10+q30-q31
7865 ! Z(1,2) = Z(2,1)
7866 ! Z(2,2) = 2d0*q20
7867 ! Z(3,2) = q20+q30-q32
7868 ! Z(1,3) = Z(3,1)
7869 ! Z(2,3) = Z(3,2)
7870 ! Z(3,3) = 2d0*q30
7871 !
7872 ! q1q2 = (q10+q20-q21)
7873 ! q1q3 = (q10+q30-q31)
7874 ! q2q3 = (q20+q30-q32)
7875 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
7876 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
7877 !
7878 ! Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
7879 ! Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
7880 ! Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
7881 ! Zadj(1,2) = Zadj(2,1)
7882 ! Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
7883 ! Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
7884 ! Zadj(1,3) = Zadj(3,1)
7885 ! Zadj(2,3) = Zadj(3,2)
7886 ! Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
7887 !
7888 ! f(1) = q10+mm02-mm12
7889 ! f(2) = q20+mm02-mm22
7890 ! f(3) = q30+mm02-mm32
7891 !
7892 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
7893 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
7894 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
7895 
7896 ! Xadj(1,1) = 2d0*mm02*Zadj(1,1) - f(2)*f(2)*Z(3,3) &
7897 ! + 2d0*f(2)*f(3)*Z(2,3) - f(3)*f(3)*Z(2,2)
7898 ! Xadj(2,1) = 2d0*mm02*Zadj(2,1) + f(1)*f(2)*Z(3,3) &
7899 ! - f(1)*f(3)*Z(2,3) - f(2)*f(3)*Z(1,3) + f(3)*f(3)*Z(2,1)
7900 ! Xadj(3,1) = 2d0*mm02*Zadj(3,1) - f(1)*f(2)*Z(3,2) &
7901 ! + f(2)*f(2)*Z(3,1) + f(1)*f(3)*Z(2,2) - f(2)*f(3)*Z(1,2)
7902 ! Xadj(1,2) = Xadj(2,1)
7903 ! Xadj(2,2) = 2d0*mm02*Zadj(2,2) - f(1)*f(1)*Z(3,3) &
7904 ! + 2d0*f(1)*f(3)*Z(1,3) - f(3)*f(3)*Z(1,1)
7905 ! Xadj(3,2) = 2d0*mm02*Zadj(3,2) + f(1)*f(1)*Z(3,2) &
7906 ! - f(1)*f(2)*Z(3,1) - f(1)*f(3)*Z(2,1) + f(2)*f(3)*Z(1,1)
7907 ! Xadj(1,3) = Xadj(3,1)
7908 ! Xadj(2,3) = Xadj(3,2)
7909 ! Xadj(3,3) = 2d0*mm02*Zadj(3,3) - f(1)*f(1)*Z(2,2) &
7910 ! + 2d0*f(1)*f(2)*Z(2,1) - f(2)*f(2)*Z(1,1)
7911 
7912 
7913  ! coefficients Shat defined in (5.13)
7914  allocate(shat(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc,3))
7915 
7916  do r=0,rmaxc
7917  do n0=0,r/2
7918  do n1=0,r-2*n0
7919  do n2=0,r-2*n0-n1
7920  n3 = r-2*n0-n1-n2
7921 
7922  shat(n0,n1,n2,n3,:) = -c_0(n0,n1,n2,n3)
7923 
7924  if(n1.eq.0) then
7925  shat(n0,n1,n2,n3,1) = shat(n0,n1,n2,n3,1) + c_i(n0,n2,n3,1)
7926  end if
7927 
7928  if(n2.eq.0) then
7929  shat(n0,n1,n2,n3,2) = shat(n0,n1,n2,n3,2) + c_i(n0,n1,n3,2)
7930  end if
7931 
7932  if(n3.eq.0) then
7933  shat(n0,n1,n2,n3,3) = shat(n0,n1,n2,n3,3) + c_i(n0,n1,n2,3)
7934  end if
7935 
7936 #ifdef Dgytest
7937  if(n0.eq.0.and.n1.eq.0.and.n2.eq.0.and.n3.eq.1)then
7938  write(*,*) 'CalcDgy 0 C_0',c_0(n0,n1,n2,n3)
7939  write(*,*) 'CalcDgy 0 C_1',c_i(n0,n2,n3,1)
7940  write(*,*) 'CalcDgy 0 C_2',c_i(n0,n1,n3,2)
7941  write(*,*) 'CalcDgy 0 C_3',c_i(n0,n1,n2,3)
7942  write(*,*) 'CalcDgy 0 Sh1',shat(n0,n1,n2,n3,1)
7943  write(*,*) 'CalcDgy 0 Sh2',shat(n0,n1,n2,n3,2)
7944  write(*,*) 'CalcDgy 0 Sh3',shat(n0,n1,n2,n3,3)
7945  endif
7946 #endif
7947 
7948  end do
7949  end do
7950  end do
7951  end do
7952 
7953  ! choose reduction formulas with biggest denominators
7954  maxxadj = 0d0
7955  if (abs(xadj(1,1)).gt.maxxadj) then
7956  maxxadj = abs(xadj(1,1))
7957  a = 1
7958  b = 1
7959  inds2 = reshape((/2,2,2,3,3,2,3,3/),shape(inds2))
7960  zadj2(1) = -z(3,3)
7961  zadj2(2) = z(3,2)
7962  zadj2(3) = z(2,3)
7963  zadj2(4) = -z(2,2)
7964  end if
7965  if (abs(xadj(2,2)).gt.maxxadj) then
7966  maxxadj = abs(xadj(2,2))
7967  a = 2
7968  b = 2
7969  inds2 = reshape((/1,1,1,3,3,1,3,3/),shape(inds2))
7970  zadj2(1) = -z(3,3)
7971  zadj2(2) = z(3,1)
7972  zadj2(3) = z(1,3)
7973  zadj2(4) = -z(1,1)
7974  end if
7975  if (abs(xadj(3,3)).gt.maxxadj) then
7976  maxxadj = abs(xadj(3,3))
7977  a = 3
7978  b = 3
7979  inds2 = reshape((/1,1,1,2,2,1,2,2/),shape(inds2))
7980  zadj2(1) = -z(2,2)
7981  zadj2(2) = z(2,1)
7982  zadj2(3) = z(1,2)
7983  zadj2(4) = -z(1,1)
7984  end if
7985  if (abs(xadj(1,2)).gt.maxxadj) then
7986  maxxadj = abs(xadj(1,2))
7987  a = 1
7988  b = 2
7989  inds2 = reshape((/2,1,2,3,3,1,3,3/),shape(inds2))
7990  zadj2(1) = z(3,3)
7991  zadj2(2) = -z(3,1)
7992  zadj2(3) = -z(2,3)
7993  zadj2(4) = z(2,1)
7994  end if
7995  if (abs(xadj(1,3)).gt.maxxadj) then
7996  maxxadj = abs(xadj(1,3))
7997  a = 1
7998  b = 3
7999  inds2 = reshape((/2,1,2,2,3,1,3,2/),shape(inds2))
8000  zadj2(1) = -z(3,2)
8001  zadj2(2) = z(3,1)
8002  zadj2(3) = z(2,2)
8003  zadj2(4) = -z(2,1)
8004  end if
8005  if (abs(xadj(2,3)).gt.maxxadj) then
8006  a = 2
8007  b = 3
8008  inds2 = reshape((/1,1,1,2,3,1,3,2/),shape(inds2))
8009  zadj2(1) = z(3,2)
8010  zadj2(2) = -z(3,1)
8011  zadj2(3) = -z(1,2)
8012  zadj2(4) = z(1,1)
8013  end if
8014 
8015  maxzadj = 0d0
8016  if (abs(zadj(1,1)).gt.maxzadj) then
8017  maxzadj = abs(zadj(1,1))
8018  k = 1
8019  l = 1
8020  lt = 2
8021  ltt = 3
8022  end if
8023  if (abs(zadj(2,2)).gt.maxzadj) then
8024  maxzadj = abs(zadj(2,2))
8025  k = 2
8026  l = 2
8027  lt = 1
8028  ltt = 3
8029  end if
8030  if (abs(zadj(3,3)).gt.maxzadj) then
8031  maxzadj = abs(zadj(3,3))
8032  k = 3
8033  l = 3
8034  lt = 1
8035  ltt = 2
8036  end if
8037  if (abs(zadj(1,2)).gt.maxzadj) then
8038  maxzadj = abs(zadj(1,2))
8039  k = 1
8040  l = 2
8041  lt = 1
8042  ltt = 3
8043  end if
8044  if (abs(zadj(1,3)).gt.maxzadj) then
8045  maxzadj = abs(zadj(1,3))
8046  k = 1
8047  l = 3
8048  lt = 1
8049  ltt = 2
8050  end if
8051  if (abs(zadj(2,3)).gt.maxzadj) then
8052  k = 2
8053  l = 3
8054  lt = 1
8055  ltt = 2
8056  end if
8057 
8058 #ifdef Dgytest
8059  write(*,*) 'CalcDgy: Zadj',k,l,zadj(k,l)
8060  write(*,*) 'CalcDgy: Xadj',a,b,xadj(a,b)
8061 #endif
8062 
8063 
8064  ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
8065  rmaxexp = rmaxc+1
8066  allocate(dexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
8067 
8068 
8069  ! calculate Cuv
8070  allocate(duvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp,0:rmaxexp))
8071  call calcduv(duvexpgy,cuv_0,mm02,f,rmaxexp,id)
8072  duv(0:rmax,0:rmax,0:rmax,0:rmax) = duvexpgy(0:rmax,0:rmax,0:rmax,0:rmax)
8073 
8074  ! allocate arrays for error propagation
8075  allocate(d00_err(0:rmaxexp))
8076  allocate(dij_err(0:rmaxexp))
8077  allocate(cij_err(0:rmaxc))
8078 
8079  allocate(d00_err2(0:rmaxexp))
8080  allocate(dij_err2(0:rmaxexp))
8081  allocate(cij_err2(0:rmaxc))
8082 
8083  ! initialize accuracy estimates
8084  derr = acc_inf
8085  dij_err =0d0
8086  d00_err =0d0
8087  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
8088 
8089  derr2 = acc_inf
8090  dij_err2 =0d0
8091  d00_err2 =0d0
8092  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
8093 
8094 ! maxZadj = maxval(abs(Zadj))
8095 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
8096 ! maxZadjf = maxval(abs(Zadjf))
8097 ! adetZ = abs(detZ)
8098 
8099  ! truncation of expansion if calculated term larger than truncfacexp * previous term
8100  ! crucial for expansion parameters between 0.1 and 1 !!!
8101 ! truncfacexp = sqrt(max(maxZadjf,adetZ)/maxXadj*max(1d0,maxZadj2f/maxZadj)) * truncfacD
8102  truncfacexp = sqrt(fac_gy) * truncfacd
8103  gtrunc = ordgy_max
8104 
8105 ! calculate D(1,n1,n2,n3) up to rank r+2
8106 ! calculate D(0,n1,n2,n3) up to rank r
8107  rloop: do r=0,rmaxexp-2
8108 
8109  if (r.gt.rmax+2*gtrunc+2) exit rloop
8110 
8111  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
8112  ! 0th-order coefficients
8113  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
8114 
8115  ! calculating D_00ijk.. exploiting eq. (5.49)
8116  maxdexpgy(1,r,0)=0d0
8117  do nl=r,0,-1
8118  do nlt=r-nl,0,-1
8119  nltt = r-nl-nlt
8120  inds0(l) = nl
8121  inds0(lt) = nlt
8122  inds0(ltt) = nltt
8123 
8124  inds(l) = nl+1
8125  inds(lt) = nlt
8126  inds(ltt) = nltt
8127 
8128  daux = zadj(k,1)*shat(0,inds(1),inds(2),inds(3),1) &
8129  + zadj(k,2)*shat(0,inds(1),inds(2),inds(3),2) &
8130  + zadj(k,3)*shat(0,inds(1),inds(2),inds(3),3)
8131 
8132  if (nlt.ge.1) then
8133  inds(lt) = nlt-1
8134  daux = daux - 2*nlt*zadj(k,lt)*dexpgy(1,inds(1),inds(2),inds(3),0)
8135  end if
8136 
8137  if (nltt.ge.1) then
8138  inds(lt) = nlt
8139  inds(ltt) = nltt-1
8140  daux = daux - 2*nltt*zadj(k,ltt)*dexpgy(1,inds(1),inds(2),inds(3),0)
8141  end if
8142 
8143  dexpgy(1,inds0(1),inds0(2),inds0(3),0) = daux/(2*(nl+1)*zadj(k,l))
8144 
8145  maxdexpgy(1,r,0) = maxdexpgy(1,r,0) + abs(dexpgy(1,inds0(1),inds0(2),inds0(3),0) )
8146 
8147 ! if (r+2.le.rmax) then ! for fixed rank
8148  if (r+1.le.rmax) then
8149  d(1,inds0(1),inds0(2),inds0(3)) = dexpgy(1,inds0(1),inds0(2),inds0(3),0)
8150  end if
8151 
8152 
8153 
8154  end do
8155  end do
8156 
8157  ! calculate D_ijkl.. exploiting eq. (5.53)
8158  maxdexpgy(0,r,0)=0d0
8159  do n1=0,r
8160  do n2=0,r-n1
8161  n3 = r-n1-n2
8162 
8163 ! Duv added 16.05.14
8164 ! Daux = (2d0*(1+r)*Dexpgy(1,n1,n2,n3,0) - C_0(0,n1,n2,n3))*Zadj(a,b)
8165  daux = (2d0*(1+r)*dexpgy(1,n1,n2,n3,0) - 4*duvexpgy(1,n1,n2,n3) &
8166  - c_0(0,n1,n2,n3))*zadj(a,b)
8167 
8168  smod = shat(0,n1,n2,n3,:)
8169 
8170 #ifdef Dgytest
8171  if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
8172  write(*,*) 'CalcDgy 0 Smod',smod
8173  write(*,*) 'CalcDgy 0 Daux',daux
8174  endif
8175 #endif
8176 
8177  if (n1.ge.1) then
8178  smod(1) = smod(1) - 2d0*n1*dexpgy(1,n1-1,n2,n3,0)
8179  end if
8180  if (n2.ge.1) then
8181  smod(2) = smod(2) - 2d0*n2*dexpgy(1,n1,n2-1,n3,0)
8182  end if
8183  if (n3.ge.1) then
8184  smod(3) = smod(3) - 2d0*n3*dexpgy(1,n1,n2,n3-1,0)
8185  end if
8186 
8187 #ifdef Dgytest
8188  if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
8189  write(*,*) 'CalcDgy 0',r,a,b,zadjf(b)/xadj(a,b)
8190  write(*,*) 'CalcDgy 0',k,l,detz/zadj(k,l),zadjf(k)/zadj(k,l)
8191  write(*,*) 'CalcDgy 0 line1',r,daux/xadj(a,b)
8192  endif
8193 #endif
8194 
8195  do i=1,4
8196  n = inds2(1,i)
8197  m = inds2(2,i)
8198  daux = daux + zadj2(i)*f(n)*smod(m)
8199 
8200 #ifdef Dgytest
8201  if(n1.eq.0.and.n2.eq.2.and.n3.eq.0)then
8202  write(*,*) 'CalcDgy 0 2f',r,i,zadj2(i)*f(n)*smod(m)/xadj(a,b)
8203  endif
8204 #endif
8205 
8206  end do
8207 
8208  dexpgy(0,n1,n2,n3,0) = daux/xadj(a,b)
8209 
8210 #ifdef Dgytest
8211  if(n1.eq.1.and.n2.eq.1.and.n3.eq.1)then
8212  write(*,*) 'CalcDgy D_0',r,dexpgy(0,n1,n2,n3,0)
8213  endif
8214 #endif
8215 
8216  maxdexpgy(0,r,0) = maxdexpgy(0,r,0) + abs(dexpgy(0,n1,n2,n3,0))
8217  if (r.le.rmax) then
8218  d(0,n1,n2,n3) = dexpgy(0,n1,n2,n3,0)
8219 ! Derr(r) = abs(maxZadjf/maxXadj*Dexpgy(0,n1,n2,n3,0))
8220  end if
8221 
8222  end do
8223  end do
8224 
8225  if (r.le.rmax) then
8226 ! Derr(r) = abs(maxZadjf/Xadj(a,b))*maxDexpgy(0,r,0)
8227  derr(r) = fac_gy*maxdexpgy(0,r,0)
8228  endif
8229 
8230  ! error propagation from C's
8231  d00_err(r+2) = cij_err(r+1)/2d0
8232  dij_err(r)=max(maxzadj/maxxadj*max(2*(r+1)*d00_err(r+2),cerr_i(r,0)), &
8233  maxzadj2f/maxxadj*max(2*d00_err(r+1),cij_err(r)))
8234 
8235  d00_err2(r+2) = cij_err2(r+1)/2d0
8236  dij_err2(r)=max(maxzadj/maxxadj*max(2*(r+1)*d00_err2(r+2),cerr2_i(r,0)), &
8237  maxzadj2f/maxxadj*max(2*d00_err2(r+1),cij_err2(r)))
8238 
8239  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8240  ! higher order coefficients
8241  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8242 
8243  rg = r
8244  gloop: do g=1,min(gtrunc,r/2)
8245  rg = rg-2
8246 
8247  ! calculating D_00ijk.. exploiting eq. (5.49)
8248  maxdexpgy(1,rg,g) = 0d0
8249  do nl=rg,0,-1
8250  do nlt=rg-nl,0,-1
8251  nltt = rg-nl-nlt
8252  inds0(l) = nl
8253  inds0(lt) = nlt
8254  inds0(ltt) = nltt
8255 
8256  inds = inds0
8257  inds(l) = inds(l)+1
8258  daux = -zadjf(k)*dexpgy(0,inds(1),inds(2),inds(3),g-1)
8259 
8260  inds(k) = inds(k)+1
8261  daux = daux - detz*dexpgy(0,inds(1),inds(2),inds(3),g-1)
8262 
8263  if (nlt.ge.1) then
8264  inds(l) = nl+1
8265  inds(lt) = nlt-1
8266  inds(ltt) = nltt
8267  daux = daux - 2*nlt*zadj(k,lt)*dexpgy(1,inds(1),inds(2),inds(3),g)
8268  end if
8269  if (nltt.ge.1) then
8270  inds(l) = nl+1
8271  inds(lt) = nlt
8272  inds(ltt) = nltt-1
8273  daux = daux - 2*nltt*zadj(k,ltt)*dexpgy(1,inds(1),inds(2),inds(3),g)
8274  end if
8275 
8276  dexpgy(1,inds0(1),inds0(2),inds0(3),g) = daux/(2*(nl+1)*zadj(k,l))
8277 
8278  maxdexpgy(1,rg,g) = maxdexpgy(1,rg,g) + abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g) )
8279 ! if (rg+2.le.rmax) then
8280 ! D(1,inds0(1),inds0(2),inds0(3)) = D(1,inds0(1),inds0(2),inds0(3)) &
8281 ! + Dexpgy(1,inds0(1),inds0(2),inds0(3),g)
8282 ! end if
8283 
8284 
8285 ! 10.08.2017 factor 1d1 added for g=1 since first terms can cancel for certain cases
8286  if (g.eq.1.and.abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)).gt. &
8287  1d1*truncfacexp*max(1/m2scale,maxdexpgy(1,rg,g-1)) .or. &
8288  g.ge.2.and.abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)).gt. &
8289  truncfacexp*maxdexpgy(1,rg,g-1)) then
8290 
8291 #ifdef Dgytest
8292  write(*,*) 'CalcDgy exit gloop',1,inds0(1),inds0(2),inds0(3),g, &
8293  abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g)),abs(dexpgy(1,inds0(1),inds0(2),inds0(3),g-1)),maxdexpgy(1,rg,g-1)
8294 #endif
8295 
8296  gtrunc = g-1
8297  exit gloop
8298 ! gtrunc = g
8299 ! cycle gloop ! worsens results !?
8300  end if
8301 
8302  end do
8303  end do
8304 
8305 #ifndef PPEXP00
8306 ! if (rg+2.le.rmax) then ! for fixed rank
8307  if (rg+1.le.rmax) then
8308  do n1=0,rg
8309  do n2=0,rg-n1
8310  n3=rg-n1-n2
8311  d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgy(1,n1,n2,n3,g)
8312  end do
8313  end do
8314  end if
8315 #endif
8316 
8317  ! calculate D_ijkl.. exploiting eq. (5.53)
8318  maxdexpgy(0,rg,g) = 0d0
8319  do n1=0,rg
8320  do n2=0,rg-n1
8321  n3 = rg-n1-n2
8322 
8323  inds(1) = n1
8324  inds(2) = n2
8325  inds(3) = n3
8326  inds(a) = inds(a)+1
8327  daux = 2*(1+rg)*dexpgy(1,n1,n2,n3,g)*zadj(a,b) &
8328  - zadjf(b)*dexpgy(0,inds(1),inds(2),inds(3),g-1)
8329 
8330  smod = 0d0
8331  if (n1.ge.1) then
8332  smod(1) = smod(1) - 2d0*n1*dexpgy(1,n1-1,n2,n3,g)
8333  end if
8334  if (n2.ge.1) then
8335  smod(2) = smod(2) - 2d0*n2*dexpgy(1,n1,n2-1,n3,g)
8336  end if
8337  if (n3.ge.1) then
8338  smod(3) = smod(3) - 2d0*n3*dexpgy(1,n1,n2,n3-1,g)
8339  end if
8340 
8341  do i=1,4
8342  n = inds2(1,i)
8343  m = inds2(2,i)
8344  daux = daux + zadj2(i)*f(n)*smod(m)
8345  end do
8346 
8347  dexpgy(0,n1,n2,n3,g) = daux/xadj(a,b)
8348 
8349  maxdexpgy(0,rg,g) = maxdexpgy(0,rg,g) + abs(dexpgy(0,n1,n2,n3,g))
8350 
8351 ! if (rg.le.rmax) then
8352 ! D(0,n1,n2,n3) = D(0,n1,n2,n3) + Dexpgy(0,n1,n2,n3,g)
8353 ! end if
8354 
8355  if (g.eq.1.and.abs(dexpgy(0,n1,n2,n3,g)).gt. &
8356  truncfacexp*max(1/m2scale**2,maxdexpgy(0,rg,g-1)) .or. &
8357  g.ge.2.and.abs(dexpgy(0,n1,n2,n3,g)).gt. &
8358  truncfacexp*maxdexpgy(0,rg,g-1)) then
8359 
8360 #ifdef Dgytest
8361  write(*,*) 'CalcDgy cycle loop',n1,n2,n3,g,abs(dexpgy(0,n1,n2,n3,g)),abs(dexpgy(0,n1,n2,n3,g-1)),maxdexpgy(0,rg,g-1)
8362 #endif
8363 
8364  gtrunc = g-1
8365  exit gloop
8366 ! gtrunc = g
8367 ! cycle gloop
8368  end if
8369 
8370  end do
8371  end do
8372 
8373  ! error propagation from C's
8374  if(rg.gt.1)then
8375  d00_err(rg+2) = max(d00_err(rg+2), &
8376  maxzadjf/maxzadj/2d0*dij_err(rg+1), &
8377  abs(detz)/maxzadj/2d0*dij_err(rg+2))
8378  end if
8379  dij_err(rg)=max(dij_err(rg),maxzadjf/maxxadj*dij_err(rg+1), &
8380  2*(rg+1)*maxzadj/maxxadj*d00_err(rg+2), &
8381  2*maxzadj2f/maxxadj*d00_err(rg+1))
8382 
8383  if(rg.gt.1)then
8384  d00_err2(rg+2) = max(d00_err2(rg+2), &
8385  maxzadjf/maxzadj/2d0*dij_err2(rg+1), &
8386  abs(detz)/maxzadj/2d0*dij_err2(rg+2))
8387  end if
8388  dij_err2(rg)=max(dij_err2(rg),maxzadjf/maxxadj*dij_err2(rg+1), &
8389  2*(rg+1)*maxzadj/maxxadj*d00_err2(rg+2), &
8390  2*maxzadj2f/maxxadj*d00_err2(rg+1))
8391 
8392 #ifdef PPEXP00
8393 ! if (rg+2.le.rmax) then ! for fixed rank
8394  if (rg+2.le.rmax) then
8395  do n1=0,rg
8396  do n2=0,rg-n1
8397  n3=rg-n1-n2
8398  d(1,n1,n2,n3) = d(1,n1,n2,n3) + dexpgy(1,n1,n2,n3,g)
8399  end do
8400  end do
8401  end if
8402 #endif
8403 
8404  if ((rg.le.rmax)) then
8405  derr(rg) = 0d0
8406  do n1=0,rg
8407  do n2=0,rg-n1
8408  n3 = rg-n1-n2
8409  d(0,n1,n2,n3) = d(0,n1,n2,n3) + dexpgy(0,n1,n2,n3,g)
8410  if(abs(dexpgy(0,n1,n2,n3,g-1)).ne.0d0) then
8411 ! Derr(rg)=max(Derr(rg),abs(Dexpgy(0,n1,n2,n3,g))**2/abs(Dexpgy(0,n1,n2,n3,g-1)))
8412  derr(rg)=max(derr(rg),abs(dexpgy(0,n1,n2,n3,g))*min(1d0,abs(dexpgy(0,n1,n2,n3,g))/abs(dexpgy(0,n1,n2,n3,g-1))))
8413  else
8414  derr(rg)=max(derr(rg),abs(dexpgy(0,n1,n2,n3,g)))
8415  endif
8416 
8417 #ifdef Dgytest
8418 ! write(*,*) 'CalcDgy Derr calc',rg,Derr(rg),n1,n2,n3,g,abs(Dexpgy(0,n1,n2,n3,g)),abs(Dexpgy(0,n1,n2,n3,g-1))
8419 #endif
8420 
8421  end do
8422  end do
8423 
8424  ! if error from C's larger than error from expansion stop expansion
8425  ! allow for one more term, as each step involves only even or odd ranks
8426 #ifdef PVEST2
8427  if(dij_err2(rg).gt.3d0*derr(rg)) then
8428 #else
8429  if(dij_err(rg).gt.3d0*derr(rg)) then
8430 #endif
8431  gtrunc = min(g,gtrunc)
8432 ! gtrunc = min(g+1,gtrunc)
8433 
8434 #ifdef Dgytest
8435  write(*,*) 'CalcDgy exit err',rg,g,gtrunc
8436  write(*,*) 'CalcDgy exit err',dij_err(rg),derr(rg)
8437 #endif
8438  end if
8439 
8440  end if
8441 
8442  end do gloop
8443 
8444 #ifdef Dgytest
8445 
8446  write(*,*) 'CalcDgy D(1,0,0,0)',r,d(1,0,0,0)
8447  write(*,*) 'CalcDgy D(0,0,0,0)',r,d(0,0,0,0)
8448  write(*,*) 'CalcDgy D(0,0,0,1)',r,d(0,0,0,1)
8449  if (r.ge.2.and.rmax.ge.2) then
8450  write(*,*) 'CalcDgy D(0,0,0,2)',r,d(0,0,0,2)
8451  endif
8452  if (r.ge.3.and.rmax.ge.3)then
8453  write(*,*) 'CalcDgy D(1,0,0,1)',r,d(1,0,0,1)
8454  write(*,*) 'CalcDgy D(0,1,0,2)',r,d(0,1,0,2)
8455  write(*,*) 'CalcDgy D(0,0,0,3)',r,d(0,0,0,3)
8456  write(*,*) 'CalcDgy D(0,1,1,1)',r,d(0,1,1,1)
8457  write(*,*) 'CalcDgy D(0,2,1,0)',r,d(0,2,1,0)
8458  endif
8459 
8460  write(*,*) 'CalcDgy Dij_err',r,dij_err
8461  write(*,*) 'CalcDgy Dij_acc',r,dij_err/abs(d(0,0,0,0))
8462 
8463  write(*,*) 'CalcDgy err',r,g,derr
8464  write(*,*) 'CalcDgy acc',r,g,derr/abs(d(0,0,0,0))
8465 #endif
8466 
8467  derr2 = max(derr,dij_err2(0:rmax))
8468  derr = max(derr,dij_err(0:rmax))
8469 
8470 ! if(maxval(Derr).le.acc_req_D*abs(D(0,0,0,0))) exit ! changed 28.01.15
8471  ! check if target precision already reached
8472 #ifdef Cutrloop
8473  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0) then
8474  if (r.lt.rmax) then
8475  do rg=r+1,rmax
8476  do n1=0,rg
8477  do n2=0,rg-n1
8478  d(0,n1,n2,rg-n1-n2)=0d0
8479  end do
8480  end do
8481  end do
8482  do rg=r+1,rmax
8483  do n1=0,rg-2
8484  do n2=0,rg-2-n1
8485  d(1,n1,n2,rg-2-n1-n2)=0d0
8486  end do
8487  end do
8488  end do
8489 
8490 100 format(((a)))
8491 111 format(a22,2('(',g24.17,',',g24.17,') ':))
8492  call seterrflag_coli(-5)
8493  call errout_coli('CalcDgy',' exit rloop for D', &
8494  errorwriteflag)
8495  if (errorwriteflag) then
8496  write(nerrout_coli,100)' CalcDgy: exit rloop for D ', &
8497  ' should not appear'
8498  write(nerrout_coli,111)' CalcDgy: p10 = ',p10
8499  write(nerrout_coli,111)' CalcDgy: p21 = ',p21
8500  write(nerrout_coli,111)' CalcDgy: p32 = ',p32
8501  write(nerrout_coli,111)' CalcDgy: p30 = ',p30
8502  write(nerrout_coli,111)' CalcDgy: p20 = ',p20
8503  write(nerrout_coli,111)' CalcDgy: p31 = ',p31
8504  write(nerrout_coli,111)' CalcDgy: m02 = ',m02
8505  write(nerrout_coli,111)' CalcDgy: m12 = ',m12
8506  write(nerrout_coli,111)' CalcDgy: m22 = ',m22
8507  write(nerrout_coli,111)' CalcDgy: m32 = ',m32
8508  end if
8509  end if
8510 
8511 #else
8512  if(maxval(derr-acc_req_d*abs(d(0,0,0,0))).le.0d0.and.r.ge.rmax) then
8513 #endif
8514 
8515  exit rloop
8516 
8517  end if
8518 
8519  end do rloop
8520 
8521 
8522  ! calculating D_0000ijk.. exploiting eq. (5.49)
8523 ! do r=4,rmax
8524 !! do n0=2,rmax/2 ! for fixed rank
8525 ! do n0=2,rmax
8526  do r=4,rmax+1 ! includes rmax+1 24.01.16
8527  do n0=2,max(rmax,r/2) ! includes rmax+1 24.01.16
8528  do nl=r-2*n0,0,-1
8529  do nlt=r-2*n0-nl,0,-1
8530  nltt = r-2*n0-nl-nlt
8531  inds0(l) = nl
8532  inds0(lt) = nlt
8533  inds0(ltt) = nltt
8534 
8535  inds(l) = nl+1
8536  inds(lt) = nlt
8537  inds(ltt) = nltt
8538  daux = zadj(k,1)*shat(n0-1,inds(1),inds(2),inds(3),1) &
8539  + zadj(k,2)*shat(n0-1,inds(1),inds(2),inds(3),2) &
8540  + zadj(k,3)*shat(n0-1,inds(1),inds(2),inds(3),3) &
8541  - zadjf(k)*d(n0-1,inds(1),inds(2),inds(3))
8542 
8543  inds(k) = inds(k)+1
8544  daux = daux - detz*d(n0-1,inds(1),inds(2),inds(3))
8545  inds(k) = inds(k)-1
8546 
8547  if (nlt.ge.1) then
8548  inds(lt) = nlt-1
8549  daux = daux - 2*nlt*zadj(k,lt)*d(n0,inds(1),inds(2),inds(3))
8550  end if
8551  if (nltt.ge.1) then
8552  inds(lt) = nlt
8553  inds(ltt) = nltt-1
8554  daux = daux - 2*nltt*zadj(k,ltt)*d(n0,inds(1),inds(2),inds(3))
8555  end if
8556 
8557  d(n0,inds0(1),inds0(2),inds0(3)) = daux/(2*(nl+1)*zadj(k,l))
8558 
8559  end do
8560  end do
8561  end do
8562  end do
8563 
8564  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
8565  ! already calculated for rmax+1 with extension of 24.01.16 above
8566 ! do r=rmax+1,2*rmax
8567 #ifdef notneeded
8568  do r=rmax+1,rmax+1
8569  do n0=r-rmax,r/2
8570  do n1=0,r-2*n0
8571  do n2=0,r-2*n0-n1
8572  n3 = r-2*n0-n1-n2
8573 
8574  write(*,*) 'CalcDgy exp rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
8575 
8576  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
8577  + 4*duv(n0,n1,n2,n3) &
8578  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
8579  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
8580 
8581  write(*,*) 'CalcDgy dir rmax+1',r,n0,n1,n2,n3, d(n0,n1,n2,n3)
8582 
8583  end do
8584  end do
8585  end do
8586  end do
8587 #endif
8588 
8589 #ifdef Dgytest
8590  if(rmax.ge.2) then
8591  write(*,*) 'CalcDgy D(1,0,0,0) fin',d(1,0,0,0)
8592  write(*,*) 'CalcDgy D(0,0,2,0) fin',d(0,0,2,0)
8593  write(*,*) 'CalcDgy D(0,0,0,2) fin',d(0,0,0,2)
8594  if(rmax.ge.3) then
8595  write(*,*) 'CalcDgy D(1,0,1,0) fin',d(1,0,1,0)
8596  write(*,*) 'CalcDgy D(0,1,1,1) fin',d(0,1,1,1)
8597  write(*,*) 'CalcDgy D(0,0,3,0) fin',d(0,0,3,0)
8598  endif
8599  endif
8600 
8601  write(*,*) 'CalcDgy final err',derr
8602  write(*,*) 'CalcDgy final acc',derr/abs(d(0,0,0,0))
8603 #endif
8604 
8605 ! write(*,*) 'CalcDgy Derr ',Derr
8606 ! write(*,*) 'CalcDgy Derr2',Derr2
8607 

◆ calcdpv()

subroutine reductiond::calcdpv ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 3532 of file reductionD.F90.

3532 
3533  use globald
3534 
3535  integer, intent(in) :: rmax,id
3536  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
3537  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
3538  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
3539  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
3540  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
3541  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
3542  double complex, allocatable :: D_alt(:,:,:,:)
3543  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
3544  double complex :: Smod(3)
3545  double complex :: D0_coli, elimminf2_coli
3546  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
3547  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
3548  integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
3549  integer :: bin,k,nid(0:3)
3550 
3551 ! if (id.eq.0) write(*,*) 'CalcDpv in', rmax,id
3552 
3553  ! calculation of scalar coefficient
3554  d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
3555  duv(0,0,0,0) = 0d0
3556 
3557  ! accuracy estimate for D0 function
3558  derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3559  derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3560 
3561  if (rmax.eq.0) return
3562 
3563  ! allocation of C functions
3564  rmaxc = rmax-1
3565  ! rmaxC = max(rmax-1,0)
3566  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3567  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3568  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3569  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3570  allocate(cerr_i(0:rmaxc,0:3))
3571  allocate(cerr2_i(0:rmaxc,0:3))
3572 
3573  ! allocate arrays for error propagation
3574  allocate(d00_err(0:rmax))
3575  allocate(dij_err(0:rmax))
3576  allocate(cij_err(0:rmaxc))
3577 
3578  allocate(d00_err2(0:rmax))
3579  allocate(dij_err2(0:rmax))
3580  allocate(cij_err2(0:rmaxc))
3581 
3582  ! determine binaries for C-coefficients
3583  k=0
3584  bin = 1
3585  do while (k.le.3)
3586  if (mod(id/bin,2).eq.0) then
3587  nid(k) = id+bin
3588  k = k+1
3589  end if
3590  bin = 2*bin
3591  end do
3592 
3593 
3594  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
3595  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
3596  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
3597  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
3598 
3599 #ifdef Dpvtest
3600  write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,0)
3601  write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,1)
3602  write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,2)
3603  write(*,*) 'CalcDpv Cerr_i=',cerr_i(:,3)
3604 #endif
3605 
3606  ! shift of integration momentum in C\{0}
3607  do n1=1,rmaxc
3608  do n2=0,rmaxc-n1
3609  do n3=0,rmaxc-n1-n2
3610  n0 = (rmaxc-n1-n2-n3)
3611  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
3612  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
3613  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
3614  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
3615  end do
3616  end do
3617  end do
3618 
3619 
3620  ! determine inverse Gram matrix
3621 ! mm02 = elimminf2_coli(m02)
3622 ! mm12 = elimminf2_coli(m12)
3623 ! mm22 = elimminf2_coli(m22)
3624 ! mm32 = elimminf2_coli(m32)
3625 ! q10 = elimminf2_coli(p10)
3626 ! q21 = elimminf2_coli(p21)
3627 ! q32 = elimminf2_coli(p32)
3628 ! q30 = elimminf2_coli(p30)
3629 ! q31 = elimminf2_coli(p31)
3630 ! q20 = elimminf2_coli(p20)
3631 
3632 
3633 ! q1q2 = (q10+q20-q21)
3634 ! q1q3 = (q10+q30-q31)
3635 ! q2q3 = (q20+q30-q32)
3636 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
3637 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
3638 
3639 ! Zinv(1,1) = (4d0*q30*q20-q2q3*q2q3)/detZ
3640 ! Zinv(2,1) = (q1q3*q2q3-2d0*q30*q1q2)/detZ
3641 ! Zinv(3,1) = (q1q2*q2q3-2d0*q20*q1q3)/detZ
3642 ! Zinv(1,2) = Zinv(2,1)
3643 ! Zinv(2,2) = (4d0*q10*q30-q1q3*q1q3)/detZ
3644 ! Zinv(3,2) = (q1q2*q1q3-2d0*q10*q2q3)/detZ
3645 ! Zinv(1,3) = Zinv(3,1)
3646 ! Zinv(2,3) = Zinv(3,2)
3647 ! Zinv(3,3) = (4d0*q10*q20-q1q2*q1q2)/detZ
3648 !
3649 ! f(1) = q10+mm02-mm12
3650 ! f(2) = q20+mm02-mm22
3651 ! f(3) = q30+mm02-mm32
3652 
3653 ! commented out 2.9.17
3654 ! Zinv = Zadj/detZ
3655 
3656  ! calculate Duv
3657  call calcduv(duv,cuv_0,mm02,f,rmax,id)
3658 
3659  ! initialization of error propagation
3660 ! Zadj=Zinv*detZ
3661 
3662 ! maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(3,1)), &
3663 ! abs(Zadj(2,2)),abs(Zadj(3,2)),abs(Zadj(3,3)))
3664 
3665 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
3666 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
3667 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
3668 ! maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)),abs(Zadjf(3)))
3669 !
3670 ! aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2)+Zadjf(3)*f(3))
3671 
3672 ! adetZ = abs(detZ)
3673 ! adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2)-Zadjf(3)*f(3))
3674 
3675  dij_err =0d0
3676  d00_err =0d0
3677  dij_err(0) = derr(0)
3678  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
3679 
3680  dij_err2 =0d0
3681  d00_err2 =0d0
3682  dij_err2(0) = derr2(0)
3683  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
3684 
3685 #ifdef Dpvtest
3686  write(*,*) 'CalcDpv Cij_err=',cij_err
3687  write(*,*) 'CalcDpv Dij_err(0)=',dij_err(0)
3688 #endif
3689 
3690  allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
3691 
3692  ! PV reduction
3693  do r=1,rmax
3694 
3695  if (mod(r,2).eq.0) then
3696  ! reduction formula (5.10) for D(r/2,0,0,0)
3697  n0 = r/2
3698  d(n0,0,0,0) = (c_0(n0-1,0,0,0) + 2*mm02*d(n0-1,0,0,0) + 4*duv(n0,0,0,0) &
3699  + f(1)*d(n0-1,1,0,0) + f(2)*d(n0-1,0,1,0) &
3700  + f(3)*d(n0-1,0,0,1)) / (2*(r-1))
3701  end if
3702 
3703 
3704  do n0=(r-1)/2,0,-1
3705  do n1=0,r-2*n0
3706  do n2=0,r-2*n0-n1
3707  n3 = r-2*n0-n1-n2
3708 
3709  if (n1.ge.1) then
3710  nn1 = n1-1
3711  nn2 = n2
3712  nn3 = n3
3713  j = 1
3714  else if (n2.ge.1) then
3715  nn1 = n1
3716  nn2 = n2-1
3717  nn3 = n3
3718  j = 2
3719  else
3720  nn1 = n1
3721  nn2 = n2
3722  nn3 = n3-1
3723  j = 3
3724  end if
3725 
3726  do i=1,3
3727  smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
3728  end do
3729 
3730  if (nn1.ge.1) then
3731  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
3732  else
3733  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
3734  end if
3735 
3736  if (nn2.ge.1) then
3737  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
3738  else
3739  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
3740  end if
3741 
3742  if (nn3.ge.1) then
3743  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
3744  else
3745  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
3746  end if
3747 
3748  d(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2) &
3749  + zinv(3,j)*smod(3)
3750 
3751  end do
3752  end do
3753  end do
3754 
3755  ! determine error from symmetry for n0=0 and n1>1, n2>1
3756  derr(r)=derr(r-1)
3757  derr2(r)=derr2(r-1)
3758  n0=0
3759  do n1=0,r-2*n0
3760  do n2=0,r-2*n0-n1
3761  n3 = r-2*n0-n1-n2
3762  if (n1.ge.1.and.n2+n3.ge.1) then
3763 
3764  if (n2.ge.1) then
3765  nn1 = n1
3766  nn2 = n2-1
3767  nn3 = n3
3768  j = 2
3769  else
3770  nn1 = n1
3771  nn2 = n2
3772  nn3 = n3-1
3773  j = 3
3774  end if
3775 
3776  do i=1,3
3777  smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
3778  end do
3779 
3780  if (nn1.ge.1) then
3781  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
3782  else
3783  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
3784  end if
3785 
3786  if (nn2.ge.1) then
3787  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
3788  else
3789  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
3790  end if
3791 
3792  if (nn3.ge.1) then
3793  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
3794  else
3795  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
3796  end if
3797 
3798  d_alt(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2) &
3799  + zinv(3,j)*smod(3)
3800 
3801  derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3802  derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3803 
3804 ! write(*,*) 'CalcDpv: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
3805 ! D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
3806 
3807 
3808  end if
3809  end do
3810  end do
3811 
3812  if(r.ge.2)then
3813  d00_err(r) = max(abs(m02)*dij_err(r-2), cerr_i(r-2,0), &
3814  azadjff/adetz*dij_err(r-2), &
3815  maxzadjf/adetz*max(d00_err(r-1),cij_err(r-2)))
3816  else
3817  d00_err(r) = 0d0
3818  end if
3819  dij_err(r) = max(maxzadjf*dij_err(r-1), &
3820  maxzadj*max(d00_err(r),cij_err(r-1)))/adetz
3821 
3822  if(r.ge.2)then
3823  d00_err2(r) = max(abs(m02)*dij_err2(r-2), cerr2_i(r-2,0), &
3824  azadjff/adetz*dij_err2(r-2), &
3825  maxzadjf/adetz*max(d00_err2(r-1),cij_err2(r-2)))
3826  else
3827  d00_err2(r) = 0d0
3828  end if
3829  dij_err2(r) = max(maxzadjf*dij_err2(r-1), &
3830  maxzadj*max(d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
3831  end do
3832 
3833  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
3834 ! do r=rmax+1,2*rmax
3835  do r=rmax+1,rmax+1
3836  do n0=r-rmax,r/2
3837  do n1=0,r-2*n0
3838  do n2=0,r-2*n0-n1
3839  n3 = r-2*n0-n1-n2
3840 
3841  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
3842  + 4*duv(n0,n1,n2,n3) &
3843  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
3844  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
3845  end do
3846  end do
3847  end do
3848  end do
3849 
3850 #ifdef Dpvtest
3851  write(*,*) 'CalcDpv Derrsym',derr
3852  write(*,*) 'CalcDpv Daccsym',derr/abs(d(0,0,0,0))
3853 
3854 ! write(*,*) 'Dij_err_jj',maxZadjf*Dij_err/adetZ
3855 ! write(*,*) 'Dij_err_00',maxZadj*D00_err(1:rmax)/adetZ
3856 ! write(*,*) 'Dij_err_cc',maxZadj*Cij_err/adetZ
3857 
3858  write(*,*) 'CalcDpv Dijerr',dij_err(1:rmax)
3859  write(*,*) 'CalcDpv Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
3860 #endif
3861 
3862  derr2 = max(derr2,dij_err2(0:rmax))
3863  derr = max(derr,dij_err(0:rmax))
3864 
3865 #ifdef Dpvtest
3866  write(*,*) 'CalcDpv Derr',derr
3867  write(*,*) 'CalcDpv Dacc',derr/abs(d(0,0,0,0))
3868 #endif
3869 
3870  if (id.eq.0) then
3871  write(*,*) 'CalcDpv Derr ',derr
3872  write(*,*) 'CalcDpv Derr2',derr2
3873  end if
3874 

◆ calcdpv1()

subroutine reductiond::calcdpv1 ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 2738 of file reductionD.F90.

2738 
2739  use globald
2740 
2741  integer, intent(in) :: rmax,id
2742  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
2743  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
2744  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
2745  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
2746  double complex :: C_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1), Cuv_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1)
2747  double complex :: C_i(0:rmax-1,0:rmax-1,0:rmax-1,3), Cuv_i(0:rmax-1,0:rmax-1,0:rmax-1,3)
2748  double complex :: D_alt(0:rmax,0:rmax,0:rmax,0:rmax)
2749  double precision :: Cerr_i(0:rmax-1,0:3),Cerr2_i(0:rmax-1,0:3)
2750 ! double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
2751 ! double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
2752 ! double complex, allocatable :: D_alt(:,:,:,:)
2753 ! double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
2754  double complex :: Smod(3)
2755  double complex :: D0_coli, elimminf2_coli
2756  ! double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
2757  ! double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
2758  double precision :: D00_err(0:rmax),Dij_err(0:rmax),Cij_err(0:rmax-1)
2759  double precision :: D00_err2(0:rmax),Dij_err2(0:rmax),Cij_err2(0:rmax-1)
2760  integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
2761  integer :: bin,k,nid(0:3)
2762 
2763 ! if (id.eq.0) write(*,*) 'CalcDpv1 in', rmax, id
2764 
2765  ! calculation of scalar coefficient
2766  d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
2767  duv(0,0,0,0) = 0d0
2768 
2769  ! accuracy estimate for D0 function
2770  derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
2771  derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
2772 
2773  if (rmax.eq.0) return
2774 
2775  ! allocation of C functions
2776  rmaxc = rmax-1
2777  ! rmaxC = max(rmax-1,0)
2778 ! allocate(C_0(0:rmaxC,0:rmaxC,0:rmaxC,0:rmaxC))
2779 ! allocate(Cuv_0(0:rmaxC,0:rmaxC,0:rmaxC,0:rmaxC))
2780 ! allocate(C_i(0:rmaxC,0:rmaxC,0:rmaxC,3))
2781 ! allocate(Cuv_i(0:rmaxC,0:rmaxC,0:rmaxC,3))
2782 ! allocate(Cerr_i(0:rmaxC,0:3))
2783 ! allocate(Cerr2_i(0:rmaxC,0:3))
2784 
2785  ! allocate arrays for error propagation
2786 ! allocate(D00_err(0:rmax))
2787 ! allocate(Dij_err(0:rmax))
2788 ! allocate(Cij_err(0:rmaxC))
2789 
2790 ! allocate(D00_err2(0:rmax))
2791 ! allocate(Dij_err2(0:rmax))
2792 ! allocate(Cij_err2(0:rmaxC))
2793 
2794  ! determine binaries for C-coefficients
2795  k=0
2796  bin = 1
2797  do while (k.le.3)
2798  if (mod(id/bin,2).eq.0) then
2799  nid(k) = id+bin
2800  k = k+1
2801  end if
2802  bin = 2*bin
2803  end do
2804 
2805 
2806  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
2807  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
2808  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
2809  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
2810 
2811 #ifdef Dpv1test
2812  write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,0)
2813  write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,1)
2814  write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,2)
2815  write(*,*) 'CalcDpv1 Cerr_i=',cerr_i(:,3)
2816 #endif
2817 
2818  ! shift of integration momentum in C\{0}
2819  do n1=1,rmaxc
2820  do n2=0,rmaxc-n1
2821  do n3=0,rmaxc-n1-n2
2822  n0 = (rmaxc-n1-n2-n3)
2823  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
2824  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
2825  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
2826  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
2827  end do
2828  end do
2829  end do
2830 
2831 
2832  ! calculate Duv
2833  call calcduv(duv,cuv_0,mm02,f,rmax,id)
2834 
2835  ! initialization of error propagation
2836 
2837  dij_err =0d0
2838  d00_err =0d0
2839  dij_err(0) = derr(0)
2840  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
2841 
2842  dij_err2 =0d0
2843  d00_err2 =0d0
2844  dij_err2(0) = derr2(0)
2845  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
2846 
2847 #ifdef Dpv1test
2848  write(*,*) 'CalcDpv1 Cij_err=',cij_err
2849  write(*,*) 'CalcDpv1 Dij_err(0)=',dij_err(0)
2850  write(*,*) 'CalcDpv1 test :', &
2851  (1d0 - (zadjf(1)+zadjf(2)+zadjf(3))/detz), &
2852  (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
2853  + zadjs(3)*(mm32-mm02) ) /detz
2854 #endif
2855 
2856 ! allocate(D_alt(0:rmax,0:rmax,0:rmax,0:rmax))
2857 
2858  ! PV reduction
2859  do r=1,rmax
2860 
2861  do n0=r/2,1,-1
2862  do n1=0,r-2*n0
2863  do n2=0,r-2*n0-n1
2864  n3 = r-2*n0-n1-n2
2865 
2866  ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
2867 
2868  d(n0,n1,n2,n3) = 4*duv(n0,n1,n2,n3) + detx/detz*d(n0-1,n1,n2,n3)
2869 
2870  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2871  + (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
2872  + zadjs(3)*(mm32-mm02) ) /detz * c_0(n0-1,n1,n2,n3)
2873 ! + (1d0 - (Zadjf(1)+Zadjf(2)+Zadjf(3))/detZ)* C_0(n0-1,n1,n2,n3)
2874 
2875  if (n1.ge.1) then
2876  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2877  - 2*n1*zadjf(1)/detz*d(n0,n1-1,n2,n3)
2878  else
2879  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2880  + zadjf(1)/detz* c_i(n0-1,n2,n3,1)
2881  end if
2882 
2883  if (n2.ge.1) then
2884  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2885  - 2*n2*zadjf(2)/detz*d(n0,n1,n2-1,n3)
2886  else
2887  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2888  + zadjf(2)/detz * c_i(n0-1,n1,n3,2)
2889  end if
2890 
2891  if (n3.ge.1) then
2892  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2893  - 2*n3*zadjf(3)/detz*d(n0,n1,n2,n3-1)
2894  else
2895  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) &
2896  + zadjf(3)/detz * c_i(n0-1,n1,n2,3)
2897  end if
2898 
2899  d(n0,n1,n2,n3) = d(n0,n1,n2,n3) / (2*(r-1))
2900 
2901  end do
2902  end do
2903  end do
2904 
2905  ! reduction formula (5.11) with (5.10) inserted for n0 = 0
2906 ! do n0=(r-1)/2,0,-1
2907  n0=0
2908  do n1=0,r-2*n0
2909  do n2=0,r-2*n0-n1
2910  n3 = r-2*n0-n1-n2
2911 
2912  if (n1.ge.1) then
2913  nn1 = n1-1
2914  nn2 = n2
2915  nn3 = n3
2916  j = 1
2917  else if (n2.ge.1) then
2918  nn1 = n1
2919  nn2 = n2-1
2920  nn3 = n3
2921  j = 2
2922  else
2923  nn1 = n1
2924  nn2 = n2
2925  nn3 = n3-1
2926  j = 3
2927  end if
2928 
2929 ! do i=1,3
2930 ! Smod(i) = -C_0(n0,nn1,nn2,nn3)
2931 ! end do
2932  smod = 0d0
2933 
2934  if (nn1.ge.1) then
2935  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
2936  else
2937  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
2938  end if
2939 
2940  if (nn2.ge.1) then
2941  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
2942  else
2943  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
2944  end if
2945 
2946  if (nn3.ge.1) then
2947  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
2948  else
2949  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
2950  end if
2951 
2952  d(n0,n1,n2,n3) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
2953  + zadj(3,j)*smod(3) &
2954  - zadjs(j)*c_0(n0,nn1,nn2,nn3) &
2955  - zadjf(j)*d(n0,nn1,nn2,nn3))/detz
2956 
2957  end do
2958  end do
2959 ! end do
2960 
2961  ! determine error from symmetry for n0=0 and n1>1, n2>1
2962  derr(r)=derr(r-1)
2963  derr2(r)=derr2(r-1)
2964 
2965 ! write(*,*) 'CalcDpv1: Derr(r)',r,Derr(r),Derr2(r)
2966 
2967  n0=0
2968  do n1=0,r-2*n0
2969  do n2=0,r-2*n0-n1
2970  n3 = r-2*n0-n1-n2
2971  if (n1.ge.1.and.n2+n3.ge.1) then
2972 
2973  if (n2.ge.1) then
2974  nn1 = n1
2975  nn2 = n2-1
2976  nn3 = n3
2977  j = 2
2978  else
2979  nn1 = n1
2980  nn2 = n2
2981  nn3 = n3-1
2982  j = 3
2983  end if
2984 
2985 ! do i=1,3
2986 ! Smod(i) = -C_0(n0,nn1,nn2,nn3)
2987 ! end do
2988  smod = 0d0
2989 
2990  if (nn1.ge.1) then
2991  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
2992  else
2993  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
2994  end if
2995 
2996  if (nn2.ge.1) then
2997  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
2998  else
2999  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
3000  end if
3001 
3002  if (nn3.ge.1) then
3003  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
3004  else
3005  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
3006  end if
3007 
3008  d_alt(n0,n1,n2,n3) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
3009  + zadj(3,j)*smod(3) &
3010  - zadjs(j)*c_0(n0,nn1,nn2,nn3) &
3011  - zadjf(j)*d(n0,nn1,nn2,nn3))/detz
3012 
3013  derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3014  derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3015 
3016 #ifdef Dpv1test
3017 ! write(*,*) 'CalcDpv1: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
3018 ! D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
3019 #endif
3020 
3021 
3022  end if
3023  end do
3024  end do
3025 
3026  if(r.ge.2)then
3027 
3028 ! estimate using insertions of (5.11) in (5.10)
3029  d00_err(r) = max(2*abs(m02)*dij_err(r-2), cerr_i(r-2,0), &
3030  azadjff/adetz*dij_err(r-2), &
3031  maxzadjf/adetz*max(2*d00_err(r-1),cij_err(r-2)))/(2*(r-1))
3032  else
3033  d00_err(r) = 0d0
3034  end if
3035  dij_err(r) = max(maxzadjf*dij_err(r-1), &
3036  maxzadj*max(2*d00_err(r),cij_err(r-1)))/adetz
3037 
3038  if(r.ge.2)then
3039 ! estimate using insertions of (5.11) in (5.10)
3040  d00_err2(r) = max(2*abs(m02)*dij_err2(r-2), cerr2_i(r-2,0), &
3041  azadjff/adetz*dij_err2(r-2), &
3042  maxzadjf/adetz*max(2*d00_err2(r-1),cij_err2(r-2)))/(2*(r-1))
3043  else
3044  d00_err2(r) = 0d0
3045  end if
3046  dij_err2(r) = max(maxzadjf*dij_err2(r-1), &
3047  maxzadj*max(2*d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
3048 
3049 #ifdef Dpv1test
3050  write(*,*) 'Dij_err(r)', r,dij_err(r),d00_err(r)
3051  write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
3052  write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
3053  write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
3054  write(*,*) 'factors',maxzadj/adetz,maxzadjf/adetz
3055  write(*,*) 'Dij_err2(r)', r,dij_err2(r),d00_err2(r)
3056  write(*,*) 'Dij_err2_jj',maxzadjf*dij_err/sqrt(adetz*maxz*maxzadj)
3057  write(*,*) 'Dij_err2_00',maxzadj*d00_err(1:rmax)/sqrt(adetz*maxz*maxzadj)
3058  write(*,*) 'Dij_err2_cc',maxzadj*cij_err/sqrt(adetz*maxz*maxzadj)
3059  write(*,*) 'factors2',maxzadj/sqrt(adetz*maxz*maxzadj),maxzadjf/sqrt(adetz*maxz*maxzadj)
3060 #endif
3061 
3062  end do
3063 
3064  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
3065 ! do r=rmax+1,2*rmax
3066  do r=rmax+1,rmax+1
3067  do n0=r-rmax,r/2
3068  do n1=0,r-2*n0
3069  do n2=0,r-2*n0-n1
3070  n3 = r-2*n0-n1-n2
3071 
3072  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
3073  + 4*duv(n0,n1,n2,n3) &
3074  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
3075  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
3076  end do
3077  end do
3078  end do
3079  end do
3080 
3081 #ifdef Dpv1test
3082  write(*,*) 'CalcDpv1 Derrsym',derr
3083  write(*,*) 'CalcDpv1 Daccsym',derr/abs(d(0,0,0,0))
3084 
3085  write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
3086  write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
3087  write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
3088  write(*,*) 'CalcDpv1 Dijerr',dij_err(1:rmax)
3089  write(*,*) 'CalcDpv1 Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
3090 
3091  write(*,*) 'CalcDpv1 Derr2sym',derr2
3092  write(*,*) 'CalcDpv1 Dacc2sym',derr2/abs(d(0,0,0,0))
3093 
3094  write(*,*) 'Dij_err2_jj',maxzadjf*dij_err2/sqrt(adetz*maxz*maxzadj)
3095  write(*,*) 'Dij_err2_00',maxzadj*d00_err2(1:rmax)/sqrt(adetz*maxz*maxzadj)
3096  write(*,*) 'Dij_err2_cc',maxzadj*cij_err2/sqrt(adetz*maxz*maxzadj)
3097  write(*,*) 'CalcDpv1 Dijerr2',dij_err2(1:rmax)
3098  write(*,*) 'CalcDpv1 Dijacc2',dij_err2(1:rmax)/abs(d(0,0,0,0))
3099 
3100 #endif
3101 
3102  derr2 = max(derr2,dij_err2(0:rmax))
3103  derr = max(derr,dij_err(0:rmax))
3104 
3105 #ifdef Dpv1test
3106  write(*,*) 'CalcDpv1 D(0,0,0,0) = ',d(0,0,0,0)
3107  if(rmax.ge.3)then
3108  write(*,*) 'CalcDpv1 D(0,1,1,1) = ',d(0,1,1,1)
3109  endif
3110 
3111  write(*,*) 'CalcDpv1 Derr',derr
3112  write(*,*) 'CalcDpv1 Dacc',derr/abs(d(0,0,0,0))
3113  write(*,*) 'CalcDpv1 Derr2',derr2
3114  write(*,*) 'CalcDpv1 Dacc2',derr2/abs(d(0,0,0,0))
3115 #endif
3116 
3117 ! if (id.eq.0) then
3118 ! write(*,*) 'CalcDpv1 Derr ',Derr
3119 ! write(*,*) 'CalcDpv1 Derr2',Derr2
3120 ! end if
3121 

◆ calcdpv1o()

subroutine reductiond::calcdpv1o ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 3131 of file reductionD.F90.

3131 
3132  use globald
3133 
3134  integer, intent(in) :: rmax,id
3135  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
3136  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
3137  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
3138  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
3139  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
3140  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
3141  double complex, allocatable :: D_alt(:,:,:,:)
3142  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
3143  double complex :: Smod(3)
3144  double complex :: D0_coli, elimminf2_coli
3145  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
3146  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
3147  integer :: rmaxC,r,n0,n1,n2,n3,nn0,nn1,nn2,nn3,i,j
3148  integer :: bin,k,nid(0:3)
3149 
3150 ! if (id.eq.0) write(*,*) 'CalcDpv1o in', rmax, id
3151 
3152  ! calculation of scalar coefficient
3153  d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
3154  duv(0,0,0,0) = 0d0
3155 
3156  ! accuracy estimate for D0 function
3157  derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3158  derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3159 
3160  if (rmax.eq.0) return
3161 
3162  ! allocation of C functions
3163  rmaxc = rmax-1
3164  ! rmaxC = max(rmax-1,0)
3165  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3166  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3167  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3168  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3169  allocate(cerr_i(0:rmaxc,0:3))
3170  allocate(cerr2_i(0:rmaxc,0:3))
3171 
3172  ! allocate arrays for error propagation
3173  allocate(d00_err(0:rmax))
3174  allocate(dij_err(0:rmax))
3175  allocate(cij_err(0:rmaxc))
3176 
3177  allocate(d00_err2(0:rmax))
3178  allocate(dij_err2(0:rmax))
3179  allocate(cij_err2(0:rmaxc))
3180 
3181  ! determine binaries for C-coefficients
3182  k=0
3183  bin = 1
3184  do while (k.le.3)
3185  if (mod(id/bin,2).eq.0) then
3186  nid(k) = id+bin
3187  k = k+1
3188  end if
3189  bin = 2*bin
3190  end do
3191 
3192 
3193  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
3194  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
3195  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
3196  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
3197 
3198 #ifdef Dpv1otest
3199  write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,0)
3200  write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,1)
3201  write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,2)
3202  write(*,*) 'CalcDpv1o Cerr_i=',cerr_i(:,3)
3203 #endif
3204 
3205  ! shift of integration momentum in C\{0}
3206  do n1=1,rmaxc
3207  do n2=0,rmaxc-n1
3208  do n3=0,rmaxc-n1-n2
3209  n0 = (rmaxc-n1-n2-n3)
3210  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
3211  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
3212  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
3213  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
3214  end do
3215  end do
3216  end do
3217 
3218 
3219  ! determine inverse Gram matrix
3220 ! mm02 = elimminf2_coli(m02)
3221 ! mm12 = elimminf2_coli(m12)
3222 ! mm22 = elimminf2_coli(m22)
3223 ! mm32 = elimminf2_coli(m32)
3224 ! q10 = elimminf2_coli(p10)
3225 ! q21 = elimminf2_coli(p21)
3226 ! q32 = elimminf2_coli(p32)
3227 ! q30 = elimminf2_coli(p30)
3228 ! q31 = elimminf2_coli(p31)
3229 ! q20 = elimminf2_coli(p20)
3230 
3231 
3232 ! q1q2 = (q10+q20-q21)
3233 ! q1q3 = (q10+q30-q31)
3234 ! q2q3 = (q20+q30-q32)
3235 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
3236 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
3237 
3238 ! Zinv(1,1) = (4d0*q30*q20-q2q3*q2q3)/detZ
3239 ! Zinv(2,1) = (q1q3*q2q3-2d0*q30*q1q2)/detZ
3240 ! Zinv(3,1) = (q1q2*q2q3-2d0*q20*q1q3)/detZ
3241 ! Zinv(1,2) = Zinv(2,1)
3242 ! Zinv(2,2) = (4d0*q10*q30-q1q3*q1q3)/detZ
3243 ! Zinv(3,2) = (q1q2*q1q3-2d0*q10*q2q3)/detZ
3244 ! Zinv(1,3) = Zinv(3,1)
3245 ! Zinv(2,3) = Zinv(3,2)
3246 ! Zinv(3,3) = (4d0*q10*q20-q1q2*q1q2)/detZ
3247 !
3248 ! f(1) = q10+mm02-mm12
3249 ! f(2) = q20+mm02-mm22
3250 ! f(3) = q30+mm02-mm32
3251 
3252 ! commented out 2.9.17
3253 ! Zinv = Zadj/detZ
3254 
3255  ! calculate Duv
3256  call calcduv(duv,cuv_0,mm02,f,rmax,id)
3257 
3258  ! initialization of error propagation
3259 ! Zadj=Zinv*detZ
3260 
3261 ! maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(3,1)), &
3262 ! abs(Zadj(2,2)),abs(Zadj(3,2)),abs(Zadj(3,3)))
3263 
3264 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
3265 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
3266 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
3267 ! maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)),abs(Zadjf(3)))
3268 !
3269 ! aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2)+Zadjf(3)*f(3))
3270 
3271 ! adetZ = abs(detZ)
3272 ! adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2)-Zadjf(3)*f(3))
3273 
3274  dij_err =0d0
3275  d00_err =0d0
3276  dij_err(0) = derr(0)
3277  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
3278 
3279  dij_err2 =0d0
3280  d00_err2 =0d0
3281  dij_err2(0) = derr2(0)
3282  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
3283 
3284 #ifdef Dpv1otest
3285  write(*,*) 'CalcDpv1o Cij_err=',cij_err
3286  write(*,*) 'CalcDpv1o Dij_err(0)=',dij_err(0)
3287 #endif
3288 
3289  allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
3290 
3291  ! PV reduction
3292  do r=1,rmax
3293 
3294  do n0=r/2,1,-1
3295  do n1=0,r-2*n0
3296  do n2=0,r-2*n0-n1
3297  n3 = r-2*n0-n1-n2
3298 
3299  ! reduction formula (5.10) for D(r/2,0,0,0)
3300  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) + 4*duv(n0,n1,n2,n3) &
3301  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
3302  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
3303 
3304  end do
3305  end do
3306  end do
3307 
3308 
3309 ! do n0=(r-1)/2,0,-1
3310  n0=0
3311  do n1=0,r-2*n0
3312  do n2=0,r-2*n0-n1
3313  n3 = r-2*n0-n1-n2
3314 
3315  if (n1.ge.1) then
3316  nn1 = n1-1
3317  nn2 = n2
3318  nn3 = n3
3319  j = 1
3320  else if (n2.ge.1) then
3321  nn1 = n1
3322  nn2 = n2-1
3323  nn3 = n3
3324  j = 2
3325  else
3326  nn1 = n1
3327  nn2 = n2
3328  nn3 = n3-1
3329  j = 3
3330  end if
3331 
3332  do i=1,3
3333  smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
3334  end do
3335 
3336  if (nn1.ge.1) then
3337  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
3338  else
3339  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
3340  end if
3341 
3342  if (nn2.ge.1) then
3343  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
3344  else
3345  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
3346  end if
3347 
3348  if (nn3.ge.1) then
3349  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
3350  else
3351  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
3352  end if
3353 
3354  d(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2) &
3355  + zinv(3,j)*smod(3)
3356 
3357  end do
3358  end do
3359 ! end do
3360 
3361  ! determine error from symmetry for n0=0 and n1>1, n2>1
3362  derr(r)=derr(r-1)
3363  derr2(r)=derr2(r-1)
3364  n0=0
3365  do n1=0,r-2*n0
3366  do n2=0,r-2*n0-n1
3367  n3 = r-2*n0-n1-n2
3368  if (n1.ge.1.and.n2+n3.ge.1) then
3369 
3370  if (n2.ge.1) then
3371  nn1 = n1
3372  nn2 = n2-1
3373  nn3 = n3
3374  j = 2
3375  else
3376  nn1 = n1
3377  nn2 = n2
3378  nn3 = n3-1
3379  j = 3
3380  end if
3381 
3382  do i=1,3
3383  smod(i) = -c_0(n0,nn1,nn2,nn3)-f(i)*d(n0,nn1,nn2,nn3)
3384  end do
3385 
3386  if (nn1.ge.1) then
3387  smod(1) = smod(1) - 2*nn1*d(n0+1,nn1-1,nn2,nn3)
3388  else
3389  smod(1) = smod(1) + c_i(n0,nn2,nn3,1)
3390  end if
3391 
3392  if (nn2.ge.1) then
3393  smod(2) = smod(2) - 2*nn2*d(n0+1,nn1,nn2-1,nn3)
3394  else
3395  smod(2) = smod(2) + c_i(n0,nn1,nn3,2)
3396  end if
3397 
3398  if (nn3.ge.1) then
3399  smod(3) = smod(3) - 2*nn3*d(n0+1,nn1,nn2,nn3-1)
3400  else
3401  smod(3) = smod(3) + c_i(n0,nn1,nn2,3)
3402  end if
3403 
3404  d_alt(n0,n1,n2,n3) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2) &
3405  + zinv(3,j)*smod(3)
3406 
3407  derr(r)=max(derr(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3408  derr2(r)=max(derr2(r),abs(d(n0,n1,n2,n3)-d_alt(n0,n1,n2,n3)))
3409 
3410 #ifdef Dpv1otest
3411 ! write(*,*) 'CalcDpv: errpr',r,Derr(r),abs(D(n0,n1,n2,n3)-D_alt(n0,n1,n2,n3)), &
3412 ! D(n0,n1,n2,n3),D_alt(n0,n1,n2,n3),n0,n1,n2,n3
3413 #endif
3414 
3415 
3416  end if
3417  end do
3418  end do
3419 
3420  if(r.ge.2)then
3421 ! 09.02.2016
3422 ! old estimate using insertions of (5.11) in (5.10)
3423  d00_err(r) = max(2*abs(m02)*dij_err(r-2), cerr_i(r-2,0), &
3424  azadjff/adetz*dij_err(r-2), &
3425  maxzadjf/adetz*max(2*d00_err(r-1),cij_err(r-2)))/(2*(r-1))
3426 ! new estimate
3427 ! D00_err(r) = max(2*abs(m02)*Dij_err(r-2), Cerr_i(r-2,0), &
3428 ! fmax*Dij_err(r-1) )/(2*(r-1))
3429  else
3430  d00_err(r) = 0d0
3431  end if
3432  dij_err(r) = max(maxzadjf*dij_err(r-1), &
3433  maxzadj*max(2*d00_err(r),cij_err(r-1)))/adetz
3434 
3435  if(r.ge.2)then
3436 ! old estimate using insertions of (5.11) in (5.10)
3437  d00_err2(r) = max(2*abs(m02)*dij_err2(r-2), cerr2_i(r-2,0), &
3438  azadjff/adetz*dij_err2(r-2), &
3439  maxzadjf/adetz*max(2*d00_err2(r-1),cij_err2(r-2)))/(2*(r-1))
3440 ! new estimate
3441 ! D00_err2(r) = max(2*abs(m02)*Dij_err2(r-2), Cerr2_i(r-2,0), &
3442 ! fmax*Dij_err2(r-1) )/(2*(r-1))
3443  else
3444  d00_err2(r) = 0d0
3445  end if
3446  dij_err2(r) = max(maxzadjf*dij_err2(r-1), &
3447  maxzadj*max(2*d00_err2(r),cij_err2(r-1)))/sqrt(adetz*maxz*maxzadj)
3448 
3449 #ifdef Dpv1otest
3450  write(*,*) 'Dij_err(r)', r,dij_err(r),d00_err(r)
3451  write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
3452  write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
3453  write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
3454  write(*,*) 'factors',maxzadj/adetz,maxzadjf/adetz
3455  write(*,*) 'Dij_err2(r)', r,dij_err2(r),d00_err2(r)
3456  write(*,*) 'Dij_err2_jj',maxzadjf*dij_err/sqrt(adetz*maxz*maxzadj)
3457  write(*,*) 'Dij_err2_00',maxzadj*d00_err(1:rmax)/sqrt(adetz*maxz*maxzadj)
3458  write(*,*) 'Dij_err2_cc',maxzadj*cij_err/sqrt(adetz*maxz*maxzadj)
3459  write(*,*) 'factors2',maxzadj/sqrt(adetz*maxz*maxzadj),maxzadjf/sqrt(adetz*maxz*maxzadj)
3460 #endif
3461 
3462  end do
3463 
3464  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
3465 ! do r=rmax+1,2*rmax
3466  do r=rmax+1,rmax+1
3467  do n0=r-rmax,r/2
3468  do n1=0,r-2*n0
3469  do n2=0,r-2*n0-n1
3470  n3 = r-2*n0-n1-n2
3471 
3472  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
3473  + 4*duv(n0,n1,n2,n3) &
3474  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
3475  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
3476  end do
3477  end do
3478  end do
3479  end do
3480 
3481 #ifdef Dpv1otest
3482  write(*,*) 'CalcDpv1o Derrsym',derr
3483  write(*,*) 'CalcDpv1o Daccsym',derr/abs(d(0,0,0,0))
3484 
3485  write(*,*) 'Dij_err_jj',maxzadjf*dij_err/adetz
3486  write(*,*) 'Dij_err_00',maxzadj*d00_err(1:rmax)/adetz
3487  write(*,*) 'Dij_err_cc',maxzadj*cij_err/adetz
3488  write(*,*) 'CalcDpv1o Dijerr',dij_err(1:rmax)
3489  write(*,*) 'CalcDpv1o Dijacc',dij_err(1:rmax)/abs(d(0,0,0,0))
3490 
3491  write(*,*) 'CalcDpv1o Derr2sym',derr2
3492  write(*,*) 'CalcDpv1o Dacc2sym',derr2/abs(d(0,0,0,0))
3493 
3494  write(*,*) 'Dij_err2_jj',maxzadjf*dij_err2/sqrt(adetz*maxz*maxzadj)
3495  write(*,*) 'Dij_err2_00',maxzadj*d00_err2(1:rmax)/sqrt(adetz*maxz*maxzadj)
3496  write(*,*) 'Dij_err2_cc',maxzadj*cij_err2/sqrt(adetz*maxz*maxzadj)
3497  write(*,*) 'CalcDpv1o Dijerr2',dij_err2(1:rmax)
3498  write(*,*) 'CalcDpv1o Dijacc2',dij_err2(1:rmax)/abs(d(0,0,0,0))
3499 
3500 #endif
3501 
3502  derr2 = max(derr2,dij_err2(0:rmax))
3503  derr = max(derr,dij_err(0:rmax))
3504 
3505 #ifdef Dpv1otest
3506  write(*,*) 'CalcDpv1o D(0,0,0,0) = ',d(0,0,0,0)
3507  if(rmax.ge.3)then
3508  write(*,*) 'CalcDpv1o D(0,1,1,1) = ',d(0,1,1,1)
3509  endif
3510 
3511  write(*,*) 'CalcDpv1o Derr',derr
3512  write(*,*) 'CalcDpv1o Dacc',derr/abs(d(0,0,0,0))
3513  write(*,*) 'CalcDpv1o Derr2',derr2
3514  write(*,*) 'CalcDpv1o Dacc2',derr2/abs(d(0,0,0,0))
3515 #endif
3516 
3517 ! if (id.eq.0) then
3518 ! write(*,*) 'CalcDpv1o Derr ',Derr
3519 ! write(*,*) 'CalcDpv1o Derr2',Derr2
3520 ! end if
3521 

◆ calcdpv2()

subroutine reductiond::calcdpv2 ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 3887 of file reductionD.F90.

3887 
3888  use globald
3889 
3890  integer, intent(in) :: rmax,id
3891  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
3892  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
3893  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
3894  double precision, intent(out) :: Derr(0:rmax),Derr2(0:rmax)
3895  double complex, allocatable :: C_0(:,:,:,:), Cuv_0(:,:,:,:)
3896  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
3897  double complex, allocatable :: D_alt(:,:,:,:)
3898  double precision, allocatable :: Cerr_i(:,:),Cerr2_i(:,:)
3899  double complex :: D0_coli, elimminf2_coli
3900  double complex :: Daux(1:rmax/2+1,0:rmax-1,0:rmax-1,0:rmax-1), Smod(3)
3901  double precision, allocatable :: D00_err(:),Dij_err(:),Cij_err(:)
3902  double precision, allocatable :: D00_err2(:),Dij_err2(:),Cij_err2(:)
3903  integer :: rmaxC,r,n0,n1,n2,n3,k
3904  integer :: bin,nid(0:3)
3905 
3906 #ifdef Dpv2test
3907  write(*,*) 'CalcDpv2 in'
3908 #endif
3909 ! write(*,*) 'CalcDpv2 in', rmax, id
3910 
3911  ! calculation of scalar coefficient
3912  d(0,0,0,0) = d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)
3913  duv(0,0,0,0) = 0d0
3914 
3915  ! accuracy estimate for D0 function
3916  derr(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3917  derr2(0) = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
3918 
3919  if (rmax.eq.0) return
3920 
3921  ! allocation of C functions
3922  rmaxc = rmax-1
3923  ! rmaxC = max(rmax-1,0)
3924  allocate(c_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3925  allocate(cuv_0(0:rmaxc,0:rmaxc,0:rmaxc,0:rmaxc))
3926  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3927  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,3))
3928  allocate(cerr_i(0:rmaxc,0:3))
3929  allocate(cerr2_i(0:rmaxc,0:3))
3930 
3931  ! allocate arrays for error propagation
3932  allocate(d00_err(0:rmax+1))
3933  allocate(dij_err(0:rmax))
3934  allocate(cij_err(0:rmaxc))
3935 
3936  allocate(d00_err2(0:rmax+1))
3937  allocate(dij_err2(0:rmax))
3938  allocate(cij_err2(0:rmaxc))
3939 
3940 
3941  ! determine binaries for C-coefficients
3942  k=0
3943  bin = 1
3944  do while (k.le.3)
3945  if (mod(id/bin,2).eq.0) then
3946  nid(k) = id+bin
3947  k = k+1
3948  end if
3949  bin = 2*bin
3950  end do
3951 
3952  call calcc(c_0(:,0,:,:),cuv_0(:,0,:,:),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(:,0),cerr2_i(:,0))
3953  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(:,1),cerr2_i(:,1))
3954  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(:,2),cerr2_i(:,2))
3955  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(:,3),cerr2_i(:,3))
3956 
3957  ! shift of integration momentum in C\{0}
3958  do n1=1,rmaxc
3959  do n2=0,rmaxc-n1
3960  do n3=0,rmaxc-n1-n2
3961  n0 = (rmaxc-n1-n2-n3)
3962  c_0(0:n0,n1,n2,n3) = -c_0(0:n0,n1-1,n2,n3) &
3963  -c_0(0:n0,n1-1,n2+1,n3)-c_0(0:n0,n1-1,n2,n3+1)
3964  cuv_0(0:n0,n1,n2,n3) = -cuv_0(0:n0,n1-1,n2,n3) &
3965  -cuv_0(0:n0,n1-1,n2+1,n3)-cuv_0(0:n0,n1-1,n2,n3+1)
3966  end do
3967  end do
3968  end do
3969 
3970 
3971  ! determine inverse modified Cayley matrix
3972 ! mm02 = elimminf2_coli(m02)
3973 ! mm12 = elimminf2_coli(m12)
3974 ! mm22 = elimminf2_coli(m22)
3975 ! mm32 = elimminf2_coli(m32)
3976 ! q10 = elimminf2_coli(p10)
3977 ! q21 = elimminf2_coli(p21)
3978 ! q32 = elimminf2_coli(p32)
3979 ! q30 = elimminf2_coli(p30)
3980 ! q31 = elimminf2_coli(p31)
3981 ! q20 = elimminf2_coli(p20)
3982 
3983  ! calculate Duv
3984  call calcduv(duv,cuv_0,mm02,mx(1:3,0),rmax,id)
3985 
3986  ! initialization of error propagation
3987 
3988 ! adetX = abs(chdet(4,mx))
3989 ! maxZadjf=maxval(abs(mxinv(0,1:3)))*adetX
3990 ! maxXadj=maxval(abs(mxinv(1:3,1:3)))*adetX
3991 ! adetZ=abs(mxinv(0,0))*adetX
3992 
3993 ! write(*,*) 'CalcDpv adetX ',adetX,maxZadjf,maxXadj,adetZ
3994 
3995  dij_err =0d0
3996  d00_err =0d0
3997  dij_err(0) = derr(0)
3998  cij_err = max(cerr_i(:,0),cerr_i(:,1),cerr_i(:,2),cerr_i(:,3))
3999 
4000  dij_err2 =0d0
4001  d00_err2 =0d0
4002  dij_err2(0) = derr2(0)
4003  cij_err2 = max(cerr2_i(:,0),cerr2_i(:,1),cerr2_i(:,2),cerr2_i(:,3))
4004 
4005 ! write(*,*) 'CalcDpv2 Cerr _i0=',Cerr_i(:,0)
4006 ! write(*,*) 'CalcDpv2 Cerr2_i0=',Cerr2_i(:,0)
4007 ! write(*,*) 'CalcDpv2 Cerr _i1=',Cerr_i(:,1)
4008 ! write(*,*) 'CalcDpv2 Cerr2_i1=',Cerr2_i(:,1)
4009 ! write(*,*) 'CalcDpv2 Cerr _i2=',Cerr_i(:,2)
4010 ! write(*,*) 'CalcDpv2 Cerr2_i2=',Cerr2_i(:,2)
4011 ! write(*,*) 'CalcDpv2 Cerr _i3=',Cerr_i(:,3)
4012 ! write(*,*) 'CalcDpv2 Cerr2_i3=',Cerr2_i(:,3)
4013 ! write(*,*) 'CalcDpv2 Cij_err=',Cij_err
4014 ! write(*,*) 'CalcDpv2 Cij_err2=',Cij_err2
4015 #ifdef Dpv2test
4016  write(*,*) 'CalcDpv2 Dij_err(0)=',dij_err(0)
4017  write(*,*) 'CalcDpv2 Dij_acc(0)=',dij_err(0)/d(0,0,0,0)
4018  write(*,*) 'CalcDpv2 Cij_err=',cij_err
4019 #endif
4020 
4021  allocate(d_alt(0:rmax,0:rmax,0:rmax,0:rmax))
4022 
4023  ! alternative PV-like reduction
4024  do r=1,rmax
4025 
4026  do n0=2,r/2
4027  do n1=0,r-2*n0
4028  do n2=0,r-2*n0-n1
4029  n3 = r-2*n0-n1-n2
4030 
4031  do k=1,3
4032  smod(k) = -c_0(n0-1,n1,n2,n3)
4033  end do
4034 
4035  if (n1.ge.1) then
4036  smod(1) = smod(1) - 2*n1*d(n0,n1-1,n2,n3)
4037  else
4038  smod(1) = smod(1) + c_i(n0-1,n2,n3,1)
4039  end if
4040 
4041  if (n2.ge.1) then
4042  smod(2) = smod(2) - 2*n2*d(n0,n1,n2-1,n3)
4043  else
4044  smod(2) = smod(2) + c_i(n0-1,n1,n3,2)
4045  end if
4046 
4047  if (n3.ge.1) then
4048  smod(3) = smod(3) - 2*n3*d(n0,n1,n2,n3-1)
4049  else
4050  smod(3) = smod(3) + c_i(n0-1,n1,n2,3)
4051  end if
4052 
4053  daux(n0,n1,n2,n3) = (d(n0-1,n1,n2,n3) - mxinv(1,0)*smod(1) &
4054  - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
4055 
4056  end do
4057  end do
4058  end do
4059 
4060 
4061  do n0=1,r/2
4062  do n1=0,r-2*n0
4063  do n2=0,r-2*n0-n1
4064  n3 = r-2*n0-n1-n2
4065 
4066  d(n0,n1,n2,n3) = (daux(n0,n1,n2,n3) + 4d0*duv(n0,n1,n2,n3) &
4067  + c_0(n0-1,n1,n2,n3))/(r-1)/2d0
4068 
4069  end do
4070  end do
4071  end do
4072 
4073 ! do n1=0,r-1
4074 ! do n2=0,r-1-n1
4075 ! n3 = r-1-n1-n2
4076 !
4077 ! do k=1,3
4078 ! Smod(k) = -C_0(0,n1,n2,n3)
4079 ! end do
4080 !
4081 ! if (n1.ge.1) then
4082 ! Smod(1) = Smod(1) - 2*n1*D(1,n1-1,n2,n3)
4083 ! else
4084 ! Smod(1) = Smod(1) + C_i(0,n2,n3,1)
4085 ! end if
4086 !
4087 ! if (n2.ge.1) then
4088 ! Smod(2) = Smod(2) - 2*n2*D(1,n1,n2-1,n3)
4089 ! else
4090 ! Smod(2) = Smod(2) + C_i(0,n1,n3,2)
4091 ! end if
4092 !
4093 ! if (n3.ge.1) then
4094 ! Smod(3) = Smod(3) - 2*n3*D(1,n1,n2,n3-1)
4095 ! else
4096 ! Smod(3) = Smod(3) + C_i(0,n1,n2,3)
4097 ! end if
4098 !
4099 ! Daux(1,n1,n2,n3) = (D(0,n1,n2,n3) - mxinv(1,0)*Smod(1) &
4100 ! - mxinv(2,0)*Smod(2) - mxinv(3,0)*Smod(3))/mxinv(0,0)
4101 !
4102 ! D(0,n1+1,n2,n3) = mxinv(0,1)*Daux(1,n1,n2,n3) &
4103 ! + mxinv(1,1)*Smod(1) + mxinv(2,1)*Smod(2) + mxinv(3,1)*Smod(3)
4104 ! D(0,n1,n2+1,n3) = mxinv(0,2)*Daux(1,n1,n2,n3) &
4105 ! + mxinv(1,2)*Smod(1) + mxinv(2,2)*Smod(2) + mxinv(3,2)*Smod(3)
4106 ! D(0,n1,n2,n3+1) = mxinv(0,3)*Daux(1,n1,n2,n3) &
4107 ! + mxinv(1,3)*Smod(1) + mxinv(2,3)*Smod(2) + mxinv(3,3)*Smod(3)
4108 !
4109 ! end do
4110 ! end do
4111 
4112  ! calculate D and determine error from symmetry for n0=0 and n1>0, n2>0, n3>0
4113  derr(r)=derr(r-1)
4114  derr2(r)=derr2(r-1)
4115 
4116  do n1=0,r-1
4117  do n2=0,r-1-n1
4118  n3 = r-1-n1-n2
4119 
4120  do k=1,3
4121  smod(k) = -c_0(0,n1,n2,n3)
4122  end do
4123 
4124  if (n1.ge.1) then
4125  smod(1) = smod(1) - 2*n1*d(1,n1-1,n2,n3)
4126  else
4127  smod(1) = smod(1) + c_i(0,n2,n3,1)
4128  end if
4129 
4130  if (n2.ge.1) then
4131  smod(2) = smod(2) - 2*n2*d(1,n1,n2-1,n3)
4132  else
4133  smod(2) = smod(2) + c_i(0,n1,n3,2)
4134  end if
4135 
4136  if (n3.ge.1) then
4137  smod(3) = smod(3) - 2*n3*d(1,n1,n2,n3-1)
4138  else
4139  smod(3) = smod(3) + c_i(0,n1,n2,3)
4140  end if
4141 
4142  daux(1,n1,n2,n3) = (d(0,n1,n2,n3) - mxinv(1,0)*smod(1) &
4143  - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
4144 
4145  d(0,n1+1,n2,n3) = mxinv(0,1)*daux(1,n1,n2,n3) &
4146  + mxinv(1,1)*smod(1) + mxinv(2,1)*smod(2) + mxinv(3,1)*smod(3)
4147  d(0,n1,n2+1,n3) = mxinv(0,2)*daux(1,n1,n2,n3) &
4148  + mxinv(1,2)*smod(1) + mxinv(2,2)*smod(2) + mxinv(3,2)*smod(3)
4149  d_alt(0,n1,n2,n3+1) = mxinv(0,3)*daux(1,n1,n2,n3) &
4150  + mxinv(1,3)*smod(1) + mxinv(2,3)*smod(2) + mxinv(3,3)*smod(3)
4151 
4152  if(n3.eq.r-1) then
4153  d(0,0,0,r) = d_alt(0,0,0,r)
4154  else
4155 ! write(*,*) 'errsym=',abs(D(0,n1,n2,n3+1)-D_alt(0,n1,n2,n3+1)), &
4156 ! D(0,n1,n2,n3+1),D_alt(0,n1,n2,n3+1)
4157 
4158  derr(r)=max(derr(r),abs(d(0,n1,n2,n3+1)-d_alt(0,n1,n2,n3+1)))
4159  derr2(r)=max(derr2(r),abs(d(0,n1,n2,n3+1)-d_alt(0,n1,n2,n3+1)))
4160  end if
4161 
4162 ! write(*,*) 'Da(0,n1,n2,n3)=',n1+1,n2,n3,D(0,n1+1,n2,n3)
4163 ! write(*,*) 'Da(0,n1,n2,n3)=',n1,n2+1,n3,D(0,n1,n2+1,n3)
4164 ! write(*,*) 'Db(0,n1,n2,n3)=',n1,n2,n3+1,D_alt(0,n1,n2,n3+1)
4165 
4166  end do
4167  end do
4168 
4169  d00_err(r+1) = max(cerr_i(r-1,0),adetx/adetz*dij_err(r-1), &
4170  maxzadjf/adetz*max(cij_err(r-1),2*d00_err(r)))/(2*r)
4171  dij_err(r) = max(maxzadjf*max(2*r*d00_err(r+1),cerr_i(r-1,0)), &
4172  maxxadj*max(2*d00_err(r),cij_err(r-1)))/adetx
4173 
4174  d00_err2(r+1) = max(cerr2_i(r-1,0),adetx/adetz*dij_err2(r-1), &
4175  maxzadjf/adetz*max(cij_err2(r-1),2*d00_err2(r)))/(2*r)
4176  dij_err2(r) = max(maxzadjf*max(2*r*d00_err2(r+1),cerr2_i(r-1,0)), &
4177  maxxadj*max(2*d00_err2(r),cij_err2(r-1)))/adetx*sqrt(adetz/(maxz*maxzadj))
4178 
4179 #ifdef Dpv2test
4180  write(*,*) 'CalcDpv2 Cerr_i ',r-1, cerr_i(r-1,0)
4181  write(*,*) 'CalcDpv2 Cij_err ',r-1, cij_err(r-1)
4182  write(*,*) 'CalcDpv2 D00_err ',r+1, d00_err(r+1)
4183  write(*,*) 'CalcDpv2 Dij_err ',r, dij_err(r)
4184  write(*,*) 'CalcDpv2 Cerr2_i ',r-1, cerr2_i(r-1,0)
4185  write(*,*) 'CalcDpv2 Cij_err2',r-1, cij_err2(r-1)
4186  write(*,*) 'CalcDpv2 D00_err2',r+1, d00_err2(r+1)
4187  write(*,*) 'CalcDpv2 Dij_err2',r, dij_err2(r)
4188 #endif
4189 
4190  end do
4191 
4192  ! reduction formula (5.10) for n0+n1+n2+N3=r, n0=1 only!!!!!!
4193 ! do r=rmax+1,2*rmax
4194  do r=rmax+1,rmax+1
4195 
4196 #ifdef Dpv2test
4197 ! pv1 version gets unstable for some cases!
4198  do n0=r-rmax,r/2
4199  do n1=0,r-2*n0
4200  do n2=0,r-2*n0-n1
4201  n3 = r-2*n0-n1-n2
4202 
4203  d(n0,n1,n2,n3) = (c_0(n0-1,n1,n2,n3) + 2*mm02*d(n0-1,n1,n2,n3) &
4204  + 4*duv(n0,n1,n2,n3) &
4205  + f(1)*d(n0-1,n1+1,n2,n3) + f(2)*d(n0-1,n1,n2+1,n3) &
4206  + f(3)*d(n0-1,n1,n2,n3+1)) / (2*(r-1))
4207 
4208 ! write(*,*) 'D1(n0+1)',n0,n1,n2,n3
4209 ! write(*,*) 'D1(n0+1)',(C_0(n0-1,n1,n2,n3) + 2*mm02*D(n0-1,n1,n2,n3) &
4210 ! + 4*Duv(n0,n1,n2,n3) &
4211 ! + f(1)*D(n0-1,n1+1,n2,n3) + f(2)*D(n0-1,n1,n2+1,n3) &
4212 ! + f(3)*D(n0-1,n1,n2,n3+1)) / (2*(r-1))
4213 
4214  end do
4215  end do
4216  end do
4217 #endif
4218 
4219 ! pv2 formulas added 24.01.2016
4220  do n0=max(2,r-rmax),r/2
4221  do n1=0,r-2*n0
4222  do n2=0,r-2*n0-n1
4223  n3 = r-2*n0-n1-n2
4224 
4225  do k=1,3
4226  smod(k) = -c_0(n0-1,n1,n2,n3)
4227  end do
4228 
4229  if (n1.ge.1) then
4230  smod(1) = smod(1) - 2*n1*d(n0,n1-1,n2,n3)
4231  else
4232  smod(1) = smod(1) + c_i(n0-1,n2,n3,1)
4233  end if
4234 
4235  if (n2.ge.1) then
4236  smod(2) = smod(2) - 2*n2*d(n0,n1,n2-1,n3)
4237  else
4238  smod(2) = smod(2) + c_i(n0-1,n1,n3,2)
4239  end if
4240 
4241  if (n3.ge.1) then
4242  smod(3) = smod(3) - 2*n3*d(n0,n1,n2,n3-1)
4243  else
4244  smod(3) = smod(3) + c_i(n0-1,n1,n2,3)
4245  end if
4246 
4247  daux(n0,n1,n2,n3) = (d(n0-1,n1,n2,n3) - mxinv(1,0)*smod(1) &
4248  - mxinv(2,0)*smod(2) - mxinv(3,0)*smod(3))/mxinv(0,0)
4249 
4250  end do
4251  end do
4252  end do
4253 
4254 
4255  do n0=r-rmax,r/2
4256  do n1=0,r-2*n0
4257  do n2=0,r-2*n0-n1
4258  n3 = r-2*n0-n1-n2
4259 
4260  d(n0,n1,n2,n3) = (daux(n0,n1,n2,n3) + 4d0*duv(n0,n1,n2,n3) &
4261  + c_0(n0-1,n1,n2,n3))/(r-1)/2d0
4262 
4263 #ifdef Dpv2test
4264 ! write(*,*) 'D2(n0+1)',n0,n1,n2,n3
4265 ! write(*,*) 'D2(n0+1)',(Daux(n0,n1,n2,n3) + 4d0*Duv(n0,n1,n2,n3) &
4266 ! + C_0(n0-1,n1,n2,n3))/(r-1)/2d0
4267 #endif
4268  end do
4269  end do
4270  end do
4271 
4272  end do
4273 
4274 #ifdef Dpv2test
4275  write(*,*) 'CalcDpv2 Derrsym',derr
4276  write(*,*) 'CalcDpv2 Daccsym',derr/abs(d(0,0,0,0))
4277  write(*,*) 'CalcDpv2 Derr2sym',derr2
4278  write(*,*) 'CalcDpv2 Dacc2sym',derr2/abs(d(0,0,0,0))
4279 
4280  write(*,*) 'CalcDpv2 Dijerr',dij_err
4281  write(*,*) 'CalcDpv2 Dijacc',dij_err/abs(d(0,0,0,0))
4282 #endif
4283 
4284  derr2 = max(derr2,dij_err2(0:rmax))
4285  derr = max(derr,dij_err(0:rmax))
4286 
4287 #ifdef Dpv2test
4288 ! write(*,*) 'CalcDpv2 D(0,0,0,0) = ',D(0,0,0,0)
4289 ! if(rmax.ge.2)then
4290 ! write(*,*) 'CalcDpv2 D(1,0,1,0) = ',D(1,0,1,0)
4291 ! endif
4292 ! if(rmax.ge.3)then
4293 ! write(*,*) 'CalcDpv2 D(0,1,1,1) = ',D(0,1,1,1)
4294 ! endif
4295 
4296  write(*,*) 'CalcDpv2 Derr ',derr
4297  write(*,*) 'CalcDpv2 Dacc ',derr/abs(d(0,0,0,0))
4298  write(*,*) 'CalcDpv2 Derr2',derr2
4299  write(*,*) 'CalcDpv2 Dacc2',derr2/abs(d(0,0,0,0))
4300 #endif
4301 
4302 ! write(*,*) 'CalcDpv2 Derr ',Derr
4303 ! write(*,*) 'CalcDpv2 Derr2',Derr2
4304 

◆ calcdred()

subroutine reductiond::calcdred ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  D,
double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(out)  Duv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p32,
double complex, intent(in)  p30,
double complex, intent(in)  p20,
double complex, intent(in)  p31,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
double complex, intent(in)  m32,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Derr1,
double precision, dimension(0:rmax), intent(out)  Derr2 
)

Definition at line 320 of file reductionD.F90.

320 
321  use globald
322 
323  integer, intent(in) :: rmax,id
324  double complex, intent(in) :: p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
325 ! integer :: scheme_C0(rmax-1:rmax_C),scheme_C1(rmax-1:rmax_C)
326 ! integer :: scheme_C2(rmax-1:rmax_C),scheme_C3(rmax-1,rmax_C)
327  double complex, intent(out) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
328  double complex, intent(out) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
329  double complex :: elimminf2_coli
330  double precision, intent(out) :: Derr1(0:rmax),Derr2(0:rmax)
331  double precision :: D0est,Dtyp
332 #ifdef USED0
333  double complex :: D0_coli
334 #endif
335 ! double complex :: detX
336  double complex :: chdet
337  integer :: rmaxC,r,rid,n0,n1,n2,n3,g,gy,gp,gr,gm,gpf,i,iexp
338  integer :: bin,k,nid(0:3)
339  logical :: use_pv,use_pv2,use_g,use_gy,use_gp,use_gr,use_gm,use_gpf
340 
341  integer :: r_alt,Drmethod(0:rmax),DrCalc(0:rmax),DCalc
342  double complex, allocatable :: C_i(:,:,:,:), Cuv_i(:,:,:,:)
343  double complex :: D_alt(0:rmax,0:rmax,0:rmax,0:rmax)
344  double complex :: Duv_alt(0:rmax,0:rmax,0:rmax,0:rmax)
345  double precision :: Derr(0:rmax),Derr_alt(0:rmax),Derr1_alt(0:rmax),Derr2_alt(0:rmax)
346  integer :: Drmethod_alt(0:rmax)
347 
348  double precision :: err_pv(0:rmax),err_pv2(0:rmax),err_g(0:rmax),err_gy(0:rmax),err_gp(0:rmax)
349  double precision :: err_gr(0:rmax),err_gm(0:rmax),err_gpf(0:rmax)
350  double precision :: h_pv,w_pv,v_pv,z_pv,h_pv2,w_pv2,v_pv2,z_pv2,hw_pv2
351  double precision :: u_g,z_g,err_g_C,err_g_Cr,err_g_exp
352  double precision :: u_gm,z_gm,err_gm_C,err_gm_Cr,err_gm_exp
353  double precision :: v1_gy,b_gy,err_gy_C,err_gy_Cr,err_gy_exp
354  double precision :: v_gp,v1_gp,z_gp,err_gp_C,err_gp_Cr,err_gp_exp
355  double precision :: v1_gpf,b_gpf,err_gpf_C,err_gpf_Cr,err_gpf_exp
356  double precision :: x_gr,y_gr,y1_gr,a_gr,err_gr_C,err_gr_Cr,err_gr_exp
357  double precision :: err_C0,Cerr_i(0:rmax_C,0:3),err_C(0:rmax_C),err_D0,acc_D,errfac(0:3),err_req_D,err_inf,Cerr2_i(0:rmax_C,0:3)
358  double precision :: checkest,norm,Dscale2
359  logical :: lerr_D0,errorwriteflag
360 
361  character(len=*),parameter :: fmt1 = "(A7,'dcmplx(',d25.18,' , ',d25.18,' )')"
362  character(len=*),parameter :: fmt10 = "(A17,'(',d25.18,' , ',d25.18,' )')"
363 
364 #ifdef CritPointsCOLI
365  integer, parameter :: MaxCritPointD=50
366 #else
367  integer, parameter :: MaxCritPointD=0
368 #endif
369  integer, save :: CritPointCntD
370  integer ncount
371 
372  data critpointcntd /0/
373 
374 #ifdef Dredtest
375  write(*,*) 'CalcDred in',rmax,id,acc_req_d
376  write(*,*) 'CalcDred acc_req',acc_req_d,reqacc_coli
377  write(*,*) 'CalcDred in',p10,p21,p32,p30,p20,p31,m02,m12,m22,m32
378 #endif
379 
380  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
381  ! calculate 3-point functions for rank < rmax
382  ! and corresponding accuracy estimates
383  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
384 
385  ! allocation of C functions
386  ! bad estimate of higher C coefficients leads to bad estimates for expansions -> not tried!
387  ! do not involve estimate of C0 in extrapolations!
388  rmaxc = max(rmax-1,3)
389  allocate(c_i(0:rmaxc,0:rmaxc,0:rmaxc,0:3))
390  allocate(cuv_i(0:rmaxc,0:rmaxc,0:rmaxc,0:3))
391 
392  ! determine binaries for C-coefficients
393  k=0
394  bin = 1
395  do while (k.le.3)
396  if (mod(id/bin,2).eq.0) then
397  nid(k) = id+bin
398  k = k+1
399  end if
400  bin = 2*bin
401  end do
402 
403  ! caution: C_i in first call not properly defined!
404  call calcc(c_i(:,:,:,0),cuv_i(:,:,:,0),p21,p32,p31,m12,m22,m32,rmaxc,nid(0),cerr_i(0:rmaxc,0),cerr2_i(0:rmaxc,0))
405  call calcc(c_i(:,:,:,1),cuv_i(:,:,:,1),p20,p32,p30,m02,m22,m32,rmaxc,nid(1),cerr_i(0:rmaxc,1),cerr2_i(0:rmaxc,1))
406  call calcc(c_i(:,:,:,2),cuv_i(:,:,:,2),p10,p31,p30,m02,m12,m32,rmaxc,nid(2),cerr_i(0:rmaxc,2),cerr2_i(0:rmaxc,2))
407  call calcc(c_i(:,:,:,3),cuv_i(:,:,:,3),p10,p21,p20,m02,m12,m22,rmaxc,nid(3),cerr_i(0:rmaxc,3),cerr2_i(0:rmaxc,3))
408 
409 #ifdef Dredtest
410  write(*,*) 'CalcDred Cerr 0 =',cerr_i(0:rmaxc,0)
411  write(*,*) 'CalcDred Cerr 1 =',cerr_i(0:rmaxc,1)
412  write(*,*) 'CalcDred Cerr 2 =',cerr_i(0:rmaxc,2)
413  write(*,*) 'CalcDred Cerr 3 =',cerr_i(0:rmaxc,3)
414  if (abs(c_i(0,0,0,0)).ne.0d0) &
415  write(*,*) 'CalcDred Cacc 0 =',cerr_i(0:rmaxc,0)/abs(c_i(0,0,0,0))
416  if (abs(c_i(0,0,0,1)).ne.0d0) &
417  write(*,*) 'CalcDred Cacc 1 =',cerr_i(0:rmaxc,1)/abs(c_i(0,0,0,1))
418  if (abs(c_i(0,0,0,2)).ne.0d0) &
419  write(*,*) 'CalcDred Cacc 2 =',cerr_i(0:rmaxc,2)/abs(c_i(0,0,0,2))
420  if (abs(c_i(0,0,0,3)).ne.0d0) &
421  write(*,*) 'CalcDred Cacc 3 =',cerr_i(0:rmaxc,3)/abs(c_i(0,0,0,3))
422 #endif
423 
424 ! acc_C(0:rmaxC)=max((Cerr_i(0:rmaxC,0))/abs(C_i(0,0,0,0)), &
425 ! (Cerr_i(0:rmaxC,1))/abs(C_i(0,0,0,1)), &
426 ! (Cerr_i(0:rmaxC,2))/abs(C_i(0,0,0,2)), &
427 ! (Cerr_i(0:rmaxC,3))/abs(C_i(0,0,0,3)))
428 
429 
430  do i=0,3
431 ! changed 01.07.2015 to avoid bad estimates that excluded expansions
432 ! errfac(i)=max(Cerr_i(rmaxC,i)/Cerr_i(rmaxC-1,i),sqrt(Cerr_i(rmaxC,i)/Cerr_i(rmaxC-2,i)))
433  errfac(i) = 1d0
434  do r=rmaxc+1,rmax_c
435  cerr_i(r,i)=cerr_i(r-1,i)*errfac(i)
436  end do
437  end do
438 
439  do r=0,rmax_c
440  err_c(r)=maxval(cerr_i(r,0:3))
441  end do
442 
443  err_c0=err_c(0)
444 
445 #ifdef Dredtest
446  write(*,*) 'CalcDred err_C0:',err_c0
447  write(*,*) 'CalcDred Cerr 0 =',cerr_i(0:rmax_c,0)
448  write(*,*) 'CalcDred Cerr 1 =',cerr_i(0:rmax_c,1)
449  write(*,*) 'CalcDred Cerr 2 =',cerr_i(0:rmax_c,2)
450  write(*,*) 'CalcDred Cerr 3 =',cerr_i(0:rmax_c,3)
451  write(*,*) 'CalcDred Cerr =', err_c(0:rmax_c)
452 #endif
453 
454 
455 
456 
457 
458  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
459  ! choose reduction scheme
460  ! by estimating expected errors
461  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
462 
463  ! eliminate infinitesimal masses
464  mm02 = elimminf2_coli(m02)
465  mm12 = elimminf2_coli(m12)
466  mm22 = elimminf2_coli(m22)
467  mm32 = elimminf2_coli(m32)
468  q10 = elimminf2_coli(p10)
469  q21 = elimminf2_coli(p21)
470  q32 = elimminf2_coli(p32)
471  q30 = elimminf2_coli(p30)
472  q31 = elimminf2_coli(p31)
473  q20 = elimminf2_coli(p20)
474 
475  ! set mass scales
476  q2max = max(abs(q10),abs(q21),abs(q32),abs(q30),abs(q31),abs(q20))
477  m2max = max(abs(mm02),abs(mm12),abs(mm22),abs(mm32))
478  m2scale = max(q2max,m2max)
479 
480  ! Gram and related stuff
481 ! q1q2 = (q10+q20-q21)/2D0
482 ! q1q3 = (q10+q30-q31)/2D0
483 ! q2q3 = (q20+q30-q32)/2D0
484 
485  z(1,1) = 2d0*q10
486  z(2,1) = q10+q20-q21
487  z(3,1) = q10+q30-q31
488  z(1,2) = z(2,1)
489  z(2,2) = 2d0*q20
490  z(3,2) = q20+q30-q32
491  z(1,3) = z(3,1)
492  z(2,3) = z(3,2)
493  z(3,3) = 2d0*q30
494 ! write(*,*) 'Zn ',Z
495 
496  maxz = maxval(abs(z))
497 
498  detz = chdet(3,z)
499  if (detz.ne.0d0) then
500  call chinv(3,z,zinv)
501  zadj = zinv * detz
502  else
503 ! Zadj(1,1) = 4d0*(q30*q20-q2q3*q2q3)
504 ! Zadj(2,1) = 4d0*(q1q3*q2q3-q30*q1q2)
505 ! Zadj(3,1) = 4d0*(q1q2*q2q3-q20*q1q3)
506 ! Zadj(1,2) = Zadj(2,1)
507 ! Zadj(2,2) = 4d0*(q10*q30-q1q3*q1q3)
508 ! Zadj(3,2) = 4d0*(q1q2*q1q3-q10*q2q3)
509 ! Zadj(1,3) = Zadj(3,1)
510 ! Zadj(2,3) = Zadj(3,2)
511 ! Zadj(3,3) = 4d0*(q10*q20-q1q2*q1q2)
512 
513  zadj(1,1) = (z(3,3)*z(2,2)-z(2,3)*z(2,3))
514  zadj(2,1) = (z(1,3)*z(2,3)-z(3,3)*z(1,2))
515  zadj(3,1) = (z(1,2)*z(2,3)-z(2,2)*z(1,3))
516  zadj(1,2) = zadj(2,1)
517  zadj(2,2) = (z(1,1)*z(3,3)-z(1,3)*z(1,3))
518  zadj(3,2) = (z(1,2)*z(1,3)-z(1,1)*z(2,3))
519  zadj(1,3) = zadj(3,1)
520  zadj(2,3) = zadj(3,2)
521  zadj(3,3) = (z(1,1)*z(2,2)-z(1,2)*z(1,2))
522  endif
523 ! write(*,*) 'Zadjn ',Zadj
524 ! write(*,*) 'detZn ',detZ
525 
526 #ifdef Dredtest
527  zadjs(1) = q20*(q31+q32-q21) + q31*(q32-q30) &
528  + q30*(q32+q21) - q32*(q32+2d0*q10-q21)
529  write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)+zadj(1,3)
530  zadjs(3) = q20*(q21+q31-q32) + (q31-q21)*(q21-q10) &
531  - 2d0*q30*q21 + q32*(q10+q21)
532  write(*,*) 'Zadjs(3) ',zadjs(3), zadj(3,1)+zadj(3,2)+zadj(3,3)
533 #endif
534 
535  zadjs(1) = q32*(-2d0*q10 + q20+q30+q31+q21 - q32) &
536  + (q21-q31)*(q30-q20)
537  zadjs(2) = q31*(-2d0*q20 + q10+q30+q32+q21 - q31) &
538  + (q21-q32)*(q30-q10)
539  zadjs(3) = q21*(-2d0*q30 + q10+q20+q32+q31 - q21) &
540  + (q31-q32)*(q20-q10)
541 
542 #ifdef Dredtest
543  write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)+zadj(1,3)
544  write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)+zadj(2,3)
545  write(*,*) 'Zadjs(3) ',zadjs(3), zadj(3,1)+zadj(3,2)+zadj(3,3)
546 #endif
547 
548  detzmzadjf = -2*q21*q31*q32 + q30*q21*(-q21 + q31 + q32) &
549  + q20*q31*(q21 - q31 + q32) + q10*q32*(q21 + q31 - q32)
550 
551  adetz = abs(detz)
552  maxzadj = max(abs(zadj(1,1)),abs(zadj(2,1)),abs(zadj(3,1)), &
553  abs(zadj(2,2)),abs(zadj(3,2)),abs(zadj(3,3)))
554 
555  f(1) = q10+mm02-mm12
556  f(2) = q20+mm02-mm22
557  f(3) = q30+mm02-mm32
558  fmax = max(abs(f(1)),abs(f(2)),abs(f(3)))
559 
560  mx(0,0) = 2d0*mm02
561  mx(1,0) = q10 - mm12 + mm02
562  mx(2,0) = q20 - mm22 + mm02
563  mx(3,0) = q30 - mm32 + mm02
564  mx(0,1) = mx(1,0)
565  mx(0,2) = mx(2,0)
566  mx(0,3) = mx(3,0)
567  mx(1:3,1:3) = z(1:3,1:3)
568 
569  detx = chdet(4,mx)
570 
571  if (detx.ne.0d0.and.maxz.ne.0d0) then
572  call chinv(4,mx,mxinv)
573  xadj = mxinv * detx
574 
575  zadjf(1:3) = -xadj(0,1:3)
576 
577  zadj2ff(1:3,1:3) = xadj(1:3,1:3) - 2d0*mm02*zadj(1:3,1:3)
578  else
579  zadjf(1) = zadj(1,1)*f(1)+zadj(2,1)*f(2)+zadj(3,1)*f(3)
580  zadjf(2) = zadj(1,2)*f(1)+zadj(2,2)*f(2)+zadj(3,2)*f(3)
581  zadjf(3) = zadj(1,3)*f(1)+zadj(2,3)*f(2)+zadj(3,3)*f(3)
582 
583  zadj2ff(1,1) = -f(2)*f(2)*z(3,3) - f(3)*f(3)*z(2,2) &
584  + 2*f(2)*f(3)*z(3,2)
585  zadj2ff(2,1) = f(2)*f(1)*z(3,3) - f(3)*f(1)*z(2,3) &
586  - f(2)*f(3)*z(1,3) + f(3)*f(3)*z(1,2)
587  zadj2ff(3,1) = -f(2)*f(1)*z(3,2) + f(3)*f(1)*z(2,2) &
588  + f(2)*f(2)*z(3,1) - f(3)*f(2)*z(2,1)
589  zadj2ff(1,2) = zadj2ff(2,1)
590  zadj2ff(2,2) = -f(1)*f(1)*z(3,3) - f(3)*f(3)*z(1,1) &
591  + 2*f(1)*f(3)*z(1,3)
592  zadj2ff(3,2) = f(1)*f(1)*z(2,3) - f(1)*f(2)*z(1,3) &
593  - f(3)*f(1)*z(2,1) + f(3)*f(2)*z(1,1)
594  zadj2ff(1,3) = zadj2ff(3,1)
595  zadj2ff(2,3) = zadj2ff(3,2)
596  zadj2ff(3,3) = -f(1)*f(1)*z(2,2) - f(2)*f(2)*z(1,1) &
597  + 2*f(1)*f(2)*z(2,1)
598 
599  xadj(1,1) = 2d0*mm02*zadj(1,1) + zadj2ff(1,1)
600  xadj(2,1) = 2d0*mm02*zadj(2,1) + zadj2ff(2,1)
601  xadj(3,1) = 2d0*mm02*zadj(3,1) + zadj2ff(3,1)
602  xadj(1,2) = xadj(2,1)
603  xadj(2,2) = 2d0*mm02*zadj(2,2) + zadj2ff(2,2)
604  xadj(3,2) = 2d0*mm02*zadj(3,2) + zadj2ff(3,2)
605  xadj(1,3) = xadj(3,1)
606  xadj(2,3) = xadj(3,2)
607  xadj(3,3) = 2d0*mm02*zadj(3,3) + zadj2ff(3,3)
608  endif
609 
610 
611 ! write(*,*) 'Xadjn ',Xadj
612 ! write(*,*) 'detXn ',detX
613 ! write(*,*) 'Zadjfn',Zadjf
614 ! write(*,*) 'Zadj2ffn',Zadj2ff
615 
616  maxzadj2ff = max(abs(zadj2ff(1,1)),abs(zadj2ff(2,1)),abs(zadj2ff(3,1)), &
617  abs(zadj2ff(2,2)),abs(zadj2ff(3,2)),abs(zadj2ff(3,3)))
618  maxzadjf = max(abs(zadjf(1)),abs(zadjf(2)),abs(zadjf(3)))
619  maxzadjfd = max(maxzadjf,adetz)
620  zadjff = zadjf(1)*f(1)+zadjf(2)*f(2)+zadjf(3)*f(3)
621  azadjff = abs(zadjff)
622  adetx = abs(2d0*mm02*detz-zadjf(1)*f(1)-zadjf(2)*f(2)-zadjf(3)*f(3))
623 
624 ! write(*,*) 'fs', f(1), f(2), f(3)
625 ! write(*,*) aZadjff, maxZadjf*fmax
626 
627  maxxadj = max(abs(xadj(1,1)),abs(xadj(2,1)),abs(xadj(3,1)), &
628  abs(xadj(2,2)),abs(xadj(3,2)),abs(xadj(3,3)))
629 
630 ! write(*,*) 'CalcDred acc_inf=',acc_inf
631 ! write(*,*) 'CalcDred Derr=',Derr
632 
633 ! write(*,*) 'CalcDred adetX ',adetX,maxZadjf,maxXadj,adetZ
634 ! write(*,*) 'CalcDred Zadj2ff',maxZadj2ff
635 ! write(*,*) 'CalcDred maxZadj',maxZadj
636 ! write(*,*) 'CalcDred Zadjf',Zadjf
637 ! write(*,*) 'CalcDred f',f
638 ! write(*,*) 'CalcDred Zadjff',Zadjff
639 
640  zadj2f = 0d0
641  zadj2f(1,2,1) = z(3,2)*f(3) - z(3,3)*f(2)
642  zadj2f(1,3,1) = -z(2,2)*f(3) + z(2,3)*f(2)
643  zadj2f(2,3,1) = z(1,2)*f(3) - z(1,3)*f(2)
644  zadj2f(1,2,2) = -z(3,1)*f(3) + z(3,3)*f(1)
645  zadj2f(1,3,2) = z(2,1)*f(3) - z(2,3)*f(1)
646  zadj2f(2,3,2) = -z(1,1)*f(3) + z(1,3)*f(1)
647  zadj2f(1,2,3) = z(3,1)*f(2) - z(3,2)*f(1)
648  zadj2f(1,3,3) = -z(2,1)*f(2) + z(2,2)*f(1)
649  zadj2f(2,3,3) = z(1,1)*f(2) - z(1,2)*f(1)
650  zadj2f(2,1,1) = -zadj2f(1,2,1)
651  zadj2f(3,1,1) = -zadj2f(1,3,1)
652  zadj2f(3,2,1) = -zadj2f(2,3,1)
653  zadj2f(2,1,2) = -zadj2f(1,2,2)
654  zadj2f(3,1,2) = -zadj2f(1,3,2)
655  zadj2f(3,2,2) = -zadj2f(2,3,2)
656  zadj2f(2,1,3) = -zadj2f(1,2,3)
657  zadj2f(3,1,3) = -zadj2f(1,3,3)
658  zadj2f(3,2,3) = -zadj2f(2,3,3)
659 
660  maxzadj2f=maxval(abs(zadj2f))
661 
662 ! write(*,*) 'CalcDred Zadj2f',maxZadj2f
663 
664 ! write(*,*) 'CalcDred m2scale',m2scale
665 
666  ! 1/sqrt(adetX) seems to describe scale of D0 well
667  ! scale ratio between D0 and C0's better described by maximal scale (missing in at least one C0 function)
668  ! m2scale = sqrt(adetX)/q2max
669 
670 ! write(*,*) 'CalcDred m2scale',m2scale
671 ! write(*,*) 'CalcDred 1/sX ',1/sqrt(adetX)
672 
673 ! Zadj2ff = Zadj2f(:,1,:)*f(1)+Zadj2f(:,2,:)*f(2)+Zadj2f(:,3,:)*f(3)
674 
675 ! write(*,*) 'CalcDred Zadj2ff',Zadj2ff
676 
677 
678  ! quantities for modified error estimates
679  ! momentum weights
680 ! do i = 1,3
681 ! pweight(i) = max(abs(Z(i,1))/maxval(abs(Z(1:3,1))), &
682 ! abs(Z(i,2))/maxval(abs(Z(1:3,2))), &
683 ! abs(Z(i,3))/maxval(abs(Z(1:3,3))))
684 ! end do
685 
686 ! wmaxZadj = max(pweight(1)*abs(Zadj(1,1)), &
687 ! pweight(1)*abs(Zadj(1,2)),pweight(1)*abs(Zadj(1,3)), &
688 ! pweight(2)*abs(Zadj(2,1)),pweight(3)*abs(Zadj(3,1)), &
689 ! pweight(2)*abs(Zadj(2,3)),pweight(3)*abs(Zadj(3,2)), &
690 ! pweight(2)*abs(Zadj(2,2)),pweight(3)*abs(Zadj(3,3)))
691 
692 ! wmaxZadjf = max(pweight(1)*abs(Zadjf(1)),pweight(2)*abs(Zadjf(2)), &
693 ! pweight(3)*abs(Zadjf(3)))
694 
695 ! wmaxXadj = max(pweight(1)*abs(Xadj(1,1)), &
696 ! pweight(1)*abs(Xadj(1,2)),pweight(1)*abs(Xadj(1,3)), &
697 ! pweight(2)*abs(Xadj(2,1)),pweight(2)*abs(Xadj(2,3)), &
698 ! pweight(3)*abs(Xadj(3,1)),pweight(3)*abs(Xadj(3,2)), &
699 ! pweight(2)*abs(Xadj(2,2)),pweight(3)*abs(Xadj(3,3)))
700 ! wmaxXadj = max(2d0*abs(mm02)*sqrt(adetZ*maxZadj/maxZ),maxZadj2ff*maxZadjf/(maxZadj*fmax))
701 
702 ! write(*,*) 'CalcDred pweight',pweight(1:3)
703 ! write(*,*) 'CalcDred wmaxZadj',maxZadj,wmaxZadj
704 ! write(*,*) 'CalcDred wmaxZadjf',maxZadjf,wmaxZadjf
705 ! write(*,*) 'CalcDred wmaxZadjf',maxXadj,wmaxXadj
706 
707  ! rough estimate for D0 to set the scale, to be improved
708  dscale2 = max(abs(p10*p32),abs(p21*p30),abs(p20*p31),abs(m02*m02), \
709  abs(m12*m12),abs(m22*m22),abs(m32*m32))
710 #ifdef USED0
711  d0est = max(abs(d0_coli(p10,p21,p32,p30,p20,p31,m02,m12,m22,m32)), \
712  1d0/dscale2)
713  lerr_d0 = .true.
714 #else
715 ! changed 09.09.16
716  if(dscale2.ne.0d0) then
717  d0est = 1d0/dscale2
718  else
719  d0est = 1d0
720  end if
721 ! if (adetX.ne.0d0) then
722 ! D0est = 1d0/sqrt(adetX)
723 ! elseif (m2max.ne.0d0) then
724 ! D0est = 1d0/m2max**2
725 ! else if (maxZ.ne.0d0) then
726 ! D0est = 1d0/maxZ**2
727 ! else
728 ! D0est = 1d0
729 ! endif
730  lerr_d0 = .false.
731 #endif
732  err_inf = acc_inf*d0est
733  dtyp = d0est
734 
735 #ifdef Dredtest
736  if (adetx.ne.0d0) write(*,*) 'D0est',1d0/sqrt(adetx)
737  if (m2max.ne.0d0) write(*,*) 'D0est',1d0/m2max**2
738  if (maxz.ne.0d0) write(*,*) 'D0est',1d0/maxz**2
739  write(*,*) 'D0est',d0est
740 #endif
741 
742  dcalc = 0
743  drcalc = 0
744  drmethod = 0
745  derr1 = err_inf
746  derr2 = err_inf
747  derr = err_inf
748  acc_d = acc_inf
749  dcount(0) = dcount(0)+1
750 
751  ! error estimate of D0
752  if (adetx.ne.0d0) then
753  err_d0 = acc_def_d0*max( d0est, 1d0/sqrt(adetx) )
754  else
755  err_d0 = acc_def_d0*d0est
756  endif
757 
758 
759 
760  err_req_d = acc_req_d * d0est
761 
762 ! write(*,*) 'CalcDred err_req ',err_req_D,acc_req_D , D0est
763 
764  ! estimate accuracy of PV-reduction
765 ! if (adetZ.eq.0d0) then
766 ! if (adetZ.lt.dprec_cll*maxZ**3) then
767  h_pv = real(undefined_d)
768  w_pv = real(undefined_d)
769  v_pv = real(undefined_d)
770  z_pv = real(undefined_d)
771 
772 ! if (adetZ.lt.dprec_cll*maxZadjf.or.adetZ.eq.0d0) then
773 ! 14.07.2017
774  if (adetz.lt.dprec_cll*maxzadjf.or.adetz.lt.dprec_cll*maxz**3.or.adetz.eq.0d0) then
775  use_pv = .false.
776  err_pv = err_inf
777  else
778  use_pv = .true.
779  if (rmax.eq.0) then
780  err_pv(0) = err_d0
781  else
782 #ifdef PVEST2
783  h_pv = sqrt(adetz/(maxz*maxzadj))
784  w_pv = max((maxzadjf*h_pv/adetz)**2, abs(mm02)*maxzadj*h_pv/adetz, azadjff*maxzadj*(h_pv/adetz)**2)
785  v_pv = maxzadjf*h_pv/adetz
786  z_pv = maxzadj*h_pv/adetz
787 #else
788  w_pv = max((maxzadjf/adetz)**2, abs(mm02)*maxzadj/adetz, azadjff*maxzadj/adetz**2)
789  v_pv = maxzadjf/adetz
790  z_pv = maxzadj/adetz
791 #endif
792  if (mod(rmax,2).eq.1) then
793  err_pv(rmax) = max( w_pv**((rmax-1)/2) * v_pv * err_d0, &
794  w_pv**((rmax-1)/2) * z_pv * err_c0, z_pv * err_c(rmax-1) )
795 #ifdef Dredtest
796  write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,z_pv,err_d0,err_c0,rmax
797 
798  write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax-1)/2) * v_pv * err_d0, &
799  w_pv**((rmax-1)/2) * z_pv * err_c0, z_pv * err_c(rmax-1)
800 #endif
801  else
802  err_pv(rmax) = max( w_pv**(rmax/2) * err_d0, &
803  w_pv**(rmax/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(rmax-1) )
804 #ifdef Dredtest
805  write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,z_pv
806  write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax)/2) * err_d0, &
807  w_pv**(rmax/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(rmax-1)
808  write(*,*) 'CalcDred err_pv con: ',err_pv(rmax), w_pv**((rmax)/2),err_d0, &
809  w_pv**(rmax/2-1) * v_pv,err_c0, z_pv,err_c(rmax-1)
810 #endif
811  end if
812  end if
813  end if
814 
815 
816  ! estimate accuracy of alternative PV-reduction
817 ! if ((adetZ.eq.0).or.(adetX.eq.0)) then
818 ! if ((adetZ.lt.dprec_cll*maxZ**3).or.(adetX.lt.dprec_cll*maxval(abs(mx))**4)) then
819  w_pv2 = real(undefined_d)
820  h_pv2 = real(undefined_d)
821  hw_pv2 = real(undefined_d)
822  v_pv2 = real(undefined_d)
823  z_pv2 = real(undefined_d)
824 
825 ! if ((adetZ.lt.dprec_cll*maxZadjf).or.(adetX.lt.dprec_cll*maxval(abs(mx))*adetZ).or.adetZ.eq.0d0.or.adetX.eq.0d0) then
826 ! 14.07.2017
827  if ((adetz.lt.dprec_cll*maxzadjf).or.(adetx.lt.dprec_cll*maxval(abs(mx))*adetz).or. &
828  (adetz.lt.dprec_cll*maxz**3).or.adetz.eq.0d0.or.adetx.eq.0d0) then
829  use_pv2 = .false.
830  err_pv2 = err_inf
831  else
832  use_pv2 = .true.
833  if (rmax.eq.0) then
834  err_pv2(0) = err_d0
835  else
836  w_pv2 = maxzadjf/adetz
837 #ifdef PVEST2
838  h_pv2 = sqrt(adetz/(maxz*maxzadj))
839  hw_pv2 = w_pv2*h_pv2
840 #else
841  hw_pv2 = w_pv2
842 #endif
843  v_pv2 = maxxadj/adetz
844  z_pv2 = adetz/adetx
845 
846 #ifdef Dredtest
847  write(*,*) 'CalcDred w_pv2: ',w_pv2,v_pv2,z_pv2
848  write(*,*) 'CalcDred w_pv2: ',mod(rmax,2).eq.1
849 #endif
850 
851  if (mod(rmax,2).eq.1) then
852 ! change 21.10.15 for PVEST2
853 ! err_pv2(rmax) = max( err_D0 * max(w_pv2**rmax, &
854 ! w_pv2*v_pv2**((rmax-1)/2) ), &
855 ! err_C0 * z_pv2*max(w_pv2**(rmax+1), &
856 ! w_pv2*v_pv2**((rmax-1)/2), &
857 ! v_pv2**((rmax+1)/2)), &
858 ! err_C(rmax-1) * z_pv2 * max(w_pv2,w_pv2**2,v_pv2) )
859  err_pv2(rmax) = max( err_d0 * max(hw_pv2**rmax, &
860  hw_pv2*v_pv2**((rmax-1)/2) ), &
861  err_c0 * z_pv2*max(w_pv2*hw_pv2**(rmax), &
862  max(1d0,w_pv2)*hw_pv2*v_pv2**((rmax-1)/2), &
863  v_pv2**((rmax+1)/2)), &
864  err_c(rmax-1) * z_pv2 * max(hw_pv2,hw_pv2*w_pv2,v_pv2) )
865 
866 #ifdef Dredtest
867  write(*,*) 'CalcDred err_pv2: ', &
868  err_pv2(rmax) , err_d0,err_d0*w_pv2**rmax,err_d0*v_pv2**((rmax-1)/2), &
869  err_d0*w_pv2*v_pv2**((rmax-1)/2)
870  write(*,*) 'CalcDred err_pv2: ' &
871  ,err_pv2(rmax) , err_d0 * max(1d0,w_pv2**rmax,v_pv2**((rmax-1)/2), &
872  w_pv2*v_pv2**((rmax-1)/2) ) &
873  , err_c0 * z_pv2*max(w_pv2**(rmax+1), &
874  w_pv2*v_pv2**((rmax-1)/2), &
875  v_pv2**((rmax+1)/2)) &
876  , err_c(rmax-1) * max(z_pv2*w_pv2, &
877  z_pv2*w_pv2**2,z_pv2*v_pv2)
878  write(*,*) 'CalcDred err_pv2: ', &
879  err_c0 * z_pv2*w_pv2**(rmax+1), &
880  err_c0 * z_pv2* w_pv2*v_pv2**((rmax-1)/2), &
881  err_c0 * z_pv2* v_pv2**((rmax+1)/2) , &
882  err_c0
883 #endif
884 
885  else
886 ! change 21.10.15 for PVEST2
887 ! err_pv2(rmax) = max( err_D0 * max(w_pv2**rmax,v_pv2**(rmax/2)), &
888 ! err_C0 * z_pv2 * max(w_pv2**(rmax+1), &
889 ! v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
890 ! err_C(rmax-1) * z_pv2 * max(w_pv2, w_pv2**2, v_pv2) )
891  err_pv2(rmax) = max( err_d0 * max(hw_pv2**rmax,v_pv2**(rmax/2)), &
892  err_c0 * z_pv2 * max(w_pv2*hw_pv2**(rmax), &
893  v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
894  err_c(rmax-1) * z_pv2 * max(hw_pv2,hw_pv2*w_pv2, v_pv2) )
895 
896 
897 ! write(*,*) 'CalcDred err_pv2: ', &
898 ! err_pv2(rmax) , err_D0 * max(1d0,w_pv2**rmax,v_pv2**(rmax/2)), &
899 ! err_C0 * z_pv2 * max(w_pv2**(rmax+1), &
900 ! v_pv2**(rmax/2),w_pv2*v_pv2**(rmax/2)), &
901 ! err_C(rmax-1) * max(1d0,z_pv2*w_pv2, &
902 ! z_pv2*w_pv2**2,z_pv2*v_pv2)
903 ! write(*,*) 'CalcDred err_pv2: ', &
904 ! err_C0 * z_pv2 * w_pv2**(rmax+1), &
905 ! err_C0 * z_pv2 * v_pv2**(rmax/2), &
906 ! err_C0 * z_pv2 * w_pv2*v_pv2**(rmax/2), &
907 ! err_C0
908  end if
909  end if
910  end if
911 
912  ! scale estimates down to allow trying other methods
913  err_pv(rmax) = err_pv(rmax)/impest_d
914  err_pv2(rmax) = err_pv2(rmax)/impest_d
915 
916 ! write(*,*) 'CalcDred err_pv: ',err_pv, w_pv**((rmax-1)/2) * v_pv * err_D0, &
917 ! w_pv**((rmax-1)/2) * z_pv * err_C0, z_pv * err_C(rmax-1)
918 
919 #ifdef Dredtest
920  write(*,*) 'CalcDred: err_pv',err_pv(rmax),err_pv2(rmax),err_req_d
921  write(*,*) 'CalcDred: acc_pv',err_pv(rmax)/d0est,err_pv2(rmax)/d0est,acc_req_d
922 #endif
923 
924 #ifdef TEST
925  use_pv = .false.
926  use_pv2 = .false.
927  use_pv = .true.
928 ! use_pv2 = .true.
929  err_pv2(rmax) = 1d30
930 ! err_pv(rmax) = 1d30
931 #endif
932 
933 
934 ! Dtyp = real(undefined_D)
935  dtyp = d0est
936 #ifdef ALWAYSPV
937  if(use_pv.or.use_pv2) then
938 #else
939  if (min(err_pv(rmax),err_pv2(rmax)).le.err_req_d) then
940 #endif
941  if (err_pv(rmax).le.err_pv2(rmax)) then
942 
943 #ifdef Dredtest
944  write(*,*) 'CalcDred: call Dpv 1 ',rmax,id,err_pv(rmax)
945 #endif
946 
947  ! use PV-reduction if appropriate
948  call calcdpv1(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
949 #ifdef PVEST2
950  derr = derr2
951 #else
952  derr = derr1
953 #endif
954 
955  dcount(1) = dcount(1)+1
956  drcalc(0:rmax) = drcalc(0:rmax)+1
957  dcalc = dcalc+1
958  drmethod(0:rmax) = 1
959 ! err_D = err_pv
960 
961 #ifdef Dredtest
962  checkest=derr(rmax)/err_pv(rmax)
963  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
964  write(*,*) 'CalcDred: estimate err_pv imprecise',err_pv(rmax),derr(rmax)
965  end if
966 #endif
967 
968  err_pv=derr
969 
970  else
971 
972 #ifdef Dredtest
973  write(*,*) 'CalcDred: call Dpv2 1',rmax,id,err_pv2(rmax)
974 #endif
975 
976  ! use alternative PV-reduction if appropriate
977  call calcdpv2(d,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,id,derr1,derr2)
978 #ifdef PVEST2
979  derr = derr2
980 #else
981  derr = derr1
982 #endif
983  dcount(2) = dcount(2)+1
984  drcalc(0:rmax)=drcalc(0:rmax)+2
985  dcalc = dcalc+2
986  drmethod(0:rmax)=2
987 
988 #ifdef Dredtest
989  checkest=derr(rmax)/err_pv2(rmax)
990  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
991  write(*,*) 'CalcDred: estimate err_pv2 imprecise',err_pv2(rmax),derr(rmax)
992  end if
993 #endif
994  err_pv2=derr
995 
996  end if
997 
998 #ifndef USED0
999  ! refine error estimate for D0
1000 ! D0est = abs(D(0,0,0,0))
1001  err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
1002  err_req_d = acc_req_d * abs(d(0,0,0,0))
1003  lerr_d0 = .true.
1004 #endif
1005 
1006  if (rmax.ge.1) then
1007  dtyp = max(abs(d(0,0,0,0)), &
1008  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
1009  else
1010  dtyp = abs(d(0,0,0,0))
1011  end if
1012  if(dtyp.eq.0d0) dtyp = d0est
1013  err_req_d = acc_req_d * dtyp
1014 
1015 
1016 #ifdef Dredtest
1017  write(*,*) 'CalcDred Derr1 after PV = ',derr1
1018 ! write(*,*) 'CalcDred Dacc1 after PV = ',Derr1/abs(D(0,0,0,0))
1019  write(*,*) 'CalcDred Dacc1 after PV = ',derr1/dtyp
1020  write(*,*) 'CalcDred err1_D',derr1(rmax)
1021  write(*,*) 'CalcDred Derr2 after PV = ',derr2
1022 ! write(*,*) 'CalcDred Dacc2 after PV = ',Derr2/abs(D(0,0,0,0))
1023  write(*,*) 'CalcDred Dacc2 after PV = ',derr2/dtyp
1024  write(*,*) 'CalcDred err2_D',derr2(rmax)
1025 #endif
1026 
1027 ! Derr = Derr2 might lead to imprecise results
1028  if (derr1(rmax).lt.err_req_d) then
1029  dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
1030  return
1031  end if
1032 
1033  else ! added 14.07.2017
1034  d = 0d0
1035  duv = 0d0
1036  derr1 = err_inf
1037  derr2 = err_inf
1038  end if
1039 
1040 #ifdef Dredtest
1041 ! return
1042 #endif
1043 
1044 ! allocate(D_alt(0:rmax,0:rmax,0:rmax,0:rmax))
1045 ! allocate(Duv_alt(0:rmax,0:rmax,0:rmax,0:rmax))
1046 ! allocate(Derr1_alt(0:rmax))
1047 ! allocate(Derr2_alt(0:rmax))
1048 ! allocate(Drmethod_alt(0:rmax))
1049 
1050  ! choose most promising expansion scheme
1051  ! Gram expansion
1052 ! if (maxZadjf.ne.0d0) then
1053  if (maxzadjf.gt.m2scale**3*dprec_cll) then ! 10.07.2017
1054  x_g = adetz/maxzadjf
1055 ! u_g = max(1d0,maxZadj2ff/maxZadjf/4d0,abs(mm02)*maxZadj/maxZadjf/4d0)
1056 ! 03.03.15 large P counts!
1057 ! u_g = max(1d0,maxZadj2ff/maxZadjf/2d0,abs(mm02)*maxZadj/maxZadjf/2d0)
1058 ! 24.04.15 term appear only combined
1059  u_g = max(1d0,maxxadj/maxzadjf/2d0)
1060  fac_g = x_g*u_g
1061  err_g = err_inf
1062  g = -1
1063  if (fac_g.ge.1) then
1064  use_g = .false.
1065  err_g_exp = err_inf
1066  err_g_c = err_c(rmax) ! dummy
1067  err_g_cr = real(undefined_d)
1068  z_g = real(undefined_d)
1069  else
1070  use_g = .true.
1071 ! z_g = max(1d0,m2scale*maxZadj/maxZadjf)
1072  z_g = maxzadj/maxzadjf
1073  err_g_cr = max( err_c(rmax), err_c0 * u_g**rmax ) * z_g
1074  err_g_c = err_g_cr
1075  err_g_exp = u_g**(rmax-1) * dtyp
1076  end if
1077  else
1078  use_g = .false.
1079  err_g = err_inf
1080  g = -1
1081  err_g_exp = err_inf
1082  err_g_c = err_c(rmax) ! dummy
1083  u_g = real(undefined_d)
1084  z_g = real(undefined_d)
1085  err_g_cr = real(undefined_d)
1086  endif
1087 
1088 #ifdef Dredtest
1089  write(*,*) 'CalcDred: after Gram pars',use_g,fac_g,x_g,u_g,z_g,err_g_cr,err_c(rmax),err_c0,err_g_exp
1090 ! write(*,*) 'CalcDred: after Gram pars',adetZ,maxZadjf,maxXadj,maxZ
1091  write(*,*) 'CalcDred: after Gram pars',err_c(rmax), err_c0 * u_g**rmax
1092 #endif
1093 
1094 #ifdef USEGM
1095  ! modified Gram expansion
1096 ! if (aZadjff.ne.0d0) then
1097  if (azadjff.gt.m2scale**4*dprec_cll) then ! 10.07.2017
1098  x_gm = adetz*fmax/azadjff
1099 ! u_gm = max(1d0,maxZadj2ff/maxZadjf/4d0,abs(mm02)*maxZadj/maxZadjf/4d0)
1100 ! 03.03.15 large P counts!
1101 ! u_gm = max(1d0,maxZadj2ff/maxZadjf/2d0,abs(mm02)*maxZadj/maxZadjf/2d0)
1102 ! 24.04.15 term appear only combined
1103  u_gm = max(1d0,maxxadj/maxzadjf/2d0)
1104  fac_gm = x_gm*u_gm
1105  err_gm = err_inf
1106  gm = -1
1107  if (fac_gm.ge.1) then
1108  use_gm = .false.
1109  err_gm_exp = err_inf
1110  err_gm_c = err_c(rmax) ! dummy
1111  else
1112  use_gm = .true.
1113 ! z_gm = max(1d0,m2scale*maxZadj/maxZadjf)
1114  z_gm = maxzadjf/azadjff
1115  err_gm_cr = max( err_c(rmax), err_c0 * u_gm**rmax ) * z_gm
1116  err_gm_c = err_gm_cr
1117  err_gm_exp = u_gm**(rmax-1) * dtyp
1118  end if
1119  else
1120  use_gm = .false.
1121  err_gm = err_inf
1122  gm = -1
1123  err_gm_exp = err_inf
1124  err_gm_c = err_c(rmax) ! dummy
1125  endif
1126 
1127 #ifdef Dredtest
1128  write(*,*) 'CalcDred: after mod Gram pars',use_gm,fac_gm,x_gm,u_gm,z_gm,err_gm_cr,err_c(rmax),err_c0,err_gm_exp
1129 ! write(*,*) 'CalcDred: after mod Gram pars',1d0,maxZadj2ff/maxZadjf,abs(mm02)*maxZadj/maxZadjf
1130  write(*,*) 'CalcDred: after mod Gram pars',err_c(rmax), err_c0 * u_gm**rmax
1131  write(*,*) 'CalcDred: after mod Gram pars', adetz,fmax,azadjff
1132 #endif
1133 
1134 #else
1135  use_gm = .false.
1136  err_gm = err_inf
1137  gm = -1
1138  err_gm_exp = err_inf
1139  err_gm_c = err_c(rmax) ! dummy
1140 #endif
1141 
1142  ! Gram-Cayley expansion
1143 ! if (maxXadj.ne.0d0.and.maxZadj.ne.0) then
1144  if (maxxadj.gt.m2scale**3*dprec_cll.and.maxzadj.gt.m2scale*dprec_cll) then ! 10.07.2017
1145  x_gy = maxzadjf/maxxadj
1146  y_gy = adetz/maxxadj
1147  v_gy = maxzadj2f/maxzadj
1148  v1_gy = max(1d0,v_gy)
1149  fac_gy = max(x_gy,y_gy)*v1_gy
1150  err_gy = err_inf
1151  gy = -1
1152  if (fac_gy.ge.1) then
1153  use_gy = .false.
1154  err_gy_exp = err_inf
1155  err_gy_c = err_c(rmax+1) ! dummy
1156  err_gy_cr = real(undefined_d)
1157  b_gy = real(undefined_d)
1158  else
1159  use_gy = .true.
1160 ! b_gy = max(1d0,m2scale*maxZadj/maxXadj)
1161  b_gy = maxzadj/maxxadj
1162  err_gy_cr = max( err_c(rmax) * v1_gy, err_c(rmax+1) )
1163  err_gy_c = err_gy_cr * b_gy
1164  err_gy_exp = 1d0 * dtyp
1165  end if
1166  else
1167  use_gy = .false.
1168  err_gy = err_inf
1169  gy = -1
1170  err_gy_exp = err_inf
1171  err_gy_c = err_c(rmax+1) ! dummy
1172  v1_gy = real(undefined_d)
1173  b_gy = real(undefined_d)
1174  err_gy_cr = real(undefined_d)
1175  endif
1176 
1177 
1178 #ifdef Dredtest
1179  write(*,*) 'CalcDred: after GramCay pars',use_gy,fac_gy,x_gy,y_gy,v_gy,b_gy,err_gy_cr,err_gy_exp
1180  if (use_gy) then
1181  write(*,*) 'CalcDred: after GramCay pars',maxxadj/maxzadj,1/v_gy,1/v_gy*maxxadj/maxzadj,1/v_gy*maxxadj/maxzadj*x_gy
1182  end if
1183 #endif
1184 
1185  ! expansion in small momenta
1186 ! if (fmax.ne.0d0) then
1187  if (fmax.gt.m2scale*dprec_cll) then ! 10.07.2017
1188  w_gp = maxz/fmax ! was q2max
1189  v_gp = abs(mm02/fmax)
1190  v1_gp = max(1d0,v_gp)
1191  fac_gp = w_gp*v1_gp
1192  err_gp = err_inf
1193  gp = -1
1194  if (fac_gp.ge.1d0) then
1195  use_gp = .false.
1196  err_gp_exp = err_inf
1197  err_gp_c = err_c(rmax) ! dummy
1198  err_gp_cr = real(undefined_d)
1199  z_gp = real(undefined_d)
1200  else
1201  use_gp = .true.
1202 ! z_gp = max(1d0,m2scale/fmax)
1203  z_gp = 1d0/fmax
1204  err_gp_cr = max(err_c0 * v_gp**rmax , err_c(rmax)) * z_gp
1205  err_gp_c = err_gp_cr
1206  err_gp_exp = v1_gp**(rmax-1) * dtyp
1207  end if
1208  else
1209  use_gp = .false.
1210  err_gp = err_inf
1211  gp = -1
1212  err_gp_exp = err_inf
1213  err_gp_c = err_c(rmax) ! dummy
1214  v1_gp = real(undefined_d)
1215  v_gp = real(undefined_d)
1216  z_gp = real(undefined_d)
1217  err_gp_cr = real(undefined_d)
1218  endif
1219 
1220 #ifdef Dredtest
1221  write(*,*) 'CalcDred: after Mom pars',use_gp,fac_gp,w_gp,v_gp,z_gp,err_gp_cr,err_gp_exp
1222 #endif
1223 
1224  ! reversed Gram expansion
1225 ! if (maxZadjf.ne.0d0.and.maxZadj2f.ne.0d0) then
1226  if (maxzadjf.gt.m2scale**3*dprec_cll.and.maxzadj2f.gt.m2scale**2*dprec_cll) then ! 10.07.2017
1227  x_gr = adetz/maxzadjf
1228  y_gr = maxzadj/maxzadj2f ! c*y c=2
1229  y1_gr = max(1d0,y_gr)
1230  a_gr = maxzadj/maxzadjf
1231  fac_gr = max(x_gr,y_gr)
1232  err_gr = err_inf
1233  gr = -1
1234  if (fac_gr.ge.1.or.2*rmax.gt.rmax_c) then
1235  use_gr = .false.
1236  err_gr_exp = err_inf
1237  err_gr_c = err_c(rmax) ! dummy
1238  err_gr_cr = real(undefined_d)
1239  else
1240  use_gr = .true.
1241  err_gr_cr = err_c(rmax)
1242  err_gr_c = err_gr_cr * a_gr
1243  err_gr_exp = y1_gr * dtyp
1244  end if
1245  else
1246  use_gr = .false.
1247  err_gr = err_inf
1248  gr = -1
1249  err_gr_exp = err_inf
1250  err_gr_c = err_c(rmax) ! dummy
1251  a_gr = real(undefined_d)
1252  y_gr = real(undefined_d)
1253  y1_gr = real(undefined_d)
1254  err_gr_cr = real(undefined_d)
1255  endif
1256 
1257 #ifdef Dredtest
1258  write(*,*) 'CalcDred: after revGram pars',use_gr,fac_gr,x_gr,y_gr,y1_gr,a_gr,err_gr_cr,err_c(rmax),err_c0,err_gr_exp
1259  write(*,*) 'CalcDred: after revGram pars',err_gr_c,dtyp
1260 #endif
1261 
1262  ! expansion in small momenta and f's
1263 ! estimates to be confirmed 16.08.17, r dependence may be different
1264 ! since D_mni... is needed in contrast to Dgy expansion
1265  if (abs(m02).gt.m2scale*dprec_cll) then
1266  x_gpf = fmax/abs(m02)
1267  y_gpf = maxz/abs(m02)
1268  v_gpf = 0d0
1269  v1_gpf = max(1d0,v_gpf)
1270  fac_gpf = max(x_gpf,y_gpf)
1271  err_gpf = err_inf
1272  gpf = -1
1273  if (fac_gpf.ge.1) then
1274  use_gpf = .false.
1275  err_gpf_exp = err_inf
1276  err_gpf_c = err_c(rmax+1) ! dummy
1277  err_gpf_cr = real(undefined_d)
1278  b_gpf = real(undefined_d)
1279  else
1280  use_gpf = .true.
1281  b_gpf = 1d0/abs(m02)
1282  err_gpf_cr = max( err_c(rmax), err_c(rmax+1) )
1283  err_gpf_c = err_gpf_cr * b_gpf
1284  err_gpf_exp = 1d0 * dtyp
1285  end if
1286  else
1287  use_gpf = .false.
1288  err_gpf = err_inf
1289  gpf = -1
1290  err_gpf_exp = err_inf
1291  err_gpf_c = err_c(rmax+1) ! dummy
1292  b_gpf = real(undefined_d)
1293  err_gpf_cr = real(undefined_d)
1294  endif
1295 
1296 
1297 #ifdef Dredtest
1298  write(*,*) 'CalcDred: after pf pars',use_gpf,fac_gpf,x_gpf,y_gpf,v_gpf,b_gpf,err_gpf_cr,err_gpf_exp,err_gpf
1299  if (use_gpf) then
1300  write(*,*) 'CalcDred: after pf pars',maxxadj/maxzadj,1/v_gpf,1/v_gpf*maxxadj/maxzadj,1/v_gpf*maxxadj/maxzadj*x_gpf
1301  end if
1302 #endif
1303 
1304 ! no method works
1305  if(use_pv.or.use_pv2.or.use_g.or.use_gy.or.use_gp.or.use_gr.or.use_gm.or.use_gpf.eqv..false.) then
1306  call seterrflag_coli(-6)
1307  call errout_coli('CalcDred',' no reduction method works', &
1308  errorwriteflag)
1309 ! write(nerrout_coli,'((a))') ' no reduction method works'
1310  if (errorwriteflag) then
1311  write(nerrout_coli,fmt10) ' CalcDred: p10 = ',p10
1312  write(nerrout_coli,fmt10) ' CalcDred: p21 = ',p21
1313  write(nerrout_coli,fmt10) ' CalcDred: p32 = ',p32
1314  write(nerrout_coli,fmt10) ' CalcDred: p30 = ',p30
1315  write(nerrout_coli,fmt10) ' CalcDred: p20 = ',p20
1316  write(nerrout_coli,fmt10) ' CalcDred: p31 = ',p31
1317  write(nerrout_coli,fmt10) ' CalcDred: m02 = ',m02
1318  write(nerrout_coli,fmt10) ' CalcDred: m12 = ',m12
1319  write(nerrout_coli,fmt10) ' CalcDred: m22 = ',m22
1320  write(nerrout_coli,fmt10) ' CalcDred: m32 = ',m32
1321  end if
1322  d = 0d0
1323  duv = 0d0
1324  derr1 = err_inf
1325  derr2 = err_inf
1326 
1327 #ifdef Dredtest
1328  write(*,*) 'CalcDred: exit'
1329 #endif
1330 
1331  return
1332  endif
1333 
1334 #ifdef TEST
1335 ! switched off for testing
1336  use_g = .false.
1337 ! use_gy = .false.
1338  use_gp = .false.
1339  use_gr = .false.
1340 ! use_gpf= .false.
1341 ! use_g = .true.
1342 ! use_gy = .true.
1343 ! use_gp = .true.
1344 ! use_gr = .true.
1345 #endif
1346 
1347  iexp = 0
1348  do i=0,rmax_d-rmax
1349 
1350  if (use_g) then
1351  if (err_g_exp.gt.err_g_c) then
1352  g = i
1353  err_g_exp = err_g_exp*fac_g
1354  err_g_c = max(err_g_cr,err_c(rmax+g)*z_g*x_g**g)
1355  err_g(rmax) = max(err_g_exp,err_g_c)
1356  if(err_g(rmax).lt.err_req_d) then
1357  iexp = 1
1358  ! increase g by 2 to account for bad estimates
1359  g = min(max(g+2,3*g/2),rmax_d-rmax)
1360  exit
1361  end if
1362  end if
1363  end if
1364 
1365 #ifdef Dredtest
1366 ! write(*,*) 'CalcDred: it g',g, err_g_exp, err_g_C, err_g(rmax)
1367 ! write(*,*) 'CalcDred: it g',err_g_Cr,err_C(rmax+g)*z_g*x_g**g
1368 ! write(*,*) 'CalcDred: it g',err_C(rmax+g),z_g,x_g
1369 #endif
1370 
1371 #ifdef USEGM
1372  if (use_gm) then
1373  if (err_gm_exp.gt.err_gm_c) then
1374  gm = i
1375  err_gm_exp = err_gm_exp*fac_gm
1376  err_gm_c = max(err_gm_cr,err_c(rmax+gm)*z_gm*x_gm**gm)
1377  err_gm(rmax) = max(err_gm_exp,err_gm_c)
1378  if(err_gm(rmax).lt.err_req_d) then
1379  iexp = 7
1380  ! increase gm by 2 to account for bad estimates
1381  gm = min(max(gm+2,3*gm/2),rmax_d-rmax)
1382  exit
1383  end if
1384  end if
1385  end if
1386 
1387 #ifdef Dredtest
1388 ! write(*,*) 'CalcDred: it gm',gm, err_gm_exp, err_gm_C, err_gm(rmax)
1389 ! write(*,*) 'CalcDred: it gm',err_gm_Cr,err_C(rmax+gm)*z_gm*x_gm**gm
1390 ! write(*,*) 'CalcDred: it gm',err_C(rmax+gm),z_gm,x_gm
1391 #endif
1392 #endif
1393 
1394 
1395  if (mod(i,2).eq.1) then
1396 
1397 #ifdef Dredtest
1398  write(*,*) 'CalcDred: it gy',use_gy,err_gy_exp,err_gy_c,err_gy(rmax),err_req_d
1399 #endif
1400 
1401  if (use_gy) then
1402  if (err_gy_exp.gt.err_gy_c.and.err_gy(rmax).gt.err_req_d) then
1403  gy = i/2
1404  err_gy_exp = err_gy_exp*fac_gy
1405  err_gy_c = b_gy*max(err_gy_cr, &
1406  max(err_c(rmax+2*gy)*v1_gy,err_c(rmax+2*gy+1))*y_gy**gy, &
1407  max(err_c(rmax+gy)*v1_gy,err_c(rmax+gy+1))*(max(x_gy,v_gy*y_gy))**gy)
1408  err_gy(rmax) = max(err_gy_exp,err_gy_c)
1409 
1410 #ifdef Dredtest
1411  write(*,*) 'CalcDred i gy',i,gy,err_gy_exp,err_gy_c,err_gy(rmax)
1412  write(*,*) 'CalcDred i ',err_gy_cr, &
1413  max(err_c(rmax+2*gy)*v1_gy,err_c(rmax+2*gy+1))*y_gy**gy, &
1414  max(err_c(rmax+gy)*v1_gy,err_c(rmax+gy+1))*(max(x_gy,v_gy*y_gy))**gy
1415  write(*,*) 'CalcDred i ', b_gy*err_c(rmax+2*gy)*v1_gy*y_gy**gy, &
1416  b_gy*err_c(rmax+2*gy+1)*y_gy**gy
1417  write(*,*) 'CalcDred i ', &
1418  b_gy,err_c(rmax+2*gy+1),y_gy**gy
1419  write(*,*) 'CalcDred i ', b_gy*x_gy**gy*err_c(rmax+gy)*v1_gy, &
1420  b_gy*err_c(rmax+gy+1)*x_gy**gy
1421  write(*,*) 'CalcDred i ', &
1422  b_gy,err_c(rmax+gy+1),x_gy**gy,x_gy,gy
1423 #endif
1424 
1425  if(err_gy(rmax).lt.err_req_d) then
1426  iexp = 2
1427  ! increase gy by 2 to account for bad estimates
1428  gy = min(max(gy+2,2*gy),(rmax_d-rmax)/2)
1429  exit
1430  end if
1431  end if
1432  end if
1433 
1434 #ifdef Dredtest
1435 ! write(*,*) 'CalcDred: it gy',i,gy, err_gy_exp,err_gy_C ,err_gy(rmax)
1436 #endif
1437 
1438  end if
1439 
1440 ! write(*,*) 'CalcDred bef gp it',err_gp(rmax),err_gp_C,err_req_D
1441 
1442  if (use_gp) then
1443  if (err_gp_exp.gt.err_gp_c.and.err_gp(rmax).gt.err_req_d) then
1444  gp = i
1445  err_gp_exp = err_gp_exp*fac_gp
1446  err_gp_c = max(err_c(rmax+gp)*z_gp*w_gp**gp,err_gp_cr)
1447  err_gp(rmax) = max(err_gp_exp,err_gp_c)
1448  if(err_gp(rmax).lt.err_req_d) then
1449  iexp = 3
1450  ! increase gp by 2 to account for bad estimates
1451  gp = min(max(gp+2,3*gp/2),rmax_d-rmax)
1452  exit
1453  end if
1454  end if
1455  end if
1456 
1457 ! write(*,*) 'CalcDred: it gp',gp,err_gp, err_gp_C, err_gp(rmax)
1458 
1459  if (mod(i,2).eq.1.and.i.le.rmax_c-2*rmax) then
1460 
1461 #ifdef Dredtest
1462 ! write(*,*) 'CalcDred: it gr',use_gr,err_gr_exp,err_gr_C,err_gr(rmax), &
1463 ! err_req_D
1464 #endif
1465 
1466  if (use_gr) then
1467  if (err_gr_exp.gt.err_gr_c.and.err_gr(rmax).gt.err_req_d) then
1468  gr = i/2
1469  err_gr_exp = err_gr_exp*fac_gr
1470  err_gr_c = a_gr*max(err_gr_cr, &
1471  max(err_c(rmax+gr),err_c(rmax+gr+1)*y_gr)*fac_gr**gr)
1472  err_gr(rmax) = max(err_gr_exp,err_gr_c)
1473 #ifdef Dredtest
1474 ! write(*,*) 'CalcDred: it gr',gr,err_gr(rmax),err_req_D
1475 #endif
1476  if(err_gr(rmax).lt.err_req_d) then
1477  iexp = 4
1478  ! increase gy by 2 to account for bad estimates
1479 ! changed 25.07.14
1480 ! gr = min(max(gr+2,2*gr),(rmax_D-rmax)/2,(rmax_C-2*rmax)/2)
1481  gr = min(max(gr+2,2*gr),rmax_d-rmax,max(0,(rmax_c-2*rmax)/2))
1482  exit
1483  end if
1484  end if
1485  end if
1486 
1487 #ifdef Dredtest
1488 ! write(*,*) 'CalcDred: it gr',i,gr, err_gr_exp,err_gr_C ,err_gr(rmax)
1489 #endif
1490 
1491  if (mod(i,2).eq.1) then
1492 
1493 #ifdef Dredtest
1494  write(*,*) 'CalcDred: it gy',use_gy,err_gy_exp,err_gy_c,err_gy(rmax),err_req_d
1495 #endif
1496 
1497  if (use_gpf) then
1498  if (err_gpf_exp.gt.err_gpf_c.and.err_gpf(rmax).gt.err_req_d) then
1499  gpf = i/2
1500  err_gpf_exp = err_gpf_exp*fac_gpf
1501  err_gpf_c = b_gpf*max(err_gpf_cr, &
1502  max(err_c(rmax+2*gpf)*v1_gpf,err_c(rmax+2*gpf+1))*y_gpf**gpf, &
1503  max(err_c(rmax+gpf)*v1_gpf,err_c(rmax+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf)
1504  err_gpf(rmax) = max(err_gpf_exp,err_gpf_c)
1505 
1506 #ifdef Dredtest
1507  write(*,*) 'CalcDred i gpf',i,gpf,err_gpf_exp,err_gpf_c,err_gpf(rmax)
1508  write(*,*) 'CalcDred i ',err_gpf_cr, &
1509  max(err_c(rmax+2*gpf)*v1_gpf,err_c(rmax+2*gpf+1))*y_gpf**gpf, &
1510  max(err_c(rmax+gpf)*v1_gpf,err_c(rmax+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf
1511  write(*,*) 'CalcDred i ', b_gpf*err_c(rmax+2*gpf)*v1_gpf*y_gpf**gpf, &
1512  b_gpf*err_c(rmax+2*gpf+1)*y_gpf**gpf
1513  write(*,*) 'CalcDred i ', &
1514  b_gpf,err_c(rmax+2*gpf+1),y_gpf**gpf
1515  write(*,*) 'CalcDred i ', b_gpf*x_gpf**gpf*err_c(rmax+gpf)*v1_gpf, &
1516  b_gpf*err_c(rmax+gpf+1)*x_gpf**gpf
1517  write(*,*) 'CalcDred i ', &
1518  b_gpf,err_c(rmax+gpf+1),x_gpf**gpf,x_gpf,gpf
1519 #endif
1520 
1521  if(err_gpf(rmax).lt.err_req_d) then
1522  iexp = 5
1523  ! increase gpf by 2 to account for bad estimates
1524  gpf = min(max(gpf+2,2*gpf),(rmax_d-rmax)/2)
1525  exit
1526  end if
1527  end if
1528  end if
1529 
1530 #ifdef Dredtest
1531 ! write(*,*) 'CalcDred: it gpf',i,gpf, err_gpf_exp,err_gpf_C ,err_gpf(rmax)
1532 #endif
1533 
1534  end if
1535  end if
1536 
1537 
1538  end do
1539 
1540  ! scale estimates down to allow trying other methods
1541  err_g(rmax) = err_g(rmax)/impest_d
1542  err_gy(rmax) = err_gy(rmax)/impest_d
1543  err_gp(rmax) = err_gp(rmax)/impest_d
1544  err_gr(rmax) = err_gr(rmax)/impest_d
1545  err_gm(rmax) = err_gm(rmax)/impest_d
1546  err_gpf(rmax) = err_gpf(rmax)/impest_d
1547 
1548 #ifdef Dredtest
1549  write(*,*) 'iexp=',iexp
1550  write(*,*) 'facexp=',fac_g,fac_gy,fac_gp,fac_gr,fac_gm,fac_gpf
1551  write(*,*) 'errexp=',err_g_exp,err_gy_exp,err_gp_exp,err_gr_exp,err_gm_exp,err_gpf_exp,err_req_d
1552  write(*,*) 'errexptot=',i,g,err_g(rmax),gy,err_gy(rmax),gp,err_gp(rmax), &
1553 
1554  gr,err_gr(rmax),gm,err_gm(rmax),gpf,err_gpf(rmax)
1555  write(*,*) 'accexptot=',i,g,err_g(rmax)/dtyp,gy,err_gy(rmax)/dtyp, &
1556  gp,err_gp(rmax)/dtyp,gr,err_gr(rmax)/dtyp,gm,err_gm(rmax)/dtyp, &
1557  gpf,err_gpf(rmax)/dtyp
1558 #endif
1559 
1560 ! call expansions with estimated order to save CPU time
1561 
1562 #ifdef TEST
1563 ! iexp = 0
1564 ! iexp = 5
1565 ! gm = 10
1566 ! iexp = 1
1567 ! g = 10
1568 ! iexp = 4
1569 ! gr = 3
1570  iexp = 2
1571  gy = 4
1572 #endif
1573 
1574  select case (iexp)
1575 
1576  case (1)
1577  call calcdg(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,g,g,id,derr1_alt,derr2_alt)
1578 #ifdef PVEST2
1579  derr_alt = derr2_alt
1580 #else
1581  derr_alt = derr1_alt
1582 #endif
1583  dcount(3) = dcount(3)+1
1584  drcalc(0:rmax)=drcalc(0:rmax)+4
1585  dcalc = dcalc+4
1586  drmethod_alt(0:rmax)=4
1587 
1588 #ifdef Dredtest
1589  checkest=derr_alt(rmax)/err_g(rmax)
1590  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1591  write(*,*) 'CalcDred: estimate err_g imprecise ',err_g(rmax),derr_alt(rmax)
1592  end if
1593 #endif
1594 
1595  err_g=derr_alt
1596 
1597  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1598 
1599 
1600 #ifdef Dredtest
1601  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1602 ! write(*,*) 'CalcDred after exp Dacc=',Derr/abs(D(0,0,0,0))
1603  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1604  write(*,*) 'CalcDred after exp method=',drmethod
1605 #endif
1606 
1607  case (2)
1608  call calcdgy(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gy,gy,id,derr1_alt,derr2_alt)
1609 #ifdef PVEST2
1610  derr_alt = derr2_alt
1611 #else
1612  derr_alt = derr1_alt
1613 #endif
1614  dcount(4) = dcount(4)+1
1615  drcalc(0:rmax)=drcalc(0:rmax)+8
1616  dcalc = dcalc+8
1617  drmethod_alt(0:rmax)=8
1618 
1619 #ifdef Dredtest
1620  checkest=derr_alt(rmax)/err_gy(rmax)
1621  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1622  write(*,*) 'CalcDred: estimate err_gy imprecise',err_gy(rmax),derr_alt(rmax),checkest
1623  end if
1624 #endif
1625  err_gy=derr_alt
1626 
1627  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1628 
1629 #ifdef Dredtest
1630  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1631  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1632  write(*,*) 'CalcDred after exp method=',drmethod
1633 #endif
1634 #ifdef Dredtest
1635 ! write(*,*) 'after CalcDgy D(1,0,1,0)',D_alt(1,0,1,0),D(1,0,1,0)
1636 #endif
1637 
1638 
1639  case (3)
1640  call calcdgp(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gp,gp,id,derr1_alt,derr2_alt)
1641 #ifdef PVEST2
1642  derr_alt = derr2_alt
1643 #else
1644  derr_alt = derr1_alt
1645 #endif
1646  dcount(5) = dcount(5)+1
1647  drcalc(0:rmax)=drcalc(0:rmax)+16
1648  dcalc = dcalc+16
1649  drmethod_alt(0:rmax)=16
1650 
1651 #ifdef Dredtest
1652  checkest=derr_alt(rmax)/err_gp(rmax)
1653  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1654  write(*,*) 'CalcDred: estimate err_gp imprecise',err_gp(rmax),derr_alt(rmax)
1655  end if
1656 #endif
1657  err_gp=derr_alt
1658 
1659  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1660 
1661 #ifdef Dredtest
1662  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1663  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1664  write(*,*) 'CalcDred after exp method=',drmethod
1665 #endif
1666 
1667  case (4)
1668  call calcdgr(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gr,gr,id,derr1_alt,derr2_alt)
1669 #ifdef PVEST2
1670  derr_alt = derr2_alt
1671 #else
1672  derr_alt = derr1_alt
1673 #endif
1674  dcount(6) = dcount(6)+1
1675  drcalc(0:rmax)=drcalc(0:rmax)+32
1676  dcalc = dcalc+32
1677  drmethod_alt(0:rmax)=32
1678 
1679 #ifdef Dredtest
1680  checkest=derr_alt(rmax)/err_gr(rmax)
1681  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1682  write(*,*) 'CalcDred: estimate err_gr imprecise',err_gr(rmax),derr_alt(rmax)
1683  end if
1684 #endif
1685  err_gr=derr_alt
1686 
1687  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1688 
1689 #ifdef Dredtest
1690  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1691  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1692  write(*,*) 'CalcDred after exp method=',drmethod
1693 #endif
1694 
1695 #ifdef USEGM
1696  case (7)
1697  call calcdgm(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gm,gm,id,derr1_alt,derr2_alt)
1698 #ifdef PVEST2
1699  derr_alt = derr2_alt
1700 #else
1701  derr_alt = derr1_alt
1702 #endif
1703  dcount(7) = dcount(7)+1
1704  drcalc(0:rmax)=drcalc(0:rmax)+64
1705  dcalc = dcalc+64
1706  drmethod_alt(0:rmax)=64
1707 
1708 #ifdef Dredtest
1709  checkest=derr_alt(rmax)/err_gm(rmax)
1710  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1711  write(*,*) 'CalcDred: estimate err_gm imprecise',err_gm(rmax),derr_alt(rmax)
1712  end if
1713 #endif
1714  err_gm=derr_alt
1715 
1716  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1717 
1718 #ifdef Dredtest
1719  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1720  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1721  write(*,*) 'CalcDred after exp method=',drmethod
1722 #endif
1723 #endif
1724 
1725  case (5)
1726  call calcdgpf(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,rmax,gpf,gpf,id,derr1_alt,derr2_alt)
1727 #ifdef PVEST2
1728  derr_alt = derr2_alt
1729 #else
1730  derr_alt = derr1_alt
1731 #endif
1732  dcount(7) = dcount(7)+1
1733  drcalc(0:rmax)=drcalc(0:rmax)+64
1734  dcalc = dcalc+64
1735  drmethod_alt(0:rmax)=64
1736 
1737 #ifdef Dredtest
1738  checkest=derr_alt(rmax)/err_gpf(rmax)
1739  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
1740  write(*,*) 'CalcDred: estimate err_gpf imprecise',err_gpf(rmax),derr_alt(rmax),checkest
1741  end if
1742 #endif
1743  err_gpf=derr_alt
1744 
1745  call copydimp3(d,d_alt,derr,derr_alt,derr1,derr1_alt,derr2,derr2_alt,drmethod,drmethod_alt,rmax,rmax)
1746 
1747 #ifdef Dredtest
1748  write(*,*) 'CalcDred after exp Derr=',derr,err_req_d
1749  write(*,*) 'CalcDred after exp Dacc=',derr/dtyp
1750  write(*,*) 'CalcDred after exp method=',drmethod
1751 #endif
1752 
1753  end select
1754 
1755 ! write(*,*) 'CalcDred Calc',DrCalc(rmax)
1756 
1757 #ifndef USED0
1758 #ifndef ALWAYSPV
1759  ! refine error estimate for D0
1760  if(.not.lerr_d0.and.iexp.ne.0) then
1761 ! D0est = abs(D(0,0,0,0))
1762  err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
1763 ! err_req_D = acc_req_D * abs(D(0,0,0,0))
1764  lerr_d0 = .true.
1765  end if
1766 #endif
1767 #endif
1768 
1769  if (iexp.ne.0) then ! if added 21.11.2016
1770  if (rmax.ge.1) then
1771  dtyp = max(abs(d(0,0,0,0)), &
1772  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
1773  else
1774  dtyp = abs(d(0,0,0,0))
1775  end if
1776  err_req_d = acc_req_d * dtyp
1777 
1778 #ifdef Dredtest
1779  write(*,*) 'CalcDred ',rmax,derr1(rmax),err_req_d
1780 #endif
1781 
1782  if (derr1(rmax).le.err_req_d) then
1783  dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
1784  return
1785  end if
1786  end if
1787 
1788 #ifdef TEST
1789  return
1790 #endif
1791 
1792 #ifdef Dredtest
1793  write(*,*) 'CalcDred no optimal method'
1794  write(*,*) 'err_req_D=',err_req_d
1795  write(*,*) 'err_est=',err_pv(rmax),err_pv2(rmax),err_g(rmax),err_gy(rmax),err_gp(rmax),err_gr(rmax),err_gpf(rmax)
1796 #endif
1797 
1798  ! no method does work optimal
1799  ! use the least problematic (for each rank)
1800  do r=rmax,0,-1
1801 
1802  if(use_pv.and.mod(drcalc(r),2).ne.1) then
1803  ! estimate accuracy of PV-reduction
1804  if (use_pv) then
1805 
1806  if (mod(r,2).eq.1) then
1807  err_pv(r) = max( w_pv**((r-1)/2) * v_pv * err_d0, &
1808  w_pv**((r-1)/2) * z_pv * err_c0, z_pv * err_c(r-1) )
1809 
1810 ! write(*,*) 'CalcDred w_pv: ',w_pv,v_pv,err_D0,r
1811 
1812 ! write(*,*) 'CalcDred err_pv: ',err_pv(r), w_pv**((r-1)/2) * v_pv * err_D0, &
1813 ! w_pv**((r-1)/2) * z_pv * err_C0, z_pv * err_C(r-1)
1814 
1815  else if (r.ne.0) then
1816  err_pv(r) = max( w_pv**(r/2) * err_d0, &
1817  w_pv**(r/2-1) * v_pv * z_pv * err_c0, z_pv * err_c(r-1) )
1818 
1819 ! write(*,*) 'CalcDred err_pv: ',err_pv(r), w_pv**((r)/2) * err_D0, &
1820 ! w_pv**(r/2-1) * v_pv * z_pv * err_C0, z_pv * err_C(r-1)
1821 
1822  else
1823  err_pv(r) = err_d0
1824  end if
1825  end if
1826  ! scale estimates down to allow trying other methods
1827  err_pv(r) = err_pv(r)/impest_d
1828  end if
1829 
1830  if (use_pv2.and.mod(drcalc(r),4)-mod(drcalc(r),2).ne.2) then
1831  ! estimate accuracy of alternative PV-reduction
1832  if (use_pv2) then
1833 
1834 ! write(*,*) 'CalcDred err_pv2', r,w_pv2,v_pv2,z_pv2,err_D0,err_C0
1835 
1836  if (mod(r,2).eq.1) then
1837 ! changed 21.10.15 for PVEST2
1838 ! err_pv2(r) = max( err_D0 * max(w_pv2**r, &
1839 ! w_pv2*v_pv2**((r-1)/2) ), &
1840 ! err_C0 * z_pv2* max(w_pv2**(r+1), &
1841 ! w_pv2*v_pv2**((r-1)/2), &
1842 ! v_pv2**((r+1)/2)), &
1843 ! err_C(r-1) * z_pv2 * max(w_pv2,w_pv2**2,v_pv2) )
1844  err_pv2(r) = max( err_d0 * max(hw_pv2**r, &
1845  hw_pv2*v_pv2**((r-1)/2) ), &
1846  err_c0 * z_pv2* max(w_pv2*w_pv2**(r), &
1847  hw_pv2*v_pv2**((r-1)/2), &
1848  w_pv2*hw_pv2*v_pv2**((r-1)/2), &
1849  v_pv2**((r+1)/2)), &
1850  err_c(r-1) * z_pv2 * max(hw_pv2,w_pv2*hw_pv2**2,v_pv2) )
1851 
1852 
1853 ! write(*,*) 'CalcDred err_pv2: ', &
1854 ! err_pv2(r) , err_D0,err_D0*w_pv2**r,err_D0*v_pv2**((r-1)/2), &
1855 ! err_D0*w_pv2*v_pv2**((r-1)/2), &
1856 ! err_C0 * z_pv2*w_pv2**(r+1), &
1857 ! err_C0 * z_pv2*w_pv2*v_pv2**((r-1)/2), &
1858 ! err_C0 * z_pv2*v_pv2**((r+1)/2), &
1859 ! err_C(r-1), err_C(r-1)*z_pv2*w_pv2, &
1860 ! err_C(r-1)* z_pv2*w_pv2**2, err_C(r-1)*z_pv2*v_pv2
1861 
1862 
1863  else if (r.ne.0) then
1864 ! changed 21.10.15 for PVEST2
1865 ! err_pv2(r) = max( err_D0 * max(w_pv2**r,v_pv2**(r/2)), &
1866 ! err_C0 * z_pv2 * max(w_pv2**(r+1), &
1867 ! v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
1868 ! err_C(r-1) * z_pv2 * max(w_pv2, w_pv2**2, v_pv2) )
1869  err_pv2(r) = max( err_d0 * max(hw_pv2**r,v_pv2**(r/2)), &
1870  err_c0 * z_pv2 * max(w_pv2*hw_pv2**(r), &
1871  v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
1872  err_c(r-1) * z_pv2 * max(hw_pv2, w_pv2*hw_pv2**2, v_pv2) )
1873 
1874 
1875 ! write(*,*) 'CalcDred err_pv2: ', &
1876 ! err_pv2(r) , err_D0 * max(1d0,w_pv2**r,v_pv2**(r/2)), &
1877 ! err_C0 * z_pv2 * max(w_pv2**(r+1),z_pv2*w_pv2, &
1878 ! v_pv2**(r/2),w_pv2*v_pv2**(r/2)), &
1879 ! err_C(r-1) * max(1d0,z_pv2*w_pv2, &
1880 ! z_pv2*w_pv2**2,z_pv2*v_pv2)
1881 
1882  else
1883  err_pv2(r) = err_d0
1884  end if
1885  end if
1886  ! scale estimates down to allow trying other methods
1887  err_pv2(r) = err_pv2(r)/impest_d
1888  end if
1889 
1890  if (mod(drcalc(r),8)-mod(drcalc(r),4).ne.4.and.use_g) then
1891  ! estimate accuracy of alternative Gram expansion
1892  err_g_cr = max( err_c(r), err_c0 * u_g**r ) * z_g
1893  err_g_c = err_g_cr
1894  err_g_exp = u_g**(r-1) * dtyp
1895 
1896  ! determine optimal order of expansion
1897  do i=0,rmax_d-r
1898  g = i
1899  err_g_exp = err_g_exp*fac_g
1900  err_g_c = max(err_g_cr,err_c(r+g)*z_g*x_g**g)
1901  err_g(r) = max(err_g_exp,err_g_c)
1902  if (err_g_exp.lt.err_g_c.or.err_g(r).lt.err_req_d) exit
1903  end do
1904  ! increase g by 2 to account for bad estimates
1905  g = min(max(g+2,2*g),rmax_d-r)
1906  ! scale estimates down to allow trying other methods
1907  err_g(r) = err_g(r)/impest_d
1908  end if
1909 
1910  if (mod(drcalc(r),16)-mod(drcalc(r),8).ne.8.and.use_gy) then
1911  ! estimate accuracy of alternative Gram expansion
1912  err_gy_cr = max( err_c(r) * v1_gy, err_c(r+1) )
1913  err_gy_c = err_gy_cr * b_gy
1914  err_gy_exp = 1d0 * dtyp
1915 
1916  ! determine optimal order of expansion
1917  gy = 0
1918  do i=0,rmax_d-r
1919  if (mod(i,2).eq.1) then
1920  gy = i/2
1921  err_gy_exp = err_gy_exp*fac_gy
1922  err_gy_c = b_gy*max(err_gy_cr, &
1923  max(err_c(r+2*gy)*v1_gy,err_c(r+2*gy+1))*y_gy**gy, &
1924  max(err_c(r+gy)*v1_gy,err_c(r+gy+1))*(max(x_gy,v_gy*y_gy))**gy)
1925  err_gy(r) = max(err_gy_exp,err_gy_c)
1926  if (err_gy_exp.lt.err_gy_c.or.err_gy(r).lt.err_req_d) exit
1927  end if
1928  end do
1929  ! increase gy to account for bad estimates
1930  gy = min(max(gy+2,2*gy),(rmax_d-r)/2)
1931  ! scale estimates down to allow trying other methods
1932  err_gy(r) = err_gy(r)/impest_d
1933  end if
1934 
1935  if (mod(drcalc(r),32)-mod(drcalc(r),16).ne.16.and.use_gp) then
1936  ! estimate accuracy of small momenta expansion
1937  err_gp_cr = max(err_c0*v_gp**r,err_c(r))*z_gp
1938  err_gp_exp = v1_gp**(r-1) * dtyp
1939 
1940  ! determine optimal order of expansion
1941  do i=0,rmax_d-r
1942  gp = i
1943  err_gp_exp = err_gp_exp*fac_gp
1944  err_gp_c = max(err_c(r+gp)*z_gp*w_gp**gp,err_gp_cr)
1945  err_gp(r) = max(err_gp_exp,err_gp_c)
1946  if (err_gp_exp.lt.err_gp_c.or.err_gp(r).lt.err_req_d) exit
1947  end do
1948  ! increase gp to account for bad estimates
1949  gp = min(max(gp+2,3*gp/2),rmax_d-r)
1950  ! scale estimates down to allow trying other methods
1951  err_gp(r) = err_gp(r)/impest_d
1952  end if
1953 
1954  if (mod(drcalc(r),64)-mod(drcalc(r),32).ne.32.and.use_gr) then
1955  ! estimate accuracy of alternative Gram expansion
1956  err_gr_cr = err_c(r)
1957  err_gr_c = err_gr_cr * a_gr
1958  err_gr_exp = y1_gr * dtyp
1959 
1960  ! determine optimal order of expansion
1961  gr = 0
1962  do i=0,min(rmax_d-r,rmax_c-2*r)
1963  if (mod(i,2).eq.1) then
1964  gr = i/2
1965  err_gr_exp = err_gr_exp*fac_gr
1966  err_gr_c = a_gr*max(err_gr_cr, &
1967  max(err_c(r+gr),err_c(r+gr+1)*y_gr)*fac_gr**gr)
1968  err_gr(r) = max(err_gr_exp,err_gr_c)
1969 
1970 #ifdef Dgrtest
1971  write(*,*) 'CalcDgr err_gr',i,gr,err_gr_exp,err_gr_c,err_gr(r),err_req_d
1972 #endif
1973 
1974  if (err_gr_exp.lt.err_gr_c.or.err_gr(r).lt.err_req_d) exit
1975  end if
1976  end do
1977  ! increase gr to account for bad estimates
1978 ! changed 28.07.14
1979 ! gr = min(max(gr+2,2*gr),(rmax_D-r)/2,(rmax_C-2*r)/2)
1980  gr = min(max(gr+2,2*gr),rmax_d-r,max(0,(rmax_c-2*r)/2))
1981  ! scale estimates down to allow trying other methods
1982  err_gr(r) = err_gr(r)/impest_d
1983 
1984  end if
1985 
1986  if (mod(drcalc(r),128)-mod(drcalc(r),64).ne.64.and.use_gpf) then
1987  ! estimate accuracy of small momenta and f expansion
1988  err_gpf_cr = max( err_c(r) * v1_gpf, err_c(r+1) )
1989  err_gpf_c = err_gpf_cr * b_gpf
1990  err_gpf_exp = 1d0 * dtyp
1991 
1992  ! determine optimal order of expansion
1993  gpf = 0
1994  do i=0,rmax_d-r
1995  if (mod(i,2).eq.1) then
1996  gpf = i/2
1997  err_gpf_exp = err_gpf_exp*fac_gpf
1998  err_gpf_c = b_gpf*max(err_gpf_cr, &
1999  max(err_c(r+2*gpf)*v1_gpf,err_c(r+2*gpf+1))*y_gpf**gpf, &
2000  max(err_c(r+gpf)*v1_gpf,err_c(r+gpf+1))*(max(x_gpf,v_gpf*y_gpf))**gpf)
2001  err_gpf(r) = max(err_gpf_exp,err_gpf_c)
2002  if (err_gpf_exp.lt.err_gpf_c.or.err_gpf(r).lt.err_req_d) exit
2003  end if
2004  end do
2005  ! increase gpf to account for bad estimates
2006  gpf = min(max(gpf+2,2*gpf),(rmax_d-r)/2)
2007  ! scale estimates down to allow trying other methods
2008  err_gpf(r) = err_gpf(r)/impest_d
2009  end if
2010 
2011 
2012 
2013 #ifdef USEGM
2014  if (mod(drcalc(r),128)-mod(drcalc(r),64).ne.64.and.use_gm) then
2015  ! estimate accuracy of modified Gram expansion
2016  err_gm_cr = max( err_c(r), err_c0 * u_gm**r ) * z_gm
2017  err_gm_c = err_gm_cr
2018  err_gm_exp = u_gm**(r-1) * dtyp
2019 
2020  ! determine optimal order of expansion
2021  do i=0,rmax_d-r
2022  gm = i
2023  err_gm_exp = err_gm_exp*fac_gm
2024  err_gm_c = max(err_gm_cr,err_c(r+gm)*z_gm*x_gm**gm)
2025  err_gm(r) = max(err_gm_exp,err_gm_c)
2026  if (err_gm_exp.lt.err_gm_c.or.err_gm(r).lt.err_req_d) exit
2027  end do
2028  ! increase gm by 2 to account for bad estimates
2029  gm = min(max(gm+2,2*gm),rmax_d-r)
2030  ! scale estimates down to allow trying other methods
2031  err_gm(r) = err_gm(r)/impest_d
2032  end if
2033 #endif
2034 
2035 
2036 #ifdef Dredtest
2037  write(*,*) 'CalcDred: bef final loop ord methods',r,g,gy,gp,gr,gm,gpf
2038  write(*,*) 'CalcDred: bef final loop err methods',r,err_pv(r),err_pv2(r), &
2039  err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gm(r),err_gpf(r)
2040  write(*,*) 'CalcDred: bef final loop acc methods',r,err_pv(r)/dtyp,err_pv2(r)/dtyp, &
2041  err_g(r)/dtyp,err_gy(r)/dtyp,err_gp(r)/dtyp, &
2042  err_gr(r)/dtyp,err_gm(r)/dtyp,err_gpf(r)/dtyp
2043  write(*,*) 'CalcDred: bef final loop method',r,drcalc(r),drmethod(r)
2044 #endif
2045 
2046 100 continue ! try other methods if error larger than expected
2047  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)) &
2048  .and.min(err_pv(r),err_pv2(r)).lt.err_inf) then
2049 
2050  if (use_pv.and.err_pv(r).le.err_pv2(r).and.mod(drcalc(r),2).ne.1) then
2051 
2052 ! deallocate(D_alt)
2053 ! deallocate(Duv_alt)
2054 ! deallocate(Derr1_alt)
2055 ! deallocate(Derr2_alt)
2056 ! deallocate(Drmethod_alt)
2057 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2058 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2059 ! allocate(Derr1_alt(0:r))
2060 ! allocate(Derr2_alt(0:r))
2061 ! allocate(Drmethod_alt(0:r))
2062 
2063 #ifdef Dredtest
2064  write(*,*) 'CalcDred: call Dpv 2',r,id
2065 #endif
2066 
2067 ! write(*,*) 'CalcDred: Dpv r',r,rmax,p10
2068 ! write(*,*) 'CalcDred: Dpv Duv',size(Duv)
2069 ! write(*,*) 'CalcDred: Dpv Duv_alt',size(Duv_alt)
2070 
2071 
2072  if (r.eq.rmax) then
2073  call calcdpv1(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt,derr2_alt)
2074  else
2075  call calcdpv1(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2076  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt(0:r),derr2_alt(0:r))
2077  end if
2078 #ifdef PVEST2
2079  derr_alt = derr2_alt
2080 #else
2081  derr_alt = derr1_alt
2082 #endif
2083  dcount(11) = dcount(11)+1
2084  drcalc(0:r)=drcalc(0:r)+1
2085  dcalc = dcalc+1
2086  drmethod_alt(0:r)=1
2087  checkest=derr_alt(r)/err_pv(r)
2088 
2089 #ifdef Dredtest
2090  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2091  write(*,*) 'CalcDred: estimate err_pv imprecise',err_pv(r),derr_alt(r)
2092  end if
2093 #endif
2094 
2095 #ifdef Dredtest
2096  write(*,*) 'final loop r Dpv D(1,0,1,0)',r,d_alt(1,0,1,0),d(1,0,1,0)
2097  write(*,*) 'final loop r Dpv Derr',derr_alt(2),derr(2)
2098 #endif
2099  err_pv(0:r)=derr_alt(0:r)
2100 
2101  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2102  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2103 
2104  if (rmax.ge.1) then
2105  dtyp = max(abs(d(0,0,0,0)), &
2106  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2107  else
2108  dtyp = abs(d(0,0,0,0))
2109  end if
2110  err_req_d = acc_req_d * dtyp
2111 
2112 #ifdef Dredtest
2113  write(*,*) 'CalcDred: after pv 2nd try Dmethod_alt=',drmethod_alt
2114  write(*,*) 'CalcDred: after pv 2nd try Derr_alt(r)=',derr_alt
2115  write(*,*) 'CalcDred: after pv 2nd try Dacc_alt(r)=',derr_alt/dtyp
2116  write(*,*) 'CalcDred: after pv 2nd try Dmethod=',drmethod
2117  write(*,*) 'CalcDred: after pv 2nd try Derr(r)=',derr
2118  write(*,*) 'CalcDred: after pv 2nd try Dacc(r)=',derr/dtyp
2119 #endif
2120 
2121 #ifdef Dredtest
2122 ! if(r.gt.2)then
2123 ! write(*,*) 'after CalcDpv D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
2124 ! endif
2125 #endif
2126  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2127 
2128  elseif (use_pv2.and.err_pv2(r).le.err_pv(r).and.mod(drcalc(r),4)-mod(drcalc(r),2).ne.2) then
2129 
2130 ! deallocate(D_alt)
2131 ! deallocate(Duv_alt)
2132 ! deallocate(Derr_alt)
2133 ! deallocate(Derr2_alt)
2134 ! deallocate(Drmethod_alt)
2135 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2136 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2137 ! allocate(Derr_alt(0:r))
2138 ! allocate(Derr2_alt(0:r))
2139 ! allocate(Drmethod_alt(0:r))
2140 
2141 #ifdef Dredtest
2142  write(*,*) 'CalcDred: call Dpv2 2',r,id
2143 #endif
2144  if (r.eq.rmax) then
2145  call calcdpv2(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt,derr2_alt)
2146  else
2147  call calcdpv2(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2148  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,id,derr1_alt(0:r),derr2_alt(0:r))
2149  end if
2150 
2151 #ifdef PVEST2
2152  derr_alt = derr2_alt
2153 #else
2154  derr_alt = derr1_alt
2155 #endif
2156  dcount(12) = dcount(12)+1
2157  drcalc(0:r)=drcalc(0:r)+2
2158  dcalc = dcalc+2
2159  drmethod_alt(0:r)=2
2160  checkest=derr_alt(r)/err_pv2(r)
2161 
2162 #ifdef Dredtest
2163  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2164  write(*,*) 'CalcDred: estimate err_pv2 imprecise',err_pv2(r),derr_alt(r)
2165  end if
2166 #endif
2167  err_pv2(0:r)=derr_alt(0:r)
2168 
2169 #ifdef Dredtest
2170  if(r.ge.2) then
2171  write(*,*) 'final loop r Dpv2 D(1,0,1,0)',r,d_alt(1,0,1,0),d(1,0,1,0)
2172  write(*,*) 'final loop r Dpv2 Derr',derr_alt(2),derr(2)
2173  endif
2174 #endif
2175  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2176  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2177 
2178  if (rmax.ge.1) then
2179  dtyp = max(abs(d(0,0,0,0)), &
2180  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2181  else
2182  dtyp = abs(d(0,0,0,0))
2183  end if
2184  err_req_d = acc_req_d * dtyp
2185 
2186  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2187 
2188 #ifdef Dredtest
2189  write(*,*) 'CalcDred: after pv 2nd try Dmethod=',drmethod
2190  write(*,*) 'CalcDred: after pv 2nd try Derr(r)=',derr
2191  write(*,*) 'CalcDred: after pv 2nd try Dacc(r)=',derr/dtyp
2192 #endif
2193 
2194  end if
2195 
2196  else
2197 
2198 #ifdef Dredtest
2199  write(*,*) 'CalcDred: explore exps once more'
2200 #endif
2201 
2202  if (use_g.and.err_g(r).le.min(err_gy(r),err_gp(r),err_gr(r),err_gpf(r)) &
2203  .and.mod(drcalc(r),8)-mod(drcalc(r),4).ne.4) then
2204 
2205 ! deallocate(D_alt)
2206 ! deallocate(Duv_alt)
2207 ! deallocate(Derr_alt)
2208 ! deallocate(Derr2_alt)
2209 ! deallocate(Drmethod_alt)
2210 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2211 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2212 ! allocate(Derr_alt(0:r))
2213 ! allocate(Derr2_alt(0:r))
2214 ! allocate(Drmethod_alt(0:r))
2215 
2216  if (r.eq.rmax) then
2217  call calcdg(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt,derr2_alt)
2218  else
2219  call calcdg(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2220  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
2221  end if
2222 #ifdef PVEST2
2223  derr_alt = derr2_alt
2224 #else
2225  derr_alt = derr1_alt
2226 #endif
2227  dcount(13) = dcount(13)+1
2228  drcalc(0:r)=drcalc(0:r)+4
2229  dcalc = dcalc+4
2230  drmethod_alt(0:r)=4
2231  checkest=derr_alt(r)/err_g(r)
2232 
2233 #ifdef Dredtest
2234  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2235  write(*,*) 'CalcDred: estimate err_g imprecise ',err_g(r),derr_alt(r)
2236  end if
2237 #endif
2238 
2239  err_g(0:r)=derr_alt(0:r)
2240 
2241  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2242  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2243 
2244  if (rmax.ge.1) then
2245  dtyp = max(abs(d(0,0,0,0)), &
2246  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2247  else
2248  dtyp = abs(d(0,0,0,0))
2249  end if
2250  err_req_d = acc_req_d * dtyp
2251 
2252 #ifdef Dredtest
2253  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2254  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2255  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2256 #endif
2257 
2258 #ifdef Dredtest
2259 ! if(r.gt.2)then
2260 ! write(*,*) 'after CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
2261 ! endif
2262 #endif
2263 
2264  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2265 
2266  else if (use_gy.and.err_gy(r).le.min(err_g(r),err_gp(r),err_gr(r),err_gpf(r)) &
2267  .and.mod(drcalc(r),16)-mod(drcalc(r),8).ne.8) then
2268 
2269 ! deallocate(D_alt)
2270 ! deallocate(Duv_alt)
2271 ! deallocate(Derr_alt)
2272 ! deallocate(Derr2_alt)
2273 ! deallocate(Drmethod_alt)
2274 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2275 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2276 ! allocate(Derr_alt(0:r))
2277 ! allocate(Derr2_alt(0:r))
2278 ! allocate(Drmethod_alt(0:r))
2279 
2280  if (r.eq.rmax) then
2281  call calcdgy(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gy,(rmax_d)/2,id,derr1_alt,derr2_alt)
2282  else
2283  call calcdgy(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2284  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gy,(rmax_d)/2,id,derr1_alt(0:r),derr2_alt(0:r))
2285  end if
2286 #ifdef PVEST2
2287  derr_alt = derr2_alt
2288 #else
2289  derr_alt = derr1_alt
2290 #endif
2291  dcount(14) = dcount(14)+1
2292  drcalc(0:r)=drcalc(0:r)+8
2293  dcalc = dcalc+8
2294  drmethod_alt(0:r)=8
2295  checkest=derr_alt(r)/err_gy(r)
2296 
2297 #ifdef Dredtest
2298  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2299  write(*,*) 'CalcDred: estimate err_gy imprecise',err_gy(r),derr_alt(r)
2300  end if
2301 #endif
2302 
2303  err_gy(0:r)=derr_alt(0:r)
2304 
2305  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2306  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2307 
2308  if (rmax.ge.1) then
2309  dtyp = max(abs(d(0,0,0,0)), &
2310  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2311  else
2312  dtyp = abs(d(0,0,0,0))
2313  end if
2314  err_req_d = acc_req_d * dtyp
2315 
2316 #ifdef Dredtest
2317  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2318  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2319  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2320 #endif
2321 
2322 #ifdef Dredtest
2323 ! if(rmax.ge.3)then
2324 ! write(*,*) 'after CalcDgy D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
2325 ! endif
2326 #endif
2327 
2328  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2329 
2330  elseif (use_gp.and.err_gp(r).le.min(err_g(r),err_gy(r),err_gr(r),err_gpf(r)) &
2331  .and.mod(drcalc(r),32)-mod(drcalc(r),16).ne.16) then
2332 
2333 ! deallocate(D_alt)
2334 ! deallocate(Duv_alt)
2335 ! deallocate(Derr_alt)
2336 ! deallocate(Derr2_alt)
2337 ! deallocate(Drmethod_alt)
2338 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2339 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2340 ! allocate(Derr_alt(0:r))
2341 ! allocate(Derr2_alt(0:r))
2342 ! allocate(Drmethod_alt(0:r))
2343 
2344  if (r.eq.rmax) then
2345  call calcdgp(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gp,rmax_d,id,derr1_alt,derr2_alt)
2346  else
2347  call calcdgp(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2348  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gp,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
2349  endif
2350 #ifdef PVEST2
2351  derr_alt = derr2_alt
2352 #else
2353  derr_alt = derr1_alt
2354 #endif
2355  dcount(15) = dcount(15)+1
2356  drcalc(0:r)=drcalc(0:r)+16
2357  dcalc = dcalc+16
2358  drmethod_alt(0:r)=16
2359  checkest=derr_alt(r)/err_gp(r)
2360 
2361 #ifdef Dredtest
2362  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2363  write(*,*) 'CalcDred: estimate err_gp imprecise',err_gp(r),derr_alt(r)
2364  end if
2365 #endif
2366 
2367  err_gp(0:r)=derr_alt(0:r)
2368 
2369  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2370  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2371 
2372  if (rmax.ge.1) then
2373  dtyp = max(abs(d(0,0,0,0)), &
2374  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2375  else
2376  dtyp = abs(d(0,0,0,0))
2377  end if
2378  err_req_d = acc_req_d * dtyp
2379 
2380 #ifdef Dredtest
2381  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2382  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2383  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2384 #endif
2385 
2386  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2387 
2388  elseif (use_gr.and.err_gr(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gpf(r)) &
2389  .and.mod(drcalc(r),64)-mod(drcalc(r),32).ne.32) then
2390 
2391 ! deallocate(D_alt)
2392 ! deallocate(Duv_alt)
2393 ! deallocate(Derr_alt)
2394 ! deallocate(Derr2_alt)
2395 ! deallocate(Drmethod_alt)
2396 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2397 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2398 ! allocate(Derr_alt(0:r))
2399 ! allocate(Derr2_alt(0:r))
2400 ! allocate(Drmethod_alt(0:r))
2401 
2402  if (r.eq.rmax) then
2403  call calcdgr(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gr,rmax_d,id,derr1_alt,derr2_alt)
2404  else
2405  call calcdgr(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2406  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gr,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
2407  endif
2408 #ifdef PVEST2
2409  derr_alt = derr2_alt
2410 #else
2411  derr_alt = derr1_alt
2412 #endif
2413  dcount(16) = dcount(16)+1
2414  drcalc(0:r)=drcalc(0:r)+32
2415  dcalc = dcalc+32
2416  drmethod_alt(0:r)=32
2417  checkest=derr_alt(r)/err_gr(r)
2418 
2419 #ifdef Dredtest
2420  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2421  write(*,*) 'CalcDred: estimate err_gr imprecise',err_gr(r),derr_alt(r)
2422  end if
2423 #endif
2424 
2425  err_gr(0:r)=derr_alt(0:r)
2426 
2427  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2428  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2429 
2430  if (rmax.ge.1) then
2431  dtyp = max(abs(d(0,0,0,0)), &
2432  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2433  else
2434  dtyp = abs(d(0,0,0,0))
2435  end if
2436  err_req_d = acc_req_d * dtyp
2437 
2438 #ifdef Dredtest
2439  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2440  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2441  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2442 #endif
2443 
2444  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2445 
2446 
2447 #ifdef Dredtest
2448 ! if(r.gt.2)then
2449 ! write(*,*) 'CalcDred D(1,0,1,0)',r,D(1,0,1,0)
2450 ! endif
2451 #endif
2452 
2453  else if (use_gpf.and.err_gpf(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gr(r)) &
2454  .and.mod(drcalc(r),128)-mod(drcalc(r),64).ne.64) then
2455 
2456  if (r.eq.rmax) then
2457  call calcdgpf(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gpf,(rmax_d)/2,id,derr1_alt,derr2_alt)
2458  else
2459  call calcdgpf(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2460  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,gpf,(rmax_d)/2,id,derr1_alt(0:r),derr2_alt(0:r))
2461  end if
2462 #ifdef PVEST2
2463  derr_alt = derr2_alt
2464 #else
2465  derr_alt = derr1_alt
2466 #endif
2467  dcount(17) = dcount(17)+1
2468  drcalc(0:r)=drcalc(0:r)+64
2469  dcalc = dcalc+64
2470  drmethod_alt(0:r)=64
2471  checkest=derr_alt(r)/err_gpf(r)
2472 
2473 #ifdef Dredtest
2474  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2475  write(*,*) 'CalcDred: estimate err_gpf imprecise',err_gpf(r),derr_alt(r)
2476  end if
2477 #endif
2478 
2479  err_gpf(0:r)=derr_alt(0:r)
2480  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2481  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2482 
2483  if (rmax.ge.1) then
2484  dtyp = max(abs(d(0,0,0,0)), &
2485  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2486  else
2487  dtyp = abs(d(0,0,0,0))
2488  end if
2489  err_req_d = acc_req_d * dtyp
2490 
2491 #ifdef Dredtest
2492  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2493  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2494  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2495 #endif
2496 
2497 #ifdef Dredtest
2498 ! if(rmax.ge.3)then
2499 ! write(*,*) 'after CalcDgpf D(1,0,0,0)',r,D_alt(1,0,0,0),D(1,0,0,0)
2500 ! endif
2501 #endif
2502 
2503  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2504 
2505 #ifdef USEGM
2506  else if (use_gm.and.err_gm(r).le.min(err_gy(r),err_gp(r),err_gr(r),err_g(r)) &
2507  .and.mod(drcalc(r),128)-mod(drcalc(r),64).ne.64) then
2508 
2509 ! deallocate(D_alt)
2510 ! deallocate(Duv_alt)
2511 ! deallocate(Derr_alt)
2512 ! deallocate(Derr2_alt)
2513 ! deallocate(Drmethod_alt)
2514 ! allocate(D_alt(0:r,0:r,0:r,0:r))
2515 ! allocate(Duv_alt(0:r,0:r,0:r,0:r))
2516 ! allocate(Derr_alt(0:r))
2517 ! allocate(Derr2_alt(0:r))
2518 ! allocate(Drmethod_alt(0:r))
2519 
2520  if (r.eq.rmax) then
2521  call calcdgm(d_alt,duv,p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt,derr2_alt)
2522  else
2523  call calcdgm(d_alt(0:r,0:r,0:r,0:r),duv_alt(0:r,0:r,0:r,0:r), &
2524  p10,p21,p32,p30,p20,p31,m02,m12,m22,m32,r,g,rmax_d,id,derr1_alt(0:r),derr2_alt(0:r))
2525  end if
2526 #ifdef PVEST2
2527  derr_alt = derr2_alt
2528 #else
2529  derr_alt = derr1_alt
2530 #endif
2531  dcount(17) = dcount(17)+1
2532  drcalc(0:r)=drcalc(0:r)+64
2533  dcalc = dcalc+64
2534  drmethod_alt(0:r)=64
2535  checkest=derr_alt(r)/err_gm(r)
2536 
2537 #ifdef Dredtest
2538  if(checkest.gt.1d2*impest_d.or.checkest.lt.1d-2*impest_d) then
2539  write(*,*) 'CalcDred: estimate err_g imprecise ',err_gm(r),derr_alt(r)
2540  end if
2541 #endif
2542 
2543  err_gm(0:r)=derr_alt(0:r)
2544 
2545  call copydimp3(d,d_alt(0:r,0:r,0:r,0:r),derr,derr_alt(0:r),derr1,derr1_alt(0:r), &
2546  derr2,derr2_alt(0:r),drmethod,drmethod_alt(0:r),rmax,r)
2547 
2548  if (rmax.ge.1) then
2549  dtyp = max(abs(d(0,0,0,0)), &
2550  abs(d(0,1,0,0)),abs(d(0,0,1,0)),abs(d(0,0,0,1)))
2551  else
2552  dtyp = abs(d(0,0,0,0))
2553  end if
2554  err_req_d = acc_req_d * dtyp
2555 
2556 #ifdef Dredtest
2557  write(*,*) 'CalcDred: after exp 2nd try Dmethod=',drmethod
2558  write(*,*) 'CalcDred: after exp 2nd try Derr(r)=',derr
2559  write(*,*) 'CalcDred: after exp 2nd try Dacc(r)=',derr/dtyp
2560 #endif
2561 
2562 #ifdef Dredtest
2563 ! if(r.gt.2)then
2564 ! write(*,*) 'after CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
2565 ! endif
2566 #endif
2567 
2568  if(checkest.gt.impest_d.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2569 #endif
2570 
2571  end if
2572  end if
2573 
2574 #ifndef USED0
2575 #ifndef ALWAYSPV
2576  ! refine error estimate for D0
2577  if(.not.lerr_d0) then
2578 ! D0est = abs(D(0,0,0,0))
2579  err_d0 = acc_def_d0*max( abs(d(0,0,0,0)), 1d0/sqrt(adetx) )
2580 ! err_req_D = acc_req_D * abs(D(0,0,0,0))
2581  lerr_d0 = .true.
2582  end if
2583 #endif
2584 #endif
2585 
2586 #ifdef Dredtest
2587 ! if(r.ge.2) then
2588 ! write(*,*) 'after r CalcDg D(1,0,1,0)',r,D_alt(1,0,1,0),D(1,0,1,0)
2589 ! write(*,*) 'after r CalcDg Derr',Derr_alt(2),Derr(2)
2590 ! endif
2591 #endif
2592 
2593 
2594 #ifdef Dredtest
2595  write(*,*) 'CalcDred: final loop err methods',r,err_pv(r),err_pv2(r), &
2596  err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gm(r),err_gpf(r)
2597  write(*,*) 'CalcDred: final loop acc methods',r,err_pv(r)/dtyp,err_pv2(r)/dtyp, &
2598  err_g(r)/dtyp,err_gy(r)/dtyp,err_gp(r)/dtyp, &
2599  err_gr(r)/dtyp,err_gm(r)/dtyp,err_gpf(r)/dtyp
2600  write(*,*) 'CalcDred: final loop method',r,drcalc(r),drmethod(r)
2601 #endif
2602 
2603  end do
2604 
2605  norm = abs(d(0,0,0,0))
2606 
2607  do r=1,rmax
2608  do n1=0,rmax
2609  do n2=0,rmax-n1
2610  n3 = rmax-n1-n2
2611  norm = max(norm,abs(d(0,n1,n2,n3)))
2612  end do
2613  end do
2614  end do
2615  acc_d = derr(rmax)/norm
2616 
2617  dcount(dcalc+dcountoffset0) = dcount(dcalc+dcountoffset0)+1
2618 
2619 #ifdef Dredtest
2620  write(*,*) 'CalcDred final err_D=',derr
2621  write(*,*) 'CalcDred final acc_D=',derr/norm,critacc_coli
2622  write(*,*) 'CalcDred final method_D=',drmethod
2623 #endif
2624 
2625  if (acc_d.gt.sqrt(reqacc_coli)) then
2626  dcount(dcalc+dcountoffset3) = dcount(dcalc+dcountoffset3)+1
2627  end if
2628 
2629  if (acc_d.gt.reqacc_coli) then
2630  dcount(dcalc+dcountoffset1) = dcount(dcalc+dcountoffset1)+1
2631  end if
2632 
2633  if (acc_d.gt.critacc_coli) then
2634 
2635  dcount(dcalc+dcountoffset2) = dcount(dcalc+dcountoffset2)+1
2636 
2637 #ifdef Dredtest
2638  write(*,*) 'CritPoint D',critacc_coli,acc_d
2639  write(*,*) 'CritPoint D',critpointcntd,maxcritpointd
2640 #endif
2641 
2642 ! call SetErrFlag_coli(-5)
2643 ! call ErrOut_coli('CalcDred',' critical accuracy not reached', &
2644 ! errorwriteflag)
2645 
2646 #ifdef CritPointsCOLI
2647  critpointcntd = critpointcntd + 1
2648 
2649  if (critpointcntd.le.maxcritpointd.and.monitoring) then
2650 
2651  call critpointsout_coli('D_coli',acc_d)
2652  write(ncpout_coli,*) 'arguments of CalcDred_coli:'
2653  write(ncpout_coli,*) 'rank = ', rmax
2654  write(ncpout_coli,fmt1) 'p10 = ', p10
2655  write(ncpout_coli,fmt1) 'p21 = ', p21
2656  write(ncpout_coli,fmt1) 'p32 = ', p32
2657  write(ncpout_coli,fmt1) 'p30 = ', p30
2658  write(ncpout_coli,fmt1) 'p20 = ', p20
2659  write(ncpout_coli,fmt1) 'p31 = ', p31
2660  write(ncpout_coli,fmt1) 'm02 = ', m02
2661  write(ncpout_coli,fmt1) 'm12 = ', m12
2662  write(ncpout_coli,fmt1) 'm22 = ', m22
2663  write(ncpout_coli,fmt1) 'm32 = ', m32
2664  if (critpointcntd.eq.maxcritpointd) then
2665  write(ncpout_coli,*)
2666  write(ncpout_coli,*)
2667  write(ncpout_coli,*)
2668  write(ncpout_coli,*) '***********************************************************'
2669  write(ncpout_coli,*)
2670  write(ncpout_coli,*) ' Further output of bad D functions will be suppressed '
2671  end if
2672  end if
2673 #endif
2674  end if
2675 
2676 #ifdef Dredtest
2677  write(*,*) 'CalcDred exit D(1,0,0,0)',r,d_alt(1,0,0,0),d(1,0,0,0)
2678 #endif
2679 

◆ calcduv()

subroutine reductiond::calcduv ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(inout)  Duv,
double complex, dimension(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1), intent(in)  Cuv_0,
double complex, intent(in)  m02,
double complex, dimension(3), intent(in)  f,
integer, intent(in)  rmax,
integer, intent(in)  id 
)

Definition at line 2694 of file reductionD.F90.

2694 
2695  integer, intent(in) :: rmax,id
2696  double complex, intent(in) :: m02,f(3)
2697  double complex, intent(inout) :: Duv(0:rmax,0:rmax,0:rmax,0:rmax)
2698  double complex, intent(in) :: Cuv_0(0:rmax-1,0:rmax-1,0:rmax-1,0:rmax-1)
2699  integer :: r,n0,n1,n2,n3
2700 
2701  ! D_(n0,n1,n2,n3) UV-finite for n0<2
2702  duv(0:min(rmax,1),:,:,:) = 0d0
2703 
2704  ! PV reduction (5.10)
2705 ! do r=4,rmax
2706 ! do n0=2,r/2
2707  do r=4,rmax+1
2708  do n0=max(2,r-rmax),r/2
2709  do n1=0,r-2*n0
2710  do n2=0,r-2*n0-n1
2711  n3 = r-2*n0-n1-n2
2712 
2713  duv(n0,n1,n2,n3) = (cuv_0(n0-1,n1,n2,n3) + 2*m02*duv(n0-1,n1,n2,n3) &
2714  + f(1)*duv(n0-1,n1+1,n2,n3) &
2715  + f(2)*duv(n0-1,n1,n2+1,n3) &
2716  + f(3)*duv(n0-1,n1,n2,n3+1)) / (2*(r-1))
2717 
2718  end do
2719  end do
2720  end do
2721  end do
2722 

◆ copydimp3()

subroutine reductiond::copydimp3 ( double complex, dimension(0:rmax,0:rmax,0:rmax,0:rmax), intent(inout)  D,
double complex, dimension(0:r_alt,0:r_alt,0:r_alt,0:r_alt), intent(in)  D_alt,
double precision, dimension(0:rmax), intent(inout)  Derr,
double precision, dimension(0:r_alt), intent(in)  Derr_alt,
double precision, dimension(0:rmax), intent(inout)  Derr1,
double precision, dimension(0:r_alt), intent(in)  Derr1_alt,
double precision, dimension(0:rmax), intent(inout)  Derr2,
double precision, dimension(0:r_alt), intent(in)  Derr2_alt,
integer, dimension(0:rmax), intent(inout)  Drmethod,
integer, dimension(0:r_alt), intent(in)  Drmethod_alt,
integer, intent(in)  rmax,
integer, intent(in)  r_alt 
)

Definition at line 9800 of file reductionD.F90.

9800 
9801  integer, intent(in) :: rmax,r_alt
9802  double complex, intent(inout) :: D(0:rmax,0:rmax,0:rmax,0:rmax)
9803  double precision, intent(inout) :: Derr(0:rmax),Derr1(0:rmax),Derr2(0:rmax)
9804  integer, intent(inout) :: Drmethod(0:rmax)
9805  double complex, intent(in) :: D_alt(0:r_alt,0:r_alt,0:r_alt,0:r_alt)
9806  double precision, intent(in) :: Derr_alt(0:r_alt),Derr1_alt(0:r_alt),Derr2_alt(0:r_alt)
9807  integer, intent(in) :: Drmethod_alt(0:r_alt)
9808 
9809  integer :: r,n1,n2,n0
9810 
9811  do r=0,r_alt
9812  if (derr_alt(r).lt.derr(r)) then
9813  drmethod(r)=drmethod_alt(r)
9814  derr(r)=derr_alt(r)
9815  derr1(r)=derr1_alt(r)
9816  derr2(r)=derr2_alt(r)
9817  forall (n0=0:r/2)
9818  forall (n1=0:2*r-n0)
9819  forall (n2=0:r-2*n0-n1)
9820  d(n0,n1,n2,r-2*n0-n1-n2) = d_alt(n0,n1,n2,r-2*n0-n1-n2)
9821  end forall
9822  end forall
9823  end forall
9824  forall (n0=1:(r+1)/2)
9825  forall (n1=0:r+1-2*n0)
9826  forall (n2=0:r+1-2*n0-n1)
9827  d(n0,n1,n2,r+1-2*n0-n1-n2) = d_alt(n0,n1,n2,r+1-2*n0-n1-n2)
9828  end forall
9829  end forall
9830  end forall
9831 ! forall (n0=0:r)
9832 ! forall (n1=0:r-n0)
9833 ! forall (n2=0:r-n0-n1)
9834 ! D(n0,n1,n2,r-n0-n1-n2) = D_alt(n0,n1,n2,r-n0-n1-n2)
9835 ! end forall
9836 ! end forall
9837 ! end forall
9838 ! forall (n1=0:r)
9839 ! forall (n2=0:r-n1)
9840 ! forall (n3=0:r-n1-n2)
9841 ! D((r-n1-n2-n3)/2,n1,n2,n3) = D_alt((r-n1-n2-n3)/2,n1,n2,n3)
9842 ! end forall
9843 ! end forall
9844 ! end forall
9845  end if
9846  end do
9847 

Variable Documentation

◆ truncfacd

double precision, parameter reductiond::truncfacd = 1d2

Definition at line 80 of file reductionD.F90.

80  double precision, parameter :: truncfacD = 1d2
globald::q32
double complex q32
Definition: reductionD.F90:48
globalc::detzmzadjf
double complex detzmzadjf
Definition: reductionC.F90:52
globalc::azadjff
double precision azadjff
Definition: reductionC.F90:51
globald::q31
double complex q31
Definition: reductionD.F90:48
globalc::fmax
double precision fmax
Definition: reductionC.F90:51
globald::mm32
double complex mm32
Definition: reductionD.F90:48
globald
Definition: reductionD.F90:46
globalc::xadj
double complex, dimension(0:2, 0:2) xadj
Definition: reductionC.F90:50
globalc::maxzadjf
double precision maxzadjf
Definition: reductionC.F90:51
globalc::m2max
double precision m2max
Definition: reductionC.F90:51
globald::zadj2ff
double complex, dimension(3, 3) zadj2ff
Definition: reductionD.F90:51
globald::q30
double complex q30
Definition: reductionD.F90:48
globalc::fac_gy
double precision fac_gy
Definition: reductionC.F90:55
globalc::m2scale
double precision m2scale
Definition: reductionC.F90:51
globalc::zadjf
double complex, dimension(2) zadjf
Definition: reductionC.F90:50
globalc::fac_gr
double precision fac_gr
Definition: reductionC.F90:55
globalc::q10
double complex q10
Definition: reductionC.F90:49
globald::x_gm
double precision x_gm
Definition: reductionD.F90:57
globalc::maxz
double precision maxz
Definition: reductionC.F90:51
globalc::maxzadjfd
double precision maxzadjfd
Definition: reductionC.F90:51
globalc::q2max
double precision q2max
Definition: reductionC.F90:51
globalc::detx
double complex detx
Definition: reductionC.F90:50
globalc::fac_gpf
double precision fac_gpf
Definition: reductionC.F90:55
globalc::fac_gp
double precision fac_gp
Definition: reductionC.F90:55
globalc::q20
double complex q20
Definition: reductionC.F90:49
globalc::mx
double complex, dimension(0:2, 0:2) mx
Definition: reductionC.F90:53
globalc::maxxadj
double precision maxxadj
Definition: reductionC.F90:51
globalc::zadj
double complex, dimension(2, 2) zadj
Definition: reductionC.F90:50
globalc::maxzadj
double precision maxzadj
Definition: reductionC.F90:54
globald::zadjff
double complex zadjff
Definition: reductionD.F90:52
globalc::zinv
double complex, dimension(2, 2) zinv
Definition: reductionC.F90:52
globald::maxzadj2ff
double precision maxzadj2ff
Definition: reductionD.F90:55
globalc::fac_g
double precision fac_g
Definition: reductionC.F90:55
globalc::adetx
double precision adetx
Definition: reductionC.F90:51
globald::fac_gm
double precision fac_gm
Definition: reductionD.F90:57
globalc::zadjs
double complex, dimension(2) zadjs
Definition: reductionC.F90:52
globalc::adetz
double precision adetz
Definition: reductionC.F90:51
globalc::mm22
double complex mm22
Definition: reductionC.F90:49
globalc::z
double complex, dimension(2, 2) z
Definition: reductionC.F90:50
globalc::q21
double complex q21
Definition: reductionC.F90:49
globalc::mxinv
double complex, dimension(0:2, 0:2) mxinv
Definition: reductionC.F90:53
globald::undefined_d
double complex, parameter undefined_d
Definition: reductionD.F90:64
globalc::detz
double complex detz
Definition: reductionC.F90:50