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

Functions/Subroutines

subroutine calcc (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr1, Cerr2, rbasic, acc_req_Cextra)
 
subroutine calccred (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr1, Cerr2, rbasic, acc_req_Cextra)
 
subroutine calccuv (Cuv, Buv_0, m02, f, rmax, id)
 
subroutine calccpv1 (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
 
subroutine calccpv1o (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
 
subroutine calccpv (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
 
subroutine calccpv2 (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, id, Cerr, Cerr2)
 
subroutine calccpvshift (Cshift, Cuvshift, p10shift, p21shift, p20shift, m02shift, m12shift, m22shift, rmax, id, Cerr, Cerr2)
 
subroutine calccgn (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordg_min, ordg_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccg (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordg_min, ordg_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccgr (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgr_min, ordgr_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccgy (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgy_min, ordgy_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccgyo (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgy_min, ordgy_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccgp (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgp_min, ordgp_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine calccgpf (C, Cuv, p10, p21, p20, m02, m12, m22, rmax, ordgpf_min, ordgpf_max, id, Cerr, acc_req_Cr, Cerr2)
 
subroutine copycimp3 (C, C_alt, Cerr, Cerr_alt, Cerr1, Cerr1_alt, Cerr2, Cerr2_alt, Crmethod, Crmethod_alt, rmax, r_alt)
 

Variables

double precision, parameter truncfacc = 1d2
 

Function/Subroutine Documentation

◆ calcc()

subroutine reductionc::calcc ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr1,
double precision, dimension(0:rmax), intent(out)  Cerr2,
integer, intent(in), optional  rbasic,
double precision, dimension(0:rmax), intent(in), optional  acc_req_Cextra 
)

Definition at line 95 of file reductionC.F90.

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 

◆ calccg()

subroutine reductionc::calccg ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordg_min,
integer, intent(in)  ordg_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 4717 of file reductionC.F90.

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 

◆ calccgn()

subroutine reductionc::calccgn ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordg_min,
integer, intent(in)  ordg_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 4089 of file reductionC.F90.

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 

◆ calccgp()

subroutine reductionc::calccgp ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordgp_min,
integer, intent(in)  ordgp_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 7274 of file reductionC.F90.

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 

◆ calccgpf()

subroutine reductionc::calccgpf ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordgpf_min,
integer, intent(in)  ordgpf_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 7741 of file reductionC.F90.

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 

◆ calccgr()

subroutine reductionc::calccgr ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordgr_min,
integer, intent(in)  ordgr_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 5331 of file reductionC.F90.

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 

◆ calccgy()

subroutine reductionc::calccgy ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordgy_min,
integer, intent(in)  ordgy_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 6070 of file reductionC.F90.

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 

◆ calccgyo()

subroutine reductionc::calccgyo ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  ordgy_min,
integer, intent(in)  ordgy_max,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(in)  acc_req_Cr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 6706 of file reductionC.F90.

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 

◆ calccpv()

subroutine reductionc::calccpv ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 3130 of file reductionC.F90.

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 

◆ calccpv1()

subroutine reductionc::calccpv1 ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 2487 of file reductionC.F90.

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 

◆ calccpv1o()

subroutine reductionc::calccpv1o ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 2826 of file reductionC.F90.

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 

◆ calccpv2()

subroutine reductionc::calccpv2 ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 3434 of file reductionC.F90.

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 

◆ calccpvshift()

subroutine reductionc::calccpvshift ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cshift,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuvshift,
double complex, intent(in)  p10shift,
double complex, intent(in)  p21shift,
double complex, intent(in)  p20shift,
double complex, intent(in)  m02shift,
double complex, intent(in)  m12shift,
double complex, intent(in)  m22shift,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr,
double precision, dimension(0:rmax), intent(out)  Cerr2 
)

Definition at line 3755 of file reductionC.F90.

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 

◆ calccred()

subroutine reductionc::calccred ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  C,
double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, intent(in)  p10,
double complex, intent(in)  p21,
double complex, intent(in)  p20,
double complex, intent(in)  m02,
double complex, intent(in)  m12,
double complex, intent(in)  m22,
integer, intent(in)  rmax,
integer, intent(in)  id,
double precision, dimension(0:rmax), intent(out)  Cerr1,
double precision, dimension(0:rmax), intent(out)  Cerr2,
integer, intent(in), optional  rbasic,
double precision, dimension(0:rmax), intent(in), optional  acc_req_Cextra 
)

Definition at line 322 of file reductionC.F90.

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 

◆ calccuv()

subroutine reductionc::calccuv ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(out)  Cuv,
double complex, dimension(0:rmax-1,0:rmax-1,0:rmax-1), intent(in)  Buv_0,
double complex, intent(in)  m02,
double complex, dimension(2), intent(in)  f,
integer, intent(in)  rmax,
integer, intent(in)  id 
)

Definition at line 2442 of file reductionC.F90.

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 

◆ copycimp3()

subroutine reductionc::copycimp3 ( double complex, dimension(0:rmax,0:rmax,0:rmax), intent(inout)  C,
double complex, dimension(0:r_alt,0:r_alt,0:r_alt), intent(in)  C_alt,
double precision, dimension(0:rmax), intent(inout)  Cerr,
double precision, dimension(0:r_alt), intent(in)  Cerr_alt,
double precision, dimension(0:rmax), intent(inout)  Cerr1,
double precision, dimension(0:r_alt), intent(in)  Cerr1_alt,
double precision, dimension(0:rmax), intent(inout)  Cerr2,
double precision, dimension(0:r_alt), intent(in)  Cerr2_alt,
integer, dimension(0:rmax), intent(inout)  Crmethod,
integer, dimension(0:rmax), intent(in)  Crmethod_alt,
integer, intent(in)  rmax,
integer, intent(in)  r_alt 
)

Definition at line 8324 of file reductionC.F90.

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 

Variable Documentation

◆ truncfacc

double precision, parameter reductionc::truncfacc = 1d2

Definition at line 82 of file reductionC.F90.

82  double precision, parameter :: truncfacC = 1d2
globalc::detzmzadjf
double complex detzmzadjf
Definition: reductionC.F90:52
globalc::azadjff
double precision azadjff
Definition: reductionC.F90:51
globalc::fmax
double precision fmax
Definition: reductionC.F90:51
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
globalc::maxzadjf
double precision maxzadjf
Definition: reductionC.F90:51
globalc::m2max
double precision m2max
Definition: reductionC.F90:51
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
globalc::adetzshift
double precision adetzshift
Definition: reductionC.F90:59
globalc::zadjf
double complex, dimension(2) zadjf
Definition: reductionC.F90:50
globalc::fac_gr
double precision fac_gr
Definition: reductionC.F90:55
globalc
Definition: reductionC.F90:47
globalc::q10
double complex q10
Definition: reductionC.F90:49
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::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
globalc::maxzadjfshift
double precision maxzadjfshift
Definition: reductionC.F90:59
globalc::maxzshift
double precision maxzshift
Definition: reductionC.F90:59
globalc::fac_gpf
double precision fac_gpf
Definition: reductionC.F90:55
globalc::fac_gp
double precision fac_gp
Definition: reductionC.F90:55
globalc::q20
double complex q20
Definition: reductionC.F90:49
globalc::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
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
globalc::zadjsshift
double complex, dimension(2) zadjsshift
Definition: reductionC.F90:61
globalc::zinv
double complex, dimension(2, 2) zinv
Definition: reductionC.F90:52
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
globalc::undefined_c
double complex, parameter undefined_c
Definition: reductionC.F90:65
globalc::zadjs
double complex, dimension(2) zadjs
Definition: reductionC.F90:52
globalc::adetz
double precision adetz
Definition: reductionC.F90:51
globalc::mm22
double complex mm22
Definition: reductionC.F90:49
globalc::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
globalc::zadjfshift
double complex, dimension(2) zadjfshift
Definition: reductionC.F90:60
globalc::q21
double complex q21
Definition: reductionC.F90:49
globalc::mxinv
double complex, dimension(0:2, 0:2) mxinv
Definition: reductionC.F90:53
globalc::detz
double complex detz
Definition: reductionC.F90:50