JHUGen MELA  JHUGen v7.5.6, MELA v2.4.2
Matrix element calculations as used in JHUGen.
reductionC.F90
Go to the documentation of this file.
1 !!
2 !! File reductionC.F90 is part of COLLIER
3 !! - A Complex One-Loop Library In Extended Regularizations
4 !!
5 !! Copyright (C) 2015, 2016 Ansgar Denner, Stefan Dittmaier, Lars Hofer
6 !!
7 !! COLLIER is licenced under the GNU GPL version 3, see COPYING for details.
8 !!
9 
10 !#define Credtest
11 !#define Cpvtest
12 !#define Cpv1test
13 !#define Cpv1otest
14 !#define Cpv2test
15 !#define Cpvshifttest
16 !#define Cgtest
17 !#define Cgytest
18 !#define Cgrtest
19 !#define Cgptest
20 !#define Cgpftest
21 #define ALWAYSPV ! default
22 !#define USEC0
23 !#define PPEXP00
24 #define Cutrloop ! default
25 !#define TRACECin
26 !#define TRACECout
27 !#define CritPointsCOLI
28 #define PVEST2 ! default
29 
30 #define PVSHIFT
31 !#define TEST
32 !#define Cgntest
33 
34 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
35 !
36 ! ***********************
37 ! * module reductionC *
38 ! * by Lars Hofer *
39 ! * adapted by A Denner *
40 ! ***********************
41 !
42 ! functions and subroutines:
43 ! CalcCuv, CalcCpv, CalcCpv2, CalcCg, CalcCgy, CalcCgp, CalcCgr, CalcCgpf, CopyCimp3
44 !
45 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
46 
47 module globalc
48 
49  double complex :: q10,q21,q20,mm02,mm12,mm22
50  double complex :: detz,z(2,2),zadj(2,2),f(2),zadjf(2),xadj(0:2,0:2),detx
51  double precision :: q2max,m2max,m2scale,adetz,adetx,fmax,maxzadjf,maxzadjfd,maxxadj,azadjff,maxz
52  double complex :: zinv(2,2),zadjs(2),detzmzadjf
53  double complex :: mx(0:2,0:2), mxinv(0:2,0:2)
54  double precision :: maxzadj
55  double precision :: fac_g,fac_gy,fac_gp,fac_gr,fac_gpf
56  double precision :: wmaxzadj,wmaxzadjf,wmaxxadj
57 
58  double complex :: q10shift,q21shift,q20shift,mm02shift,mm12shift,mm22shift
59  double precision :: adetzshift,adetxshift,fmaxshift,maxzadjfshift,azadjffshift,maxzshift
60  double complex :: detzshift,zshift(2,2),zadjshift(2,2),fshift(2),zadjfshift(2),xadjshift(0:2,0:2),detxshift
61  double complex :: zinvshift(2,2),zadjsshift(2),detzmzadjfshift
62  double complex :: mxshift(0:2,0:2), mxinvshift(0:2,0:2)
63  double precision :: maxzadjshift
64 
65  double complex, parameter :: undefined_c=1d50
66 
67 end module globalc
68 
69 
70 
71 
72 
73 module reductionc
74 
75  use coli_stat
76  use reductionab
77 
78  implicit none
79 
80 
81  ! should not be too small since expansion for large expansion parameters are calculated to early
82  double precision, parameter :: truncfacc = 1d2
83  ! double precision, parameter :: truncfacC = 1d3 worse than 1d2?
84 ! double precision, parameter :: acc_C=1d-13
85 
86 contains
87 
88 
89  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
90  ! subroutine CalcC(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
91  !
92  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
93 
94  subroutine calcc(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
95 
96  integer, intent(in) :: rmax, id
97  integer, optional, intent(in) :: rbasic
98  double precision, optional, intent(in) :: acc_req_Cextra(0:rmax)
99  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
100  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
101  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
102  double precision, intent(out) :: Cerr1(0:rmax),Cerr2(0:rmax)
103  double complex, allocatable :: Caux(:,:,:), Cuvaux(:,:,:), fct(:)
104  double precision, allocatable :: Cerr1aux(:),Cerr2aux(:)
105  double complex :: x(6)
106  integer :: rank,switch,cnt,n0,n1,n2,r,rb
107  logical :: nocalc,wrica
108 
109 #ifdef TRACECin
110  write(*,*) 'CalcC in ',rmax,id
111 #endif
112 
113  if (use_cache_system) then
114  if ((ncache.gt.0).and.(ncache.le.ncache_max)) then
115 ! if (use_cache(ncache).ge.3) then
116  x(1)=p10
117  x(2)=p21
118  x(3)=p20
119  x(4)=m02
120  x(5)=m12
121  x(6)=m22
122  rank = rmax
123  switch = 0
124 
125  if(rmax.ge.1) then
126  allocate(fct(ncoefsg(rmax,3)+ncoefsg(rmax-1,3)+2*(rmax+2)))
127  call readcache(fct,ncoefsg(rmax,3)+ncoefsg(rmax-1,3)+2*(rmax+2),x,6,1,id,3,rank,nocalc,wrica)
128  else
129  allocate(fct(ncoefsg(rmax,3)+2*(rmax+2)))
130  call readcache(fct,ncoefsg(rmax,3)+2*(rmax+2),x,6,1,id,3,rank,nocalc,wrica)
131  end if
132 
133  if(nocalc)then
134 
135  if(present(rbasic)) then
136  rb =rbasic
137  else
138  rb = rmax
139  endif
140  if(int(fct(1)).lt.rb) then
141 ! if cached results are for smaller rbasic recalculate and write to cache
142 ! NOTE: coefficients shifted in cache by one slot
143  wrica = .true.
144  else
145  cnt = 1
146  do r=0,rmax
147  do n0=0,r
148  do n1=0,r-n0
149  n2 = r-n0-n1
150 
151  cnt = cnt+1
152  c(n0,n1,n2) = fct(cnt)
153 
154  end do
155  end do
156  do n0=1,r
157  do n1=0,r-n0
158  n2 = r-n0-n1
159 
160  cnt = cnt+1
161  cuv(n0,n1,n2) = fct(cnt)
162 
163  end do
164  end do
165  cnt = cnt+1
166  cerr1(r) = real(fct(cnt))
167  cnt = cnt+1
168  cerr2(r) = real(fct(cnt))
169  end do
170 
171  return
172  endif
173  end if
174 
175 
176  if(rank.eq.rmax) then
177 
178  if(present(rbasic)) then
179  call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rank,id,cerr1,cerr2,rbasic+rank-rmax,acc_req_cextra)
180  else
181  call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rank,id,cerr1,cerr2)
182  end if
183 
184  if (wrica) then
185  cnt = 1
186  if(present(rbasic)) then
187  fct(cnt) = rbasic
188  else
189  fct(cnt) = rank
190  end if
191  do r=0,rank
192  do n0=0,r
193  do n1=0,r-n0
194  n2 = r-n0-n1
195 
196  cnt = cnt+1
197  fct(cnt) = c(n0,n1,n2)
198  end do
199  end do
200  do n0=1,r
201  do n1=0,r-n0
202  n2 = r-n0-n1
203 
204  cnt = cnt+1
205  fct(cnt) = cuv(n0,n1,n2)
206  end do
207  end do
208  cnt = cnt+1
209  fct(cnt) = cerr1(r)
210  cnt = cnt+1
211  fct(cnt) = cerr2(r)
212  end do
213 
214  if(rank.ge.1) then
215  call writecache(fct,ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2),id,3,rank)
216  else
217  call writecache(fct,ncoefsg(rank,3)+2*(rank+2),id,3,rank)
218  end if
219 
220  end if
221 
222  return
223 
224 
225  else
226  allocate(caux(0:rank,0:rank,0:rank))
227  allocate(cuvaux(0:rank,0:rank,0:rank))
228  allocate(cerr1aux(0:rank))
229  allocate(cerr2aux(0:rank))
230 
231  if(present(rbasic)) then
232  call calccred(caux,cuvaux,p10,p21,p20,m02,m12,m22,rank,id,cerr1aux,cerr2aux,rbasic+rank-rmax,acc_req_cextra)
233  else
234  call calccred(caux,cuvaux,p10,p21,p20,m02,m12,m22,rank,id,cerr1aux,cerr2aux)
235  end if
236 
237  if (wrica) then
238  cnt = 1
239  deallocate(fct)
240  if(rank.ge.1) then
241  allocate(fct(ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2)))
242  else
243  allocate(fct(ncoefsg(rank,3)+2*(rank+2)))
244  end if
245  if(present(rbasic)) then
246  fct(cnt) = rbasic+rank-rmax
247  else
248  fct(cnt) = rank
249  end if
250  do r=0,rank
251  do n0=0,r
252  do n1=0,r-n0
253  n2 = r-n0-n1
254 
255  cnt = cnt+1
256  fct(cnt) = caux(n0,n1,n2)
257  end do
258  end do
259  do n0=1,r
260  do n1=0,r-n0
261  n2 = r-n0-n1
262 
263  cnt = cnt+1
264  fct(cnt) = cuvaux(n0,n1,n2)
265  end do
266  end do
267  cnt = cnt+1
268  fct(cnt) = cerr1aux(r)
269  cnt = cnt+1
270  fct(cnt) = cerr2aux(r)
271  end do
272 
273  if(rank.ge.1) then
274  call writecache(fct,ncoefsg(rank,3)+ncoefsg(rank-1,3)+2*(rank+2),id,3,rank)
275  else
276  call writecache(fct,ncoefsg(rank,3)+2*(rank+2),id,3,rank)
277  end if
278 
279  end if
280 
281  c = caux(0:rmax,0:rmax,0:rmax)
282  cuv = cuvaux(0:rmax,0:rmax,0:rmax)
283  cerr1 = cerr1aux(0:rmax)
284  cerr2 = cerr2aux(0:rmax)
285 
286  deallocate(caux)
287  deallocate(cuvaux)
288  deallocate(cerr1aux)
289  deallocate(cerr2aux)
290 
291 ! write(*,*) 'Cred Cerr1',Cerr1
292 ! write(*,*) 'Cred Cerr2',Cerr2
293 
294  return
295 
296  end if
297 ! end if
298  end if
299  end if
300 
301  if(present(rbasic))then
302  call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2,rbasic,acc_req_cextra)
303  else
304  call calccred(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
305  end if
306 
307 ! write(*,*) 'Cred nc Cerr1',Cerr1
308 ! write(*,*) 'Cred nc Cerr2',Cerr2
309 
310  end subroutine calcc
311 
312 
313 
314 
315 
316  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
317  ! subroutine CalcCred(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
318  !
319  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
320 
321  subroutine calccred(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr1,Cerr2,rbasic,acc_req_Cextra)
322 
323  use globalc
324 
325  integer, intent(in) :: rmax,id
326  integer, intent(in), optional :: rbasic
327  ! rbasic defines rank of tensors that are needed by mastercall
328  ! higher ranks up to rmax are needed for internal iterations
329  double precision, intent(in), optional :: acc_req_Cextra(0:rmax)
330  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
331  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
332  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
333  double precision, intent(out) ::Cerr1(0:rmax),Cerr2(0:rmax)
334  double complex :: C_alt(0:rmax,0:rmax,0:rmax)
335  double complex :: Cuv_alt(0:rmax,0:rmax,0:rmax)
336  double precision :: Cerr(0:rmax),Cerr_alt(0:rmax),Cerr1_alt(0:rmax),Cerr2_alt(0:rmax)
337  double precision :: C0est,Ctyp
338 #ifdef USEC0
339  double complex :: C0_coli
340 #endif
341  double complex :: C0_coli
342 ! double complex :: detX,chdet
343  double complex :: chdet
344 
345  double complex :: elimminf2_coli
346  integer :: r,rid,n0,n1,n2,g,gy,gp,gr,gpf,i,rdef,iexp
347  logical :: use_pv,use_pv2,use_g,use_gy,use_gp,use_gr,use_gpf,use_pvs
348 
349  integer :: r_alt,Crmethod(0:rmax),Crmethod_alt(0:rmax),CrCalc(0:rmax),CCalc
350  double precision :: acc_pv_alt, acc_pv2_alt, acc_Cr_alt
351 
352  ! CalcC stores methods that have been calculated
353  ! Crmethod(r) stores best method=used for rank r
354 
355  double precision :: err_pv(0:rmax),err_pv2(0:rmax),err_g(0:rmax),err_gy(0:rmax), &
356  err_gp(0:rmax),err_gr(0:rmax),err_gpf(0:rmax)
357  double precision :: err_pvs(0:rmax)
358  double precision :: h_pv,w_pv,v_pv,z_pv,h_pv2,w_pv2,v_pv2,z_pv2,hw_pv2
359  double precision :: h_pvs,w_pvs,v_pvs,z_pvs
360  double precision :: x_g,u_g,z_g,err_g_B(0:rmax),err_g_exp
361  double precision :: x_gy,y_gy,v_gy,v1_gy,b_gy,err_gy_B(0:rmax),err_gy_exp
362  double precision :: w_gp,v_gp,z_gp,err_gp_B(0:rmax),err_gp_exp
363  double precision :: x_gr,y_gr,y1_gr,a_gr,err_gr_B(0:rmax),err_gr_exp
364  double precision :: x_gpf,y_gpf,v_gpf,v1_gpf,b_gpf,err_gpf_B(0:rmax),err_gpf_exp
365  double precision :: err_B,err_C0,err_C(0:rmax),err_inf,err_req_Cr(0:rmax),acc_req_Cr(0:rmax),acc_C(0:rmax)
366  double precision :: checkest,norm,Cscale
367  logical :: lerr_C0,errorwriteflag
368 
369  character(len=*),parameter :: fmt1 = "(A7,'dcmplx(',d25.18,' , ',d25.18,' )')"
370  character(len=*),parameter :: fmt10 = "(A17,'(',d25.18,' , ',d25.18,' )')"
371 #ifdef CritPointsCOLI
372  integer, parameter :: MaxCritPointC=50
373 #else
374  integer, parameter :: MaxCritPointC=0
375 #endif
376  integer, save :: CritPointCntC
377 
378  data critpointcntc /0/
379 
380  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
381  ! choose reduction scheme
382  ! by estimating expected errors
383  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
384 
385 #ifdef Credtest
386  write(*,*) 'CalcCred in ',rmax,id,p10,p21,p20
387 #endif
388 #ifdef TRACECin
389  write(*,*) 'CalcCred in ',rmax,id
390 #endif
391 
392  if (present(rbasic)) then
393  rdef = rbasic
394  else
395  rdef = rmax
396  end if
397 
398 #ifdef Credtest
399  write(*,*) 'CalcCred rdef ',rdef
400 #endif
401 
402  if (present(acc_req_cextra)) then
403  acc_req_cr = acc_req_cextra
404  else
405  acc_req_cr = acc_req_c
406  end if
407 
408 #ifdef Credtest
409  write(*,*) 'CalcCred acc_req_Cr ',acc_req_cr
410 #endif
411 
412  ! eliminate infinitesimal masses
413  mm02 = elimminf2_coli(m02)
414  mm12 = elimminf2_coli(m12)
415  mm22 = elimminf2_coli(m22)
416  q10 = elimminf2_coli(p10)
417  q21 = elimminf2_coli(p21)
418  q20 = elimminf2_coli(p20)
419 
420  ! set mass scales
421  q2max = max(abs(q10),abs(q21),abs(q20))
422  m2max = max(abs(mm02),abs(mm12),abs(mm22))
423  m2scale = max(q2max,m2max)
424 
425  ! Gram and related stuff
426  z(1,1) = 2d0*q10
427  z(2,1) = q10+q20-q21 ! = q1q2
428  z(1,2) = z(2,1)
429  z(2,2) = 2d0*q20
430 
431  maxz = maxval(abs(z))
432 
433  detz = chdet(2,z)
434 
435  if (detz.ne.0d0) then
436  call chinv(2,z,zinv)
437  zadj = zinv * detz
438  else
439  zadj(1,1) = z(2,2)
440  zadj(2,1) = -z(2,1)
441  zadj(1,2) = -z(2,1)
442  zadj(2,2) = z(1,1)
443  end if
444 
445  zadjs(1) = q21 + q20 - q10
446  zadjs(2) = q21 + q10 - q20
447 
448 #ifdef Credtest
449  write(*,*) 'Z(1) ',z(1,1), z(1,2),z(2,1),z(2,2),detz
450  write(*,*) 'Zadj(1) ',zadj(1,1), zadj(1,2),zadj(2,1),zadj(2,2),detz
451  write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)
452  write(*,*) 'Zadjs(1) ',zadjs(1), zadj(1,1)+zadj(1,2)
453  write(*,*) 'Zadjs(2) ',zadjs(2), zadj(2,1)+zadj(2,2)
454 #endif
455 
456  detzmzadjf = q21*z(2,1)
457 
458 ! write(*,*) 'Zn ',Z
459 ! write(*,*) 'Zinvn ',Zinv
460 ! write(*,*) 'Zadjn ',Zadj
461 ! write(*,*) 'detZn ',detZ
462 
463  adetz = abs(detz)
464  maxzadj = max(abs(zadj(1,1)),abs(zadj(2,1)),abs(zadj(2,2)))
465 
466  f(1) = q10+mm02-mm12
467  f(2) = q20+mm02-mm22
468  fmax = max(abs(f(1)),abs(f(2)))
469 
470  mx(0,0) = 2d0*mm02
471 ! 25.08.17
472 ! mx(1,0) = q10 - mm12 + mm02
473 ! mx(2,0) = q20 - mm22 + mm02
474 ! mx(2,1) = q10+q20-q21
475 ! mx(1,1) = 2d0*q10
476 ! mx(2,2) = 2d0*q20
477  mx(1,0) = f(1)
478  mx(2,0) = f(2)
479  mx(0,1) = mx(1,0)
480  mx(0,2) = mx(2,0)
481  mx(1:2,1:2) = z(1:2,1:2)
482 
483  detx = chdet(3,mx)
484 
485  if (detx.ne.0d0.and.maxz.ne.0d0) then
486 
487 ! write(*,*) 'CalcCred mx=',mx
488 
489  call chinv(3,mx,mxinv)
490 
491 ! write(*,*) 'CalcCred mxinv=',mxinv
492 
493  xadj = mxinv * detx
494 
495 ! write(*,*) 'CalcCred Xadj=',Xadj
496 
497  zadjf(1:2) = -xadj(0,1:2)
498 
499  else
500 ! 25.08.17
501 ! mx(0,0) = 2d0*mm02
502 ! mx(1,0) = q10 - mm12 + mm02
503 ! mx(2,0) = q20 - mm22 + mm02
504 ! mx(0,1) = mx(1,0)
505 ! mx(1,1) = 2d0*q10
506 ! mx(2,1) = q10+q20-q21
507 ! mx(0,2) = mx(2,0)
508 ! mx(1,2) = mx(2,1)
509 ! mx(2,2) = 2d0*q20
510 
511  zadjf(1) = zadj(1,1)*f(1)+zadj(2,1)*f(2)
512  zadjf(2) = zadj(1,2)*f(1)+zadj(2,2)*f(2)
513 
514  xadj(2,2) = 2d0*mm02*z(1,1) - f(1)*f(1)
515  xadj(1,1) = 2d0*mm02*z(2,2) - f(2)*f(2)
516  xadj(2,1) = 2d0*mm02*z(2,1) - f(1)*f(2)
517  xadj(1,2) = xadj(2,1)
518  end if
519 
520 #ifdef Credtest
521 ! write(*,*) 'fi ',f(1),f(2)
522 ! write(*,*) 'm02 ',m02,2*q10,2*q20,2*Z(2,1)
523 ! write(*,*) 'Xadj11 ',4d0*mm02*q20 - f(1)*f(1),Xadj(1,1)
524 ! write(*,*) 'Xadj21 ',2d0*mm02*Z(2,1) - f(1)*f(2),Xadj(1,2)
525 ! write(*,*) 'Xadj22 ',4d0*mm02*q10 - f(2)*f(2),Xadj(2,2)
526 ! write(*,*) 'detXn ',detX
527 ! write(*,*) 'Zadjf1',Zadjf(1),Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
528 ! write(*,*) 'Zadjf2',Zadjf(2),Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
529 #endif
530 
531  maxzadjf = max(abs(zadjf(1)),abs(zadjf(2)))
532  maxzadjfd = max(maxzadjf,adetz)
533 
534  azadjff = abs(zadjf(1)*f(1) + zadjf(2)*f(2))
535  adetx = abs(2d0*mm02*detz - zadjf(1)*f(1) - zadjf(2)*f(2))
536  maxxadj = max(abs(xadj(1,1)),abs(xadj(2,1)),abs(xadj(2,2)))
537 
538 #ifdef Credtest
539  write(*,*) 'maxZ ',maxz,z
540  write(*,*) 'maxZadj ',maxzadj,zadj
541  write(*,*) 'maxZadjf ',maxzadjf,zadjf
542  write(*,*) 'CalcCred adetX ',adetx,adetz
543  write(*,*) 'CalcCred Zadjf ',zadjf
544  write(*,*) 'CalcCred Xadj ',xadj(1:2,1:2)
545 #endif
546 
547 
548  ! quantities for modified error estimates
549  ! momentum weights
550 ! do i = 1,2
551 ! pweight(i) = max(abs(Z(i,1))/maxval(abs(Z(1:2,1))), &
552 ! abs(Z(i,2))/maxval(abs(Z(1:2,2))))
553 ! end do
554 
555 ! wmaxZadj = max(pweight(1)*abs(Zadj(1,1)),pweight(1)*abs(Zadj(1,2)), &
556 ! pweight(2)*abs(Zadj(2,1)),pweight(2)*abs(Zadj(2,2)))
557 !
558 ! wmaxZadjf = max(pweight(1)*abs(Zadjf(1)),pweight(2)*abs(Zadjf(2)))
559 !
560 ! wmaxXadj = max(pweight(1)*abs(Xadj(1,1)), &
561 ! pweight(1)*abs(Xadj(1,2)),pweight(2)*abs(Xadj(2,1)), &
562 ! pweight(2)*abs(Xadj(2,2)))
563 ! wmaxXadj = max(2d0*abs(mm02)*sqrt(adetZ*maxZadj/maxZ),maxZadj2ff*maxZadjf/(maxZadj*fmax))
564 
565 ! write(*,*) 'CalcCred pweight',pweight(1:2)
566 ! write(*,*) 'CalcCred wmaxZadj',maxZadj,wmaxZadj
567 ! write(*,*) 'CalcCred wmaxZadjf',maxZadjf,wmaxZadjf
568 ! write(*,*) 'CalcCred wmaxZadjf',maxXadj,wmaxXadj
569 
570 
571  ! rough estimate for C0 to set the scale, to be improved
572  cscale = max(abs(p10),abs(p21),abs(p20),abs(m02), \
573  abs(m12),abs(m22))
574 #ifdef USEC0
575  c0est = max(abs(c0_coli(p10,p21,p20,m02,m12,m22)),1d0/cscale)
576  lerr_c0 = .true.
577 #else
578 ! changed 09.09.16
579  if(cscale.ne.0d0) then
580  c0est = 1d0/cscale
581  else
582  c0est = 1d0
583  end if
584 ! if (adetZ.ne.0d0) then
585 ! C0est = 1d0/sqrt(adetZ)
586 ! elseif (m2max.ne.0d0) then
587 ! C0est = 1d0/m2max
588 ! else if (maxZ.ne.0d0) then
589 ! C0est = 1d0/maxZ
590 ! else
591 ! C0est = 1d0
592 ! end if
593  lerr_c0 = .false.
594 #endif
595 
596 #ifdef Credtest
597  write(*,*) 'CalcCred C0 = ',c0_coli(p10,p21,p20,m02,m12,m22)
598  if(adetz.ne.0d0) then
599  write(*,*) 'CalcCred C0est = ',c0est,1d0/sqrt(adetz)
600  else
601  write(*,*) 'CalcCred C0est = ',c0est
602  end if
603 #endif
604 
605  err_inf = acc_inf*c0est
606 
607  err_req_cr = acc_req_cr * c0est
608 
609  ccalc = 0
610  crcalc = 0
611  crmethod = 0
612  cerr = err_inf
613  cerr1 = err_inf
614  cerr2 = err_inf
615  acc_c = acc_inf
616  ccount(0) = ccount(0)+1
617 
618  ! error estimate for C0
619  if (adetz.ne.0d0) then
620 ! err_C0 = acc_def_C0*q2max/sqrt(adetZ) * C0est
621  err_c0 = acc_def_c0*max( c0est, 1d0/sqrt(adetz) )
622  else
623  err_c0 = acc_def_c0 * c0est
624  end if
625  err_b = acc_def_b
626 
627 
628  ! estimate accuracy of PV-reduction
629 ! if (adetZ.eq.0d0) then
630 ! if (adetZ.lt.dprec_cll*maxZ**2) then
631  h_pv = real(undefined_c)
632  w_pv = real(undefined_c)
633  v_pv = real(undefined_c)
634  z_pv = real(undefined_c)
635 ! if (adetZ.lt.dprec_cll*maxZadjf.or.adetZ.eq.0d0) then
636 ! 14.07.2017
637  if (adetz.lt.dprec_cll*maxzadjf.or.adetz.lt.dprec_cll*maxz**2.or.adetz.eq.0d0) then
638  use_pv = .false.
639  err_pv = err_inf
640  else
641  use_pv = .true.
642  err_pv(0) = err_c0
643  if (rdef.gt.0) then
644 #ifdef PVEST2
645  h_pv = sqrt(adetz)/maxzadj
646  w_pv = max((maxzadjf*h_pv/adetz)**2, abs(mm02)*maxz*h_pv/adetz, azadjff*maxz*(h_pv/adetz)**2)
647  v_pv = maxzadjf*h_pv/adetz
648  z_pv = maxz*h_pv/adetz
649 #else
650  w_pv = max((maxzadjf/adetz)**2, abs(mm02)*maxz/adetz, maxz*azadjff/adetz**2)
651  v_pv = maxzadjf/adetz
652  z_pv = maxz/adetz
653 #endif
654 
655 #ifdef Credtest
656  write(*,*) 'CalcCred w_pv',(maxzadjf/adetz)**2, abs(mm02)*q2max/adetz, maxz*azadjff/adetz**2
657  write(*,*) 'CalcCred w_pv',w_pv,v_pv,z_pv,h_pv
658 #endif
659 
660  if (mod(rdef,2).eq.1) then
661  err_pv(rdef) = max( w_pv**((rdef-1)/2) * v_pv * err_c0, &
662  max(w_pv**((rdef-1)/2),1d0) * z_pv * err_b )
663 
664 #ifdef Credtest
665  write(*,*) 'CalcCred err_pv cont', w_pv**((rdef-1)/2)* v_pv* err_c0, &
666  w_pv**((rdef-1)/2) * z_pv * err_b, err_c0,err_b
667  write(*,*) 'CalcCred err_pv cont', w_pv**((rdef-1)/2),v_pv, err_c0
668 #endif
669 
670  else
671  err_pv(rdef) = max( w_pv**(rdef/2) * err_c0, &
672  max(w_pv**(rdef/2-1) * v_pv, 1d0) * z_pv * err_b )
673 
674 #ifdef Credtest
675  write(*,*) 'CalcCred w_pv', w_pv,err_c0,sqrt(w_pv)
676  write(*,*) 'CalcCred err_pv cont', w_pv**(rdef/2) * err_c0, &
677  w_pv**(rdef/2-1) * v_pv * z_pv * err_b, z_pv * err_b, err_c0,err_b
678 #endif
679 
680  end if
681  end if
682  end if
683 
684  ! estimate accuracy of alternative PV-reduction
685 ! if ((adetZ.eq.0).or.(adetX.eq.0)) then
686 ! if ((adetZ.lt.dprec_cll*maxZ**2).or.(adetX.lt.dprec_cll*maxval(abs(mx))**3)) then
687  z_pv2 = real(undefined_c)
688  v_pv2 = real(undefined_c)
689  w_pv2 = real(undefined_c)
690  hw_pv2 = real(undefined_c)
691 ! if ((adetZ.lt.dprec_cll*maxZadjf).or.(adetX.lt.dprec_cll*maxval(abs(mx))*adetZ).or.adetZ.eq.0d0) then
692 ! 14.07.2017
693  if ((adetz.lt.dprec_cll*maxzadjf).or.(adetx.lt.dprec_cll*maxval(abs(mx))*adetz).or. &
694  (adetz.lt.dprec_cll*maxz**2).or.(adetx.lt.dprec_cll*fmax**2*maxz).or.adetz.eq.0d0.or.adetx.eq.0d0) then
695  use_pv2 = .false.
696  err_pv2 = err_inf
697  else
698  use_pv2 = .true.
699  err_pv2(0) = err_c0
700  if (rdef.gt.0) then
701  w_pv2 = maxzadjf/adetz
702 #ifdef PVEST2
703  h_pv2 = sqrt(adetz)/maxzadj
704  hw_pv2 = w_pv2*h_pv2
705 #else
706  hw_pv2 = w_pv2
707 #endif
708  v_pv2 = maxxadj/adetz
709  z_pv2 = adetz/adetx
710 
711 ! write(*,*) 'CalcCred: w_pv2',w_pv2,v_pv2,z_pv2,err_C0,err_B
712 
713  if (mod(rdef,2).eq.1) then
714 ! change 21.10.15 for PVEST2
715 ! err_pv2(rdef) = max( err_C0 * max(w_pv2**rdef,w_pv2*v_pv2**((rdef-1)/2) ), &
716 ! err_B * z_pv2 * max(w_pv2**(rdef+1),w_pv2, &
717 ! w_pv2*v_pv2**((rdef-1)/2),w_pv2**2, &
718 ! v_pv2**((rdef+1)/2),v_pv2 ) )
719 
720  err_pv2(rdef) = max( err_c0 * max(hw_pv2**rdef,hw_pv2*v_pv2**((rdef-1)/2) ), &
721  err_b * z_pv2 * max(w_pv2*hw_pv2**(rdef),hw_pv2, &
722  w_pv2*hw_pv2*v_pv2**((rdef-1)/2), &
723  hw_pv2*v_pv2**((rdef-1)/2),w_pv2*hw_pv2, &
724  v_pv2**((rdef+1)/2),v_pv2 ) )
725 
726 ! write(*,*) 'CalcCred: err_pv2',rdef,err_C0 * max(1d0,w_pv2**rdef,v_pv2**((rdef-1)/2),w_pv2*v_pv2**((rdef-1)/2) ), &
727 ! err_B * max(1d0,z_pv2*w_pv2**(rdef+1),z_pv2*w_pv2, &
728 ! z_pv2*w_pv2*v_pv2**((rdef-1)/2),z_pv2*w_pv2**2, &
729 ! z_pv2*v_pv2**((rdef+1)/2),z_pv2*v_pv2 )
730 
731  else
732 ! change 21.10.15 for PVEST2
733 ! err_pv2(rdef) = max( err_C0 * max(w_pv2**rdef,v_pv2**(rdef/2)), &
734 ! err_B * z_pv2 * max(w_pv2**(rdef+1),w_pv2, &
735 ! w_pv2*v_pv2**(rdef/2), w_pv2**2, &
736 ! v_pv2**(rdef/2),v_pv2) )
737  err_pv2(rdef) = max( err_c0 * max(hw_pv2**rdef,v_pv2**(rdef/2)), &
738  err_b * z_pv2 * max(w_pv2*hw_pv2**(rdef),hw_pv2, &
739  w_pv2*v_pv2**(rdef/2), w_pv2*hw_pv2, &
740  v_pv2**(rdef/2),v_pv2) )
741  end if
742  end if
743  end if
744 
745  ! scale estimates down to allow trying other methods
746  err_pv(rdef) = err_pv(rdef)/impest_c
747  err_pv2(rdef) = err_pv2(rdef)/impest_c
748 
749 #ifdef TEST
750 ! use_pv = .false. ! TEST switch off PV
751  use_pv2 = .false.
752 ! use_pv = .true.
753 ! use_pv2 = .true.
754 ! err_pv(rdef) = 1d50
755  err_pv2(rdef) = 1d50
756 #endif
757 
758 #ifdef Credtest
759  write(*,*) 'CalcCred: err_pv',err_pv(rdef),err_pv2(rdef),err_req_cr(rdef)
760  write(*,*) 'CalcCred: acc_pv',err_pv(rdef)/c0est,err_pv2(rdef)/c0est,acc_req_c
761 #endif
762 
763 ! changed 16.11.16
764 ! Ctyp = real(undefined_C)
765  ctyp = c0est
766 
767 #ifdef ALWAYSPV
768  if(use_pv.or.use_pv2) then
769 #else
770  if (min(err_pv(rdef),err_pv2(rdef)).le.err_req_cr(rdef)) then
771 #endif
772  if (err_pv(rdef).le.err_pv2(rdef)) then
773 
774 #ifdef Credtest
775  write(*,*) 'CalcCred: call Cpv 1 ',rmax,id,err_pv(rdef)
776 #endif
777 
778  ! use PV-reduction if appropriate
779  call calccpv1(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
780 #ifdef PVEST2
781  cerr = cerr2
782 #else
783  cerr = cerr1
784 #endif
785  ccount(1) = ccount(1)+1
786  crcalc(0:rmax)=crcalc(0:rmax)+1
787  ccalc=ccalc+1
788  crmethod(0:rmax)=1
789 
790 #ifdef Credtest
791  checkest=cerr(rdef)/err_pv(rdef)
792  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
793  write(*,*) 'CalcCred: estimate err_pv imprecise',err_pv(rdef),cerr(rdef)
794  end if
795 #endif
796  err_pv=cerr
797 
798  else
799 
800 #ifdef Credtest
801  write(*,*) 'CalcCred: call Cpv2 1',rdef,id,err_pv2(rdef)
802 #endif
803 
804  ! use alternative PV-reduction if appropriate
805  call calccpv2(c,cuv,p10,p21,p20,m02,m12,m22,rmax,id,cerr1,cerr2)
806 #ifdef PVEST2
807  cerr = cerr2
808 #else
809  cerr = cerr1
810 #endif
811  ccount(2) = ccount(2)+1
812  crcalc(0:rmax)=crcalc(0:rmax)+2
813  ccalc=ccalc+2
814  crmethod(0:rmax)=2
815 
816 #ifdef Credtest
817  checkest=cerr(rdef)/err_pv2(rdef)
818  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
819  write(*,*) 'CalcCred: estimate err_pv2 imprecise',err_pv2(rdef),cerr(rdef)
820  end if
821 #endif
822 
823  err_pv2=cerr
824 
825  end if
826 
827 #ifndef USEC0
828  ! refine error estimate for C0
829 ! C0est = abs(C(0,0,0))
830  err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
831 ! err_req_Cr = acc_req_Cr * abs(C(0,0,0))
832  lerr_c0 = .true.
833 #endif
834 
835  if (rmax.ge.1) then
836  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
837  else
838  ctyp = abs(c(0,0,0))
839  end if
840  if(ctyp.eq.0d0) ctyp = c0est
841  err_req_cr = acc_req_cr * ctyp
842 
843 
844 #ifdef Credtest
845  write(*,*) 'CalcCred C0est after PV=',abs(c(0,0,0)),ctyp
846  write(*,*) 'CalcCred Cerr after PV =',cerr
847  write(*,*) 'CalcCred Cacc after PV =',cerr/ctyp
848  write(*,*) 'CalcCred err_req =',err_req_cr
849  write(*,*) 'CalcCred Cerr1-req=',cerr1-err_req_cr
850  write(*,*) 'CalcCred max(Cerr-req)',maxval(cerr-err_req_cr)
851  write(*,*) 'CalcCred max(Cerr1-req)',maxval(cerr1-err_req_cr)
852 #endif
853 
854 ! check with Cerr = Cerr2: exp not tried => larger errors
855  if (maxval(cerr1-err_req_cr).lt.0) then
856  ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
857  return
858  end if
859  else ! added 14.07.2017
860  c = 0d0
861  cuv = 0d0
862  cerr1 = err_inf
863  cerr2 = err_inf
864  end if
865 
866 #ifdef TEST
867 ! return ! use only PV
868 #endif
869 
870 
871  ! choose most promising expansion scheme
872  ! Gram expansion
873 ! if (maxZadjf.ne.0d0) then
874  if (maxzadjf.gt.m2scale**2*dprec_cll) then ! 10.07.2017
875  x_g = adetz/maxzadjf
876 ! u_g = max(1d0,m2scale*m2scale/maxZadjf/6d0,abs(mm02)*q2max/maxZadjf/6d0)
877 ! u_g = max(1d0,fmax*fmax/maxZadjf/6d0,abs(mm02)*maxZ/maxZadjf/6d0)
878 ! 03.03.15 large P counts!
879 ! u_g = max(1d0,fmax*fmax/maxZadjf/2d0,abs(mm02)*maxZ/maxZadjf/2d0)
880 ! 24.04.15 term appear only combined
881  u_g = max(1d0,maxxadj/maxzadjf/2d0)
882  fac_g = x_g*u_g
883  err_g = err_inf
884  g = -1
885  if (fac_g.ge.1) then
886  use_g = .false.
887  err_g_exp = err_inf
888  z_g = real(undefined_c)
889  else
890  use_g = .true.
891 ! z_g = max(1d0,m2scale*q2max/maxZadjf)
892  z_g = maxz/maxzadjf
893  err_g_b(rdef) = err_b * u_g**rdef * z_g
894  err_g_exp = u_g**(rdef-1) * ctyp
895  end if
896  else
897  use_g = .false.
898  err_g = err_inf
899  g = -1
900  err_g_exp = err_inf
901  u_g = real(undefined_c)
902  z_g = real(undefined_c)
903  end if
904 
905 #ifdef Credtest
906  if(use_g) then
907  write(*,*) 'CalcCred: after Gram pars',use_g,fac_g,x_g,u_g,z_g,err_g_b(rdef),err_g_exp
908  else
909  write(*,*) 'CalcCred: after Gram pars',use_g,err_g_exp
910  end if
911 #endif
912 
913  ! Gram-Cayley expansion
914 ! if (maxXadj.ne.0d0.and.maxZ.ne.0d0) then
915  if (maxxadj.gt.m2scale**2*dprec_cll.and.maxz.gt.m2scale*dprec_cll) then ! 10.07.2017
916  x_gy = maxzadjf/maxxadj
917  y_gy = adetz/maxxadj
918 ! v_gy = m2scale/q2max
919  v_gy = fmax/maxz
920  v1_gy = max(1d0,v_gy)
921  fac_gy = max(x_gy,y_gy)*v1_gy
922  err_gy = err_inf
923  gy = -1
924  if (fac_gy.ge.1) then
925  use_gy = .false.
926  err_gy_exp = err_inf
927  b_gy = real(undefined_c)
928  else
929  use_gy = .true.
930 ! b_gy = max(1d0,m2scale*q2max/maxXadj)
931  b_gy = maxz/maxxadj
932  err_gy_b(rdef) = err_b * b_gy*v1_gy
933  err_gy_exp = 1d0 * ctyp
934  end if
935  else
936  use_gy = .false.
937  err_gy = err_inf
938  gy = -1
939  err_gy_exp = err_inf
940  v1_gy = real(undefined_c)
941  b_gy = real(undefined_c)
942  end if
943 
944 #ifdef Credtest
945  if(use_gy) then
946  write(*,*) 'CalcCred: after GramCay pars',use_gy,fac_gy,x_gy,y_gy,v_gy,b_gy,err_gy_b(rdef),err_gy_exp
947  else
948  write(*,*) 'CalcCred: after GramCay pars',use_gy,err_gy_exp
949  end if
950 #endif
951 
952  ! expansion in small momenta
953 ! if (fmax.ne.0d0) then
954  if (fmax.gt.m2scale*dprec_cll) then ! 10.07.2017
955 ! w_gp = q2max/fmax
956  w_gp = maxz/fmax
957  v_gp = max(1d0,abs(mm02)/fmax)
958  fac_gp = w_gp*v_gp
959  err_gp = err_inf
960  gp = -1
961  if (fac_gp.ge.1d0) then
962  use_gp = .false.
963  err_gp_exp = err_inf
964  z_gp = real(undefined_c)
965  else
966  use_gp = .true.
967 ! z_gp = max(1d0,m2scale/fmax)
968  z_gp = 1d0/fmax
969  err_gp_b(rdef) = err_b * z_gp*v_gp**rdef
970  err_gp_exp = v_gp**(rdef-1) * ctyp
971  end if
972  else
973  use_gp = .false.
974  err_gp = err_inf
975  gp = -1
976  err_gp_exp = err_inf
977  z_gp = real(undefined_c)
978  v_gp = real(undefined_c)
979  end if
980 
981 #ifdef Credtest
982  if(use_gp) then
983  write(*,*) 'CalcCred: after Mom pars',use_gp,fac_gp,w_gp,v_gp,z_gp,err_gp_b(rdef),err_gp_exp
984  else
985  write(*,*) 'CalcCred: after Mom pars',use_gp,err_gp_exp
986  end if
987 #endif
988 
989  ! reversed Gram expansion
990 ! if (maxZadjf.ne.0d0.and.fmax.ne.0d0) then
991  if (maxzadjf.gt.m2scale**2*dprec_cll.and.fmax.gt.m2scale*dprec_cll) then ! 10.07.2017
992  x_gr = adetz/maxzadjf
993  y_gr = maxzadj/fmax ! c*y c=2
994  y1_gr = max(1d0,y_gr)
995  a_gr = maxzadj/maxzadjf
996  fac_gr = max(x_gr,y_gr)
997  err_gr = err_inf
998  gr = -1
999  if (fac_gr.ge.1.or.2*rmax.gt.rmax_b) then
1000  use_gr = .false.
1001  err_gr_exp = err_inf
1002  else
1003  use_gr = .true.
1004  err_gr_b(rdef) = err_b * a_gr
1005  err_gr_exp = y1_gr * ctyp
1006  end if
1007  else
1008  use_gr = .false.
1009  err_gr = err_inf
1010  gr = -1
1011  err_gr_exp = err_inf
1012  y1_gr = real(undefined_c)
1013  a_gr = real(undefined_c)
1014  end if
1015 
1016 #ifdef Credtest
1017  if(use_gr) then
1018  write(*,*) 'CalcCred: after revGram pars',use_gr,fac_gr,x_gr,y_gr,y1_gr,a_gr,err_gr_b(rdef),err_gr_exp
1019  else
1020  write(*,*) 'CalcCred: after revGram pars',use_gr,err_gr_exp
1021  end if
1022 #endif
1023 
1024  ! expansion in small momenta and f's
1025 ! estimates to be confirmed 16.08.17, r dependence may be different
1026 ! since C_mni... is needed in contrast to Cgy expansion
1027  if (abs(m02).gt.m2scale*dprec_cll) then
1028  x_gpf = fmax/abs(m02)
1029  y_gpf = maxz/abs(m02)
1030  v_gpf = 0d0
1031  v1_gpf = max(1d0,v_gpf)
1032  fac_gpf = max(x_gpf,y_gpf)*v1_gpf
1033  err_gpf = err_inf
1034  gpf = -1
1035  if (fac_gpf.ge.1) then
1036  use_gpf = .false.
1037  err_gpf_exp = err_inf
1038  b_gpf = real(undefined_c)
1039  else
1040  use_gpf = .true.
1041  b_gpf = 1d0/abs(m02)
1042  err_gpf_b(rdef) = err_b * b_gpf*v1_gpf
1043  err_gpf_exp = 1d0 * ctyp
1044  end if
1045  else
1046  use_gpf = .false.
1047  err_gpf = err_inf
1048  gpf = -1
1049  err_gpf_exp = err_inf
1050  v1_gpf = real(undefined_c)
1051  b_gpf = real(undefined_c)
1052  end if
1053 
1054 #ifdef Credtest
1055  if(use_gpf) then
1056  write(*,*) 'CalcCred: after pf pars',use_gpf,fac_gpf,x_gpf,y_gpf,v_gpf,b_gpf,err_gpf_b(rdef),err_gpf_exp
1057  else
1058  write(*,*) 'CalcCred: after pf pars',use_gpf,err_gpf_exp
1059  end if
1060 #endif
1061 
1062 
1063 ! no method works
1064  if(use_pv.or.use_pv2.or.use_g.or.use_gy.or.use_gp.or.use_gr.or.use_gpf.eqv..false.) then
1065  call seterrflag_coli(-6)
1066  call errout_coli('CalcCred',' no reduction method works', &
1067  errorwriteflag)
1068 ! write(nerrout_coli,'((a))') ' no reduction method works'
1069  if (errorwriteflag) then
1070  write(nerrout_coli,fmt10) ' CalcCred: p10 = ',p10
1071  write(nerrout_coli,fmt10) ' CalcCred: p21 = ',p21
1072  write(nerrout_coli,fmt10) ' CalcCred: p20 = ',p20
1073  write(nerrout_coli,fmt10) ' CalcCred: m02 = ',m02
1074  write(nerrout_coli,fmt10) ' CalcCred: m12 = ',m12
1075  write(nerrout_coli,fmt10) ' CalcCred: m22 = ',m22
1076  end if
1077  c = 0d0
1078  cuv = 0d0
1079  cerr = err_inf
1080  cerr2 = err_inf
1081 
1082 #ifdef Credtest
1083  write(*,*) 'CalcCred: exit'
1084 #endif
1085 
1086  return
1087  endif
1088 
1089 #ifdef TEST
1090 ! switched off for testing
1091  use_g = .false.
1092  use_gy = .false.
1093  use_gp = .false.
1094  use_gr = .false.
1095  use_gpf = .false.
1096 #endif
1097 
1098  iexp = 0
1099  do i=0,rmax_c-rmax
1100 
1101  if (use_g) then
1102  if (err_g_exp.gt.err_g_b(rdef)) then
1103  g = i
1104  err_g_exp = err_g_exp*fac_g
1105  err_g(rdef) = max(err_g_exp,err_g_b(rdef))
1106  if(err_g(rdef).lt.err_req_cr(rdef)) then
1107  iexp = 1
1108  ! increase g by 2 to account for bad estimates
1109  g = min(max(g+2,2*g),rmax_c-rmax)
1110  exit
1111  end if
1112 
1113 #ifdef Credtest
1114  write(*,*) 'CalcCred i g',i,g,err_g_exp,err_g_b(rdef),err_g(rdef)
1115 #endif
1116 
1117  end if
1118  end if
1119 
1120  if (mod(i,2).eq.1) then
1121  if (use_gy) then
1122  if (err_gy_exp.gt.err_gy_b(rdef)) then
1123  gy = i/2
1124  err_gy_exp = err_gy_exp*fac_gy
1125  err_gy(rdef) = max(err_gy_exp, err_gy_b(rdef))
1126  if(err_gy(rdef).lt.err_req_cr(rdef)) then
1127  iexp = 2
1128  ! increase gy by 2 to account for bad estimates
1129  gy = min(max(gy+4,2*gy),(rmax_c-rmax)/2)
1130  exit
1131  end if
1132 
1133 #ifdef Credtest
1134  write(*,*) 'CalcCred i gy',i,gy,err_gy_exp,err_gy_b(rdef),err_gy(rdef)
1135 #endif
1136 
1137  end if
1138  end if
1139  end if
1140 
1141  if (use_gp) then
1142  if (err_gp_exp.gt.err_gp_b(rdef)) then
1143  gp = i
1144  err_gp_exp = err_gp_exp*fac_gp
1145  err_gp(rdef) = max(err_gp_exp,err_gp_b(rdef))
1146  if(err_gp(rdef).lt.err_req_cr(rdef)) then
1147  iexp = 3
1148  ! increase gp by 2 to account for bad estimates
1149  gp = min(max(gp+2,2*gp),rmax_c-rmax)
1150  exit
1151  end if
1152 
1153 #ifdef Credtest
1154  write(*,*) 'CalcCred i gp',i,gp,err_gp_exp,err_gp_b(rdef),err_gp(rdef)
1155 #endif
1156 
1157  end if
1158  end if
1159 
1160  if (mod(i,2).eq.1) then
1161 
1162  if (use_gr) then
1163 
1164 #ifdef Credtest
1165  write(*,*) 'CalcCred: it gr',use_gr,err_gr_exp,err_gr_b(rdef),err_gr(rdef), &
1166  err_req_cr(rdef)
1167 #endif
1168 
1169  if (err_gr_exp.gt.err_gr_b(rdef)) then
1170  gr = i/2
1171  err_gr_exp = err_gr_exp*fac_gr
1172  err_gr(rdef) = max(err_gr_exp, err_gr_b(rdef))
1173  if(err_gr(rdef).lt.err_req_cr(rdef)) then
1174  iexp = 4
1175  ! increase gy by 2 to account for bad estimates
1176 ! changed 28.07.14
1177 ! gr = min(max(gr+4,2*gr),(rmax_C-rmax)/2)
1178  gr = min(max(gr+4,2*gr),rmax_c-rmax,max(0,(rmax_b-2*rmax)/2))
1179  exit
1180  end if
1181  end if
1182 
1183 #ifdef Credtest
1184  write(*,*) 'CalcCred: it gr',i,gr, err_gr_exp,err_gr_b(rdef) ,err_gr(rdef)
1185 #endif
1186 
1187  end if
1188  end if
1189 
1190  if (mod(i,2).eq.1) then
1191  if (use_gpf) then
1192  if (err_gpf_exp.gt.err_gpf_b(rdef)) then
1193  gpf = i/2
1194  err_gpf_exp = err_gpf_exp*fac_gpf
1195  err_gpf(rdef) = max(err_gpf_exp, err_gpf_b(rdef))
1196  if(err_gpf(rdef).lt.err_req_cr(rdef)) then
1197  iexp = 5
1198  ! increase gpf by 2 to account for bad estimates
1199  gpf = min(max(gpf+4,2*gpf),(rmax_c-rmax)/2)
1200  exit
1201  end if
1202 
1203 #ifdef Credtest
1204  write(*,*) 'CalcCred i gpf',i,gpf,err_gpf_exp,err_gpf_b(rdef),err_gpf(rdef),err_req_cr(rdef)
1205 #endif
1206 
1207  end if
1208  end if
1209  end if
1210 
1211  end do
1212 
1213  ! scale estimates down to allow trying other methods
1214  err_g(rdef) = err_g(rdef)/impest_c
1215  err_gy(rdef) = err_gy(rdef)/impest_c
1216  err_gp(rdef) = err_gp(rdef)/impest_c
1217  err_gr(rdef) = err_gr(rdef)/impest_c
1218  err_gpf(rdef)= err_gpf(rdef)/impest_c
1219 
1220 #ifdef Credtest
1221  write(*,*) 'iexp=',iexp
1222  write(*,*) 'facexp=',fac_g,fac_gy,fac_gp,fac_gr,fac_gpf
1223  write(*,*) 'errexp=',err_g_exp,err_gy_exp,err_gp_exp,err_gr_exp,err_gpf_exp,err_req_cr(rdef)
1224  write(*,*) 'errexptot=',i
1225  write(*,*) 'g: errexptot =',g,err_g(rdef)
1226  write(*,*) 'gy: errexptot =',gy,err_gy(rdef)
1227  write(*,*) 'gp: errexptot =',gp,err_gp(rdef)
1228  write(*,*) 'gr: errexptot =',gr,err_gr(rdef)
1229  write(*,*) 'gpf: errexptot=',gpf,err_gpf(rdef)
1230  write(*,*) 'errexptot=',i,g,err_g(rdef),gy,err_gy(rdef),gp,err_gp(rdef),gr,err_gr(rdef),gpf,err_gpf(rdef)
1231  write(*,*) 'accexptot=',i,g,err_g(rdef)/ctyp,gy,err_gy(rdef)/ctyp,gp,err_gp(rdef)/ctyp, &
1232  gr,err_gr(rdef)/ctyp,gpf,err_gpf(rdef)/ctyp
1233 #endif
1234 
1235  ! call expansions with estimated order to save CPU time
1236 
1237 #ifdef TEST
1238 ! iexp = 0 ! TEST: force specific expansion
1239 ! gy = 14
1240 #endif
1241 
1242  select case (iexp)
1243 
1244 #ifdef TEST
1245 ! case only as replacement for CalcCg, not as extra case
1246  case (7)
1247  call calccgn(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,g,g,id,cerr1_alt,acc_req_cr,cerr2_alt)
1248 #ifdef PVEST2
1249  cerr_alt = cerr2_alt
1250 #else
1251  cerr_alt = cerr1_alt
1252 #endif
1253  ccount(3) = ccount(3)+1
1254  crcalc(0:rmax)=crcalc(0:rmax)+4
1255  ccalc=ccalc+4
1256  crmethod_alt(0:rmax)=4
1257 
1258 #ifdef Credtest
1259  checkest=cerr_alt(rdef)/err_g(rdef)
1260  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1261  write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(rdef),cerr_alt(rdef)
1262  end if
1263 #endif
1264 
1265  err_g=cerr_alt
1266 
1267  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1268 
1269 #ifdef Credtest
1270  write(*,*) 'CalcCred Cerr after exp =',cerr
1271  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1272  write(*,*) 'CalcCred method=',crmethod
1273 #endif
1274 #endif
1275 
1276  case (1)
1277  call calccg(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,g,g,id,cerr1_alt,acc_req_cr,cerr2_alt)
1278 #ifdef PVEST2
1279  cerr_alt = cerr2_alt
1280 #else
1281  cerr_alt = cerr1_alt
1282 #endif
1283  ccount(3) = ccount(3)+1
1284  crcalc(0:rmax)=crcalc(0:rmax)+4
1285  ccalc=ccalc+4
1286  crmethod_alt(0:rmax)=4
1287 
1288 #ifdef Credtest
1289  checkest=cerr_alt(rdef)/err_g(rdef)
1290  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1291  write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(rdef),cerr_alt(rdef)
1292  end if
1293 #endif
1294 
1295  err_g=cerr_alt
1296 
1297  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1298 
1299 #ifdef Credtest
1300  write(*,*) 'CalcCred Cerr after exp =',cerr
1301  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1302  write(*,*) 'CalcCred method=',crmethod
1303 #endif
1304 
1305  case (2)
1306 
1307  call calccgy(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gy,gy,id,cerr1_alt,acc_req_cr,cerr2_alt)
1308 #ifdef PVEST2
1309  cerr_alt = cerr2_alt
1310 #else
1311  cerr_alt = cerr1_alt
1312 #endif
1313  ccount(4) = ccount(4)+1
1314  crcalc(0:rmax)=crcalc(0:rmax)+8
1315  ccalc=ccalc+8
1316  crmethod_alt(0:rmax)=8
1317 
1318 #ifdef Credtest
1319  checkest=cerr_alt(rdef)/err_gy(rdef)
1320  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1321  write(*,*) 'CalcCred: estimate err_gy imprecise',err_gy(rdef),cerr_alt(rdef),checkest
1322  end if
1323 #endif
1324 
1325  err_gy=cerr_alt
1326 
1327  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1328 
1329 #ifdef Credtest
1330  write(*,*) 'CalcCred Cerr after exp =',cerr
1331  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1332  write(*,*) 'CalcCred method=',crmethod
1333 #endif
1334 
1335  case (3)
1336  call calccgp(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gp,gp,id,cerr1_alt,acc_req_cr,cerr2_alt)
1337 #ifdef PVEST2
1338  cerr_alt = cerr2_alt
1339 #else
1340  cerr_alt = cerr1_alt
1341 #endif
1342  ccount(5) = ccount(5)+1
1343  crcalc(0:rmax)=crcalc(0:rmax)+16
1344  ccalc=ccalc+16
1345  crmethod_alt(0:rmax)=16
1346 
1347 #ifdef Credtest
1348  checkest=cerr_alt(rdef)/err_gp(rdef)
1349  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1350  write(*,*) 'CalcCred: estimate err_gp imprecise',err_gp(rdef),cerr_alt(rdef)
1351  end if
1352 #endif
1353 
1354  err_gp=cerr_alt
1355 
1356  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1357 
1358 #ifdef Credtest
1359  write(*,*) 'CalcCred Cerr after exp =',cerr
1360  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1361  write(*,*) 'CalcCred method=',crmethod
1362 #endif
1363 
1364  case (4)
1365  call calccgr(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gr,gr,id,cerr1_alt,acc_req_cr,cerr2_alt)
1366 #ifdef PVEST2
1367  cerr_alt = cerr2_alt
1368 #else
1369  cerr_alt = cerr1_alt
1370 #endif
1371  ccount(6) = ccount(6)+1
1372  crcalc(0:rmax)=crcalc(0:rmax)+32
1373  ccalc=ccalc+32
1374  crmethod_alt(0:rmax)=32
1375 
1376 #ifdef Credtest
1377  checkest=cerr_alt(rdef)/err_gr(rdef)
1378  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1379  write(*,*) 'CalcCred: estimate err_gr imprecise',err_gr(rdef),cerr_alt(rdef)
1380  end if
1381 #endif
1382 
1383  err_gr=cerr_alt
1384 
1385  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1386 
1387 #ifdef Credtest
1388  write(*,*) 'CalcCred Cerr after exp =',cerr
1389  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1390  write(*,*) 'CalcCred method=',crmethod
1391 #endif
1392 
1393  case (5)
1394 
1395  call calccgpf(c_alt,cuv,p10,p21,p20,m02,m12,m22,rmax,gpf,gpf,id,cerr1_alt,acc_req_cr,cerr2_alt)
1396 #ifdef PVEST2
1397  cerr_alt = cerr2_alt
1398 #else
1399  cerr_alt = cerr1_alt
1400 #endif
1401  ccount(4) = ccount(4)+1
1402  crcalc(0:rmax)=crcalc(0:rmax)+8
1403  ccalc=ccalc+8
1404  crmethod_alt(0:rmax)=8
1405 
1406 #ifdef Credtest
1407  checkest=cerr_alt(rdef)/err_gpf(rdef)
1408  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1409  write(*,*) 'CalcCred: estimate err_gpf imprecise',err_gpf(rdef),cerr_alt(rdef),checkest
1410  end if
1411 #endif
1412 
1413  err_gpf=cerr_alt
1414 
1415  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1416 
1417 #ifdef Credtest
1418  write(*,*) 'CalcCred Cerr after exp =',cerr
1419  write(*,*) 'CalcCred Cacc=',cerr/ctyp
1420  write(*,*) 'CalcCred method=',crmethod
1421 #endif
1422 
1423  end select
1424 
1425 #ifndef USEC0
1426 #ifndef ALWAYSPV
1427  ! refine error estimate for C0
1428  if(.not.lerr_c0.and.iexp.ne.0) then
1429 ! C0est = abs(C(0,0,0))
1430  err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
1431 ! err_req_Cr = acc_req_Cr * abs(C(0,0,0))
1432  lerr_c0 = .true.
1433  end if
1434 #endif
1435 #endif
1436 
1437  if (iexp.ne.0) then ! if added 21.11.2016
1438  if (rmax.ge.1) then
1439  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
1440  else
1441  ctyp = abs(c(0,0,0))
1442  end if
1443  err_req_cr = acc_req_cr * ctyp
1444 
1445  if (maxval(cerr1-err_req_cr).lt.0) then
1446  ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
1447  return
1448  end if
1449  end if
1450 
1451 #ifdef Credtest
1452  write(*,*) 'CalcCred no optimal method bef shift',ctyp,acc_req_cr
1453  write(*,*) 'err_req=',err_req_cr(rdef),rdef
1454  write(*,*) 'err_est=',err_pv(rdef),err_pv2(rdef),err_g(rdef) &
1455  ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)
1456 #endif
1457 
1458 #ifdef TEST
1459  return ! do not try shifted PV
1460 #endif
1461 
1462 #ifdef PVSHIFT
1463  ! try PV with shifted momentum
1464  shiftloop: do i=1,2
1465 
1466 #ifdef Credtest
1467  write(*,*) 'CalcCred try pv shift i = ',i
1468 #endif
1469 
1470  if (i.eq.1) then
1471  mm02shift = mm12
1472  mm12shift = mm02
1473  mm22shift = mm22
1474  q10shift = q10
1475  q21shift = q20
1476  q20shift = q21
1477  else
1478  mm02shift = mm22
1479  mm12shift = mm12
1480  mm22shift = mm02
1481  q10shift = q21
1482  q21shift = q10
1483  q20shift = q20
1484  end if
1485 
1486  zshift(1,1) = 2d0*q10shift
1487  zshift(2,1) = q10shift+q20shift-q21shift
1488  zshift(1,2) = zshift(2,1)
1489  zshift(2,2) = 2d0*q20shift
1490 
1491  maxzshift = maxval(abs(zshift))
1492 
1493  detzshift = chdet(2,zshift)
1494 
1495 ! if (detZshift.ne.0d0) then
1496 ! call chinv(2,Zshift,Zinvshift)
1497 ! Zadjshift = Zinvshift * detZshift
1498 ! else
1499  zadjshift(1,1) = zshift(2,2)
1500  zadjshift(2,1) = -zshift(1,2)
1501  zadjshift(1,2) = -zshift(1,2)
1502  zadjshift(2,2) = zshift(1,1)
1503 ! end if
1504 
1505  zadjsshift(1) = q21shift + q20shift - q10shift
1506  zadjsshift(2) = q21shift + q10shift - q20shift
1507 
1508  detzmzadjfshift = q21shift*zshift(2,1)
1509 
1510  adetzshift = abs(detzshift)
1511  maxzadjshift = max(abs(zadjshift(1,1)),abs(zadjshift(2,1)),abs(zadjshift(2,2)))
1512 
1513  fshift(1) = q10shift+mm02shift-mm12shift
1514  fshift(2) = q20shift+mm02shift-mm22shift
1515 
1516 #ifdef Credtestshift
1517  write(*,*) 'fshift1',q10shift+mm02shift-mm12shift,q10shift,mm02shift,-mm12shift
1518  write(*,*) 'fshift2',q20shift+mm02shift-mm22shift,q20shift,mm02shift,-mm22shift
1519 #endif
1520 
1521  mxshift(0,0) = 2d0*mm02shift
1522  mxshift(1,0) = fshift(1)
1523  mxshift(2,0) = fshift(2)
1524  mxshift(0,1) = mxshift(1,0)
1525  mxshift(0,2) = mxshift(2,0)
1526 ! mxshift(1,1) = 2d0*q10shift
1527 ! mxshift(2,1) = q10shift+q20shift-q21shift
1528 ! mxshift(2,2) = 2d0*q20shift
1529 ! mxshift(1,2) = mxshift(2,1)
1530 
1531  mxshift(1:2,1:2) = zshift(1:2,1:2)
1532 
1533  detxshift = chdet(3,mxshift)
1534 
1535  if (detxshift.ne.0d0.and.maxzshift.ne.0d0) then
1536 
1537 ! write(*,*) 'CalcCred mxshift=',mxshift
1538 
1539  call chinv(3,mxshift,mxinvshift)
1540 
1541 ! write(*,*) 'CalcCred mxinvshift=',mxinvshift
1542 
1543  xadjshift = mxinvshift * detxshift
1544 
1545 ! write(*,*) 'CalcCred Xadj=',Xadj
1546 
1547  zadjfshift(1:2) = -xadjshift(0,1:2)
1548 
1549  else
1550  zadjfshift(1) = zadjshift(1,1)*fshift(1)+zadjshift(2,1)*fshift(2)
1551  zadjfshift(2) = zadjshift(1,2)*fshift(1)+zadjshift(2,2)*fshift(2)
1552  xadjshift(2,2) = 2d0*mm02shift*mxshift(1,1) - fshift(1)*fshift(1)
1553  xadjshift(1,1) = 2d0*mm02shift*mxshift(2,2) - fshift(2)*fshift(2)
1554  xadjshift(2,1) = 2d0*mm02shift*mxshift(1,2) - fshift(1)*fshift(2)
1555  xadjshift(1,2) = xadjshift(2,1)
1556  end if
1557 
1558 #ifdef Credtestshift
1559  write(*,*) 'fishift ',fshift(1),fshift(2)
1560  write(*,*) 'm02shift ',mm02shift,mxshift(1,1),mxshift(2,2),mxshift(1,2)
1561  write(*,*) 'Xadjshift11 ', 2d0*mm02shift*mxshift(1,1) - fshift(2)*fshift(2),xadjshift(1,1)
1562  write(*,*) 'Xadjshift21 ', 2d0*mm02shift*mxshift(1,2) - fshift(1)*fshift(2),xadjshift(1,2)
1563  write(*,*) 'Xadjshift22 ', 2d0*mm02shift*mxshift(2,2) - fshift(1)*fshift(1),xadjshift(2,2)
1564  write(*,*) 'detXshiftn ',detxshift
1565  write(*,*) 'Zadjfshift1',zadjfshift(1),2d0*q20shift*fshift(1) &
1566  +(q21shift-q20shift-q10shift)*fshift(2)
1567  write(*,*) 'Zadjfshift2',zadjfshift(2), &
1568  (q21shift-q20shift-q10shift)*fshift(1)+2d0*q10shift*fshift(2)
1569 #endif
1570 
1571  maxzadjfshift = max(abs(zadjfshift(1)),abs(zadjfshift(2)))
1572 ! maxZadjfds = max(maxZadjfshift,adetZshift)
1573 
1574  azadjffshift = abs(zadjfshift(1)*fshift(1) + zadjfshift(2)*fshift(2))
1575 ! adetXshift = abs(2d0*mm02*detZshift - Zadjfshift(1)*fshift(1) - Zadjfshift(2)*fshift(2))
1576 ! maxXadjshift = max(abs(Xadjshift(1,1)),abs(Xadjshift(2,1)),abs(Xadjshift(2,2)))
1577 
1578  h_pvs = real(undefined_c)
1579  w_pvs = real(undefined_c)
1580  v_pvs = real(undefined_c)
1581  z_pvs = real(undefined_c)
1582  if (adetzshift.lt.dprec_cll*maxzadjfshift.or.adetzshift.lt.dprec_cll*maxzshift**2.or.adetzshift.eq.0d0) then
1583  use_pvs = .false.
1584  err_pvs = err_inf
1585  else
1586  use_pvs = .true.
1587  err_pvs(0) = err_c0
1588  if (rdef.gt.0) then
1589 #ifdef PVEST2
1590  h_pvs = sqrt(adetzshift)/maxzadjshift
1591  w_pvs = max((maxzadjfshift*h_pvs/adetzshift)**2, abs(mm02shift)*maxzshift*h_pv/adetzshift, &
1592  azadjffshift*maxzshift*(h_pvs/adetzshift)**2)
1593  v_pvs = maxzadjfshift*h_pvs/adetzshift
1594  z_pvs = maxz*h_pvs/adetzshift
1595 #else
1596  w_pvs = max((maxzadjfshift/adetzshift)**2, abs(mm02shift)*maxzshift/adetzshift, &
1597  maxzshift*azadjffshift/adetzshift**2)
1598  v_pvs = maxzadjfshift/adetzshift
1599  z_pvs = maxzshift/adetzshift
1600 #endif
1601 
1602 #ifdef Credtest
1603  write(*,*) 'CalcCred w_pvs',(maxzadjfshift/adetz)**2, abs(mm02shift)*maxz/adetz, maxz*azadjffshift/adetz**2
1604  write(*,*) 'CalcCred w_pvs',w_pvs,v_pvs,z_pv,h_pv
1605 #endif
1606 
1607  if (mod(rdef,2).eq.1) then
1608  err_pvs(rdef) = max( w_pvs**((rdef-1)/2) * v_pvs * err_c0, &
1609  max(w_pvs**((rdef-1)/2),1d0) * z_pv * err_b )
1610 
1611 #ifdef Credtest
1612  write(*,*) 'CalcCred err_pvs', w_pvs**((rdef-1)/2)* v_pvs* err_c0, &
1613  w_pvs**((rdef-1)/2) * z_pv * err_b, err_c0,err_b
1614  write(*,*) 'CalcCred err_pvs', w_pvs**((rdef-1)/2),v_pvs, err_c0
1615 #endif
1616 
1617  else
1618  err_pvs(rdef) = max( w_pvs**(rdef/2) * err_c0, &
1619  max(w_pvs**(rdef/2-1) * v_pvs, 1d0) * z_pv * err_b )
1620 
1621 #ifdef Credtest
1622  write(*,*) 'CalcCred w_pvs', w_pvs,err_c0,sqrt(w_pvs)
1623  write(*,*) 'CalcCred w_pvs', (maxzadjfshift/adetzshift)**2, &
1624  abs(mm02shift)*maxzshift/adetzshift, maxzshift*azadjffshift/adetzshift**2
1625  write(*,*) 'CalcCred err_pvs', w_pvs**(rdef/2) * err_c0, &
1626  w_pvs**(rdef/2-1) * v_pvs * z_pv * err_b, z_pv * err_b, err_c0,err_b
1627 #endif
1628 
1629  end if
1630  end if
1631  end if
1632 
1633 #ifdef Credtest
1634  write(*,*) 'CalcCred use_pvs',use_pvs,err_pvs(rdef).lt.err_pv(rdef),i
1635  write(*,*) 'CalcCred err_pvs',err_pvs(rdef),err_pv(rdef),i
1636 #endif
1637 
1638  if(use_pvs.and.err_pvs(rdef).lt. min(err_pv(rdef),err_pv2(rdef),err_g(rdef) &
1639  ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)) ) then
1640 
1641 #ifdef Credtest
1642  write(*,*) 'CalcCred: call Cpvs 1 ',rmax,id,err_pvs(rdef)
1643 #endif
1644 
1645  ! use shifted PV-reduction
1646  if (i.eq.1) then
1647  call calccpvshift(c_alt,cuv,p10,p20,p21,m12,m02,m22,rmax,id,cerr1_alt,cerr2_alt)
1648 ! map coefficients back, order of calculation matters!
1649  do r=1,rmax
1650  do n2=0,rmax-r
1651  do n1=rmax-n2,r,-1
1652  n0 = rmax-n1-n2
1653 ! write(*,*) 'pvs2',n0,n1,n2,-C_alt(0:n0,n1-1,n2),-C_alt(0:n0,n1,n2),-C_alt(0:n0,n1-1,n2+1)
1654  c_alt(0:n0,n1,n2) = -c_alt(0:n0,n1-1,n2)-c_alt(0:n0,n1,n2)-c_alt(0:n0,n1-1,n2+1)
1655 ! write(*,*) 'pvs2',n0,n1,n2,C_alt(0:n0,n1,n2)
1656  end do
1657  end do
1658  end do
1659 
1660  elseif (i.eq.2) then
1661  call calccpvshift(c_alt,cuv,p21,p10,p20,m22,m12,m02,rmax,id,cerr1_alt,cerr2_alt)
1662 
1663  do r=1,rmax
1664  do n1=0,rmax-r
1665  do n2=rmax-n1,r,-1
1666  n0 = rmax-n1-n2
1667  c_alt(0:n0,n1,n2) = -c_alt(0:n0,n1,n2-1)-c_alt(0:n0,n1,n2)-c_alt(0:n0,n1+1,n2-1)
1668 ! write(*,*) 'pvs2',n0,n1,n2,C_alt(0:n0,n1,n2),-C_alt(0:n0,n1,n2-1),-C_alt(0:n0,n1,n2),-C_alt(0:n0,n1+1,n2-1)
1669  end do
1670  end do
1671  end do
1672 
1673  end if
1674 
1675 #ifdef PVEST2
1676  cerr_alt = cerr2_alt
1677 #else
1678  cerr_alt = cerr1_alt
1679 #endif
1680  ccount(9) = ccount(9)+1
1681 ! CrCalc(0:rmax)=CrCalc(0:rmax)+1
1682 ! CCalc=CCalc+1
1683  crmethod_alt(0:rmax)=1
1684  if (cerr_alt(rmax).lt.cerr(rmax)) then
1685  ccount(8) = ccount(8)+1
1686  end if
1687 
1688 #ifdef Credtest
1689  checkest=cerr_alt(rdef)/err_pvs(rdef)
1690  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1691  write(*,*) 'CalcCred: estimate err_pvs imprecise ',err_pvs(rdef),cerr_alt(rdef)
1692  end if
1693 #endif
1694 
1695  err_pvs=cerr_alt
1696 
1697  call copycimp3(c,c_alt,cerr,cerr_alt,cerr1,cerr1_alt,cerr2,cerr2_alt,crmethod,crmethod_alt,rmax,rmax)
1698 
1699  if (rmax.ge.1) then
1700  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
1701  else
1702  ctyp = abs(c(0,0,0))
1703  end if
1704  err_req_cr = acc_req_cr * ctyp
1705 
1706 #ifdef Credtest
1707  write(*,*) 'CalcCred C0est after PVS=',abs(c(0,0,0)),ctyp
1708  write(*,*) 'CalcCred Cerr after PVS =',cerr
1709  write(*,*) 'CalcCred Cacc after PVS =',cerr/ctyp
1710  write(*,*) 'CalcCred err_req =',err_req_cr
1711  write(*,*) 'CalcCred Cerr1-req=',cerr1-err_req_cr
1712  write(*,*) 'CalcCred max(Cerr-req)',maxval(cerr-err_req_cr)
1713  write(*,*) 'CalcCred max(Cerr1-req)',maxval(cerr1-err_req_cr)
1714 #endif
1715 
1716 ! check with Cerr = Cerr2: exp not tried => larger errors
1717  if (maxval(cerr1-err_req_cr).lt.0) then
1718  ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
1719  return
1720  end if
1721 
1722  end if
1723  end do shiftloop
1724 #endif
1725 
1726 #ifdef Credtest
1727  write(*,*) 'CalcCred no optimal method aft shift',ctyp,acc_req_cr
1728  write(*,*) 'err_req=',err_req_cr(rdef),rdef
1729  write(*,*) 'err_est=',err_pv(rdef),err_pv2(rdef),err_g(rdef) &
1730  ,err_gy(rdef),err_gp(rdef),err_gr(rdef),err_gpf(rdef)
1731 #endif
1732 
1733 #ifdef TEST
1734  return ! TEST: no improvement by other methods
1735 #endif
1736 
1737  ! no method does work optimal
1738  ! use the least problematic (for each rank)
1739 
1740  do r=rmax,0,-1
1741 
1742 
1743  if(use_pv.and.mod(crcalc(r),2).ne.1) then
1744  ! estimate accuracy of PV-reduction if not yet calculated
1745  if (use_pv) then
1746 
1747 ! write(*,*) 'CalcCred err_pv', r,w_pv,v_pv,z_pv,err_C0,err_B
1748 
1749  if (mod(r,2).eq.1) then
1750  err_pv(r) = max( w_pv**((r-1)/2) * v_pv * err_c0, &
1751  max(w_pv**((r-1)/2),1d0) * z_pv * err_b )
1752 
1753 ! write(*,*) 'CalcCred err_pv', w_pv**((r-1)/2) * v_pv * err_C0, &
1754 ! w_pv**((r-1)/2) * z_pv * err_B, err_C0,err_B
1755 
1756  else if (r.ne.0) then
1757  err_pv(r) = max( w_pv**(r/2) * err_c0, &
1758  max(w_pv**(r/2-1) * v_pv , 1d0) * z_pv * err_b )
1759 
1760 ! write(*,*) 'CalcCred err_pv', w_pv**(rmax/2) * err_C0, &
1761 ! w_pv**(rmax/2-1) * v_pv * z_pv * err_B, err_C0,err_B
1762  else
1763  err_pv(r) = err_c0
1764  end if
1765  else
1766  err_pv(r) = err_inf
1767  end if
1768  ! scale estimates down to allow trying other methods
1769  err_pv(r) = err_pv(r)/impest_c
1770  end if
1771 
1772  if (use_pv2.and.mod(crcalc(r),4)-mod(crcalc(r),2).ne.2) then
1773  ! estimate accuracy of alternative PV-reduction if not yet calculated
1774  if (use_pv2) then
1775  if (mod(r,2).eq.1) then
1776 ! change 21.10.15 for PVEST2
1777 ! err_pv2(r) = max( err_C0 * max(w_pv2**r,w_pv2*v_pv2**((r-1)/2) ), &
1778 ! err_B * z_pv2 * max(w_pv2**(r+1),w_pv2, &
1779 ! w_pv2*v_pv2**((r-1)/2),w_pv2**2, &
1780 ! v_pv2**((r+1)/2),v_pv2) )
1781  err_pv2(r) = max( err_c0 * max(hw_pv2**r,hw_pv2*v_pv2**((r-1)/2) ), &
1782  err_b * z_pv2 * max(w_pv2*hw_pv2**(r),hw_pv2, &
1783  hw_pv2*v_pv2**((r-1)/2),w_pv2*hw_pv2, &
1784  w_pv2*hw_pv2*v_pv2**((r-1)/2), &
1785  v_pv2**((r+1)/2),v_pv2) )
1786 
1787 ! write(*,*) 'CalcC err_pv2 ',r, err_pv2(r), &
1788 ! err_C0 * max(1d0,w_pv2**r,v_pv2**((r-1)/2),w_pv2*v_pv2**((r-1)/2) ) , &
1789 ! err_B * max(1d0,z_pv2*w_pv2**(r+1),z_pv2*w_pv2, &
1790 ! z_pv2*w_pv2*v_pv2**((r-1)/2),z_pv2*w_pv2**2, &
1791 ! z_pv2*v_pv2**((r+1)/2),z_pv2*v_pv2)
1792 
1793  else
1794 ! change 21.10.15 for PVEST2
1795 ! err_pv2(r) = max( err_C0 * max(w_pv2**r,v_pv2**(r/2)), &
1796 ! err_B * z_pv2 * max(w_pv2**(r+1),w_pv2, &
1797 ! w_pv2*v_pv2**(r/2), w_pv2**2, &
1798 ! v_pv2**(r/2),v_pv2) )
1799  err_pv2(r) = max( err_c0 * max(hw_pv2**r,v_pv2**(r/2)), &
1800  err_b * z_pv2 * max(w_pv2*hw_pv2**(r),hw_pv2, &
1801  hw_pv2*v_pv2**(r/2), w_pv2*hw_pv2, &
1802  v_pv2**(r/2),v_pv2) )
1803  end if
1804  else
1805  err_pv2(r) = err_inf
1806  end if
1807  ! scale estimates down to allow trying other methods
1808  err_pv2(r) = err_pv2(r)/impest_c
1809  end if
1810 
1811  if (use_g.and.mod(crcalc(r),8)-mod(crcalc(r),4).ne.4) then
1812  ! estimate accuracy of alternative Gram expansion if not yet calculated
1813  err_g_b(r) = err_b * u_g**r * z_g
1814  err_g_exp = u_g**(r-1) * ctyp
1815  err_g(r) = err_inf
1816 
1817  ! determine optimal order of expansion
1818  do i=0,rmax_c-r
1819  g = i
1820  err_g_exp = err_g_exp*fac_g
1821  err_g(r) = max(err_g_exp,err_g_b(r))
1822 
1823 ! write(*,*) 'CalcCred gi',i,g,err_g_exp,err_g(r),err_g_B(r),err_req_Cr(r)
1824 
1825  if (err_g_exp.lt.err_g_b(r).or.err_g(r).lt.err_req_cr(r)) exit
1826  end do
1827  ! increase gp by 2 to account for bad estimates
1828  g = min(max(g+2,2*g),rmax_c-r)
1829  ! scale estimates down to allow trying other methods
1830  err_g(r) = err_g(r)/impest_c
1831  end if
1832 
1833  if (use_gy.and.mod(crcalc(r),16)-mod(crcalc(r),8).ne.8) then
1834  ! estimate accuracy of alternative Gram-Cayley expansion if not yet calculated
1835  err_gy_b(r) = err_b * b_gy*v1_gy
1836  err_gy_exp = 1d0 * ctyp
1837 
1838  ! determine optimal order of expansion
1839  gy = 0
1840  do i=0,rmax_c-r
1841  if (mod(i,2).eq.1) then
1842  gy = i/2
1843  err_gy_exp = err_gy_exp*fac_gy
1844  err_gy(r) = max(err_gy_exp, err_gy_b(r))
1845  if (err_gy_exp.lt.err_gy_b(r).or.err_gy(r).lt.err_req_cr(r)) exit
1846  end if
1847  end do
1848  ! increase gy by 2 to account for bad estimates
1849  gy = min(max(gy+4,2*gy),(rmax_c-r)/2)
1850  ! scale estimates down to allow trying other methods
1851  err_gy(r) = err_gy(r)/impest_c
1852  end if
1853 
1854  if (use_gp.and.mod(crcalc(r),32)-mod(crcalc(r),16).ne.16) then
1855  ! estimate accuracy of small momentum expansion if not yet calculated
1856  err_gp_b(r) = err_b * z_gp*v_gp**r
1857  err_gp_exp = v_gp**(r-1) * ctyp
1858 
1859  ! determine optimal order of expansion
1860  do i=0,rmax_c-r
1861  gp = i
1862  err_gp_exp = err_gp_exp*fac_gp
1863  err_gp(r) = max(err_gp_exp,err_gp_b(r))
1864  if (err_gp_exp.lt.err_gp_b(r).or.err_gp(r).lt.err_req_cr(r)) exit
1865  end do
1866  ! increase gp by 2 to account for bad estimates
1867  gp = min(max(gp+2,2*gp),rmax_c-r)
1868  ! scale estimates down to allow trying other methods
1869  err_gp(r) = err_gp(r)/impest_c
1870  end if
1871 
1872  if (mod(crcalc(r),64)-mod(crcalc(r),32).ne.32.and.use_gr) then
1873  ! estimate accuracy of alternative Gram expansion
1874  err_gr_b(r) = err_b * a_gr
1875  err_gr_exp = y1_gr * ctyp
1876 
1877  ! determine optimal order of expansion
1878  gr = 0
1879  do i=0,rmax_c-r
1880  if (mod(i,2).eq.1) then
1881  gr = i/2
1882  err_gr_exp = err_gr_exp*fac_gr
1883  err_gr(r) = max(err_gr_exp,err_gr_b(r))
1884 
1885 #ifdef Cgrtest
1886  write(*,*) 'CalcCgr err_gr',i,gr,err_gr_exp,err_gr_b(r),err_gr(r),err_req_cr(r)
1887 #endif
1888 
1889  if (err_gr_exp.lt.err_gr_b(r).or.err_gr(r).lt.err_req_cr(r)) exit
1890  end if
1891  end do
1892  ! increase gr to account for bad estimates
1893 ! changed 28.07.14
1894 ! gr = min(max(gr+2,2*gr),(rmax_C-r)/2)
1895  gr = min(max(gr+2,2*gr),rmax_c-r,max(0,(rmax_b-2*r)/2))
1896  ! scale estimates down to allow trying other methods
1897  err_gr(r) = err_gr(r)/impest_c
1898 
1899  end if
1900 
1901  if (use_gpf.and.mod(crcalc(r),128)-mod(crcalc(r),64).ne.64) then
1902  ! estimate accuracy of alternative Gram-Cayley expansion if not yet calculated
1903  err_gpf_b(r) = err_b * b_gpf*v1_gpf
1904  err_gpf_exp = 1d0 * ctyp
1905 
1906  ! determine optimal order of expansion
1907  gpf = 0
1908  do i=0,rmax_c-r
1909  if (mod(i,2).eq.1) then
1910  gpf = i/2
1911  err_gpf_exp = err_gpf_exp*fac_gpf
1912  err_gpf(r) = max(err_gpf_exp, err_gpf_b(r))
1913  if (err_gpf_exp.lt.err_gpf_b(r).or.err_gpf(r).lt.err_req_cr(r)) exit
1914  end if
1915  end do
1916  ! increase gpf by 2 to account for bad estimates
1917  gpf = min(max(gpf+4,2*gpf),(rmax_c-r)/2)
1918  ! scale estimates down to allow trying other methods
1919  err_gpf(r) = err_gpf(r)/impest_c
1920  end if
1921 
1922 
1923 #ifdef Credtest
1924  write(*,*) 'CalcCred: bef final loop expansion depth',r,g,gy,gp,gr,gpf
1925  write(*,*) 'CalcCred: bef final loop err methods',r,err_pv(r),err_pv2(r) &
1926  ,err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gp(r),err_gpf(r)
1927  write(*,*) 'CalcCred: bef final loop acc methods',r,err_pv(r)/ctyp,err_pv2(r)/ctyp, &
1928  err_g(r)/ctyp,err_gy(r)/ctyp,err_gp(r)/ctyp,err_gr(r)/ctyp,err_gpf(r)/ctyp
1929  write(*,*) 'CalcCred: bef final loop',r,crcalc(r),crmethod(r)
1930 #endif
1931 
1932 100 continue ! try other methods if error larger than expected
1933 
1934  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)) &
1935  .and.min(err_pv(r),err_pv2(r)).lt.err_inf) then
1936 
1937  if (use_pv.and.err_pv(r).le.err_pv2(r).and.mod(crcalc(r),2).ne.1) then
1938 
1939 ! deallocate(C_alt)
1940 ! deallocate(Cuv_alt)
1941 ! deallocate(Cerr_alt)
1942 ! deallocate(Cerr2_alt)
1943 ! deallocate(Crmethod_alt)
1944 ! allocate(C_alt(0:r,0:r,0:r))
1945 ! allocate(Cuv_alt(0:r,0:r,0:r))
1946 ! allocate(Cerr_alt(0:r))
1947 ! allocate(Cerr2_alt(0:r))
1948 ! allocate(Crmethod_alt(0:r))
1949 
1950 #ifdef Credtest
1951  write(*,*) 'CalcCred: call Cpv 2',r,id
1952 #endif
1953  if (r.eq.rmax) then
1954  call calccpv1(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,id,cerr1_alt,cerr2_alt)
1955  else
1956  call calccpv1(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
1957  p10,p21,p20,m02,m12,m22,r,id,cerr1_alt(0:r),cerr2_alt(0:r))
1958  end if
1959 #ifdef PVEST2
1960  cerr_alt = cerr2_alt
1961 #else
1962  cerr_alt = cerr1_alt
1963 #endif
1964  ccount(11) = ccount(11)+1
1965  crcalc(0:r)=crcalc(0:r)+1
1966  ccalc=ccalc+1
1967  crmethod_alt(0:r)=1
1968  checkest=cerr_alt(r)/(err_pv(r)*abs(c_alt(0,0,0)))
1969 
1970 #ifdef Credtest
1971  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
1972  write(*,*) 'CalcCred: estimate acc_pv imprecise',err_pv(r),cerr_alt(r)/abs(c_alt(0,0,0))
1973  end if
1974 #endif
1975 
1976  err_pv(0:r)=cerr_alt(0:r)
1977 
1978  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
1979  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
1980 
1981  if (rmax.ge.1) then
1982  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
1983  else
1984  ctyp = abs(c(0,0,0))
1985  end if
1986  err_req_cr = acc_req_cr * ctyp
1987 
1988 #ifdef Credtest
1989  write(*,*) 'CalcCred: after pv 2nd try Cmethod',crmethod
1990  write(*,*) 'CalcCred: after pv 2nd try Cerr(r)',cerr
1991  write(*,*) 'CalcCred: after pv 2nd try Cacc(r)',cerr/ctyp
1992 #endif
1993 
1994  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
1995 
1996  elseif (use_pv2.and.err_pv2(r).le.err_pv(r).and.mod(crcalc(r),4)-mod(crcalc(r),2).ne.2) then
1997 
1998 ! deallocate(C_alt)
1999 ! deallocate(Cuv_alt)
2000 ! deallocate(Cerr_alt)
2001 ! deallocate(Cerr2_alt)
2002 ! deallocate(Crmethod_alt)
2003 ! allocate(C_alt(0:r,0:r,0:r))
2004 ! allocate(Cuv_alt(0:r,0:r,0:r))
2005 ! allocate(Cerr_alt(0:r))
2006 ! allocate(Cerr2_alt(0:r))
2007 ! allocate(Crmethod_alt(0:r))
2008 
2009  if (r.eq.rmax) then
2010  call calccpv2(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,id,cerr1_alt,cerr2_alt)
2011  else
2012  call calccpv2(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r),p10,p21,p20,m02,m12,m22,r,id,cerr1_alt(0:r),cerr2_alt(0:r))
2013  end if
2014 #ifdef PVEST2
2015  cerr_alt = cerr2_alt
2016 #else
2017  cerr_alt = cerr1_alt
2018 #endif
2019  ccount(12) = ccount(12)+1
2020  crcalc(0:r)=crcalc(0:r)+2
2021  ccalc=ccalc+2
2022  crmethod_alt(0:r)=2
2023  checkest=cerr_alt(r)/(err_pv(r)*abs(c_alt(0,0,0)))
2024 
2025 #ifdef Credtest
2026  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2027  write(*,*) 'CalcCred: estimate err_pv2 imprecise',err_pv2(r),cerr_alt(r)
2028  end if
2029 #endif
2030 
2031  err_pv2(0:r)=cerr_alt(0:r)
2032 
2033  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2034  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2035 
2036  if (rmax.ge.1) then
2037  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2038  else
2039  ctyp = abs(c(0,0,0))
2040  end if
2041  err_req_cr = acc_req_cr * ctyp
2042 
2043 #ifdef Credtest
2044  write(*,*) 'CalcCred: after pv 2nd try Cmethod',crmethod
2045  write(*,*) 'CalcCred: after pv 2nd try Cerr(r)',cerr
2046  write(*,*) 'CalcCred: after pv 2nd try Cacc(r)',cerr/ctyp
2047 #endif
2048 
2049  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2050 
2051  end if
2052 
2053  else
2054 
2055 #ifdef Credtest
2056  write(*,*) 'CalcCred: explore exps once more'
2057 #endif
2058 
2059  if (use_g.and.err_g(r).le.min(err_gy(r),err_gp(r),err_gr(r),err_gpf(r)) &
2060  .and.mod(crcalc(r),8)-mod(crcalc(r),4).ne.4) then
2061 
2062 ! deallocate(C_alt)
2063 ! deallocate(Cuv_alt)
2064 ! deallocate(Cerr_alt)
2065 ! deallocate(Cerr2_alt)
2066 ! deallocate(Crmethod_alt)
2067 ! allocate(C_alt(0:r,0:r,0:r))
2068 ! allocate(Cuv_alt(0:r,0:r,0:r))
2069 ! allocate(Cerr_alt(0:r))
2070 ! allocate(Cerr2_alt(0:r))
2071 ! allocate(Crmethod_alt(0:r))
2072 
2073  if (r.eq.rmax) then
2074  call calccg(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,g,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
2075  else
2076  call calccg(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
2077  p10,p21,p20,m02,m12,m22,r,g,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
2078  end if
2079 #ifdef PVEST2
2080  cerr_alt = cerr2_alt
2081 #else
2082  cerr_alt = cerr1_alt
2083 #endif
2084  ccount(13) = ccount(13)+1
2085  crcalc(0:r)=crcalc(0:r)+4
2086  ccalc=ccalc+4
2087  crmethod_alt(0:r)=4
2088  checkest=cerr_alt(r)/err_g(r)
2089 
2090 #ifdef Credtest
2091  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2092  write(*,*) 'CalcCred: estimate err_g imprecise ',err_g(r),cerr_alt(r)
2093  end if
2094 #endif
2095 
2096  err_g(0:r)=cerr_alt(0:r)
2097 
2098  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2099  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2100 
2101  if (rmax.ge.1) then
2102  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2103  else
2104  ctyp = abs(c(0,0,0))
2105  end if
2106  err_req_cr = acc_req_cr * ctyp
2107 
2108 #ifdef Credtest
2109  write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
2110  write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
2111  write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
2112 #endif
2113 
2114  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2115 
2116  else if (use_gy.and.err_gy(r).le.min(err_g(r),err_gp(r),err_gr(r),err_gpf(r)) &
2117  .and.mod(crcalc(r),16)-mod(crcalc(r),8).ne.8) then
2118 ! deallocate(C_alt)
2119 ! deallocate(Cuv_alt)
2120 ! deallocate(Cerr_alt)
2121 ! deallocate(Cerr2_alt)
2122 ! deallocate(Crmethod_alt)
2123 ! allocate(C_alt(0:r,0:r,0:r))
2124 ! allocate(Cuv_alt(0:r,0:r,0:r))
2125 ! allocate(Cerr_alt(0:r))
2126 ! allocate(Cerr2_alt(0:r))
2127 ! allocate(Crmethod_alt(0:r))
2128 
2129  if (r.eq.rmax) then
2130  call calccgy(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gy,(rmax_c)/2,id,cerr1_alt,acc_req_cr,cerr2_alt)
2131  else
2132  call calccgy(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
2133  p10,p21,p20,m02,m12,m22,r,gy,(rmax_c)/2,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
2134  end if
2135 #ifdef PVEST2
2136  cerr_alt = cerr2_alt
2137 #else
2138  cerr_alt = cerr1_alt
2139 #endif
2140  ccount(14) = ccount(14)+1
2141  crcalc(0:r)=crcalc(0:r)+8
2142  ccalc=ccalc+8
2143  crmethod_alt(0:r)=8
2144  checkest=cerr_alt(r)/err_gy(r)
2145 
2146 #ifdef Credtest
2147  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2148  write(*,*) 'CalcCred: estimate err_gy imprecise',err_gy(r),cerr_alt(r)
2149  end if
2150 #endif
2151  err_gy(0:r)=cerr_alt(0:r)
2152 
2153  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2154  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2155 
2156  if (rmax.ge.1) then
2157  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2158  else
2159  ctyp = abs(c(0,0,0))
2160  end if
2161  err_req_cr = acc_req_cr * ctyp
2162 
2163 #ifdef Credtest
2164  write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
2165  write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
2166  write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
2167 #endif
2168 
2169  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2170 
2171  elseif (use_gp.and.err_gp(r).le.min(err_g(r),err_gy(r),err_gr(r),err_gpf(r)) &
2172  .and.mod(crcalc(r),32)-mod(crcalc(r),16).ne.16) then
2173 
2174 ! deallocate(C_alt)
2175 ! deallocate(Cuv_alt)
2176 ! deallocate(Cerr_alt)
2177 ! deallocate(Cerr2_alt)
2178 ! deallocate(Crmethod_alt)
2179 ! allocate(C_alt(0:r,0:r,0:r))
2180 ! allocate(Cuv_alt(0:r,0:r,0:r))
2181 ! allocate(Cerr_alt(0:r))
2182 ! allocate(Cerr2_alt(0:r))
2183 ! allocate(Crmethod_alt(0:r))
2184 
2185  if (r.eq.rmax) then
2186  call calccgp(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gp,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
2187  else
2188  call calccgp(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
2189  p10,p21,p20,m02,m12,m22,r,gp,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
2190  end if
2191 #ifdef PVEST2
2192  cerr_alt = cerr2_alt
2193 #else
2194  cerr_alt = cerr1_alt
2195 #endif
2196  ccount(15) = ccount(15)+1
2197  crcalc(0:r)=crcalc(0:r)+16
2198  ccalc=ccalc+16
2199  crmethod_alt(0:r)=16
2200  checkest=cerr_alt(r)/err_gp(r)
2201 
2202 #ifdef Credtest
2203  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2204  write(*,*) 'CalcCred: estimate err_gp imprecise',err_gp(r),cerr_alt(r)
2205  end if
2206 #endif
2207 
2208  err_gp(0:r)=cerr_alt(0:r)
2209 
2210  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2211  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2212 
2213  if (rmax.ge.1) then
2214  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2215  else
2216  ctyp = abs(c(0,0,0))
2217  end if
2218  err_req_cr = acc_req_cr * ctyp
2219 
2220 #ifdef Credtest
2221  write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
2222  write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
2223  write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
2224 #endif
2225 
2226  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2227 
2228  elseif (use_gr.and.err_gr(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gpf(r)) &
2229  .and.mod(crcalc(r),64)-mod(crcalc(r),32).ne.32) then
2230 ! deallocate(C_alt)
2231 ! deallocate(Cuv_alt)
2232 ! deallocate(Cerr_alt)
2233 ! deallocate(Cerr2_alt)
2234 ! deallocate(Crmethod_alt)
2235 ! allocate(C_alt(0:r,0:r,0:r))
2236 ! allocate(Cuv_alt(0:r,0:r,0:r))
2237 ! allocate(Cerr_alt(0:r))
2238 ! allocate(Cerr2_alt(0:r))
2239 ! allocate(Crmethod_alt(0:r))
2240 
2241  if (r.eq.rmax) then
2242  call calccgr(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gr,rmax_c,id,cerr1_alt,acc_req_cr,cerr2_alt)
2243  else
2244  call calccgr(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
2245  p10,p21,p20,m02,m12,m22,r,gr,rmax_c,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
2246  end if
2247 #ifdef PVEST2
2248  cerr_alt = cerr2_alt
2249 #else
2250  cerr_alt = cerr1_alt
2251 #endif
2252  ccount(16) = ccount(16)+1
2253  crcalc(0:r)=crcalc(0:r)+32
2254  ccalc=ccalc+32
2255  crmethod_alt(0:r)=32
2256  checkest=cerr_alt(r)/err_gr(r)
2257 
2258 #ifdef Credtest
2259  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2260  write(*,*) 'CalcCred: estimate err_gr imprecise',err_gr(r),cerr_alt(r)
2261  end if
2262 #endif
2263 
2264  err_gr(0:r)=cerr_alt(0:r)
2265 
2266  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2267  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2268 
2269  if (rmax.ge.1) then
2270  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2271  else
2272  ctyp = abs(c(0,0,0))
2273  end if
2274  err_req_cr = acc_req_cr * ctyp
2275 
2276 #ifdef Credtest
2277  write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
2278  write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
2279  write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
2280 #endif
2281 
2282  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2283 
2284  else if (use_gpf.and.err_gpf(r).le.min(err_g(r),err_gy(r),err_gp(r),err_gr(r)) &
2285  .and.mod(crcalc(r),128)-mod(crcalc(r),64).ne.64) then
2286 ! deallocate(C_alt)
2287 ! deallocate(Cuv_alt)
2288 ! deallocate(Cerr_alt)
2289 ! deallocate(Cerr2_alt)
2290 ! deallocate(Crmethod_alt)
2291 ! allocate(C_alt(0:r,0:r,0:r))
2292 ! allocate(Cuv_alt(0:r,0:r,0:r))
2293 ! allocate(Cerr_alt(0:r))
2294 ! allocate(Cerr2_alt(0:r))
2295 ! allocate(Crmethod_alt(0:r))
2296 
2297  if (r.eq.rmax) then
2298  call calccgpf(c_alt,cuv,p10,p21,p20,m02,m12,m22,r,gpf,(rmax_c)/2,id,cerr1_alt,acc_req_cr,cerr2_alt)
2299  else
2300  call calccgpf(c_alt(0:r,0:r,0:r),cuv_alt(0:r,0:r,0:r), &
2301  p10,p21,p20,m02,m12,m22,r,gpf,(rmax_c)/2,id,cerr1_alt(0:r),acc_req_cr(0:r),cerr2_alt(0:r))
2302  end if
2303 #ifdef PVEST2
2304  cerr_alt = cerr2_alt
2305 #else
2306  cerr_alt = cerr1_alt
2307 #endif
2308  ccount(17) = ccount(17)+1
2309  crcalc(0:r)=crcalc(0:r)+64
2310  ccalc=ccalc+64
2311  crmethod_alt(0:r)=64
2312  checkest=cerr_alt(r)/err_gpf(r)
2313 
2314 #ifdef Credtest
2315  if(checkest.gt.1d2*impest_c.or.checkest.lt.1d-2*impest_c) then
2316  write(*,*) 'CalcCred: estimate err_gpf imprecise',err_gpf(r),cerr_alt(r)
2317  end if
2318 #endif
2319  err_gpf(0:r)=cerr_alt(0:r)
2320 
2321  call copycimp3(c,c_alt(0:r,0:r,0:r),cerr,cerr_alt(0:r),cerr1,cerr1_alt(0:r), &
2322  cerr2,cerr2_alt(0:r),crmethod,crmethod_alt(0:r),rmax,r)
2323 
2324  if (rmax.ge.1) then
2325  ctyp = max(abs(c(0,0,0)),abs(c(0,1,0)),abs(c(0,0,1)))
2326  else
2327  ctyp = abs(c(0,0,0))
2328  end if
2329  err_req_cr = acc_req_cr * ctyp
2330 
2331 #ifdef Credtest
2332  write(*,*) 'CalcCred: after exps 2nd try Cmethod',crmethod
2333  write(*,*) 'CalcCred: after exps 2nd try Cerr(r)',cerr
2334  write(*,*) 'CalcCred: after exps 2nd try Cacc(r)',cerr/ctyp
2335 #endif
2336 
2337  if(checkest.gt.impest_c.and.mode_coli.lt.1) goto 100 ! error larger than expected: try other methods
2338 
2339  end if
2340 
2341  end if
2342 
2343 #ifndef USEC0
2344 #ifndef ALWAYSPV
2345  ! refine error estimate for C0
2346  if(.not.lerr_c0) then
2347 ! C0est = abs(C(0,0,0))
2348  err_c0 = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
2349 ! err_req_Cr = acc_req_Cr * abs(C(0,0,0))
2350  lerr_c0 = .true.
2351  end if
2352 #endif
2353 #endif
2354 
2355 #ifdef Credtest
2356  write(*,*) 'CalcCred: final loop err methods',r,err_pv(r),err_pv2(r), &
2357  err_g(r),err_gy(r),err_gp(r),err_gr(r),err_gpf(r)
2358  write(*,*) 'CalcCred: final loop acc methods',r,err_pv(r)/ctyp,err_pv2(r)/ctyp, &
2359  err_g(r)/ctyp,err_gy(r)/ctyp,err_gp(r)/ctyp,err_gr(r)/ctyp,err_gpf(r)/ctyp
2360  write(*,*) 'CalcCred: final loop',r,crcalc(r),crmethod(r)
2361 #endif
2362  end do
2363 
2364  norm = abs(c(0,0,0))
2365  do r=1,rdef
2366  do n1=0,rdef
2367  n2 = rdef-n1
2368  norm = max(norm,abs(c(0,n1,n2)))
2369  end do
2370  end do
2371  acc_c(0:rdef) = cerr(0:rdef)/norm
2372 
2373  ccount(ccalc+ccountoffset0) = ccount(ccalc+ccountoffset0)+1
2374 
2375  if (maxval(acc_c(0:rdef)-sqrt(reqacc_coli)).gt.0) then
2376  ccount(ccalc+ccountoffset3) = ccount(ccalc+ccountoffset3)+1
2377  end if
2378 
2379  if (maxval(acc_c(0:rdef)-reqacc_coli).gt.0) then
2380  ccount(ccalc+ccountoffset1) = ccount(ccalc+ccountoffset1)+1
2381  end if
2382 
2383 #ifdef Credtest
2384  write(*,*) 'CalcCred final acc_C=',cerr/norm,critacc_coli
2385  write(*,*) 'CalcCred final method C=',crmethod
2386 #endif
2387 
2388  if (maxval(acc_c(0:rdef)-critacc_coli).gt.0) then
2389 
2390  ccount(ccalc+ccountoffset2) = ccount(ccalc+ccountoffset2)+1
2391 
2392 #ifdef Credtest
2393  write(*,*) 'CritPoint C',critacc_coli,acc_c
2394  write(*,*) 'CritPoint C',maxval(acc_c(0:rdef)-critacc_coli),maxval(acc_c(0:rdef)),rdef,acc_c(rdef)
2395 #endif
2396 
2397 ! call SetErrFlag_coli(-5)
2398 ! call ErrOut_coli('CalcCred',' critical accuracy not reached', &
2399 ! errorwriteflag)
2400 
2401 #ifdef CritPointsCOLI
2402  critpointcntc = critpointcntc + 1
2403 
2404  if (critpointcntc.le.maxcritpointc.and.monitoring) then
2405  call critpointsout_coli('C_coli',acc_c(rdef))
2406  write(ncpout_coli,*) 'arguments of CalcCred_coli:'
2407  write(ncpout_coli,*) 'rank = ', rmax
2408  if(present(rbasic)) write(ncpout_coli,*) 'rbas = ', rbasic
2409  write(ncpout_coli,fmt1) 'p10 = ', p10
2410  write(ncpout_coli,fmt1) 'p21 = ', p21
2411  write(ncpout_coli,fmt1) 'p20 = ', p20
2412  write(ncpout_coli,fmt1) 'm02 = ', m02
2413  write(ncpout_coli,fmt1) 'm12 = ', m12
2414  write(ncpout_coli,fmt1) 'm22 = ', m22
2415  if (critpointcntc.eq.maxcritpointc) then
2416  write(ncpout_coli,*)
2417  write(ncpout_coli,*)
2418  write(ncpout_coli,*)
2419  write(ncpout_coli,*) '***********************************************************'
2420  write(ncpout_coli,*)
2421  write(ncpout_coli,*) ' Further output of bad C functions will be suppressed '
2422  end if
2423  end if
2424 #endif
2425  end if
2426 
2427 #ifdef Credtest
2428  write(*,*) 'CalcCred out'
2429 #endif
2430 
2431  end subroutine calccred
2432 
2433 
2434 
2435 
2436  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2437  ! subroutine CalcCuv(Cuv,Buv_0,m02,f,rmax,id)
2438  !
2439  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2440 
2441  subroutine calccuv(Cuv,Buv_0,m02,f,rmax,id)
2442 
2443  integer, intent(in) :: rmax,id
2444  double complex, intent(in) :: m02,f(2)
2445 ! double complex, intent(inout) :: Cuv(0:rmax,0:rmax,0:rmax)
2446  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
2447  double complex, intent(in) :: Buv_0(0:rmax-1,0:rmax-1,0:rmax-1)
2448  integer :: r,n0,n1,n2,r0
2449 
2450  ! C_(0,n1,n2) UV-finite
2451  cuv(0,:,:) = 0d0
2452 
2453 ! do r=2,rmax
2454 ! do n0=1,rmax/2
2455 ! do n1=0,r-2*n0
2456 ! n2 = r-2*n0-n1
2457  do r=2,2*rmax
2458  do n0=max(1,r-rmax),r/2
2459  do n1=0,r-2*n0
2460  n2 = r-2*n0-n1
2461 
2462  cuv(n0,n1,n2) = (buv_0(n0-1,n1,n2) + 2*m02*cuv(n0-1,n1,n2) &
2463  + f(1)*cuv(n0-1,n1+1,n2) &
2464  + f(2)*cuv(n0-1,n1,n2+1)) / (2*r)
2465 
2466  end do
2467  end do
2468  end do
2469 
2470  end subroutine calccuv
2471 
2472 
2473 
2474 
2475 
2476 
2477  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2478  ! subroutine CalcCpv1(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
2479  !
2480  ! new version 10.02.2016 (5.10) with (5.11) inserted
2481  ! 27.09.2016 prefactors of B_0 improved
2482  ! 02.09.2017 allocate and q1q2 removed
2483  !
2484  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2485 
2486  subroutine calccpv1(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
2487 
2488  use globalc
2489 
2490  integer, intent(in) :: rmax,id
2491  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
2492  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
2493  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
2494  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
2495 ! double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
2496 ! double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
2497 ! double complex, allocatable :: C_alt(:,:,:)
2498  double complex :: B_0(0:rmax-1,0:rmax-1,0:rmax-1), Buv_0(0:rmax-1,0:rmax-1,0:rmax-1)
2499  double complex :: B_i(0:rmax-1,0:rmax-1,2), Buv_i(0:rmax-1,0:rmax-1,2)
2500  double complex :: C_alt(0:rmax,0:rmax,0:rmax)
2501  double complex :: Smod(2)
2502  double complex :: C0_coli, elimminf2_coli
2503 ! double precision, allocatable :: C00_err(:),Cij_err(:)
2504 ! double precision, allocatable :: C00_err2(:),Cij_err2(:)
2505  double precision :: C00_err(0:rmax),Cij_err(0:rmax)
2506  double precision :: C00_err2(0:rmax),Cij_err2(0:rmax)
2507  double precision :: B_err,B_max
2508  integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
2509  integer :: bin,k,nid(0:2)
2510 
2511 #ifdef Cpv1test
2512 ! write(*,*) 'CalcCpv1 p in ',p10,p21,p20
2513 ! write(*,*) 'CalcCpv1 m in ',m02,m12,m22
2514  write(*,*) 'CalcCpv1 in ',rmax,id
2515 #endif
2516 #ifdef TRACECin
2517  write(*,*) 'CalcCpv1 in ',rmax,id
2518 #endif
2519 
2520  ! calculation of scalar coefficient
2521  c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
2522  cuv(0,0,0) = 0d0
2523 
2524  ! accuracy estimate for C0 function
2525  cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
2526  cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
2527 
2528  if (rmax.eq.0) return
2529 
2530  ! allocation and calculation of B functions
2531  rmaxb = rmax-1
2532  ! rmaxB = max(rmax-1,0)
2533 ! allocate(B_0(0:rmaxB,0:rmaxB,0:rmaxB))
2534 ! allocate(Buv_0(0:rmaxB,0:rmaxB,0:rmaxB))
2535 ! allocate(B_i(0:rmaxB,0:rmaxB,2))
2536 ! allocate(Buv_i(0:rmaxB,0:rmaxB,2))
2537 
2538  ! allocate arrays for error propagation
2539 ! allocate(C00_err(0:rmax))
2540 ! allocate(Cij_err(0:rmax))
2541 ! allocate(C00_err2(0:rmax))
2542 ! allocate(Cij_err2(0:rmax))
2543 
2544  ! determine binaries for B-coefficients
2545  k=0
2546  bin = 1
2547  do while (k.le.2)
2548  if (mod(id/bin,2).eq.0) then
2549  nid(k) = id+bin
2550  k = k+1
2551  end if
2552  bin = 2*bin
2553  end do
2554 
2555  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
2556  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
2557  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
2558 
2559  ! shift of integration momentum in B_0 and calculate maximal B(0,...)
2560  b_max=0d0
2561  do n1=1,rmaxb
2562  do n2=0,rmaxb-n1
2563  n0 = (rmaxb-n1-n2)
2564  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
2565  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
2566  b_max = max(b_max,abs(b_0(0,n1,n2)))
2567  end do
2568  end do
2569 
2570 ! write(*,*) 'B_max=',B_max
2571 
2572  b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
2573 
2574  ! determine inverse Gram matrix
2575  ! commented out 2.9.2017
2576  ! Zinv = Zadj/detZ
2577 
2578  ! calculate Cuv
2579  call calccuv(cuv,buv_0,mm02,f,rmax,id)
2580 
2581  ! initialization of error propagation
2582  cij_err =0d0
2583  c00_err =0d0
2584  cij_err(0) = cerr(0)
2585  b_err = acc_def_b*b_max
2586 
2587  cij_err2 =0d0
2588  c00_err2 =0d0
2589  cij_err2(0) = cerr2(0)
2590 
2591 
2592 #ifdef Cpv1test
2593 ! write(*,*) 'CalcCpv1: B_err= ',B_err,acc_def_B,B_max
2594  write(*,*) 'CalcDpv1 Cij_err(0)=',cij_err(0)
2595 ! write(*,*) 'CalcCpv1 test :', &
2596 ! (1d0 - (Zadjf(1)+Zadjf(2))/detZ), &
2597 ! (detZmZadjf + Zadjs(1)*(mm12-mm02) + Zadjs(2)*(mm22-mm02)) /detZ
2598 #endif
2599 
2600 ! allocate(C_alt(0:rmax,0:rmax,0:rmax))
2601 
2602  ! PV reduction
2603  do r=1,rmax
2604 
2605  ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
2606  do n0=r/2,1,-1
2607  do n1=0,r-2*n0
2608  n2 = r-2*n0-n1
2609  c(n0,n1,n2) = + 4*cuv(n0,n1,n2) + detx/detz*c(n0-1,n1,n2)
2610  c(n0,n1,n2) = c(n0,n1,n2) &
2611  + (detzmzadjf + zadjs(1)*(mm12-mm02) + zadjs(2)*(mm22-mm02) &
2612  ) /detz * b_0(n0-1,n1,n2)
2613 ! + (1d0 - (Zadjf(1)+Zadjf(2))/detZ)* B_0(n0-1,n1,n2)
2614 
2615  if (n1.ge.1) then
2616  c(n0,n1,n2) = c(n0,n1,n2) &
2617  - 2*n1*zadjf(1)/detz*c(n0,n1-1,n2)
2618  else
2619  c(n0,n1,n2) = c(n0,n1,n2) &
2620  + zadjf(1)/detz* b_i(n0-1,n2,1)
2621  end if
2622  if (n2.ge.1) then
2623  c(n0,n1,n2) = c(n0,n1,n2) &
2624  - 2*n2*zadjf(2)/detz*c(n0,n1,n2-1)
2625  else
2626  c(n0,n1,n2) = c(n0,n1,n2) &
2627  + zadjf(2)/detz * b_i(n0-1,n1,2)
2628  end if
2629 
2630  c(n0,n1,n2) = c(n0,n1,n2) / (2*r)
2631 
2632 ! if(n0.eq.1) then
2633 ! write(*,*) 'Ca(1,n1,n2)=',n1,n2, 4*Cuv(n0,n1,n2) + detX/detZ*C(n0-1,n1,n2)
2634 ! write(*,*) 'Ca(1,n1,n2)=', (detZmZadjf + Zadjs(1)*(mm12-mm02) + Zadjs(2)*(mm22-mm02) &
2635 ! ) /detZ * B_0(n0-1,n1,n2)
2636 ! write(*,*) 'Ca(1,n1,n2)=', detZmZadjf , Zadjs(1)*(mm12-mm02) , Zadjs(2)*(mm22-mm02) &
2637 ! ,detZ , B_0(n0-1,n1,n2)
2638 ! write(*,*) 'Ca(1,n1,n2)=', (1d0 - (Zadjf(1)+Zadjf(2))/detZ)* B_0(n0-1,n1,n2)
2639 ! write(*,*) 'Ca(1,n1,n2)=', + Zadjf(1)/detZ* B_i(n0-1,n2,1)
2640 ! write(*,*) 'Ca(1,n1,n2)=', + Zadjf(2)/detZ * B_i(n0-1,n1,2)
2641 ! end if
2642 
2643  end do
2644  end do
2645 
2646  ! reduction formula (5.11) with (5.10) inserted for n0 = 0
2647 ! do n0=(r-1)/2,0,-1
2648  n0=0
2649  do n1=0,r-2*n0
2650  n2 = r-2*n0-n1
2651 
2652  if (n1.ge.1) then
2653  nn1 = n1-1
2654  nn2 = n2
2655  j = 1
2656  else
2657  nn1 = n1
2658  nn2 = n2-1
2659  j = 2
2660  end if
2661 
2662 ! do i=1,2
2663 ! Smod(i) = -B_0(n0,nn1,nn2)
2664 ! end do
2665  smod = 0d0
2666 
2667  if (nn1.ge.1) then
2668  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
2669  else
2670  smod(1) = smod(1) + b_i(n0,nn2,1)
2671  end if
2672 
2673  if (nn2.ge.1) then
2674  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
2675  else
2676  smod(2) = smod(2) + b_i(n0,nn1,2)
2677  end if
2678 
2679  c(n0,n1,n2) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
2680  - zadjs(j)*b_0(n0,nn1,nn2) &
2681  - zadjf(j)*c(n0,nn1,nn2))/detz
2682 
2683 #ifdef Cpv1test
2684  if(n0.eq.0) then
2685  write(*,*) 'Ca(0,n1,n2)=',n1,n2,c(0,n1,n2),nn1,nn2,j
2686  write(*,*) 'Ca(0,n1,n2)=',zadj(1,j),smod(1),zadj(2,j),smod(2)
2687  write(*,*) 'Ca(0,n1,n2)=',zadjs(j),b_0(n0,nn1,nn2),zadjf(j),c(n0,nn1,nn2)
2688  write(*,*) 'Ca(0,n1,n2)=',zadj(1,j)*smod(1),zadj(2,j)*smod(2)
2689  write(*,*) 'Ca(0,n1,n2)=',-zadjs(j)*b_0(n0,nn1,nn2),-zadjf(j)*c(n0,nn1,nn2)
2690  end if
2691 #endif
2692 
2693  end do
2694 ! end do
2695 
2696  ! determine error from symmetry for n0=0 and n1>=1, n2>=1
2697  cerr(r)=cerr(r-1)
2698  cerr2(r)=cerr2(r-1)
2699  n0=0
2700  do n1=1,r-2*n0-1
2701  n2 = r-2*n0-n1
2702 
2703  nn1 = n1
2704  nn2 = n2-1
2705  j = 2
2706 
2707 ! do i=1,2
2708 ! Smod(i) = -B_0(n0,nn1,nn2)
2709 ! end do
2710  smod = 0
2711 
2712  if (nn1.ge.1) then
2713  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
2714  else
2715  smod(1) = smod(1) + b_i(n0,nn2,1)
2716  end if
2717 
2718  if (nn2.ge.1) then
2719  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
2720  else
2721  smod(2) = smod(2) + b_i(n0,nn1,2)
2722  end if
2723 
2724  c_alt(n0,n1,n2) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
2725  - zadjs(j)*b_0(n0,nn1,nn2) &
2726  - zadjf(j)*c(n0,nn1,nn2))/detz
2727 
2728  cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
2729  cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
2730 
2731 #ifdef Cpv1test
2732  if(n0.eq.0) then
2733  write(*,*) 'Cb(0,n1,n2)=',n1,n2,c_alt(0,n1,n2),nn1,nn2,j
2734  write(*,*) 'Cb(0,n1,n2)=',zadj(1,j),smod(1),zadj(2,j),smod(2)
2735  write(*,*) 'Cb(0,n1,n2)=',zadjs(j),b_0(n0,nn1,nn2),zadjf(j),c(n0,nn1,nn2)
2736  end if
2737 #endif
2738 ! write(*,*) 'CalcCpv1 Cerr',n0,n1,n2, Cerr(r), abs(C(n0,n1,n2)),abs(C_alt(n0,n1,n2))
2739 
2740  end do
2741 
2742  if(r.ge.2)then
2743 ! estimate using insertions of (5.11) in (5.10)
2744  c00_err(r) = max(2*abs(m02)*cij_err(r-2), b_err, &
2745  azadjff/adetz*cij_err(r-2), &
2746  maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
2747 
2748 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err, &
2749 ! aZadjff/adetZ*Cij_err(r-2), &
2750 ! maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
2751 ! C00_err(r)
2752 
2753  else
2754  c00_err(r) = 0d0
2755  end if
2756 ! estimate using insertions of (5.10) in (5.11)
2757  cij_err(r) = max(maxzadjf*cij_err(r-1), &
2758  maxzadj*max(2*c00_err(r),b_err))/adetz
2759 
2760  if(r.ge.2)then
2761  c00_err2(r) = max(2*abs(m02)*cij_err2(r-2), b_err, &
2762  azadjff/adetz*cij_err2(r-2), &
2763  maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
2764 
2765 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err2(r-2), B_err, &
2766 ! aZadjff/adetZ*Cij_err2(r-2), &
2767 ! maxZadjf/adetZ*C00_err2(r-1),maxZadjf/adetZ*B_err, &
2768 ! C00_err2(r)
2769 
2770  else
2771  c00_err2(r) = 0d0
2772  end if
2773  cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetz)
2774  end do
2775 
2776  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
2777  do r=rmax+1,2*rmax
2778  do n0=r-rmax,r/2
2779  do n1=0,r-2*n0
2780  n2 = r-2*n0-n1
2781  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
2782  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
2783  end do
2784  end do
2785  end do
2786 
2787 
2788 #ifdef Cpv1test
2789  write(*,*) 'CalcCpv1 Cerrsym',cerr
2790  write(*,*) 'CalcCpv1 Caccsym',cerr/abs(c(0,0,0))
2791 
2792  write(*,*) 'CalcCpv1 Cijerr',cij_err(1:rmax)
2793  write(*,*) 'CalcCpv1 Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
2794 #endif
2795 
2796  cerr2 = max(cerr2,cij_err2(0:rmax))
2797  cerr = max(cerr,cij_err(0:rmax))
2798 
2799 #ifdef Cpv1test
2800  write(*,*) 'CalcCpv1 Cerr',cerr
2801  write(*,*) 'CalcCpv1 Cacc',cerr/abs(c(0,0,0))
2802 #endif
2803 
2804 ! write(*,*) 'CalcCpv1 out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
2805 
2806 ! write(*,*) 'CalcCpv1 Cerr ',Cerr
2807 ! write(*,*) 'CalcCpv1 Cerr2',Cerr2
2808 
2809 #ifdef Cpv1test
2810 ! write(*,*) 'CalcCpv1 C',C(0,0,0)
2811 ! write(*,*) 'CalcCpv1 C1',C(0,1,0)
2812 ! write(*,*) 'CalcCpv1 C2',C(0,0,1)
2813 #endif
2814 
2815  end subroutine calccpv1
2816 
2817 
2818 
2819 
2820  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2821  ! subroutine CalcCpv1o(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
2822  !
2823  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
2824 
2825  subroutine calccpv1o(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
2826 
2827  use globalc
2828 
2829  integer, intent(in) :: rmax,id
2830  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
2831  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
2832  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
2833  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
2834  double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
2835  double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
2836  double complex, allocatable :: C_alt(:,:,:)
2837  double complex :: Smod(2)
2838  double complex :: C0_coli, elimminf2_coli
2839  double precision, allocatable :: C00_err(:),Cij_err(:)
2840  double precision, allocatable :: C00_err2(:),Cij_err2(:)
2841  double precision :: B_err,B_max
2842  integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
2843  integer :: bin,k,nid(0:2)
2844 
2845 #ifdef Cpv1otest
2846  write(*,*) 'CalcCpv1o in ',rmax,id
2847 #endif
2848 #ifdef TRACECin
2849  write(*,*) 'CalcCpv1o in ',rmax,id
2850 #endif
2851 
2852  ! calculation of scalar coefficient
2853  c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
2854  cuv(0,0,0) = 0d0
2855 
2856  ! accuracy estimate for C0 function
2857  cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
2858  cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
2859 
2860  if (rmax.eq.0) return
2861 
2862  ! allocation and calculation of B functions
2863  rmaxb = rmax-1
2864  ! rmaxB = max(rmax-1,0)
2865  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
2866  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
2867  allocate(b_i(0:rmaxb,0:rmaxb,2))
2868  allocate(buv_i(0:rmaxb,0:rmaxb,2))
2869 
2870  ! allocate arrays for error propagation
2871  allocate(c00_err(0:rmax))
2872  allocate(cij_err(0:rmax))
2873  allocate(c00_err2(0:rmax))
2874  allocate(cij_err2(0:rmax))
2875 
2876  ! determine binaries for B-coefficients
2877  k=0
2878  bin = 1
2879  do while (k.le.2)
2880  if (mod(id/bin,2).eq.0) then
2881  nid(k) = id+bin
2882  k = k+1
2883  end if
2884  bin = 2*bin
2885  end do
2886 
2887  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
2888  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
2889  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
2890 
2891  ! shift of integration momentum in B_0 and calculate maximal B(0,...)
2892  b_max=0d0
2893  do n1=1,rmaxb
2894  do n2=0,rmaxb-n1
2895  n0 = (rmaxb-n1-n2)
2896  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
2897  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
2898  b_max = max(b_max,abs(b_0(0,n1,n2)))
2899  end do
2900  end do
2901 
2902 ! write(*,*) 'B_max=',B_max
2903 
2904  b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
2905 
2906  ! determine inverse Gram matrix
2907 ! mm02 = elimminf2_coli(m02)
2908 ! mm12 = elimminf2_coli(m12)
2909 ! mm22 = elimminf2_coli(m22)
2910 ! q10 = elimminf2_coli(p10)
2911 ! q21 = elimminf2_coli(p21)
2912 ! q20 = elimminf2_coli(p20)
2913 !
2914 ! q1q2 = (q10+q20-q21)
2915 ! detZ = 4d0*q10*q20-q1q2*q1q2
2916 ! Zinv(1,1) = 2d0*q20/detZ
2917 ! Zinv(2,1) = -q1q2/detZ
2918 ! Zinv(1,2) = Zinv(2,1)
2919 ! Zinv(2,2) = 2d0*q10/detZ
2920 ! f(1) = q10+mm02-mm12
2921 ! f(2) = q20+mm02-mm22
2922 
2923  ! commented out 2.9.2017
2924  ! Zinv = Zadj/detZ
2925 
2926  ! calculate Cuv
2927  call calccuv(cuv,buv_0,mm02,f,rmax,id)
2928 
2929  ! initialization of error propagation
2930 ! Zadj=Zinv*detZ
2931 
2932 ! maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(2,2)))
2933 
2934 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
2935 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
2936 ! maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)))
2937 
2938 ! aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2))
2939 
2940 ! adetZ = abs(detZ)
2941 ! adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2))
2942 
2943 ! write(*,*) 'adZ=',maxZadj,adetZ
2944 
2945 
2946  cij_err =0d0
2947  c00_err =0d0
2948  cij_err(0) = cerr(0)
2949  b_err = acc_def_b*b_max
2950 
2951  cij_err2 =0d0
2952  c00_err2 =0d0
2953  cij_err2(0) = cerr2(0)
2954 
2955 ! write(*,*) 'CalcCpv1o: B_err= ',B_err,acc_def_B,B_max
2956 
2957  allocate(c_alt(0:rmax,0:rmax,0:rmax))
2958 
2959  ! PV reduction
2960  do r=1,rmax
2961 
2962  ! reduction formula (5.10) for C(r/2,0,0)
2963  do n0=r/2,1,-1
2964  do n1=0,r-2*n0
2965  n2 = r-2*n0-n1
2966  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
2967  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
2968  end do
2969  end do
2970 
2971 ! do n0=(r-1)/2,0,-1
2972  n0=0
2973  do n1=0,r-2*n0
2974  n2 = r-2*n0-n1
2975 
2976  if (n1.ge.1) then
2977  nn1 = n1-1
2978  nn2 = n2
2979  j = 1
2980  else
2981  nn1 = n1
2982  nn2 = n2-1
2983  j = 2
2984  end if
2985 
2986  ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
2987  do i=1,2
2988  smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
2989  end do
2990 
2991  if (nn1.ge.1) then
2992  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
2993  else
2994  smod(1) = smod(1) + b_i(n0,nn2,1)
2995  end if
2996 
2997  if (nn2.ge.1) then
2998  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
2999  else
3000  smod(2) = smod(2) + b_i(n0,nn1,2)
3001  end if
3002 
3003  c(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
3004 
3005 ! if(n0.eq.0) then
3006 ! write(*,*) 'Ca(0,n1,n2)=',n1,n2,C(0,n1,n2),nn1,nn2,j
3007 ! write(*,*) 'Ca(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
3008 ! end if
3009 
3010  end do
3011 ! end do
3012 
3013  ! determine error from symmetry for n0=0 and n1>=1, n2>=1
3014  cerr(r)=cerr(r-1)
3015  cerr2(r)=cerr2(r-1)
3016  n0=0
3017  do n1=1,r-2*n0-1
3018  n2 = r-2*n0-n1
3019 
3020  nn1 = n1
3021  nn2 = n2-1
3022  j = 2
3023 
3024  ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
3025  do i=1,2
3026  smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
3027  end do
3028 
3029  if (nn1.ge.1) then
3030  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
3031  else
3032  smod(1) = smod(1) + b_i(n0,nn2,1)
3033  end if
3034 
3035  if (nn2.ge.1) then
3036  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
3037  else
3038  smod(2) = smod(2) + b_i(n0,nn1,2)
3039  end if
3040 
3041  c_alt(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
3042 
3043  cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
3044  cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
3045 
3046 ! if(n0.eq.0) then
3047 ! write(*,*) 'Cb(0,n1,n2)=',n1,n2,C_alt(0,n1,n2),nn1,nn2,j
3048 ! write(*,*) 'Cb(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
3049 ! end if
3050 ! write(*,*) 'CalcCpv1o Cerr',n0,n1,n2, Cerr(r), abs(C(n0,n1,n2)),abs(C_alt(n0,n1,n2))
3051 
3052  end do
3053 
3054  if(r.ge.2)then
3055  c00_err(r) = max(2*abs(m02)*cij_err(r-2), b_err, &
3056  azadjff/adetz*cij_err(r-2), &
3057  maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
3058 
3059 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err, &
3060 ! aZadjff/adetZ*Cij_err(r-2), &
3061 ! maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
3062 ! C00_err(r)
3063 
3064  else
3065  c00_err(r) = 0d0
3066  end if
3067  cij_err(r) = max(maxzadjf*cij_err(r-1), &
3068  maxzadj*max(2*c00_err(r),b_err))/adetz
3069 
3070  if(r.ge.2)then
3071  c00_err2(r) = max(2*abs(m02)*cij_err2(r-2), b_err, &
3072  azadjff/adetz*cij_err2(r-2), &
3073  maxzadjf/adetz*max(2*c00_err(r-1),b_err))/(2*r)
3074 
3075 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err2(r-2), B_err, &
3076 ! aZadjff/adetZ*Cij_err2(r-2), &
3077 ! maxZadjf/adetZ*C00_err2(r-1),maxZadjf/adetZ*B_err, &
3078 ! C00_err2(r)
3079 
3080  else
3081  c00_err2(r) = 0d0
3082  end if
3083  cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetz)
3084  end do
3085 
3086  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
3087  do r=rmax+1,2*rmax
3088  do n0=r-rmax,r/2
3089  do n1=0,r-2*n0
3090  n2 = r-2*n0-n1
3091  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
3092  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
3093  end do
3094  end do
3095  end do
3096 
3097 
3098 #ifdef Cpv1otest
3099  write(*,*) 'CalcCpv1o Cerrsym',cerr
3100  write(*,*) 'CalcCpv1o Caccsym',cerr/abs(c(0,0,0))
3101 
3102  write(*,*) 'CalcCpv1o Cijerr',cij_err(1:rmax)
3103  write(*,*) 'CalcCpv1o Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
3104 #endif
3105 
3106  cerr2 = max(cerr2,cij_err2(0:rmax))
3107  cerr = max(cerr,cij_err(0:rmax))
3108 
3109 #ifdef Cpv1otest
3110  write(*,*) 'CalcCpv1o Cerr',cerr
3111  write(*,*) 'CalcCpv1o Cacc',cerr/abs(c(0,0,0))
3112 #endif
3113 
3114 ! write(*,*) 'CalcCpv1o out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
3115 
3116 ! write(*,*) 'CalcCpv1o Cerr ',Cerr
3117 ! write(*,*) 'CalcCpv1o Cerr2',Cerr2
3118 
3119  end subroutine calccpv1o
3120 
3121 
3122 
3123 
3124  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3125  ! subroutine CalcCpv(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,Cerr,Cerr2)
3126  !
3127  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3128 
3129  subroutine calccpv(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
3130 
3131  use globalc
3132 
3133  integer, intent(in) :: rmax,id
3134  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
3135  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
3136  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
3137  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
3138  double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
3139  double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
3140  double complex, allocatable :: C_alt(:,:,:)
3141  double complex :: Smod(2)
3142  double complex :: C0_coli, elimminf2_coli
3143  double precision, allocatable :: C00_err(:),Cij_err(:)
3144  double precision, allocatable :: C00_err2(:),Cij_err2(:)
3145  double precision :: B_err,B_max
3146  integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
3147  integer :: bin,k,nid(0:2)
3148 
3149 #ifdef Cpvtest
3150  write(*,*) 'CalcCpv in ', id
3151 #endif
3152 #ifdef TRACECin
3153  write(*,*) 'CalcCpv !n ', id
3154 #endif
3155 
3156  ! calculation of scalar coefficient
3157  c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
3158  cuv(0,0,0) = 0d0
3159 
3160  ! accuracy estimate for C0 function
3161  cerr(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
3162  cerr2(0) = acc_def_c0*max(1d0/sqrt(adetz),abs(c(0,0,0)))
3163 
3164 ! write(*,*) 'CalcCpv: Cerr(0)= ',Cerr(0),Cerr(0)/abs(C(0,0,0)),abs(C(0,0,0))
3165 
3166  if (rmax.eq.0) return
3167 
3168  ! allocation and calculation of B functions
3169  rmaxb = rmax-1
3170  ! rmaxB = max(rmax-1,0)
3171  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
3172  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
3173  allocate(b_i(0:rmaxb,0:rmaxb,2))
3174  allocate(buv_i(0:rmaxb,0:rmaxb,2))
3175 
3176  ! allocate arrays for error propagation
3177  allocate(c00_err(0:rmax))
3178  allocate(cij_err(0:rmax))
3179  allocate(c00_err2(0:rmax))
3180  allocate(cij_err2(0:rmax))
3181 
3182  ! determine binaries for B-coefficients
3183  k=0
3184  bin = 1
3185  do while (k.le.2)
3186  if (mod(id/bin,2).eq.0) then
3187  nid(k) = id+bin
3188  k = k+1
3189  end if
3190  bin = 2*bin
3191  end do
3192 
3193  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
3194  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
3195  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
3196 
3197  ! shift of integration momentum in B_0 and calculate maximal B(0,...)
3198  b_max=0d0
3199  do n1=1,rmaxb
3200  do n2=0,rmaxb-n1
3201  n0 = (rmaxb-n1-n2)
3202  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
3203  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
3204  b_max = max(b_max,abs(b_0(0,n1,n2)))
3205  end do
3206  end do
3207 
3208 ! write(*,*) 'B_max=',B_max
3209 
3210  b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
3211 
3212  ! determine inverse Gram matrix
3213 ! mm02 = elimminf2_coli(m02)
3214 ! mm12 = elimminf2_coli(m12)
3215 ! mm22 = elimminf2_coli(m22)
3216 ! q10 = elimminf2_coli(p10)
3217 ! q21 = elimminf2_coli(p21)
3218 ! q20 = elimminf2_coli(p20)
3219 !
3220 ! q1q2 = (q10+q20-q21)
3221 ! detZ = 4d0*q10*q20-q1q2*q1q2
3222 ! Zinv(1,1) = 2d0*q20/detZ
3223 ! Zinv(2,1) = -q1q2/detZ
3224 ! Zinv(1,2) = Zinv(2,1)
3225 ! Zinv(2,2) = 2d0*q10/detZ
3226 ! f(1) = q10+mm02-mm12
3227 ! f(2) = q20+mm02-mm22
3228 
3229  ! commented out 2.9.2017
3230  ! Zinv = Zadj/detZ
3231 
3232  ! calculate Cuv
3233  call calccuv(cuv,buv_0,mm02,f,rmax,id)
3234 
3235  ! initialization of error propagation
3236 ! Zadj=Zinv*detZ
3237 
3238 ! maxZadj = max(abs(Zadj(1,1)),abs(Zadj(2,1)),abs(Zadj(2,2)))
3239 
3240 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
3241 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
3242 ! maxZadjf = max(abs(Zadjf(1)),abs(Zadjf(2)))
3243 
3244 ! aZadjff = abs(Zadjf(1)*f(1)+Zadjf(2)*f(2))
3245 
3246 ! adetZ = abs(detZ)
3247 ! adetX = abs(2d0*mm02*detZ-Zadjf(1)*f(1)-Zadjf(2)*f(2))
3248 
3249 ! write(*,*) 'adZ=',maxZadj,adetZ
3250 
3251 
3252  cij_err =0d0
3253  c00_err =0d0
3254  cij_err(0) = cerr(0)
3255  b_err = acc_def_b*b_max
3256 
3257  cij_err2 =0d0
3258  c00_err2 =0d0
3259  cij_err2(0) = cerr2(0)
3260 
3261 ! write(*,*) 'CalcCpv: B_err= ',B_err,acc_B,B_max
3262 
3263  allocate(c_alt(0:rmax,0:rmax,0:rmax))
3264 
3265  ! PV reduction
3266  do r=1,rmax
3267 
3268  if (mod(r,2).eq.0) then
3269  ! reduction formula (5.10) for C(r/2,0,0)
3270  n0 = r/2
3271  c(n0,0,0) = (b_0(n0-1,0,0) + 2*mm02*c(n0-1,0,0) + 4*cuv(n0,0,0) &
3272  + f(1)*c(n0-1,1,0) + f(2)*c(n0-1,0,1)) / (2*r)
3273  end if
3274 
3275  do n0=(r-1)/2,0,-1
3276  do n1=0,r-2*n0
3277  n2 = r-2*n0-n1
3278 
3279  if (n1.ge.1) then
3280  nn1 = n1-1
3281  nn2 = n2
3282  j = 1
3283  else
3284  nn1 = n1
3285  nn2 = n2-1
3286  j = 2
3287  end if
3288 
3289  ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
3290  do i=1,2
3291  smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
3292  end do
3293 
3294  if (nn1.ge.1) then
3295  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
3296  else
3297  smod(1) = smod(1) + b_i(n0,nn2,1)
3298  end if
3299 
3300  if (nn2.ge.1) then
3301  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
3302  else
3303  smod(2) = smod(2) + b_i(n0,nn1,2)
3304  end if
3305 
3306  c(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
3307 
3308 ! if(n0.eq.0) then
3309 ! write(*,*) 'Ca(0,n1,n2)=',n1,n2,C(0,n1,n2),nn1,nn2
3310 ! write(*,*) 'Ca(0,n1,n2)=',Zinv(1,j),Smod(1),Zinv(2,j),Smod(2)
3311 ! end if
3312 
3313  end do
3314  end do
3315 
3316  ! determine error from symmetry for n0=0 and n1>1, n2>1
3317  cerr(r)=cerr(r-1)
3318  cerr2(r)=cerr2(r-1)
3319  n0=0
3320  do n1=0,r-2*n0
3321  n2 = r-2*n0-n1
3322 
3323  if (n1.ge.1.and.n2.ge.1) then
3324  nn1 = n1
3325  nn2 = n2-1
3326  j = 2
3327 
3328  ! reduction formula (5.11) for C(n0,n1,n2), n1+n2=/=0
3329  do i=1,2
3330  smod(i) = -b_0(n0,nn1,nn2)-f(i)*c(n0,nn1,nn2)
3331  end do
3332 
3333  if (nn1.ge.1) then
3334  smod(1) = smod(1) - 2d0*nn1*c(n0+1,nn1-1,nn2)
3335  else
3336  smod(1) = smod(1) + b_i(n0,nn2,1)
3337  end if
3338 
3339  if (nn2.ge.1) then
3340  smod(2) = smod(2) - 2d0*nn2*c(n0+1,nn1,nn2-1)
3341  else
3342  smod(2) = smod(2) + b_i(n0,nn1,2)
3343  end if
3344 
3345  c_alt(n0,n1,n2) = zinv(1,j)*smod(1) + zinv(2,j)*smod(2)
3346 
3347  cerr(r)=max(cerr(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
3348  cerr2(r)=max(cerr2(r),abs(c(n0,n1,n2)-c_alt(n0,n1,n2)))
3349 
3350  end if
3351  end do
3352 
3353  if(r.ge.2)then
3354  c00_err(r) = max(abs(m02)*cij_err(r-2), b_err, &
3355  azadjff/adetz*cij_err(r-2), &
3356  maxzadjf/adetz*max(c00_err(r-1),b_err))
3357 
3358 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err, &
3359 ! aZadjff/adetZ*Cij_err(r-2), &
3360 ! maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
3361 ! C00_err(r)
3362 
3363  else
3364  c00_err(r) = 0d0
3365  end if
3366  cij_err(r) = max(maxzadjf*cij_err(r-1), &
3367  maxzadj*max(c00_err(r),b_err))/adetz
3368 
3369  if(r.ge.2)then
3370  c00_err2(r) = max(abs(m02)*cij_err(r-2), b_err, &
3371  azadjff/adetz*cij_err2(r-2), &
3372  maxzadjf/adetz*max(c00_err2(r-1),b_err))
3373 
3374 ! write(*,*) 'C00errtest',r,abs(m02)*Cij_err(r-2), B_err, &
3375 ! aZadjff/adetZ*Cij_err(r-2), &
3376 ! maxZadjf/adetZ*C00_err(r-1),maxZadjf/adetZ*B_err, &
3377 ! C00_err(r)
3378 
3379  else
3380  c00_err2(r) = 0d0
3381  end if
3382  cij_err2(r) = max((maxzadjf/maxzadj)*cij_err2(r-1), &
3383  max(c00_err2(r),b_err))/sqrt(adetz)
3384 
3385 ! write(*,*) 'CalcCpv r',r, Cij_err(r),maxZadjf*Cij_err(r-1)/adetZ, &
3386 ! maxZadj*(C00_err(r))/adetZ, &
3387 ! maxZadj*(B_err)/adetZ
3388 
3389  end do
3390 
3391 
3392  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
3393  ! PV reduction (5.10)
3394  do r=rmax+1,2*rmax
3395  do n0=r-rmax,r/2
3396  do n1=0,r-2*n0
3397  n2 = r-2*n0-n1
3398  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
3399  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
3400  end do
3401  end do
3402  end do
3403 
3404 #ifdef Cpvtest
3405  write(*,*) 'CalcCpv Cerrsym',cerr
3406  write(*,*) 'CalcCpv Caccsym',cerr/abs(c(0,0,0))
3407 
3408  write(*,*) 'CalcCpv Cijerr',cij_err(1:rmax)
3409  write(*,*) 'CalcCpv Cijacc',cij_err(1:rmax)/abs(c(0,0,0))
3410 #endif
3411 
3412  cerr2 = max(cerr2,cij_err2(0:rmax))
3413  cerr = max(cerr,cij_err(0:rmax))
3414 
3415 #ifdef Cpvtest
3416  write(*,*) 'CalcCpv Cerr',cerr
3417  write(*,*) 'CalcCpv Cacc',cerr/abs(c(0,0,0))
3418 #endif
3419 
3420 ! write(*,*) 'CalcCpv out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
3421 
3422  end subroutine calccpv
3423 
3424 
3425 
3426 
3427 
3428  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3429  ! subroutine CalcCpv2(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
3430  !
3431  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3432 
3433  subroutine calccpv2(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,id,Cerr,Cerr2)
3434 
3435  use globalc
3436 
3437  integer, intent(in) :: rmax,id
3438  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
3439  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
3440  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
3441  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
3442  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:)
3443  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
3444  double complex, allocatable :: C_alt(:,:,:)
3445  double complex :: C0_coli, elimminf2_coli
3446 ! double complex :: Caux(1:rmax/2+1,0:rmax-1,0:rmax-1), Smod(2)
3447  double complex :: Caux(1:rmax,0:rmax-1,0:rmax-1), Smod(2)
3448  double complex :: chdet
3449  double precision, allocatable :: C00_err(:),Cij_err(:)
3450  double precision, allocatable :: C00_err2(:),Cij_err2(:)
3451  double precision :: B_err,B_max
3452  integer :: rmaxB,r,n0,n1,n2,k
3453  integer :: bin,nid(0:3)
3454 
3455 #ifdef Cpv2test
3456  write(*,*) 'CalcCpv2 in '
3457 #endif
3458 #ifdef TRACECin
3459  write(*,*) 'CalcCpv2 in '
3460 #endif
3461 
3462  ! calculation of scalar coefficient
3463  c(0,0,0) = c0_coli(p10,p21,p20,m02,m12,m22)
3464  cuv(0,0,0) = 0d0
3465 
3466  ! accuracy estimate for C0 function
3467  cerr(0) = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
3468  cerr2(0) = acc_def_c0*max( abs(c(0,0,0)), 1d0/sqrt(adetz) )
3469 
3470 ! write(*,*) 'CalcCpv2: Cerr(0)= ',Cerr(0),Cerr(0)/abs(C(0,0,0)),abs(C(0,0,0))
3471 
3472  if (rmax.eq.0) return
3473 
3474 
3475  ! calculation of B-coefficients
3476  rmaxb = rmax-1
3477  ! rmaxB = max(rmax-1,0)
3478  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
3479  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
3480  allocate(b_i(0:rmaxb,0:rmaxb,2))
3481  allocate(buv_i(0:rmaxb,0:rmaxb,2))
3482 
3483  ! allocate arrays for error propagation
3484  allocate(c00_err(0:rmax+1))
3485  allocate(cij_err(0:rmax))
3486  allocate(c00_err2(0:rmax+1))
3487  allocate(cij_err2(0:rmax))
3488 
3489  ! determine binaries for B-coefficients
3490  k=0
3491  bin = 1
3492  do while (k.le.2)
3493  if (mod(id/bin,2).eq.0) then
3494  nid(k) = id+bin
3495  k = k+1
3496  end if
3497  bin = 2*bin
3498  end do
3499 
3500  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
3501  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
3502  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
3503 
3504  ! shift of integration momentum in B_0 and calculate maximal B(0,...)
3505  b_max=0d0
3506  do n1=1,rmaxb
3507  do n2=0,rmaxb-n1
3508  n0 = (rmaxb-n1-n2)
3509  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
3510  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
3511  b_max = max(b_max,abs(b_0(0,n1,n2)))
3512  end do
3513  end do
3514  b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
3515 
3516  ! determine inverse modified Cayley matrix
3517 ! mm02 = elimminf2_coli(m02)
3518 ! mm12 = elimminf2_coli(m12)
3519 ! mm22 = elimminf2_coli(m22)
3520 ! q10 = elimminf2_coli(p10)
3521 ! q21 = elimminf2_coli(p21)
3522 ! q20 = elimminf2_coli(p20)
3523 
3524 
3525  ! calculate Cuv
3526  call calccuv(cuv,buv_0,mm02,mx(1:2,0),rmax,id)
3527 
3528  ! initialization of error propagation
3529 
3530 ! adetX = abs(chdet(3,mx))
3531 ! maxZadjf=maxval(abs(mxinv(0,1:2)))*adetX
3532 ! maxXadj=maxval(abs(mxinv(1:2,1:2)))*adetX
3533 ! adetZ=abs(mxinv(0,0))*adetX
3534 
3535 ! write(*,*) 'CalcCpv2 adetX ',adetX,maxZadjf,maxXadj,adetZ
3536 
3537  cij_err =0d0
3538  c00_err =0d0
3539  cij_err(0) = cerr(0)
3540  b_err = acc_def_b*b_max
3541 
3542  cij_err2 =0d0
3543  c00_err2 =0d0
3544  cij_err2(0) = cerr2(0)
3545 
3546 ! write(*,*) 'CalcCpv: B_err= ',B_err,acc_B,B_max
3547 
3548  allocate(c_alt(0:rmax,0:rmax,0:rmax))
3549 
3550  ! alternative PV-like reduction
3551  do r=1,rmax
3552 
3553  do n0=2,r/2
3554  do n1=0,r-2*n0
3555  n2 = r-2*n0-n1
3556 
3557  do k=1,2
3558  smod(k) = -b_0(n0-1,n1,n2)
3559  end do
3560 
3561  if (n1.ge.1) then
3562  smod(1) = smod(1) - 2*n1*c(n0,n1-1,n2)
3563  else
3564  smod(1) = smod(1) + b_i(n0-1,n2,1)
3565  end if
3566 
3567  if (n2.ge.1) then
3568  smod(2) = smod(2) - 2*n2*c(n0,n1,n2-1)
3569  else
3570  smod(2) = smod(2) + b_i(n0-1,n1,2)
3571  end if
3572 
3573  caux(n0,n1,n2) = (c(n0-1,n1,n2) - mxinv(1,0)*smod(1) &
3574  - mxinv(2,0)*smod(2))/mxinv(0,0)
3575 
3576  end do
3577  end do
3578 
3579 
3580  do n0=1,r/2
3581  do n1=0,r-2*n0
3582  n2 = r-2*n0-n1
3583 
3584  c(n0,n1,n2) = (caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2) &
3585  + b_0(n0-1,n1,n2))/r/2d0
3586 
3587  end do
3588  end do
3589 
3590 
3591 
3592  ! calculate C and determine error from symmetry for n0=0 and n1>0, n2>0
3593  cerr(r)=cerr(r-1)
3594  cerr2(r)=cerr2(r-1)
3595 
3596  do n1=0,r-1
3597  n2 = r-1-n1
3598 
3599  do k=1,2
3600  smod(k) = -b_0(0,n1,n2)
3601  end do
3602 
3603  if (n1.ge.1) then
3604  smod(1) = smod(1) - 2*n1*c(1,n1-1,n2)
3605  else
3606  smod(1) = smod(1) + b_i(0,n2,1)
3607  end if
3608 
3609  if (n2.ge.1) then
3610  smod(2) = smod(2) - 2*n2*c(1,n1,n2-1)
3611  else
3612  smod(2) = smod(2) + b_i(0,n1,2)
3613  end if
3614 
3615  caux(1,n1,n2) = (c(0,n1,n2) - mxinv(1,0)*smod(1) &
3616  - mxinv(2,0)*smod(2))/mxinv(0,0)
3617 
3618  c(0,n1+1,n2) = mxinv(0,1)*caux(1,n1,n2) &
3619  + mxinv(1,1)*smod(1) + mxinv(2,1)*smod(2)
3620  c_alt(0,n1,n2+1) = mxinv(0,2)*caux(1,n1,n2) &
3621  + mxinv(1,2)*smod(1) + mxinv(2,2)*smod(2)
3622 
3623  if(n1.eq.0) then
3624  c(0,0,r) = c_alt(0,0,r)
3625  else
3626  cerr(r)=max(cerr(r),abs(c(0,n1,n2+1)-c_alt(0,n1,n2+1)))
3627  cerr2(r)=max(cerr2(r),abs(c(0,n1,n2+1)-c_alt(0,n1,n2+1)))
3628  end if
3629 
3630  end do
3631 
3632  c00_err(r+1) = max(b_err,adetx/adetz*cij_err(r-1), &
3633  maxzadjf/adetz*max(b_err,c00_err(r)))/(2*(r+1))
3634 
3635 ! write(*,*) 'CalcCpv2 00 r',r, B_err,adetX/adetZ*Cij_err(r-1), &
3636 ! maxZadjf/adetZ*B_err, maxZadjf/adetZ*C00_err(r)
3637 
3638  cij_err(r) = max(maxzadjf*max(2*(r+1)*c00_err(r+1),b_err), &
3639  maxxadj*max(2*c00_err(r),b_err))/adetx
3640 
3641  c00_err2(r+1) = max(b_err,adetx/adetz*cij_err2(r-1), &
3642  maxzadjf/adetz*max(b_err,c00_err2(r)))/(2*(r+1))
3643 
3644 ! write(*,*) 'CalcCpv2 00 r',r, B_err,adetX/adetZ*Cij_err(r-1), &
3645 ! maxZadjf/adetZ*B_err, maxZadjf/adetZ*C00_err(r)
3646 
3647  cij_err2(r) = max(maxzadjf*max(2*(r+1)*c00_err2(r+1),b_err), &
3648  maxxadj*max(2*c00_err2(r),b_err))/adetx*(sqrt(adetz)/maxzadj)
3649 
3650 ! write(*,*) 'CalcCpv2 ij r',r, maxZadjf*C00_err(r+1)/adetX,B_err*maxZadjf/adetX, &
3651 ! maxXadj*C00_err(r)/adetX, maxXadj*B_err/adetX
3652 
3653  end do
3654 
3655 
3656  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
3657  do r=rmax+1,2*rmax
3658 
3659 #ifdef Cpv2test
3660 ! pv1 version might get unstable for some cases!
3661  do n0=r-rmax,r/2
3662  do n1=0,r-2*n0
3663  n2 = r-2*n0-n1
3664  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
3665  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
3666 
3667  write(*,*) 'C1(n0+1)',n0,n1,n2
3668  write(*,*) 'C1(n0+1)',(b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
3669  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
3670 
3671  end do
3672  end do
3673 #endif
3674 
3675 ! pv2 formulas added 24.01.2016
3676  do n0=max(2,r-rmax),r/2
3677  do n1=0,r-2*n0
3678  n2 = r-2*n0-n1
3679 
3680  do k=1,2
3681  smod(k) = -b_0(n0-1,n1,n2)
3682  end do
3683 
3684  if (n1.ge.1) then
3685  smod(1) = smod(1) - 2*n1*c(n0,n1-1,n2)
3686  else
3687  smod(1) = smod(1) + b_i(n0-1,n2,1)
3688  end if
3689 
3690  if (n2.ge.1) then
3691  smod(2) = smod(2) - 2*n2*c(n0,n1,n2-1)
3692  else
3693  smod(2) = smod(2) + b_i(n0-1,n1,2)
3694  end if
3695 
3696  caux(n0,n1,n2) = (c(n0-1,n1,n2) - mxinv(1,0)*smod(1) &
3697  - mxinv(2,0)*smod(2))/mxinv(0,0)
3698 
3699  end do
3700  end do
3701 
3702 
3703  do n0=r-rmax,r/2
3704  do n1=0,r-2*n0
3705  n2 = r-2*n0-n1
3706 
3707  c(n0,n1,n2) = (caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2) &
3708  + b_0(n0-1,n1,n2))/r/2d0
3709 
3710 #ifdef Cpv2test
3711  write(*,*) 'C2(n0+1)',n0,n1,n2
3712  write(*,*) 'C2(n0+1)',(caux(n0,n1,n2) + 4d0*cuv(n0,n1,n2) &
3713  + b_0(n0-1,n1,n2))/r/2d0
3714 #endif
3715 
3716  end do
3717  end do
3718 
3719  end do
3720 
3721 #ifdef Cpv2test
3722  write(*,*) 'CalcCpv2 Cerrsym',cerr
3723  write(*,*) 'CalcCpv2 Caccsym',cerr/abs(c(0,0,0))
3724 
3725  write(*,*) 'CalcCpv2 Cijerr',cij_err
3726  write(*,*) 'CalcCpv2 Cijacc',cij_err/abs(c(0,0,0))
3727 #endif
3728 
3729  cerr2 = max(cerr2,cij_err2(0:rmax))
3730  cerr = max(cerr,cij_err(0:rmax))
3731 
3732 #ifdef Cpv2test
3733  write(*,*) 'CalcCpv2 Cerr',cerr
3734  write(*,*) 'CalcCpv2 Cacc',cerr/abs(c(0,0,0))
3735 #endif
3736 
3737 ! write(*,*) 'CalcCpv2 out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
3738 
3739 ! write(*,*) 'CalcCpv2 Cerr ',Cerr
3740 ! write(*,*) 'CalcCpv2 Cerr2',Cerr2
3741 
3742  end subroutine calccpv2
3743 
3744 
3745 
3746  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3747  ! subroutine CalcCpvshift(Cshift,Cuvshift,p10shift,p21shift,p20shift,m02shift,m12shift,m22shift,rmax,Cerr,Cerr2)
3748  !
3749  ! Based on CalcCpv1
3750  ! uses shifted momenta and global shifted quantities
3751  !
3752  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!7!!!!!!!!!!!!!!!!!!!!!!!!
3753 
3754  subroutine calccpvshift(Cshift,Cuvshift,p10shift,p21shift,p20shift,m02shift,m12shift,m22shift,rmax,id,Cerr,Cerr2)
3755 
3756  use globalc
3757 
3758  integer, intent(in) :: rmax,id
3759  double complex, intent(in) :: p10shift,p21shift,p20shift,m02shift,m12shift,m22shift
3760  double complex, intent(out) :: Cuvshift(0:rmax,0:rmax,0:rmax)
3761  double complex, intent(out) :: Cshift(0:rmax,0:rmax,0:rmax)
3762  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
3763  double complex, allocatable :: B_0(:,:,:), Buv_0(:,:,:)
3764  double complex, allocatable :: B_i(:,:,:), Buv_i(:,:,:)
3765  double complex, allocatable :: Cshift_alt(:,:,:)
3766  double complex :: Smod(2)
3767  double complex :: C0_coli, elimminf2_coli
3768  double precision, allocatable :: C00_err(:),Cij_err(:)
3769  double precision, allocatable :: C00_err2(:),Cij_err2(:)
3770  double precision :: B_err,B_max
3771  integer :: rmaxB,r,n0,n1,n2,nn0,nn1,nn2,i,j
3772  integer :: bin,k,nid(0:2)
3773  logical :: use_cache_system_save
3774 
3775 #ifdef Cpvshifttest
3776  write(*,*) 'CalcCpvshift p in ',p10shift,p21shift,p20shift
3777  write(*,*) 'CalcCpvshift m in ',m02shift,m12shift,m22shift
3778  write(*,*) 'CalcCpvshift in ',rmax,id
3779 #endif
3780 #ifdef TRACECin
3781  write(*,*) 'CalcCpvshift in ',rmax,id
3782 #endif
3783 
3784  ! calculation of scalar coefficient
3785  cshift(0,0,0) = c0_coli(p10shift,p21shift,p20shift,m02shift,m12shift,m22shift)
3786  cuvshift(0,0,0) = 0d0
3787 
3788  ! accuracy estimate for C0 function
3789  cerr(0) = acc_def_c0*max(1d0/sqrt(adetzshift),abs(cshift(0,0,0)))
3790  cerr2(0) = acc_def_c0*max(1d0/sqrt(adetzshift),abs(cshift(0,0,0)))
3791 
3792  if (rmax.eq.0) return
3793 
3794  ! allocation and calculation of B functions
3795  rmaxb = rmax-1
3796  ! rmaxB = max(rmax-1,0)
3797  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
3798  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
3799  allocate(b_i(0:rmaxb,0:rmaxb,2))
3800  allocate(buv_i(0:rmaxb,0:rmaxb,2))
3801 
3802  ! allocate arrays for error propagation
3803  allocate(c00_err(0:rmax))
3804  allocate(cij_err(0:rmax))
3805  allocate(c00_err2(0:rmax))
3806  allocate(cij_err2(0:rmax))
3807 
3808  ! determine binaries for B-coefficients
3809  k=0
3810  bin = 1
3811  do while (k.le.2)
3812  if (mod(id/bin,2).eq.0) then
3813  nid(k) = id+bin
3814  k = k+1
3815  end if
3816  bin = 2*bin
3817  end do
3818 
3819 ! call CalcB(B_0(:,0,:),Buv_0(:,0,:),p21shift,m12shift,m22shift,rmaxB,nid(0))
3820 ! call CalcB(B_i(:,:,1),Buv_i(:,:,1),p20shift,m02shift,m22shift,rmaxB,nid(1))
3821 ! call CalcB(B_i(:,:,2),Buv_i(:,:,2),p10shift,m02shift,m12shift,rmaxB,nid(2))
3822  use_cache_system_save = use_cache_system
3823  use_cache_system = .false.
3824  call calcb(b_0(:,0,:),buv_0(:,0,:),p21shift,m12shift,m22shift,rmaxb,0)
3825  call calcb(b_i(:,:,1),buv_i(:,:,1),p20shift,m02shift,m22shift,rmaxb,0)
3826  call calcb(b_i(:,:,2),buv_i(:,:,2),p10shift,m02shift,m12shift,rmaxb,0)
3827  use_cache_system = use_cache_system_save
3828 ! call SwitchOnCacheSystem_cll
3829 
3830 
3831  ! shift of integration momentum in B_0 and calculate maximal B(0,...)
3832  b_max=0d0
3833  do n1=1,rmaxb
3834  do n2=0,rmaxb-n1
3835  n0 = (rmaxb-n1-n2)
3836  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
3837  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
3838  b_max = max(b_max,abs(b_0(0,n1,n2)))
3839  end do
3840  end do
3841 
3842 ! write(*,*) 'B_max=',B_max
3843 
3844  b_max=max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
3845 
3846  ! determine inverse Gram matrix
3847 ! Zinvshift = Zadjshift/detZshift
3848 
3849  ! calculate Cuv
3850  call calccuv(cuvshift,buv_0,mm02shift,fshift,rmax,id)
3851 
3852  ! initialization of error propagation
3853  cij_err =0d0
3854  c00_err =0d0
3855  cij_err(0) = cerr(0)
3856  b_err = acc_def_b*b_max
3857 
3858  cij_err2 =0d0
3859  c00_err2 =0d0
3860  cij_err2(0) = cerr2(0)
3861 
3862 
3863 #ifdef Cpvshifttest
3864 ! write(*,*) 'CalcCpvshift: B_err= ',B_err,acc_def_B,B_max
3865  write(*,*) 'CalcDpvshift Cij_err(0)=',cij_err(0)
3866 ! write(*,*) 'CalcCpvshift test :', &
3867 ! (1d0 - (Zadjf(1)+Zadjf(2))/detZshift), &
3868 ! (detZmZadjf + Zadjs(1)*(mm12shift-mm02shift) + Zadjs(2)*(mm22shift-mm02shift)) /detZshift
3869 #endif
3870 
3871  allocate(cshift_alt(0:rmax,0:rmax,0:rmax))
3872 
3873  ! PV reduction
3874  do r=1,rmax
3875 
3876  ! reduction formula (5.10) with (5.11) inserted for n0 >= 1
3877  do n0=r/2,1,-1
3878  do n1=0,r-2*n0
3879  n2 = r-2*n0-n1
3880  cshift(n0,n1,n2) = + 4*cuvshift(n0,n1,n2) + detxshift/detzshift*cshift(n0-1,n1,n2)
3881  cshift(n0,n1,n2) = cshift(n0,n1,n2) &
3882  + (detzmzadjfshift + zadjsshift(1)*(mm12shift-mm02shift) + zadjsshift(2)*(mm22shift-mm02shift) &
3883  ) /detzshift * b_0(n0-1,n1,n2)
3884 ! + (1d0 - (Zadjfshift(1)+Zadjfshift(2))/detZshift)* B_0(n0-1,n1,n2)
3885 
3886  if (n1.ge.1) then
3887  cshift(n0,n1,n2) = cshift(n0,n1,n2) &
3888  - 2*n1*zadjfshift(1)/detzshift*cshift(n0,n1-1,n2)
3889  else
3890  cshift(n0,n1,n2) = cshift(n0,n1,n2) &
3891  + zadjfshift(1)/detzshift* b_i(n0-1,n2,1)
3892  end if
3893  if (n2.ge.1) then
3894  cshift(n0,n1,n2) = cshift(n0,n1,n2) &
3895  - 2*n2*zadjfshift(2)/detzshift*cshift(n0,n1,n2-1)
3896  else
3897  cshift(n0,n1,n2) = cshift(n0,n1,n2) &
3898  + zadjfshift(2)/detzshift * b_i(n0-1,n1,2)
3899  end if
3900 
3901  cshift(n0,n1,n2) = cshift(n0,n1,n2) / (2*r)
3902 
3903 ! if(n0.eq.1) then
3904 ! write(*,*) 'Cas(1,n1,n2)=',n1,n2, 4*Cuvshift(n0,n1,n2) + detXshift/detZshift*Cshift(n0-1,n1,n2)
3905 ! write(*,*) 'Cas(1,n1,n2)=', (detZmZadjfshift + Zadjsshift(1)*(mm12shift-mm02shift) + Zadjsshift(2)*(mm22shift-mm02shift) &
3906 ! ) /detZshift * B_0(n0-1,n1,n2)
3907 ! write(*,*) 'Cas(1,n1,n2)=', detZmZadjfshift,Zadjsshift(1)*(mm12shift-mm02shift),Zadjsshift(2)*(mm22shift-mm02shift) &
3908 ! ,detZshift ,B_0(n0-1,n1,n2)
3909 ! write(*,*) 'Cas(1,n1,n2)=', (1d0 - (Zadjfshift(1)+Zadjfshift(2))/detZshift)* B_0(n0-1,n1,n2)
3910 ! write(*,*) 'Cas(1,n1,n2)=', + Zadjfshift(1)/detZshift* B_i(n0-1,n2,1)
3911 ! write(*,*) 'Cas(1,n1,n2)=', + Zadjfshift(2)/detZshift * B_i(n0-1,n1,2)
3912 ! end if
3913 
3914  end do
3915  end do
3916 
3917  ! reduction formula (5.11) with (5.10) inserted for n0 = 0
3918 ! do n0=(r-1)/2,0,-1
3919  n0=0
3920  do n1=0,r-2*n0
3921  n2 = r-2*n0-n1
3922 
3923  if (n1.ge.1) then
3924  nn1 = n1-1
3925  nn2 = n2
3926  j = 1
3927  else
3928  nn1 = n1
3929  nn2 = n2-1
3930  j = 2
3931  end if
3932 
3933 ! do i=1,2
3934 ! Smod(i) = -B_0(n0,nn1,nn2)
3935 ! end do
3936  smod = 0d0
3937 
3938  if (nn1.ge.1) then
3939  smod(1) = smod(1) - 2d0*nn1*cshift(n0+1,nn1-1,nn2)
3940  else
3941  smod(1) = smod(1) + b_i(n0,nn2,1)
3942  end if
3943 
3944  if (nn2.ge.1) then
3945  smod(2) = smod(2) - 2d0*nn2*cshift(n0+1,nn1,nn2-1)
3946  else
3947  smod(2) = smod(2) + b_i(n0,nn1,2)
3948  end if
3949 
3950  cshift(n0,n1,n2) = (zadjshift(1,j)*smod(1) + zadjshift(2,j)*smod(2) &
3951  - zadjsshift(j)*b_0(n0,nn1,nn2) &
3952  - zadjfshift(j)*cshift(n0,nn1,nn2))/detzshift
3953 
3954 ! if(n0.eq.0) then
3955 ! write(*,*) 'Cas(0,n1,n2)=',n1,n2,Cshift(0,n1,n2),nn1,nn2,j
3956 ! write(*,*) 'Cas(0,n1,n2)=',Zadjshift(1,j),Smod(1),Zadjshift(2,j),Smod(2)
3957 ! write(*,*) 'Cas(0,n1,n2)=',Zadjsshift(j),B_0(n0,nn1,nn2),Zadjfshift(j),Cshift(n0,nn1,nn2)
3958 ! write(*,*) 'Cas(0,n1,n2)=',Zadjshift(1,j)*Smod(1),Zadjshift(2,j)*Smod(2)
3959 ! write(*,*) 'Cas(0,n1,n2)=',-Zadjsshift(j)*B_0(n0,nn1,nn2),-Zadjfshift(j)*Cshift(n0,nn1,nn2)
3960 ! end if
3961 
3962  end do
3963 ! end do
3964 
3965  ! determine error from symmetry for n0=0 and n1>=1, n2>=1
3966  cerr(r)=cerr(r-1)
3967  cerr2(r)=cerr2(r-1)
3968  n0=0
3969  do n1=1,r-2*n0-1
3970  n2 = r-2*n0-n1
3971 
3972  nn1 = n1
3973  nn2 = n2-1
3974  j = 2
3975 
3976 ! do i=1,2
3977 ! Smod(i) = -B_0(n0,nn1,nn2)
3978 ! end do
3979  smod = 0
3980 
3981  if (nn1.ge.1) then
3982  smod(1) = smod(1) - 2d0*nn1*cshift(n0+1,nn1-1,nn2)
3983  else
3984  smod(1) = smod(1) + b_i(n0,nn2,1)
3985  end if
3986 
3987  if (nn2.ge.1) then
3988  smod(2) = smod(2) - 2d0*nn2*cshift(n0+1,nn1,nn2-1)
3989  else
3990  smod(2) = smod(2) + b_i(n0,nn1,2)
3991  end if
3992 
3993  cshift_alt(n0,n1,n2) = (zadjshift(1,j)*smod(1) + zadjshift(2,j)*smod(2) &
3994  - zadjsshift(j)*b_0(n0,nn1,nn2) &
3995  - zadjfshift(j)*cshift(n0,nn1,nn2))/detzshift
3996 
3997  cerr(r)=max(cerr(r),abs(cshift(n0,n1,n2)-cshift_alt(n0,n1,n2)))
3998  cerr2(r)=max(cerr2(r),abs(cshift(n0,n1,n2)-cshift_alt(n0,n1,n2)))
3999 
4000 ! if(n0.eq.0) then
4001 ! write(*,*) 'Cbs(0,n1,n2)=',n1,n2,Cshift_alt(0,n1,n2),nn1,nn2,j
4002 ! write(*,*) 'Cbs(0,n1,n2)=',Zadjshift(1,j),Smod(1),Zadjshift(2,j),Smod(2)
4003 ! write(*,*) 'Cbs(0,n1,n2)=',Zadjsshift(j),B_0(n0,nn1,nn2),Zadjfshift(j),Cshift(n0,nn1,nn2)
4004 ! end if
4005 ! write(*,*) 'CalcCpvshift Cerr',n0,n1,n2, Cerr(r), abs(Cshift(n0,n1,n2)),abs(Cshift_alt(n0,n1,n2))
4006 
4007  end do
4008 
4009  if(r.ge.2)then
4010 ! estimate using insertions of (5.11) in (5.10)
4011  c00_err(r) = max(2*abs(m02shift)*cij_err(r-2), b_err, &
4012  azadjffshift/adetzshift*cij_err(r-2), &
4013  maxzadjfshift/adetzshift*max(2*c00_err(r-1),b_err))/(2*r)
4014 
4015  else
4016  c00_err(r) = 0d0
4017  end if
4018 ! estimate using insertions of (5.10) in (5.11)
4019  cij_err(r) = max(maxzadjfshift*cij_err(r-1), &
4020  maxzadjshift*max(2*c00_err(r),b_err))/adetzshift
4021 
4022  if(r.ge.2)then
4023  c00_err2(r) = max(2*abs(m02shift)*cij_err2(r-2), b_err, &
4024  azadjffshift/adetzshift*cij_err2(r-2), &
4025  maxzadjfshift/adetzshift*max(2*c00_err(r-1),b_err))/(2*r)
4026 
4027  else
4028  c00_err2(r) = 0d0
4029  end if
4030  cij_err2(r) = max((maxzadjfshift/maxzadjshift)*cij_err2(r-1),max(2*c00_err2(r),b_err))/sqrt(adetzshift)
4031  end do
4032 
4033  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
4034  do r=rmax+1,2*rmax
4035  do n0=r-rmax,r/2
4036  do n1=0,r-2*n0
4037  n2 = r-2*n0-n1
4038  cshift(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02shift*cshift(n0-1,n1,n2) + 4*cuvshift(n0,n1,n2) &
4039  + fshift(1)*cshift(n0-1,n1+1,n2) + fshift(2)*cshift(n0-1,n1,n2+1)) / (2*r)
4040  end do
4041  end do
4042  end do
4043 
4044 
4045 #ifdef Cpvshifttest
4046  write(*,*) 'CalcCpvshift Cerrsym',cerr
4047  write(*,*) 'CalcCpvshift Caccsym',cerr/abs(cshift(0,0,0))
4048 
4049  write(*,*) 'CalcCpvshift Cijerr',cij_err(1:rmax)
4050  write(*,*) 'CalcCpvshift Cijacc',cij_err(1:rmax)/abs(cshift(0,0,0))
4051 #endif
4052 
4053  cerr2 = max(cerr2,cij_err2(0:rmax))
4054  cerr = max(cerr,cij_err(0:rmax))
4055 
4056 #ifdef Cpvshifttest
4057  write(*,*) 'CalcCpvshift Cerr',cerr
4058  write(*,*) 'CalcCpvshift Cacc',cerr/abs(cshift(0,0,0))
4059 ! write(*,*) 'CalcCpvshift Cerr2',Cerr2
4060 #endif
4061 
4062 
4063 
4064 #ifdef Cpvshifttest
4065  write(*,*) 'CalcCpvshift C',cshift(0,0,0)
4066  write(*,*) 'CalcCpvshift C1',cshift(0,1,0)
4067  write(*,*) 'CalcCpvshift C2',cshift(0,0,1)
4068  write(*,*) 'CalcCpvshift C11',cshift(0,2,0)
4069  write(*,*) 'CalcCpvshift C12',cshift(0,1,1)
4070  write(*,*) 'CalcCpvshift C22',cshift(0,0,2)
4071 #endif
4072 
4073  end subroutine calccpvshift
4074 
4075 
4076 
4077 
4078 
4079  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4080  !
4081  ! Version derived from CalcDg AD 28.11.2014
4082  !
4083  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4084  ! subroutine CalcCgn(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
4085  !
4086  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4087 
4088  subroutine calccgn(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
4089 
4090  use globalc
4091 
4092  integer, intent(in) :: rmax,ordg_min,ordg_max,id
4093  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
4094  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
4095  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
4096  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
4097  double precision, intent(in) :: acc_req_Cr(0:rmax)
4098  double complex :: Xtilde,Zkl,Zadjfj,Zadj2,Zadjkl
4099  double complex, allocatable :: Cexpg(:,:,:,:), CuvExpg(:,:,:)
4100  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
4101  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
4102  double complex :: Smod(2), Skl, CexpgAux
4103  double complex :: C0_coli, elimminf2_coli
4104  double precision, allocatable :: C00_err(:),Cij_err(:)
4105  double precision, allocatable :: C00_err2(:),Cij_err2(:)
4106  double precision :: B_err,B_max
4107  double precision :: maxCexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
4108  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,i,j,m,n,sgn,g,rg
4109  integer :: inds0(2), inds(2), inds2(2), ktlt(2)
4110  integer :: bin,nid(0:2)
4111 
4112  double complex, allocatable :: D_alt(:,:,:,:)
4113 
4114 #ifdef Cgntest
4115  write(*,*) 'CalcCgn in ',rmax,ordg_min,ordg_max
4116 #endif
4117 #ifdef TRACECin
4118  write(*,*) 'CalcCgn in ',rmax,ordg_min,ordg_max
4119 #endif
4120 
4121  ! allocation of B functions
4122  rmaxb = rmax + ordg_min
4123  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
4124  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
4125  allocate(b_i(0:rmaxb,0:rmaxb,2))
4126  allocate(buv_i(0:rmaxb,0:rmaxb,2))
4127 
4128 
4129  ! determine binaries for B-coefficients
4130  k=0
4131  bin = 1
4132  do while (k.le.2)
4133  if (mod(id/bin,2).eq.0) then
4134  nid(k) = id+bin
4135  k = k+1
4136  end if
4137  bin = 2*bin
4138  end do
4139 
4140  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
4141  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
4142  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
4143 
4144  ! shift of integration momentum in B_0
4145  b_max=0d0
4146  do n1=1,rmaxb
4147  do n2=0,rmaxb-n1
4148  n0 = (rmaxb-n1-n2)
4149  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
4150  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
4151  b_max = max(b_max,abs(b_0(0,n1,n2)))
4152  end do
4153  end do
4154  ! error estimate for B's
4155  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
4156  b_err = acc_def_b*b_max
4157 
4158 
4159  ! determine (adjugated) Gram matrix
4160 ! mm02 = elimminf2_coli(m02)
4161 ! mm12 = elimminf2_coli(m12)
4162 ! mm22 = elimminf2_coli(m22)
4163 ! q10 = elimminf2_coli(p10)
4164 ! q21 = elimminf2_coli(p21)
4165 ! q20 = elimminf2_coli(p20)
4166 !
4167 ! q1q2 = (q10+q20-q21)
4168 ! detZ = 4d0*q10*q20-q1q2*q1q2
4169 
4170 ! if (abs(detZ/( 4d0*q10*q20 + q1q2*q1q2)).lt.1d-4) then
4171 ! if (abs(q10-q20).lt.abs(q10-q21).and. &
4172 ! abs(q10-q20).lt.abs(q20-q21)) then
4173 ! detZ = 4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
4174 ! end if
4175 ! end if
4176 
4177 ! write(*,*) 'Z = ',Z
4178 
4179 ! Zadj(1,1) = 2d0*q20
4180 ! Zadj(2,1) = -q1q2
4181 ! Zadj(1,2) = -q1q2
4182 ! Zadj(2,2) = 2d0*q10
4183 ! f(1) = q10+mm02-mm12
4184 ! f(2) = q20+mm02-mm22
4185 
4186 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
4187 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
4188 
4189 ! maxZadj=maxval(abs(Zadj))
4190 ! fmax =maxval(abs(f))
4191 
4192  ! coefficients Shat defined in (5.13)
4193  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
4194 
4195  do r=0,rmaxb
4196  do n0=0,r/2
4197 
4198  do n1=0,r-2*n0
4199  n2 = r-2*n0-n1
4200  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
4201  end do
4202 
4203  k = r-2*n0
4204  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
4205  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
4206 
4207  end do
4208  end do
4209 
4210  ! choose reduction formulas with biggest denominators
4211  if (abs(zadjf(1)).ge.abs(zadjf(2))) then
4212  j = 1
4213  else
4214  j = 2
4215  end if
4216 
4217  maxzadj = 0d0 ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
4218  ! Zadj2(n,m) == Zadf2(k,n,l,m)
4219  if (abs(zadj(1,1)).gt.maxzadj) then
4220  maxzadj = abs(zadj(1,1))
4221  k = 1
4222  l = 1
4223  inds2 = (/2,2/)
4224  zadj2 = -1d0
4225  end if
4226  if (abs(zadj(1,2)).gt.maxzadj) then
4227  maxzadj = abs(zadj(1,2))
4228  k = 1
4229  l = 2
4230  inds2 = (/2,1/)
4231  zadj2 = 1d0
4232  end if
4233 
4234  zadjfj = zadjf(j)
4235  zadjkl = zadj(k,l)
4236  xtilde = xadj(k,l)
4237 
4238 ! write(*,*) 'CalcCgn Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
4239 
4240 
4241  ! allocation of array for det(Z)-expanded C-coefficients
4242  rmaxexp = rmaxb+1
4243  allocate(cexpg(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordg_max))
4244 
4245  ! calculate Cuv
4246  allocate(cuvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp))
4247  call calccuv(cuvexpg,buv_0,mm02,f,rmaxexp,id)
4248  cuv(0:rmax,0:rmax,0:rmax) = cuvexpg(0:rmax,0:rmax,0:rmax)
4249 
4250  ! allocate arrays for error propagation
4251  allocate(c00_err(0:rmaxexp))
4252  allocate(cij_err(0:rmaxexp))
4253  allocate(c00_err2(0:rmaxexp))
4254  allocate(cij_err2(0:rmaxexp))
4255 
4256  ! initialize accuracy estimates
4257  cerr = acc_inf
4258  cij_err =0d0
4259  c00_err =0d0
4260 
4261  cerr2 = acc_inf
4262  cij_err2 =0d0
4263  c00_err2 =0d0
4264 
4265 #ifdef Cgntest
4266  write(*,*) 'CalcCgn rmax = ',rmax,rmaxexp
4267  write(*,*) 'CalcCgn Cij_err = ',cij_err
4268  write(*,*) 'CalcCgn B0 = ', b_0(0,0,0),b_i(0,0,1),b_i(0,0,2)
4269 #endif
4270 
4271 ! maxZadj = maxval(abs(Zadj))
4272 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
4273 
4274  ! truncation of expansion if calculated term larger than truncfacexp * previous term
4275  ! crucial for expansion parameters between 0.1 and 1 !!!
4276  truncfacexp = sqrt(fac_g) * truncfacc
4277  gtrunc = ordg_max
4278 
4279 ! calculate C(n0,n1,n2) up to rank r for n0>0 and up to rank r-1 for n0=0
4280  rloop: do r=1,rmaxexp
4281 
4282 #ifdef Cgntest
4283 ! write(*,*) 'CalcCgn rloop',r,rmax,gtrunc
4284 #endif
4285 
4286  if (r.gt.rmax+gtrunc+1) exit rloop
4287 
4288 #ifdef Cgntest
4289  write(*,*) 'CalcCgn rloop',r
4290 #endif
4291 
4292  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4293  ! 0th-order coefficients
4294  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4295 
4296  ! calculating
4297  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
4298  ! exploiting eq. (5.40)
4299  maxcexpg(1,r,0)=0d0
4300  do n0=r/2,1,-1
4301  do n1=0,r-2*n0
4302  n2=r-2*n0-n1
4303 
4304  inds0(1) = n1
4305  inds0(2) = n2
4306 
4307  cexpgaux = 2d0*zadj(k,l)*b_0(n0-1,n1,n2) &
4308  + xtilde*cexpg(n0-1,n1,n2,0) &
4309  + 4d0*zadj(k,l)*cuvexpg(n0,n1,n2)
4310 
4311  inds = inds0
4312  inds(k) = inds(k)+1
4313  do i=1,2
4314  cexpgaux = cexpgaux + zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
4315  end do
4316 
4317  do i=1,2
4318  inds = inds0
4319  inds(i) = inds(i)+1
4320  cexpgaux = cexpgaux - zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
4321  end do
4322 
4323  n = inds2(1)
4324  m = inds2(2)
4325 
4326  skl = f(n)*shat(n0-1,inds0(1),inds0(2),m)
4327 
4328  inds = inds0
4329  if (inds(m).ge.1) then
4330  inds(m) = inds(m)-1
4331  skl = skl - 2d0*f(n)*inds0(m)*cexpg(n0,inds(1),inds(2),0)
4332  if (inds(n).ge.1) then
4333  inds(n) = inds(n)-1
4334  skl = skl - 4d0*inds0(m)*(inds(n)+1)*cexpg(n0+1,inds(1),inds(2),0)
4335  end if
4336  end if
4337  inds = inds0
4338  if (inds(n).ge.1) then
4339  inds(n) = inds(n)-1
4340  skl = skl + 2d0*inds0(n)*shat(n0,inds(1),inds(2),m) &
4341  - 2d0*f(m)*inds0(n)*cexpg(n0,inds(1),inds(2),0)
4342  end if
4343 
4344  cexpgaux = cexpgaux - zadj2*skl
4345 
4346  cexpg(n0,n1,n2,0) = cexpgaux/(2d0*zadjkl)/(2d0*(r-n0)+1)
4347 
4348  if (n0.eq.1) then
4349  maxcexpg(1,r,0) = maxcexpg(1,r,0) + abs(cexpg(n0,n1,n2,0) )
4350  end if
4351 
4352  if (r-n0.le.rmax) then
4353  c(n0,n1,n2) = cexpg(n0,n1,n2,0)
4354  end if
4355 
4356  end do
4357  end do
4358 
4359  ! calculate
4360  ! C_00ijkl.. --> C_aijkl..
4361  ! exploiting eq. (5.38)
4362  maxcexpg(0,r-1,0)=0d0
4363  do n1=0,r-1
4364  n2=r-1-n1
4365 
4366  smod = shat(0,n1,n2,:)
4367  if (n1.ge.1) then
4368  smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,0)
4369  end if
4370  if (n2.ge.1) then
4371  smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,0)
4372  end if
4373 
4374  cexpg(0,n1,n2,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2))/zadjfj
4375  maxcexpg(0,r-1,0) = maxcexpg(0,r-1,0) + abs(cexpg(0,n1,n2,0))
4376  if (r-n0.le.rmax+1) then
4377  c(0,n1,n2) = cexpg(0,n1,n2,0)
4378  end if
4379 
4380 #ifdef Cgntest
4381 ! if(n0.eq.0.and.n1.eq.0.and.n2.eq.3) then
4382 ! write(*,*) 'C2(0,0,3,0)= ',0,C(n0,n1,n2)
4383 ! end if
4384 #endif
4385 
4386  end do
4387 
4388 #ifdef Cgntest
4389 ! write(*,*) 'CalcCgn maxCexpg 0',r-1, maxCexpg(0,r-1,0)
4390 #endif
4391 
4392  if(r.le.rmax+1) then
4393 ! Cerr(r-1) = abs(detZ/Zadjfj)*maxCexpg(0,r-1,0)
4394  cerr(r-1) = fac_g*maxcexpg(0,r-1,0)
4395  end if
4396 
4397  ! error propagation from B's
4398  c00_err(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zadjkl),b_err) &
4399  /(2*(2*r-1))
4400  cij_err(r-1)=maxzadj*max(b_err,2*c00_err(r))/abs(zadjfj)
4401 
4402  c00_err2(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zadjkl),b_err) &
4403  /(2*(2*r-1))
4404  cij_err2(r-1)=maxzadj*max(b_err,2*c00_err2(r))/abs(zadjfj)
4405 
4406 #ifdef Cgntest
4407  write(*,*) 'CalcCgn C00_err',r, maxzadj,fmax,abs(zadjkl),b_err,abs(zadjfj)
4408  write(*,*) 'CalcCgn C00_err',r, c00_err(r), cij_err(r-1)
4409 #endif
4410 
4411  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4412  ! higher order coefficients
4413  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4414 
4415  rg = r
4416  gloop: do g=1,min(gtrunc,r-1)
4417  rg = rg-1
4418 
4419 ! write(*,*) 'gloop ',g,rg
4420 
4421  ! calculating
4422  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
4423  ! exploiting eq. (5.40)
4424  maxcexpg(1,rg,g) = 0d0
4425  do n0=rg/2,1,-1
4426  do n1=0,rg-2*n0
4427  n2=rg-2*n0-n1
4428 
4429  inds0(1) = n1
4430  inds0(2) = n2
4431 
4432  inds = inds0
4433  inds(k) = inds(k)+1
4434  inds(l) = inds(l)+1
4435  cexpgaux = xtilde*cexpg(n0-1,n1,n2,g) &
4436  - detz*cexpg(n0-1,inds(1),inds(2),g-1)
4437 
4438 
4439  n = inds2(1)
4440  m = inds2(2)
4441 
4442  skl = 0d0
4443 
4444  inds = inds0
4445  if (inds(m).ge.1) then
4446  inds(m) = inds(m)-1
4447  skl = skl - 2d0*f(n)*inds0(m)*cexpg(n0,inds(1),inds(2),g)
4448  if (inds(n).ge.1) then
4449  inds(n) = inds(n)-1
4450  skl = skl - 4d0*inds0(m)*(inds(n)+1)*cexpg(n0+1,inds(1),inds(2),g)
4451  end if
4452  end if
4453  inds = inds0
4454  if (inds(n).ge.1) then
4455  inds(n) = inds(n)-1
4456  skl = skl - 2d0*f(m)*inds0(n)*cexpg(n0,inds(1),inds(2),g)
4457  end if
4458 
4459  cexpgaux = cexpgaux - zadj2*skl
4460 
4461  cexpg(n0,n1,n2,g) = cexpgaux/(2d0*zadjkl)/(2d0*(rg-n0)+1)
4462 
4463 
4464  if(n0.eq.1) then
4465  maxcexpg(1,rg,g) = maxcexpg(1,rg,g) + abs(cexpg(n0,n1,n2,g))
4466 
4467  if (g.eq.1.and.abs(cexpg(n0,n1,n2,g)).gt. &
4468  truncfacexp*max(1d0,maxcexpg(1,rg,g-1)) .or. &
4469  g.ge.2.and.abs(cexpg(n0,n1,n2,g)).gt. &
4470  truncfacexp*maxcexpg(1,rg,g-1)) then
4471 
4472 #ifdef Cgntest
4473  write(*,*) 'CalcCgn exit gloop',n0,n1,n2,g,abs(cexpg(n0,n1,n2,g)),maxcexpg(1,rg,g-1),truncfacexp
4474 #endif
4475 
4476  gtrunc = g-1
4477  exit gloop
4478  end if
4479  end if
4480 
4481  end do
4482  end do
4483 
4484 #ifndef PPEXP00
4485  do n0=rg/2,1,-1
4486  if (rg-n0.le.rmax) then
4487  do n1=0,rg-2*n0
4488  n2=rg-2*n0-n1
4489  c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
4490  end do
4491  end if
4492  end do
4493 #endif
4494 ! write(*,*) 'CalcCgn after it1 ',rg
4495 
4496  ! calculate
4497  ! C_00ijkl.. --> C_aijkl..
4498  ! exploiting eq. (5.38)
4499 
4500 ! write(*,*) 'CalcCgn maxCexp',rg-1,g-1,maxCexpg(0,rg-1,g-1)
4501 
4502  maxcexpg(0,rg-1,g) = 0d0
4503  do n1=0,rg-1
4504  n2=rg-1-n1
4505 
4506  smod = 0d0
4507  if (n1.ge.1) then
4508  smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,g)
4509  end if
4510  if (n2.ge.1) then
4511  smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,g)
4512  end if
4513 
4514  inds(1) = n1
4515  inds(2) = n2
4516  inds(j) = inds(j)+1
4517  cexpg(0,n1,n2,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
4518  - detz*cexpg(0,inds(1),inds(2),g-1))/zadjfj
4519 
4520  maxcexpg(0,rg-1,g) = maxcexpg(0,rg-1,g) + abs(cexpg(0,n1,n2,g))
4521 
4522 ! if(n1.eq.0.and.n2.eq.1) then
4523 ! write(*,*) 'C2(2,3)= ',g,Cexpg(0,n1,n2,g)
4524 ! write(*,*) 'C2(2,3)= ',Zadj(1,j)*Smod(1)/Zadjfj, Zadj(2,j)*Smod(2)/Zadjfj, &
4525 ! - detZ*Cexpg(0,inds(1),inds(2),inds(3),g-1)/Zadjfj
4526 ! write(*,*) 'C2(2,3)= ',inds(1),inds(2), &
4527 ! - detZ/Zadjfj,Cexpg(0,inds(1),inds(2),g-1)
4528 ! end if
4529 
4530  if (g.eq.1.and.abs(cexpg(0,n1,n2,g)).gt. &
4531  truncfacexp*max(1/m2max,maxcexpg(0,rg-1,g-1)) .or. &
4532  g.ge.2.and.abs(cexpg(0,n1,n2,g)).gt. &
4533  truncfacexp*maxcexpg(0,rg-1,g-1)) then
4534 
4535 #ifdef Cgntest
4536  write(*,*) 'CalcCgn exit gloop',0,n1,n2,g,abs(cexpg(0,n1,n2,g)),maxcexpg(0,rg-1,g-1),truncfacexp
4537 #endif
4538  gtrunc = g-1
4539  exit gloop
4540  end if
4541 
4542  end do
4543 
4544  ! error propagation from B's
4545  if(rg.gt.1)then
4546  c00_err(rg) = max(c00_err(rg), &
4547  max( abs(m02)*cij_err(rg-2), &
4548  max(adetz*cij_err(rg),fmax**2*cij_err(rg-2),fmax*c00_err(rg-1))/abs(zadjkl) ) &
4549  /(2*(2*rg-1)) )
4550  end if
4551  cij_err(rg-1) = max(cij_err(rg-1),max(2*maxzadj*c00_err(rg),adetz*cij_err(rg))/abs(zadjfj) )
4552 
4553  if(rg.gt.1)then
4554  c00_err2(rg) = max(c00_err2(rg), &
4555  max( abs(m02)*cij_err2(rg-2), &
4556  max(adetz*cij_err2(rg),fmax**2*cij_err2(rg-2),fmax*c00_err2(rg-1))/abs(zadjkl) ) &
4557  /(2*(2*rg-1)) )
4558  end if
4559  cij_err2(rg-1) = max(cij_err2(rg-1),max(2*maxzadj*c00_err2(rg),adetz*cij_err2(rg))/abs(zadjfj) )
4560 
4561 ! write(*,*) 'CalcCg g: ',r,adetZ/abs(Zadjfj),C00_err(rg),B_err
4562 ! write(*,*) 'CalcCg g: Cij_err=',rg-1,Cij_err(rg-1)
4563 
4564 #ifdef PPEXP00
4565  do n0=rg/2,1,-1
4566  if (rg-n0.le.rmax) then
4567  do n1=0,rg-2*n0
4568  n2=rg-2*n0-n1
4569  c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
4570  end do
4571  end if
4572  end do
4573 #endif
4574 
4575 ! write(*,*) 'CalcCgn after it1 ',rg
4576  if ((rg.le.rmax+1)) then
4577  cerr(rg-1) = 0d0
4578  do n1=0,rg-1
4579  n2 = rg-1-n1
4580  c(0,n1,n2) = c(0,n1,n2) + cexpg(0,n1,n2,g)
4581  if(abs(cexpg(0,n1,n2,g-1)).ne.0d0) then
4582 ! Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)))
4583  cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g))*min(1d0,abs(cexpg(0,n1,n2,g))/abs(cexpg(0,n1,n2,g-1))))
4584  else
4585  cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g)))
4586  end if
4587 
4588 ! write(*,*) 'CalcCg err',r,rg,n1,n2,Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)) &
4589 ! ,abs(Cexpg(0,n1,n2,g)),abs(Cexpg(0,n1,n2,g-1))
4590 
4591  end do
4592 
4593  ! if error from B's larger than error from expansion stop expansion
4594  if(cij_err(rg-1).gt.cerr(rg-1)) then
4595  gtrunc = min(g,gtrunc)
4596 
4597 #ifdef Cgtest
4598  write(*,*) 'CalcCgn exit err',r,g,gtrunc &
4599  ,cij_err(rg-1),cerr(rg-1)
4600 #endif
4601 
4602  end if
4603  end if
4604 
4605  end do gloop
4606 
4607 #ifdef Cgntest
4608  write(*,*) 'CalcCgn C(0,0,0) = ',r,c(0,0,0)
4609  if(r.gt.1)then
4610  write(*,*) 'CalcCgn C(1,0,0) = ',r,c(1,0,0)
4611  write(*,*) 'CalcCgn C(0,1,0) = ',r,c(0,1,0)
4612  write(*,*) 'CalcCgn C(0,0,1) = ',r,c(0,0,1)
4613  end if
4614  if(r.gt.2.and.rmax.ge.2)then
4615  write(*,*) 'CalcCgn C(0,2,0) = ',r,c(0,2,0)
4616 ! write(*,*) 'CalcCgn C(0,1,1) = ',r,C(0,1,1)
4617  write(*,*) 'CalcCgn C(0,0,2) = ',r,c(0,0,2)
4618  end if
4619  if(r.gt.3.and.rmax.ge.3)then
4620  write(*,*) 'CalcCgn C(1,0,1) = ',r,c(1,0,1)
4621  write(*,*) 'CalcCgn C(1,1,0) = ',r,c(1,1,0)
4622  write(*,*) 'CalcCgn C(1,0,1) = ',r,c(1,0,1)
4623 ! write(*,*) 'CalcCgn C(1,2,0) = ',r,C(1,2,0)
4624  write(*,*) 'CalcCgn C(0,3,0) = ',r,c(0,3,0)
4625  write(*,*) 'CalcCgn C(0,2,1) = ',r,c(0,2,1)
4626  write(*,*) 'CalcCgn C(0,0,3) = ',r,c(0,0,3)
4627  end if
4628  write(*,*) 'CalcCgn Cij_err',r,cij_err
4629  write(*,*) 'CalcCgn Cij_acc',r,cij_err/abs(c(0,0,0))
4630 
4631  write(*,*) 'CalcCgn err',r,cerr
4632  write(*,*) 'CalcCgn acc',r,cerr/abs(c(0,0,0))
4633 #endif
4634 
4635  cerr2 = max(cerr,cij_err2(0:rmax))
4636  cerr = max(cerr,cij_err(0:rmax))
4637 
4638 #ifdef Cgntest
4639 ! write(*,*) 'CalcCgn exit r',r,maxval(Cerr),acc_req_C*abs(C(0,0,0))
4640 #endif
4641 
4642 ! if(maxval(Cerr).le.acc_req_C*abs(C(0,0,0))) exit ! changed 28.01.15
4643  ! check if target precision already reached
4644 #ifdef Cutrloop
4645  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
4646  do rg=r+1,rmax
4647 
4648 ! write(*,*) 'CalcCgn exit rloop =',rg,r,rmax
4649 
4650  do n0=0,rg/2
4651  do n1=0,rg-2*n0
4652  c(n0,n1,rg-2*n0-n1)=0d0
4653  end do
4654  end do
4655  end do
4656  if(r.le.rmax) then
4657  do n1=0,r
4658  c(0,n1,r-n1)=0d0
4659  end do
4660  end if
4661 #else
4662  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
4663 #endif
4664  exit rloop
4665  end if
4666 
4667  end do rloop
4668 
4669  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
4670  do r=rmax+1,2*rmax
4671  do n0=r-rmax,r/2
4672  do n1=0,r-2*n0
4673  n2 = r-2*n0-n1
4674  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
4675  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
4676  end do
4677  end do
4678  end do
4679 
4680 
4681 #ifdef Cgntest
4682 ! write(*,*) 'CalcCgn C(0,0,0,0) = ',C(0,0,0)
4683 ! if(rmax.ge.3)then
4684 ! write(*,*) 'CalcCgn C(0,1,1,1) = ',C(0,1,1)
4685 ! end if
4686 
4687  write(*,*) 'CalcCgn final err',cerr
4688  write(*,*) 'CalcCgn final acc',cerr/abs(c(0,0,0))
4689 #endif
4690 
4691 ! write(*,*) 'CalcCgn out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
4692 #ifdef TRACECout
4693  write(*,*) 'CalcCgn rmax',rmax
4694  do r=14,rmax
4695  do n0=0,r/2
4696  do n1=0,r-2*n0
4697  write(*,*) 'CalcCgn out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
4698  end do
4699  end do
4700  end do
4701 #endif
4702 
4703 ! write(*,*) 'CalcCgn Cerr ',Cerr
4704 ! write(*,*) 'CalcCgn Cerr2',Cerr2
4705 
4706  end subroutine calccgn
4707 
4708 
4709 
4710 
4711  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4712  ! subroutine CalcCg(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
4713  !
4714  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4715 
4716  subroutine calccg(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordg_min,ordg_max,id,Cerr,acc_req_Cr,Cerr2)
4717 
4718  use globalc
4719 
4720  integer, intent(in) :: rmax,ordg_min,ordg_max,id
4721  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
4722  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
4723  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
4724  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
4725  double precision, intent(in) :: acc_req_Cr(0:rmax)
4726  double complex :: Xtilde,Zkl,Zadjfj
4727  double complex, allocatable :: Cexpg(:,:,:,:), CuvExpg(:,:,:)
4728  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
4729  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
4730  double complex :: Smod(2), Skl
4731  double complex :: C0_coli, elimminf2_coli
4732  double precision, allocatable :: C00_err(:),Cij_err(:)
4733  double precision, allocatable :: C00_err2(:),Cij_err2(:)
4734  double precision :: B_err,B_max
4735  double precision :: maxCexpg(0:1,0:rmax+ordg_min+1,0:ordg_max),truncfacexp
4736  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,j,sgn,g,rg,mr
4737  integer :: inds0(2), inds(2), ktlt(2)
4738  integer :: bin,nid(0:2)
4739 
4740 #ifdef Cgtest
4741  write(*,*) 'CalcCg in ',rmax,ordg_min,ordg_max,id
4742 #endif
4743 #ifdef TRACECin
4744  write(*,*) 'CalcCg in ',rmax,ordg_min,ordg_max,id
4745 ! write(*,*) 'CalcCg in acc',acc_req_Cr
4746 #endif
4747 
4748  ! write(*,*) 'LH: CalcCg, ord', ordg_min
4749  ! calculation B-coefficients
4750  rmaxb = rmax + ordg_min
4751  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
4752  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
4753  allocate(b_i(0:rmaxb,0:rmaxb,2))
4754  allocate(buv_i(0:rmaxb,0:rmaxb,2))
4755 
4756  ! determine binaries for B-coefficients
4757  k=0
4758  bin = 1
4759  do while (k.le.2)
4760  if (mod(id/bin,2).eq.0) then
4761  nid(k) = id+bin
4762  k = k+1
4763  end if
4764  bin = 2*bin
4765  end do
4766 
4767  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
4768  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
4769  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
4770 
4771  ! shift of integration momentum in B_0
4772  b_max=0d0
4773  do n1=1,rmaxb
4774  do n2=0,rmaxb-n1
4775  n0 = (rmaxb-n1-n2)
4776  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
4777  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
4778  b_max = max(b_max,abs(b_0(0,n1,n2)))
4779  end do
4780  end do
4781  ! error estimate for B's
4782  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
4783  b_err = acc_def_b*b_max
4784 
4785  ! determine (adjugated) Gram matrix
4786 ! mm02 = elimminf2_coli(m02)
4787 ! mm12 = elimminf2_coli(m12)
4788 ! mm22 = elimminf2_coli(m22)
4789 ! q10 = elimminf2_coli(p10)
4790 ! q21 = elimminf2_coli(p21)
4791 ! q20 = elimminf2_coli(p20)
4792 !
4793 ! q1q2 = (q10+q20-q21)
4794 ! detZ = 4d0*q10*q20-q1q2*q1q2
4795 
4796 ! if (abs(detZ/( 4d0*q10*q20 + q1q2*q1q2)).lt.1d-4) then
4797 ! if (abs(q10-q20).lt.abs(q10-q21).and. &
4798 ! abs(q10-q20).lt.abs(q20-q21)) then
4799 ! detZ = 4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
4800 ! end if
4801 ! end if
4802 
4803 ! write(*,*) 'Z = ',Z
4804 
4805 ! Zadj(1,1) = 2d0*q20
4806 ! Zadj(2,1) = -q1q2
4807 ! Zadj(1,2) = -q1q2
4808 ! Zadj(2,2) = 2d0*q10
4809 ! f(1) = q10+mm02-mm12
4810 ! f(2) = q20+mm02-mm22
4811 
4812 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
4813 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
4814 
4815 ! commented out 2.9.2017
4816 ! maxZadj=maxval(abs(Zadj))
4817 ! fmax =maxval(abs(f))
4818 
4819  ! coefficients Shat defined in (5.13)
4820  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
4821 
4822  do r=0,rmaxb
4823  do n0=0,r/2
4824 
4825  do n1=0,r-2*n0
4826  n2 = r-2*n0-n1
4827  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
4828  end do
4829 
4830  k = r-2*n0
4831  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
4832  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
4833 
4834  end do
4835  end do
4836 
4837 
4838  ! choose reduction formulas with biggest denominators
4839  if (abs(zadjf(1)).ge.abs(zadjf(2))) then
4840  j = 1
4841  else
4842  j = 2
4843  end if
4844 
4845  if (abs(z(1,1)).ge.abs(z(2,2))) then
4846  if (abs(z(1,1)).ge.abs(z(1,2))) then
4847  k = 1
4848  l = 1
4849  sgn = 1
4850  ktlt = (/ 0,2 /)
4851  else
4852  k = 1
4853  l = 2
4854  sgn = -1
4855  ktlt = (/ 1,1 /)
4856  end if
4857  else
4858  if (abs(z(2,2)).ge.abs(z(1,2))) then
4859  k = 2
4860  l = 2
4861  sgn = 1
4862  ktlt = (/ 2,0 /)
4863  else
4864  k = 1
4865  l = 2
4866  sgn = -1
4867  ktlt = (/ 1,1 /)
4868  end if
4869  end if
4870 
4871  zadjfj = zadjf(j)
4872  zkl = z(k,l)
4873  if(k.eq.l) then
4874  xtilde = xadj(3-k,3-l) ! subroutine uses Z instead of Zadj
4875  else ! -> exchange indices 1 and 2
4876  xtilde = -xadj(3-k,3-l) ! -> minus sign for k \ne l
4877  end if
4878 
4879 ! write(*,*) 'CalcCg Xtilde n',Xtilde,Xadj(1,1),Xadj(1,2),Xadj(2,2)
4880 
4881 ! write(*,*) 'Xtilde =',Xtilde,k,l
4882 
4883  ! allocation of array for det(Z)-expanded C-coefficients
4884  rmaxexp = rmaxb+1
4885  allocate(cexpg(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordg_max))
4886 
4887 
4888  ! calculate Cuv
4889  allocate(cuvexpg(0:rmaxexp,0:rmaxexp,0:rmaxexp))
4890  call calccuv(cuvexpg,buv_0,mm02,f,rmaxexp,id)
4891  cuv(0:rmax,0:rmax,0:rmax) = cuvexpg(0:rmax,0:rmax,0:rmax)
4892 
4893  ! allocate arrays for error propagation
4894  allocate(c00_err(0:rmaxexp))
4895  allocate(cij_err(0:rmaxexp))
4896  allocate(c00_err2(0:rmaxexp))
4897  allocate(cij_err2(0:rmaxexp))
4898 
4899  ! initialize accuracy estimates
4900  cerr = acc_inf
4901  cij_err = 0d0
4902  c00_err = 0d0
4903 
4904  cerr2 = acc_inf
4905  cij_err2 = 0d0
4906  c00_err2 = 0d0
4907 
4908  ! truncation of expansion if calculated term larger than truncfacexp * previous term
4909  ! crucial for expansion parameters between 0.1 and 1 !!!
4910 ! truncfacexp = sqrt(abs(detZ/Zadjfj)) * truncfacC
4911  truncfacexp = sqrt(fac_g) * truncfacc
4912  gtrunc = ordg_max
4913 
4914 ! calculate C(n0,n1,n2) up to rank r for n0>0 and up to rank r-1 for n0=0
4915  rloop: do r=1,rmaxexp
4916 
4917  if (r.gt.rmax+gtrunc+1) exit rloop
4918 
4919 ! write(*,*) 'CalcCg rloop',r,rmaxExp,gtrunc
4920 
4921  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4922  ! 0th-order coefficients
4923  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
4924 
4925  ! calculating
4926  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
4927  ! exploiting eq. (5.40)
4928  maxcexpg(1,r,0)=0d0
4929  do n0=r/2,1,-1
4930  do n1=0,r-2*n0
4931  n2=r-2*n0-n1
4932 
4933  inds0(1) = n1
4934  inds0(2) = n2
4935  skl = 0d0
4936  inds = inds0
4937  if (inds(k).ge.1) then
4938  inds(k) = inds(k)-1
4939  skl = skl - 2d0*f(l)*inds0(k)*cexpg(n0,inds(1),inds(2),0)
4940  if (inds(l).ge.1) then
4941  inds(l) = inds(l)-1
4942  skl = skl - 4d0*inds0(k)*(inds(l)+1)*cexpg(n0+1,inds(1),inds(2),0)
4943  end if
4944  end if
4945  inds = inds0
4946  if (inds(l).ge.1) then
4947  inds(l) = inds(l)-1
4948  skl = skl + 2d0*inds0(l)*shat(n0,inds(1),inds(2),k) &
4949  - 2d0*f(k)*inds0(l)*cexpg(n0,inds(1),inds(2),0)
4950  end if
4951 
4952  cexpg(n0,n1,n2,0) = (2d0*zkl*b_0(n0-1,n1,n2) + xtilde*cexpg(n0-1,n1,n2,0) &
4953  - z(1,k)*shat(n0-1,n1+1,n2,l) - z(2,k)*shat(n0-1,n1,n2+1,l) &
4954  + f(l)*shat(n0-1,n1,n2,k) + 4d0*zkl*cuvexpg(n0,n1,n2) + skl) &
4955  /(2d0*zkl)/(2d0*(r-n0)+1d0)
4956 
4957  if (n0.eq.1) then
4958  maxcexpg(1,r,0) = maxcexpg(1,r,0) + abs(cexpg(n0,n1,n2,0))
4959  end if
4960 
4961  if (r-n0.le.rmax) then
4962  c(n0,n1,n2) = cexpg(n0,n1,n2,0)
4963  end if
4964 
4965  end do
4966  end do
4967 
4968  ! calculate
4969  ! C_00ijkl.. --> C_aijkl..
4970  ! exploiting eq. (5.38)
4971  maxcexpg(0,r-1,0)=0d0
4972  do n1=0,r-1
4973  n2 = r-1-n1
4974 
4975  smod = shat(0,n1,n2,:)
4976  if (n1.ge.1) then
4977  smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,0)
4978  end if
4979  if (n2.ge.1) then
4980  smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,0)
4981  end if
4982 
4983  cexpg(0,n1,n2,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2))/zadjfj
4984 
4985  maxcexpg(0,r-1,0) = maxcexpg(0,r-1,0) + abs(cexpg(0,n1,n2,0))
4986  if (r-n0.le.rmax+1) then
4987  c(0,n1,n2) = cexpg(0,n1,n2,0)
4988  end if
4989 
4990  end do
4991 
4992  if(r.le.rmax+1) then
4993 ! Cerr(r-1) = abs(detZ/Zadjfj)*maxCexpg(0,r-1,0)
4994  cerr(r-1) = fac_g*maxcexpg(0,r-1,0)
4995  end if
4996 
4997  ! error propagation from B's
4998  c00_err(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zkl),b_err) &
4999  /(2*(2*r-1))
5000  cij_err(r-1)=maxzadj*max(b_err,2*c00_err(r))/abs(zadjfj)
5001 
5002  c00_err2(r) = max(max(maxzadj*b_err,fmax*b_err)/abs(zkl),b_err) &
5003  /(2*(2*r-1))
5004  cij_err2(r-1)=maxzadj*max(b_err,2*c00_err2(r))/abs(zadjfj)
5005 
5006 ! write(*,*) 'CalcCg after 0: ',maxZadj/abs(Zadjfj),C00_err(r),B_err
5007 ! write(*,*) 'CalcCg after 0: Cij_err=',r-1,Cij_err(r-1)
5008 
5009 
5010  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5011  ! higher order coefficients
5012  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5013 
5014  rg = r
5015  gloop: do g=1,min(gtrunc,r-1)
5016  rg = rg-1
5017 ! write(*,*) 'CalcCg gloop',g,rg
5018 
5019  ! calculating for rank=rmaxB+1
5020  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
5021  ! exploiting eq. (5.40)
5022  maxcexpg(1,rg,g) = 0d0
5023  do n0=rg/2,1,-1
5024  do n1=0,rg-2*n0
5025  n2=rg-2*n0-n1
5026 
5027  inds0(1) = n1
5028  inds0(2) = n2
5029  skl = 0d0
5030  inds = inds0
5031  if (inds(k).ge.1) then
5032  inds(k) = inds(k)-1
5033  skl = skl - 2d0*f(l)*inds0(k)*cexpg(n0,inds(1),inds(2),g)
5034  if (inds(l).ge.1) then
5035  inds(l) = inds(l)-1
5036  skl = skl - 4d0*inds0(k)*(inds(l)+1)*cexpg(n0+1,inds(1),inds(2),g)
5037  end if
5038  inds = inds0
5039  end if
5040  if (inds(l).ge.1) then
5041  inds(l) = inds(l)-1
5042  skl = skl - 2d0*f(k)*inds0(l)*cexpg(n0,inds(1),inds(2),g)
5043  end if
5044 
5045  inds = inds0 + ktlt
5046  cexpg(n0,n1,n2,g) = (xtilde*cexpg(n0-1,n1,n2,g) + skl &
5047  - detz*sgn*cexpg(n0-1,inds(1),inds(2),g-1)) &
5048  /(2d0*zkl)/(2d0*(rg-n0)+1d0)
5049  if(n0.eq.1) then
5050  maxcexpg(1,rg,g) = maxcexpg(1,rg,g) + abs(cexpg(n0,n1,n2,g))
5051 
5052  if (g.eq.1.and.abs(cexpg(n0,n1,n2,g)).gt. &
5053  truncfacexp*max(1d0,maxcexpg(1,rg,g-1)).or. &
5054  g.ge.2.and.abs(cexpg(n0,n1,n2,g)).gt. &
5055  truncfacexp*maxcexpg(1,rg,g-1)) then
5056 
5057 #ifdef Cgtest
5058  write(*,*) 'CalcCg exit gloop',n0,n1,n2,g,abs(cexpg(n0,n1,n2,g)),maxcexpg(1,rg,g-1)
5059 #endif
5060 ! write(*,*) 'CalcCg exit gloop',n0,n1,n2,g,abs(Cexpg(n0,n1,n2,g)),maxCexpg(1,rg,g-1)
5061 
5062  gtrunc = g-1
5063  exit gloop
5064  end if
5065  end if
5066  end do
5067  end do
5068 
5069 ! write(*,*) 'Calcg: rg,g,acc',rg,g,acc
5070 
5071 #ifndef PPEXP00
5072  do n0=rg/2,1,-1
5073  if (rg-n0.le.rmax) then
5074  do n1=0,rg-2*n0
5075  n2=rg-2*n0-n1
5076  c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
5077  end do
5078  end if
5079  end do
5080 #endif
5081 
5082  ! calculate
5083  ! C_000000..00 --> C_i0000..00 --> C_ij00..00 --> ... --> C_ijk..
5084  ! exploiting eq. (5.38)
5085  maxcexpg(0,rg-1,g) = 0d0
5086  do n1=0,rg-1
5087  n2 = rg-1-n1
5088 
5089  smod = 0d0
5090  if (n1.ge.1) then
5091  smod(1) = smod(1) - 2d0*n1*cexpg(1,n1-1,n2,g)
5092  end if
5093  if (n2.ge.1) then
5094  smod(2) = smod(2) - 2d0*n2*cexpg(1,n1,n2-1,g)
5095  end if
5096 
5097  inds(1) = n1
5098  inds(2) = n2
5099  inds(j) = inds(j)+1
5100 
5101  cexpg(0,n1,n2,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
5102  - detz*cexpg(0,inds(1),inds(2),g-1))/zadjfj
5103 
5104  maxcexpg(0,rg-1,g) = maxcexpg(0,rg-1,g) + abs(cexpg(0,n1,n2,g))
5105 
5106  if (g.eq.1.and.abs(cexpg(0,n1,n2,g)).gt. &
5107  truncfacexp*max(1/m2max,maxcexpg(0,rg-1,g-1)) .or. &
5108  g.ge.2.and.abs(cexpg(0,n1,n2,g)).gt. &
5109  truncfacexp*maxcexpg(0,rg-1,g-1)) then
5110 
5111 #ifdef Cgtest
5112  write(*,*) 'CalcCg exit gloop',0,n1,n2,g,abs(cexpg(0,n1,n2,g)),maxcexpg(0,rg-1,g-1)
5113  write(*,*) 'CalcCg exit gloop',abs(cexpg(0,n1,n2,g)).gt.truncfacexp*maxcexpg(0,rg-1,g-1),truncfacexp
5114  write(*,*) 'CalcCg exit gloop',zadj(1,j)*smod(1)/zadjfj , zadj(2,j)*smod(2)/zadjfj, &
5115  - detz*cexpg(0,inds(1),inds(2),g-1)/zadjfj
5116 #endif
5117 
5118  gtrunc = g-1
5119 
5120 #ifdef Cgtest
5121  write(*,*) 'CalcCg exit gloop',rmax,g,rmaxexp
5122 #endif
5123 ! write(*,*) 'CalcCg exit gloop',rmax,g,rmaxExp
5124 
5125  exit gloop
5126  end if
5127 
5128  end do
5129 
5130  ! error propagation from B's
5131  if(rg.gt.1)then
5132 ! C00_err(rg) = max(C00_err(rg), &
5133 ! max( abs(m02)*Cij_err(rg-2), &
5134 ! max(adetZ*Cij_err(rg),fmax**2*Cij_err(rg-2),fmax*C00_err(rg-1))/abs(Zkl) ) &
5135 ! /(2*(2*rg-1)) )
5136 !24.04.15 ->
5137 ! C00_err(rg) = max(C00_err(rg), &
5138 ! max( abs(m02)*Cij_err(rg-2), &
5139 ! max(adetZ*Cij_err(rg),abs(Xtilde)*Cij_err(rg-2),fmax*C00_err(rg-1))/abs(Zkl) ) &
5140 ! /(2*(2*rg-1)) )
5141 !06.05.15 ->
5142  c00_err(rg) = max(c00_err(rg), &
5143  max(adetz*cij_err(rg),abs(xtilde)*cij_err(rg-2),fmax*c00_err(rg-1))/abs(zkl) &
5144  /(2*(2*rg-1)) )
5145  end if
5146  cij_err(rg-1) = max(cij_err(rg-1),max(2*maxzadj*c00_err(rg),adetz*cij_err(rg))/abs(zadjfj) )
5147 
5148  if(rg.gt.1)then
5149  c00_err2(rg) = max(c00_err2(rg), &
5150  max(adetz*cij_err2(rg),abs(xtilde)*cij_err2(rg-2),fmax*c00_err2(rg-1))/abs(zkl) &
5151  /(2*(2*rg-1)) )
5152  end if
5153  cij_err2(rg-1) = max(cij_err2(rg-1),max(2*maxzadj*c00_err2(rg),adetz*cij_err2(rg))/abs(zadjfj) )
5154 
5155 ! write(*,*) 'CalcCg g: ',r,adetZ/abs(Zadjfj),C00_err(rg),B_err
5156 ! write(*,*) 'CalcCg g: Cij_err=',rg-1,Cij_err(rg-1)
5157 
5158 
5159 #ifdef PPEXP00
5160  do n0=rg/2,1,-1
5161  if (rg-n0.le.rmax) then
5162  do n1=0,rg-2*n0
5163  n2=rg-2*n0-n1
5164  c(n0,n1,n2) = c(n0,n1,n2) + cexpg(n0,n1,n2,g)
5165  end do
5166  end if
5167  end do
5168 #endif
5169 
5170  if ((rg.le.rmax+1)) then
5171  cerr(rg-1) = 0d0
5172  do n1=0,rg-1
5173  n2 = rg-1-n1
5174  c(0,n1,n2) = c(0,n1,n2) + cexpg(0,n1,n2,g)
5175  if(abs(cexpg(0,n1,n2,g-1)).ne.0d0) then
5176 ! Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)))
5177  cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g))*min(1d0,abs(cexpg(0,n1,n2,g))/abs(cexpg(0,n1,n2,g-1))))
5178  else
5179  cerr(rg-1)=max(cerr(rg-1),abs(cexpg(0,n1,n2,g)))
5180  end if
5181 
5182 ! write(*,*) 'CalcCg err',r,rg,n1,n2,Cerr(rg-1),abs(Cexpg(0,n1,n2,g))**2/abs(Cexpg(0,n1,n2,g-1)) &
5183 ! ,abs(Cexpg(0,n1,n2,g)),abs(Cexpg(0,n1,n2,g-1))
5184 
5185  end do
5186 
5187  ! if error from B's larger than error from expansion stop expansion
5188  if(cij_err(rg-1).gt.cerr(rg-1)) then
5189  gtrunc = min(g,gtrunc)
5190 
5191 #ifdef Cgtest
5192  write(*,*) 'CalcCg exit err',r,g,gtrunc
5193 #endif
5194 ! write(*,*) 'CalcCg exit err',r,g,gtrunc
5195 
5196  end if
5197  end if
5198 
5199  end do gloop
5200 
5201 #ifdef Cgtest
5202  write(*,*) 'CalcCg C(0,0,0) = ',r,c(0,0,0)
5203  write(*,*) 'CalcCg C(2,0,0) = ',r,c(1,0,0)
5204  write(*,*) 'CalcCg C(0,1,0) = ',r,c(0,1,0)
5205  write(*,*) 'CalcCg C(0,0,1) = ',r,c(0,0,1)
5206  if(r.ge.5.and.rmax.ge.5) then
5207  write(*,*) 'CalcCg C(2,1,0) = ',r,c(2,1,0)
5208  endif
5209 #endif
5210 
5211 #ifdef Cgtest
5212  write(*,*) 'CalcCg Cerr r =',r,cerr
5213  write(*,*) 'CalcCg Cij_err =',r,cij_err
5214 #endif
5215 
5216  cerr2 = max(cerr,cij_err2(0:rmax))
5217  cerr = max(cerr,cij_err(0:rmax))
5218 
5219 #ifdef Cgtest
5220  write(*,*) 'CalcCg Cerr =',r,cerr,maxval(cerr)
5221 #endif
5222 ! write(*,*) 'CalcCg Cerr =',r,Cerr,maxval(Cerr)
5223 ! write(*,*) 'CalcCg areq =',acc_req_Cr*abs(C(0,0,0))
5224 ! write(*,*) 'CalcCg Cex =',maxval(Cerr-acc_req_Cr*abs(C(0,0,0)))
5225 
5226 ! do mr = 15,min(r,rmax)
5227 ! do n0=mr/2,1,-1
5228 ! do n1=0,mr-2*n0
5229 ! n2=mr-2*n0-n1
5230 ! write(*,*) 'CalcCg n5 order ',r,rg,mr,n0,n1,n2
5231 ! write(*,*) 'CalcCg n5 order C',C(n0,n1,n2)
5232 ! end do
5233 ! end do
5234 ! end do
5235 ! do mr = 15,min(r-1,rmax)
5236 ! n0=0
5237 ! do n1=0,mr
5238 ! n2=mr-n1
5239 ! write(*,*) 'CalcCg n5 order ',r,rg,mr,n0,n1,n2
5240 ! write(*,*) 'CalcCg n5 order C',C(n0,n1,n2)
5241 ! end do
5242 ! end do
5243 
5244  ! check if target precision already reached
5245 ! if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit ! changed 28.01.15
5246 #ifdef Cutrloop
5247  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
5248  do rg=r+1,rmax
5249 
5250 ! write(*,*) 'CalcCg exit rloop =',rg,r,rmax
5251 
5252  do n0=0,rg/2
5253  do n1=0,rg-2*n0
5254  c(n0,n1,rg-2*n0-n1)=0d0
5255  end do
5256  end do
5257  end do
5258  if(r.le.rmax) then
5259  do n1=0,r
5260  c(0,n1,r-n1)=0d0
5261  end do
5262  end if
5263 #else
5264  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
5265 #endif
5266 ! write(*,*) 'CalcCg exit rloop =',r,rmax,rg
5267 
5268  exit rloop
5269  end if
5270 
5271  end do rloop
5272 
5273  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
5274  do r=rmax+1,2*rmax
5275  do n0=r-rmax,r/2
5276  do n1=0,r-2*n0
5277  n2 = r-2*n0-n1
5278  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
5279  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
5280  end do
5281  end do
5282  end do
5283 
5284 ! do mr = 15,rmax
5285 ! do n0=mr/2,1,-1
5286 ! do n1=0,mr-2*n0
5287 ! n2=mr-2*n0-n1
5288 ! write(*,*) 'CalcCg n6 order ',r,rg,mr,n0,n1,n2
5289 ! write(*,*) 'CalcCg n6 order C',C(n0,n1,n2)
5290 ! end do
5291 ! end do
5292 ! end do
5293 ! do mr = 15,rmax
5294 ! n0=0
5295 ! do n1=0,mr
5296 ! n2=mr-n1
5297 ! write(*,*) 'CalcCg n6 order ',r,rg,mr,n0,n1,n2
5298 ! write(*,*) 'CalcCg n6 order C',C(n0,n1,n2)
5299 ! end do
5300 ! end do
5301 
5302 #ifdef Cgtest
5303  write(*,*) 'CalcCg final err',cerr
5304  write(*,*) 'CalcCg final acc',cerr/abs(c(0,0,0))
5305 #endif
5306 
5307 #ifdef TRACECout
5308  write(*,*) 'CalcCg rmax',rmax
5309  do r=15,rmax
5310  do n0=0,r/2
5311  do n1=0,r-2*n0
5312  write(*,*) 'CalcCg out ',r,n0,n1,r-2*n0-n1
5313  write(*,*) 'CalcCg out C',c(n0,n1,r-2*n0-n1)
5314  end do
5315  end do
5316  end do
5317 #endif
5318 
5319 ! write(*,*) 'CalcCg Cerr ',Cerr
5320 ! write(*,*) 'CalcCg Cerr2',Cerr2
5321 
5322  end subroutine calccg
5323 
5324 
5325  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5326  ! subroutine CalcCgr(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgr_min,ordgr_max,id,Cerr,acc_req_Cr,Cerr2)
5327  !
5328  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5329 
5330  subroutine calccgr(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgr_min,ordgr_max,id,Cerr,acc_req_Cr,Cerr2)
5331 
5332  use globalc
5333 
5334  integer, intent(in) :: rmax,ordgr_min,ordgr_max,id
5335  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
5336  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
5337  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
5338  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
5339  double precision, intent(in) :: acc_req_Cr(0:rmax)
5340  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
5341  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
5342  double precision :: B_err,B_max
5343  double complex :: Zadjfj,Zadj2(2,2), Zadjkl, Zadj2f(2,2,2)
5344  double complex, allocatable :: Cexpgr(:,:,:,:), CuvExpgr(:,:,:)
5345  double complex :: Smod(2), Skl, Caux
5346  double complex :: elimminf2_coli
5347  double precision, allocatable :: C00_err(:),Cij_err(:)
5348  double precision, allocatable :: C00_err2(:),Cij_err2(:)
5349  double precision :: maxZadj2f
5350  double precision :: maxCexpgr(0:1,0:2*(rmax+ordgr_min),0:ordgr_max),truncfacexp
5351  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,i,j,m,n,g,rg,lt,ltt,nn,nntt
5352  integer :: inds0(2), inds1(2), inds(2)
5353  integer :: bin,nid(0:2)
5354 
5355 #ifdef Cgrtest
5356  write(*,*) 'CalcCgr in ',rmax,ordgr_min,ordgr_max
5357  write(*,*) 'CalcCgr in, f ',f
5358 #endif
5359 #ifdef TRACECin
5360  write(*,*) 'CalcCgr in ',rmax,ordgr_min,ordgr_max
5361 #endif
5362 
5363  ! allocation of B functions
5364  rmaxb = 2*rmax + 2*ordgr_min
5365  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
5366  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
5367  allocate(b_i(0:rmaxb,0:rmaxb,2))
5368  allocate(buv_i(0:rmaxb,0:rmaxb,2))
5369 
5370  ! determine binaries for B-coefficients
5371  k=0
5372  bin = 1
5373  do while (k.le.2)
5374  if (mod(id/bin,2).eq.0) then
5375  nid(k) = id+bin
5376  k = k+1
5377  end if
5378  bin = 2*bin
5379  end do
5380 
5381  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
5382  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
5383  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
5384 
5385  ! shift of integration momentum in B_0
5386  b_max=0d0
5387  do n1=1,rmaxb
5388  do n2=0,rmaxb-n1
5389  n0 = (rmaxb-n1-n2)
5390  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
5391  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
5392  end do
5393  end do
5394  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
5395  b_err = acc_def_b*b_max
5396 
5397  ! calculate adjugated Gram matrix
5398 ! mm02 = elimminf2_coli(m02)
5399 ! mm12 = elimminf2_coli(m12)
5400 ! mm22 = elimminf2_coli(m22)
5401 ! mm32 = elimminf2_coli(m32)
5402 ! q10 = elimminf2_coli(p10)
5403 ! q21 = elimminf2_coli(p21)
5404 ! q32 = elimminf2_coli(p32)
5405 ! q30 = elimminf2_coli(p30)
5406 ! q31 = elimminf2_coli(p31)
5407 ! q20 = elimminf2_coli(p20)
5408 
5409 ! Z(1,1) = 2d0*q10
5410 ! Z(2,1) = q10+q20-q21
5411 ! Z(3,1) = q10+q30-q31
5412 ! Z(1,2) = Z(2,1)
5413 ! Z(2,2) = 2d0*q20
5414 ! Z(3,2) = q20+q30-q32
5415 ! Z(1,3) = Z(3,1)
5416 ! Z(2,3) = Z(3,2)
5417 ! Z(3,3) = 2d0*q30
5418 
5419 ! q1q2 = (q10+q20-q21)
5420 ! q1q3 = (q10+q30-q31)
5421 ! q2q3 = (q20+q30-q32)
5422 ! detZ = 8d0*q10*q30*q20+2D0*q1q2*q1q3*q2q3 &
5423 ! & -2d0*(q10*q2q3*q2q3+q20*q1q3*q1q3+q30*q1q2*q1q2)
5424 
5425 ! Zadj(1,1) = (4d0*q30*q20-q2q3*q2q3)
5426 ! Zadj(2,1) = (q1q3*q2q3-2d0*q30*q1q2)
5427 ! Zadj(3,1) = (q1q2*q2q3-2d0*q20*q1q3)
5428 ! Zadj(1,2) = Zadj(2,1)
5429 ! Zadj(2,2) = (4d0*q10*q30-q1q3*q1q3)
5430 ! Zadj(3,2) = (q1q2*q1q3-2d0*q10*q2q3)
5431 ! Zadj(1,3) = Zadj(3,1)
5432 ! Zadj(2,3) = Zadj(3,2)
5433 ! Zadj(3,3) = (4d0*q10*q20-q1q2*q1q2)
5434 !
5435 ! f(1) = q10+mm02-mm12
5436 ! f(2) = q20+mm02-mm22
5437 ! f(3) = q30+mm02-mm32
5438 
5439 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)+Zadj(3,1)*f(3)
5440 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)+Zadj(3,2)*f(3)
5441 ! Zadjf(3) = Zadj(1,3)*f(1)+Zadj(2,3)*f(2)+Zadj(3,3)*f(3)
5442 
5443 
5444  ! coefficients Shat defined in (5.13)
5445  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
5446 
5447  do r=0,rmaxb
5448  do n0=0,r/2
5449 
5450  do n1=0,r-2*n0
5451  n2 = r-2*n0-n1
5452  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
5453  end do
5454 
5455  k = r-2*n0
5456  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
5457  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
5458 
5459  end do
5460  end do
5461 
5462 
5463  ! choose reduction formulas with biggest denominators
5464  if (abs(zadjf(1)).ge.abs(zadjf(2))) then
5465  j = 1
5466  else
5467  j = 2
5468  end if
5469 
5470  zadj2f(1,2,1) = -f(2)
5471  zadj2f(1,2,2) = f(1)
5472 
5473  maxzadj2f = 0d0 ! Zadj2f(k,n,l) = Zadf2(k,n,l,m)*f(m)
5474  ! Zadj2(m) == Zadf2(k,n,l,m)
5475  ! maxZadj2f = fmax!!
5476  if (abs(zadj2f(1,2,1)).gt.maxzadj2f) then
5477  maxzadj2f = abs(zadj2f(1,2,1))
5478  k = 1
5479  n = 2
5480  l = 1
5481  m = 2
5482  zadj2(2,2) = -1d0
5483  end if
5484  if (abs(zadj2f(1,2,2)).gt.maxzadj2f) then
5485  maxzadj2f = abs(zadj2f(1,2,2))
5486  k = 1
5487  n = 2
5488  l = 2
5489  m = 1
5490  zadj2(2,1) = 1d0
5491  end if
5492 
5493 #ifdef Cgrtest
5494  write(*,*) 'CalcCgr maxZadj2f ',maxzadj2f,maxval(abs(zadj2f(:,:,:)))
5495  write(*,*) 'CalcCgr Zadj2f ',zadj2f
5496  write(*,*) 'CalcCgr Zadj2f ',zadj2f(1,2,1),zadj2f(1,2,1)
5497  write(*,*) 'CalcCgr f ',f
5498 #endif
5499 
5500  zadjfj = zadjf(j)
5501  zadjkl = zadj(k,l)
5502 
5503 #ifdef Cgrtest
5504  write(*,*) 'CalcCgr k,n,nt,l',k,n,l,m
5505  write(*,*) 'CalcCgr pars', maxzadj2f,zadj2f(k,n,l),zadj(k,l),maxzadj
5506  write(*,*) 'CalcCgr pars', abs(zadjf(l)),abs(detz)
5507  write(*,*) 'CalcCgr pars', abs(zadjf(l)/ maxzadj2f),abs(detz/maxzadj2f)
5508 #endif
5509 
5510  zadjfj = zadjf(j)
5511  zadjkl = zadj(k,l)
5512 
5513  ! allocation of array for expanded C-coefficients
5514  rmaxexp = rmaxb
5515  allocate(cexpgr(0:rmaxexp/2,0:rmaxexp,0:rmaxexp,0:ordgr_max))
5516 
5517  ! calculate Cuv
5518  allocate(cuvexpgr(0:(rmaxexp+1),0:rmaxexp+1,0:rmaxexp+1))
5519  call calccuv(cuvexpgr,buv_0,mm02,f,rmaxexp+1,id)
5520  cuv(0:rmax,0:rmax,0:rmax) = cuvexpgr(0:rmax,0:rmax,0:rmax)
5521 
5522  ! allocate arrays for error propagation
5523  allocate(c00_err(0:rmaxexp))
5524  allocate(cij_err(0:rmaxexp))
5525  allocate(c00_err2(0:rmaxexp))
5526  allocate(cij_err2(0:rmaxexp))
5527 
5528  ! initialize accuracy estimates
5529  cerr = acc_inf
5530  cij_err =0d0
5531  c00_err =0d0
5532 
5533  cerr2 = acc_inf
5534  cij_err2 =0d0
5535  c00_err2 =0d0
5536 
5537 ! maxZadj = maxval(abs(Zadj))
5538 ! maxZadj2f = maxval(abs(f(inds2(1,:))*Zadj2(:)))
5539 
5540  ! truncation of expansion if calculated term larger than truncfacexp * previous term
5541  ! crucial for expansion parameters between 0.1 and 1 !!!
5542  truncfacexp = sqrt(fac_gr) * truncfacc
5543  gtrunc = ordgr_max
5544 
5545 ! calculate C(n0,n1,n2) up to rank r+n0
5546  rloop: do r=0,rmaxexp/2
5547 
5548 #ifdef Cgrtest
5549 ! write(*,*) 'CalcCgr rloop',r,rmax,gtrunc
5550 #endif
5551 
5552  if (r.gt.rmax+gtrunc) exit rloop
5553 
5554 #ifdef Cgrtest
5555  write(*,*) 'CalcCgr rloop',r,rmaxexp,rmaxb
5556 #endif
5557 
5558  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
5559  ! 0th-order coefficients
5560  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
5561 
5562  ! calculating
5563  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
5564  ! exploiting eq. (5.40) - (5.53) solved for C_00i1..<ir>...iP
5565  maxcexpgr(1,r,0)=0d0
5566  do n0=r,1,-1
5567  do nn=r-n0,0,-1
5568  nntt = r-n0-nn
5569 
5570 #ifdef Cgrtest
5571  write(*,*) 'CalcCgr rloop',n0,nn,zadj2f(k,n,l)
5572 #endif
5573 
5574  inds0(n) = nn
5575  inds0(k) = nntt
5576 
5577 #ifdef Cgrtest
5578  write(*,*) 'CalcCgr inds0',n0,inds0
5579 #endif
5580 
5581  inds1(n) = nn+1
5582  inds1(k) = nntt
5583 
5584 #ifdef Cgrtest
5585  write(*,*) 'CalcCgr inds1',n0,inds1
5586 #endif
5587 
5588  caux = -zadj(k,l)*b_0(n0-1,inds1(1),inds1(2))
5589 
5590 ! Caux = 2*Zadj(k,l) * (1+r-2*n0) * Cexpgr(n0,inds1(1),inds1(2),0)
5591 
5592 ! inds = inds1
5593 ! inds(k) = inds(k) + 1
5594 ! inds(l) = inds(l) + 1
5595 ! Caux = Caux + detZ * Cexpgr(n0-1,inds(1),inds(2),0)
5596 !
5597 ! inds = inds1
5598 ! inds(k) = inds(k) + 1
5599 ! Caux = Caux + Zadjf(l) * Cexpgr(n0-1,inds(1),inds(2),0)
5600 
5601 #ifdef Cgrtest
5602  write(*,*) 'CalcCgr Caux 1c',-zadj(k,l)*b_0(n0-1,inds1(1),inds1(2))
5603  write(*,*) 'CalcCgr Caux 1s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5604 #endif
5605 
5606  inds = inds1
5607  inds(k) = inds(k)+1
5608  do i=1,2
5609  caux = caux - zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
5610 #ifdef Cgrtest
5611  write(*,*) 'CalcCgr Caux 2ci', -zadj(i,l)*shat(n0-1,inds(1),inds(2),i)
5612 #endif
5613  end do
5614 
5615 #ifdef Cgrtest
5616  write(*,*) 'CalcCgr Caux 2s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5617 #endif
5618 
5619  do i=1,2
5620  inds = inds1
5621  inds(i) = inds(i)+1
5622  caux = caux + zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
5623 #ifdef Cgrtest
5624  write(*,*) 'CalcCgr Caux 3ci',zadj(k,l)*shat(n0-1,inds(1),inds(2),i)
5625 #endif
5626  end do
5627 
5628 
5629 #ifdef Cgrtest
5630  write(*,*) 'CalcCgr Caux 3s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5631 #endif
5632 
5633  caux = caux + 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),m)
5634 
5635 
5636 #ifdef Cgrtest
5637  write(*,*) 'CalcCgr Caux 4ca', 2*(nn+1) *zadj2(n ,m )*shat(n0,inds0(1),inds0(2),m)
5638  write(*,*) 'CalcCgr Caux 4s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5639 #endif
5640 
5641 ! Caux = Caux - 2*(nn+1)* Zadj2f(k,n,l)*Cexpgr(n0,inds0(1),inds0(2),0)
5642 
5643  inds = inds1
5644  if(m.eq.n) then
5645  if (inds(n).gt.1) then
5646  inds(n) = inds(n)-2
5647  caux = caux - 4*(nn+1)*nn * zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),0)
5648 #ifdef Cgrtest
5649  write(*,*) 'CalcCgr Caux 6c',4*(nn+1)*nn* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),0)
5650  write(*,*) 'CalcCgr Caux 6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5651 #endif
5652  end if
5653  else
5654  if (inds(n).gt.0.and.inds(m).gt.0) then
5655  inds(n) = inds(n)-1
5656  inds(m) = inds(m)-1
5657  caux = caux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),0)
5658 #ifdef Cgrtest
5659  write(*,*) 'CalcCgr Caux 6c',-4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),0)
5660  write(*,*) 'CalcCgr Caux 6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5661 #endif
5662  end if
5663  end if
5664 
5665  cexpgr(n0,inds0(1),inds0(2),0) = caux/(2*(nn+1)* zadj2f(k,n,l))
5666 
5667  if (n0.eq.1) then
5668  maxcexpgr(1,r,0) = maxcexpgr(1,r,0) + abs(cexpgr(n0,inds0(1),inds0(2),0) )
5669  end if
5670 
5671 ! if (r+n0.le.rmax) then ! for fixed rank
5672  if (r.le.rmax) then
5673  c(n0,inds0(1),inds0(2)) = cexpgr(n0,inds0(1),inds0(2),0)
5674  end if
5675 
5676  end do
5677  end do
5678 
5679  ! calculate
5680  ! C_00ijkl.. --> C_aijkl..
5681  ! exploiting eq. (5.38)
5682  maxcexpgr(0,r,0)=0d0
5683  do n1=0,r
5684  n2 = r-n1
5685 
5686  smod = shat(0,n1,n2,:)
5687  if (n1.ge.1) then
5688  smod(1) = smod(1) - 2d0*n1*cexpgr(1,n1-1,n2,0)
5689  end if
5690  if (n2.ge.1) then
5691  smod(2) = smod(2) - 2d0*n2*cexpgr(1,n1,n2-1,0)
5692  end if
5693 
5694  cexpgr(0,n1,n2,0) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
5695  )/zadjfj
5696  maxcexpgr(0,r,0) = maxcexpgr(0,r,0) + abs(cexpgr(0,n1,n2,0))
5697  if (r.le.rmax) then
5698  c(0,n1,n2) = cexpgr(0,n1,n2,0)
5699  end if
5700 
5701 
5702 #ifdef Cgrtest
5703  if(r.le.rmax) then
5704  write(*,*) 'CalcCgr C(0,n1,n2,0)=',n1,n2,c(0,n1,n2)
5705  end if
5706 
5707  if(n0.eq.0.and.n1.eq.0.and.n2.eq.3) then
5708  write(*,*) 'C(0,0,3)= ',0,c(n0,n1,n2)
5709  end if
5710 #endif
5711 
5712  end do
5713 
5714 #ifdef Cgrtest
5715 ! write(*,*) 'CalcCgr maxCexpgr 0',r-1, maxCexpgr(0,r-1,0)
5716 #endif
5717 
5718  if(r.le.rmax) then
5719 ! Cerr(r) = abs(detZ/Zadjfj)*maxCexpgr(0,r,0)
5720  cerr(r) = fac_gr*maxcexpgr(0,r,0)
5721  end if
5722 
5723  ! error propagation from C's
5724  if(r.gt.0)then
5725  c00_err(r+1) = maxzadj*b_err/(2*maxzadj2f)
5726  end if
5727  cij_err(r)=maxzadj*max(b_err,2*c00_err(r+1))/abs(zadjfj)
5728 
5729  if(r.gt.0)then
5730  c00_err2(r+1) = maxzadj*b_err/(2*maxzadj2f)
5731  end if
5732  cij_err2(r)=maxzadj*max(b_err,2*c00_err2(r+1))/abs(zadjfj)
5733 
5734  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5735  ! higher order coefficients
5736  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5737 
5738  rg = r
5739  gloop: do g=1,min(gtrunc,r)
5740  rg = rg-1
5741 
5742 #ifdef Cgrtest
5743  write(*,*) 'CalcCgr: gloop ',r,rg,g
5744 #endif
5745 
5746  ! calculating
5747  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
5748  ! exploiting eq. (5.40) - (5.53) solved for C_00i1..<ir>...iP
5749  maxcexpgr(1,rg,g) = 0d0
5750  do n0=rg,1,-1 ! note rank of tensor = rg+n0
5751  do nn=rg-n0,0,-1
5752  nntt = rg-n0-nn
5753  inds0(n) = nn
5754  inds0(k) = nntt
5755 
5756  inds1(n) = nn+1
5757  inds1(k) = nntt
5758 
5759 #ifdef Cgrtest
5760  write(*,*) 'CalcCgr Caux r inds=',n0,inds0
5761 #endif
5762 
5763  caux = 2*zadj(k,l) * (2+rg-n0) * cexpgr(n0,inds1(1),inds1(2),g-1)
5764 
5765 #ifdef Cgrtest
5766  write(*,*) 'CalcCgr Caux r1c',2*zadj(k,l)*(2+rg-n0)* cexpgr(n0,inds1(1),inds1(2),g-1)
5767  write(*,*) 'CalcCgr Caux r1c',2*zadj(k,l)*(2+rg-n0),cexpgr(n0,inds1(1),inds1(2),g-1) &
5768  ,n0,inds1(1),inds1(2)
5769  write(*,*) 'CalcCgr Caux r1s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5770 #endif
5771 
5772  if (g.gt.1) then
5773  inds = inds1
5774  inds(k) = inds(k) + 1
5775  inds(l) = inds(l) + 1
5776  caux = caux + detz * cexpgr(n0-1,inds(1),inds(2),g-2)
5777 
5778 #ifdef Cgrtest
5779  write(*,*) 'CalcCgr Caux r2c',detz * cexpgr(n0-1,inds(1),inds(2),g-2)
5780  write(*,*) 'CalcCgr Caux r2s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5781 #endif
5782  end if
5783 
5784  inds = inds1
5785  inds(k) = inds(k) + 1
5786  caux = caux + zadjf(l) * cexpgr(n0-1,inds(1),inds(2),g-1)
5787 
5788 #ifdef Cgrtest
5789  write(*,*) 'CalcCgr Caux r3c',zadjf(l)* cexpgr(n0-1,inds(1),inds(2),g-1)
5790  write(*,*) 'CalcCgr Caux r3c',zadjf(l),cexpgr(n0-1,inds(1),inds(2),g-1),n0-1,inds(1),inds(2)
5791  write(*,*) 'CalcCgr Caux r3s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5792 #endif
5793 
5794 ! Caux = Caux - 2*nn* Zadj2f(k,n,l)*Cexpgr(n0,inds0(1),inds0(2),g)
5795 
5796  inds = inds1
5797  if(m.eq.n) then
5798  if (inds(n).gt.1) then
5799  inds(n) = inds(n)-2
5800  caux = caux - 4*(nn+1)*nn * zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),g)
5801 #ifdef Cgrtest
5802  write(*,*) 'CalcCgr Caux r6c',4*(nn+1)*nn* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),g)
5803  write(*,*) 'CalcCgr Caux r6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5804 #endif
5805  end if
5806  else
5807  if (inds(n).gt.0.and.inds(m).gt.0) then
5808  inds(n) = inds(n)-1
5809  inds(m) = inds(m)-1
5810  caux = caux - 4*(nn+1)*(inds(m)+1)* zadj2(n,m ) * cexpgr(n0+1,inds(1),inds(2),g)
5811 #ifdef Cgrtest
5812  write(*,*) 'CalcCgr Caux r6c',4*(nn+1)*(inds(m)+1)* zadj2(n,m ) *cexpgr(n0+1,inds(1),inds(2),g)
5813  write(*,*) 'CalcCgr Caux r6c',n,m,nn,4*(nn+1)*(inds(m)+1),zadj2(n,m ),cexpgr(n0+1,inds(1),inds(2),g)
5814  write(*,*) 'CalcCgr Caux r6s',caux,caux/(2*(nn+1)* zadj2f(k,n,l))
5815 #endif
5816  end if
5817  end if
5818 
5819 
5820  cexpgr(n0,inds0(1),inds0(2),g) = caux/(2*(nn+1)* zadj2f(k,n,l))
5821 
5822  if(n0.eq.1) then
5823  maxcexpgr(1,rg,g) = maxcexpgr(1,rg,g) + abs(cexpgr(n0,inds0(1),inds0(2),g))
5824 
5825  if (g.eq.1.and.abs(cexpgr(n0,inds0(1),inds0(2),g)).gt. &
5826  truncfacexp*max(1d0,maxcexpgr(1,rg,g-1)) .or. &
5827  g.ge.2.and.abs(cexpgr(n0,inds0(1),inds0(2),g)).gt. &
5828  truncfacexp*maxcexpgr(1,rg,g-1)) then
5829 
5830 #ifdef Cgrtest
5831  write(*,*) 'CalcCgr exit gloop',n0,inds0(1),inds0(2),g,rg, &
5832  abs(cexpgr(n0,inds0(1),inds0(2),g)),maxcexpgr(1,rg,g-1),truncfacexp
5833 #endif
5834 
5835  gtrunc = g-1
5836  exit gloop
5837  end if
5838  end if
5839 
5840  end do
5841  end do
5842 
5843 #ifndef PPEXP00
5844  if (rg.le.rmax) then
5845  do n0=rg,1,-1
5846 ! if (rg+n0.le.rmax) then ! for fixed rank
5847  if (rg.le.rmax) then
5848  do n1=0,rg-n0
5849  n2=rg-n0-n1
5850  c(n0,n1,n2) = c(n0,n1,n2) + cexpgr(n0,n1,n2,g)
5851  end do
5852  end if
5853  end do
5854  end if
5855 #endif
5856 ! write(*,*) 'CalcCgr after it1 ',rg
5857 
5858  ! calculate
5859  ! C_00ijkl.. --> C_aijkl..
5860  ! exploiting eq. (5.38)
5861 
5862 ! write(*,*) 'CalcCgr maxCexp',rg,g-1,maxCexpgr(0,rg,g-1)
5863 
5864  maxcexpgr(0,rg,g) = 0d0
5865  do n1=0,rg
5866  n2 = rg-n1
5867 
5868  smod = 0d0
5869  if (n1.ge.1) then
5870  smod(1) = smod(1) - 2d0*n1*cexpgr(1,n1-1,n2,g)
5871  end if
5872  if (n2.ge.1) then
5873  smod(2) = smod(2) - 2d0*n2*cexpgr(1,n1,n2-1,g)
5874  end if
5875 
5876  inds(1) = n1
5877  inds(2) = n2
5878  inds(j) = inds(j)+1
5879  cexpgr(0,n1,n2,g) = (zadj(1,j)*smod(1) + zadj(2,j)*smod(2) &
5880  - detz*cexpgr(0,inds(1),inds(2),g-1))/zadjfj
5881 
5882  maxcexpgr(0,rg,g) = maxcexpgr(0,rg,g) + abs(cexpgr(0,n1,n2,g))
5883 
5884 ! if(n1.eq.0.and.n2.eq.1) then
5885 ! write(*,*) 'C2(2,3)= ',g,Cexpgr(0,n1,n2,g)
5886 ! write(*,*) 'C2(2,3)= ',Zadj(1,j)*Smod(1)/Zadjfj, Zadj(2,j)*Smod(2)/Zadjfj, &
5887 ! - detZ*Cexpgr(0,inds(1),inds(2),g-1)/Zadjfj
5888 ! write(*,*) 'C2(2,3)= ',inds(1),inds(2), &
5889 ! - detZ/Zadjfj,Cexpgr(0,inds(1),inds(2),g-1)
5890 ! end if
5891 
5892  if (g.eq.1.and.abs(cexpgr(0,n1,n2,g)).gt. &
5893  truncfacexp*max(1d0/m2scale,maxcexpgr(0,rg,g-1)).or. &
5894  g.ge.2.and.abs(cexpgr(0,n1,n2,g)).gt. &
5895  truncfacexp*maxcexpgr(0,rg,g-1)) then
5896 
5897 #ifdef Cgrtest
5898  write(*,*) 'CalcCgr exit gloop',0,n1,n2,g,abs(cexpgr(0,n1,n2,g)),maxcexpgr(0,rg,g-1),truncfacexp
5899 #endif
5900  gtrunc = g-1
5901  exit gloop
5902  end if
5903 
5904  end do
5905 
5906  ! error propagation from C's
5907  if(rg.gt.0)then
5908  c00_err(rg+1) = max( c00_err(rg+1), &
5909  max( maxzadj*(2+rg-2*n0)*c00_err(rg+2), &
5910  abs(detz)*cij_err(rg+2), &
5911  maxzadjf*cij_err(rg+1) &
5912  ) / (2*maxzadj2f) )
5913  end if
5914  cij_err(rg)=max(cij_err(rg), &
5915  max(2*maxzadj*c00_err(rg+1),abs(detz)*cij_err(rg))/abs(zadjfj) )
5916 
5917  if(rg.gt.0)then
5918  c00_err2(rg+1) = max( c00_err2(rg+1), &
5919  max( maxzadj*(2+rg-2*n0)*c00_err2(rg+2), &
5920  abs(detz)*cij_err2(rg+2), &
5921  maxzadjf*cij_err2(rg+1) &
5922  ) / (2*maxzadj2f) )
5923  end if
5924  cij_err2(rg)=max(cij_err2(rg), &
5925  max(2*maxzadj*c00_err2(rg+1),abs(detz)*cij_err2(rg))/abs(zadjfj) )
5926 
5927 #ifdef PPEXP00
5928  if (rg.le.rmax) then
5929  do n0=rg,1,-1
5930 ! if (rg+n0.le.rmax) then ! for fixed rank
5931  if (rg.le.rmax) then
5932  do n1=0,rg-n0
5933  n2=rg-n0-n1
5934  c(n0,n1,n2) = c(n0,n1,n2) + cexpgr(n0,n1,n2,g)
5935  end do
5936  end if
5937  end do
5938  end if
5939 #endif
5940 
5941  if (rg.le.rmax) then
5942  cerr(rg) = 0d0
5943  do n1=0,rg
5944  n2 = rg-n1
5945  c(0,n1,n2) = c(0,n1,n2) + cexpgr(0,n1,n2,g)
5946  if(abs(cexpgr(0,n1,n2,g-1)).ne.0d0) then
5947 ! Cerr(rg)=max(Cerr(rg),abs(Cexpgr(0,n1,n2,g))**2/abs(Cexpgr(0,n1,n2,g-1)))
5948  cerr(rg)=max(cerr(rg),abs(cexpgr(0,n1,n2,g))*min(1d0,abs(cexpgr(0,n1,n2,g))/abs(cexpgr(0,n1,n2,g-1))))
5949  else
5950  cerr(rg)=max(cerr(rg),abs(cexpgr(0,n1,n2,g)))
5951  end if
5952 
5953 #ifdef Cgrtest
5954  write(*,*) 'CalcCgr Cerr calc',rg,cerr(rg),n1,n2,abs(cexpgr(0,n1,n2,g)),abs(cexpgr(0,n1,n2,g-1))
5955 #endif
5956 
5957  end do
5958 
5959  ! if error from B's larger than error from expansion stop expansion
5960  if(cij_err(rg).gt.3d0*cerr(rg)) then
5961  gtrunc = min(g,gtrunc)
5962 
5963 #ifdef Cgrtest
5964  write(*,*) 'CalcCgr exit err',r,rg,g,gtrunc,cij_err(rg),cerr(rg)
5965 #endif
5966 
5967  end if
5968 
5969  end if
5970 
5971  end do gloop
5972 
5973 #ifdef Cgrtest
5974  write(*,*) 'CalcCgr C(0,0,0) = ',r,c(0,0,0)
5975  if(r.ge.1)then
5976  write(*,*) 'CalcCgr C(1,0,0) = ',r,c(1,0,0)
5977  write(*,*) 'CalcCgr C(0,1,0) = ',r,c(0,1,0)
5978  write(*,*) 'CalcCgr C(0,0,1) = ',r,c(0,0,1)
5979  write(*,*) 'CalcCgr C(0,0,0) = ',r,c(0,0,0)
5980  end if
5981  if(r.ge.2.and.rmax.ge.2)then
5982  write(*,*) 'CalcCgr C(1,1,0) = ',r,c(1,1,0)
5983  write(*,*) 'CalcCgr C(1,0,1) = ',r,c(1,0,1)
5984  write(*,*) 'CalcCgr C(1,0,0) = ',r,c(1,0,0)
5985 ! write(*,*) 'CalcCgr C(0,2,0) = ',r,C(0,2,0)
5986 ! write(*,*) 'CalcCgr C(0,1,1) = ',r,C(0,1,1)
5987  write(*,*) 'CalcCgr C(0,0,2) = ',r,c(0,0,2)
5988  end if
5989  if(r.ge.3.and.rmax.ge.2)then
5990 ! write(*,*) 'CalcCgr C(3,0,0) = ',r,C(3,0,0)
5991 ! write(*,*) 'CalcCgr C(2,0,1) = ',r,C(2,0,1)
5992  write(*,*) 'CalcCgr C(1,0,2) = ',r,c(1,0,2)
5993  write(*,*) 'CalcCgr C(0,3,0) = ',r,c(0,3,0)
5994  write(*,*) 'CalcCgr C(0,2,1) = ',r,c(0,2,1)
5995  write(*,*) 'CalcCgr C(0,0,3) = ',r,c(0,0,3)
5996  write(*,*) 'CalcCgr C(0,1,1) = ',r,c(0,1,1)
5997  write(*,*) 'CalcCgr C(0,0,2) = ',r,c(0,0,2)
5998  end if
5999  write(*,*) 'CalcCgr Cij_err',r,cij_err
6000  write(*,*) 'CalcCgr Cij_acc',r,cij_err/abs(c(0,0,0))
6001 
6002  write(*,*) 'CalcCgr err',r,cerr
6003  write(*,*) 'CalcCgr acc',r,cerr/abs(c(0,0,0))
6004 #endif
6005 
6006  cerr2 = max(cerr,cij_err2(0:rmax))
6007  cerr = max(cerr,cij_err(0:rmax))
6008 
6009 #ifdef Cgrtest
6010 ! write(*,*) 'CalcCgr exit r',r,maxval(Cerr),acc_req_C*abs(C(0,0,0))
6011 #endif
6012 
6013 ! if(maxval(Cerr).le.acc_req_C*abs(C(0,0,0))) exit changed 28.01.15
6014  ! check if target precision already reached
6015 #ifdef Cutrloop
6016  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
6017  do rg=r+1,rmax
6018  do n0=0,rg/2
6019  do n1=0,rg-n0
6020  c(n0,n1,rg-n0-n1)=0d0
6021  end do
6022  end do
6023  end do
6024 #else
6025  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
6026 #endif
6027  exit rloop
6028  end if
6029 
6030  end do rloop
6031 
6032 #ifdef Cgrtest
6033 ! write(*,*) 'CalcCgr C(0,0,0) = ',C(0,0,0)
6034 ! if(rmax.ge.3)then
6035 ! write(*,*) 'CalcCgr C(0,1,1,1) = ',C(0,1,1,1)
6036 ! end if
6037 
6038  write(*,*) 'CalcCgr final err',cerr
6039  write(*,*) 'CalcCgr final acc',cerr /abs(c(0,0,0))
6040 #endif
6041 
6042 ! write(*,*) 'CalcCgr out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
6043 #ifdef TRACECout
6044  write(*,*) 'CalcCgr rmax',rmax
6045  do r=14,rmax
6046  do n0=0,r/2
6047  do n1=0,r-2*n0
6048  write(*,*) 'CalcCgr out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
6049  end do
6050  end do
6051  end do
6052 #endif
6053 
6054 ! write(*,*) 'CalcCgr Cerr ',Cerr
6055 ! write(*,*) 'CalcCgr Cerr2',Cerr2
6056 
6057  end subroutine calccgr
6058 
6059 
6060 
6061 
6062  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6063  ! subroutine CalcCgy(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
6064  !
6065  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6066 
6067  ! modified version of Ansgar (similar to CalcDgy)
6068 
6069  subroutine calccgy(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
6070 
6071  use globalc
6072 
6073  integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
6074  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
6075  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
6076  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
6077  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
6078  double precision, intent(in) :: acc_req_Cr(0:rmax)
6079  double complex, allocatable :: Cexpgy(:,:,:,:), CuvExpgy(:,:,:)
6080  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
6081  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
6082  double complex :: Smod, Caux, Zadj2f
6083  double complex :: C0_coli, elimminf2_coli
6084  double precision, allocatable :: C00_err(:),Cij_err(:)
6085  double precision, allocatable :: C00_err2(:),Cij_err2(:)
6086  double precision :: B_err,B_max,aZadj2f
6087  double precision :: maxCexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp
6088  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,i,j,jt,g,rg
6089  integer :: inds0(2),inds(2),k,l,lt,nl,nlt
6090  integer :: bin,nid(0:2)
6091 
6092 #ifdef Cgytest
6093  write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
6094  write(*,*) 'CalcCgy in ',p10,p21,p20,m02,m12,m22
6095 #endif
6096 #ifdef TRACECin
6097  write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
6098 #endif
6099 
6100  ! write(*,*) 'LH: CalcCgy, ord', ordgy_min
6101  ! calculation of B-coefficients
6102  rmaxb = rmax + 2*ordgy_min + 1
6103  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
6104  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
6105  allocate(b_i(0:rmaxb,0:rmaxb,2))
6106  allocate(buv_i(0:rmaxb,0:rmaxb,2))
6107 
6108  ! determine binaries for B-coefficients
6109  k=0
6110  bin = 1
6111  do while (k.le.2)
6112  if (mod(id/bin,2).eq.0) then
6113  nid(k) = id+bin
6114  k = k+1
6115  end if
6116  bin = 2*bin
6117  end do
6118 
6119  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
6120  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
6121  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
6122 
6123  ! shift of integration momentum in B_0
6124  b_max=0d0
6125  do n1=1,rmaxb
6126  do n2=0,rmaxb-n1
6127  n0 = (rmaxb-n1-n2)
6128  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
6129  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
6130  end do
6131  end do
6132  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
6133  b_err = acc_def_b*b_max
6134 
6135  ! determine (adjugated) Gram and Cayley matrix
6136 ! mm02 = elimminf2_coli(m02)
6137 ! mm12 = elimminf2_coli(m12)
6138 ! mm22 = elimminf2_coli(m22)
6139 ! q10 = elimminf2_coli(p10)
6140 ! q21 = elimminf2_coli(p21)
6141 ! q20 = elimminf2_coli(p20)
6142 !
6143 ! q1q2 = (q10+q20-q21)
6144 ! detZ = 4d0*q10*q20-q1q2*q1q2
6145 
6146  if (abs(detz).lt.abs(4d0*q10*q20 + z(2,1)*z(2,1))*1d-4) then
6147  if (abs(q10-q20).lt.abs(q10-q21).and. &
6148  abs(q10-q20).lt.abs(q20-q21)) then
6149  detz = 4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
6150  end if
6151  end if
6152 
6153 ! Zadj(1,1) = 2d0*q20
6154 ! Zadj(2,1) = -q1q2
6155 ! Zadj(1,2) = -q1q2
6156 ! Zadj(2,2) = 2d0*q10
6157 ! f(1) = q10+mm02-mm12
6158 ! f(2) = q20+mm02-mm22
6159 !
6160 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
6161 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
6162 !
6163 ! Xadj(1,1) and Xadj(2,2) exchanged!!!
6164 ! Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
6165 ! Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
6166 ! Xadj(1,2) = Xadj(2,1)
6167 ! Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
6168 
6169 
6170  ! coefficients Shat defined in (5.13)
6171  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
6172 
6173  do r=0,rmaxb
6174  do n0=0,r/2
6175 
6176  do n1=0,r-2*n0
6177  n2 = r-2*n0-n1
6178  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
6179  end do
6180 
6181  k = r-2*n0
6182  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
6183  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
6184 
6185  end do
6186  end do
6187 
6188  ! choose reduction formulas with biggest denominators
6189  if (abs(xadj(1,1)).ge.abs(xadj(2,2))) then
6190  if (abs(xadj(1,1)).ge.abs(xadj(1,2))) then
6191  i = 1
6192  j = 1
6193  jt = 2
6194  zadj2f = -f(2)
6195  else
6196  i = 1
6197  j = 2
6198  jt = 1
6199  zadj2f = f(2)
6200  end if
6201  else
6202  if (abs(xadj(2,2)).ge.abs(xadj(1,2))) then
6203  i = 2
6204  j = 2
6205  jt = 1
6206  zadj2f = -f(1)
6207  else
6208  i = 1
6209  j = 2
6210  jt = 2
6211  zadj2f = -f(2)
6212  end if
6213  end if
6214  azadj2f = abs(zadj2f)
6215 
6216  if (abs(zadj(1,1)).ge.abs(zadj(2,2))) then
6217  if (abs(zadj(1,1)).ge.abs(zadj(1,2))) then
6218  k = 1
6219  l = 1
6220  lt = 2
6221  else
6222  k = 1
6223  l = 2
6224  lt = 1
6225  end if
6226  else
6227  if (abs(zadj(2,2)).ge.abs(zadj(1,2))) then
6228  k = 2
6229  l = 2
6230  lt = 1
6231  else
6232  k = 1
6233  l = 2
6234  lt = 1
6235  end if
6236  end if
6237 
6238 #ifdef Cgytest
6239  write(*,*) 'CalcCgy: Zadj',k,l,zadj(k,l)
6240  write(*,*) 'CalcCgy: Xadj',i,j,xadj(i,j)
6241  write(*,*) 'CalcCgy: Zadjf',j,zadjf(j),maxzadjf
6242 #endif
6243 
6244 ! write(*,*) 'CalcCgy Zadj(i,j)=',i,j,Zadj(i,j),Xadj(i,j)
6245 
6246  ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
6247  rmaxexp = rmaxb+1
6248  allocate(cexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
6249 
6250  ! calculate Cuv
6251  allocate(cuvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp))
6252  call calccuv(cuvexpgy,buv_0,mm02,f,rmaxexp,id)
6253  cuv(0:rmax,0:rmax,0:rmax) = cuvexpgy(0:rmax,0:rmax,0:rmax)
6254 
6255  ! allocate arrays for error propagation
6256  allocate(c00_err(0:rmaxexp))
6257  allocate(cij_err(0:rmaxexp))
6258  allocate(c00_err2(0:rmaxexp))
6259  allocate(cij_err2(0:rmaxexp))
6260 
6261  ! initialize accuracy estimates
6262  cerr = acc_inf
6263  cij_err =0d0
6264  c00_err =0d0
6265 
6266  cerr2 = acc_inf
6267  cij_err2 =0d0
6268  c00_err2 =0d0
6269 
6270 ! maxZadjf = maxval(abs(Zadjf))
6271 ! fmax = maxval(abs(f))
6272 
6273  ! truncation of expansion if calculated term larger than truncfacexp * previous term
6274  ! crucial for expansion parameters between 0.1 and 1 !!!
6275 ! truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(i,j))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
6276  truncfacexp = sqrt(fac_gy) * truncfacc
6277  gtrunc = ordgy_max
6278 
6279 #ifdef Cgytest
6280  write(*,*) 'CalcCgy gtrunc orig=',gtrunc
6281  write(*,*) 'CalcCgy rmaxExp-2=',rmaxexp-2
6282 #endif
6283 
6284 ! calculate C(1,n1,n2) up to rank r+2
6285 ! calculate C(0,n1,n2) up to rank r
6286  rloop: do r=0,rmaxexp-2
6287 
6288 #ifdef Cgytest
6289  write(*,*) 'CalcCgy rloop=',r,rmaxexp-2,rmax+2*gtrunc+2
6290  write(*,*) 'CalcCgy rloop=',rmax,gtrunc
6291 #endif
6292 
6293  if (r.gt.rmax+2*gtrunc+2) exit rloop
6294 
6295  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6296  ! 0th-order coefficients
6297  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6298 
6299  ! calculating C_00ijk.. exploiting eq. (5.49)
6300  maxcexpgy(1,r,0)=0d0
6301  do nl=r,0,-1
6302  nlt=r-nl
6303  inds0(l) = nl
6304  inds0(lt) = nlt
6305 
6306  inds(l) = nl+1
6307  inds(lt) = nlt
6308  caux = zadj(k,1)*shat(0,inds(1),inds(2),1) &
6309  + zadj(k,2)*shat(0,inds(1),inds(2),2)
6310 
6311  if (nlt.ge.1) then
6312  inds(lt) = nlt-1
6313  caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),0)
6314  end if
6315 
6316  cexpgy(1,inds0(1),inds0(2),0) = caux/(2*(nl+1)*zadj(k,l))
6317  maxcexpgy(1,r,0) = maxcexpgy(1,r,0) + abs(cexpgy(1,inds0(1),inds0(2),0) )
6318 ! if (r+2.le.rmax) then ! for fixed rank
6319  if (r+1.le.rmax) then
6320  c(1,inds0(1),inds0(2)) = cexpgy(1,inds0(1),inds0(2),0)
6321  end if
6322 
6323  end do
6324 
6325  ! calculate C_ijkl.. exploiting eq. (5.53)
6326  maxcexpgy(0,r,0)=0d0
6327  do n1=0,r
6328  n2 = r-n1
6329  inds(1) = n1
6330  inds(2) = n2
6331 
6332  caux = (2*(2+r)*cexpgy(1,n1,n2,0) - 4*cuvexpgy(1,n1,n2) &
6333  - b_0(0,n1,n2))*zadj(i,j)
6334 
6335 ! write(*,*) 'CalcCred Caux',Caux,Zadj(i,j),f(i),f(j)
6336 
6337  smod = shat(0,n1,n2,jt)
6338 
6339  if (inds(jt).ge.1) then
6340  inds(jt) = inds(jt)-1
6341  smod = smod - 2d0*(inds(jt)+1)*cexpgy(1,inds(1),inds(2),0)
6342  end if
6343 
6344  caux = caux + zadj2f*smod
6345 
6346 ! write(*,*) 'CalcCgy maxadjf',maxZadjf,Xadj(i,j),Caux
6347 
6348  cexpgy(0,n1,n2,0) = caux/xadj(i,j)
6349  maxcexpgy(0,r,0) = maxcexpgy(0,r,0) + abs(cexpgy(0,n1,n2,0))
6350  if (r.le.rmax) then
6351  c(0,n1,n2) = cexpgy(0,n1,n2,0)
6352  end if
6353 
6354  end do
6355 
6356  if (r.le.rmax) then
6357 ! Cerr(r) = abs(maxZadjf/Xadj(i,j))*maxCexpgy(0,r,0)
6358  cerr(r) = fac_gy*maxcexpgy(0,r,0)
6359 
6360 ! write(*,*) 'CalcCgy Cerr,0 ',r,Cerr(r),fac_gy,maxCexpgy(0,r,0)
6361 
6362  end if
6363 
6364  ! error propagation from B's
6365  c00_err(r+2) = b_err /2d0
6366  cij_err(r)=max(abs(zadj(i,j))/abs(xadj(i,j))*max(b_err,2*(r+2)*c00_err(r+2)), &
6367  fmax/abs(xadj(i,j))*max(b_err,2*c00_err(r+1)))
6368 
6369  c00_err2(r+2) = b_err /2d0
6370  cij_err2(r)=max(abs(zadj(i,j))/abs(xadj(i,j))*max(b_err,2*(r+2)*c00_err2(r+2)), &
6371  fmax/abs(xadj(i,j))*max(b_err,2*c00_err2(r+1)))
6372 
6373 
6374  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6375  ! higher order coefficients
6376  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6377 
6378  rg = r
6379  gloop: do g=1,min(gtrunc,r/2)
6380  rg = rg-2
6381 
6382 ! write(*,*) 'CalcCgy gtrunc gloop=',gtrunc,r,g,rg
6383 
6384  ! calculating C_00ijk.. exploiting eq. (5.49)
6385  maxcexpgy(1,rg,g) = 0d0
6386  do nl=rg,0,-1
6387  nlt=rg-nl
6388  inds0(l) = nl
6389  inds0(lt) = nlt
6390 
6391  inds(l) = nl+1
6392  inds(lt) = nlt
6393  caux = -zadjf(k)*cexpgy(0,inds(1),inds(2),g-1)
6394 
6395  inds(k) = inds(k)+1
6396  caux = caux - detz*cexpgy(0,inds(1),inds(2),g-1)
6397 
6398  if (nlt.ge.1) then
6399  inds(l) = nl+1
6400  inds(lt) = nlt-1
6401  caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),g)
6402  end if
6403 
6404  cexpgy(1,inds0(1),inds0(2),g) = caux/(2*(nl+1)*zadj(k,l))
6405  maxcexpgy(1,rg,g) = maxcexpgy(1,rg,g) + abs(cexpgy(1,inds0(1),inds0(2),g) )
6406 
6407  if (g.eq.1.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt. &
6408  truncfacexp*max(1d0,maxcexpgy(1,rg,g-1)) .or. &
6409  g.ge.2.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt. &
6410  truncfacexp*maxcexpgy(1,rg,g-1)) then
6411 #ifdef Cgytest
6412  write(*,*) 'CalcCgy exit gloop',n1,n2,g,abs(cexpgy(1,inds0(1),inds0(2),g)),maxcexpgy(1,rg,g-1)
6413  write(*,*) 'CalcCgy exit gloop',g,rg,inds0(1),inds0(2)
6414 #endif
6415 
6416  gtrunc = g-1
6417  exit gloop
6418 
6419  end if
6420 
6421  end do
6422 
6423 #ifndef PPEXP00
6424 ! if (rg+2.le.rmax) then ! for fixed rank
6425  if (rg+1.le.rmax) then
6426  do nl=rg,0,-1
6427  nlt=rg-nl
6428  inds0(l) = nl
6429  inds0(lt) = nlt
6430  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
6431  + cexpgy(1,inds0(1),inds0(2),g)
6432  end do
6433  end if
6434 #endif
6435 
6436  ! calculate C_ijkl.. exploiting eq. (5.53)
6437  maxcexpgy(0,rg,g) = 0d0
6438  do n1=0,rg
6439  n2 = rg-n1
6440  inds0(1) = n1
6441  inds0(2) = n2
6442 
6443  caux = 2*(2+rg)*cexpgy(1,n1,n2,g)*zadj(i,j)
6444 
6445 ! write(*,*) 'CalcCgy g Caux 1',rg,g,Caux
6446 
6447  if (inds0(jt).ge.1) then
6448  inds = inds0
6449  inds(jt) = inds(jt)-1
6450  caux = caux - 2d0*zadj2f*inds0(jt)*cexpgy(1,inds(1),inds(2),g)
6451  end if
6452 
6453 ! write(*,*) 'CalcCgy g Caux 2',rg,g,Caux
6454 
6455  inds0(i) = inds0(i)+1
6456  caux = caux - zadjf(j)*cexpgy(0,inds0(1),inds0(2),g-1)
6457 
6458 ! write(*,*) 'CalcCgy g Caux 3',rg,g,Caux
6459 
6460  cexpgy(0,n1,n2,g) = caux/xadj(i,j)
6461 
6462 ! write(*,*) 'CalcCgy g Cexpgy',rg,g,n1,n2,Cexpgy(0,n1,n2,g)
6463 
6464  maxcexpgy(0,rg,g) = maxcexpgy(0,rg,g) + abs(cexpgy(0,n1,n2,g))
6465 
6466  if (g.eq.1.and.abs(cexpgy(0,n1,n2,g)).gt. &
6467  truncfacexp*max(1d0/m2scale,maxcexpgy(0,rg,g-1)).or. &
6468  g.ge.2.and.abs(cexpgy(0,n1,n2,g)).gt. &
6469  truncfacexp*maxcexpgy(0,rg,g-1)) then
6470 
6471 #ifdef Cgytest
6472  write(*,*) 'CalcCgy exit gloop',n1,n2,g,rg
6473  write(*,*) 'CalcCgy exit gloop',abs(cexpgy(0,n1,n2,g)),maxcexpgy(0,rg,g-1),1d0/m2scale
6474  write(*,*) 'CalcCgy exit gloop',truncfacexp
6475 #endif
6476 
6477  gtrunc = g-1
6478  exit gloop
6479 
6480  end if
6481 
6482 ! if ((g.ge.2).and.(abs(Cexpgy(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgy(0,n1,n2,g-1)))) then
6483 ! gtrunc = g-1
6484 ! end if
6485 
6486  end do
6487 
6488  ! error propagation from B's
6489  if(rg.gt.1)then
6490  c00_err(rg+2) =max(c00_err(rg+2), &
6491  max(abs(zadjf(k))/2d0*cij_err(rg+1), &
6492  abs(detz)/2d0*cij_err(rg+2))/abs(zadj(k,l)))
6493  end if
6494 
6495 #ifdef Cgytest
6496  write(*,*) 'CalcCgy test2',rg,i,j,cij_err(rg)
6497  write(*,*) 'CalcCgy test2',rg,cij_err(rg+1),c00_err(rg+1)
6498  write(*,*) 'CalcCgy test2',rg,abs(zadj(i,j))
6499  write(*,*) 'CalcCgy test2',rg,abs(zadj2f)
6500  write(*,*) 'CalcCgy test2',rg,abs(zadjf(j))
6501  write(*,*) 'CalcCgy test2',rg,abs(xadj(i,j))
6502 #endif
6503 
6504  cij_err(rg)= max( cij_err(rg), &
6505  max(2*(rg+2)*abs(zadj(i,j))*c00_err(rg+2), &
6506  2*abs(zadj2f)*c00_err(rg+1), &
6507  abs(zadjf(j))*cij_err(rg+1))/abs(xadj(i,j)))
6508 
6509  if(rg.gt.1)then
6510  c00_err2(rg+2) =max(c00_err2(rg+2), &
6511  max(abs(zadjf(k))/2d0*cij_err2(rg+1), &
6512  abs(detz)/2d0*cij_err2(rg+2))/abs(zadj(k,l)))
6513  end if
6514 
6515  cij_err2(rg)= max( cij_err2(rg), &
6516  max(2*(rg+2)*abs(zadj(i,j))*c00_err2(rg+2), &
6517  2*abs(zadj2f)*c00_err2(rg+1), &
6518  abs(zadjf(j))*cij_err2(rg+1))/abs(xadj(i,j)))
6519 
6520 #ifdef PPEXP00
6521 ! if (rg+2.le.rmax) then ! for fixed rank
6522  if (rg+1.le.rmax) then
6523  do nl=rg,0,-1
6524  nlt=rg-nl
6525  inds0(l) = nl
6526  inds0(lt) = nlt
6527  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
6528  + cexpgy(1,inds0(1),inds0(2),g)
6529  end do
6530  end if
6531 #endif
6532 
6533  if ((rg.le.rmax)) then
6534  cerr(rg) = 0d0
6535  do n1=0,rg
6536  n2=rg-n1
6537  c(0,n1,n2) = c(0,n1,n2) + cexpgy(0,n1,n2,g)
6538 
6539 #ifdef Cgytest
6540  write(*,*) 'CalcCgy test1',rg,n1,n2,cerr(rg)
6541  write(*,*) 'CalcCgy test1',cexpgy(0,n1,n2,g)
6542  write(*,*) 'CalcCgy test1',cexpgy(0,n1,n2,g-1)
6543 #endif
6544 
6545  if(abs(cexpgy(0,n1,n2,g-1)).ne.0d0) then
6546  cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g))*min(1d0,abs(cexpgy(0,n1,n2,g))/abs(cexpgy(0,n1,n2,g-1))))
6547  else
6548  cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g)))
6549  end if
6550 
6551 #ifdef Cgytest
6552  write(*,*) 'CalcCgy test1',cerr(rg)
6553 #endif
6554 
6555  end do
6556 
6557  ! if error from B's larger than error from expansion stop expansion
6558  if(cij_err(rg).gt.cerr(rg)) then
6559  gtrunc = min(g,gtrunc)
6560 ! gtrunc = min(g+1,gtrunc)
6561 
6562 #ifdef Cgytest
6563  write(*,*) 'CalcCgy adjust gtrunc',r,g,gtrunc
6564 #endif
6565 
6566  end if
6567 
6568  end if
6569 
6570 
6571  end do gloop
6572 
6573 ! write(*,*) 'CalcCgy gtrunc aft gloop=',gtrunc,r
6574 
6575 #ifdef Cgytest
6576  write(*,*) 'CalcCgy Cerr r =',r
6577  write(*,*) 'CalcCgy Cerr r =',r,cerr
6578  write(*,*) 'CalcCgy Cacc r =',r,cerr/abs(c(0,0,0))
6579  write(*,*) 'CalcCgy Cij_err =',r,cij_err
6580  write(*,*) 'CalcCgy C(0,0,0)=',r,c(0,0,0)
6581  if(rmax.ge.1.and.r.ge.1) then
6582  write(*,*) 'CalcCgy C(0,1,0)=',r,c(0,1,0)
6583  if(rmax.ge.2.and.r.ge.2) then
6584  write(*,*) 'CalcCgy C(0,1,1)=',r,c(0,1,1)
6585  if(rmax.ge.3.and.r.ge.3) then
6586  write(*,*) 'CalcCgy C(0,1,2)=',r,c(0,1,2)
6587  if(rmax.ge.4) then
6588  write(*,*) 'CalcCgy C(0,0,4)=',r,c(0,0,4)
6589  endif
6590  endif
6591  endif
6592  endif
6593 #endif
6594 
6595  cerr2 = max(cerr,cij_err2(0:rmax))
6596  cerr = max(cerr,cij_err(0:rmax))
6597 
6598 #ifdef Cgytest
6599  write(*,*) 'CalcCgy Cerr =',r,cerr,maxval(cerr)
6600 #endif
6601 
6602  ! check if target precision already reached
6603 ! if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit ! changed 28.01.15
6604 #ifdef Cutrloop
6605  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
6606  do rg=r+1,rmax
6607  do n1=0,rg
6608  c(0,n1,rg-n1)=0d0
6609  end do
6610  end do
6611  do rg=r+1,rmax
6612  do n1=0,rg-2
6613  c(1,n1,rg-2-n1)=0d0
6614  end do
6615  end do
6616 #else
6617  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
6618 #endif
6619 
6620 #ifdef Cgytest
6621  write(*,*) 'CalcCgy exit rloop',r,cerr,maxval(cerr)
6622 #endif
6623 
6624  exit rloop
6625 
6626  end if
6627 
6628  end do rloop
6629 
6630 
6631  ! calculating C_0000ijk.. exploiting eq. (5.49)
6632  do r=4,rmax
6633 ! do n0=2,rmax/2 ! for fixed rank
6634  do n0=2,rmax
6635  do nl=r-2*n0,0,-1
6636  nlt=r-2*n0-nl
6637  inds0(l) = nl
6638  inds0(lt) = nlt
6639 
6640  inds(l) = nl+1
6641  inds(lt) = nlt
6642  caux = zadj(k,1)*shat(n0-1,inds(1),inds(2),1) &
6643  + zadj(k,2)*shat(n0-1,inds(1),inds(2),2) &
6644  - zadjf(k)*c(n0-1,inds(1),inds(2))
6645 
6646  inds(k) = inds(k)+1
6647  caux = caux - detz*c(n0-1,inds(1),inds(2))
6648 
6649  if (nlt.ge.1) then
6650  inds(l) = nl+1
6651  inds(lt) = nlt-1
6652  caux = caux - 2*nlt*zadj(k,lt)*c(n0,inds(1),inds(2))
6653  end if
6654 
6655  c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1)*zadj(k,l))
6656 
6657  end do
6658  end do
6659  end do
6660 
6661  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
6662  do r=rmax+1,2*rmax
6663  do n0=r-rmax,r/2
6664  do n1=0,r-2*n0
6665  n2 = r-2*n0-n1
6666  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
6667  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
6668  end do
6669  end do
6670  end do
6671 
6672 #ifdef Cgytest
6673  write(*,*) 'CalcCgy final err',cerr
6674  write(*,*) 'CalcCgy final acc',cerr/abs(c(0,0,0))
6675 #endif
6676 
6677 ! write(*,*) 'CalcCgy out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
6678 #ifdef TRACECout
6679  write(*,*) 'CalcCgy rmax',rmax
6680  do r=14,rmax
6681  do n0=0,r/2
6682  do n1=0,r-2*n0
6683  write(*,*) 'CalcCgy out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
6684  end do
6685  end do
6686  end do
6687 #endif
6688 
6689 ! write(*,*) 'CalcCgy Cerr ',Cerr
6690 ! write(*,*) 'CalcCgy Cerr2',Cerr2
6691 
6692  end subroutine calccgy
6693 
6694 
6695 
6696 
6697 
6698  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6699  ! subroutine CalcCgyo(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
6700  !
6701  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6702 
6703  ! version of Lars
6704 
6705  subroutine calccgyo(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgy_min,ordgy_max,id,Cerr,acc_req_Cr,Cerr2)
6706 
6707  use globalc
6708 
6709  integer, intent(in) :: rmax,ordgy_min,ordgy_max,id
6710  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
6711  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
6712  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
6713  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
6714  double precision, intent(in) :: acc_req_Cr(0:rmax)
6715  double complex, allocatable :: Cexpgy(:,:,:,:), CuvExpgy(:,:,:)
6716  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
6717  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
6718  double complex :: Smod, Caux
6719  double complex :: C0_coli, elimminf2_coli
6720  double precision, allocatable :: C00_err(:),Cij_err(:)
6721  double precision, allocatable :: C00_err2(:),Cij_err2(:)
6722  double precision :: B_err,B_max
6723  double precision :: maxCexpgy(0:1,0:rmax+2*ordgy_min,0:ordgy_max),truncfacexp
6724  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,a,b,j,sgnab,g,rg
6725  integer :: inds0(2),inds(2),at,bt,k,l,lt,nl,nlt
6726  integer :: bin,nid(0:2)
6727 
6728 #ifdef Cgytest
6729  write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
6730 #endif
6731 #ifdef TRACECin
6732  write(*,*) 'CalcCgy in ',rmax,ordgy_min,ordgy_max,id
6733 #endif
6734 
6735  ! write(*,*) 'LH: CalcCgy, ord', ordgy_min
6736  ! calculation of B-coefficients
6737  rmaxb = rmax + 2*ordgy_min + 1
6738  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
6739  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
6740  allocate(b_i(0:rmaxb,0:rmaxb,2))
6741  allocate(buv_i(0:rmaxb,0:rmaxb,2))
6742 
6743  ! determine binaries for B-coefficients
6744  k=0
6745  bin = 1
6746  do while (k.le.2)
6747  if (mod(id/bin,2).eq.0) then
6748  nid(k) = id+bin
6749  k = k+1
6750  end if
6751  bin = 2*bin
6752  end do
6753 
6754  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
6755  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
6756  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
6757 
6758  ! shift of integration momentum in B_0
6759  b_max=0d0
6760  do n1=1,rmaxb
6761  do n2=0,rmaxb-n1
6762  n0 = (rmaxb-n1-n2)
6763  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
6764  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
6765  end do
6766  end do
6767  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
6768  b_err = acc_def_b*b_max
6769 
6770  ! determine (adjugated) Gram and Cayley matrix
6771 ! mm02 = elimminf2_coli(m02)
6772 ! mm12 = elimminf2_coli(m12)
6773 ! mm22 = elimminf2_coli(m22)
6774 ! q10 = elimminf2_coli(p10)
6775 ! q21 = elimminf2_coli(p21)
6776 ! q20 = elimminf2_coli(p20)
6777 !
6778 ! q1q2 = (q10+q20-q21)
6779 ! detZ = 4d0*q10*q20-q1q2*q1q2
6780 
6781  if (abs(detz/( 4d0*q10*q20 + z(2,1)*z(2,1))).lt.1d-4) then
6782  if (abs(q10-q20).lt.abs(q10-q21).and. &
6783  abs(q10-q20).lt.abs(q20-q21)) then
6784  detz = 4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
6785  end if
6786  end if
6787 
6788 ! Zadj(1,1) = 2d0*q20
6789 ! Zadj(2,1) = -q1q2
6790 ! Zadj(1,2) = -q1q2
6791 ! Zadj(2,2) = 2d0*q10
6792 ! f(1) = q10+mm02-mm12
6793 ! f(2) = q20+mm02-mm22
6794 !
6795 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
6796 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
6797 !
6798 ! Xadj(1,1) and Xadj(2,2) exchanged!!!
6799 ! Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
6800 ! Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
6801 ! Xadj(1,2) = Xadj(2,1)
6802 ! Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
6803 
6804 
6805  ! coefficients Shat defined in (5.13)
6806  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
6807 
6808  do r=0,rmaxb
6809  do n0=0,r/2
6810 
6811  do n1=0,r-2*n0
6812  n2 = r-2*n0-n1
6813  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
6814  end do
6815 
6816  k = r-2*n0
6817  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
6818  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
6819 
6820  end do
6821  end do
6822 
6823  ! choose reduction formulas with biggest denominators
6824  if (abs(xadj(1,1)).ge.abs(xadj(2,2))) then
6825  if (abs(xadj(1,1)).ge.abs(xadj(1,2))) then
6826  a = 1
6827  b = 1
6828  at = 2
6829  bt = 2
6830  sgnab = 1
6831  else
6832  a = 1
6833  b = 2
6834  at = 2
6835  bt = 1
6836  sgnab = -1
6837  end if
6838  else
6839  if (abs(xadj(2,2)).ge.abs(xadj(1,2))) then
6840  a = 2
6841  b = 2
6842  at = 1
6843  bt = 1
6844  sgnab = 1
6845  else
6846  a = 1
6847  b = 2
6848  at = 2
6849  bt = 1
6850  sgnab = -1
6851  end if
6852  end if
6853 
6854  if (abs(zadj(1,1)).ge.abs(zadj(2,2))) then
6855  if (abs(zadj(1,1)).ge.abs(zadj(1,2))) then
6856  k = 1
6857  l = 1
6858  lt = 2
6859  else
6860  k = 1
6861  l = 2
6862  lt = 1
6863  end if
6864  else
6865  if (abs(zadj(2,2)).ge.abs(zadj(1,2))) then
6866  k = 2
6867  l = 2
6868  lt = 1
6869  else
6870  k = 1
6871  l = 2
6872  lt = 1
6873  end if
6874  end if
6875 
6876  ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
6877  rmaxexp = rmaxb+1
6878  allocate(cexpgy(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgy_max))
6879 
6880  ! calculate Cuv
6881  allocate(cuvexpgy(0:rmaxexp,0:rmaxexp,0:rmaxexp))
6882  call calccuv(cuvexpgy,buv_0,mm02,f,rmaxexp,id)
6883  cuv(0:rmax,0:rmax,0:rmax) = cuvexpgy(0:rmax,0:rmax,0:rmax)
6884 
6885  ! allocate arrays for error propagation
6886  allocate(c00_err(0:rmaxexp))
6887  allocate(cij_err(0:rmaxexp))
6888  allocate(c00_err2(0:rmaxexp))
6889  allocate(cij_err2(0:rmaxexp))
6890 
6891  ! initialize accuracy estimates
6892  cerr = acc_inf
6893  cij_err =0d0
6894  c00_err =0d0
6895 
6896  cerr2 = acc_inf
6897  cij_err2 =0d0
6898  c00_err2 =0d0
6899 
6900 ! maxZadjf = maxval(abs(Zadjf))
6901 ! fmax = maxval(abs(f))
6902 
6903  ! truncation of expansion if calculated term larger than truncfacexp * previous term
6904  ! crucial for expansion parameters between 0.1 and 1 !!!
6905 ! truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(a,b))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
6906  truncfacexp = sqrt(fac_gy) * truncfacc
6907 
6908  gtrunc = ordgy_max
6909 
6910 ! calculate C(1,n1,n2) up to rank r+2
6911 ! calculate C(0,n1,n2) up to rank r
6912  rloop: do r=0,rmaxexp-2
6913 
6914  if (r.gt.rmax+2*gtrunc+2) exit rloop
6915 
6916  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6917  ! 0th-order coefficients
6918  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
6919 
6920  ! calculating C_00ijk.. exploiting eq. (5.49)
6921  maxcexpgy(1,r,0)=0d0
6922  do nl=r,0,-1
6923  nlt=r-nl
6924  inds0(l) = nl
6925  inds0(lt) = nlt
6926 
6927  inds(l) = nl+1
6928  inds(lt) = nlt
6929  caux = zadj(k,1)*shat(0,inds(1),inds(2),1) &
6930  + zadj(k,2)*shat(0,inds(1),inds(2),2)
6931 
6932  if (nlt.ge.1) then
6933  inds(lt) = nlt-1
6934  caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),0)
6935  end if
6936 
6937  cexpgy(1,inds0(1),inds0(2),0) = caux/(2*(nl+1)*zadj(k,l))
6938  maxcexpgy(1,r,0) = maxcexpgy(1,r,0) + abs(cexpgy(1,inds0(1),inds0(2),0) )
6939  if (r+2.le.rmax) then
6940  c(1,inds0(1),inds0(2)) = cexpgy(1,inds0(1),inds0(2),0)
6941  end if
6942 
6943  end do
6944 
6945  ! calculate C_ijkl.. exploiting eq. (5.53)
6946  maxcexpgy(0,r,0)=0d0
6947  do n1=0,r
6948  n2 = r-n1
6949  inds(1) = n1
6950  inds(2) = n2
6951 
6952  caux = (2*(2+r)*cexpgy(1,n1,n2,0) - 4*cuvexpgy(1,n1,n2) &
6953  - b_0(0,n1,n2))*z(a,b)
6954 
6955 ! write(*,*) 'CalcCred Caux',Caux,Z(a,b),f(a),f(b)
6956 
6957  smod = shat(0,n1,n2,a)
6958 
6959  if (inds(a).ge.1) then
6960  inds(a) = inds(a)-1
6961  smod = smod - 2d0*(inds(a)+1)*cexpgy(1,inds(1),inds(2),0)
6962 
6963  end if
6964 
6965  caux = caux - f(b)*smod
6966 
6967 ! write(*,*) 'CalcCgy maxadjf',maxZadjf,Xadj(a,b),Caux
6968 
6969  cexpgy(0,n1,n2,0) = caux/xadj(a,b)
6970  maxcexpgy(0,r,0) = maxcexpgy(0,r,0) + abs(cexpgy(0,n1,n2,0))
6971  if (r.le.rmax) then
6972  c(0,n1,n2) = cexpgy(0,n1,n2,0)
6973  cerr(r) = abs(maxzadjf/xadj(a,b)*cexpgy(0,n1,n2,0))
6974  end if
6975 
6976  end do
6977 
6978  if (r.le.rmax) then
6979 ! Cerr(r-1) = abs(maxZadjf/Xadj(a,b))*maxCexpgy(0,r,0)
6980  cerr(r-1) = fac_gy*maxcexpgy(0,r,0)
6981  end if
6982 
6983  ! error propagation from B's
6984  c00_err(r+2) = b_err
6985  cij_err(r)=max(abs(zadj(a,b))/abs(xadj(a,b))*max(b_err,c00_err(r+2)), &
6986  fmax/abs(xadj(a,b))*max(b_err,c00_err(r+1)))
6987 
6988  c00_err2(r+2) = b_err
6989  cij_err2(r)=max(abs(zadj(a,b))/abs(xadj(a,b))*max(b_err,c00_err(r+2)), &
6990  fmax/abs(xadj(a,b))*max(b_err,c00_err2(r+1)))
6991 
6992 
6993  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6994  ! higher order coefficients
6995  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6996 
6997  rg = r
6998  gloop: do g=1,min(gtrunc,r/2)
6999  rg = rg-2
7000 
7001 ! write(*,*) 'CalcCgy gtrunc gloop=',gtrunc,r,g,rg
7002 
7003  ! calculating C_00ijk.. exploiting eq. (5.49)
7004  maxcexpgy(1,rg,g) = 0d0
7005  do nl=rg,0,-1
7006  nlt=rg-nl
7007  inds0(l) = nl
7008  inds0(lt) = nlt
7009 
7010  inds(l) = nl+1
7011  inds(lt) = nlt
7012  caux = -zadjf(k)*cexpgy(0,inds(1),inds(2),g-1)
7013 
7014  inds(k) = inds(k)+1
7015  caux = caux - detz*cexpgy(0,inds(1),inds(2),g-1)
7016 
7017  if (nlt.ge.1) then
7018  inds(l) = nl+1
7019  inds(lt) = nlt-1
7020  caux = caux - 2*nlt*zadj(k,lt)*cexpgy(1,inds(1),inds(2),g)
7021  end if
7022 
7023  cexpgy(1,inds0(1),inds0(2),g) = caux/(2*(nl+1)*zadj(k,l))
7024  maxcexpgy(1,rg,g) = maxcexpgy(1,rg,g) + abs(cexpgy(1,inds0(1),inds0(2),g) )
7025 
7026 
7027  if (g.eq.1.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt. &
7028  truncfacexp*max(1d0,maxcexpgy(1,rg,g-1)) .or. &
7029  g.ge.2.and.abs(cexpgy(1,inds0(1),inds0(2),g)).gt. &
7030  truncfacexp*maxcexpgy(1,rg,g-1)) then
7031 
7032 #ifdef Cgytest
7033  write(*,*) 'CalcCgy cycle loop',n1,n2,g,abs(cexpgy(1,inds0(1),inds0(2),g)),maxcexpgy(1,rg,g-1)
7034 #endif
7035 
7036  gtrunc = g-1
7037  exit gloop
7038 ! gtrunc = g
7039 ! cycle gloop
7040 
7041  end if
7042 
7043  end do
7044 
7045 #ifndef PPEXP00
7046  if (rg+2.le.rmax) then
7047  do nl=rg,0,-1
7048  nlt=rg-nl
7049  inds0(l) = nl
7050  inds0(lt) = nlt
7051  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
7052  + cexpgy(1,inds0(1),inds0(2),g)
7053  end do
7054  end if
7055 #endif
7056 
7057  ! calculate C_ijkl.. exploiting eq. (5.53)
7058  maxcexpgy(0,rg,g) = 0d0
7059  do n1=0,rg
7060  n2 = rg-n1
7061  inds0(1) = n1
7062  inds0(2) = n2
7063 
7064  caux = 2*(2+rg)*cexpgy(1,n1,n2,g)*z(a,b)
7065 
7066 ! write(*,*) 'CalcCgy g Caux 1',rg,g,Caux
7067 
7068  if (inds0(a).ge.1) then
7069  inds = inds0
7070  inds(a) = inds(a)-1
7071  caux = caux + 2d0*f(b)*inds0(a)*cexpgy(1,inds(1),inds(2),g)
7072  end if
7073 
7074 ! write(*,*) 'CalcCgy g Caux 2',rg,g,Caux
7075 
7076  inds0(at) = inds0(at)+1
7077  caux = caux - sgnab*zadjf(bt)*cexpgy(0,inds0(1),inds0(2),g-1)
7078 
7079 ! write(*,*) 'CalcCgy g Caux 3',rg,g,Caux
7080 
7081  cexpgy(0,n1,n2,g) = caux/xadj(a,b)
7082 
7083 ! write(*,*) 'CalcCgyo g Cexpgy',rg,g,n1,n2,Cexpgy(0,n1,n2,g)
7084 
7085  maxcexpgy(0,rg,g) = maxcexpgy(0,rg,g) + abs(cexpgy(0,n1,n2,g))
7086 
7087  if (g.eq.1.and.abs(cexpgy(0,n1,n2,g)).gt. &
7088  truncfacexp*max(1d0/m2scale,maxcexpgy(0,rg,g-1)).or. &
7089  g.ge.2.and.abs(cexpgy(0,n1,n2,g)).gt. &
7090  truncfacexp*maxcexpgy(0,rg,g-1)) then
7091 
7092 #ifdef Cgytest
7093  write(*,*) 'CalcCgy cycle loop',n1,n2,g,abs(cexpgy(0,n1,n2,g)),maxcexpgy(0,rg,g-1)
7094 #endif
7095 
7096  gtrunc = g-1
7097  exit gloop
7098 ! gtrunc = g
7099 ! cycle gloop
7100  end if
7101 
7102 ! if ((g.ge.2).and.(abs(Cexpgy(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgy(0,n1,n2,g-1)))) then
7103 ! gtrunc = g-1
7104 ! end if
7105 
7106  end do
7107 
7108  ! error propagation from B's
7109  if(rg.gt.1)then
7110  c00_err(rg+2) =max(c00_err(rg+2), &
7111  max(abs(zadjf(k))*cij_err(rg+1),abs(detz)*cij_err(rg+2))/abs(zadj(k,l)))
7112  end if
7113  cij_err(rg)= max( cij_err(rg), &
7114  max(abs(z(a,b))*c00_err(rg+2),abs(f(b))*c00_err(rg+1), &
7115  abs(zadjf(b))*cij_err(rg+1))/abs(xadj(a,b)))
7116 
7117  if(rg.gt.1)then
7118  c00_err2(rg+2) =max(c00_err2(rg+2), &
7119  max(abs(zadjf(k))*cij_err2(rg+1),abs(detz)*cij_err2(rg+2))/abs(zadj(k,l)))
7120  end if
7121  cij_err2(rg)= max( cij_err2(rg), &
7122  max(abs(z(a,b))*c00_err2(rg+2),abs(f(b))*c00_err2(rg+1), &
7123  abs(zadjf(b))*cij_err2(rg+1))/abs(xadj(a,b)))
7124 
7125 #ifdef PPEXP00
7126  if (rg+2.le.rmax) then
7127  do nl=rg,0,-1
7128  nlt=rg-nl
7129  inds0(l) = nl
7130  inds0(lt) = nlt
7131  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
7132  + cexpgy(1,inds0(1),inds0(2),g)
7133  end do
7134  end if
7135 #endif
7136 
7137  if ((rg.le.rmax)) then
7138  cerr(rg) = 0d0
7139  do n1=0,rg
7140  n2=rg-n1
7141  c(0,n1,n2) = c(0,n1,n2) + cexpgy(0,n1,n2,g)
7142  if(abs(cexpgy(0,n1,n2,g-1)).ne.0d0) then
7143  cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g))*min(1d0,abs(cexpgy(0,n1,n2,g))/abs(cexpgy(0,n1,n2,g-1))))
7144  else
7145  cerr(rg)=max(cerr(rg),abs(cexpgy(0,n1,n2,g)))
7146  end if
7147  end do
7148 
7149  ! if error from B's larger than error from expansion stop expansion
7150  if(cij_err(rg).gt.cerr(rg)) then
7151  gtrunc = min(g,gtrunc)
7152 ! gtrunc = min(g+1,gtrunc)
7153 
7154 #ifdef Cgytest
7155  write(*,*) 'CalcCgy exit err',r,g,gtrunc
7156 #endif
7157 
7158  end if
7159 
7160  end if
7161 
7162 
7163  end do gloop
7164 
7165 ! write(*,*) 'CalcCgy gtrunc after gloop=',gtrunc,r
7166 
7167 #ifdef Cgytest
7168  write(*,*) 'CalcCgy Cerr r =',r
7169  write(*,*) 'CalcCgy Cerr r =',r,cerr
7170  write(*,*) 'CalcCgy Cacc r =',r,cerr/abs(c(0,0,0))
7171  write(*,*) 'CalcCgy Cij_err =',r,cij_err
7172 #endif
7173 
7174  cerr2 = max(cerr,cij_err2(0:rmax))
7175  cerr = max(cerr,cij_err(0:rmax))
7176 
7177 #ifdef Cgytest
7178  write(*,*) 'CalcCgy Cerr =',r,cerr,maxval(cerr)
7179 #endif
7180 
7181  ! check if target precision already reached
7182 ! if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit ! changed 28.01.15
7183 #ifdef Cutrloop
7184  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
7185  do rg=r+1,rmax
7186  do n1=0,rg
7187  c(0,n1,rg-n1)=0d0
7188  end do
7189  end do
7190  do rg=r+1,rmax
7191  do n1=0,rg-2
7192  c(1,n1,rg-2-n1)=0d0
7193  end do
7194  end do
7195 #else
7196  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
7197 #endif
7198  exit rloop
7199  end if
7200 
7201  end do rloop
7202 
7203 
7204  ! calculating C_0000ijk.. exploiting eq. (5.49)
7205  do r=4,rmax
7206  do n0=2,rmax/2
7207  do nl=r-2*n0,0,-1
7208  nlt=r-2*n0-nl
7209  inds0(l) = nl
7210  inds0(lt) = nlt
7211 
7212  inds(l) = nl+1
7213  inds(lt) = nlt
7214  caux = zadj(k,1)*shat(n0-1,inds(1),inds(2),1) &
7215  + zadj(k,2)*shat(n0-1,inds(1),inds(2),2) &
7216  - zadjf(k)*c(n0-1,inds(1),inds(2))
7217 
7218  inds(k) = inds(k)+1
7219  caux = caux - detz*c(n0-1,inds(1),inds(2))
7220 
7221  if (nlt.ge.1) then
7222  inds(l) = nl+1
7223  inds(lt) = nlt-1
7224  caux = caux - 2*nlt*zadj(k,lt)*c(n0,inds(1),inds(2))
7225  end if
7226 
7227  c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1)*zadj(k,l))
7228 
7229  end do
7230  end do
7231  end do
7232 
7233  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
7234  do r=rmax+1,2*rmax
7235  do n0=r-rmax,r/2
7236  do n1=0,r-2*n0
7237  n2 = r-2*n0-n1
7238  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
7239  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
7240  end do
7241  end do
7242  end do
7243 
7244 #ifdef Cgytest
7245  write(*,*) 'CalcCgy final err',cerr
7246  write(*,*) 'CalcCgy final acc',cerr/abs(c(0,0,0))
7247 #endif
7248 
7249 ! write(*,*) 'CalcCgyo out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
7250 #ifdef TRACECout
7251  write(*,*) 'CalcCgyo rmax',rmax
7252  do r=14,rmax
7253  do n0=0,r/2
7254  do n1=0,r-2*n0
7255  write(*,*) 'CalcCgyo out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
7256  end do
7257  end do
7258  end do
7259 #endif
7260 
7261 
7262  end subroutine calccgyo
7263 
7264 
7265 
7266 
7267 
7268  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7269  ! subroutine CalcCgp(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgp_min,ordgp_max,id,Cerr,acc_req_Cr,Cerr2)
7270  !
7271  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7272 
7273  subroutine calccgp(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgp_min,ordgp_max,id,Cerr,acc_req_Cr,Cerr2)
7274 
7275  use globalc
7276 
7277  integer, intent(in) :: rmax,ordgp_min,ordgp_max,id
7278  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
7279  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
7280  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
7281  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
7282  double precision, intent(in) :: acc_req_Cr(0:rmax)
7283  double complex, allocatable :: Cexpgp(:,:,:,:), CuvExpgp(:,:,:)
7284  double complex, allocatable :: B_0(:,:,:), B_k(:,:), Shat(:,:,:)
7285  double complex, allocatable :: Buv_0(:,:,:), Buv_k(:,:)
7286  double complex :: Smod, fk, elimminf2_coli
7287  double precision, allocatable :: C00_err(:),Cij_err(:)
7288  double precision, allocatable :: C00_err2(:),Cij_err2(:)
7289  double precision :: B_err,B_max
7290  double precision :: maxCexpgp(0:1,0:rmax+ordgp_min+1,0:ordgp_max),truncfacexp
7291  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,k,l,g,rg
7292  integer :: bin,nid(0:2),i
7293 
7294 #ifdef Cgptest
7295  write(*,*) 'CalcCgp in ',rmax,ordgp_min,ordgp_max,id
7296 #endif
7297 #ifdef TRACECin
7298  write(*,*) 'CalcCgp in ',rmax,ordgp_min,ordgp_max,id
7299 #endif
7300 
7301  ! determine Gram matrix
7302 ! mm02 = elimminf2_coli(m02)
7303 ! mm12 = elimminf2_coli(m12)
7304 ! mm22 = elimminf2_coli(m22)
7305 ! q10 = elimminf2_coli(p10)
7306 ! q21 = elimminf2_coli(p21)
7307 ! q20 = elimminf2_coli(p20)
7308 !
7309 ! q1q2 = (q10+q20-q21)
7310 ! commented out 2.9.17
7311 ! Z(1,1) = 2d0*q10
7312 ! Z(2,1) = q1q2
7313 ! Z(1,2) = q1q2
7314 ! Z(2,2) = 2d0*q20
7315 ! f(1) = q10+mm02-mm12
7316 ! f(2) = q20+mm02-mm22
7317 
7318 
7319  ! choose reduction formulas with biggest denominators
7320  if (abs(f(1)).ge.abs(f(2))) then
7321  k = 1
7322  else
7323  k = 2
7324  end if
7325  fk = f(k)
7326 
7327 
7328  ! calculations of B-coefficients
7329  rmaxb = rmax + ordgp_min
7330  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
7331  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
7332  allocate(b_k(0:rmaxb,0:rmaxb))
7333  allocate(buv_k(0:rmaxb,0:rmaxb))
7334 
7335  ! determine binaries for B-coefficients
7336  i=0
7337  bin = 1
7338  do while (i.le.2)
7339  if (mod(id/bin,2).eq.0) then
7340  nid(i) = id+bin
7341  i = i+1
7342  end if
7343  bin = 2*bin
7344  end do
7345 
7346  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
7347  if (k.eq.1) then
7348  call calcb(b_k(:,:),buv_k(:,:),p20,m02,m22,rmaxb,nid(1))
7349  else
7350  call calcb(b_k(:,:),buv_k(:,:),p10,m02,m12,rmaxb,nid(2))
7351  end if
7352 
7353  ! shift of integration momentum in B_0
7354  b_max=0d0
7355  do n1=1,rmaxb
7356  do n2=0,rmaxb-n1
7357  n0 = (rmaxb-n1-n2)
7358  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
7359  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
7360  b_max = max(b_max,abs(b_0(0,n1,n2)))
7361  end do
7362  end do
7363  b_max = max(b_max,maxval(abs(b_k(0,0:rmaxb))))
7364  b_err = acc_def_b*b_max
7365 
7366 #ifdef Cgptest
7367  write(*,*) 'CalcCgp B_max ', b_max
7368 #endif
7369 
7370  ! coefficients Shat defined in (5.13)
7371  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb))
7372 
7373  do r=0,rmaxb
7374  do n0=0,r/2
7375 
7376  do n1=0,r-2*n0
7377  n2 = r-2*n0-n1
7378  shat(n0,n1,n2) = -b_0(n0,n1,n2)
7379  end do
7380 
7381  l = r-2*n0
7382  if (k.eq.1) then
7383  shat(n0,0,l) = shat(n0,0,l) + b_k(n0,l)
7384  else
7385  shat(n0,l,0) = shat(n0,l,0) + b_k(n0,l)
7386  end if
7387 
7388  end do
7389  end do
7390 
7391 
7392  ! allocation of array for det(Z)-expanded C-coefficients
7393  rmaxexp = rmaxb+1
7394  allocate(cexpgp(0:rmaxexp/2,0:rmaxexp-1,0:rmaxexp-1,0:ordgp_max))
7395 
7396 
7397  ! calculate Cuv
7398  allocate(cuvexpgp(0:rmaxexp,0:rmaxexp,0:rmaxexp))
7399  call calccuv(cuvexpgp,buv_0,mm02,f,rmaxexp,id)
7400  cuv(0:rmax,0:rmax,0:rmax) = cuvexpgp(0:rmax,0:rmax,0:rmax)
7401 
7402  ! allocate arrays for error propagation
7403  allocate(c00_err(0:rmaxexp))
7404  allocate(cij_err(0:rmaxexp))
7405  allocate(c00_err2(0:rmaxexp))
7406  allocate(cij_err2(0:rmaxexp))
7407 
7408  ! initialize accuracy estimates
7409  cerr = acc_inf
7410  cij_err =0d0
7411  c00_err =0d0
7412 
7413  cerr2 = acc_inf
7414  cij_err2 =0d0
7415  c00_err2 =0d0
7416 
7417 ! maxZ = maxval(abs(Z))
7418 ! maxZ = 2d0*q2max
7419 
7420  ! truncation of expansion if calculated term larger than truncfacexp * previous term
7421  ! crucial for expansion parameters between 0.1 and 1 !!!
7422 ! truncfacexp = sqrt(abs(maxZ/abs(fk))) * truncfacC
7423  truncfacexp = sqrt(fac_gp) * truncfacc
7424  gtrunc = ordgp_max
7425 
7426 #ifdef Cgptest
7427  write(*,*) 'CalcCgp rmaxExp',rmaxexp,rmax,gtrunc
7428 #endif
7429 
7430 ! calculate C(n0,n1,n2) up to rank r for n0>0 and up to rank r-1 for n0=0
7431  rloop: do r=1,rmaxexp
7432 
7433 #ifdef Cgptest
7434  write(*,*) 'CalcCgp r',r,rmax+gtrunc+1
7435 #endif
7436 
7437 
7438  if (r.gt.rmax+gtrunc+1) exit rloop
7439 
7440  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7441  ! 0th-order coefficients
7442  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7443 
7444  ! calculating
7445  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
7446  ! exploiting eq. (5.63)
7447  maxcexpgp(1,r,0)=0d0
7448  do n0=r/2,1,-1
7449  do n1=0,r-2*n0
7450  n2=r-2*n0-n1
7451 
7452  cexpgp(n0,n1,n2,0) = (2d0*cuvexpgp(n0,n1,n2) + b_0(n0-1,n1,n2) &
7453  + mm02*cexpgp(n0-1,n1,n2,0))/((r-n0)+1d0)/2d0
7454 
7455  if (n0.eq.1) then
7456  maxcexpgp(1,r,0) = maxcexpgp(1,r,0) + abs(cexpgp(n0,n1,n2,0) )
7457  end if
7458 
7459  if (r-n0.le.rmax) then
7460  c(n0,n1,n2) = cexpgp(n0,n1,n2,0)
7461  end if
7462 
7463  end do
7464  end do
7465 
7466  ! calculate
7467  ! C_00ijkl.. --> C_aijkl..
7468  ! exploiting eq. (5.62)
7469  maxcexpgp(0,r-1,0)=0d0
7470  do n1=0,r-1
7471  n2 = r-1-n1
7472 
7473  smod = shat(0,n1,n2)
7474  if ((k.eq.1).and.(n1.ge.1)) then
7475  smod = smod - 2d0*n1*cexpgp(1,n1-1,n2,0)
7476  else if ((k.eq.2).and.(n2.ge.1)) then
7477  smod = smod - 2d0*n2*cexpgp(1,n1,n2-1,0)
7478  end if
7479 
7480  cexpgp(0,n1,n2,0) = smod/fk
7481  maxcexpgp(0,r-1,0) = maxcexpgp(0,r-1,0) + abs(cexpgp(0,n1,n2,0))
7482 
7483  if (r.le.rmax+1) then
7484  c(0,n1,n2) = cexpgp(0,n1,n2,0)
7485  end if
7486 
7487  end do
7488 
7489  if (r.le.rmax+1) then
7490 ! Cerr(r-1) = abs(maxZ/fk)*maxCexpgp(0,r-1,0)
7491  cerr(r-1) = fac_gp*maxcexpgp(0,r-1,0)
7492  end if
7493 
7494  ! error propagation from B's
7495  if(r.gt.1)then
7496  c00_err(r) = b_err/(2*r)
7497  end if
7498  cij_err(r-1) = b_err/abs(fk)
7499 
7500  if(r.gt.1)then
7501  c00_err2(r) = b_err/(2*r)
7502  end if
7503  cij_err2(r-1) = b_err/abs(fk)
7504 
7505 #ifdef Cgptest
7506  write(*,*) 'CalcCgp B_err',b_err,abs(fk), cij_err(r-1),r
7507 #endif
7508 
7509  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7510  ! higher order coefficients
7511  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7512 
7513  rg = r
7514  gloop: do g=1,min(gtrunc,r-1)
7515  rg = rg-1
7516 
7517  ! calculating for rank=rmaxB+1
7518  ! C_00(a)0000..00 --> C_00(a)ij00..00 --> C_00(a)ijkl00..00 --> ... --> C_00(a)ijklmn..
7519  ! exploiting eq. (5.63)
7520  maxcexpgp(1,rg,g) = 0d0
7521  do n0=rg/2,1,-1
7522  do n1=0,rg-2*n0
7523  n2=rg-2*n0-n1
7524 
7525  cexpgp(n0,n1,n2,g) = (2d0*mm02*cexpgp(n0-1,n1,n2,g) &
7526  - z(1,1)*cexpgp(n0-1,n1+2,n2,g-1) - 2d0*z(2,1)*cexpgp(n0-1,n1+1,n2+1,g-1) &
7527  - z(2,2)*cexpgp(n0-1,n1,n2+2,g-1))/((rg-n0)+1d0)/4d0
7528 
7529  if(n0.eq.1) then
7530  maxcexpgp(1,rg,g) = maxcexpgp(1,rg,g) + abs(cexpgp(n0,n1,n2,g))
7531 
7532 
7533  if (g.eq.1.and.abs(cexpgp(1,n1,n2,g)).gt. &
7534  truncfacexp*max(1d0,maxcexpgp(1,rg,g-1)) .or. &
7535  g.ge.2.and.abs(cexpgp(1,n1,n2,g)).gt. &
7536  truncfacexp*maxcexpgp(1,rg,g-1)) then
7537 
7538 #ifdef Cgptest
7539  write(*,*) 'CalcCg exit rloop',n0,n1,n2,g,abs(cexpgp(n0,n1,n2,g)),maxcexpgp(1,rg,g-1)
7540 #endif
7541 
7542  gtrunc = g-1
7543  exit gloop
7544  end if
7545  end if
7546 
7547 ! if ((g.ge.2).and.(abs(Cexpgp(n0,n1,n2,g)).gt.truncfacexp*abs(Cexpgp(n0,n1,n2,g-1)))) then
7548 ! gtrunc = g-1
7549 ! end if
7550 
7551  end do
7552  end do
7553 
7554 #ifndef PPEXP00
7555  do n0=rg/2,1,-1
7556  if (rg-n0.le.rmax) then
7557  do n1=0,rg-2*n0
7558  n2=rg-2*n0-n1
7559  c(n0,n1,n2) = c(n0,n1,n2) + cexpgp(n0,n1,n2,g)
7560  end do
7561  end if
7562  end do
7563 #endif
7564 
7565  ! calculate
7566  ! C_000000..00 --> C_i0000..00 --> C_ij00..00 --> ... --> C_ijk..
7567  ! exploiting eq. (5.62)
7568  maxcexpgp(0,rg-1,g) = 0d0
7569  do n1=0,rg-1
7570  n2 = rg-1-n1
7571 
7572  smod = -z(1,k)*cexpgp(0,n1+1,n2,g-1) &
7573  -z(2,k)*cexpgp(0,n1,n2+1,g-1)
7574  if ((k.eq.1).and.(n1.ge.1)) then
7575  smod = smod - 2d0*n1*cexpgp(1,n1-1,n2,g)
7576  else if ((k.eq.2).and.(n2.ge.1)) then
7577  smod = smod - 2d0*n2*cexpgp(1,n1,n2-1,g)
7578  end if
7579 
7580  cexpgp(0,n1,n2,g) = smod/fk
7581 
7582  maxcexpgp(0,rg-1,g) = maxcexpgp(0,rg-1,g) + abs(cexpgp(0,n1,n2,g))
7583 
7584  if (g.eq.1.and.abs(cexpgp(0,n1,n2,g)).gt. &
7585  truncfacexp*max(1/m2max,maxcexpgp(0,rg-1,g-1)) .or. &
7586  g.ge.2.and.abs(cexpgp(0,n1,n2,g)).gt. &
7587  truncfacexp*maxcexpgp(0,rg-1,g-1)) then
7588 
7589 #ifdef Cgptest
7590  write(*,*) 'CalcCgp exit gloop',0,n1,n2,g,abs(cexpgp(0,n1,n2,g)),maxcexpgp(0,rg,g-1)
7591 #endif
7592  gtrunc = g-1
7593  exit gloop
7594  end if
7595 
7596  end do
7597 
7598  ! error propagation from B's
7599  if(rg.gt.1)then
7600  c00_err(rg) = max(c00_err(rg),max(2*abs(m02)*cij_err(rg-2),maxz*cij_err(rg))/(4*r) )
7601  end if
7602  cij_err(rg-1) = max(cij_err(rg-1),max(2*c00_err(rg),maxz*cij_err(rg))/abs(fk) )
7603 
7604  if(rg.gt.1)then
7605  c00_err2(rg) = max(c00_err2(rg),max(2*abs(m02)*cij_err2(rg-2),maxz*cij_err2(rg))/(4*r) )
7606  end if
7607  cij_err2(rg-1) = max(cij_err2(rg-1),max(2*c00_err2(rg),maxz*cij_err2(rg))/abs(fk) )
7608 
7609 #ifdef PPEXP00
7610  do n0=rg/2,1,-1
7611  if (rg-n0.le.rmax) then
7612  do n1=0,rg-2*n0
7613  n2=rg-2*n0-n1
7614  c(n0,n1,n2) = c(n0,n1,n2) + cexpgp(n0,n1,n2,g)
7615  end do
7616  end if
7617  end do
7618 #endif
7619 
7620  if ((rg.le.rmax+1)) then
7621  cerr(rg-1) = 0d0
7622  do n1=0,rg-1
7623  n2=rg-1-n1
7624  c(0,n1,n2) = c(0,n1,n2) + cexpgp(0,n1,n2,g)
7625 ! Cerr(rg-1)=max(Cerr(rg-1),abs(Cexpgp(0,n1,n2,g))**2/abs(Cexpgp(0,n1,n2,g-1)))
7626  if(abs(cexpgp(0,n1,n2,g-1)).ne.0d0) then
7627  cerr(rg-1)=max(cerr(rg-1),abs(cexpgp(0,n1,n2,g))*min(1d0,abs(cexpgp(0,n1,n2,g))/abs(cexpgp(0,n1,n2,g-1))))
7628  else
7629  cerr(rg-1)=max(cerr(rg-1),abs(cexpgp(0,n1,n2,g)))
7630  end if
7631  end do
7632 
7633  ! if error from B's larger than error from expansion stop expansion
7634  if(cij_err(rg-1).gt.cerr(rg-1)) then
7635  gtrunc = min(g,gtrunc)
7636 
7637 #ifdef Cgptest
7638  write(*,*) 'CalcCgp exit err',r,g,gtrunc
7639 #endif
7640 
7641  end if
7642 
7643  end if
7644 
7645  end do gloop
7646 
7647 #ifdef Cgptest
7648  write(*,*) 'CalcCgp Cerr r =',r,cerr
7649  write(*,*) 'CalcCgp Cacc r =',r,cerr/abs(c(0,0,0))
7650  write(*,*) 'CalcCgp Cij_err =',r,cij_err
7651 #endif
7652 
7653  cerr2 = max(cerr,cij_err2(0:rmax))
7654  cerr = max(cerr,cij_err(0:rmax))
7655 
7656 #ifdef Cgptest
7657  write(*,*) 'CalcCgp Cerr =',r,cerr,maxval(cerr)
7658  write(*,*) 'CalcCgp accr =',r,acc_req_cr*abs(c(0,0,0)),maxval(acc_req_cr*abs(c(0,0,0)))
7659  write(*,*) 'CalcCgp C-ar =',r,cerr-acc_req_cr*abs(c(0,0,0)),maxval(cerr-acc_req_cr*abs(c(0,0,0)))
7660 #endif
7661 
7662  ! check if target precision already reached
7663 ! if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit ! changed 28.01.15
7664 #ifdef Cutrloop
7665  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
7666  do rg=r+1,rmax
7667  do n0=0,rg/2
7668  do n1=0,rg-2*n0
7669  c(n0,n1,rg-2*n0-n1)=0d0
7670  end do
7671  end do
7672  end do
7673  if(r.le.rmax) then
7674  do n1=0,r
7675  c(0,n1,r-n1)=0d0
7676  end do
7677  end if
7678 #else
7679  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.gt.rmax) then
7680 #endif
7681 ! write(*,*) 'CalcCg exit rloop =',r,rmax,rg
7682 
7683  exit rloop
7684  end if
7685 
7686 ! write(*,*) 'CalcCgp after exit'
7687 
7688  end do rloop
7689 
7690  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
7691  do r=rmax+1,2*rmax
7692  do n0=r-rmax,r/2
7693  do n1=0,r-2*n0
7694  n2 = r-2*n0-n1
7695  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
7696  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
7697  end do
7698  end do
7699  end do
7700 
7701 #ifdef Cgptest
7702  write(*,*) 'CalcCgp final err',cerr
7703  write(*,*) 'CalcCgp final acc',cerr/abs(c(0,0,0))
7704 #endif
7705 
7706 #ifdef TRACECout
7707  write(*,*) 'CalcCgp rmax',rmax
7708  do r=14,rmax
7709  do n0=0,r/2
7710  do n1=0,r-2*n0
7711  write(*,*) 'CalcCgp out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
7712  end do
7713  end do
7714  end do
7715 #endif
7716 
7717 ! write(*,*) 'CalcCgp rmax',rmax
7718 ! do r=14,rmax
7719 ! do r=0,rmax
7720 ! do n0=0,r/2
7721 ! do n1=0,r-2*n0
7722 ! write(*,*) 'CalcCgp out',r,n0,n1,r-2*n0-n1,C(n0,n1,r-2*n0-n1)
7723 ! end do
7724 ! end do
7725 ! end do
7726 
7727 ! write(*,*) 'CalcCgp Cerr ',Cerr
7728 ! write(*,*) 'CalcCgp Cerr2',Cerr2
7729 
7730  end subroutine calccgp
7731 
7732 
7733  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7734  ! subroutine CalcCgpf(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgpf_min,ordgpf_max,id,Cerr,acc_req_Cr,Cerr2)
7735  !
7736  ! added by AD 16.08.2017
7737  !
7738  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
7739 
7740  subroutine calccgpf(C,Cuv,p10,p21,p20,m02,m12,m22,rmax,ordgpf_min,ordgpf_max,id,Cerr,acc_req_Cr,Cerr2)
7741 
7742  use globalc
7743 
7744  integer, intent(in) :: rmax,ordgpf_min,ordgpf_max,id
7745  double complex, intent(in) :: p10,p21,p20,m02,m12,m22
7746  double complex, intent(out) :: C(0:rmax,0:rmax,0:rmax)
7747  double complex, intent(out) :: Cuv(0:rmax,0:rmax,0:rmax)
7748  double precision, intent(out) :: Cerr(0:rmax),Cerr2(0:rmax)
7749  double precision, intent(in) :: acc_req_Cr(0:rmax)
7750  double complex, allocatable :: Cexpgpf(:,:,:,:), CuvExpgpf(:,:,:)
7751  double complex, allocatable :: B_0(:,:,:), B_i(:,:,:), Shat(:,:,:,:)
7752  double complex, allocatable :: Buv_0(:,:,:), Buv_i(:,:,:)
7753  double complex :: Smod, Caux, Zadj2f
7754  double complex :: C0_coli, elimminf2_coli
7755  double precision, allocatable :: C00_err(:),Cij_err(:)
7756  double precision, allocatable :: C00_err2(:),Cij_err2(:)
7757  double precision :: B_err,B_max,aZadj2f
7758  double precision :: maxCexpgpf(0:1,0:rmax+2*ordgpf_min,0:ordgpf_max),truncfacexp
7759  double precision :: minZk
7760  integer :: rmaxB,rmaxExp,gtrunc,r,n0,n1,n2,i,j,jt,g,rg
7761  integer :: inds0(2),inds(2),k,l,lt,nl,nlt
7762  integer :: bin,nid(0:2)
7763 
7764 #ifdef Cgpftest
7765  write(*,*) 'CalcCgpf in ',rmax,ordgpf_min,ordgpf_max,id
7766  write(*,*) 'CalcCgpf in ',p10,p21,p20,m02,m12,m22
7767 #endif
7768 #ifdef TRACECin
7769  write(*,*) 'CalcCgpf in ',rmax,ordgpf_min,ordgpf_max,id
7770 #endif
7771 
7772  ! write(*,*) 'LH: CalcCgpf, ord', ordgpf_min
7773  ! calculation of B-coefficients
7774  rmaxb = rmax + 2*ordgpf_min + 1
7775  allocate(b_0(0:rmaxb,0:rmaxb,0:rmaxb))
7776  allocate(buv_0(0:rmaxb,0:rmaxb,0:rmaxb))
7777  allocate(b_i(0:rmaxb,0:rmaxb,2))
7778  allocate(buv_i(0:rmaxb,0:rmaxb,2))
7779 
7780  ! determine binaries for B-coefficients
7781  k=0
7782  bin = 1
7783  do while (k.le.2)
7784  if (mod(id/bin,2).eq.0) then
7785  nid(k) = id+bin
7786  k = k+1
7787  end if
7788  bin = 2*bin
7789  end do
7790 
7791  call calcb(b_0(:,0,:),buv_0(:,0,:),p21,m12,m22,rmaxb,nid(0))
7792  call calcb(b_i(:,:,1),buv_i(:,:,1),p20,m02,m22,rmaxb,nid(1))
7793  call calcb(b_i(:,:,2),buv_i(:,:,2),p10,m02,m12,rmaxb,nid(2))
7794 
7795  ! shift of integration momentum in B_0
7796  b_max=0d0
7797  do n1=1,rmaxb
7798  do n2=0,rmaxb-n1
7799  n0 = (rmaxb-n1-n2)
7800  b_0(0:n0,n1,n2) = -b_0(0:n0,n1-1,n2)-b_0(0:n0,n1-1,n2+1)
7801  buv_0(0:n0,n1,n2) = -buv_0(0:n0,n1-1,n2)-buv_0(0:n0,n1-1,n2+1)
7802  end do
7803  end do
7804  b_max = max(b_max,maxval(abs(b_i(0,0:rmaxb,1:2))))
7805  b_err = acc_def_b*b_max
7806 
7807  ! determine (adjugated) Gram and Cayley matrix
7808 ! mm02 = elimminf2_coli(m02)
7809 ! mm12 = elimminf2_coli(m12)
7810 ! mm22 = elimminf2_coli(m22)
7811 ! q10 = elimminf2_coli(p10)
7812 ! q21 = elimminf2_coli(p21)
7813 ! q20 = elimminf2_coli(p20)
7814 !
7815 ! q1q2 = (q10+q20-q21)
7816 ! detZ = 4d0*q10*q20-q1q2*q1q2
7817 
7818  if (abs(detz).lt.abs(4d0*q10*q20 + z(2,1)*z(2,1))*1d-4) then
7819  if (abs(q10-q20).lt.abs(q10-q21).and. &
7820  abs(q10-q20).lt.abs(q20-q21)) then
7821  detz = 4d0*q10*q21 - (q10-q20+q21)*(q10-q20+q21)
7822  end if
7823  end if
7824 
7825 ! Zadj(1,1) = 2d0*q20
7826 ! Zadj(2,1) = -q1q2
7827 ! Zadj(1,2) = -q1q2
7828 ! Zadj(2,2) = 2d0*q10
7829 ! f(1) = q10+mm02-mm12
7830 ! f(2) = q20+mm02-mm22
7831 !
7832 ! Zadjf(1) = Zadj(1,1)*f(1)+Zadj(2,1)*f(2)
7833 ! Zadjf(2) = Zadj(1,2)*f(1)+Zadj(2,2)*f(2)
7834 !
7835 ! Xadj(1,1) and Xadj(2,2) exchanged!!!
7836 ! Xadj(1,1) = 2d0*mm02*Z(1,1) - f(1)*f(1)
7837 ! Xadj(2,1) = 2d0*mm02*Z(1,2) - f(1)*f(2)
7838 ! Xadj(1,2) = Xadj(2,1)
7839 ! Xadj(2,2) = 2d0*mm02*Z(2,2) - f(2)*f(2)
7840 
7841 
7842  ! coefficients Shat defined in (5.13)
7843  allocate(shat(0:rmaxb,0:rmaxb,0:rmaxb,2))
7844 
7845  do r=0,rmaxb
7846  do n0=0,r/2
7847 
7848  do n1=0,r-2*n0
7849  n2 = r-2*n0-n1
7850  shat(n0,n1,n2,:) = -b_0(n0,n1,n2)
7851  end do
7852 
7853  k = r-2*n0
7854  shat(n0,0,k,1) = shat(n0,0,k,1) + b_i(n0,k,1)
7855  shat(n0,k,0,2) = shat(n0,k,0,2) + b_i(n0,k,2)
7856 
7857  end do
7858  end do
7859 
7860  ! choose reduction formulas with smallest expansion terms
7861  minzk = maxz
7862  if (maxval(abs(z(1,1:2))).le.minzk) then
7863  minzk = maxval(abs(z(1,1:2)))
7864  k = 1
7865  l = 1
7866  lt = 2
7867  end if
7868  if (maxval(abs(z(2,1:2))).lt.minzk) then
7869  minzk = maxval(abs(z(2,1:2)))
7870  k = 2
7871  l = 2
7872  lt = 1
7873  end if
7874 
7875 #ifdef Cgpftest
7876  write(*,*) 'CalcCgpf: minZk',k,minzk
7877 #endif
7878 
7879 ! write(*,*) 'CalcCgpf Zadj(i,j)=',i,j,Zadj(i,j),Xadj(i,j)
7880 
7881  ! allocation of array for det(Z)- and det(X)-expanded C-coefficients
7882  rmaxexp = rmaxb+1
7883  allocate(cexpgpf(0:max(rmax/2,1),0:rmaxexp-2,0:rmaxexp-2,0:ordgpf_max))
7884 
7885  ! calculate Cuv
7886  allocate(cuvexpgpf(0:rmaxexp,0:rmaxexp,0:rmaxexp))
7887  call calccuv(cuvexpgpf,buv_0,mm02,f,rmaxexp,id)
7888  cuv(0:rmax,0:rmax,0:rmax) = cuvexpgpf(0:rmax,0:rmax,0:rmax)
7889 
7890  ! allocate arrays for error propagation
7891  allocate(c00_err(0:rmaxexp))
7892  allocate(cij_err(0:rmaxexp))
7893  allocate(c00_err2(0:rmaxexp))
7894  allocate(cij_err2(0:rmaxexp))
7895 
7896  ! initialize accuracy estimates
7897  cerr = acc_inf
7898  cij_err =0d0
7899  c00_err =0d0
7900 
7901  cerr2 = acc_inf
7902  cij_err2 =0d0
7903  c00_err2 =0d0
7904 
7905 ! maxZadjf = maxval(abs(Zadjf))
7906 ! fmax = maxval(abs(f))
7907 
7908  ! truncation of expansion if calculated term larger than truncfacexp * previous term
7909  ! crucial for expansion parameters between 0.1 and 1 !!!
7910 ! truncfacexp = sqrt(max(maxZadjf,abs(detZ))/abs(Xadj(i,j))*max(1d0,fmax/abs(Zadj(k,l)))) * truncfacC
7911  truncfacexp = sqrt(fac_gpf) * truncfacc
7912  gtrunc = ordgpf_max
7913 
7914 #ifdef Cgpftest
7915  write(*,*) 'CalcCgpf: gtrunc orig=',gtrunc
7916  write(*,*) 'CalcCgpf: rmaxExp-2=',rmaxexp-2
7917 #endif
7918 
7919 ! calculate C(1,n1,n2) up to rank r+2
7920 ! calculate C(0,n1,n2) up to rank r
7921  rloop: do r=0,rmaxexp-2
7922 
7923 #ifdef Cgpftest
7924  write(*,*) 'CalcCgpf: rloop=',r,rmaxexp-2,rmax+2*gtrunc+2
7925  write(*,*) 'CalcCgpf: rloop=',rmax,gtrunc
7926 #endif
7927 
7928  if (r.gt.rmax+2*gtrunc+2) exit rloop
7929 
7930  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7931  ! 0th-order coefficients
7932  !!!!!!!!!!!!!!!!!!!!!!!!!!!!
7933 
7934  ! calculating C_00ijk.. exploiting eq. (5.71)
7935  maxcexpgpf(1,r,0)=0d0
7936  do nl=r,0,-1
7937  nlt=r-nl
7938  inds0(l) = nl
7939  inds0(lt) = nlt
7940 
7941  inds(l) = nl+1
7942  inds(lt) = nlt
7943 
7944  caux = shat(0,inds(1),inds(2),k)
7945 
7946  cexpgpf(1,inds0(1),inds0(2),0) = caux/(2*(nl+1))
7947  maxcexpgpf(1,r,0) = maxcexpgpf(1,r,0) + abs(cexpgpf(1,inds0(1),inds0(2),0) )
7948 ! if (r+2.le.rmax) then ! for fixed rank
7949  if (r+1.le.rmax) then
7950  c(1,inds0(1),inds0(2)) = cexpgpf(1,inds0(1),inds0(2),0)
7951  end if
7952 
7953  end do
7954 
7955  ! calculate C_ijkl.. exploiting eq. (5.72)
7956  maxcexpgpf(0,r,0)=0d0
7957  do n1=0,r
7958  n2 = r-n1
7959  inds(1) = n1
7960  inds(2) = n2
7961 
7962  caux = 2*(4+r+r)*cexpgpf(1,n1,n2,0) - 4*cuvexpgpf(1,n1,n2) &
7963  - 2*b_0(0,n1,n2)
7964 
7965  cexpgpf(0,n1,n2,0) = caux/(2d0*m02)
7966 
7967  maxcexpgpf(0,r,0) = maxcexpgpf(0,r,0) + abs(cexpgpf(0,n1,n2,0))
7968  if (r.le.rmax) then
7969  c(0,n1,n2) = cexpgpf(0,n1,n2,0)
7970  end if
7971 
7972  end do
7973 
7974  if (r.le.rmax) then
7975 ! Cerr(r) = abs(maxZadjf/Xadj(i,j))*maxCexpgpf(0,r,0)
7976  cerr(r) = fac_gpf*maxcexpgpf(0,r,0)
7977 
7978 ! write(*,*) 'CalcCgpf Cerr,0 ',r,Cerr(r),fac_gpf,maxCexpgpf(0,r,0)
7979 
7980  end if
7981 
7982  ! error propagation from B's
7983  c00_err(r+2) = b_err /2d0
7984  cij_err(r) = max(b_err,2*(r+2)*c00_err(r+2))/abs(m02)
7985 
7986  c00_err2(r+2) = b_err /2d0
7987  cij_err2(r) = max(b_err,2*(r+2)*c00_err2(r+2))/abs(m02)
7988 
7989 
7990 #ifdef Cgpftest
7991  write(*,*) 'CalcCgpf leading terms r =',r
7992  write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:r)
7993  write(*,*) 'CalcCgpf Cexp0(1,0,0)=',r,c(1,0,0),cexpgpf(1,0,0,0)
7994  write(*,*) 'CalcCgpf Cexp0(0,0,0)=',r,c(0,0,0),cexpgpf(0,0,0,0)
7995 #endif
7996 
7997 
7998 
7999 
8000  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8001  ! higher order coefficients
8002  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8003 
8004  rg = r
8005  gloop: do g=1,min(gtrunc,r/2)
8006  rg = rg-2
8007 
8008  ! calculating C_00ijk.. exploiting eq. (5.71)
8009  maxcexpgpf(1,rg,g) = 0d0
8010  do nl=rg,0,-1
8011  nlt=rg-nl
8012  inds0(l) = nl
8013  inds0(lt) = nlt
8014 
8015  inds(l) = nl+1
8016  inds(lt) = nlt
8017  caux = -f(k)*cexpgpf(0,inds(1),inds(2),g-1)
8018 
8019  inds(l) = inds(l)+1
8020  caux = caux - z(k,l)*cexpgpf(0,inds(1),inds(2),g-1)
8021 
8022  inds(l) = inds(l)-1
8023  inds(lt) = inds(lt)+1
8024  caux = caux - z(k,lt)*cexpgpf(0,inds(1),inds(2),g-1)
8025 
8026  cexpgpf(1,inds0(1),inds0(2),g) = caux/(2*(nl+1))
8027 
8028  maxcexpgpf(1,rg,g) = maxcexpgpf(1,rg,g) + abs(cexpgpf(1,inds0(1),inds0(2),g) )
8029 
8030  if (g.eq.1.and.abs(cexpgpf(1,inds0(1),inds0(2),g)).gt. &
8031  truncfacexp*max(1d0,maxcexpgpf(1,rg,g-1)) .or. &
8032  g.ge.2.and.abs(cexpgpf(1,inds0(1),inds0(2),g)).gt. &
8033  truncfacexp*maxcexpgpf(1,rg,g-1)) then
8034 #ifdef Cgpftest
8035  write(*,*) 'CalcCgpf exit gloop',n1,n2,g,abs(cexpgpf(1,inds0(1),inds0(2),g)),maxcexpgpf(1,rg,g-1)
8036  write(*,*) 'CalcCgpf exit gloop',g,rg,inds0(1),inds0(2)
8037 #endif
8038 
8039  gtrunc = g-1
8040  exit gloop
8041 
8042  end if
8043 
8044  end do
8045 
8046 #ifndef PPEXP00
8047 ! if (rg+2.le.rmax) then ! for fixed rank
8048  if (rg+1.le.rmax) then
8049  do nl=rg,0,-1
8050  nlt=rg-nl
8051  inds0(l) = nl
8052  inds0(lt) = nlt
8053  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
8054  + cexpgpf(1,inds0(1),inds0(2),g)
8055  end do
8056  end if
8057 #endif
8058 
8059  ! calculate C_ijkl.. exploiting eq. (5.72)
8060  maxcexpgpf(0,rg,g) = 0d0
8061  do n1=0,rg
8062  n2 = rg-n1
8063  inds(1) = n1
8064  inds(2) = n2
8065 
8066  caux = 2*(4+rg+rg)*cexpgpf(1,n1,n2,g)
8067 
8068  do i=1,2
8069  do j=1,2
8070  inds(i)=inds(i)+1
8071  inds(j)=inds(j)+1
8072  caux = caux + z(i,j)*cexpgpf(0,inds(1),inds(2),g-1)
8073  inds(i)=inds(i)-1
8074  inds(j)=inds(j)-1
8075  end do
8076  end do
8077 
8078  cexpgpf(0,n1,n2,g) = caux/(2*m02)
8079 
8080  maxcexpgpf(0,rg,g) = maxcexpgpf(0,rg,g) + abs(cexpgpf(0,n1,n2,g))
8081 
8082  if (g.eq.1.and.abs(cexpgpf(0,n1,n2,g)).gt. &
8083  truncfacexp*max(1d0/m2scale,maxcexpgpf(0,rg,g-1)).or. &
8084  g.ge.2.and.abs(cexpgpf(0,n1,n2,g)).gt. &
8085  truncfacexp*maxcexpgpf(0,rg,g-1)) then
8086 
8087 #ifdef Cgpftest
8088  write(*,*) 'CalcCgpf exit gloop',n1,n2,g,rg
8089  write(*,*) 'CalcCgpf exit gloop',abs(cexpgpf(0,n1,n2,g)),maxcexpgpf(0,rg,g-1),1d0/m2scale
8090  write(*,*) 'CalcCgpf exit gloop',truncfacexp
8091 #endif
8092 
8093  gtrunc = g-1
8094  exit gloop
8095 
8096  end if
8097 
8098 ! if ((g.ge.2).and.(abs(Cexpgpf(0,n1,n2,g)).gt.truncfacexp*abs(Cexpgpf(0,n1,n2,g-1)))) then
8099 ! gtrunc = g-1
8100 ! end if
8101 
8102  end do
8103 
8104 #ifdef Cgpftest
8105  write(*,*) 'CalcCgpf expansion terms r =',r,g,rg
8106  write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:r)
8107  write(*,*) 'CalcCgpf Cexp(1,0,0)=',r,g,cexpgpf(1,0,0,g)
8108  write(*,*) 'CalcCgpf Cexp(0,0,0)=',r,g,cexpgpf(0,0,0,g)
8109 #endif
8110 
8111  ! error propagation from B's
8112  if(rg.gt.1)then
8113  c00_err(rg+2) =max(c00_err(rg+2), &
8114  fmax/2d0*cij_err(rg+1), &
8115  maxz/2d0*cij_err(rg+2))
8116  end if
8117 
8118 #ifdef Cgpftest
8119  write(*,*) 'CalcCgpf test2',rg,i,j,cij_err(rg)
8120  write(*,*) 'CalcCgpf test2',rg,cij_err(rg+1),c00_err(rg+1)
8121 #endif
8122 
8123  cij_err(rg)= max( cij_err(rg), &
8124  2*(rg+2)/abs(m02)*c00_err(rg+2), &
8125  maxz/(2*abs(m02))*cij_err(rg+2))
8126 
8127  if(rg.gt.1)then
8128  c00_err2(rg+2) =max(c00_err2(rg+2), &
8129  fmax/2d0*cij_err(rg+1), &
8130  maxz/2d0*cij_err(rg+2))
8131  end if
8132 
8133  cij_err2(rg)= max( cij_err2(rg), &
8134  2*(rg+2)/abs(m02)*c00_err2(rg+2), &
8135  maxz/(2*abs(m02))*cij_err2(rg+2))
8136 
8137 #ifdef PPEXP00
8138 ! if (rg+2.le.rmax) then ! for fixed rank
8139  if (rg+1.le.rmax) then
8140  do nl=rg,0,-1
8141  nlt=rg-nl
8142  inds0(l) = nl
8143  inds0(lt) = nlt
8144  c(1,inds0(1),inds0(2)) = c(1,inds0(1),inds0(2)) &
8145  + cexpgpf(1,inds0(1),inds0(2),g)
8146  end do
8147  end if
8148 #endif
8149 
8150  if ((rg.le.rmax)) then
8151  cerr(rg) = 0d0
8152  do n1=0,rg
8153  n2=rg-n1
8154  c(0,n1,n2) = c(0,n1,n2) + cexpgpf(0,n1,n2,g)
8155 
8156 #ifdef Cgpftest
8157  write(*,*) 'CalcCgpf test1',rg,n1,n2,cerr(rg)
8158  write(*,*) 'CalcCgpf test1',cexpgpf(0,n1,n2,g)
8159  write(*,*) 'CalcCgpf test1',cexpgpf(0,n1,n2,g-1)
8160 #endif
8161 
8162  if(abs(cexpgpf(0,n1,n2,g-1)).ne.0d0) then
8163  cerr(rg)=max(cerr(rg),abs(cexpgpf(0,n1,n2,g))*min(1d0,abs(cexpgpf(0,n1,n2,g))/abs(cexpgpf(0,n1,n2,g-1))))
8164  else
8165  cerr(rg)=max(cerr(rg),abs(cexpgpf(0,n1,n2,g)))
8166  end if
8167 
8168 #ifdef Cgpftest
8169  write(*,*) 'CalcCgpf test1',cerr(rg)
8170 #endif
8171 
8172 #ifdef Cgpftest
8173  write(*,*) 'CalcCgpf expansion terms r =',r,g,rg
8174  write(*,*) 'CalcCgpf Cij_err =',r,cij_err(0:min(r,rmax))
8175  write(*,*) 'CalcCgpf Cerr =',r,cerr(0:min(r,rmax))
8176  write(*,*) 'CalcCgpf C(1,0,0)=',r,c(1,0,0)
8177  write(*,*) 'CalcCgpf C(0,0,0)=',r,c(0,0,0)
8178 #endif
8179 
8180  end do
8181 
8182  ! if error from B's larger than error from expansion stop expansion
8183  if(cij_err(rg).gt.cerr(rg)) then
8184  gtrunc = min(g,gtrunc)
8185 ! gtrunc = min(g+1,gtrunc)
8186 
8187 #ifdef Cgpftest
8188  write(*,*) 'CalcCgpf adjust gtrunc',r,g,gtrunc
8189 #endif
8190 
8191  end if
8192 
8193  end if
8194 
8195  end do gloop
8196 
8197 ! write(*,*) 'CalcCgpf gtrunc aft gloop=',gtrunc,r
8198 
8199 #ifdef Cgpftest
8200  write(*,*) 'CalcCgpf Cerr r =',r
8201  write(*,*) 'CalcCgpf Cerr r =',r,cerr(0:min(r,rmax))
8202  write(*,*) 'CalcCgpf Cacc r =',r,cerr/abs(c(0,0,0))
8203  write(*,*) 'CalcCgpf Cij_err =',r,cij_err
8204  write(*,*) 'CalcCgpf C(1,0,0)=',r,c(1,0,0)
8205  write(*,*) 'CalcCgpf C(0,0,0)=',r,c(0,0,0)
8206  if(rmax.ge.1.and.r.ge.1) then
8207  write(*,*) 'CalcCgpf C(0,1,0)=',r,c(0,1,0)
8208  if(rmax.ge.2.and.r.ge.2) then
8209  write(*,*) 'CalcCgpf C(0,1,1)=',r,c(0,1,1)
8210  if(rmax.ge.3.and.r.ge.3) then
8211  write(*,*) 'CalcCgpf C(0,1,2)=',r,c(0,1,2)
8212  if(rmax.ge.4) then
8213  write(*,*) 'CalcCgpf C(0,0,4)=',r,c(0,0,4)
8214  endif
8215  endif
8216  endif
8217  endif
8218 #endif
8219 
8220  cerr2 = max(cerr,cij_err2(0:rmax))
8221  cerr = max(cerr,cij_err(0:rmax))
8222 
8223 #ifdef Cgpftest
8224  write(*,*) 'CalcCgpf Cerr =',r,cerr,maxval(cerr)
8225 #endif
8226 
8227  ! check if target precision already reached
8228 ! if(maxval(Cerr-acc_req_Cr*abs(C(0,0,0))).le.0d0) exit ! changed 28.01.15
8229 #ifdef Cutrloop
8230  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0) then
8231  do rg=r+1,rmax
8232  do n1=0,rg
8233  c(0,n1,rg-n1)=0d0
8234  end do
8235  end do
8236  do rg=r+1,rmax
8237  do n1=0,rg-2
8238  c(1,n1,rg-2-n1)=0d0
8239  end do
8240  end do
8241 #else
8242  if(maxval(cerr-acc_req_cr*abs(c(0,0,0))).le.0d0.and.r.ge.rmax) then
8243 #endif
8244 
8245 #ifdef Cgpftest
8246  write(*,*) 'CalcCgpf exit rloop',r,cerr,maxval(cerr)
8247 #endif
8248 
8249  exit rloop
8250 
8251  end if
8252 
8253  end do rloop
8254 
8255 
8256  ! calculating C_0000ijk.. exploiting eq. (5.71)
8257  do r=4,rmax
8258 ! do n0=2,rmax/2 ! for fixed rank
8259  do n0=2,rmax
8260  do nl=r-2*n0,0,-1
8261  nlt=r-2*n0-nl
8262  inds0(l) = nl
8263  inds0(lt) = nlt
8264 
8265  inds(l) = nl+1
8266  inds(lt) = nlt
8267  caux = shat(n0-1,inds(1),inds(2),k) &
8268  - f(k)*c(n0-1,inds(1),inds(2)) &
8269  - z(k,1)*c(n0-1,inds(1)+1,inds(2)) &
8270  - z(k,2)*c(n0-1,inds(1),inds(2)+1)
8271 
8272  c(n0,inds0(1),inds0(2)) = caux/(2*(nl+1))
8273 
8274  end do
8275  end do
8276  end do
8277 
8278  ! reduction formula (5.10) for n0+n1+n2=r, n0>0
8279  do r=rmax+1,2*rmax
8280  do n0=r-rmax,r/2
8281  do n1=0,r-2*n0
8282  n2 = r-2*n0-n1
8283  c(n0,n1,n2) = (b_0(n0-1,n1,n2) + 2*mm02*c(n0-1,n1,n2) + 4*cuv(n0,n1,n2) &
8284  + f(1)*c(n0-1,n1+1,n2) + f(2)*c(n0-1,n1,n2+1)) / (2*r)
8285  end do
8286  end do
8287  end do
8288 
8289 #ifdef Cgpftest
8290  write(*,*) 'CalcCgpf final err',cerr
8291  write(*,*) 'CalcCgpf final acc',cerr/abs(c(0,0,0))
8292 #endif
8293 
8294 ! write(*,*) 'CalcCgpf out',(((C((r-n1-n2)/2,n1,n2),n2=0,r-n1),n1=0,r),r=0,rmax)
8295 #ifdef TRACECout
8296  write(*,*) 'CalcCgpf rmax',rmax
8297  do r=14,rmax
8298  do n0=0,r/2
8299  do n1=0,r-2*n0
8300  write(*,*) 'CalcCgpf out',r,n0,n1,r-2*n0-n1,c(n0,n1,r-2*n0-n1)
8301  end do
8302  end do
8303  end do
8304 #endif
8305 
8306 ! write(*,*) 'CalcCgpf Cerr ',Cerr
8307 ! write(*,*) 'CalcCgpf Cerr2',Cerr2
8308 
8309  end subroutine calccgpf
8310 
8311 
8312 
8313 
8314 
8315 
8316 
8317 
8318  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8319  ! subroutine CopyCimp3(C,C_alt,Cerr,Cerr_alt,Cerr1,Cerr1_alt,Cerr2,Cerr2_alt,Crmethod,Crmethod_alt,rmax)
8320  !
8321  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
8322 
8323  subroutine copycimp3(C,C_alt,Cerr,Cerr_alt,Cerr1,Cerr1_alt,Cerr2,Cerr2_alt,Crmethod,Crmethod_alt,rmax,r_alt)
8324 
8325  integer, intent(in) :: rmax,r_alt
8326  double complex, intent(inout) :: C(0:rmax,0:rmax,0:rmax)
8327  double precision, intent(inout) :: Cerr(0:rmax),Cerr1(0:rmax),Cerr2(0:rmax)
8328  integer, intent(inout) :: Crmethod(0:rmax)
8329  double complex, intent(in) :: C_alt(0:r_alt,0:r_alt,0:r_alt)
8330  double precision, intent(in) :: Cerr_alt(0:r_alt),Cerr2_alt(0:r_alt),Cerr1_alt(0:r_alt)
8331  integer, intent(in) :: Crmethod_alt(0:rmax)
8332 
8333  integer :: r,n1,n0
8334 
8335 ! write(*,*) 'CopyCimp3: Cerr =',Cerr
8336 ! write(*,*) 'CopyCimp3: Cerr_alt =',Cerr_alt
8337 
8338  do r=0,r_alt
8339  if (cerr_alt(r).lt.cerr(r)) then
8340  crmethod(r)=crmethod_alt(r)
8341  cerr(r)=cerr_alt(r)
8342  cerr1(r)=cerr1_alt(r)
8343  cerr2(r)=cerr2_alt(r)
8344  forall (n0=0:r)
8345  forall (n1=0:r-n0)
8346  c(n0,n1,r-n0-n1) = c_alt(n0,n1,r-n0-n1)
8347  end forall
8348  end forall
8349 ! forall (n1=0:r)
8350 ! forall (n2=0:r-n1)
8351 ! C((r-n1-n2)/2,n1,n2) = C_alt((r-n1-n2)/2,n1,n2)
8352 ! end forall
8353 ! end forall
8354  end if
8355  end do
8356 
8357  end subroutine copycimp3
8358 
8359 
8360 end module reductionc
8361 
reductionc::copycimp3
subroutine copycimp3(C, C_alt, Cerr, Cerr_alt, Cerr1, Cerr1_alt, Cerr2, Cerr2_alt, Crmethod, Crmethod_alt, rmax, r_alt)
Definition: reductionC.F90:8324
globalc::detzmzadjf
double complex detzmzadjf
Definition: reductionC.F90:52
globalc::azadjff
double precision azadjff
Definition: reductionC.F90:51
reductionc::truncfacc
double precision, parameter truncfacc
Definition: reductionC.F90:82
coli_stat::ccountoffset1
integer, parameter ccountoffset1
Definition: coli_stat.F90:35
globalc::fmax
double precision fmax
Definition: reductionC.F90:51
reductionc::calccg
subroutine calccg(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordg_min, ordg_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:4717
globalc::xadj
double complex, dimension(0:2, 0:2) xadj
Definition: reductionC.F90:50
globalc::xadjshift
double complex, dimension(0:2, 0:2) xadjshift
Definition: reductionC.F90:60
reductionab::calcb
subroutine calcb(B, Buv, p10, m02, m12, rmax, id, Berr)
Definition: reductionAB.F90:92
globalc::maxzadjf
double precision maxzadjf
Definition: reductionC.F90:51
globalc::m2max
double precision m2max
Definition: reductionC.F90:51
reductionc::calccgn
subroutine calccgn(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordg_min, ordg_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:4089
reductionc::calcc
subroutine calcc(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr1, Cerr2, rbasic, acc_req_Cextra)
Definition: reductionC.F90:95
coli_stat::ccountoffset2
integer, parameter ccountoffset2
Definition: coli_stat.F90:36
globalc::zadjshift
double complex, dimension(2, 2) zadjshift
Definition: reductionC.F90:60
globalc::fac_gy
double precision fac_gy
Definition: reductionC.F90:55
globalc::m2scale
double precision m2scale
Definition: reductionC.F90:51
coli_stat::ccountoffset3
integer, parameter ccountoffset3
Definition: coli_stat.F90:37
globalc::adetzshift
double precision adetzshift
Definition: reductionC.F90:59
globalc::zadjf
double complex, dimension(2) zadjf
Definition: reductionC.F90:50
globalc::mm12
double complex mm12
Definition: reductionC.F90:49
globalc::fac_gr
double precision fac_gr
Definition: reductionC.F90:55
reductionc
Definition: reductionC.F90:73
globalc
Definition: reductionC.F90:47
globalc::q10
double complex q10
Definition: reductionC.F90:49
reductionc::calccuv
subroutine calccuv(Cuv, Buv_0, m02, f, rmax, id)
Definition: reductionC.F90:2442
reductionc::calccpvshift
subroutine calccpvshift(Cshift, Cuvshift, p10shift, p21shift, p20shift, m02shift, m12shift, m22shift, rmax, id, Cerr, Cerr2)
Definition: reductionC.F90:3755
coli_stat::ccountoffset0
integer, parameter ccountoffset0
Definition: coli_stat.F90:34
globalc::q20shift
double complex q20shift
Definition: reductionC.F90:58
globalc::maxz
double precision maxz
Definition: reductionC.F90:51
globalc::maxzadjfd
double precision maxzadjfd
Definition: reductionC.F90:51
globalc::q21shift
double complex q21shift
Definition: reductionC.F90:58
globalc::detxshift
double complex detxshift
Definition: reductionC.F90:60
globalc::wmaxzadj
double precision wmaxzadj
Definition: reductionC.F90:56
globalc::q2max
double precision q2max
Definition: reductionC.F90:51
globalc::zshift
double complex, dimension(2, 2) zshift
Definition: reductionC.F90:60
globalc::azadjffshift
double precision azadjffshift
Definition: reductionC.F90:59
globalc::detzshift
double complex detzshift
Definition: reductionC.F90:60
globalc::detx
double complex detx
Definition: reductionC.F90:50
reductionc::calccgpf
subroutine calccgpf(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgpf_min, ordgpf_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:7741
reductionc::calccgr
subroutine calccgr(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgr_min, ordgr_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:5331
globalc::maxzadjfshift
double precision maxzadjfshift
Definition: reductionC.F90:59
reductionc::calccred
subroutine calccred(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr1, Cerr2, rbasic, acc_req_Cextra)
Definition: reductionC.F90:322
globalc::maxzshift
double precision maxzshift
Definition: reductionC.F90:59
globalc::fac_gpf
double precision fac_gpf
Definition: reductionC.F90:55
globalc::wmaxzadjf
double precision wmaxzadjf
Definition: reductionC.F90:56
globalc::fac_gp
double precision fac_gp
Definition: reductionC.F90:55
globalc::q20
double complex q20
Definition: reductionC.F90:49
reductionc::calccpv
subroutine calccpv(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
Definition: reductionC.F90:3130
globalc::mm02
double complex mm02
Definition: reductionC.F90:49
coli_stat::ccount
integer(kind=8), dimension(0:ncountc) ccount
Definition: coli_stat.F90:44
globalc::mm12shift
double complex mm12shift
Definition: reductionC.F90:58
globalc::mx
double complex, dimension(0:2, 0:2) mx
Definition: reductionC.F90:53
globalc::mxshift
double complex, dimension(0:2, 0:2) mxshift
Definition: reductionC.F90:62
reductionc::calccgyo
subroutine calccgyo(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgy_min, ordgy_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:6706
globalc::maxxadj
double precision maxxadj
Definition: reductionC.F90:51
globalc::zadj
double complex, dimension(2, 2) zadj
Definition: reductionC.F90:50
globalc::mm22shift
double complex mm22shift
Definition: reductionC.F90:58
globalc::maxzadj
double precision maxzadj
Definition: reductionC.F90:54
reductionc::calccpv1o
subroutine calccpv1o(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
Definition: reductionC.F90:2826
globalc::zinvshift
double complex, dimension(2, 2) zinvshift
Definition: reductionC.F90:61
globalc::zadjsshift
double complex, dimension(2) zadjsshift
Definition: reductionC.F90:61
globalc::zinv
double complex, dimension(2, 2) zinv
Definition: reductionC.F90:52
coli_stat
Definition: coli_stat.F90:22
globalc::fac_g
double precision fac_g
Definition: reductionC.F90:55
globalc::adetx
double precision adetx
Definition: reductionC.F90:51
globalc::detzmzadjfshift
double complex detzmzadjfshift
Definition: reductionC.F90:61
reductionc::calccpv2
subroutine calccpv2(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
Definition: reductionC.F90:3434
globalc::undefined_c
double complex, parameter undefined_c
Definition: reductionC.F90:65
reductionc::calccgp
subroutine calccgp(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgp_min, ordgp_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:7274
globalc::zadjs
double complex, dimension(2) zadjs
Definition: reductionC.F90:52
globalc::fmaxshift
double precision fmaxshift
Definition: reductionC.F90:59
globalc::adetz
double precision adetz
Definition: reductionC.F90:51
reductionc::calccpv1
subroutine calccpv1(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
Definition: reductionC.F90:2487
globalc::mm22
double complex mm22
Definition: reductionC.F90:49
globalc::fshift
double complex, dimension(2) fshift
Definition: reductionC.F90:60
globalc::q10shift
double complex q10shift
Definition: reductionC.F90:58
globalc::maxzadjshift
double precision maxzadjshift
Definition: reductionC.F90:63
globalc::mxinvshift
double complex, dimension(0:2, 0:2) mxinvshift
Definition: reductionC.F90:62
globalc::z
double complex, dimension(2, 2) z
Definition: reductionC.F90:50
globalc::mm02shift
double complex mm02shift
Definition: reductionC.F90:58
globalc::f
double complex, dimension(2) f
Definition: reductionC.F90:50
reductionab
Definition: reductionAB.F90:28
globalc::zadjfshift
double complex, dimension(2) zadjfshift
Definition: reductionC.F90:60
globalc::q21
double complex q21
Definition: reductionC.F90:49
globalc::adetxshift
double precision adetxshift
Definition: reductionC.F90:59
globalc::mxinv
double complex, dimension(0:2, 0:2) mxinv
Definition: reductionC.F90:53
globalc::wmaxxadj
double precision wmaxxadj
Definition: reductionC.F90:56
reductionc::calccgy
subroutine calccgy(C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgy_min, ordgy_max, id, Cerr, acc_req_Cr, Cerr2)
Definition: reductionC.F90:6070
globalc::detz
double complex detz
Definition: reductionC.F90:50