← Back to branch summary

~maddevelopers/mg5amcnlo/3.0.1

« back to all changes in this revision

Viewing changes to vendor/CutTools/src/avh/avh_olo.f90

  • Committer: Marco Zaro
  • Date: 2014-01-27 16:54:10 UTC
  • mfrom: (78.124.55 MG5_aMC_2.1)
  • Revision ID: marco.zaro@gmail.com-20140127165410-5lma8c2hzbzm426j
merged with lp:~maddevelopers/madgraph5/MG5_aMC_2.1 r 267

Show diffs side-by-side

added added

removed removed

Lines of Context:
vendor/CutTools/src/avh/avh_olo.f90
1
1
!
2
 
! Copyright (C) 2012 Andreas van Hameren. 
3
 
!
4
 
! This file is part of OneLOop-3.2.
5
 
!
6
 
! OneLOop-3.2 is free software: you can redistribute it and/or modify
 
2
! Copyright (C) 2014 Andreas van Hameren. 
 
3
!
 
4
! This file is part of OneLOop-3.4.
 
5
!
 
6
! OneLOop-3.4 is free software: you can redistribute it and/or modify
7
7
! it under the terms of the GNU General Public License as published by
8
8
! the Free Software Foundation, either version 3 of the License, or
9
9
! (at your option) any later version.
10
10
!
11
 
! OneLOop-3.2 is distributed in the hope that it will be useful,
 
11
! OneLOop-3.4 is distributed in the hope that it will be useful,
12
12
! but WITHOUT ANY WARRANTY; without even the implied warranty of
13
13
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14
14
! GNU General Public License for more details.
15
15
!
16
16
! You should have received a copy of the GNU General Public License
17
 
! along with OneLOop-3.2.  If not, see <http://www.gnu.org/licenses/>.
 
17
! along with OneLOop-3.4.  If not, see <http://www.gnu.org/licenses/>.
18
18
!
19
19
 
20
20
 
28
28
  if (done) return ;done=.true.
29
29
  write(*,'(a72)') '########################################################################'
30
30
  write(*,'(a72)') '#                                                                      #'
31
 
  write(*,'(a72)') '#                      You are using OneLOop-3.2                       #'
 
31
  write(*,'(a72)') '#                      You are using OneLOop-3.4                       #'
32
32
  write(*,'(a72)') '#                                                                      #'
33
33
  write(*,'(a72)') '# for the evaluation of 1-loop scalar 1-, 2-, 3- and 4-point functions #'
34
34
  write(*,'(a72)') '#                                                                      #'
35
35
  write(*,'(a72)') '# author: Andreas van Hameren <hamerenREMOVETHIS@ifj.edu.pl>           #'
36
 
  write(*,'(a72)') '#   date: 19-07-2012                                                   #'
 
36
  write(*,'(a72)') '#   date: 02-01-2014                                                   #'
37
37
  write(*,'(a72)') '#                                                                      #'
38
38
  write(*,'(a72)') '# Please cite                                                          #'
39
39
  write(*,'(a72)') '#    A. van Hameren,                                                   #'
77
77
 
78
78
 
79
79
module avh_olo_dp_kinds
80
 
  integer ,parameter :: kindr2=kind(1d0)
 
80
  integer ,parameter :: kindr2=kind(1d0) 
81
81
end module
82
82
 
83
83
 
84
84
module avh_olo_dp_arrays
85
85
  use avh_olo_units
86
 
  use avh_olo_dp_kinds
 
86
  use avh_olo_dp_kinds 
87
87
  implicit none
88
88
  private
89
89
  public :: shift1,shift2,shift3,resize,enlarge
113
113
contains
114
114
 
115
115
  subroutine shift1_r( xx ,nn )
116
 
  real(kindr2) &
 
116
  real(kindr2) &  
117
117
    ,allocatable ,intent(inout) :: xx(:)
118
118
  integer        ,intent(in   ) :: nn
119
 
  real(kindr2) &
 
119
  real(kindr2) &  
120
120
    ,allocatable :: tt(:)
121
121
  integer ,parameter :: dm=1
122
122
  integer :: lb(dm),ub(dm)
157
157
  end subroutine
158
158
 
159
159
  subroutine shift2_r( xx ,nn )
160
 
  real(kindr2) &
 
160
  real(kindr2) &  
161
161
          ,allocatable ,intent(inout) :: xx(:,:)
162
162
  integer              ,intent(in   ) :: nn
163
 
  real(kindr2) &
 
163
  real(kindr2) &  
164
164
          ,allocatable :: tt(:,:)
165
165
  integer ,parameter :: dm=2
166
166
  integer :: lb(dm),ub(dm)
201
201
  end subroutine
202
202
 
203
203
  subroutine shift3_r( xx ,nn )
204
 
  real(kindr2) &
 
204
  real(kindr2) &  
205
205
    ,allocatable ,intent(inout) :: xx(:,:,:)
206
206
  integer        ,intent(in   ) :: nn
207
 
  real(kindr2) &
 
207
  real(kindr2) &  
208
208
    ,allocatable :: tt(:,:,:)
209
209
  integer ,parameter :: dm=3
210
210
  integer :: lb(dm),ub(dm)
246
246
 
247
247
 
248
248
  subroutine resize1_r( xx ,l1,u1 )
249
 
  real(kindr2) &
 
249
  real(kindr2) &  
250
250
    ,allocatable ,intent(inout) :: xx(:)
251
251
  integer        ,intent(in   ) :: l1,u1
252
 
  real(kindr2) &
 
252
  real(kindr2) &  
253
253
    ,allocatable :: tt(:)
254
254
  integer :: lb(1),ub(1)
255
255
  if (.not.allocated(xx)) then
267
267
  end subroutine 
268
268
 
269
269
  subroutine resize2_r( xx ,l1,u1 ,l2,u2 )
270
 
  real(kindr2) &
 
270
  real(kindr2) &  
271
271
    ,allocatable ,intent(inout) :: xx(:,:)
272
272
  integer        ,intent(in   ) :: l1,u1,l2,u2
273
 
  real(kindr2) &
 
273
  real(kindr2) &  
274
274
    ,allocatable :: tt(:,:)
275
275
  integer :: lb(2),ub(2)
276
276
  if (.not.allocated(xx)) then
291
291
 
292
292
 
293
293
  subroutine enlarge1_r( xx ,l1,u1 )
294
 
  real(kindr2) &
 
294
  real(kindr2) &  
295
295
    ,allocatable ,intent(inout) :: xx(:)
296
296
  integer        ,intent(in   ) :: l1,u1
297
 
  real(kindr2) &
 
297
  real(kindr2) &  
298
298
    ,allocatable :: tt(:)
299
299
  integer :: lb(1),ub(1)
300
300
  if (.not.allocated(xx)) then
303
303
  endif
304
304
  lb=lbound(xx) ;ub=ubound(xx)
305
305
  if (lb(1).le.l1.and.u1.le.ub(1)) return
 
306
  if (lb(1).gt.ub(1)) then
 
307
    deallocate( xx )
 
308
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))) )
 
309
    return
 
310
  endif
306
311
  allocate(tt(lb(1):ub(1)))
307
312
  tt = xx
308
313
  deallocate(xx)
312
317
  end subroutine 
313
318
 
314
319
  subroutine enlarge2_r( xx ,l1,u1 ,l2,u2 )
315
 
  real(kindr2) &
 
320
  real(kindr2) &  
316
321
    ,allocatable ,intent(inout) :: xx(:,:)
317
322
  integer        ,intent(in   ) :: l1,u1,l2,u2
318
 
  real(kindr2) &
 
323
  real(kindr2) &  
319
324
    ,allocatable :: tt(:,:)
320
325
  integer :: lb(2),ub(2)
321
326
  if (.not.allocated(xx)) then
325
330
  lb=lbound(xx) ;ub=ubound(xx)
326
331
  if (lb(1).le.l1.and.u1.le.ub(1).and. &
327
332
      lb(2).le.l2.and.u2.le.ub(2)      ) return
 
333
  if (lb(1).gt.ub(1).or.lb(2).gt.ub(2)) then
 
334
    deallocate( xx )
 
335
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))  &
 
336
                ,min(l2,lb(2)):max(u2,ub(2))) )
 
337
    return
 
338
  endif
328
339
  allocate(tt(lb(1):ub(1),lb(2):ub(2)))
329
340
  tt = xx
330
341
  deallocate(xx)
510
521
contains
511
522
 
512
523
  function printc( zz ,ndec ) result(rslt)
513
 
  complex(kindr2) &
 
524
  complex(kindr2) &   
514
525
    ,intent(in) :: zz
515
526
  integer,optional,intent(in) :: ndec
516
527
  character((ndecim(prcpar)+nxtr+novh)*2+3) :: rslt
527
538
  end function
528
539
 
529
540
  function printr( xx_in ,ndec_in ) result(rslt)
530
 
  real(kindr2) &
 
541
  real(kindr2) &  
531
542
                  ,intent(in) :: xx_in
532
543
  integer,optional,intent(in) :: ndec_in
533
544
  character(ndecim(prcpar)+nxtr+novh  ) :: rslt
534
545
  character(ndecim(prcpar)+nxtr+novh+1) :: cc
535
546
  character(10) :: aa,bb
536
547
  integer :: ndec
537
 
  real(kindr2) :: xx
 
548
  real(kindr2) :: xx     
538
549
  xx = xx_in
539
550
  if (present(ndec_in)) then ;ndec=ndec_in
540
551
                        else ;ndec=ndecim(prcpar)+nxtr
541
552
  endif
542
 
  write(aa,'(i10)') ndec+novh+1 ;aa=adjustl(aa)
543
 
  write(bb,'(i10)') ndec        ;bb=adjustl(bb)
 
553
  write(aa,'(i10)') min(len(cc),ndec+novh+1) ;aa=adjustl(aa)
 
554
  write(bb,'(i10)') min(len(cc),ndec       ) ;bb=adjustl(bb)
544
555
  aa = '(e'//trim(aa)//'.'//trim(bb)//')'
545
556
  write(cc,aa) xx  ;cc=adjustl(cc)
546
 
  if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:ndec*2)
547
 
  else                      ;rslt = ' '//cc(2:ndec*2)
 
557
  if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:len(cc))
 
558
  else                      ;rslt = ' '//cc(2:len(cc))
548
559
  endif
549
560
  end function
550
561
 
603
614
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
604
615
! negative imaginary.
605
616
!*******************************************************************
606
 
  complex(kindr2) &
 
617
  complex(kindr2) &   
607
618
    ,intent(in) :: xx
608
 
  complex(kindr2) &
 
619
  complex(kindr2) &   
609
620
    :: rslt ,zz
610
 
  real(kindr2) &
 
621
  real(kindr2) &  
611
622
    :: xim,xre
612
623
  xim = aimag(xx)
613
624
  if (xim.eq.RZRO) then
629
640
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
630
641
! imaginary and has the same sign as  sgn .
631
642
!*******************************************************************
632
 
  complex(kindr2) &
 
643
  complex(kindr2) &   
633
644
    ,intent(in) :: xx
634
 
  real(kindr2) &
 
645
  real(kindr2) &  
635
646
    ,intent(in) :: sgn
636
 
  complex(kindr2) &
 
647
  complex(kindr2) &   
637
648
    :: rslt ,zz
638
 
  real(kindr2) &
 
649
  real(kindr2) &  
639
650
    :: xim,xre
640
651
  xim = aimag(xx)
641
652
  if (xim.eq.RZRO) then
657
668
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
658
669
! imaginary and has the same sign as  sgn .
659
670
!*******************************************************************
660
 
  complex(kindr2) &
 
671
  complex(kindr2) &   
661
672
          ,intent(in) :: xx
662
673
  integer ,intent(in) :: sgn
663
 
  complex(kindr2) &
 
674
  complex(kindr2) &   
664
675
    :: rslt ,zz
665
 
  real(kindr2) &
 
676
  real(kindr2) &  
666
677
    :: xim,xre,hh
667
678
  xim = aimag(xx)
668
679
  if (xim.eq.RZRO) then
686
697
! Also returns  dd = aa*(x1-x2)
687
698
! If  imode=/=0  it uses  dd  as input as value of  sqrt(b^2-4*a*c)
688
699
!*******************************************************************
689
 
  complex(kindr2) &
 
700
  complex(kindr2) &   
690
701
    ,intent(out)   :: x1,x2
691
 
  complex(kindr2) &
 
702
  complex(kindr2) &   
692
703
    ,intent(inout) :: dd
693
 
  complex(kindr2) &
 
704
  complex(kindr2) &   
694
705
    ,intent(in) :: aa,bb,cc
695
706
  integer         ,intent(in) :: imode
696
 
  complex(kindr2) &
 
707
  complex(kindr2) &   
697
708
    :: qq,hh
698
 
  real(kindr2) &
 
709
  real(kindr2) &  
699
710
    :: r1,r2
700
711
 
701
712
  if (aa.eq.CZRO) then
738
749
!*******************************************************************
739
750
  intent(out) :: x1,x2
740
751
  intent(in ) :: aa,bb,cc
741
 
  complex(kindr2) &
 
752
  complex(kindr2) &   
742
753
    :: x1,x2,bb,cc ,t1,t2
743
 
  real(kindr2) &
 
754
  real(kindr2) &  
744
755
    :: aa,xx,yy,pp,qq,uu,vv,pq1,pq2,uv1,uv2,dd,xd1,xd2,yd1,yd2 &
745
756
      ,gg,hh,rx1,rx2,ix1,ix2
746
757
  if (aa.eq.RZRO) then
800
811
! If  Im(rr)  is zero, then  |rr| > 1/|rr| .
801
812
! Also returns  dd = rr - 1/rr .
802
813
!*******************************************************************
803
 
  complex(kindr2) &
 
814
  complex(kindr2) &   
804
815
    ,intent(out) :: rr,dd
805
 
  complex(kindr2) &
 
816
  complex(kindr2) &   
806
817
    ,intent(in)  :: qq
807
 
  complex(kindr2) &
 
818
  complex(kindr2) &   
808
819
    :: r2
809
 
  real(kindr2) &
 
820
  real(kindr2) &  
810
821
    :: aa,bb
811
822
  integer :: ir,ik
812
823
  dd = sqrt(qq*qq-4)
843
854
!*******************************************************************
844
855
! Like rfun, but now  dd  is input, which may get a minus sign
845
856
!*******************************************************************
846
 
  complex(kindr2) &
 
857
  complex(kindr2) &   
847
858
    ,intent(out)   :: rr
848
 
  complex(kindr2) &
 
859
  complex(kindr2) &   
849
860
    ,intent(inout) :: dd
850
 
  complex(kindr2) &
 
861
  complex(kindr2) &   
851
862
    ,intent(in)  :: qq
852
 
  complex(kindr2) &
 
863
  complex(kindr2) &   
853
864
    :: r2
854
 
  real(kindr2) &
 
865
  real(kindr2) &  
855
866
    :: aa,bb
856
867
  integer :: ir,ik
857
868
  rr = qq+dd
891
902
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
892
903
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
893
904
!*******************************************************************
894
 
  complex(kindr2) &
 
905
  complex(kindr2) &   
895
906
    ,intent(in) :: aa,bb,cc
896
 
  real(kindr2) &
 
907
  real(kindr2) &  
897
908
    ,intent(in) :: sa,sb,sc
898
 
  complex(kindr2) &
 
909
  complex(kindr2) &   
899
910
    :: rslt
900
 
  real(kindr2) &
 
911
  real(kindr2) &  
901
912
    :: ima,imb,imc
902
913
  ima = aimag(aa)
903
914
  imb = aimag(bb)
922
933
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
923
934
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
924
935
!*******************************************************************
925
 
  complex(kindr2) &
 
936
  complex(kindr2) &   
926
937
    ,intent(in) :: aa,bb,cc
927
 
  complex(kindr2) &
 
938
  complex(kindr2) &   
928
939
    :: rslt
929
 
  real(kindr2) &
 
940
  real(kindr2) &  
930
941
    :: ima,imb,imc
931
942
  ima = sgnIm(aa)
932
943
  imb = sgnIm(bb)
942
953
!*******************************************************************
943
954
! eta3(aa,b1,c1) - eta3(aa,b2,c2)
944
955
!*******************************************************************
945
 
  complex(kindr2) &
 
956
  complex(kindr2) &   
946
957
    ,intent(in) :: aa,b1,c1 ,b2,c2
947
 
  complex(kindr2) &
 
958
  complex(kindr2) &   
948
959
    :: rslt
949
 
  real(kindr2) &
 
960
  real(kindr2) &  
950
961
    :: imaa,imb1,imc1,imb2,imc2
951
962
  imaa = sgnIm(aa)
952
963
  imb1 = sgnIm(b1)
979
990
! The same as  eta3, but with  c=a*b, so that
980
991
!   eta(a,b) = log(a*b) - log(a) - log(b)
981
992
!*******************************************************************
982
 
  complex(kindr2) &
 
993
  complex(kindr2) &   
983
994
    ,intent(in) :: aa,bb
984
 
  real(kindr2) &
 
995
  real(kindr2) &  
985
996
    ,intent(in) :: sa,sb
986
 
  complex(kindr2) &
 
997
  complex(kindr2) &   
987
998
    :: rslt
988
 
  real(kindr2) &
 
999
  real(kindr2) &  
989
1000
    :: rea,reb,ima,imb,imab
990
1001
  rea = areal(aa)  ;ima = aimag(aa)
991
1002
  reb = areal(bb)  ;imb = aimag(bb)
1006
1017
  function eta2_0( aa ,bb ) result(rslt)
1007
1018
!*******************************************************************
1008
1019
!*******************************************************************
1009
 
  complex(kindr2) &
 
1020
  complex(kindr2) &   
1010
1021
    ,intent(in) :: aa,bb
1011
 
  complex(kindr2) &
 
1022
  complex(kindr2) &   
1012
1023
    :: rslt
1013
 
  real(kindr2) &
 
1024
  real(kindr2) &  
1014
1025
    :: rea,reb,ima,imb,imab
1015
1026
  rea = areal(aa)  ;ima = aimag(aa)
1016
1027
  reb = areal(bb)  ;imb = aimag(bb)
1032
1043
!*******************************************************************
1033
1044
!  p1^2 + p2^2 + p3^2 - 2*p1*p2 - 2*p2*p3 - 2*p3*p1
1034
1045
!*******************************************************************
1035
 
  complex(kindr2) &
 
1046
  complex(kindr2) &   
1036
1047
    ,intent(in) :: p1,p2,p3
1037
 
  complex(kindr2) &
 
1048
  complex(kindr2) &   
1038
1049
    :: rslt ,y1,y2,y3
1039
 
  real(kindr2) &
 
1050
  real(kindr2) &  
1040
1051
    :: b1,b2,b3
1041
1052
  y1=p2*p3 ;b1=areal(y1)
1042
1053
  y2=p3*p1 ;b2=areal(y2)
1054
1065
  function sgnIm_c(zz) result(rslt)
1055
1066
!*******************************************************************
1056
1067
!*******************************************************************
1057
 
  complex(kindr2) &
 
1068
  complex(kindr2) &   
1058
1069
    ,intent(in) :: zz
1059
1070
  integer :: rslt
1060
 
  real(kindr2) &
 
1071
  real(kindr2) &  
1061
1072
    :: imz
1062
1073
  imz = aimag(zz)
1063
1074
  if (imz.ge.RZRO) then ;rslt= 1
1068
1079
  function sgnIm_ci(zz,ii) result(rslt)
1069
1080
!*******************************************************************
1070
1081
!*******************************************************************
1071
 
  complex(kindr2) &
 
1082
  complex(kindr2) &   
1072
1083
          ,intent(in) :: zz
1073
1084
  integer ,intent(in) :: ii
1074
1085
  integer :: rslt
1075
 
  real(kindr2) &
 
1086
  real(kindr2) &  
1076
1087
    :: imz
1077
1088
  imz = aimag(zz)
1078
1089
  if     (imz.gt.RZRO) then ;rslt= 1
1084
1095
  function sgnRe_c(zz) result(rslt)
1085
1096
!*******************************************************************
1086
1097
!*******************************************************************
1087
 
  complex(kindr2) &
 
1098
  complex(kindr2) &   
1088
1099
    ,intent(in) :: zz
1089
1100
  integer :: rslt
1090
 
  real(kindr2) &
 
1101
  real(kindr2) &  
1091
1102
    :: rez
1092
1103
  rez = zz
1093
1104
  if (rez.ge.RZRO) then ;rslt= 1
1098
1109
  function sgnRe_r(rez) result(rslt)
1099
1110
!*******************************************************************
1100
1111
!*******************************************************************
1101
 
  real(kindr2) &
 
1112
  real(kindr2) &  
1102
1113
    ,intent(in) :: rez
1103
1114
  integer :: rslt
1104
1115
  if (rez.ge.RZRO) then ;rslt= 1
1109
1120
  function sgnRe_ri(rez,ii) result(rslt)
1110
1121
!*******************************************************************
1111
1122
!*******************************************************************
1112
 
  real(kindr2) &
 
1123
  real(kindr2) &  
1113
1124
          ,intent(in) :: rez
1114
1125
  integer ,intent(in) :: ii
1115
1126
  integer :: rslt
1138
1149
  private
1139
1150
  public :: update_olog,olog,olog2
1140
1151
 
1141
 
  real(kindr2) &
 
1152
  real(kindr2) &  
1142
1153
         ,allocatable,save :: thrs(:,:)
1143
1154
  integer,allocatable,save :: ntrm(:,:)
1144
1155
  integer,parameter :: nStp=6
1156
1167
!***********************************************************************
1157
1168
!***********************************************************************
1158
1169
  use avh_olo_dp_arrays
1159
 
  real(kindr2) &
 
1170
  real(kindr2) &  
1160
1171
    :: tt
1161
1172
  integer :: nn,mm,ii,jj
1162
1173
!  real(kind(1d0)) :: xx(6) !DEBUG
1213
1224
  function log_c(xx,iph) result(rslt)
1214
1225
!***********************************************************************
1215
1226
!***********************************************************************
1216
 
  complex(kindr2) &
 
1227
  complex(kindr2) &   
1217
1228
          ,intent(in) :: xx
1218
1229
  integer ,intent(in) :: iph
1219
 
  complex(kindr2) &
 
1230
  complex(kindr2) &   
1220
1231
    :: rslt ,yy,zz,z2
1221
 
  real(kindr2) &
 
1232
  real(kindr2) &  
1222
1233
    :: aa,rex,imx
1223
1234
  integer :: nn,ii,iyy
1224
1235
!
1274
1285
  function log_r(xx,iph) result(rslt)
1275
1286
!***********************************************************************
1276
1287
!***********************************************************************
1277
 
  real(kindr2) &
 
1288
  real(kindr2) &  
1278
1289
          ,intent(in) :: xx
1279
1290
  integer ,intent(in) :: iph
1280
 
  complex(kindr2) &
 
1291
  complex(kindr2) &   
1281
1292
    :: rslt
1282
 
  real(kindr2) &
 
1293
  real(kindr2) &  
1283
1294
    :: rr
1284
1295
  integer :: jj
1285
1296
!
1299
1310
  function log2_c(xx,iph) result(rslt)
1300
1311
!***********************************************************************
1301
1312
!***********************************************************************
1302
 
  complex(kindr2) &
 
1313
  complex(kindr2) &   
1303
1314
          ,intent(in) :: xx
1304
1315
  integer ,intent(in) :: iph
1305
 
  complex(kindr2) &
 
1316
  complex(kindr2) &   
1306
1317
    :: rslt ,yy,zz,z2
1307
 
  real(kindr2) &
 
1318
  real(kindr2) &  
1308
1319
    :: aa,rex,imx
1309
1320
  integer :: nn,ii,jj
1310
1321
!
1356
1367
  function log2_r(xx,iph) result(rslt)
1357
1368
!***********************************************************************
1358
1369
!***********************************************************************
1359
 
  real(kindr2) &
 
1370
  real(kindr2) &  
1360
1371
          ,intent(in) :: xx
1361
1372
  integer ,intent(in) :: iph
1362
 
  complex(kindr2) &
 
1373
  complex(kindr2) &   
1363
1374
    :: rslt
1364
 
  real(kindr2) &
 
1375
  real(kindr2) &  
1365
1376
    :: rr,yy
1366
1377
  integer :: jj
1367
1378
!  include 'avh_olo_dp_real.h90'
1415
1426
  private
1416
1427
  public :: update_dilog,dilog
1417
1428
 
1418
 
  real(kindr2) &
 
1429
  real(kindr2) &  
1419
1430
         ,allocatable,save :: coeff(:)
1420
 
  real(kindr2) &
 
1431
  real(kindr2) &  
1421
1432
         ,allocatable,save :: thrs(:,:)
1422
1433
  integer,allocatable,save :: ntrm(:,:)
1423
1434
  integer,parameter :: nStp=6
1424
1435
 
1425
 
  real(kindr2) &
 
1436
  real(kindr2) &  
1426
1437
         ,allocatable :: bern(:),fact(:)
1427
1438
 
1428
1439
  interface dilog
1434
1445
  subroutine update_dilog
1435
1446
!***********************************************************************
1436
1447
!***********************************************************************
1437
 
  real(kindr2) &
 
1448
  real(kindr2) &  
1438
1449
    :: tt
1439
1450
  integer :: nn,ii,jj
1440
1451
  logical :: highestSoFar
1550
1561
  function dilog_c(xx,iph) result(rslt)
1551
1562
!*******************************************************************
1552
1563
!*******************************************************************
1553
 
  complex(kindr2) &
 
1564
  complex(kindr2) &   
1554
1565
          ,intent(in) :: xx
1555
1566
  integer ,intent(in) :: iph
1556
 
  complex(kindr2) &
 
1567
  complex(kindr2) &   
1557
1568
    :: rslt ,yy,lyy,loy,zz,z2
1558
 
  real(kindr2) &
 
1569
  real(kindr2) &  
1559
1570
    :: rex,imx,az
1560
1571
  integer :: ii,jj,ntwo,odd,nn
1561
1572
  logical :: r_gt_1 , y_lt_h
1626
1637
  function dilog_r(xx,iph) result(rslt)
1627
1638
!*******************************************************************
1628
1639
!*******************************************************************
1629
 
  real(kindr2) &
 
1640
  real(kindr2) &  
1630
1641
          ,intent(in) :: xx
1631
1642
  integer ,intent(in) :: iph
1632
 
  complex(kindr2) &
 
1643
  complex(kindr2) &   
1633
1644
    :: rslt
1634
 
  real(kindr2) &
 
1645
  real(kindr2) &  
1635
1646
    :: yy,lyy,loy,zz,z2,liox,az
1636
1647
  integer :: jj,ii,ntwo,odd,nn
1637
1648
  logical :: r_gt_1 , y_lt_h
1647
1658
  ntwo = jj-odd
1648
1659
! 
1649
1660
  if (yy.eq.RONE.and.odd.eq.0) then
1650
 
!!$    if (ntwo.ne.0) then
1651
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog_r: ' &
1652
 
!!$        ,'|x|,iph = ',trim(myprint(yy)),',',jj,', returning 0'
1653
 
!!$    endif
 
1661
    if (ntwo.ne.0) then
 
1662
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog_r: ' &
 
1663
        ,'|x|,iph = ',trim(myprint(yy)),',',jj,', returning 0'
 
1664
    endif
1654
1665
    rslt = 0
1655
1666
    return
1656
1667
  endif
1706
1717
!*******************************************************************
1707
1718
!*******************************************************************
1708
1719
  use avh_olo_dp_olog
1709
 
  complex(kindr2) &
 
1720
  complex(kindr2) &   
1710
1721
          ,intent(in) :: x1,x2
1711
1722
  integer ,intent(in) :: i1,i2
1712
 
  complex(kindr2) &
 
1723
  complex(kindr2) &   
1713
1724
    :: rslt ,y1,y2 ,ff,gg,logr1,logr2,logo1,logo2,r1,r2,rr
1714
 
  real(kindr2) &
 
1725
  real(kindr2) &  
1715
1726
    :: eps ,re1,im1,re2,im2,a1,a2,aa,ao1,ao2
1716
1727
  integer :: j1,j2,ii,nn,oo
1717
1728
  integer,parameter :: pp(-1:1,-1:1)=&
1756
1767
!
1757
1768
  if (j1.ne.j2) then
1758
1769
    if (r1.eq.r2) then
1759
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
1760
 
!!$        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
1770
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
1771
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
1761
1772
      rslt = 0
1762
1773
!      write(*,*) 'dilog2_c j1=/=j2,r1=r2' !DEBUG
1763
1774
      return
1770
1781
!
1771
1782
  if (a1.lt.eps) then
1772
1783
    if (a2.lt.eps) then
1773
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
1774
 
!!$        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
1784
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
1785
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
1775
1786
      rslt = 0
1776
1787
!      write(*,*) 'dilog2_c r1<eps,r2<eps' !DEBUG
1777
1788
      return
1792
1803
!      write(*,*) 'dilog2_c ||1-y1|/|1-y2|-1|>0.1' !DEBUG
1793
1804
      return
1794
1805
    elseif (oo.eq.0.and.ao1.lt.eps) then
1795
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
1796
 
!!$        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
1806
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
1807
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
1797
1808
      if (ao2.lt.eps) then
1798
1809
        rslt = -1
1799
1810
!        write(*,*) 'dilog2_c |1-y1|' !DEBUG
1802
1813
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
1803
1814
      endif
1804
1815
    elseif (oo.eq.0.and.ao2.lt.eps) then
1805
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
1806
 
!!$        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
1816
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
1817
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
1807
1818
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
1808
1819
    endif
1809
1820
  else
1817
1828
      if (a1.gt.RONE) ii = ii + (nn+pp(oo,sgnIm(y2)))
1818
1829
      if (a2.gt.RONE) ii = ii - (nn+pp(oo,sgnIm(y2)))
1819
1830
      ii = nn*ii
1820
 
!!$      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
1821
 
!!$        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
1822
 
!!$        ,', putting nn=0'
 
1831
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
1832
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
1833
        ,', putting nn=0'
1823
1834
      rslt = -olog2(y2,0)
1824
1835
!      write(*,*) 'dilog2_c |logr1/lorg2|<eps' !DEBUG
1825
1836
      return
1860
1871
!*******************************************************************
1861
1872
!*******************************************************************
1862
1873
  use avh_olo_dp_olog
1863
 
  real(kindr2) &
 
1874
  real(kindr2) &  
1864
1875
          ,intent(in) :: x1,x2
1865
1876
  integer ,intent(in) :: i1,i2
1866
 
  complex(kindr2) &
 
1877
  complex(kindr2) &   
1867
1878
    :: rslt
1868
 
  real(kindr2) &
 
1879
  real(kindr2) &  
1869
1880
    :: y1,y2 ,ff,gg,logr1,logr2,logo1,logo2
1870
 
  real(kindr2) &
 
1881
  real(kindr2) &  
1871
1882
    :: eps,r1,r2,rr,ro1,ro2
1872
1883
  integer :: j1,j2,ii,nn,oo
1873
1884
!
1890
1901
!
1891
1902
  if (j1.ne.j2) then
1892
1903
    if (r1.eq.r2) then
1893
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
1894
 
!!$        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
1904
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
1905
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
1895
1906
      rslt = 0
1896
1907
!      write(*,*) 'dilog2_r j1=/=j2,r1=r2' !DEBUG
1897
1908
      return
1904
1915
!
1905
1916
  if (r1.lt.eps) then
1906
1917
    if (r2.lt.eps) then
1907
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
1908
 
!!$        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
1918
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
1919
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
1909
1920
      rslt = 0
1910
1921
!      write(*,*) 'dilog2_r r1<eps,r2<eps' !DEBUG
1911
1922
      return
1926
1937
!      write(*,*) 'dilog2_r ||1-y1|/|1-y2|-1|>0.1' !DEBUG
1927
1938
      return
1928
1939
    elseif (oo.eq.0.and.ro1.lt.eps) then
1929
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
1930
 
!!$        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
1940
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
1941
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
1931
1942
      if (ro2.lt.eps) then
1932
1943
        rslt = -1
1933
1944
!        write(*,*) 'dilog2_r |1-y1|' !DEBUG
1936
1947
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
1937
1948
      endif
1938
1949
    elseif (oo.eq.0.and.ro2.lt.eps) then
1939
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
1940
 
!!$        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
1950
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
1951
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
1941
1952
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
1942
1953
    endif
1943
1954
  else
1951
1962
      if (r1.gt.RONE) ii = ii + (nn+2*oo)
1952
1963
      if (r2.gt.RONE) ii = ii - (nn+2*oo)
1953
1964
      ii = nn*ii
1954
 
!!$      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
1955
 
!!$        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
1956
 
!!$        ,', putting nn=0'
 
1965
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
1966
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
1967
        ,', putting nn=0'
1957
1968
      rslt = -olog2(y2,0)
1958
1969
!      write(*,*) 'dilog2_r |logr1/lorg2|<eps' !DEBUG
1959
1970
      return
1995
2006
! ( f(z1)-f(z2) )/( z1-z2 ), where
1996
2007
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
1997
2008
!***********************************************************************
1998
 
  complex(kindr2) &
 
2009
  complex(kindr2) &   
1999
2010
    ,intent(in) :: z1,z2
2000
 
  complex(kindr2) &
 
2011
  complex(kindr2) &   
2001
2012
    :: rslt,yy,zz
2002
 
  real(kindr2) &
 
2013
  real(kindr2) &  
2003
2014
    :: az
2004
2015
  integer :: ii,nn
2005
2016
  az = max(abs(z1),abs(z2))
2038
2049
! ( f(z1)-f(z2) )/( z1-z2 ), where
2039
2050
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
2040
2051
!***********************************************************************
2041
 
  real(kindr2) &
 
2052
  real(kindr2) &  
2042
2053
    ,intent(in) :: z1,z2
2043
 
  real(kindr2) &
 
2054
  real(kindr2) &  
2044
2055
    :: rslt,yy,zz
2045
 
  real(kindr2) &
 
2056
  real(kindr2) &  
2046
2057
    :: az
2047
2058
  integer :: ii,nn
2048
2059
  az = max(abs(z1),abs(z2))
2087
2098
  private
2088
2099
  public :: update_bnlog,bnlog
2089
2100
 
2090
 
  real(kindr2) &
 
2101
  real(kindr2) &  
2091
2102
         ,allocatable,save :: coeff(:,:)
2092
 
  real(kindr2) &
 
2103
  real(kindr2) &  
2093
2104
         ,allocatable,save :: thrs(:,:,:)
2094
2105
  integer,allocatable,save :: ntrm(:,:,:)
2095
2106
  integer,parameter :: nStp=6
2096
 
  integer,parameter :: rank=2
 
2107
  integer,parameter :: rank=4
 
2108
  integer,parameter :: aCoef(0:rank,0:rank)=reshape((/ &
 
2109
                         1, 0, 0, 0, 0 & ! 1
 
2110
                       , 1, 2, 0, 0, 0 & ! 1/2,1
 
2111
                       , 2, 3, 6, 0, 0 & ! 1/3,1/2,1
 
2112
                       , 3, 4, 6,12, 0 & ! 1/4,1/3,1/2,1
 
2113
                       ,12,15,20,30,60 & ! 1/5,1/4,1/3,1/2,1
 
2114
                       /),(/rank+1,rank+1/))
2097
2115
 
2098
2116
  interface bnlog
2099
2117
    module procedure bnlog_c,bnlog_r
2105
2123
  subroutine update_bnlog
2106
2124
!***********************************************************************
2107
2125
!***********************************************************************
2108
 
  real(kindr2) &
 
2126
  real(kindr2) &  
2109
2127
    :: tt
2110
2128
  integer :: nn,ii,jj,n1,nmax,irank
2111
2129
  logical :: highestSoFar
2192
2210
!*******************************************************************
2193
2211
  integer ,intent(in) :: ncf
2194
2212
  integer :: ii,jj
2195
 
  real(kindr2) &
 
2213
  real(kindr2) &  
2196
2214
    :: fact,tt(rank)
2197
 
! fix by R. Pittau (December 2012)
2198
 
  coeff= 0.d0
2199
2215
!
2200
2216
  call enlarge( coeff ,2,ncf ,0,rank )
2201
2217
!
2214
2230
    coeff(ii,1) = coeff(ii,0)*(1-tt(1))
2215
2231
    if (ii.eq.3) cycle
2216
2232
    coeff(ii,2) = coeff(ii,0)*(1-2*tt(1)+tt(2))
 
2233
    if (ii.eq.4) cycle
 
2234
    coeff(ii,3) = coeff(ii,0)*(1-3*tt(1)+3*tt(2)-tt(3))
 
2235
    if (ii.eq.5) cycle
 
2236
    coeff(ii,4) = coeff(ii,0)*(1-4*tt(1)+6*tt(2)-4*tt(3)+tt(4))
2217
2237
!   if (ii.eq.n+1) cycle
2218
2238
!   coeff(ii,n) = coeff(ii,0)
2219
2239
!               * ( 1 - binom(n,1)*tt(1) + binom(n,2)*tt(2)...)
2226
2246
!*******************************************************************
2227
2247
!*******************************************************************
2228
2248
  integer ,intent(in) :: irank
2229
 
  complex(kindr2) &
 
2249
  complex(kindr2) &   
2230
2250
    ,intent(in) :: xx
2231
 
  complex(kindr2) &
2232
 
    :: rslt,yy
2233
 
  real(kindr2) &
 
2251
  complex(kindr2) &   
 
2252
    :: rslt,yy,omx
 
2253
  real(kindr2) &  
2234
2254
    :: aa,rex,imx
2235
2255
  integer :: ii,nn
2236
2256
!
2254
2274
  yy = olog(1-1/xx,0)
2255
2275
  aa = abs(yy)
2256
2276
  if     (aa.ge.thrs(6,irank,prcpar)) then
2257
 
    if     (irank.eq.0) then
2258
 
      rslt = (1-xx)*yy-1
2259
 
    elseif (irank.eq.1) then
2260
 
      rslt = (1-xx)*(1+xx)*yy-xx-CONE/2
2261
 
    elseif (irank.eq.2) then
2262
 
      rslt = (1-xx)*(1+(1+xx)*xx)*yy-xx*xx-xx/2-CONE/3
2263
 
    endif
 
2277
     omx = 1
 
2278
    rslt = aCoef(irank,irank)
 
2279
    do ii=irank,1,-1
 
2280
       omx = 1 + xx*omx
 
2281
      rslt = aCoef(ii-1,irank) + xx*rslt
 
2282
    enddo
 
2283
     omx = (1-xx)*omx
 
2284
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
2285
!    if     (irank.eq.0) then
 
2286
!      rslt = (1-xx)*yy - 1
 
2287
!    elseif (irank.eq.1) then
 
2288
!      rslt = (1-xx)*(1+xx)*yy - (1+xx*2)/2
 
2289
!    elseif (irank.eq.2) then
 
2290
!      rslt = (1-xx)*(1+xx*(1+xx))*yy - (2+xx*(3+xx*6))/6
 
2291
!    elseif (irank.eq.3) then
 
2292
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx)))*yy &
 
2293
!           - (3+xx*(4+xx*(6+xx*12)))/12
 
2294
!    elseif (irank.eq.4) then
 
2295
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx*(1+xx))))*yy &
 
2296
!           - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
2297
!    endif
2264
2298
    return
2265
2299
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
2266
2300
  elseif (aa.ge.thrs(4,irank,prcpar)) then ;nn=ntrm(5,irank,prcpar)
2286
2320
!*******************************************************************
2287
2321
!*******************************************************************
2288
2322
  integer ,intent(in) :: irank
2289
 
  real(kindr2) &
 
2323
  real(kindr2) &  
2290
2324
          ,intent(in) :: xx
2291
2325
  integer ,intent(in) :: sgn
2292
 
  complex(kindr2) &
 
2326
  complex(kindr2) &   
2293
2327
    :: rslt
2294
 
  real(kindr2) &
 
2328
  real(kindr2) &  
2295
2329
    :: yy,aa,omx
2296
2330
  integer :: ii,nn
2297
2331
  logical :: y_lt_0
2312
2346
!
2313
2347
  yy = 1-1/xx
2314
2348
  y_lt_0 = (yy.lt.RZRO)
2315
 
  if (y_lt_0) then ;yy=log(-yy)
2316
 
              else ;yy=log( yy)
2317
 
  endif
2318
 
!
2319
 
  if     (irank.eq.0) then ;omx=1-xx
2320
 
  elseif (irank.eq.1) then ;omx=(1-xx)*(1+xx) ! 1-x^2
2321
 
  elseif (irank.eq.2) then ;omx=(1-xx)*(1+(1+xx)*xx) ! 1-x^3
2322
 
  endif
2323
 
!
2324
 
  aa = abs(yy)
 
2349
  if (y_lt_0) then 
 
2350
    yy = log(-yy)
 
2351
    aa = sqrt(yy*yy+ONEPI*ONEPI)
 
2352
  else
 
2353
    yy = log( yy)
 
2354
    aa = abs(yy)
 
2355
  endif
 
2356
!
 
2357
  omx = 1
 
2358
  do ii=irank,1,-1
 
2359
    omx = 1+xx*omx
 
2360
  enddo
 
2361
  omx = (1-xx)*omx ! (1-x^{rank+1})
 
2362
!
2325
2363
  if     (aa.ge.thrs(6,irank,prcpar)) then
2326
 
    if     (irank.eq.0) then
2327
 
      rslt = omx*yy-1
2328
 
    elseif (irank.eq.1) then
2329
 
      rslt = omx*yy-xx-RONE/2
2330
 
    elseif (irank.eq.2) then
2331
 
      rslt = omx*yy-xx*xx-xx/2-RONE/3
2332
 
    endif
 
2364
    rslt = aCoef(irank,irank)
 
2365
    do ii=irank,1,-1
 
2366
      rslt = aCoef(ii-1,irank) + xx*rslt
 
2367
    enddo
 
2368
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
2369
!    if     (irank.eq.0) then
 
2370
!      rslt = omx*yy - 1
 
2371
!    elseif (irank.eq.1) then
 
2372
!      rslt = omx*yy - (1+xx*2)/2
 
2373
!    elseif (irank.eq.2) then
 
2374
!      rslt = omx*yy - (2+xx*(3+xx*6))/6
 
2375
!    elseif (irank.eq.3) then
 
2376
!      rslt = omx*yy - (3+xx*(4+xx*(6+xx*12)))/12
 
2377
!    elseif (irank.eq.4) then
 
2378
!      rslt = omx*yy - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
2379
!    endif
2333
2380
    if (y_lt_0) rslt = rslt + sgn*omx*IPI
2334
2381
    return
2335
2382
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
2365
2412
  public :: operator (*) ,operator (/)
2366
2413
 
2367
2414
  type :: qmplx_type
2368
 
  complex(kindr2) &
 
2415
  complex(kindr2) &   
2369
2416
          :: c
2370
2417
  integer :: p
2371
2418
  end type
2391
2438
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
2392
2439
! sign of  sgn .
2393
2440
!*******************************************************************
2394
 
  complex(kindr2) &
 
2441
  complex(kindr2) &   
2395
2442
    ,intent(in) :: xx
2396
 
  real(kindr2) &
 
2443
  real(kindr2) &  
2397
2444
    ,intent(in) :: sgn
2398
2445
  type(qmplx_type) :: rslt
2399
 
  real(kindr2) &
 
2446
  real(kindr2) &  
2400
2447
    :: xre,xim
2401
2448
  xre = areal(xx)
2402
2449
  if (xre.ge.RZRO) then
2421
2468
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
2422
2469
! sign of  sgn .
2423
2470
!*******************************************************************
2424
 
  complex(kindr2) &
 
2471
  complex(kindr2) &   
2425
2472
    ,intent(in) :: xx
2426
2473
  integer         ,intent(in) :: sgn
2427
2474
  type(qmplx_type) :: rslt
2428
 
  real(kindr2) &
 
2475
  real(kindr2) &  
2429
2476
    :: xre,xim
2430
2477
  xre = areal(xx)
2431
2478
  if (xre.ge.RZRO) then
2449
2496
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
2450
2497
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
2451
2498
!*******************************************************************
2452
 
  complex(kindr2) &
 
2499
  complex(kindr2) &   
2453
2500
    ,intent(in) :: xx
2454
2501
  type(qmplx_type) :: rslt
2455
 
  real(kindr2) &
 
2502
  real(kindr2) &  
2456
2503
    :: xre,xim
2457
2504
  xre = areal(xx)
2458
2505
  if (xre.ge.RZRO) then
2496
2543
  function directly(xx,ix) result(rslt)
2497
2544
!*******************************************************************
2498
2545
!*******************************************************************
2499
 
  complex(kindr2) &
 
2546
  complex(kindr2) &   
2500
2547
    ,intent(in) :: xx
2501
2548
  integer         ,intent(in) :: ix
2502
2549
  type(qmplx_type) :: rslt
2519
2566
!*******************************************************************
2520
2567
  type(qmplx_type) ,intent(in) :: xx
2521
2568
  integer :: ii,jj
2522
 
  real(kindr2) &
 
2569
  real(kindr2) &  
2523
2570
    :: xim
2524
2571
  jj = mod(xx%p,2)
2525
2572
  ii = xx%p-jj
2555
2602
! the real part of  zz%c  remains positive 
2556
2603
!*******************************************************************
2557
2604
  type(qmplx_type) ,intent(in) :: yy
2558
 
  real(kindr2) &
 
2605
  real(kindr2) &  
2559
2606
    ,intent(in) :: xx
2560
2607
  type(qmplx_type) :: zz
2561
2608
  zz%c = yy%c*abs(xx)
2582
2629
!*******************************************************************
2583
2630
!*******************************************************************
2584
2631
  type(qmplx_type) ,intent(in) :: yy
2585
 
  real(kindr2) &
 
2632
  real(kindr2) &  
2586
2633
    ,intent(in) :: xx
2587
2634
  type(qmplx_type) :: zz
2588
2635
  zz%c = yy%c/abs(xx)
2595
2642
! log(xx)
2596
2643
!*******************************************************************
2597
2644
  type(qmplx_type) ,intent(in) :: xx
2598
 
  complex(kindr2) &
 
2645
  complex(kindr2) &   
2599
2646
    :: rslt
2600
2647
!  rslt = olog(acmplx(xx%c),xx%p)
2601
2648
  rslt = olog(xx%c,xx%p)
2606
2653
! log(xx)/(1-xx)
2607
2654
!*******************************************************************
2608
2655
  type(qmplx_type) ,intent(in) :: xx
2609
 
  complex(kindr2) &
 
2656
  complex(kindr2) &   
2610
2657
    :: rslt
2611
2658
!  rslt = -olog2(acmplx(xx%c),xx%p)
2612
2659
  rslt = -olog2(xx%c,xx%p)
2619
2666
!    /0        t
2620
2667
!*******************************************************************
2621
2668
  type(qmplx_type) ,intent(in) :: xx
2622
 
  complex(kindr2) &
 
2669
  complex(kindr2) &   
2623
2670
    :: rslt
2624
2671
!  rslt = dilog(acmplx(xx%c),xx%p)
2625
2672
  rslt = dilog(xx%c,xx%p)
2630
2677
! ( li2(xx) - li2(yy) )/(xx-yy)
2631
2678
!*******************************************************************
2632
2679
  type(qmplx_type) ,intent(in) :: xx,yy
2633
 
  complex(kindr2) &
 
2680
  complex(kindr2) &   
2634
2681
    :: rslt
2635
2682
!  rslt = dilog( acmplx(xx%c),xx%p ,acmplx(yy%c),yy%p )
2636
2683
!  write(*,*) 'li2c2 x:',xx%c,xx%p !DEBUG
2651
2698
  use avh_olo_dp_qmplx
2652
2699
  implicit none
2653
2700
  private
2654
 
  public :: tadp ,bub0 ,bub11
 
2701
  public :: tadp ,tadpn ,bub0 ,bub1 ,bub11 ,bub111 ,bub1111
2655
2702
 
2656
2703
contains
2657
2704
 
2659
2706
!*******************************************************************
2660
2707
! The 1-loop scalar 1-point function.
2661
2708
!*******************************************************************
2662
 
  complex(kindr2) &
 
2709
  complex(kindr2) &   
2663
2710
    ,intent(out) :: rslt(0:2)
2664
 
  complex(kindr2) &
 
2711
  complex(kindr2) &   
2665
2712
    ,intent(in)  :: mm
2666
 
  real(kindr2) &
 
2713
  real(kindr2) &  
2667
2714
    ,intent(in)  :: amm,rmu2
2668
2715
!
2669
2716
  rslt(2) = 0
2677
2724
  end subroutine
2678
2725
 
2679
2726
 
2680
 
  subroutine bub0( rslt ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
2681
 
!*******************************************************************
2682
 
! The 1-loop scalar 2-point function. Based on the formulas from
2683
 
! A. Denner, M. Dittmaier, Nucl.Phys. B734 (2006) 62-115
2684
 
!*******************************************************************
2685
 
  complex(kindr2) &
2686
 
    ,intent(out) :: rslt(0:2)
2687
 
  complex(kindr2) &
2688
 
    ,intent(in)  :: pp,m0i,m1i
2689
 
  real(kindr2) &
2690
 
    ,intent(in)  :: app,am0i,am1i,rmu2
2691
 
  complex(kindr2) &
2692
 
    :: m0,m1,x1,x2,lambda
2693
 
  real(kindr2) &
2694
 
    :: am0,am1,maxm
2695
 
!
2696
 
  maxm = max(am0i,am1i)
2697
 
  if (maxm.eq.RZRO) then
2698
 
    if (app.eq.RZRO) then
2699
 
      rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
2700
 
      return
2701
 
    endif
2702
 
  endif
2703
 
!
2704
 
  if (am1i.ge.maxm) then
2705
 
    m0=m0i ;am0=am0i
2706
 
    m1=m1i ;am1=am1i
2707
 
  else
2708
 
    m0=m1i ;am0=am1i
2709
 
    m1=m0i ;am1=am0i
2710
 
  endif
2711
 
!
2712
 
  rslt(2) = 0
2713
 
  rslt(1) = 1
2714
 
!
2715
 
  if (app.eq.RZRO) then
2716
 
    if (abs(m0-m1).le.am1*EPSN*10) then
2717
 
      rslt(0) = -logc(qonv(m1/rmu2,-1))
2718
 
    else
2719
 
      x1 = (m1-am1*IEPS)/(m1-m0)
2720
 
      rslt(0) = -logc(qonv(m1/rmu2,-1)) - bnlog(0,x1)
2721
 
    endif
2722
 
  elseif (am0.eq.RZRO) then
2723
 
    if (abs(pp-m1).le.am1*EPSN*10) then
2724
 
      rslt(0) = 2 - logc(qonv(m1/rmu2,-1))
2725
 
    else
2726
 
      x1 = (pp-m1+am1*IEPS)/pp
2727
 
      rslt(0) = 1 - logc(qonv((m1-pp)/rmu2,-1)) - bnlog(0,x1)
2728
 
    endif
2729
 
  else
2730
 
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
2731
 
    rslt(0) = -logc(qonv(m0/rmu2,-1)) - bnlog(0,x1) - bnlog(0,x2)
2732
 
  endif
2733
 
!
 
2727
  subroutine tadpn( rslt ,rank ,mm ,amm ,rmu2 )
 
2728
!*******************************************************************
 
2729
! The 1-loop tensor 1-point functions.
 
2730
!   rslt(:,0) = A0
 
2731
!   rslt(:,1) = A00
 
2732
!   rslt(:,2) = A0000  etc.
 
2733
! For input  rank  only  rslt(:,0:rank/2)  is filled.
 
2734
!*******************************************************************
 
2735
  complex(kindr2) &   
 
2736
    ,intent(out) :: rslt(0:,0:)
 
2737
  complex(kindr2) &   
 
2738
    ,intent(in)  :: mm
 
2739
  real(kindr2) &  
 
2740
    ,intent(in)  :: amm,rmu2
 
2741
  integer ,intent(in) :: rank
 
2742
  complex(kindr2) &   
 
2743
    :: aa
 
2744
  real(kindr2) &  
 
2745
    :: bb
 
2746
  integer :: ii
 
2747
!
 
2748
  do ii=0,rank
 
2749
    rslt(2,ii) = 0
 
2750
    rslt(1,ii) = 0
 
2751
    rslt(0,ii) = 0
 
2752
  enddo
 
2753
  if (amm.eq.RZRO.or.mm.eq.CZRO) then
 
2754
    return
 
2755
  else
 
2756
    rslt(1,0) = mm
 
2757
    rslt(0,0) = mm - mm*logc( qonv(mm/rmu2,-1) )
 
2758
    aa = 1
 
2759
    bb = 0
 
2760
    do ii=1,rank/2
 
2761
      aa = aa*mm/(2*(ii+1))
 
2762
      bb = bb + RONE/(ii+1)
 
2763
      rslt(1,ii) = aa*( rslt(1,0) )
 
2764
      rslt(0,ii) = aa*( rslt(0,0) + mm*bb )
 
2765
    enddo
 
2766
  endif
2734
2767
  end subroutine
2735
2768
 
2736
2769
 
2737
 
  subroutine bub11( b11,b00,b1,b0 ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
2738
2770
!*******************************************************************
2739
 
! Return the Passarino-Veltman functions b11,b00,b1,b0 , for
 
2771
! Return the Passarino-Veltman functions
2740
2772
!
2741
2773
!      C   /      d^(Dim)q
2742
2774
!   ------ | -------------------- = b0
2750
2782
!   ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
2751
2783
!   i*pi^2 / [q^2-m0][(q+p)^2-m1]
2752
2784
!
 
2785
!   etc.
 
2786
!
2753
2787
! Based on the formulas from
2754
2788
! A. Denner, M. Dittmaier, Nucl.Phys. B734 (2006) 62-115
2755
2789
!*******************************************************************
2756
 
  complex(kindr2) &
 
2790
 
 
2791
  subroutine bub0( b0 &
 
2792
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
2793
  complex(kindr2) &   
 
2794
    ,intent(out) :: b0(0:2)
 
2795
  complex(kindr2) &   
 
2796
    ,intent(in)  :: pp,m0i,m1i
 
2797
  real(kindr2) &  
 
2798
    ,intent(in)  :: app,am0i,am1i,rmu2
 
2799
  complex(kindr2) &   
 
2800
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
2801
  real(kindr2) &  
 
2802
    :: am0,am1,maxm
 
2803
  integer :: rank
 
2804
!
 
2805
  maxm = max(am0i,am1i)
 
2806
  if (maxm.eq.RZRO) then
 
2807
    if (app.eq.RZRO) then
 
2808
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
2809
      return
 
2810
    endif
 
2811
  endif
 
2812
!
 
2813
  if (am1i.ge.maxm) then
 
2814
    m0=m0i ;am0=am0i
 
2815
    m1=m1i ;am1=am1i
 
2816
  else
 
2817
    m0=m1i ;am0=am1i
 
2818
    m1=m0i ;am1=am0i
 
2819
  endif
 
2820
!
 
2821
  b0(2) = 0
 
2822
  b0(1) = CONE
 
2823
!
 
2824
  if (app.eq.RZRO) then
 
2825
    if (abs(m0-m1).le.am1*EPSN*10) then
 
2826
      lna = -logc(qonv(m1/rmu2,-1))
 
2827
      b0(0) = lna
 
2828
    else
 
2829
      lna = -logc(qonv(m1/rmu2,-1))
 
2830
      x1 = (m1-am1*IEPS)/(m1-m0)
 
2831
      b0(0) =   lna - bnlog(0,x1)
 
2832
    endif
 
2833
  elseif (am0.eq.RZRO) then
 
2834
    if (abs(pp-m1).le.am1*EPSN*10) then
 
2835
      lna = -logc(qonv(m1/rmu2,-1))
 
2836
      b0(0) = ( lna   + 2 )
 
2837
    else
 
2838
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
2839
      x1  = (pp-m1+am1*IEPS)/pp
 
2840
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
2841
    endif
 
2842
  else
 
2843
    lna = -logc(qonv(m0/rmu2,-1))
 
2844
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
2845
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
2846
  endif
 
2847
!
 
2848
  end subroutine
 
2849
 
 
2850
  subroutine bub1( b1,b0 &
 
2851
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
2852
  complex(kindr2) &   
 
2853
    ,intent(out) :: b1(0:2),b0(0:2)
 
2854
  complex(kindr2) &   
 
2855
    ,intent(in)  :: pp,m0i,m1i
 
2856
  real(kindr2) &  
 
2857
    ,intent(in)  :: app,am0i,am1i,rmu2
 
2858
  complex(kindr2) &   
 
2859
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
2860
  real(kindr2) &  
 
2861
    :: am0,am1,maxm
 
2862
  logical :: switch 
 
2863
  integer :: rank
 
2864
!
 
2865
  maxm = max(am0i,am1i)
 
2866
  if (maxm.eq.RZRO) then
 
2867
    if (app.eq.RZRO) then
 
2868
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
2869
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
2870
      return
 
2871
    endif
 
2872
  endif
 
2873
!
 
2874
  if (am1i.ge.maxm) then
 
2875
    m0=m0i ;am0=am0i
 
2876
    m1=m1i ;am1=am1i
 
2877
    switch = .false. 
 
2878
  else
 
2879
    m0=m1i ;am0=am1i
 
2880
    m1=m0i ;am1=am0i
 
2881
    switch = .true. 
 
2882
  endif
 
2883
!
 
2884
  b0(2) = 0
 
2885
  b0(1) = CONE
 
2886
  b1(2) = 0      
 
2887
  b1(1) =-CONE/2 
 
2888
!
 
2889
  if (app.eq.RZRO) then
 
2890
    if (abs(m0-m1).le.am1*EPSN*10) then
 
2891
      lna = -logc(qonv(m1/rmu2,-1))
 
2892
      b0(0) = lna
 
2893
      b1(0) =-lna/2 
 
2894
    else
 
2895
      lna = -logc(qonv(m1/rmu2,-1))
 
2896
      x1 = (m1-am1*IEPS)/(m1-m0)
 
2897
      b0(0) =   lna - bnlog(0,x1)
 
2898
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
2899
    endif
 
2900
    if (switch) then
 
2901
      x2=m0;m0=m1;m1=x2
 
2902
    else
 
2903
      b1(0) =-b0(0)-b1(0)
 
2904
    endif
 
2905
  elseif (am0.eq.RZRO) then
 
2906
    if (abs(pp-m1).le.am1*EPSN*10) then
 
2907
      lna = -logc(qonv(m1/rmu2,-1))
 
2908
      b0(0) = ( lna   + 2 )
 
2909
      b1(0) =-( lna*2 + 2 )/4 
 
2910
    else
 
2911
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
2912
      x1  = (pp-m1+am1*IEPS)/pp
 
2913
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
2914
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
2915
    endif
 
2916
    if (switch) then
 
2917
      x2=m0;m0=m1;m1=x2
 
2918
      b1(0) =-b0(0)-b1(0)
 
2919
    endif
 
2920
  else
 
2921
    lna = -logc(qonv(m0/rmu2,-1))
 
2922
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
2923
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
2924
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
2925
    if (switch) then
 
2926
      x2=m0;m0=m1;m1=x2
 
2927
      b1(0) =-b0(0)-b1(0)
 
2928
    endif
 
2929
  endif
 
2930
!
 
2931
  end subroutine
 
2932
 
 
2933
  subroutine bub11( b11,b00,b1,b0 &
 
2934
                   ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
2935
  complex(kindr2) &   
2757
2936
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
2758
 
  complex(kindr2) &
2759
 
    ,intent(in)  :: pp,m0i,m1i
2760
 
  real(kindr2) &
2761
 
    ,intent(in)  :: app,am0i,am1i,rmu2
2762
 
  complex(kindr2) &
2763
 
    :: m0,m1,a0(0:2),lna,x1,x2,lambda
2764
 
  real(kindr2) &
2765
 
    :: am0,am1,maxm
2766
 
  logical :: switch
2767
 
!
2768
 
  maxm = max(am0i,am1i)
2769
 
  if (maxm.eq.RZRO) then
2770
 
    if (app.eq.RZRO) then
2771
 
       b0(0)=0 ; b0(1)=0 ; b0(2)=0
2772
 
       b1(0)=0 ; b1(1)=0 ; b1(2)=0
2773
 
      b00(0)=0 ;b00(1)=0 ;b00(2)=0
2774
 
      b11(0)=0 ;b11(1)=0 ;b11(2)=0
2775
 
      return
2776
 
    endif
2777
 
  endif
2778
 
!
2779
 
  if (am1i.ge.maxm) then
2780
 
    m0=m0i ;am0=am0i
2781
 
    m1=m1i ;am1=am1i
2782
 
    switch = .false.
2783
 
  else
2784
 
    m0=m1i ;am0=am1i
2785
 
    m1=m0i ;am1=am0i
2786
 
    switch = .true.
2787
 
  endif
2788
 
!
2789
 
  b0(2)  = 0
2790
 
  b1(2)  = 0
2791
 
  b11(2) = 0
2792
 
  b0(1)  = 1
2793
 
  b1(1)  =-CONE/2
2794
 
  b11(1) = CONE/3
2795
 
!
2796
 
  if (app.eq.RZRO) then
2797
 
    if (abs(m0-m1).le.am1*EPSN*10) then
2798
 
      lna = -logc(qonv(m1/rmu2,-1))
2799
 
      b0(0)  = lna
2800
 
      b1(0)  =-lna/2
2801
 
      b11(0) = lna/3
2802
 
    else
2803
 
      lna = -logc(qonv(m1/rmu2,-1))
2804
 
      x1 = (m1-am1*IEPS)/(m1-m0)
2805
 
      b0(0)  =   lna - bnlog(0,x1)
2806
 
      b1(0)  =-( lna - bnlog(1,x1) )/2
2807
 
      b11(0) = ( lna - bnlog(2,x1) )/3
2808
 
    endif
2809
 
    if (switch) then
2810
 
      x2=m0;m0=m1;m1=x2
2811
 
    else
2812
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
2813
 
      b1(0) = -b0(0)-b1(0)
2814
 
    endif
2815
 
  elseif (am0.eq.RZRO) then
2816
 
    if (abs(pp-m1).le.am1*EPSN*10) then
2817
 
      lna = -logc(qonv(m1/rmu2,-1))
2818
 
      b0(0)  = ( lna + 2*CONE   )
2819
 
      b1(0)  =-( lna +   CONE   )/2
2820
 
      b11(0) = ( lna + 2*CONE/3 )/3
2821
 
    else
2822
 
      lna = -logc(qonv((m1-pp)/rmu2,-1))
2823
 
      x1  = (pp-m1+am1*IEPS)/pp
2824
 
      b0(0)  = ( lna - bnlog(0,x1) + CONE   )
2825
 
      b1(0)  =-( lna - bnlog(1,x1) + CONE/2 )/2
2826
 
      b11(0) = ( lna - bnlog(2,x1) + CONE/3 )/3
2827
 
    endif
2828
 
    if (switch) then
2829
 
      x2=m0;m0=m1;m1=x2
2830
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
2831
 
      b1(0) = -b0(0)-b1(0)
2832
 
    endif
2833
 
  else
2834
 
    lna = -logc(qonv(m0/rmu2,-1))
2835
 
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
2836
 
    b0(0)  = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
2837
 
    b1(0)  =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
2838
 
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
2839
 
    if (switch) then
2840
 
      x2=m0;m0=m1;m1=x2
2841
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
2842
 
      b1(0) = -b0(0)-b1(0)
2843
 
    endif
2844
 
  endif
2845
 
!
2846
 
  call tadp( a0 ,m1 ,am1 ,rmu2 )
2847
 
  b00(2) = 0
2848
 
  b00(1) = m0 + m1 - pp/3
2849
 
  b00(0) = ( a0(0) - ((m1-m0)-pp)*b1(0) + 2*m0*b0(0) + b00(1) )/6
2850
 
  b00(1) = b00(1)/4
2851
 
!
 
2937
  complex(kindr2) &   
 
2938
    ,intent(in)  :: pp,m0i,m1i
 
2939
  real(kindr2) &  
 
2940
    ,intent(in)  :: app,am0i,am1i,rmu2
 
2941
  complex(kindr2) &   
 
2942
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
2943
  real(kindr2) &  
 
2944
    :: am0,am1,maxm
 
2945
  logical :: switch 
 
2946
  integer :: rank
 
2947
!
 
2948
  maxm = max(am0i,am1i)
 
2949
  if (maxm.eq.RZRO) then
 
2950
    if (app.eq.RZRO) then
 
2951
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
2952
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
2953
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
2954
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
2955
      return
 
2956
    endif
 
2957
  endif
 
2958
!
 
2959
  if (am1i.ge.maxm) then
 
2960
    m0=m0i ;am0=am0i
 
2961
    m1=m1i ;am1=am1i
 
2962
    switch = .false. 
 
2963
  else
 
2964
    m0=m1i ;am0=am1i
 
2965
    m1=m0i ;am1=am0i
 
2966
    switch = .true. 
 
2967
  endif
 
2968
!
 
2969
  b0(2) = 0
 
2970
  b0(1) = CONE
 
2971
  b1(2) = 0      
 
2972
  b1(1) =-CONE/2 
 
2973
  b11(2) = 0      
 
2974
  b11(1) = CONE/3 
 
2975
!
 
2976
  if (app.eq.RZRO) then
 
2977
    if (abs(m0-m1).le.am1*EPSN*10) then
 
2978
      lna = -logc(qonv(m1/rmu2,-1))
 
2979
      b0(0) = lna
 
2980
      b1(0) =-lna/2 
 
2981
      b11(0) = lna/3 
 
2982
    else
 
2983
      lna = -logc(qonv(m1/rmu2,-1))
 
2984
      x1 = (m1-am1*IEPS)/(m1-m0)
 
2985
      b0(0) =   lna - bnlog(0,x1)
 
2986
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
2987
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
2988
    endif
 
2989
    if (switch) then
 
2990
      x2=m0;m0=m1;m1=x2
 
2991
    else
 
2992
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
2993
      b1(0) =-b0(0)-b1(0)
 
2994
    endif
 
2995
  elseif (am0.eq.RZRO) then
 
2996
    if (abs(pp-m1).le.am1*EPSN*10) then
 
2997
      lna = -logc(qonv(m1/rmu2,-1))
 
2998
      b0(0) = ( lna   + 2 )
 
2999
      b1(0) =-( lna*2 + 2 )/4 
 
3000
      b11(0) = ( lna*3 + 2 )/9 
 
3001
    else
 
3002
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
3003
      x1  = (pp-m1+am1*IEPS)/pp
 
3004
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
3005
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
3006
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
3007
    endif
 
3008
    if (switch) then
 
3009
      x2=m0;m0=m1;m1=x2
 
3010
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3011
      b1(0) =-b0(0)-b1(0)
 
3012
    endif
 
3013
  else
 
3014
    lna = -logc(qonv(m0/rmu2,-1))
 
3015
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
3016
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
3017
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
3018
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
3019
    if (switch) then
 
3020
      x2=m0;m0=m1;m1=x2
 
3021
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3022
      b1(0) =-b0(0)-b1(0)
 
3023
    endif
 
3024
  endif
 
3025
!
 
3026
  rank = 0 
 
3027
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
3028
  x1 = (m1-m0)-pp
 
3029
  x2 = 2*m0
 
3030
  b00(2) = 0
 
3031
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
3032
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
3033
  end subroutine
 
3034
 
 
3035
  subroutine bub111( b111,b001,b11,b00,b1,b0 &
 
3036
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
3037
  complex(kindr2) &   
 
3038
    ,intent(out) :: b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
3039
  complex(kindr2) &   
 
3040
    ,intent(in)  :: pp,m0i,m1i
 
3041
  real(kindr2) &  
 
3042
    ,intent(in)  :: app,am0i,am1i,rmu2
 
3043
  complex(kindr2) &   
 
3044
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
3045
  real(kindr2) &  
 
3046
    :: am0,am1,maxm
 
3047
  logical :: switch 
 
3048
  integer :: rank
 
3049
!
 
3050
  maxm = max(am0i,am1i)
 
3051
  if (maxm.eq.RZRO) then
 
3052
    if (app.eq.RZRO) then
 
3053
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
3054
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
3055
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
3056
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
3057
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
3058
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
3059
      return
 
3060
    endif
 
3061
  endif
 
3062
!
 
3063
  if (am1i.ge.maxm) then
 
3064
    m0=m0i ;am0=am0i
 
3065
    m1=m1i ;am1=am1i
 
3066
    switch = .false. 
 
3067
  else
 
3068
    m0=m1i ;am0=am1i
 
3069
    m1=m0i ;am1=am0i
 
3070
    switch = .true. 
 
3071
  endif
 
3072
!
 
3073
  b0(2) = 0
 
3074
  b0(1) = CONE
 
3075
  b1(2) = 0      
 
3076
  b1(1) =-CONE/2 
 
3077
  b11(2) = 0      
 
3078
  b11(1) = CONE/3 
 
3079
  b111(2) = 0      
 
3080
  b111(1) =-CONE/4 
 
3081
!
 
3082
  if (app.eq.RZRO) then
 
3083
    if (abs(m0-m1).le.am1*EPSN*10) then
 
3084
      lna = -logc(qonv(m1/rmu2,-1))
 
3085
      b0(0) = lna
 
3086
      b1(0) =-lna/2 
 
3087
      b11(0) = lna/3 
 
3088
      b111(0) =-lna/4 
 
3089
    else
 
3090
      lna = -logc(qonv(m1/rmu2,-1))
 
3091
      x1 = (m1-am1*IEPS)/(m1-m0)
 
3092
      b0(0) =   lna - bnlog(0,x1)
 
3093
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
3094
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
3095
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
3096
    endif
 
3097
    if (switch) then
 
3098
      x2=m0;m0=m1;m1=x2
 
3099
    else
 
3100
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3101
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3102
      b1(0) =-b0(0)-b1(0)
 
3103
    endif
 
3104
  elseif (am0.eq.RZRO) then
 
3105
    if (abs(pp-m1).le.am1*EPSN*10) then
 
3106
      lna = -logc(qonv(m1/rmu2,-1))
 
3107
      b0(0) = ( lna   + 2 )
 
3108
      b1(0) =-( lna*2 + 2 )/4 
 
3109
      b11(0) = ( lna*3 + 2 )/9 
 
3110
      b111(0) =-( lna*4 + 2 )/16 
 
3111
    else
 
3112
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
3113
      x1  = (pp-m1+am1*IEPS)/pp
 
3114
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
3115
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
3116
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
3117
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
3118
    endif
 
3119
    if (switch) then
 
3120
      x2=m0;m0=m1;m1=x2
 
3121
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3122
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3123
      b1(0) =-b0(0)-b1(0)
 
3124
    endif
 
3125
  else
 
3126
    lna = -logc(qonv(m0/rmu2,-1))
 
3127
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
3128
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
3129
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
3130
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
3131
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
3132
    if (switch) then
 
3133
      x2=m0;m0=m1;m1=x2
 
3134
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3135
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3136
      b1(0) =-b0(0)-b1(0)
 
3137
    endif
 
3138
  endif
 
3139
!
 
3140
  rank = 0 
 
3141
  rank = 1 
 
3142
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
3143
  x1 = (m1-m0)-pp
 
3144
  x2 = 2*m0
 
3145
  b00(2) = 0
 
3146
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
3147
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
3148
  b001(2) = 0
 
3149
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
3150
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
3151
  end subroutine
 
3152
 
 
3153
  subroutine bub1111( b1111,b0011,b0000,b111,b001,b11,b00,b1,b0 &
 
3154
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
3155
  complex(kindr2) &   
 
3156
    ,intent(out) :: b1111(0:2),b0011(0:2),b0000(0:2) &
 
3157
                   ,b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
3158
  complex(kindr2) &   
 
3159
    ,intent(in)  :: pp,m0i,m1i
 
3160
  real(kindr2) &  
 
3161
    ,intent(in)  :: app,am0i,am1i,rmu2
 
3162
  complex(kindr2) &   
 
3163
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
3164
  real(kindr2) &  
 
3165
    :: am0,am1,maxm
 
3166
  logical :: switch 
 
3167
  integer :: rank
 
3168
!
 
3169
  maxm = max(am0i,am1i)
 
3170
  if (maxm.eq.RZRO) then
 
3171
    if (app.eq.RZRO) then
 
3172
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
3173
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
3174
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
3175
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
3176
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
3177
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
3178
      b0000(0)=0 ;b0000(1)=0 ;b0000(2)=0 
 
3179
      b0011(0)=0 ;b0011(1)=0 ;b0011(2)=0 
 
3180
      b1111(0)=0 ;b1111(1)=0 ;b1111(2)=0 
 
3181
      return
 
3182
    endif
 
3183
  endif
 
3184
!
 
3185
  if (am1i.ge.maxm) then
 
3186
    m0=m0i ;am0=am0i
 
3187
    m1=m1i ;am1=am1i
 
3188
    switch = .false. 
 
3189
  else
 
3190
    m0=m1i ;am0=am1i
 
3191
    m1=m0i ;am1=am0i
 
3192
    switch = .true. 
 
3193
  endif
 
3194
!
 
3195
  b0(2) = 0
 
3196
  b0(1) = CONE
 
3197
  b1(2) = 0      
 
3198
  b1(1) =-CONE/2 
 
3199
  b11(2) = 0      
 
3200
  b11(1) = CONE/3 
 
3201
  b111(2) = 0      
 
3202
  b111(1) =-CONE/4 
 
3203
  b1111(2) = 0      
 
3204
  b1111(1) = CONE/5 
 
3205
!
 
3206
  if (app.eq.RZRO) then
 
3207
    if (abs(m0-m1).le.am1*EPSN*10) then
 
3208
      lna = -logc(qonv(m1/rmu2,-1))
 
3209
      b0(0) = lna
 
3210
      b1(0) =-lna/2 
 
3211
      b11(0) = lna/3 
 
3212
      b111(0) =-lna/4 
 
3213
      b1111(0) = lna/5 
 
3214
    else
 
3215
      lna = -logc(qonv(m1/rmu2,-1))
 
3216
      x1 = (m1-am1*IEPS)/(m1-m0)
 
3217
      b0(0) =   lna - bnlog(0,x1)
 
3218
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
3219
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
3220
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
3221
      b1111(0) = ( lna - bnlog(4,x1) )/5 
 
3222
    endif
 
3223
    if (switch) then
 
3224
      x2=m0;m0=m1;m1=x2
 
3225
    else
 
3226
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
3227
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3228
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3229
      b1(0) =-b0(0)-b1(0)
 
3230
    endif
 
3231
  elseif (am0.eq.RZRO) then
 
3232
    if (abs(pp-m1).le.am1*EPSN*10) then
 
3233
      lna = -logc(qonv(m1/rmu2,-1))
 
3234
      b0(0) = ( lna   + 2 )
 
3235
      b1(0) =-( lna*2 + 2 )/4 
 
3236
      b11(0) = ( lna*3 + 2 )/9 
 
3237
      b111(0) =-( lna*4 + 2 )/16 
 
3238
      b1111(0) = ( lna*5 + 2 )/25 
 
3239
    else
 
3240
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
3241
      x1  = (pp-m1+am1*IEPS)/pp
 
3242
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
3243
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
3244
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
3245
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
3246
      b1111(0) = ( (lna-bnlog(4,x1))*5 + 1 )/25 
 
3247
    endif
 
3248
    if (switch) then
 
3249
      x2=m0;m0=m1;m1=x2
 
3250
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
3251
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3252
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3253
      b1(0) =-b0(0)-b1(0)
 
3254
    endif
 
3255
  else
 
3256
    lna = -logc(qonv(m0/rmu2,-1))
 
3257
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
3258
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
3259
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
3260
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
3261
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
3262
    b1111(0) = ( lna - bnlog(4,x1) - bnlog(4,x2) )/5 
 
3263
    if (switch) then
 
3264
      x2=m0;m0=m1;m1=x2
 
3265
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
3266
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
3267
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
3268
      b1(0) =-b0(0)-b1(0)
 
3269
    endif
 
3270
  endif
 
3271
!
 
3272
  rank = 0 
 
3273
  rank = 1 
 
3274
  rank = 2 
 
3275
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
3276
  x1 = (m1-m0)-pp
 
3277
  x2 = 2*m0
 
3278
  b00(2) = 0
 
3279
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
3280
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
3281
  b001(2) = 0
 
3282
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
3283
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
3284
  b0000(2) = 0
 
3285
  b0000(1) = ( a0(1,1) - x1*b001(1) + x2*b00(1) )/10
 
3286
  b0000(0) = ( a0(0,1) - x1*b001(0) + x2*b00(0) + 4*b0000(1) )/10
 
3287
  b0011(2) = 0
 
3288
  b0011(1) = ( a0(1,0) - x1*b111(1) + x2*b11(1) )/10
 
3289
  b0011(0) = ( a0(0,0) - x1*b111(0) + x2*b11(0) + 4*b0011(1) )/10
2852
3290
  end subroutine
2853
3291
 
2854
3292
end module
2889
3327
! with  k1^2=m2, k2^2=pp, (k1+k2)^2=m3.
2890
3328
! m2,m3 should NOT be identically 0d0.
2891
3329
!*******************************************************************
2892
 
  complex(kindr2) &
 
3330
  complex(kindr2) &   
2893
3331
     ,intent(out) :: rslt(0:2)
2894
 
  complex(kindr2) &
 
3332
  complex(kindr2) &   
2895
3333
     ,intent(in)  :: cm2,cm3,cpp
2896
 
  real(kindr2) &
 
3334
  real(kindr2) &  
2897
3335
     ,intent(in)  :: rmu2
2898
3336
   type(qmplx_type) :: q23,qm3,q32
2899
 
  complex(kindr2) &
 
3337
  complex(kindr2) &   
2900
3338
     :: sm2,sm3,k23,r23,d23,cc
2901
3339
!
2902
3340
   sm2 = mysqrt(cm2)
2933
3371
! mm should NOT be identically 0d0,
2934
3372
! and p2 NOR p3 should be identical to mm. 
2935
3373
!*******************************************************************
2936
 
  complex(kindr2) &
 
3374
  complex(kindr2) &   
2937
3375
     ,intent(out) :: rslt(0:2)
2938
 
  complex(kindr2) &
 
3376
  complex(kindr2) &   
2939
3377
     ,intent(in)  :: cp2,cp3,cm3
2940
 
  real(kindr2) &
 
3378
  real(kindr2) &  
2941
3379
     ,intent(in)  :: rmu2
2942
3380
   type(qmplx_type) :: q13,q23,qm3,x1,x2
2943
 
  complex(kindr2) &
 
3381
  complex(kindr2) &   
2944
3382
     :: r13,r23
2945
3383
!
2946
3384
   r13 = cm3-cp3
2968
3406
! mm should NOT be identically 0d0,
2969
3407
! and pp should NOT be identical to mm. 
2970
3408
!*******************************************************************
2971
 
  complex(kindr2) &
 
3409
  complex(kindr2) &   
2972
3410
     ,intent(out) :: rslt(0:2)
2973
 
  complex(kindr2) &
 
3411
  complex(kindr2) &   
2974
3412
     ,intent(in)  :: cp3,cm3
2975
 
  real(kindr2) &
 
3413
  real(kindr2) &  
2976
3414
     ,intent(in)  :: rmu2
2977
3415
   type(qmplx_type) :: q13,qm3,qxx
2978
 
  complex(kindr2) &
 
3416
  complex(kindr2) &   
2979
3417
     :: r13,logm,z2,z1,z0,cc
2980
3418
!
2981
3419
   r13 = cm3-cp3
3004
3442
! with  k1^2 = (k1+k2)^2 = m3.
3005
3443
! mm should NOT be identically 0d0.
3006
3444
!*******************************************************************
3007
 
  complex(kindr2) &
 
3445
  complex(kindr2) &   
3008
3446
     ,intent(out) :: rslt(0:2)
3009
 
  complex(kindr2) &
 
3447
  complex(kindr2) &   
3010
3448
     ,intent(in)  :: cm3
3011
 
  real(kindr2) &
 
3449
  real(kindr2) &  
3012
3450
     ,intent(in)  :: rmu2
3013
 
  complex(kindr2) &
 
3451
  complex(kindr2) &   
3014
3452
     :: zm
3015
3453
!
3016
3454
   zm = 1/(2*cm3)
3039
3477
! IR-singular case is returned.
3040
3478
!*******************************************************************
3041
3479
   use avh_olo_dp_olog
3042
 
  complex(kindr2) &
 
3480
  complex(kindr2) &   
3043
3481
     ,intent(out) :: rslt(0:2)
3044
 
  complex(kindr2) &
 
3482
  complex(kindr2) &   
3045
3483
     ,intent(in)  :: cp(3)
3046
 
  real(kindr2) &
 
3484
  real(kindr2) &  
3047
3485
     ,intent(in)  :: ap(3),rmu2
3048
 
  real(kindr2) &
 
3486
  real(kindr2) &  
3049
3487
     :: pp(3),rp1,rp2,rp3
3050
 
  complex(kindr2) &
 
3488
  complex(kindr2) &   
3051
3489
     :: log2,log3
3052
3490
   integer :: icase,i1,i2,i3
3053
3491
!
3100
3538
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
3101
3539
! by sending one internal mass to infinity.
3102
3540
!*******************************************************************
3103
 
  complex(kindr2) &
 
3541
  complex(kindr2) &   
3104
3542
     ,intent(out) :: rslt(0:2)
3105
 
  complex(kindr2) &
 
3543
  complex(kindr2) &   
3106
3544
     ,intent(in)  :: p1,p2,p3
3107
3545
   type(qmplx_type) :: q23,q24,q34,qx1,qx2
3108
 
  complex(kindr2) &
 
3546
  complex(kindr2) &   
3109
3547
     :: r23,r24,r34,aa,bb,cc,dd,x1,x2
3110
 
  real(kindr2) &
 
3548
  real(kindr2) &  
3111
3549
     :: hh
3112
3550
!
3113
3551
   r23 = -p1
3147
3585
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
3148
3586
! by sending one internal mass to infinity.
3149
3587
!*******************************************************************
3150
 
  complex(kindr2) &
 
3588
  complex(kindr2) &   
3151
3589
     ,intent(out) :: rslt(0:2)
3152
 
  complex(kindr2) &
 
3590
  complex(kindr2) &   
3153
3591
     ,intent(in)  :: p1i,p2i,p3i ,m3i 
3154
3592
   type(qmplx_type) :: q23,q24,q34,qm4,qx1,qx2,qss
3155
 
  complex(kindr2) &
 
3593
  complex(kindr2) &   
3156
3594
     :: p2,p3,p4,p12,p23,m4,sm2,sm3,sm4 &
3157
3595
                     ,aa,bb,cc,dd,x1,x2,r23,r24,r34
3158
 
  real(kindr2) &
 
3596
  real(kindr2) &  
3159
3597
     :: mhh
 
3598
   logical :: r24Not0,r34Not0
3160
3599
!
3161
3600
!   p1 = nul
3162
3601
   p2 = p1i
3174
3613
   sm3 = mhh
3175
3614
   sm2 = sm3
3176
3615
!
3177
 
   r24 = 0
3178
 
   r34 = 0
3179
 
                  r23 = (   -p2 -p2 *IEPS )/(sm2*sm3)
3180
 
   if (m4.ne.p23) r24 = ( m4-p23-p23*IEPS )/(sm2*sm4)
3181
 
   if (m4.ne.p3 ) r34 = ( m4-p3 -p3 *IEPS )/(sm3*sm4)     
 
3616
   r23 = (   -p2 -p2 *IEPS )/(sm2*sm3)
 
3617
   r24 = ( m4-p23-p23*IEPS )/(sm2*sm4)
 
3618
   r34 = ( m4-p3 -p3 *IEPS )/(sm3*sm4)
 
3619
!
 
3620
   r24Not0 = (abs(areal(r24))+abs(aimag(r24)).ge.neglig(prcpar))
 
3621
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
3182
3622
!
3183
3623
   aa = r34*r24 - r23
3184
3624
!
3209
3649
   rslt(0) = -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) )/(x2*2) &
3210
3650
             -li2c2( qx1*qm4 ,qx2*qm4 )*sm4
3211
3651
!
3212
 
   if (r34.ne.CZRO) then
 
3652
   if (r34Not0) then
3213
3653
     qss = q34*mhh
3214
3654
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
3215
3655
   endif
3216
3656
!
3217
 
   if (r24.ne.CZRO) then
 
3657
   if (r24Not0) then
3218
3658
     qss = q24*mhh
3219
3659
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24*sm2
3220
3660
   endif
3232
3672
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
3233
3673
! by sending one internal mass to infinity.
3234
3674
!*******************************************************************
3235
 
  complex(kindr2) &
 
3675
  complex(kindr2) &   
3236
3676
     ,intent(out) :: rslt(0:2)
3237
 
  complex(kindr2) &
 
3677
  complex(kindr2) &   
3238
3678
     ,intent(in)  :: p1i,p2i,p3i ,m2i,m3i
3239
3679
   type(qmplx_type) :: q23,q34,q24,qm2,qm3,qm4,qx1,qx2,qss,qy1,qy2
3240
 
  complex(kindr2) &
 
3680
  complex(kindr2) &   
3241
3681
     :: p2,p3,p23,m2,m4,sm2,sm3,sm4,aa,bb,cc,dd,x1,x2 &
3242
3682
                     ,r23,k24,r34,r24,d24
 
3683
   logical :: r23Not0,r34Not0
3243
3684
!
3244
3685
!   p1 = nul
3245
3686
   p2 = p3i
3257
3698
   sm3 = abs(sm2) !mysqrt(m3)
3258
3699
   sm4 = mysqrt(m4)
3259
3700
!
3260
 
   r23 = 0
3261
 
   k24 = 0
3262
 
   r34 = 0
3263
 
   if (m2   .ne.p2 ) r23 = (    m2-p2 -p2 *IEPS )/(sm2*sm3) ! p2
3264
 
   if (m2+m4.ne.p23) k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
3265
 
   if (m4   .ne.p3 ) r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
3701
   r23 = (    m2-p2 -p2 *IEPS )/(sm2*sm3) ! p2
 
3702
   k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
 
3703
   r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
3704
!
 
3705
   r23Not0 = (abs(areal(r23))+abs(aimag(r23)).ge.neglig(prcpar))
 
3706
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
3266
3707
!
3267
3708
   call rfun( r24,d24 ,k24 )
3268
3709
!
3306
3747
!
3307
3748
   rslt(0) = rslt(0) - li2c2( qx1*qm4 ,qx2*qm4 )*sm4
3308
3749
!
3309
 
   if (r23.ne.CZRO) then
 
3750
   if (r23Not0) then
3310
3751
     qss = q23*qm3/q24
3311
3752
     rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23*sm3/r24
3312
3753
   endif
3313
3754
!
3314
 
   if (r34.ne.CZRO) then
 
3755
   if (r34Not0) then
3315
3756
     qss = q34*qm3
3316
3757
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
3317
3758
   endif
3327
3768
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
3328
3769
! by sending one internal mass to infinity.
3329
3770
!*******************************************************************
3330
 
  complex(kindr2) &
 
3771
  complex(kindr2) &   
3331
3772
     ,intent(out) :: rslt(0:2)
3332
 
  complex(kindr2) &
 
3773
  complex(kindr2) &   
3333
3774
     ,intent(in)  :: p1i,p2i,p3i,m1i,m2i,m3i
3334
3775
   type(qmplx_type) :: q12,q13,q23,qm1,qm2,qm3,qx1,qx2,qz1,qz2,qtt
3335
 
  complex(kindr2) &
 
3776
  complex(kindr2) &   
3336
3777
     :: p1,p2,p3,m1,m2,m3,sm1,sm2,sm3,aa,bb,cc,dd,x1,x2 &
3337
3778
                     ,k12,k13,k23,r12,r13,r23,d12,d13,d23 
3338
 
  real(kindr2) &
 
3779
  real(kindr2) &  
3339
3780
     :: h1,h2,h3
3340
3781
!
3341
3782
   h1 = -aimag(m1i)
3417
3858
! Finite 1-loop scalar 3-point function with all internal masses
3418
3859
! non-zero. Based on the fomula of 't Hooft & Veltman
3419
3860
!*******************************************************************
3420
 
  complex(kindr2) &
 
3861
  complex(kindr2) &   
3421
3862
     ,intent(out) :: rslt(0:2)
3422
 
  complex(kindr2) &
 
3863
  complex(kindr2) &   
3423
3864
     ,intent(in)  :: pp(3),mm(3)
3424
 
  real(kindr2) &
 
3865
  real(kindr2) &  
3425
3866
     ,intent(in)  :: ap(3),smax
3426
 
  complex(kindr2) &
 
3867
  complex(kindr2) &   
3427
3868
     ,optional ,intent(in) :: lam
3428
 
  complex(kindr2) &
 
3869
  complex(kindr2) &   
3429
3870
     :: p1,p2,p3,m1,m2,m3,slam,yy
3430
 
  complex(kindr2) &
 
3871
  complex(kindr2) &   
3431
3872
     :: sm1,sm2,sm3
3432
3873
   type(qmplx_type) :: qm1,qm2,qm3
3433
 
  real(kindr2) &
 
3874
  real(kindr2) &  
3434
3875
     :: a12,a23,a31,thrs,a1,a2,a3
3435
3876
!
3436
3877
! Order squared momenta, first one smallest
3543
3984
! function below.
3544
3985
! t4  should be  sqrt(lambda(aa,t2,t3))
3545
3986
!***************************************************************
3546
 
  complex(kindr2) &
 
3987
  complex(kindr2) &   
3547
3988
       ,intent(in) :: aa,s1,s2,t1
3548
 
  complex(kindr2) &
 
3989
  complex(kindr2) &   
3549
3990
       ,optional,intent(in) :: t2,t3
3550
 
  complex(kindr2) &
 
3991
  complex(kindr2) &   
3551
3992
       ,optional,intent(inout) :: t4
3552
 
  complex(kindr2) &
 
3993
  complex(kindr2) &   
3553
3994
       :: rslt ,cc,bb,dd,y0,y1,y2,zz,hh,alpha
3554
 
  real(kindr2) &
 
3995
  real(kindr2) &  
3555
3996
       :: rez,arez,aimz
3556
3997
     type(qmplx_type) :: q1,q2
3557
3998
!
3593
4034
!**************************************************
3594
4035
! int( ( ln(a*y+b) - ln(a*y0+b) )/(y-y0) ,y=0..1 )
3595
4036
!**************************************************
3596
 
  complex(kindr2) &
 
4037
  complex(kindr2) &   
3597
4038
       ,intent(in) :: aa,bb,y0
3598
 
  complex(kindr2) &
 
4039
  complex(kindr2) &   
3599
4040
       :: rslt ,y1,hh
3600
4041
     type(qmplx_type) :: q1
3601
4042
     y1 = -bb/aa
3657
4098
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
3658
4099
! m2,m4 should NOT be identically 0d0
3659
4100
!*******************************************************************
3660
 
  complex(kindr2) &
 
4101
  complex(kindr2) &   
3661
4102
     ,intent(out) :: rslt(0:2)
3662
 
  complex(kindr2) &
 
4103
  complex(kindr2) &   
3663
4104
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m3,m4
3664
 
  real(kindr2) &
 
4105
  real(kindr2) &  
3665
4106
     ,intent(in)  :: rmu
3666
 
  complex(kindr2) &
 
4107
  complex(kindr2) &   
3667
4108
     :: cp2,cp3,cp12,cp23,cm2,cm3,cm4,sm1,sm2,sm3,sm4 &
3668
4109
                     ,r13,r23,r24,r34,d23,d24,d34,log24,cc
3669
4110
   type(qmplx_type) :: q13,q23,q24,q34,qss,qy1,qy2,qz1,qz2
3736
4177
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
3737
4178
! m2,m4 should NOT be identically 0d0
3738
4179
!*******************************************************************
3739
 
  complex(kindr2) &
 
4180
  complex(kindr2) &   
3740
4181
     ,intent(out) :: rslt(0:2)
3741
 
  complex(kindr2) &
 
4182
  complex(kindr2) &   
3742
4183
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m4
3743
 
  real(kindr2) &
 
4184
  real(kindr2) &  
3744
4185
     ,intent(in)  :: rmu
3745
 
  complex(kindr2) &
 
4186
  complex(kindr2) &   
3746
4187
     :: cp2,cp3,cp12,cp23,cm2,cm4,sm1,sm2,sm3,sm4 &
3747
4188
                     ,r13,r23,r24,r34,d24,log24,cc
3748
4189
   type(qmplx_type) :: q13,q23,q24,q34,qss,qz1,qz2
3812
4253
! with  k1^2=m2, k2^2=m2, k3^2=m4, (k1+k2+k3)^2=m4
3813
4254
! m2,m4 should NOT be identically 0d0
3814
4255
!*******************************************************************
3815
 
  complex(kindr2) &
 
4256
  complex(kindr2) &   
3816
4257
     ,intent(out) :: rslt(0:2)
3817
 
  complex(kindr2) &
 
4258
  complex(kindr2) &   
3818
4259
     ,intent(in)  :: cp12,cp23,cm2,cm4
3819
 
  real(kindr2) &
 
4260
  real(kindr2) &  
3820
4261
     ,intent(in)  :: rmu
3821
 
  complex(kindr2) &
 
4262
  complex(kindr2) &   
3822
4263
     :: sm2,sm4,r24,d24,cc
3823
4264
!
3824
4265
   if (cp12.eq.CZRO) then
3860
4301
! p4 should NOT be identical to m4
3861
4302
! p2 should NOT be identical to m3
3862
4303
!*******************************************************************
3863
 
  complex(kindr2) &
 
4304
  complex(kindr2) &   
3864
4305
     ,intent(out) :: rslt(0:2)
3865
 
  complex(kindr2) &
 
4306
  complex(kindr2) &   
3866
4307
     ,intent(in)  :: p2,p3,p4,p12,p23,m3,m4
3867
 
  real(kindr2) &
 
4308
  real(kindr2) &  
3868
4309
     ,intent(in)  :: rmu
3869
 
  complex(kindr2) &
 
4310
  complex(kindr2) &   
3870
4311
     :: cp2,cp3,cp4,cp12,cp23,cm3,cm4,sm3,sm4,sm1,sm2 &
3871
4312
             ,r13,r14,r23,r24,r34,d34,cc,logd,li2d,loge,li2f,li2b,li2e
3872
4313
   type(qmplx_type) :: q13,q14,q23,q24,q34,qy1,qy2
3873
 
  real(kindr2) &
 
4314
  real(kindr2) &  
3874
4315
     :: h1,h2
3875
4316
!
3876
4317
   if (p12.eq.m3) then
3877
 
!     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
3878
 
!       ,'p12=m3, returning 0'
 
4318
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
4319
       ,'p12=m3, returning 0'
3879
4320
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
3880
4321
     return
3881
4322
   endif
3882
4323
   if (p23.eq.m4) then
3883
 
!     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
3884
 
!       ,'p23=m4, returning 0'
 
4324
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
4325
       ,'p23=m4, returning 0'
3885
4326
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
3886
4327
     return
3887
4328
   endif
3943
4384
! m3,m4 should NOT be indentiallcy 0d0
3944
4385
! p4 should NOT be identical to m4
3945
4386
!*******************************************************************
3946
 
  complex(kindr2) &
 
4387
  complex(kindr2) &   
3947
4388
     ,intent(out) :: rslt(0:2)
3948
 
  complex(kindr2) &
 
4389
  complex(kindr2) &   
3949
4390
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm3,cm4
3950
 
  real(kindr2) &
 
4391
  real(kindr2) &  
3951
4392
     ,intent(in)  :: rmu
3952
 
  complex(kindr2) &
 
4393
  complex(kindr2) &   
3953
4394
     :: sm3,sm4,sm1,sm2,r13,r14,r24,r34,d34,cc &
3954
4395
                     ,log13,log14,log24,log34,li2f,li2b,li2d
3955
4396
   type(qmplx_type) :: q13,q14,q24,q34,qyy
4015
4456
! with  k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=m4
4016
4457
! m3,m4 should NOT be indentiallcy 0d0
4017
4458
!*******************************************************************
4018
 
  complex(kindr2) &
 
4459
  complex(kindr2) &   
4019
4460
     ,intent(out) :: rslt(0:2)
4020
 
  complex(kindr2) &
 
4461
  complex(kindr2) &   
4021
4462
     ,intent(in)  :: cp3,cp12,cp23,cm3,cm4
4022
 
  real(kindr2) &
 
4463
  real(kindr2) &  
4023
4464
     ,intent(in)  :: rmu
4024
 
  complex(kindr2) &
 
4465
  complex(kindr2) &   
4025
4466
     :: sm3,sm4,sm1,sm2,r13,r24,r34,d34 &
4026
4467
                     ,cc,log13,log24,log34
4027
4468
!
4074
4515
! p2 should NOT be identically 0d0
4075
4516
! p4 should NOT be identical to m4
4076
4517
!*******************************************************************
4077
 
  complex(kindr2) &
 
4518
  complex(kindr2) &   
4078
4519
     ,intent(out) :: rslt(0:2)
4079
 
  complex(kindr2) &
 
4520
  complex(kindr2) &   
4080
4521
     ,intent(in)  :: p2,p3,p4,p12,p23,m4
4081
 
  real(kindr2) &
 
4522
  real(kindr2) &  
4082
4523
     ,intent(in)  :: rmu
4083
 
  complex(kindr2) &
 
4524
  complex(kindr2) &   
4084
4525
     :: cp2,cp3,cp4,cp12,cp23,cm4,r13,r14,r23,r24,r34,z1,z0
4085
4526
   type(qmplx_type) :: q13,q14,q23,q24,q34,qm4,qxx,qx1,qx2
4086
 
  real(kindr2) &
 
4527
  real(kindr2) &  
4087
4528
     :: h1,h2
4088
4529
!
4089
4530
   if (p12.eq.CZRO) then
4154
4595
! m4 should NOT be identically 0d0
4155
4596
! p2 should NOT be identically 0d0
4156
4597
!*******************************************************************
4157
 
  complex(kindr2) &
 
4598
  complex(kindr2) &   
4158
4599
     ,intent(out) :: rslt(0:2)
4159
 
  complex(kindr2) &
 
4600
  complex(kindr2) &   
4160
4601
     ,intent(in)  :: cp2,cp3,cp12,cp23,cm4
4161
 
  real(kindr2) &
 
4602
  real(kindr2) &  
4162
4603
     ,intent(in)  :: rmu
4163
 
  complex(kindr2) &
 
4604
  complex(kindr2) &   
4164
4605
     :: logm,log12,log23,li12,li23,z2,z1,z0,cc &
4165
4606
                     ,r13,r23,r24,r34
4166
4607
   type(qmplx_type) :: q13,q23,q24,q34,qm4,qxx
4220
4661
! mm should NOT be identically 0d0
4221
4662
! p3 NOR p4 should be identically m4
4222
4663
!*******************************************************************
4223
 
  complex(kindr2) &
 
4664
  complex(kindr2) &   
4224
4665
     ,intent(out) :: rslt(0:2)
4225
 
  complex(kindr2) &
 
4666
  complex(kindr2) &   
4226
4667
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm4
4227
 
  real(kindr2) &
 
4668
  real(kindr2) &  
4228
4669
     ,intent(in)  :: rmu
4229
4670
   type(qmplx_type) :: q13,q14,q24,q34,qm4,qxx,qx1,qx2,qx3
4230
 
  complex(kindr2) &
 
4671
  complex(kindr2) &   
4231
4672
     :: r13,r14,r24,r34,z1,z0,cc
4232
 
  real(kindr2) &
 
4673
  real(kindr2) &  
4233
4674
     :: rmu2
4234
4675
!
4235
4676
   if (cp12.eq.CZRO) then
4287
4728
! m3 should NOT be identically 0d0
4288
4729
! p4 should NOT be identically m4
4289
4730
!*******************************************************************
4290
 
  complex(kindr2) &
 
4731
  complex(kindr2) &   
4291
4732
     ,intent(out) :: rslt(0:2)
4292
 
  complex(kindr2) &
 
4733
  complex(kindr2) &   
4293
4734
     ,intent(in)  :: cp4,cp12,cp23,cm4
4294
 
  real(kindr2) &
 
4735
  real(kindr2) &  
4295
4736
     ,intent(in)  :: rmu
4296
4737
   type(qmplx_type) :: q13,q14,q24,qm4
4297
 
  complex(kindr2) &
 
4738
  complex(kindr2) &   
4298
4739
     :: r13,r14,r24,logm,log12,log23,log4,li423 &
4299
4740
                     ,z2,z1,z0,cc
4300
4741
!
4347
4788
! with  k1^2=k2^2=0, k3^2=(k1+k2+k3)^2=m4
4348
4789
! m3 should NOT be identically 0d0
4349
4790
!*******************************************************************
4350
 
  complex(kindr2) &
 
4791
  complex(kindr2) &   
4351
4792
     ,intent(out) :: rslt(0:2)
4352
 
  complex(kindr2) &
 
4793
  complex(kindr2) &   
4353
4794
     ,intent(in)  :: cp12,cp23,cm4
4354
 
  real(kindr2) &
 
4795
  real(kindr2) &  
4355
4796
     ,intent(in)  :: rmu
4356
4797
   type(qmplx_type) :: q13,q24,qm4
4357
 
  complex(kindr2) &
 
4798
  complex(kindr2) &   
4358
4799
     :: r13,r24,logm,log1,log2,z2,z1,z0,cc
4359
4800
!
4360
4801
   if (cp12.eq.CZRO) then
4400
4841
!
4401
4842
! with  k1^2=k3^2=0
4402
4843
!*******************************************************************
4403
 
  complex(kindr2) &
 
4844
  complex(kindr2) &   
4404
4845
     ,intent(out) :: rslt(0:2)
4405
 
  complex(kindr2) &
 
4846
  complex(kindr2) &   
4406
4847
     ,intent(in)  :: p2,p4,p5,p6 
4407
 
  real(kindr2) &
 
4848
  real(kindr2) &  
4408
4849
     ,intent(in)  :: rmu
4409
4850
   type(qmplx_type) :: q2,q4,q5,q6,q26,q54,qy
4410
 
  complex(kindr2) &
 
4851
  complex(kindr2) &   
4411
4852
     :: logy
4412
 
  real(kindr2) &
 
4853
  real(kindr2) &  
4413
4854
     :: rmu2
4414
4855
!
4415
4856
   rmu2 = rmu*rmu
4442
4883
!
4443
4884
! with  k1^2=0
4444
4885
!*******************************************************************
4445
 
  complex(kindr2) &
 
4886
  complex(kindr2) &   
4446
4887
     ,intent(out) :: rslt(0:2)
4447
 
  complex(kindr2) &
 
4888
  complex(kindr2) &   
4448
4889
     ,intent(in)  :: p2,p3,p4,p5,p6
4449
 
  real(kindr2) &
 
4890
  real(kindr2) &  
4450
4891
     ,intent(in)  :: rmu
4451
4892
   type(qmplx_type) ::q2,q3,q4,q5,q6 ,q25,q64,qy,qz
4452
 
  complex(kindr2) &
 
4893
  complex(kindr2) &   
4453
4894
     :: logy
4454
 
  real(kindr2) &
 
4895
  real(kindr2) &  
4455
4896
     :: rmu2
4456
4897
!
4457
4898
   rmu2 = rmu*rmu
4496
4937
!*******************************************************************
4497
4938
   use avh_olo_dp_olog
4498
4939
   use avh_olo_dp_dilog
4499
 
  complex(kindr2) &
 
4940
  complex(kindr2) &   
4500
4941
     ,intent(out) :: rslt(0:2)
4501
 
  complex(kindr2) &
 
4942
  complex(kindr2) &   
4502
4943
     ,intent(in)  :: cp(6)
4503
 
  real(kindr2) &
 
4944
  real(kindr2) &  
4504
4945
     ,intent(in)  :: api(6),rmu
4505
 
  complex(kindr2) &
 
4946
  complex(kindr2) &   
4506
4947
     :: log3,log4,log5,log6,li24,li25,li26 &
4507
4948
                     ,li254,li263
4508
 
  real(kindr2) &
 
4949
  real(kindr2) &  
4509
4950
     :: rp1,rp2,rp3,rp4,rp5,rp6,pp(6),ap(6),gg,ff,hh,arg,rmu2
4510
4951
   integer :: icase,sf,sgn,i3,i4,i5,i6
4511
4952
   integer ,parameter :: base(4)=(/8,4,2,1/)
4639
5080
! equal zero. Based on the formulas from
4640
5081
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
4641
5082
!*******************************************************************
4642
 
  complex(kindr2) &
 
5083
  complex(kindr2) &   
4643
5084
    ,intent(out) :: rslt(0:2) 
4644
 
  complex(kindr2) &
 
5085
  complex(kindr2) &   
4645
5086
    ,intent(in) :: p1,p2,p3,p4,p12,p23
4646
5087
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qss
4647
 
  complex(kindr2) &
 
5088
  complex(kindr2) &   
4648
5089
    :: aa,bb,cc,dd,x1,x2,ss,r12,r13,r14,r23,r24,r34
4649
 
  real(kindr2) &
 
5090
  real(kindr2) &  
4650
5091
    :: hh
4651
5092
!
4652
5093
  r12 = -p1  !  p1
4703
5144
! non-zero. Based on the formulas from
4704
5145
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
4705
5146
!*******************************************************************
4706
 
  complex(kindr2) &
 
5147
  complex(kindr2) &   
4707
5148
    ,intent(out) :: rslt(0:2) 
4708
 
  complex(kindr2) &
 
5149
  complex(kindr2) &   
4709
5150
    ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m4
4710
5151
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
4711
 
  complex(kindr2) &
 
5152
  complex(kindr2) &   
4712
5153
    :: smm,sm4,aa,bb,cc,dd,x1,x2,r12,r13,r14,r23,r24,r34
4713
5154
  logical :: r12zero,r13zero,r14zero
4714
5155
!
4792
5233
! masses non-zero. Based on the formulas from
4793
5234
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
4794
5235
!*******************************************************************
4795
 
  complex(kindr2) &
 
5236
  complex(kindr2) &   
4796
5237
    ,intent(out) :: rslt(0:2) 
4797
 
  complex(kindr2) &
 
5238
  complex(kindr2) &   
4798
5239
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m2,m4
4799
5240
  call boxf2( rslt ,p12,p2,p23,p4,p1,p3 ,m2,m4 )
4800
5241
  end subroutine
4806
5247
! masses non-zero. Based on the formulas from
4807
5248
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
4808
5249
!*******************************************************************
4809
 
  complex(kindr2) &
 
5250
  complex(kindr2) &   
4810
5251
    ,intent(out) :: rslt(0:2) 
4811
 
  complex(kindr2) &
 
5252
  complex(kindr2) &   
4812
5253
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m3,m4
4813
5254
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
4814
 
  complex(kindr2) &
 
5255
  complex(kindr2) &   
4815
5256
    :: smm,sm3,sm4,aa,bb,cc,dd,x1,x2 &
4816
5257
                    ,r12,r13,r14,r23,r24,r34,d14,k14
4817
5258
  logical :: r12zero,r13zero,r24zero,r34zero
4912
5353
! Finite 1-loop scalar 4-point function with three internal masses
4913
5354
! non-zero.
4914
5355
!*******************************************************************
4915
 
  complex(kindr2) &
 
5356
  complex(kindr2) &   
4916
5357
    ,intent(out) :: rslt(0:2) 
4917
 
  complex(kindr2) &
 
5358
  complex(kindr2) &   
4918
5359
    ,intent(in) :: pp(6),mm(4)
4919
5360
  integer :: j
4920
5361
  integer ,parameter :: ip(6)=(/4,5,2,6,3,1/)
4938
5379
! non-zero, and m3=0. Based on the formulas from
4939
5380
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
4940
5381
!*******************************************************************
4941
 
  complex(kindr2) &
 
5382
  complex(kindr2) &   
4942
5383
    ,intent(out) :: rslt(0:2) 
4943
 
  complex(kindr2) &
 
5384
  complex(kindr2) &   
4944
5385
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m4
4945
5386
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34,qy1,qy2
4946
 
  complex(kindr2) &
 
5387
  complex(kindr2) &   
4947
5388
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2 &
4948
5389
                    ,r12,r13,r14,r23,r24,r34,d12,d14,d24,k12,k14,k24
4949
5390
  logical ::r13zero,r23zero,r34zero
5038
5479
! non-zero. Based on the formulas from
5039
5480
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
5040
5481
!*******************************************************************
5041
 
  complex(kindr2) &
 
5482
  complex(kindr2) &   
5042
5483
    ,intent(out) :: rslt(0:2) 
5043
 
  complex(kindr2) &
 
5484
  complex(kindr2) &   
5044
5485
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4
5045
5486
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qy1,qy2,qtt
5046
 
  complex(kindr2) &
 
5487
  complex(kindr2) &   
5047
5488
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2,tt &
5048
5489
                    ,k12,k13,k14,k23,k24,k34 &
5049
5490
                    ,r12,r13,r14,r23,r24,r34 &
5050
5491
                    ,d12,d13,d14,d23,d24,d34
5051
 
  real(kindr2) &
 
5492
  real(kindr2) &  
5052
5493
    :: h1,h2
5053
5494
!
5054
5495
  sm1 = mysqrt(m1)
5141
5582
!   G. 't Hooft and M.J.G. Veltman, Nucl.Phys.B153:365-401,1979 
5142
5583
!*******************************************************************
5143
5584
   use avh_olo_dp_box ,only: base,casetable,ll=>permtable
5144
 
  complex(kindr2) &
 
5585
  complex(kindr2) &   
5145
5586
     ,intent(out) :: rslt(0:2)
5146
 
  complex(kindr2) &
 
5587
  complex(kindr2) &   
5147
5588
     ,intent(in)  :: pp_in(6),mm_in(4)
5148
 
  real(kindr2) &
 
5589
  real(kindr2) &  
5149
5590
     ,intent(in)  :: ap_in(6),smax
5150
 
  complex(kindr2) &
 
5591
  complex(kindr2) &   
5151
5592
     :: pp(6),mm(4)
5152
 
  real(kindr2) &
 
5593
  real(kindr2) &  
5153
5594
     :: ap(6),aptmp(6),rem,imm,hh
5154
 
  complex(kindr2) &
 
5595
  complex(kindr2) &   
5155
5596
     :: a,b,c,d,e,f,g,h,j,k,dpe,epk,x1,x2,sdnt,o1,j1,e1 &
5156
5597
       ,dek,dpf,def,dpk,abc,bgj,jph,cph
5157
5598
   integer :: icase,jcase,ii
5190
5631
   do ii=1,4
5191
5632
     rem = areal(mm_in(ii))
5192
5633
     imm = aimag(mm_in(ii))
5193
 
     hh = EPSN2*abs(rem)
 
5634
     hh = EPSN*abs(rem)
5194
5635
     if (abs(imm).lt.hh) imm = -hh
5195
5636
     mm(ii) = acmplx(rem,imm)
5196
5637
   enddo
5295
5736
!
5296
5737
! jj should have negative imaginary part
5297
5738
!*******************************************************************
5298
 
  complex(kindr2) &
 
5739
  complex(kindr2) &   
5299
5740
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj ,dpe,dpj,dpf
5300
 
  complex(kindr2) &
 
5741
  complex(kindr2) &   
5301
5742
     :: rslt ,kk,ll,nn,y1,y2,sdnt
5302
5743
!
5303
5744
!
5323
5764
!
5324
5765
! jj should have negative imaginary part
5325
5766
!*******************************************************************
5326
 
  complex(kindr2) &
 
5767
  complex(kindr2) &   
5327
5768
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj,dpe
5328
 
  complex(kindr2) &
 
5769
  complex(kindr2) &   
5329
5770
     ::rslt ,kk,ll,nn,y1,y2,sdnt
5330
5771
!
5331
5772
!
5349
5790
! | dx |  dy ------------------------------------------------------
5350
5791
! /0   /0    (g*x + h*x + j)*(a*x^2 + b*y^2 + c*xy + d*x + e*y + f)
5351
5792
!*******************************************************************
5352
 
  complex(kindr2) &
 
5793
  complex(kindr2) &   
5353
5794
     ,intent(in) :: aa,bb,cc ,gin,hin ,dd,ee,ff ,jin ,dpe ,dpf
5354
 
  complex(kindr2) &
 
5795
  complex(kindr2) &   
5355
5796
     :: rslt ,gg,hh,jj,zz(2),beta,tmpa(2),tmpb(2) &
5356
5797
       ,tmpc(2),kiz(2),ll,nn,kk,y1,y2,yy(2,2),sdnt
5357
 
  real(kindr2) &
 
5798
  real(kindr2) &  
5358
5799
     :: ab1,ab2,ac1,ac2,abab,acac,abac,det,ap1,ap2 &
5359
5800
                  ,apab,apac,x1(2,2),x2(2,2),xmin
5360
5801
   integer :: iz,iy,izmin,sj
5472
5913
!
5473
5914
! y1i,y2i should have a non-zero imaginary part
5474
5915
!*******************************************************************
5475
 
  complex(kindr2) &
 
5916
  complex(kindr2) &   
5476
5917
     ,intent(in) ::  y1i,y2i ,dd,ee ,aa,bb,cin
5477
 
  complex(kindr2) &
 
5918
  complex(kindr2) &   
5478
5919
     :: rslt ,y1,y2,fy1y2,z1,z2,tmp,cc
5479
 
  real(kindr2) &
 
5920
  real(kindr2) &  
5480
5921
     ::rea,reb,rez1,rez2,imz1,imz2,simc,hh
5481
5922
!
5482
5923
!
5580
6021
!                                 ---------------------------
5581
6022
!                                           y1 - y2
5582
6023
!*******************************************************************
5583
 
  complex(kindr2) &
 
6024
  complex(kindr2) &   
5584
6025
     ,intent(in) :: y1,y2,zz,fy1y2
5585
 
  complex(kindr2) &
 
6026
  complex(kindr2) &   
5586
6027
     :: rslt ,oz
5587
6028
   type(qmplx_type) :: q1z,q2z,qq
5588
 
  real(kindr2) &
 
6029
  real(kindr2) &  
5589
6030
     :: h12,hz1,hz2,hzz,hoz
5590
6031
   logical :: zzsmall,ozsmall
5591
6032
!
5650
6091
!
5651
6092
! y1,y2 should have non-zero imaginary parts
5652
6093
!*******************************************************************
5653
 
  complex(kindr2) &
 
6094
  complex(kindr2) &   
5654
6095
     ,intent(in) :: y1,y2
5655
 
  complex(kindr2) &
 
6096
  complex(kindr2) &   
5656
6097
     :: rslt ,oy1,oy2
5657
6098
   oy1 = 1-y1
5658
6099
   oy2 = 1-y2
5671
6112
! 
5672
6113
! p1,p2 are logical, to be interpreted as 0,1 in the formula above 
5673
6114
!*******************************************************************
5674
 
  complex(kindr2) &
 
6115
  complex(kindr2) &   
5675
6116
     ,intent(in) :: y1,y2 ,aa,bb,cc
5676
6117
   logical         ,intent(in) :: p1,p2
5677
 
  complex(kindr2) &
 
6118
  complex(kindr2) &   
5678
6119
     :: rslt ,x1,x2,xx
5679
6120
   type(qmplx_type) :: q1,q2
5680
6121
!
5723
6164
  public :: olo_unit ,olo_scale ,olo_onshell ,olo_setting
5724
6165
  public :: olo_precision
5725
6166
  public :: olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
 
6167
  public :: olo_an ,olo_bn
5726
6168
  public :: olo
5727
6169
  public :: olo_get_scale ,olo_get_onshell ,olo_get_precision
5728
6170
!
5729
 
  integer ,public ,parameter :: olo_kind=kindr2
 
6171
  integer ,public ,parameter :: olo_kind=kindr2    
5730
6172
!
5731
 
  real(kindr2) &
 
6173
  real(kindr2) &  
5732
6174
         ,save :: onshellthrs
5733
6175
  logical,save :: nonzerothrs = .false.
5734
6176
!
5735
 
  real(kindr2) &
 
6177
  real(kindr2) &  
5736
6178
         ,save :: muscale
5737
6179
!
5738
6180
  character(99) ,parameter :: warnonshell=&
5744
6186
  interface olo_a0
5745
6187
    module procedure a0_r,a0rr,a0_c,a0cr
5746
6188
  end interface 
 
6189
  interface olo_an
 
6190
    module procedure an_r,anrr,an_c,ancr
 
6191
  end interface 
5747
6192
  interface olo_b0
5748
6193
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
5749
6194
  end interface 
5750
6195
  interface olo_b11
5751
6196
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
5752
6197
  end interface 
 
6198
  interface olo_bn
 
6199
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
 
6200
  end interface 
5753
6201
  interface olo_c0
5754
6202
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
5755
6203
  end interface 
5759
6207
!
5760
6208
  interface olo
5761
6209
    module procedure a0_r,a0rr,a0_c,a0cr
 
6210
    module procedure an_r,anrr,an_c,ancr
5762
6211
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
5763
6212
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
 
6213
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
5764
6214
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
5765
6215
    module procedure d0rr,d0rrr,d0rc,d0rcr,d0cc,d0ccr
5766
6216
  end interface 
5802
6252
  if (initz) then
5803
6253
    call init( ndec )
5804
6254
  else
5805
 
    call set_precision( newprc )
 
6255
    call set_precision( newprc )       
5806
6256
    if (newprc) then
5807
6257
      call update_olog
5808
6258
      call update_dilog
5880
6330
  if (present(iunit)) nunit = iunit
5881
6331
  if (nunit.le.0) return
5882
6332
!
5883
 
  write(nunit,*) 'MESSAGE from OneLOop: real kind parameter =',trim(myprint(kindr2))
 
6333
  write(nunit,*) 'MESSAGE from OneLOop: real kind parameter =',trim(myprint(kindr2)) 
5884
6334
  write(nunit,*) 'MESSAGE from OneLOop: number of decimals  =',trim(myprint(ndecim(prcpar)))
5885
6335
!
5886
6336
  if (nonzerothrs) then
5916
6366
!
5917
6367
  use avh_olo_dp_bub ,only: tadp
5918
6368
!
5919
 
  complex(kindr2) &
 
6369
  complex(kindr2) &   
5920
6370
    ,intent(out) :: rslt(0:2)
5921
 
  complex(kindr2) &
 
6371
  complex(kindr2) &   
5922
6372
    ,intent(in)  :: mm
5923
6373
!
5924
 
  complex(kindr2) &
 
6374
  complex(kindr2) &   
5925
6375
    :: ss
5926
 
  real(kindr2) &
 
6376
  real(kindr2) &  
5927
6377
    :: am,hh,mulocal,mulocal2
5928
6378
  character(25+99) ,parameter :: warning=&
5929
6379
                     'WARNING from OneLOop a0: '//warnonshell
5930
6380
  if (initz) call init
5931
6381
!
5932
 
  mulocal = muscale
 
6382
  mulocal = muscale 
5933
6383
!
5934
6384
  am = abs(mm)
5935
6385
!
5960
6410
!
5961
6411
  use avh_olo_dp_bub ,only: tadp
5962
6412
!
5963
 
  complex(kindr2) &
 
6413
  complex(kindr2) &   
5964
6414
    ,intent(out) :: rslt(0:2)
5965
 
  complex(kindr2) &
 
6415
  complex(kindr2) &   
5966
6416
    ,intent(in)  :: mm
5967
 
  real(kindr2) &
5968
 
   ,intent(in)  :: rmu
 
6417
  real(kindr2) &  
 
6418
   ,intent(in)  :: rmu       
5969
6419
!
5970
 
  complex(kindr2) &
 
6420
  complex(kindr2) &   
5971
6421
    :: ss
5972
 
  real(kindr2) &
 
6422
  real(kindr2) &  
5973
6423
    :: am,hh,mulocal,mulocal2
5974
6424
  character(25+99) ,parameter :: warning=&
5975
6425
                     'WARNING from OneLOop a0: '//warnonshell
5976
6426
  if (initz) call init
5977
6427
!
5978
 
  mulocal = rmu
 
6428
  mulocal = rmu     
5979
6429
!
5980
6430
  am = abs(mm)
5981
6431
!
6006
6456
!
6007
6457
  use avh_olo_dp_bub ,only: tadp
6008
6458
!
6009
 
  complex(kindr2) &
 
6459
  complex(kindr2) &   
6010
6460
    ,intent(out) :: rslt(0:2)
6011
 
  real(kindr2) &
 
6461
  real(kindr2) &  
6012
6462
    ,intent(in)  :: mm
6013
6463
!
6014
 
  complex(kindr2) &
 
6464
  complex(kindr2) &   
6015
6465
    :: ss
6016
 
  real(kindr2) &
 
6466
  real(kindr2) &  
6017
6467
    :: am,hh,mulocal,mulocal2
6018
6468
  character(25+99) ,parameter :: warning=&
6019
6469
                     'WARNING from OneLOop a0: '//warnonshell
6020
6470
  if (initz) call init
6021
6471
!
6022
 
  mulocal = muscale
 
6472
  mulocal = muscale 
6023
6473
!
6024
6474
  am = abs(mm)
6025
6475
!
6050
6500
!
6051
6501
  use avh_olo_dp_bub ,only: tadp
6052
6502
!
6053
 
  complex(kindr2) &
 
6503
  complex(kindr2) &   
6054
6504
    ,intent(out) :: rslt(0:2)
6055
 
  real(kindr2) &
 
6505
  real(kindr2) &  
6056
6506
    ,intent(in)  :: mm
6057
 
  real(kindr2) &
6058
 
   ,intent(in)  :: rmu
 
6507
  real(kindr2) &  
 
6508
   ,intent(in)  :: rmu       
6059
6509
!
6060
 
  complex(kindr2) &
 
6510
  complex(kindr2) &   
6061
6511
    :: ss
6062
 
  real(kindr2) &
 
6512
  real(kindr2) &  
6063
6513
    :: am,hh,mulocal,mulocal2
6064
6514
  character(25+99) ,parameter :: warning=&
6065
6515
                     'WARNING from OneLOop a0: '//warnonshell
6066
6516
  if (initz) call init
6067
6517
!
6068
 
  mulocal = rmu
 
6518
  mulocal = rmu     
6069
6519
!
6070
6520
  am = abs(mm)
6071
6521
!
6093
6543
  end subroutine
6094
6544
 
6095
6545
 
 
6546
  subroutine an_c( rslt ,rank ,mm )
 
6547
!
 
6548
  use avh_olo_dp_bub ,only: tadpn
 
6549
!
 
6550
  complex(kindr2) &   
 
6551
    ,intent(out) :: rslt(0:,0:)   
 
6552
  complex(kindr2) &   
 
6553
    ,intent(in)  :: mm
 
6554
  integer,intent(in) :: rank
 
6555
!
 
6556
  complex(kindr2) &   
 
6557
    :: ss
 
6558
  real(kindr2) &  
 
6559
    :: am,hh,mulocal,mulocal2
 
6560
  integer :: ii
 
6561
  character(25+99) ,parameter :: warning=&
 
6562
                     'WARNING from OneLOop An: '//warnonshell
 
6563
  if (initz) call init
 
6564
!
 
6565
  mulocal = muscale 
 
6566
!
 
6567
  am = abs(mm)
 
6568
!
 
6569
  mulocal2 = mulocal*mulocal
 
6570
!
 
6571
  if (nonzerothrs) then
 
6572
    hh = onshellthrs
 
6573
    if (am.lt.hh) am = 0
 
6574
  elseif (wunit.gt.0) then
 
6575
    hh = onshellthrs*max(am,mulocal2)
 
6576
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
6577
  endif
 
6578
!
 
6579
  ss = mm
 
6580
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
6581
!
 
6582
  if (punit.gt.0) then
 
6583
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
6584
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
6585
    write(punit,*) ' mm:',trim(myprint(mm))
 
6586
    do ii=0,rank/2
 
6587
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
6588
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
6589
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
6590
    enddo
 
6591
  endif
 
6592
  end subroutine
 
6593
 
 
6594
  subroutine ancr( rslt ,rank ,mm ,rmu )
 
6595
!
 
6596
  use avh_olo_dp_bub ,only: tadpn
 
6597
!
 
6598
  complex(kindr2) &   
 
6599
    ,intent(out) :: rslt(0:,0:)   
 
6600
  complex(kindr2) &   
 
6601
    ,intent(in)  :: mm
 
6602
  real(kindr2) &  
 
6603
   ,intent(in)  :: rmu       
 
6604
  integer,intent(in) :: rank
 
6605
!
 
6606
  complex(kindr2) &   
 
6607
    :: ss
 
6608
  real(kindr2) &  
 
6609
    :: am,hh,mulocal,mulocal2
 
6610
  integer :: ii
 
6611
  character(25+99) ,parameter :: warning=&
 
6612
                     'WARNING from OneLOop An: '//warnonshell
 
6613
  if (initz) call init
 
6614
!
 
6615
  mulocal = rmu     
 
6616
!
 
6617
  am = abs(mm)
 
6618
!
 
6619
  mulocal2 = mulocal*mulocal
 
6620
!
 
6621
  if (nonzerothrs) then
 
6622
    hh = onshellthrs
 
6623
    if (am.lt.hh) am = 0
 
6624
  elseif (wunit.gt.0) then
 
6625
    hh = onshellthrs*max(am,mulocal2)
 
6626
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
6627
  endif
 
6628
!
 
6629
  ss = mm
 
6630
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
6631
!
 
6632
  if (punit.gt.0) then
 
6633
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
6634
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
6635
    write(punit,*) ' mm:',trim(myprint(mm))
 
6636
    do ii=0,rank/2
 
6637
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
6638
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
6639
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
6640
    enddo
 
6641
  endif
 
6642
  end subroutine
 
6643
 
 
6644
  subroutine an_r( rslt ,rank ,mm  )
 
6645
!
 
6646
  use avh_olo_dp_bub ,only: tadpn
 
6647
!
 
6648
  complex(kindr2) &   
 
6649
    ,intent(out) :: rslt(0:,0:)   
 
6650
  real(kindr2) &  
 
6651
    ,intent(in)  :: mm
 
6652
  integer,intent(in) :: rank
 
6653
!
 
6654
  complex(kindr2) &   
 
6655
    :: ss
 
6656
  real(kindr2) &  
 
6657
    :: am,hh,mulocal,mulocal2
 
6658
  integer :: ii
 
6659
  character(25+99) ,parameter :: warning=&
 
6660
                     'WARNING from OneLOop An: '//warnonshell
 
6661
  if (initz) call init
 
6662
!
 
6663
  mulocal = muscale 
 
6664
!
 
6665
  am = abs(mm)
 
6666
!
 
6667
  mulocal2 = mulocal*mulocal
 
6668
!
 
6669
  if (nonzerothrs) then
 
6670
    hh = onshellthrs
 
6671
    if (am.lt.hh) am = 0
 
6672
  elseif (wunit.gt.0) then
 
6673
    hh = onshellthrs*max(am,mulocal2)
 
6674
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
6675
  endif
 
6676
!
 
6677
  ss = mm
 
6678
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
6679
!
 
6680
  if (punit.gt.0) then
 
6681
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
6682
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
6683
    write(punit,*) ' mm:',trim(myprint(mm))
 
6684
    do ii=0,rank/2
 
6685
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
6686
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
6687
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
6688
    enddo
 
6689
  endif
 
6690
  end subroutine
 
6691
 
 
6692
  subroutine anrr( rslt ,rank ,mm ,rmu )
 
6693
!
 
6694
  use avh_olo_dp_bub ,only: tadpn
 
6695
!
 
6696
  complex(kindr2) &   
 
6697
    ,intent(out) :: rslt(0:,0:)   
 
6698
  real(kindr2) &  
 
6699
    ,intent(in)  :: mm
 
6700
  real(kindr2) &  
 
6701
   ,intent(in)  :: rmu       
 
6702
  integer,intent(in) :: rank
 
6703
!
 
6704
  complex(kindr2) &   
 
6705
    :: ss
 
6706
  real(kindr2) &  
 
6707
    :: am,hh,mulocal,mulocal2
 
6708
  integer :: ii
 
6709
  character(25+99) ,parameter :: warning=&
 
6710
                     'WARNING from OneLOop An: '//warnonshell
 
6711
  if (initz) call init
 
6712
!
 
6713
  mulocal = rmu     
 
6714
!
 
6715
  am = abs(mm)
 
6716
!
 
6717
  mulocal2 = mulocal*mulocal
 
6718
!
 
6719
  if (nonzerothrs) then
 
6720
    hh = onshellthrs
 
6721
    if (am.lt.hh) am = 0
 
6722
  elseif (wunit.gt.0) then
 
6723
    hh = onshellthrs*max(am,mulocal2)
 
6724
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
6725
  endif
 
6726
!
 
6727
  ss = mm
 
6728
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
6729
!
 
6730
  if (punit.gt.0) then
 
6731
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
6732
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
6733
    write(punit,*) ' mm:',trim(myprint(mm))
 
6734
    do ii=0,rank/2
 
6735
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
6736
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
6737
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
6738
    enddo
 
6739
  endif
 
6740
  end subroutine
 
6741
 
 
6742
 
6096
6743
!*******************************************************************
6097
6744
!
6098
6745
!           C   /      d^(Dim)q
6115
6762
!
6116
6763
  use avh_olo_dp_bub ,only: bub0
6117
6764
!
6118
 
  complex(kindr2) &
 
6765
  complex(kindr2) &   
6119
6766
    ,intent(out) :: rslt(0:2)
6120
 
  complex(kindr2) &
 
6767
  complex(kindr2) &   
6121
6768
    ,intent(in)  :: pp
6122
 
  complex(kindr2) &
 
6769
  complex(kindr2) &   
6123
6770
    ,intent(in)  :: m1,m2
6124
6771
!
6125
 
  complex(kindr2) &
 
6772
  complex(kindr2) &   
6126
6773
    :: ss,r1,r2
6127
 
  real(kindr2) &
 
6774
  real(kindr2) &  
6128
6775
    :: app,am1,am2,hh,mulocal,mulocal2
6129
6776
  character(25+99) ,parameter :: warning=&
6130
6777
                     'WARNING from OneLOop b0: '//warnonshell
6149
6796
    r1 = acmplx( am1 ,-hh )
6150
6797
  endif
6151
6798
  am1 = abs(am1) + abs(hh)
6152
 
 
 
6799
!
6153
6800
  am2 = areal(r2)
6154
6801
  hh  = aimag(r2)
6155
6802
  if (hh.gt.RZRO) then
6159
6806
  endif
6160
6807
  am2 = abs(am2) + abs(hh)
6161
6808
!
6162
 
  mulocal = muscale
 
6809
  mulocal = muscale 
6163
6810
!
6164
6811
  mulocal2 = mulocal*mulocal
6165
6812
!
6193
6840
!
6194
6841
  use avh_olo_dp_bub ,only: bub0
6195
6842
!
6196
 
  complex(kindr2) &
 
6843
  complex(kindr2) &   
6197
6844
    ,intent(out) :: rslt(0:2)
6198
 
  complex(kindr2) &
 
6845
  complex(kindr2) &   
6199
6846
    ,intent(in)  :: pp
6200
 
  complex(kindr2) &
 
6847
  complex(kindr2) &   
6201
6848
    ,intent(in)  :: m1,m2
6202
 
  real(kindr2) &
6203
 
   ,intent(in)  :: rmu
 
6849
  real(kindr2) &  
 
6850
   ,intent(in)  :: rmu       
6204
6851
!
6205
 
  complex(kindr2) &
 
6852
  complex(kindr2) &   
6206
6853
    :: ss,r1,r2
6207
 
  real(kindr2) &
 
6854
  real(kindr2) &  
6208
6855
    :: app,am1,am2,hh,mulocal,mulocal2
6209
6856
  character(25+99) ,parameter :: warning=&
6210
6857
                     'WARNING from OneLOop b0: '//warnonshell
6229
6876
    r1 = acmplx( am1 ,-hh )
6230
6877
  endif
6231
6878
  am1 = abs(am1) + abs(hh)
6232
 
 
 
6879
!
6233
6880
  am2 = areal(r2)
6234
6881
  hh  = aimag(r2)
6235
6882
  if (hh.gt.RZRO) then
6239
6886
  endif
6240
6887
  am2 = abs(am2) + abs(hh)
6241
6888
!
6242
 
  mulocal = rmu
 
6889
  mulocal = rmu     
6243
6890
!
6244
6891
  mulocal2 = mulocal*mulocal
6245
6892
!
6273
6920
!
6274
6921
  use avh_olo_dp_bub ,only: bub0
6275
6922
!
6276
 
  complex(kindr2) &
 
6923
  complex(kindr2) &   
6277
6924
    ,intent(out) :: rslt(0:2)
6278
 
  real(kindr2) &
 
6925
  real(kindr2) &  
6279
6926
    ,intent(in)  :: pp
6280
 
  complex(kindr2) &
 
6927
  complex(kindr2) &   
6281
6928
    ,intent(in)  :: m1,m2
6282
6929
!
6283
 
  complex(kindr2) &
 
6930
  complex(kindr2) &   
6284
6931
    :: ss,r1,r2
6285
 
  real(kindr2) &
 
6932
  real(kindr2) &  
6286
6933
    :: app,am1,am2,hh,mulocal,mulocal2
6287
6934
  character(25+99) ,parameter :: warning=&
6288
6935
                     'WARNING from OneLOop b0: '//warnonshell
6291
6938
  r1 = m1
6292
6939
  r2 = m2
6293
6940
!
6294
 
  app=abs(pp)
 
6941
  app = abs(pp)
6295
6942
!
6296
6943
  am1 = areal(r1)
6297
6944
  hh  = aimag(r1)
6301
6948
    r1 = acmplx( am1 ,-hh )
6302
6949
  endif
6303
6950
  am1 = abs(am1) + abs(hh)
6304
 
 
 
6951
!
6305
6952
  am2 = areal(r2)
6306
6953
  hh  = aimag(r2)
6307
6954
  if (hh.gt.RZRO) then
6311
6958
  endif
6312
6959
  am2 = abs(am2) + abs(hh)
6313
6960
!
6314
 
  mulocal = muscale
 
6961
  mulocal = muscale 
6315
6962
!
6316
6963
  mulocal2 = mulocal*mulocal
6317
6964
!
6345
6992
!
6346
6993
  use avh_olo_dp_bub ,only: bub0
6347
6994
!
6348
 
  complex(kindr2) &
 
6995
  complex(kindr2) &   
6349
6996
    ,intent(out) :: rslt(0:2)
6350
 
  real(kindr2) &
 
6997
  real(kindr2) &  
6351
6998
    ,intent(in)  :: pp
6352
 
  complex(kindr2) &
 
6999
  complex(kindr2) &   
6353
7000
    ,intent(in)  :: m1,m2
6354
 
  real(kindr2) &
6355
 
   ,intent(in)  :: rmu
 
7001
  real(kindr2) &  
 
7002
   ,intent(in)  :: rmu       
6356
7003
!
6357
 
  complex(kindr2) &
 
7004
  complex(kindr2) &   
6358
7005
    :: ss,r1,r2
6359
 
  real(kindr2) &
 
7006
  real(kindr2) &  
6360
7007
    :: app,am1,am2,hh,mulocal,mulocal2
6361
7008
  character(25+99) ,parameter :: warning=&
6362
7009
                     'WARNING from OneLOop b0: '//warnonshell
6365
7012
  r1 = m1
6366
7013
  r2 = m2
6367
7014
!
6368
 
  app=abs(pp)
 
7015
  app = abs(pp)
6369
7016
!
6370
7017
  am1 = areal(r1)
6371
7018
  hh  = aimag(r1)
6375
7022
    r1 = acmplx( am1 ,-hh )
6376
7023
  endif
6377
7024
  am1 = abs(am1) + abs(hh)
6378
 
 
 
7025
!
6379
7026
  am2 = areal(r2)
6380
7027
  hh  = aimag(r2)
6381
7028
  if (hh.gt.RZRO) then
6385
7032
  endif
6386
7033
  am2 = abs(am2) + abs(hh)
6387
7034
!
6388
 
  mulocal = rmu
 
7035
  mulocal = rmu     
6389
7036
!
6390
7037
  mulocal2 = mulocal*mulocal
6391
7038
!
6419
7066
!
6420
7067
  use avh_olo_dp_bub ,only: bub0
6421
7068
!
6422
 
  complex(kindr2) &
 
7069
  complex(kindr2) &   
6423
7070
    ,intent(out) :: rslt(0:2)
6424
 
  real(kindr2) &
 
7071
  real(kindr2) &  
6425
7072
    ,intent(in)  :: pp
6426
 
  real(kindr2) &
 
7073
  real(kindr2) &  
6427
7074
    ,intent(in)  :: m1,m2
6428
7075
!
6429
 
  complex(kindr2) &
 
7076
  complex(kindr2) &   
6430
7077
    :: ss,r1,r2
6431
 
  real(kindr2) &
 
7078
  real(kindr2) &  
6432
7079
    :: app,am1,am2,hh,mulocal,mulocal2
6433
7080
  character(25+99) ,parameter :: warning=&
6434
7081
                     'WARNING from OneLOop b0: '//warnonshell
6437
7084
  r1 = m1
6438
7085
  r2 = m2
6439
7086
!
6440
 
  app=abs(pp)
 
7087
  app = abs(pp)
6441
7088
!
6442
7089
  am1 = abs(m1)
6443
7090
  am2 = abs(m2)
6444
7091
!
6445
 
  mulocal = muscale
 
7092
  mulocal = muscale 
6446
7093
!
6447
7094
  mulocal2 = mulocal*mulocal
6448
7095
!
6476
7123
!
6477
7124
  use avh_olo_dp_bub ,only: bub0
6478
7125
!
6479
 
  complex(kindr2) &
 
7126
  complex(kindr2) &   
6480
7127
    ,intent(out) :: rslt(0:2)
6481
 
  real(kindr2) &
 
7128
  real(kindr2) &  
6482
7129
    ,intent(in)  :: pp
6483
 
  real(kindr2) &
 
7130
  real(kindr2) &  
6484
7131
    ,intent(in)  :: m1,m2
6485
 
  real(kindr2) &
6486
 
   ,intent(in)  :: rmu
 
7132
  real(kindr2) &  
 
7133
   ,intent(in)  :: rmu       
6487
7134
!
6488
 
  complex(kindr2) &
 
7135
  complex(kindr2) &   
6489
7136
    :: ss,r1,r2
6490
 
  real(kindr2) &
 
7137
  real(kindr2) &  
6491
7138
    :: app,am1,am2,hh,mulocal,mulocal2
6492
7139
  character(25+99) ,parameter :: warning=&
6493
7140
                     'WARNING from OneLOop b0: '//warnonshell
6496
7143
  r1 = m1
6497
7144
  r2 = m2
6498
7145
!
6499
 
  app=abs(pp)
 
7146
  app = abs(pp)
6500
7147
!
6501
7148
  am1 = abs(m1)
6502
7149
  am2 = abs(m2)
6503
7150
!
6504
 
  mulocal = rmu
 
7151
  mulocal = rmu     
6505
7152
!
6506
7153
  mulocal2 = mulocal*mulocal
6507
7154
!
6555
7202
!
6556
7203
  use avh_olo_dp_bub ,only: bub11
6557
7204
!
6558
 
  complex(kindr2) &
 
7205
  complex(kindr2) &   
6559
7206
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6560
 
  complex(kindr2) &
 
7207
  complex(kindr2) &   
6561
7208
    ,intent(in)  :: pp
6562
 
  complex(kindr2) &
 
7209
  complex(kindr2) &   
6563
7210
    ,intent(in)  :: m1,m2
6564
7211
!
6565
 
  complex(kindr2) &
 
7212
  complex(kindr2) &   
6566
7213
    :: ss,r1,r2
6567
 
  real(kindr2) &
 
7214
  real(kindr2) &  
6568
7215
    :: app,am1,am2,hh,mulocal,mulocal2
6569
7216
  character(26+99) ,parameter :: warning=&
6570
7217
                     'WARNING from OneLOop b11: '//warnonshell
6589
7236
    r1 = acmplx( am1 ,-hh )
6590
7237
  endif
6591
7238
  am1 = abs(am1) + abs(hh)
6592
 
 
 
7239
!
6593
7240
  am2 = areal(r2)
6594
7241
  hh  = aimag(r2)
6595
7242
  if (hh.gt.RZRO) then
6599
7246
  endif
6600
7247
  am2 = abs(am2) + abs(hh)
6601
7248
!
6602
 
  mulocal = muscale
 
7249
  mulocal = muscale 
6603
7250
!
6604
7251
  mulocal2 = mulocal*mulocal
6605
7252
!
6642
7289
!
6643
7290
  use avh_olo_dp_bub ,only: bub11
6644
7291
!
6645
 
  complex(kindr2) &
 
7292
  complex(kindr2) &   
6646
7293
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6647
 
  complex(kindr2) &
 
7294
  complex(kindr2) &   
6648
7295
    ,intent(in)  :: pp
6649
 
  complex(kindr2) &
 
7296
  complex(kindr2) &   
6650
7297
    ,intent(in)  :: m1,m2
6651
 
  real(kindr2) &
6652
 
   ,intent(in)  :: rmu
 
7298
  real(kindr2) &  
 
7299
   ,intent(in)  :: rmu       
6653
7300
!
6654
 
  complex(kindr2) &
 
7301
  complex(kindr2) &   
6655
7302
    :: ss,r1,r2
6656
 
  real(kindr2) &
 
7303
  real(kindr2) &  
6657
7304
    :: app,am1,am2,hh,mulocal,mulocal2
6658
7305
  character(26+99) ,parameter :: warning=&
6659
7306
                     'WARNING from OneLOop b11: '//warnonshell
6678
7325
    r1 = acmplx( am1 ,-hh )
6679
7326
  endif
6680
7327
  am1 = abs(am1) + abs(hh)
6681
 
 
 
7328
!
6682
7329
  am2 = areal(r2)
6683
7330
  hh  = aimag(r2)
6684
7331
  if (hh.gt.RZRO) then
6688
7335
  endif
6689
7336
  am2 = abs(am2) + abs(hh)
6690
7337
!
6691
 
  mulocal = rmu
 
7338
  mulocal = rmu     
6692
7339
!
6693
7340
  mulocal2 = mulocal*mulocal
6694
7341
!
6731
7378
!
6732
7379
  use avh_olo_dp_bub ,only: bub11
6733
7380
!
6734
 
  complex(kindr2) &
 
7381
  complex(kindr2) &   
6735
7382
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6736
 
  real(kindr2) &
 
7383
  real(kindr2) &  
6737
7384
    ,intent(in)  :: pp
6738
 
  complex(kindr2) &
 
7385
  complex(kindr2) &   
6739
7386
    ,intent(in)  :: m1,m2
6740
7387
!
6741
 
  complex(kindr2) &
 
7388
  complex(kindr2) &   
6742
7389
    :: ss,r1,r2
6743
 
  real(kindr2) &
 
7390
  real(kindr2) &  
6744
7391
    :: app,am1,am2,hh,mulocal,mulocal2
6745
7392
  character(26+99) ,parameter :: warning=&
6746
7393
                     'WARNING from OneLOop b11: '//warnonshell
6749
7396
  r1 = m1
6750
7397
  r2 = m2
6751
7398
!
6752
 
  app=abs(pp)
 
7399
  app = abs(pp)
6753
7400
!
6754
7401
  am1 = areal(r1)
6755
7402
  hh  = aimag(r1)
6759
7406
    r1 = acmplx( am1 ,-hh )
6760
7407
  endif
6761
7408
  am1 = abs(am1) + abs(hh)
6762
 
 
 
7409
!
6763
7410
  am2 = areal(r2)
6764
7411
  hh  = aimag(r2)
6765
7412
  if (hh.gt.RZRO) then
6769
7416
  endif
6770
7417
  am2 = abs(am2) + abs(hh)
6771
7418
!
6772
 
  mulocal = muscale
 
7419
  mulocal = muscale 
6773
7420
!
6774
7421
  mulocal2 = mulocal*mulocal
6775
7422
!
6812
7459
!
6813
7460
  use avh_olo_dp_bub ,only: bub11
6814
7461
!
6815
 
  complex(kindr2) &
 
7462
  complex(kindr2) &   
6816
7463
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6817
 
  real(kindr2) &
 
7464
  real(kindr2) &  
6818
7465
    ,intent(in)  :: pp
6819
 
  complex(kindr2) &
 
7466
  complex(kindr2) &   
6820
7467
    ,intent(in)  :: m1,m2
6821
 
  real(kindr2) &
6822
 
   ,intent(in)  :: rmu
 
7468
  real(kindr2) &  
 
7469
   ,intent(in)  :: rmu       
6823
7470
!
6824
 
  complex(kindr2) &
 
7471
  complex(kindr2) &   
6825
7472
    :: ss,r1,r2
6826
 
  real(kindr2) &
 
7473
  real(kindr2) &  
6827
7474
    :: app,am1,am2,hh,mulocal,mulocal2
6828
7475
  character(26+99) ,parameter :: warning=&
6829
7476
                     'WARNING from OneLOop b11: '//warnonshell
6832
7479
  r1 = m1
6833
7480
  r2 = m2
6834
7481
!
6835
 
  app=abs(pp)
 
7482
  app = abs(pp)
6836
7483
!
6837
7484
  am1 = areal(r1)
6838
7485
  hh  = aimag(r1)
6842
7489
    r1 = acmplx( am1 ,-hh )
6843
7490
  endif
6844
7491
  am1 = abs(am1) + abs(hh)
6845
 
 
 
7492
!
6846
7493
  am2 = areal(r2)
6847
7494
  hh  = aimag(r2)
6848
7495
  if (hh.gt.RZRO) then
6852
7499
  endif
6853
7500
  am2 = abs(am2) + abs(hh)
6854
7501
!
6855
 
  mulocal = rmu
 
7502
  mulocal = rmu     
6856
7503
!
6857
7504
  mulocal2 = mulocal*mulocal
6858
7505
!
6895
7542
!
6896
7543
  use avh_olo_dp_bub ,only: bub11
6897
7544
!
6898
 
  complex(kindr2) &
 
7545
  complex(kindr2) &   
6899
7546
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6900
 
  real(kindr2) &
 
7547
  real(kindr2) &  
6901
7548
    ,intent(in)  :: pp
6902
 
  real(kindr2) &
 
7549
  real(kindr2) &  
6903
7550
    ,intent(in)  :: m1,m2
6904
7551
!
6905
 
  complex(kindr2) &
 
7552
  complex(kindr2) &   
6906
7553
    :: ss,r1,r2
6907
 
  real(kindr2) &
 
7554
  real(kindr2) &  
6908
7555
    :: app,am1,am2,hh,mulocal,mulocal2
6909
7556
  character(26+99) ,parameter :: warning=&
6910
7557
                     'WARNING from OneLOop b11: '//warnonshell
6913
7560
  r1 = m1
6914
7561
  r2 = m2
6915
7562
!
6916
 
  app=abs(pp)
 
7563
  app = abs(pp)
6917
7564
!
6918
7565
  am1 = abs(m1)
6919
7566
  am2 = abs(m2)
6920
7567
!
6921
 
  mulocal = muscale
 
7568
  mulocal = muscale 
6922
7569
!
6923
7570
  mulocal2 = mulocal*mulocal
6924
7571
!
6961
7608
!
6962
7609
  use avh_olo_dp_bub ,only: bub11
6963
7610
!
6964
 
  complex(kindr2) &
 
7611
  complex(kindr2) &   
6965
7612
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
6966
 
  real(kindr2) &
 
7613
  real(kindr2) &  
6967
7614
    ,intent(in)  :: pp
6968
 
  real(kindr2) &
 
7615
  real(kindr2) &  
6969
7616
    ,intent(in)  :: m1,m2
6970
 
  real(kindr2) &
6971
 
   ,intent(in)  :: rmu
 
7617
  real(kindr2) &  
 
7618
   ,intent(in)  :: rmu       
6972
7619
!
6973
 
  complex(kindr2) &
 
7620
  complex(kindr2) &   
6974
7621
    :: ss,r1,r2
6975
 
  real(kindr2) &
 
7622
  real(kindr2) &  
6976
7623
    :: app,am1,am2,hh,mulocal,mulocal2
6977
7624
  character(26+99) ,parameter :: warning=&
6978
7625
                     'WARNING from OneLOop b11: '//warnonshell
6981
7628
  r1 = m1
6982
7629
  r2 = m2
6983
7630
!
6984
 
  app=abs(pp)
 
7631
  app = abs(pp)
6985
7632
!
6986
7633
  am1 = abs(m1)
6987
7634
  am2 = abs(m2)
6988
7635
!
6989
 
  mulocal = rmu
 
7636
  mulocal = rmu     
6990
7637
!
6991
7638
  mulocal2 = mulocal*mulocal
6992
7639
!
7026
7673
  end subroutine
7027
7674
 
7028
7675
 
 
7676
  subroutine bncc( rslt ,rank ,pp,m1,m2 )
 
7677
!
 
7678
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
7679
!
 
7680
  complex(kindr2) &   
 
7681
    ,intent(out) :: rslt(0:,0:)   
 
7682
  complex(kindr2) &   
 
7683
    ,intent(in)  :: pp
 
7684
  complex(kindr2) &   
 
7685
    ,intent(in)  :: m1,m2
 
7686
  integer,intent(in) :: rank
 
7687
!
 
7688
  complex(kindr2) &   
 
7689
    :: ss,r1,r2
 
7690
  real(kindr2) &  
 
7691
    :: app,am1,am2,hh,mulocal,mulocal2
 
7692
  character(26+99) ,parameter :: warning=&
 
7693
                     'WARNING from OneLOop bn: '//warnonshell
 
7694
  if (initz) call init
 
7695
  ss = pp
 
7696
  r1 = m1
 
7697
  r2 = m2
 
7698
!
 
7699
  app = areal(ss)
 
7700
  if (aimag(ss).ne.RZRO) then
 
7701
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7702
      ,'ss has non-zero imaginary part, putting it to zero.'
 
7703
    ss = acmplx( app )
 
7704
  endif
 
7705
  app = abs(app)
 
7706
!
 
7707
  am1 = areal(r1)
 
7708
  hh  = aimag(r1)
 
7709
  if (hh.gt.RZRO) then
 
7710
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7711
      ,'r1 has positive imaginary part, switching its sign.'
 
7712
    r1 = acmplx( am1 ,-hh )
 
7713
  endif
 
7714
  am1 = abs(am1) + abs(hh)
 
7715
!
 
7716
  am2 = areal(r2)
 
7717
  hh  = aimag(r2)
 
7718
  if (hh.gt.RZRO) then
 
7719
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7720
      ,'r2 has positive imaginary part, switching its sign.'
 
7721
    r2 = acmplx( am2 ,-hh )
 
7722
  endif
 
7723
  am2 = abs(am2) + abs(hh)
 
7724
!
 
7725
  mulocal = muscale 
 
7726
!
 
7727
  mulocal2 = mulocal*mulocal
 
7728
!
 
7729
  if (nonzerothrs) then
 
7730
    hh = onshellthrs
 
7731
    if (app.lt.hh) app = 0
 
7732
    if (am1.lt.hh) am1 = 0
 
7733
    if (am2.lt.hh) am2 = 0
 
7734
  elseif (wunit.gt.0) then
 
7735
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
7736
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
7737
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
7738
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
7739
  endif
 
7740
!
 
7741
  if     (rank.eq.0) then
 
7742
    call bub0( rslt(:,0) &
 
7743
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7744
  elseif (rank.eq.1) then
 
7745
    call bub1( rslt(:,1),rslt(:,0) &
 
7746
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7747
  elseif (rank.eq.2) then
 
7748
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7749
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7750
  elseif (rank.eq.3) then
 
7751
    call bub111( rslt(:,5),rslt(:,4) &
 
7752
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7753
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7754
  elseif (rank.eq.4) then
 
7755
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
7756
                 ,rslt(:,5),rslt(:,4) &
 
7757
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7758
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7759
  else
 
7760
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7761
      ,'rank=',rank,' not implemented'
 
7762
  endif
 
7763
!
 
7764
  if (punit.gt.0) then
 
7765
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
7766
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
7767
    write(punit,*) 'pp:',trim(myprint(pp))
 
7768
    write(punit,*) 'm1:',trim(myprint(m1))
 
7769
    write(punit,*) 'm2:',trim(myprint(m2))
 
7770
    if (rank.ge.0) then
 
7771
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
7772
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
7773
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
7774
    if (rank.ge.1) then
 
7775
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
7776
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
7777
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
7778
    if (rank.ge.2) then
 
7779
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
7780
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
7781
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
7782
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
7783
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
7784
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
7785
    if (rank.ge.3) then
 
7786
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
7787
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
7788
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
7789
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
7790
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
7791
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
7792
    if (rank.ge.4) then
 
7793
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
7794
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
7795
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
7796
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
7797
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
7798
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
7799
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
7800
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
7801
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
7802
    endif;endif;endif;endif;endif
 
7803
  endif
 
7804
  end subroutine
 
7805
 
 
7806
  subroutine bnccr( rslt ,rank ,pp,m1,m2 ,rmu )
 
7807
!
 
7808
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
7809
!
 
7810
  complex(kindr2) &   
 
7811
    ,intent(out) :: rslt(0:,0:)   
 
7812
  complex(kindr2) &   
 
7813
    ,intent(in)  :: pp
 
7814
  complex(kindr2) &   
 
7815
    ,intent(in)  :: m1,m2
 
7816
  real(kindr2) &  
 
7817
   ,intent(in)  :: rmu       
 
7818
  integer,intent(in) :: rank
 
7819
!
 
7820
  complex(kindr2) &   
 
7821
    :: ss,r1,r2
 
7822
  real(kindr2) &  
 
7823
    :: app,am1,am2,hh,mulocal,mulocal2
 
7824
  character(26+99) ,parameter :: warning=&
 
7825
                     'WARNING from OneLOop bn: '//warnonshell
 
7826
  if (initz) call init
 
7827
  ss = pp
 
7828
  r1 = m1
 
7829
  r2 = m2
 
7830
!
 
7831
  app = areal(ss)
 
7832
  if (aimag(ss).ne.RZRO) then
 
7833
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7834
      ,'ss has non-zero imaginary part, putting it to zero.'
 
7835
    ss = acmplx( app )
 
7836
  endif
 
7837
  app = abs(app)
 
7838
!
 
7839
  am1 = areal(r1)
 
7840
  hh  = aimag(r1)
 
7841
  if (hh.gt.RZRO) then
 
7842
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7843
      ,'r1 has positive imaginary part, switching its sign.'
 
7844
    r1 = acmplx( am1 ,-hh )
 
7845
  endif
 
7846
  am1 = abs(am1) + abs(hh)
 
7847
!
 
7848
  am2 = areal(r2)
 
7849
  hh  = aimag(r2)
 
7850
  if (hh.gt.RZRO) then
 
7851
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7852
      ,'r2 has positive imaginary part, switching its sign.'
 
7853
    r2 = acmplx( am2 ,-hh )
 
7854
  endif
 
7855
  am2 = abs(am2) + abs(hh)
 
7856
!
 
7857
  mulocal = rmu     
 
7858
!
 
7859
  mulocal2 = mulocal*mulocal
 
7860
!
 
7861
  if (nonzerothrs) then
 
7862
    hh = onshellthrs
 
7863
    if (app.lt.hh) app = 0
 
7864
    if (am1.lt.hh) am1 = 0
 
7865
    if (am2.lt.hh) am2 = 0
 
7866
  elseif (wunit.gt.0) then
 
7867
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
7868
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
7869
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
7870
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
7871
  endif
 
7872
!
 
7873
  if     (rank.eq.0) then
 
7874
    call bub0( rslt(:,0) &
 
7875
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7876
  elseif (rank.eq.1) then
 
7877
    call bub1( rslt(:,1),rslt(:,0) &
 
7878
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7879
  elseif (rank.eq.2) then
 
7880
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7881
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7882
  elseif (rank.eq.3) then
 
7883
    call bub111( rslt(:,5),rslt(:,4) &
 
7884
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7885
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7886
  elseif (rank.eq.4) then
 
7887
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
7888
                 ,rslt(:,5),rslt(:,4) &
 
7889
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
7890
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
7891
  else
 
7892
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7893
      ,'rank=',rank,' not implemented'
 
7894
  endif
 
7895
!
 
7896
  if (punit.gt.0) then
 
7897
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
7898
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
7899
    write(punit,*) 'pp:',trim(myprint(pp))
 
7900
    write(punit,*) 'm1:',trim(myprint(m1))
 
7901
    write(punit,*) 'm2:',trim(myprint(m2))
 
7902
    if (rank.ge.0) then
 
7903
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
7904
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
7905
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
7906
    if (rank.ge.1) then
 
7907
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
7908
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
7909
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
7910
    if (rank.ge.2) then
 
7911
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
7912
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
7913
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
7914
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
7915
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
7916
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
7917
    if (rank.ge.3) then
 
7918
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
7919
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
7920
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
7921
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
7922
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
7923
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
7924
    if (rank.ge.4) then
 
7925
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
7926
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
7927
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
7928
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
7929
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
7930
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
7931
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
7932
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
7933
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
7934
    endif;endif;endif;endif;endif
 
7935
  endif
 
7936
  end subroutine
 
7937
 
 
7938
  subroutine bnrc( rslt ,rank ,pp,m1,m2 )
 
7939
!
 
7940
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
7941
!
 
7942
  complex(kindr2) &   
 
7943
    ,intent(out) :: rslt(0:,0:)   
 
7944
  real(kindr2) &  
 
7945
    ,intent(in)  :: pp
 
7946
  complex(kindr2) &   
 
7947
    ,intent(in)  :: m1,m2
 
7948
  integer,intent(in) :: rank
 
7949
!
 
7950
  complex(kindr2) &   
 
7951
    :: ss,r1,r2
 
7952
  real(kindr2) &  
 
7953
    :: app,am1,am2,hh,mulocal,mulocal2
 
7954
  character(26+99) ,parameter :: warning=&
 
7955
                     'WARNING from OneLOop bn: '//warnonshell
 
7956
  if (initz) call init
 
7957
  ss = pp
 
7958
  r1 = m1
 
7959
  r2 = m2
 
7960
!
 
7961
  app = abs(pp)
 
7962
!
 
7963
  am1 = areal(r1)
 
7964
  hh  = aimag(r1)
 
7965
  if (hh.gt.RZRO) then
 
7966
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7967
      ,'r1 has positive imaginary part, switching its sign.'
 
7968
    r1 = acmplx( am1 ,-hh )
 
7969
  endif
 
7970
  am1 = abs(am1) + abs(hh)
 
7971
!
 
7972
  am2 = areal(r2)
 
7973
  hh  = aimag(r2)
 
7974
  if (hh.gt.RZRO) then
 
7975
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
7976
      ,'r2 has positive imaginary part, switching its sign.'
 
7977
    r2 = acmplx( am2 ,-hh )
 
7978
  endif
 
7979
  am2 = abs(am2) + abs(hh)
 
7980
!
 
7981
  mulocal = muscale 
 
7982
!
 
7983
  mulocal2 = mulocal*mulocal
 
7984
!
 
7985
  if (nonzerothrs) then
 
7986
    hh = onshellthrs
 
7987
    if (app.lt.hh) app = 0
 
7988
    if (am1.lt.hh) am1 = 0
 
7989
    if (am2.lt.hh) am2 = 0
 
7990
  elseif (wunit.gt.0) then
 
7991
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
7992
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
7993
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
7994
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
7995
  endif
 
7996
!
 
7997
  if     (rank.eq.0) then
 
7998
    call bub0( rslt(:,0) &
 
7999
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8000
  elseif (rank.eq.1) then
 
8001
    call bub1( rslt(:,1),rslt(:,0) &
 
8002
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8003
  elseif (rank.eq.2) then
 
8004
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8005
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8006
  elseif (rank.eq.3) then
 
8007
    call bub111( rslt(:,5),rslt(:,4) &
 
8008
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8009
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8010
  elseif (rank.eq.4) then
 
8011
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
8012
                 ,rslt(:,5),rslt(:,4) &
 
8013
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8014
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8015
  else
 
8016
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8017
      ,'rank=',rank,' not implemented'
 
8018
  endif
 
8019
!
 
8020
  if (punit.gt.0) then
 
8021
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
8022
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
8023
    write(punit,*) 'pp:',trim(myprint(pp))
 
8024
    write(punit,*) 'm1:',trim(myprint(m1))
 
8025
    write(punit,*) 'm2:',trim(myprint(m2))
 
8026
    if (rank.ge.0) then
 
8027
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
8028
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
8029
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
8030
    if (rank.ge.1) then
 
8031
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
8032
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
8033
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
8034
    if (rank.ge.2) then
 
8035
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
8036
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
8037
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
8038
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
8039
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
8040
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
8041
    if (rank.ge.3) then
 
8042
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
8043
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
8044
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
8045
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
8046
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
8047
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
8048
    if (rank.ge.4) then
 
8049
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
8050
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
8051
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
8052
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
8053
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
8054
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
8055
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
8056
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
8057
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
8058
    endif;endif;endif;endif;endif
 
8059
  endif
 
8060
  end subroutine
 
8061
 
 
8062
  subroutine bnrcr( rslt ,rank ,pp,m1,m2 ,rmu )
 
8063
!
 
8064
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
8065
!
 
8066
  complex(kindr2) &   
 
8067
    ,intent(out) :: rslt(0:,0:)   
 
8068
  real(kindr2) &  
 
8069
    ,intent(in)  :: pp
 
8070
  complex(kindr2) &   
 
8071
    ,intent(in)  :: m1,m2
 
8072
  real(kindr2) &  
 
8073
   ,intent(in)  :: rmu       
 
8074
  integer,intent(in) :: rank
 
8075
!
 
8076
  complex(kindr2) &   
 
8077
    :: ss,r1,r2
 
8078
  real(kindr2) &  
 
8079
    :: app,am1,am2,hh,mulocal,mulocal2
 
8080
  character(26+99) ,parameter :: warning=&
 
8081
                     'WARNING from OneLOop bn: '//warnonshell
 
8082
  if (initz) call init
 
8083
  ss = pp
 
8084
  r1 = m1
 
8085
  r2 = m2
 
8086
!
 
8087
  app = abs(pp)
 
8088
!
 
8089
  am1 = areal(r1)
 
8090
  hh  = aimag(r1)
 
8091
  if (hh.gt.RZRO) then
 
8092
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8093
      ,'r1 has positive imaginary part, switching its sign.'
 
8094
    r1 = acmplx( am1 ,-hh )
 
8095
  endif
 
8096
  am1 = abs(am1) + abs(hh)
 
8097
!
 
8098
  am2 = areal(r2)
 
8099
  hh  = aimag(r2)
 
8100
  if (hh.gt.RZRO) then
 
8101
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8102
      ,'r2 has positive imaginary part, switching its sign.'
 
8103
    r2 = acmplx( am2 ,-hh )
 
8104
  endif
 
8105
  am2 = abs(am2) + abs(hh)
 
8106
!
 
8107
  mulocal = rmu     
 
8108
!
 
8109
  mulocal2 = mulocal*mulocal
 
8110
!
 
8111
  if (nonzerothrs) then
 
8112
    hh = onshellthrs
 
8113
    if (app.lt.hh) app = 0
 
8114
    if (am1.lt.hh) am1 = 0
 
8115
    if (am2.lt.hh) am2 = 0
 
8116
  elseif (wunit.gt.0) then
 
8117
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
8118
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
8119
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
8120
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
8121
  endif
 
8122
!
 
8123
  if     (rank.eq.0) then
 
8124
    call bub0( rslt(:,0) &
 
8125
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8126
  elseif (rank.eq.1) then
 
8127
    call bub1( rslt(:,1),rslt(:,0) &
 
8128
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8129
  elseif (rank.eq.2) then
 
8130
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8131
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8132
  elseif (rank.eq.3) then
 
8133
    call bub111( rslt(:,5),rslt(:,4) &
 
8134
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8135
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8136
  elseif (rank.eq.4) then
 
8137
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
8138
                 ,rslt(:,5),rslt(:,4) &
 
8139
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8140
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8141
  else
 
8142
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8143
      ,'rank=',rank,' not implemented'
 
8144
  endif
 
8145
!
 
8146
  if (punit.gt.0) then
 
8147
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
8148
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
8149
    write(punit,*) 'pp:',trim(myprint(pp))
 
8150
    write(punit,*) 'm1:',trim(myprint(m1))
 
8151
    write(punit,*) 'm2:',trim(myprint(m2))
 
8152
    if (rank.ge.0) then
 
8153
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
8154
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
8155
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
8156
    if (rank.ge.1) then
 
8157
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
8158
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
8159
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
8160
    if (rank.ge.2) then
 
8161
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
8162
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
8163
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
8164
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
8165
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
8166
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
8167
    if (rank.ge.3) then
 
8168
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
8169
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
8170
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
8171
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
8172
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
8173
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
8174
    if (rank.ge.4) then
 
8175
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
8176
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
8177
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
8178
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
8179
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
8180
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
8181
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
8182
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
8183
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
8184
    endif;endif;endif;endif;endif
 
8185
  endif
 
8186
  end subroutine
 
8187
 
 
8188
  subroutine bnrr( rslt ,rank ,pp,m1,m2 )
 
8189
!
 
8190
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
8191
!
 
8192
  complex(kindr2) &   
 
8193
    ,intent(out) :: rslt(0:,0:)   
 
8194
  real(kindr2) &  
 
8195
    ,intent(in)  :: pp
 
8196
  real(kindr2) &  
 
8197
    ,intent(in)  :: m1,m2
 
8198
  integer,intent(in) :: rank
 
8199
!
 
8200
  complex(kindr2) &   
 
8201
    :: ss,r1,r2
 
8202
  real(kindr2) &  
 
8203
    :: app,am1,am2,hh,mulocal,mulocal2
 
8204
  character(26+99) ,parameter :: warning=&
 
8205
                     'WARNING from OneLOop bn: '//warnonshell
 
8206
  if (initz) call init
 
8207
  ss = pp
 
8208
  r1 = m1
 
8209
  r2 = m2
 
8210
!
 
8211
  app = abs(pp)
 
8212
!
 
8213
  am1 = abs(m1)
 
8214
  am2 = abs(m2)
 
8215
!
 
8216
  mulocal = muscale 
 
8217
!
 
8218
  mulocal2 = mulocal*mulocal
 
8219
!
 
8220
  if (nonzerothrs) then
 
8221
    hh = onshellthrs
 
8222
    if (app.lt.hh) app = 0
 
8223
    if (am1.lt.hh) am1 = 0
 
8224
    if (am2.lt.hh) am2 = 0
 
8225
  elseif (wunit.gt.0) then
 
8226
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
8227
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
8228
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
8229
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
8230
  endif
 
8231
!
 
8232
  if     (rank.eq.0) then
 
8233
    call bub0( rslt(:,0) &
 
8234
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8235
  elseif (rank.eq.1) then
 
8236
    call bub1( rslt(:,1),rslt(:,0) &
 
8237
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8238
  elseif (rank.eq.2) then
 
8239
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8240
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8241
  elseif (rank.eq.3) then
 
8242
    call bub111( rslt(:,5),rslt(:,4) &
 
8243
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8244
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8245
  elseif (rank.eq.4) then
 
8246
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
8247
                 ,rslt(:,5),rslt(:,4) &
 
8248
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8249
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8250
  else
 
8251
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8252
      ,'rank=',rank,' not implemented'
 
8253
  endif
 
8254
!
 
8255
  if (punit.gt.0) then
 
8256
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
8257
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
8258
    write(punit,*) 'pp:',trim(myprint(pp))
 
8259
    write(punit,*) 'm1:',trim(myprint(m1))
 
8260
    write(punit,*) 'm2:',trim(myprint(m2))
 
8261
    if (rank.ge.0) then
 
8262
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
8263
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
8264
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
8265
    if (rank.ge.1) then
 
8266
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
8267
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
8268
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
8269
    if (rank.ge.2) then
 
8270
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
8271
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
8272
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
8273
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
8274
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
8275
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
8276
    if (rank.ge.3) then
 
8277
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
8278
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
8279
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
8280
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
8281
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
8282
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
8283
    if (rank.ge.4) then
 
8284
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
8285
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
8286
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
8287
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
8288
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
8289
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
8290
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
8291
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
8292
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
8293
    endif;endif;endif;endif;endif
 
8294
  endif
 
8295
  end subroutine
 
8296
 
 
8297
  subroutine bnrrr( rslt ,rank ,pp,m1,m2 ,rmu )
 
8298
!
 
8299
  use avh_olo_dp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
8300
!
 
8301
  complex(kindr2) &   
 
8302
    ,intent(out) :: rslt(0:,0:)   
 
8303
  real(kindr2) &  
 
8304
    ,intent(in)  :: pp
 
8305
  real(kindr2) &  
 
8306
    ,intent(in)  :: m1,m2
 
8307
  real(kindr2) &  
 
8308
   ,intent(in)  :: rmu       
 
8309
  integer,intent(in) :: rank
 
8310
!
 
8311
  complex(kindr2) &   
 
8312
    :: ss,r1,r2
 
8313
  real(kindr2) &  
 
8314
    :: app,am1,am2,hh,mulocal,mulocal2
 
8315
  character(26+99) ,parameter :: warning=&
 
8316
                     'WARNING from OneLOop bn: '//warnonshell
 
8317
  if (initz) call init
 
8318
  ss = pp
 
8319
  r1 = m1
 
8320
  r2 = m2
 
8321
!
 
8322
  app = abs(pp)
 
8323
!
 
8324
  am1 = abs(m1)
 
8325
  am2 = abs(m2)
 
8326
!
 
8327
  mulocal = rmu     
 
8328
!
 
8329
  mulocal2 = mulocal*mulocal
 
8330
!
 
8331
  if (nonzerothrs) then
 
8332
    hh = onshellthrs
 
8333
    if (app.lt.hh) app = 0
 
8334
    if (am1.lt.hh) am1 = 0
 
8335
    if (am2.lt.hh) am2 = 0
 
8336
  elseif (wunit.gt.0) then
 
8337
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
8338
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
8339
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
8340
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
8341
  endif
 
8342
!
 
8343
  if     (rank.eq.0) then
 
8344
    call bub0( rslt(:,0) &
 
8345
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8346
  elseif (rank.eq.1) then
 
8347
    call bub1( rslt(:,1),rslt(:,0) &
 
8348
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8349
  elseif (rank.eq.2) then
 
8350
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8351
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8352
  elseif (rank.eq.3) then
 
8353
    call bub111( rslt(:,5),rslt(:,4) &
 
8354
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8355
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8356
  elseif (rank.eq.4) then
 
8357
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
8358
                 ,rslt(:,5),rslt(:,4) &
 
8359
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
8360
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
8361
  else
 
8362
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
8363
      ,'rank=',rank,' not implemented'
 
8364
  endif
 
8365
!
 
8366
  if (punit.gt.0) then
 
8367
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
8368
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
8369
    write(punit,*) 'pp:',trim(myprint(pp))
 
8370
    write(punit,*) 'm1:',trim(myprint(m1))
 
8371
    write(punit,*) 'm2:',trim(myprint(m2))
 
8372
    if (rank.ge.0) then
 
8373
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
8374
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
8375
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
8376
    if (rank.ge.1) then
 
8377
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
8378
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
8379
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
8380
    if (rank.ge.2) then
 
8381
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
8382
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
8383
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
8384
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
8385
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
8386
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
8387
    if (rank.ge.3) then
 
8388
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
8389
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
8390
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
8391
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
8392
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
8393
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
8394
    if (rank.ge.4) then
 
8395
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
8396
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
8397
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
8398
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
8399
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
8400
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
8401
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
8402
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
8403
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
8404
    endif;endif;endif;endif;endif
 
8405
  endif
 
8406
  end subroutine
 
8407
 
 
8408
 
7029
8409
!*******************************************************************
7030
8410
! calculates
7031
8411
!               C   /               d^(Dim)q
7049
8429
  use avh_olo_dp_tri
7050
8430
  use avh_olo_dp_auxfun ,only: kallen
7051
8431
!
7052
 
  complex(kindr2) &
 
8432
  complex(kindr2) &   
7053
8433
    ,intent(out) :: rslt(0:2)
7054
 
  complex(kindr2) &
 
8434
  complex(kindr2) &   
7055
8435
    ,intent(in)  :: p1,p2,p3
7056
 
  complex(kindr2) &
 
8436
  complex(kindr2) &   
7057
8437
    ,intent(in)  :: m1,m2,m3
7058
8438
!
7059
 
  complex(kindr2) &
 
8439
  complex(kindr2) &   
7060
8440
    :: pp(3)
7061
 
  complex(kindr2) &
 
8441
  complex(kindr2) &   
7062
8442
    :: mm(3)
7063
 
  complex(kindr2) &
 
8443
  complex(kindr2) &   
7064
8444
    :: ss(3),rr(3),lambda
7065
 
  real(kindr2) &
 
8445
  real(kindr2) &  
7066
8446
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7067
 
  real(kindr2) &
 
8447
  real(kindr2) &  
7068
8448
    :: mulocal,mulocal2
7069
8449
  integer :: icase,ii
7070
8450
  character(25+99) ,parameter :: warning=&
7101
8481
    if (am(ii).gt.smax) smax = am(ii)
7102
8482
  enddo
7103
8483
!
7104
 
  mulocal = muscale
 
8484
  mulocal = muscale 
7105
8485
!
7106
8486
  mulocal2 = mulocal*mulocal
7107
8487
!
7211
8591
  use avh_olo_dp_tri
7212
8592
  use avh_olo_dp_auxfun ,only: kallen
7213
8593
!
7214
 
  complex(kindr2) &
 
8594
  complex(kindr2) &   
7215
8595
    ,intent(out) :: rslt(0:2)
7216
 
  complex(kindr2) &
 
8596
  complex(kindr2) &   
7217
8597
    ,intent(in)  :: p1,p2,p3
7218
 
  complex(kindr2) &
 
8598
  complex(kindr2) &   
7219
8599
    ,intent(in)  :: m1,m2,m3
7220
 
  real(kindr2) &
7221
 
    ,intent(in)  :: rmu
 
8600
  real(kindr2) &  
 
8601
    ,intent(in)  :: rmu      
7222
8602
!
7223
 
  complex(kindr2) &
 
8603
  complex(kindr2) &   
7224
8604
    :: pp(3)
7225
 
  complex(kindr2) &
 
8605
  complex(kindr2) &   
7226
8606
    :: mm(3)
7227
 
  complex(kindr2) &
 
8607
  complex(kindr2) &   
7228
8608
    :: ss(3),rr(3),lambda
7229
 
  real(kindr2) &
 
8609
  real(kindr2) &  
7230
8610
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7231
 
  real(kindr2) &
 
8611
  real(kindr2) &  
7232
8612
    :: mulocal,mulocal2
7233
8613
  integer :: icase,ii
7234
8614
  character(25+99) ,parameter :: warning=&
7265
8645
    if (am(ii).gt.smax) smax = am(ii)
7266
8646
  enddo
7267
8647
!
7268
 
  mulocal = rmu
 
8648
  mulocal = rmu     
7269
8649
!
7270
8650
  mulocal2 = mulocal*mulocal
7271
8651
!
7375
8755
  use avh_olo_dp_tri
7376
8756
  use avh_olo_dp_auxfun ,only: kallen
7377
8757
!
7378
 
  complex(kindr2) &
 
8758
  complex(kindr2) &   
7379
8759
    ,intent(out) :: rslt(0:2)
7380
 
  real(kindr2) &
 
8760
  real(kindr2) &  
7381
8761
    ,intent(in)  :: p1,p2,p3
7382
 
  complex(kindr2) &
 
8762
  complex(kindr2) &   
7383
8763
    ,intent(in)  :: m1,m2,m3
7384
8764
!
7385
 
  real(kindr2) &
 
8765
  real(kindr2) &  
7386
8766
    :: pp(3)
7387
 
  complex(kindr2) &
 
8767
  complex(kindr2) &   
7388
8768
    :: mm(3)
7389
 
  complex(kindr2) &
 
8769
  complex(kindr2) &   
7390
8770
    :: ss(3),rr(3),lambda
7391
 
  real(kindr2) &
 
8771
  real(kindr2) &  
7392
8772
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7393
 
  real(kindr2) &
 
8773
  real(kindr2) &  
7394
8774
    :: mulocal,mulocal2
7395
8775
  integer :: icase,ii
7396
8776
  character(25+99) ,parameter :: warning=&
7421
8801
    if (am(ii).gt.smax) smax = am(ii)
7422
8802
  enddo
7423
8803
!
7424
 
  mulocal = muscale
 
8804
  mulocal = muscale 
7425
8805
!
7426
8806
  mulocal2 = mulocal*mulocal
7427
8807
!
7531
8911
  use avh_olo_dp_tri
7532
8912
  use avh_olo_dp_auxfun ,only: kallen
7533
8913
!
7534
 
  complex(kindr2) &
 
8914
  complex(kindr2) &   
7535
8915
    ,intent(out) :: rslt(0:2)
7536
 
  real(kindr2) &
 
8916
  real(kindr2) &  
7537
8917
    ,intent(in)  :: p1,p2,p3
7538
 
  complex(kindr2) &
 
8918
  complex(kindr2) &   
7539
8919
    ,intent(in)  :: m1,m2,m3
7540
 
  real(kindr2) &
7541
 
    ,intent(in)  :: rmu
 
8920
  real(kindr2) &  
 
8921
    ,intent(in)  :: rmu      
7542
8922
!
7543
 
  real(kindr2) &
 
8923
  real(kindr2) &  
7544
8924
    :: pp(3)
7545
 
  complex(kindr2) &
 
8925
  complex(kindr2) &   
7546
8926
    :: mm(3)
7547
 
  complex(kindr2) &
 
8927
  complex(kindr2) &   
7548
8928
    :: ss(3),rr(3),lambda
7549
 
  real(kindr2) &
 
8929
  real(kindr2) &  
7550
8930
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7551
 
  real(kindr2) &
 
8931
  real(kindr2) &  
7552
8932
    :: mulocal,mulocal2
7553
8933
  integer :: icase,ii
7554
8934
  character(25+99) ,parameter :: warning=&
7579
8959
    if (am(ii).gt.smax) smax = am(ii)
7580
8960
  enddo
7581
8961
!
7582
 
  mulocal = rmu
 
8962
  mulocal = rmu     
7583
8963
!
7584
8964
  mulocal2 = mulocal*mulocal
7585
8965
!
7689
9069
  use avh_olo_dp_tri
7690
9070
  use avh_olo_dp_auxfun ,only: kallen
7691
9071
!
7692
 
  complex(kindr2) &
 
9072
  complex(kindr2) &   
7693
9073
    ,intent(out) :: rslt(0:2)
7694
 
  real(kindr2) &
 
9074
  real(kindr2) &  
7695
9075
    ,intent(in)  :: p1,p2,p3
7696
 
  real(kindr2) &
 
9076
  real(kindr2) &  
7697
9077
    ,intent(in)  :: m1,m2,m3
7698
9078
!
7699
 
  real(kindr2) &
 
9079
  real(kindr2) &  
7700
9080
    :: pp(3)
7701
 
  real(kindr2) &
 
9081
  real(kindr2) &  
7702
9082
    :: mm(3)
7703
 
  complex(kindr2) &
 
9083
  complex(kindr2) &   
7704
9084
    :: ss(3),rr(3),lambda
7705
 
  real(kindr2) &
 
9085
  real(kindr2) &  
7706
9086
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7707
 
  real(kindr2) &
 
9087
  real(kindr2) &  
7708
9088
    :: mulocal,mulocal2
7709
9089
  integer :: icase,ii
7710
9090
  character(25+99) ,parameter :: warning=&
7728
9108
    if (am(ii).gt.smax) smax = am(ii)
7729
9109
  enddo
7730
9110
!
7731
 
  mulocal = muscale
 
9111
  mulocal = muscale 
7732
9112
!
7733
9113
  mulocal2 = mulocal*mulocal
7734
9114
!
7838
9218
  use avh_olo_dp_tri
7839
9219
  use avh_olo_dp_auxfun ,only: kallen
7840
9220
!
7841
 
  complex(kindr2) &
 
9221
  complex(kindr2) &   
7842
9222
    ,intent(out) :: rslt(0:2)
7843
 
  real(kindr2) &
 
9223
  real(kindr2) &  
7844
9224
    ,intent(in)  :: p1,p2,p3
7845
 
  real(kindr2) &
 
9225
  real(kindr2) &  
7846
9226
    ,intent(in)  :: m1,m2,m3
7847
 
  real(kindr2) &
7848
 
    ,intent(in)  :: rmu
 
9227
  real(kindr2) &  
 
9228
    ,intent(in)  :: rmu      
7849
9229
!
7850
 
  real(kindr2) &
 
9230
  real(kindr2) &  
7851
9231
    :: pp(3)
7852
 
  real(kindr2) &
 
9232
  real(kindr2) &  
7853
9233
    :: mm(3)
7854
 
  complex(kindr2) &
 
9234
  complex(kindr2) &   
7855
9235
    :: ss(3),rr(3),lambda
7856
 
  real(kindr2) &
 
9236
  real(kindr2) &  
7857
9237
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
7858
 
  real(kindr2) &
 
9238
  real(kindr2) &  
7859
9239
    :: mulocal,mulocal2
7860
9240
  integer :: icase,ii
7861
9241
  character(25+99) ,parameter :: warning=&
7879
9259
    if (am(ii).gt.smax) smax = am(ii)
7880
9260
  enddo
7881
9261
!
7882
 
  mulocal = rmu
 
9262
  mulocal = rmu     
7883
9263
!
7884
9264
  mulocal2 = mulocal*mulocal
7885
9265
!
8012
9392
  use avh_olo_dp_box
8013
9393
  use avh_olo_dp_boxc
8014
9394
!
8015
 
  complex(kindr2) &
8016
 
    ,intent(out) :: rslt(0:2)
8017
 
  complex(kindr2) &
8018
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
8019
 
  complex(kindr2) &
8020
 
    ,intent(in)  :: m1,m2,m3,m4
8021
 
!
8022
 
  complex(kindr2) &
8023
 
    :: pp(6)
8024
 
  complex(kindr2) &
8025
 
    :: mm(4)
8026
 
  complex(kindr2) &
8027
 
    :: ss(6),rr(4)
8028
 
  real(kindr2) &
8029
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
8030
 
  real(kindr2) &
8031
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
8032
 
  integer :: icase,ii,jj
8033
 
  logical :: useboxc
8034
 
  integer ,parameter :: lp(6,3)=&
8035
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
8036
 
  integer ,parameter :: lm(4,3)=&
8037
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
8038
 
  character(25+99) ,parameter :: warning=&
8039
 
                 'WARNING from OneLOop d0: '//warnonshell
8040
 
  if (initz) call init
8041
 
  pp(1) = p1
8042
 
  pp(2) = p2
8043
 
  pp(3) = p3
8044
 
  pp(4) = p4
8045
 
  pp(5) = p12
8046
 
  pp(6) = p23
8047
 
  mm(1) = m1
8048
 
  mm(2) = m2
8049
 
  mm(3) = m3
8050
 
  mm(4) = m4
8051
 
  smax = 0
8052
 
!
8053
 
  do ii=1,6
8054
 
    ap(ii) = areal(pp(ii))
8055
 
    if (aimag(pp(ii)).ne.RZRO) then
8056
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8057
 
        ,'momentum with non-zero imaginary part, putting it to zero.'
8058
 
      pp(ii) = acmplx( ap(ii) ,0 )
8059
 
    endif
8060
 
    ap(ii) = abs(ap(ii))
8061
 
    if (ap(ii).gt.smax) smax = ap(ii)
8062
 
  enddo
8063
 
!
8064
 
  do ii=1,4
8065
 
    am(ii) = areal(mm(ii))
8066
 
    hh = aimag(mm(ii))
8067
 
    if (hh.gt.RZRO) then
8068
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8069
 
        ,'mass-squared has positive imaginary part, switching its sign.'
8070
 
      mm(ii) = acmplx( am(ii) ,-hh )
8071
 
    endif
8072
 
    am(ii) = abs(am(ii)) + abs(hh)
8073
 
    if (am(ii).gt.smax) smax = am(ii)
8074
 
  enddo
8075
 
!
8076
 
  small = 0
8077
 
  do ii=1,6
8078
 
    hh = abs(ap(ii))
8079
 
    if (hh.gt.small) small=hh
8080
 
  enddo
8081
 
  small = small*neglig(prcpar)
8082
 
!
8083
 
  mulocal = muscale
8084
 
!
8085
 
  mulocal2 = mulocal*mulocal
8086
 
!
8087
 
  if (smax.eq.RZRO) then
8088
 
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8089
 
      ,'all input equal zero, returning 0'
8090
 
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
8091
 
    return
8092
 
  endif
8093
 
!
8094
 
  if (mulocal2.gt.smax) smax = mulocal2
8095
 
!
8096
 
  if (nonzerothrs) then
8097
 
    hh = onshellthrs
8098
 
    do ii=1,4
8099
 
      if (ap(ii).lt.hh) ap(ii) = 0
8100
 
      if (am(ii).lt.hh) am(ii) = 0
8101
 
    enddo
8102
 
  else
8103
 
    hh = onshellthrs*smax
8104
 
    if (wunit.gt.0) then
8105
 
    do ii=1,4
8106
 
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
8107
 
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
8108
 
    enddo
8109
 
    endif
8110
 
  endif
8111
 
!
8112
 
  jj = 1
8113
 
  min56 = min(ap(5),ap(6))
8114
 
  if (min56.lt.hh) then
8115
 
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8116
 
      ,'input does not seem to represent hard kinematics, '&
8117
 
      ,'trying to permutate'
8118
 
    min13=min(ap(1),ap(3))
8119
 
    min24=min(ap(2),ap(4))
8120
 
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
8121
 
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
8122
 
    else
8123
 
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8124
 
        ,'no permutation helps, errors might follow'
8125
 
    endif
8126
 
  endif
8127
 
!
8128
 
  icase = 0
8129
 
  do ii=1,4
8130
 
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
8131
 
  enddo
8132
 
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
8133
 
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
8134
 
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
8135
 
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
8136
 
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
8137
 
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
8138
 
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
8139
 
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
8140
 
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
8141
 
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
8142
 
  icase = casetable(icase)
8143
 
!
8144
 
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
8145
 
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
8146
 
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
8147
 
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
8148
 
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
8149
 
  if (nonzerothrs) then
8150
 
    if (s1r2.lt.hh) s1r2 = 0
8151
 
    if (s2r2.lt.hh) s2r2 = 0
8152
 
    if (s2r3.lt.hh) s2r3 = 0
8153
 
    if (s3r4.lt.hh) s3r4 = 0
8154
 
    if (s4r4.lt.hh) s4r4 = 0
8155
 
  elseif (wunit.gt.0) then
8156
 
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
8157
 
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
8158
 
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
8159
 
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
8160
 
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
8161
 
  endif
8162
 
!
8163
 
  if     (icase.eq.4) then
8164
 
!4 non-zero internal masses
8165
 
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8166
 
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8167
 
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8168
 
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8169
 
               .or.(     areal(ss(1)).ge.-small  &
8170
 
                    .and.areal(ss(2)).ge.-small  &
8171
 
                    .and.areal(ss(3)).ge.-small  &
8172
 
                    .and.areal(ss(4)).ge.-small) )
8173
 
    if (useboxc) then
8174
 
      call boxc( rslt ,ss,rr ,as ,smax )
8175
 
    else
8176
 
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
8177
 
    endif
8178
 
  elseif (icase.eq.3) then
8179
 
!3 non-zero internal masses
8180
 
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8181
 
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8182
 
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8183
 
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8184
 
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8185
 
                 .or.(     areal(ss(1)).ge.-small  &
8186
 
                      .and.areal(ss(2)).ge.-small  &
8187
 
                      .and.areal(ss(3)).ge.-small  &
8188
 
                      .and.areal(ss(4)).ge.-small) )
8189
 
      if (useboxc) then
8190
 
        call boxc( rslt ,ss,rr ,as ,smax )
8191
 
      else
8192
 
        call boxf3( rslt, ss,rr )
8193
 
      endif
8194
 
    else
8195
 
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
8196
 
    endif
8197
 
  elseif (icase.eq.5) then
8198
 
!2 non-zero internal masses, opposite case
8199
 
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8200
 
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8201
 
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
8202
 
      else
8203
 
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8204
 
      endif
8205
 
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8206
 
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8207
 
    else
8208
 
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8209
 
    endif
8210
 
  elseif (icase.eq.2) then
8211
 
!2 non-zero internal masses, adjacent case
8212
 
    if     (as(1).ne.RZRO) then
8213
 
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
8214
 
    elseif (s2r3.ne.RZRO) then
8215
 
      if     (s4r4.ne.RZRO) then
8216
 
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8217
 
      else
8218
 
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
8219
 
      endif
8220
 
    elseif (s4r4.ne.RZRO) then
8221
 
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8222
 
    else
8223
 
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8224
 
    endif
8225
 
  elseif (icase.eq.1) then
8226
 
!1 non-zero internal mass
8227
 
    if     (as(1).ne.RZRO) then
8228
 
      if      (as(2).ne.RZRO) then
8229
 
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
8230
 
      else
8231
 
        if     (s3r4.ne.RZRO) then
8232
 
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8233
 
        else
8234
 
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8235
 
        endif
8236
 
      endif
8237
 
    elseif (as(2).ne.RZRO) then
8238
 
      if      (s4r4.ne.RZRO) then
8239
 
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8240
 
      else
8241
 
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8242
 
      endif
8243
 
    else
8244
 
      if     (s3r4.ne.RZRO) then
8245
 
        if     (s4r4.ne.RZRO) then
8246
 
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8247
 
        else
8248
 
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8249
 
        endif
8250
 
      elseif (s4r4.ne.RZRO) then
8251
 
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8252
 
      else
8253
 
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
8254
 
      endif
8255
 
    endif
8256
 
  else
8257
 
!0 non-zero internal mass
8258
 
    call box00( rslt ,ss ,as ,mulocal )
8259
 
  endif
8260
 
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
8261
 
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
8262
 
!
8263
 
  if (punit.gt.0) then
8264
 
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
8265
 
    write(punit,*) 'muscale:',trim(myprint(mulocal))
8266
 
    write(punit,*) ' p1:',trim(myprint(p1))
8267
 
    write(punit,*) ' p2:',trim(myprint(p2))
8268
 
    write(punit,*) ' p3:',trim(myprint(p3))
8269
 
    write(punit,*) ' p4:',trim(myprint(p4))
8270
 
    write(punit,*) 'p12:',trim(myprint(p12))
8271
 
    write(punit,*) 'p23:',trim(myprint(p23))
8272
 
    write(punit,*) ' m1:',trim(myprint(m1))
8273
 
    write(punit,*) ' m2:',trim(myprint(m2))
8274
 
    write(punit,*) ' m3:',trim(myprint(m3))
8275
 
    write(punit,*) ' m4:',trim(myprint(m4))
8276
 
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
8277
 
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
8278
 
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
8279
 
  endif
8280
 
  end subroutine
8281
 
 
8282
 
  subroutine d0ccr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
8283
 
  use avh_olo_dp_box
8284
 
  use avh_olo_dp_boxc
8285
 
!
8286
 
  complex(kindr2) &
8287
 
    ,intent(out) :: rslt(0:2)
8288
 
  complex(kindr2) &
8289
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
8290
 
  complex(kindr2) &
8291
 
    ,intent(in)  :: m1,m2,m3,m4
8292
 
  real(kindr2) &
8293
 
    ,intent(in)  :: rmu
8294
 
!
8295
 
  complex(kindr2) &
8296
 
    :: pp(6)
8297
 
  complex(kindr2) &
8298
 
    :: mm(4)
8299
 
  complex(kindr2) &
8300
 
    :: ss(6),rr(4)
8301
 
  real(kindr2) &
8302
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
8303
 
  real(kindr2) &
8304
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
8305
 
  integer :: icase,ii,jj
8306
 
  logical :: useboxc
8307
 
  integer ,parameter :: lp(6,3)=&
8308
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
8309
 
  integer ,parameter :: lm(4,3)=&
8310
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
8311
 
  character(25+99) ,parameter :: warning=&
8312
 
                 'WARNING from OneLOop d0: '//warnonshell
8313
 
  if (initz) call init
8314
 
  pp(1) = p1
8315
 
  pp(2) = p2
8316
 
  pp(3) = p3
8317
 
  pp(4) = p4
8318
 
  pp(5) = p12
8319
 
  pp(6) = p23
8320
 
  mm(1) = m1
8321
 
  mm(2) = m2
8322
 
  mm(3) = m3
8323
 
  mm(4) = m4
8324
 
  smax = 0
8325
 
!
8326
 
  do ii=1,6
8327
 
    ap(ii) = areal(pp(ii))
8328
 
    if (aimag(pp(ii)).ne.RZRO) then
8329
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8330
 
        ,'momentum with non-zero imaginary part, putting it to zero.'
8331
 
      pp(ii) = acmplx( ap(ii) ,0 )
8332
 
    endif
8333
 
    ap(ii) = abs(ap(ii))
8334
 
    if (ap(ii).gt.smax) smax = ap(ii)
8335
 
  enddo
8336
 
!
8337
 
  do ii=1,4
8338
 
    am(ii) = areal(mm(ii))
8339
 
    hh = aimag(mm(ii))
8340
 
    if (hh.gt.RZRO) then
8341
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8342
 
        ,'mass-squared has positive imaginary part, switching its sign.'
8343
 
      mm(ii) = acmplx( am(ii) ,-hh )
8344
 
    endif
8345
 
    am(ii) = abs(am(ii)) + abs(hh)
8346
 
    if (am(ii).gt.smax) smax = am(ii)
8347
 
  enddo
8348
 
!
8349
 
  small = 0
8350
 
  do ii=1,6
8351
 
    hh = abs(ap(ii))
8352
 
    if (hh.gt.small) small=hh
8353
 
  enddo
8354
 
  small = small*neglig(prcpar)
8355
 
!
8356
 
  mulocal = rmu
8357
 
!
8358
 
  mulocal2 = mulocal*mulocal
8359
 
!
8360
 
  if (smax.eq.RZRO) then
8361
 
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8362
 
      ,'all input equal zero, returning 0'
8363
 
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
8364
 
    return
8365
 
  endif
8366
 
!
8367
 
  if (mulocal2.gt.smax) smax = mulocal2
8368
 
!
8369
 
  if (nonzerothrs) then
8370
 
    hh = onshellthrs
8371
 
    do ii=1,4
8372
 
      if (ap(ii).lt.hh) ap(ii) = 0
8373
 
      if (am(ii).lt.hh) am(ii) = 0
8374
 
    enddo
8375
 
  else
8376
 
    hh = onshellthrs*smax
8377
 
    if (wunit.gt.0) then
8378
 
    do ii=1,4
8379
 
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
8380
 
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
8381
 
    enddo
8382
 
    endif
8383
 
  endif
8384
 
!
8385
 
  jj = 1
8386
 
  min56 = min(ap(5),ap(6))
8387
 
  if (min56.lt.hh) then
8388
 
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8389
 
      ,'input does not seem to represent hard kinematics, '&
8390
 
      ,'trying to permutate'
8391
 
    min13=min(ap(1),ap(3))
8392
 
    min24=min(ap(2),ap(4))
8393
 
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
8394
 
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
8395
 
    else
8396
 
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8397
 
        ,'no permutation helps, errors might follow'
8398
 
    endif
8399
 
  endif
8400
 
!
8401
 
  icase = 0
8402
 
  do ii=1,4
8403
 
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
8404
 
  enddo
8405
 
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
8406
 
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
8407
 
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
8408
 
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
8409
 
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
8410
 
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
8411
 
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
8412
 
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
8413
 
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
8414
 
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
8415
 
  icase = casetable(icase)
8416
 
!
8417
 
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
8418
 
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
8419
 
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
8420
 
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
8421
 
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
8422
 
  if (nonzerothrs) then
8423
 
    if (s1r2.lt.hh) s1r2 = 0
8424
 
    if (s2r2.lt.hh) s2r2 = 0
8425
 
    if (s2r3.lt.hh) s2r3 = 0
8426
 
    if (s3r4.lt.hh) s3r4 = 0
8427
 
    if (s4r4.lt.hh) s4r4 = 0
8428
 
  elseif (wunit.gt.0) then
8429
 
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
8430
 
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
8431
 
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
8432
 
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
8433
 
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
8434
 
  endif
8435
 
!
8436
 
  if     (icase.eq.4) then
8437
 
!4 non-zero internal masses
8438
 
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8439
 
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8440
 
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8441
 
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8442
 
               .or.(     areal(ss(1)).ge.-small  &
8443
 
                    .and.areal(ss(2)).ge.-small  &
8444
 
                    .and.areal(ss(3)).ge.-small  &
8445
 
                    .and.areal(ss(4)).ge.-small) )
8446
 
    if (useboxc) then
8447
 
      call boxc( rslt ,ss,rr ,as ,smax )
8448
 
    else
8449
 
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
8450
 
    endif
8451
 
  elseif (icase.eq.3) then
8452
 
!3 non-zero internal masses
8453
 
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8454
 
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8455
 
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8456
 
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8457
 
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8458
 
                 .or.(     areal(ss(1)).ge.-small  &
8459
 
                      .and.areal(ss(2)).ge.-small  &
8460
 
                      .and.areal(ss(3)).ge.-small  &
8461
 
                      .and.areal(ss(4)).ge.-small) )
8462
 
      if (useboxc) then
8463
 
        call boxc( rslt ,ss,rr ,as ,smax )
8464
 
      else
8465
 
        call boxf3( rslt, ss,rr )
8466
 
      endif
8467
 
    else
8468
 
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
8469
 
    endif
8470
 
  elseif (icase.eq.5) then
8471
 
!2 non-zero internal masses, opposite case
8472
 
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8473
 
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8474
 
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
8475
 
      else
8476
 
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8477
 
      endif
8478
 
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8479
 
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8480
 
    else
8481
 
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8482
 
    endif
8483
 
  elseif (icase.eq.2) then
8484
 
!2 non-zero internal masses, adjacent case
8485
 
    if     (as(1).ne.RZRO) then
8486
 
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
8487
 
    elseif (s2r3.ne.RZRO) then
8488
 
      if     (s4r4.ne.RZRO) then
8489
 
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8490
 
      else
8491
 
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
8492
 
      endif
8493
 
    elseif (s4r4.ne.RZRO) then
8494
 
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8495
 
    else
8496
 
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8497
 
    endif
8498
 
  elseif (icase.eq.1) then
8499
 
!1 non-zero internal mass
8500
 
    if     (as(1).ne.RZRO) then
8501
 
      if      (as(2).ne.RZRO) then
8502
 
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
8503
 
      else
8504
 
        if     (s3r4.ne.RZRO) then
8505
 
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8506
 
        else
8507
 
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8508
 
        endif
8509
 
      endif
8510
 
    elseif (as(2).ne.RZRO) then
8511
 
      if      (s4r4.ne.RZRO) then
8512
 
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8513
 
      else
8514
 
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8515
 
      endif
8516
 
    else
8517
 
      if     (s3r4.ne.RZRO) then
8518
 
        if     (s4r4.ne.RZRO) then
8519
 
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8520
 
        else
8521
 
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8522
 
        endif
8523
 
      elseif (s4r4.ne.RZRO) then
8524
 
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8525
 
      else
8526
 
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
8527
 
      endif
8528
 
    endif
8529
 
  else
8530
 
!0 non-zero internal mass
8531
 
    call box00( rslt ,ss ,as ,mulocal )
8532
 
  endif
8533
 
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
8534
 
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
8535
 
!
8536
 
  if (punit.gt.0) then
8537
 
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
8538
 
    write(punit,*) 'muscale:',trim(myprint(mulocal))
8539
 
    write(punit,*) ' p1:',trim(myprint(p1))
8540
 
    write(punit,*) ' p2:',trim(myprint(p2))
8541
 
    write(punit,*) ' p3:',trim(myprint(p3))
8542
 
    write(punit,*) ' p4:',trim(myprint(p4))
8543
 
    write(punit,*) 'p12:',trim(myprint(p12))
8544
 
    write(punit,*) 'p23:',trim(myprint(p23))
8545
 
    write(punit,*) ' m1:',trim(myprint(m1))
8546
 
    write(punit,*) ' m2:',trim(myprint(m2))
8547
 
    write(punit,*) ' m3:',trim(myprint(m3))
8548
 
    write(punit,*) ' m4:',trim(myprint(m4))
8549
 
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
8550
 
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
8551
 
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
8552
 
  endif
8553
 
  end subroutine
8554
 
 
8555
 
  subroutine d0rc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
8556
 
  use avh_olo_dp_box
8557
 
  use avh_olo_dp_boxc
8558
 
!
8559
 
  complex(kindr2) &
8560
 
    ,intent(out) :: rslt(0:2)
8561
 
  real(kindr2) &
8562
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
8563
 
  complex(kindr2) &
8564
 
    ,intent(in)  :: m1,m2,m3,m4
8565
 
!
8566
 
  real(kindr2) &
8567
 
    :: pp(6)
8568
 
  complex(kindr2) &
8569
 
    :: mm(4)
8570
 
  complex(kindr2) &
8571
 
    :: ss(6),rr(4)
8572
 
  real(kindr2) &
8573
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
8574
 
  real(kindr2) &
8575
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
8576
 
  integer :: icase,ii,jj
8577
 
  logical :: useboxc
8578
 
  integer ,parameter :: lp(6,3)=&
8579
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
8580
 
  integer ,parameter :: lm(4,3)=&
8581
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
8582
 
  character(25+99) ,parameter :: warning=&
8583
 
                 'WARNING from OneLOop d0: '//warnonshell
8584
 
  if (initz) call init
8585
 
  pp(1) = p1
8586
 
  pp(2) = p2
8587
 
  pp(3) = p3
8588
 
  pp(4) = p4
8589
 
  pp(5) = p12
8590
 
  pp(6) = p23
8591
 
  mm(1) = m1
8592
 
  mm(2) = m2
8593
 
  mm(3) = m3
8594
 
  mm(4) = m4
8595
 
  smax = 0
8596
 
!
8597
 
  do ii=1,6
8598
 
    ap(ii) = abs(pp(ii))
8599
 
    if (ap(ii).gt.smax) smax = ap(ii)
8600
 
  enddo
8601
 
!
8602
 
  do ii=1,4
8603
 
    am(ii) = areal(mm(ii))
8604
 
    hh = aimag(mm(ii))
8605
 
    if (hh.gt.RZRO) then
8606
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8607
 
        ,'mass-squared has positive imaginary part, switching its sign.'
8608
 
      mm(ii) = acmplx( am(ii) ,-hh )
8609
 
    endif
8610
 
    am(ii) = abs(am(ii)) + abs(hh)
8611
 
    if (am(ii).gt.smax) smax = am(ii)
8612
 
  enddo
8613
 
!
8614
 
  small = 0
8615
 
  do ii=1,6
8616
 
    hh = abs(ap(ii))
8617
 
    if (hh.gt.small) small=hh
8618
 
  enddo
8619
 
  small = small*neglig(prcpar)
8620
 
!
8621
 
  mulocal = muscale
8622
 
!
8623
 
  mulocal2 = mulocal*mulocal
8624
 
!
8625
 
  if (smax.eq.RZRO) then
8626
 
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8627
 
      ,'all input equal zero, returning 0'
8628
 
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
8629
 
    return
8630
 
  endif
8631
 
!
8632
 
  if (mulocal2.gt.smax) smax = mulocal2
8633
 
!
8634
 
  if (nonzerothrs) then
8635
 
    hh = onshellthrs
8636
 
    do ii=1,4
8637
 
      if (ap(ii).lt.hh) ap(ii) = 0
8638
 
      if (am(ii).lt.hh) am(ii) = 0
8639
 
    enddo
8640
 
  else
8641
 
    hh = onshellthrs*smax
8642
 
    if (wunit.gt.0) then
8643
 
    do ii=1,4
8644
 
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
8645
 
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
8646
 
    enddo
8647
 
    endif
8648
 
  endif
8649
 
!
8650
 
  jj = 1
8651
 
  min56 = min(ap(5),ap(6))
8652
 
  if (min56.lt.hh) then
8653
 
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8654
 
      ,'input does not seem to represent hard kinematics, '&
8655
 
      ,'trying to permutate'
8656
 
    min13=min(ap(1),ap(3))
8657
 
    min24=min(ap(2),ap(4))
8658
 
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
8659
 
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
8660
 
    else
8661
 
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8662
 
        ,'no permutation helps, errors might follow'
8663
 
    endif
8664
 
  endif
8665
 
!
8666
 
  icase = 0
8667
 
  do ii=1,4
8668
 
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
8669
 
  enddo
8670
 
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
8671
 
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
8672
 
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
8673
 
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
8674
 
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
8675
 
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
8676
 
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
8677
 
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
8678
 
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
8679
 
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
8680
 
  icase = casetable(icase)
8681
 
!
8682
 
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
8683
 
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
8684
 
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
8685
 
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
8686
 
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
8687
 
  if (nonzerothrs) then
8688
 
    if (s1r2.lt.hh) s1r2 = 0
8689
 
    if (s2r2.lt.hh) s2r2 = 0
8690
 
    if (s2r3.lt.hh) s2r3 = 0
8691
 
    if (s3r4.lt.hh) s3r4 = 0
8692
 
    if (s4r4.lt.hh) s4r4 = 0
8693
 
  elseif (wunit.gt.0) then
8694
 
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
8695
 
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
8696
 
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
8697
 
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
8698
 
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
8699
 
  endif
8700
 
!
8701
 
  if     (icase.eq.4) then
8702
 
!4 non-zero internal masses
8703
 
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8704
 
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8705
 
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8706
 
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8707
 
               .or.(     areal(ss(1)).ge.-small  &
8708
 
                    .and.areal(ss(2)).ge.-small  &
8709
 
                    .and.areal(ss(3)).ge.-small  &
8710
 
                    .and.areal(ss(4)).ge.-small) )
8711
 
    if (useboxc) then
8712
 
      call boxc( rslt ,ss,rr ,as ,smax )
8713
 
    else
8714
 
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
8715
 
    endif
8716
 
  elseif (icase.eq.3) then
8717
 
!3 non-zero internal masses
8718
 
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8719
 
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8720
 
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8721
 
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8722
 
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8723
 
                 .or.(     areal(ss(1)).ge.-small  &
8724
 
                      .and.areal(ss(2)).ge.-small  &
8725
 
                      .and.areal(ss(3)).ge.-small  &
8726
 
                      .and.areal(ss(4)).ge.-small) )
8727
 
      if (useboxc) then
8728
 
        call boxc( rslt ,ss,rr ,as ,smax )
8729
 
      else
8730
 
        call boxf3( rslt, ss,rr )
8731
 
      endif
8732
 
    else
8733
 
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
8734
 
    endif
8735
 
  elseif (icase.eq.5) then
8736
 
!2 non-zero internal masses, opposite case
8737
 
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8738
 
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8739
 
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
8740
 
      else
8741
 
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8742
 
      endif
8743
 
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
8744
 
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8745
 
    else
8746
 
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
8747
 
    endif
8748
 
  elseif (icase.eq.2) then
8749
 
!2 non-zero internal masses, adjacent case
8750
 
    if     (as(1).ne.RZRO) then
8751
 
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
8752
 
    elseif (s2r3.ne.RZRO) then
8753
 
      if     (s4r4.ne.RZRO) then
8754
 
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8755
 
      else
8756
 
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
8757
 
      endif
8758
 
    elseif (s4r4.ne.RZRO) then
8759
 
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8760
 
    else
8761
 
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
8762
 
    endif
8763
 
  elseif (icase.eq.1) then
8764
 
!1 non-zero internal mass
8765
 
    if     (as(1).ne.RZRO) then
8766
 
      if      (as(2).ne.RZRO) then
8767
 
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
8768
 
      else
8769
 
        if     (s3r4.ne.RZRO) then
8770
 
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8771
 
        else
8772
 
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8773
 
        endif
8774
 
      endif
8775
 
    elseif (as(2).ne.RZRO) then
8776
 
      if      (s4r4.ne.RZRO) then
8777
 
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8778
 
      else
8779
 
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8780
 
      endif
8781
 
    else
8782
 
      if     (s3r4.ne.RZRO) then
8783
 
        if     (s4r4.ne.RZRO) then
8784
 
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8785
 
        else
8786
 
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
8787
 
        endif
8788
 
      elseif (s4r4.ne.RZRO) then
8789
 
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
8790
 
      else
8791
 
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
8792
 
      endif
8793
 
    endif
8794
 
  else
8795
 
!0 non-zero internal mass
8796
 
    call box00( rslt ,ss ,as ,mulocal )
8797
 
  endif
8798
 
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
8799
 
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
8800
 
!
8801
 
  if (punit.gt.0) then
8802
 
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
8803
 
    write(punit,*) 'muscale:',trim(myprint(mulocal))
8804
 
    write(punit,*) ' p1:',trim(myprint(p1))
8805
 
    write(punit,*) ' p2:',trim(myprint(p2))
8806
 
    write(punit,*) ' p3:',trim(myprint(p3))
8807
 
    write(punit,*) ' p4:',trim(myprint(p4))
8808
 
    write(punit,*) 'p12:',trim(myprint(p12))
8809
 
    write(punit,*) 'p23:',trim(myprint(p23))
8810
 
    write(punit,*) ' m1:',trim(myprint(m1))
8811
 
    write(punit,*) ' m2:',trim(myprint(m2))
8812
 
    write(punit,*) ' m3:',trim(myprint(m3))
8813
 
    write(punit,*) ' m4:',trim(myprint(m4))
8814
 
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
8815
 
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
8816
 
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
8817
 
  endif
8818
 
  end subroutine
8819
 
 
8820
 
  subroutine d0rcr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
8821
 
  use avh_olo_dp_box
8822
 
  use avh_olo_dp_boxc
8823
 
!
8824
 
  complex(kindr2) &
8825
 
    ,intent(out) :: rslt(0:2)
8826
 
  real(kindr2) &
8827
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
8828
 
  complex(kindr2) &
8829
 
    ,intent(in)  :: m1,m2,m3,m4
8830
 
  real(kindr2) &
8831
 
    ,intent(in)  :: rmu
8832
 
!
8833
 
  real(kindr2) &
8834
 
    :: pp(6)
8835
 
  complex(kindr2) &
8836
 
    :: mm(4)
8837
 
  complex(kindr2) &
8838
 
    :: ss(6),rr(4)
8839
 
  real(kindr2) &
8840
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
8841
 
  real(kindr2) &
8842
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
8843
 
  integer :: icase,ii,jj
8844
 
  logical :: useboxc
8845
 
  integer ,parameter :: lp(6,3)=&
8846
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
8847
 
  integer ,parameter :: lm(4,3)=&
8848
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
8849
 
  character(25+99) ,parameter :: warning=&
8850
 
                 'WARNING from OneLOop d0: '//warnonshell
8851
 
  if (initz) call init
8852
 
  pp(1) = p1
8853
 
  pp(2) = p2
8854
 
  pp(3) = p3
8855
 
  pp(4) = p4
8856
 
  pp(5) = p12
8857
 
  pp(6) = p23
8858
 
  mm(1) = m1
8859
 
  mm(2) = m2
8860
 
  mm(3) = m3
8861
 
  mm(4) = m4
8862
 
  smax = 0
8863
 
!
8864
 
  do ii=1,6
8865
 
    ap(ii) = abs(pp(ii))
8866
 
    if (ap(ii).gt.smax) smax = ap(ii)
8867
 
  enddo
8868
 
!
8869
 
  do ii=1,4
8870
 
    am(ii) = areal(mm(ii))
8871
 
    hh = aimag(mm(ii))
8872
 
    if (hh.gt.RZRO) then
8873
 
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8874
 
        ,'mass-squared has positive imaginary part, switching its sign.'
8875
 
      mm(ii) = acmplx( am(ii) ,-hh )
8876
 
    endif
8877
 
    am(ii) = abs(am(ii)) + abs(hh)
8878
 
    if (am(ii).gt.smax) smax = am(ii)
8879
 
  enddo
8880
 
!
8881
 
  small = 0
8882
 
  do ii=1,6
8883
 
    hh = abs(ap(ii))
8884
 
    if (hh.gt.small) small=hh
8885
 
  enddo
8886
 
  small = small*neglig(prcpar)
8887
 
!
8888
 
  mulocal = rmu
8889
 
!
8890
 
  mulocal2 = mulocal*mulocal
8891
 
!
8892
 
  if (smax.eq.RZRO) then
8893
 
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
8894
 
      ,'all input equal zero, returning 0'
8895
 
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
8896
 
    return
8897
 
  endif
8898
 
!
8899
 
  if (mulocal2.gt.smax) smax = mulocal2
8900
 
!
8901
 
  if (nonzerothrs) then
8902
 
    hh = onshellthrs
8903
 
    do ii=1,4
8904
 
      if (ap(ii).lt.hh) ap(ii) = 0
8905
 
      if (am(ii).lt.hh) am(ii) = 0
8906
 
    enddo
8907
 
  else
8908
 
    hh = onshellthrs*smax
8909
 
    if (wunit.gt.0) then
8910
 
    do ii=1,4
8911
 
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
8912
 
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
8913
 
    enddo
8914
 
    endif
8915
 
  endif
8916
 
!
8917
 
  jj = 1
8918
 
  min56 = min(ap(5),ap(6))
8919
 
  if (min56.lt.hh) then
8920
 
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8921
 
      ,'input does not seem to represent hard kinematics, '&
8922
 
      ,'trying to permutate'
8923
 
    min13=min(ap(1),ap(3))
8924
 
    min24=min(ap(2),ap(4))
8925
 
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
8926
 
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
8927
 
    else
8928
 
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
8929
 
        ,'no permutation helps, errors might follow'
8930
 
    endif
8931
 
  endif
8932
 
!
8933
 
  icase = 0
8934
 
  do ii=1,4
8935
 
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
8936
 
  enddo
8937
 
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
8938
 
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
8939
 
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
8940
 
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
8941
 
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
8942
 
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
8943
 
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
8944
 
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
8945
 
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
8946
 
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
8947
 
  icase = casetable(icase)
8948
 
!
8949
 
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
8950
 
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
8951
 
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
8952
 
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
8953
 
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
8954
 
  if (nonzerothrs) then
8955
 
    if (s1r2.lt.hh) s1r2 = 0
8956
 
    if (s2r2.lt.hh) s2r2 = 0
8957
 
    if (s2r3.lt.hh) s2r3 = 0
8958
 
    if (s3r4.lt.hh) s3r4 = 0
8959
 
    if (s4r4.lt.hh) s4r4 = 0
8960
 
  elseif (wunit.gt.0) then
8961
 
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
8962
 
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
8963
 
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
8964
 
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
8965
 
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
8966
 
  endif
8967
 
!
8968
 
  if     (icase.eq.4) then
8969
 
!4 non-zero internal masses
8970
 
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8971
 
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8972
 
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8973
 
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8974
 
               .or.(     areal(ss(1)).ge.-small  &
8975
 
                    .and.areal(ss(2)).ge.-small  &
8976
 
                    .and.areal(ss(3)).ge.-small  &
8977
 
                    .and.areal(ss(4)).ge.-small) )
8978
 
    if (useboxc) then
8979
 
      call boxc( rslt ,ss,rr ,as ,smax )
8980
 
    else
8981
 
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
8982
 
    endif
8983
 
  elseif (icase.eq.3) then
8984
 
!3 non-zero internal masses
8985
 
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
8986
 
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
8987
 
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
8988
 
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
8989
 
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
8990
 
                 .or.(     areal(ss(1)).ge.-small  &
8991
 
                      .and.areal(ss(2)).ge.-small  &
8992
 
                      .and.areal(ss(3)).ge.-small  &
8993
 
                      .and.areal(ss(4)).ge.-small) )
8994
 
      if (useboxc) then
8995
 
        call boxc( rslt ,ss,rr ,as ,smax )
8996
 
      else
8997
 
        call boxf3( rslt, ss,rr )
8998
 
      endif
8999
 
    else
9000
 
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
9001
 
    endif
9002
 
  elseif (icase.eq.5) then
9003
 
!2 non-zero internal masses, opposite case
9004
 
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
9005
 
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
9006
 
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
9007
 
      else
9008
 
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9009
 
      endif
9010
 
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
9011
 
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9012
 
    else
9013
 
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9014
 
    endif
9015
 
  elseif (icase.eq.2) then
9016
 
!2 non-zero internal masses, adjacent case
9017
 
    if     (as(1).ne.RZRO) then
9018
 
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
9019
 
    elseif (s2r3.ne.RZRO) then
9020
 
      if     (s4r4.ne.RZRO) then
9021
 
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9022
 
      else
9023
 
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
9024
 
      endif
9025
 
    elseif (s4r4.ne.RZRO) then
9026
 
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9027
 
    else
9028
 
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9029
 
    endif
9030
 
  elseif (icase.eq.1) then
9031
 
!1 non-zero internal mass
9032
 
    if     (as(1).ne.RZRO) then
9033
 
      if      (as(2).ne.RZRO) then
9034
 
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
9035
 
      else
9036
 
        if     (s3r4.ne.RZRO) then
9037
 
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9038
 
        else
9039
 
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9040
 
        endif
9041
 
      endif
9042
 
    elseif (as(2).ne.RZRO) then
9043
 
      if      (s4r4.ne.RZRO) then
9044
 
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9045
 
      else
9046
 
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9047
 
      endif
9048
 
    else
9049
 
      if     (s3r4.ne.RZRO) then
9050
 
        if     (s4r4.ne.RZRO) then
9051
 
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9052
 
        else
9053
 
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9054
 
        endif
9055
 
      elseif (s4r4.ne.RZRO) then
9056
 
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9057
 
      else
9058
 
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
9059
 
      endif
9060
 
    endif
9061
 
  else
9062
 
!0 non-zero internal mass
9063
 
    call box00( rslt ,ss ,as ,mulocal )
9064
 
  endif
9065
 
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
9066
 
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
9067
 
!
9068
 
  if (punit.gt.0) then
9069
 
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
9070
 
    write(punit,*) 'muscale:',trim(myprint(mulocal))
9071
 
    write(punit,*) ' p1:',trim(myprint(p1))
9072
 
    write(punit,*) ' p2:',trim(myprint(p2))
9073
 
    write(punit,*) ' p3:',trim(myprint(p3))
9074
 
    write(punit,*) ' p4:',trim(myprint(p4))
9075
 
    write(punit,*) 'p12:',trim(myprint(p12))
9076
 
    write(punit,*) 'p23:',trim(myprint(p23))
9077
 
    write(punit,*) ' m1:',trim(myprint(m1))
9078
 
    write(punit,*) ' m2:',trim(myprint(m2))
9079
 
    write(punit,*) ' m3:',trim(myprint(m3))
9080
 
    write(punit,*) ' m4:',trim(myprint(m4))
9081
 
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
9082
 
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
9083
 
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
9084
 
  endif
9085
 
  end subroutine
9086
 
 
9087
 
  subroutine d0rr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
9088
 
  use avh_olo_dp_box
9089
 
  use avh_olo_dp_boxc
9090
 
!
9091
 
  complex(kindr2) &
9092
 
    ,intent(out) :: rslt(0:2)
9093
 
  real(kindr2) &
9094
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
9095
 
  real(kindr2) &
9096
 
    ,intent(in)  :: m1,m2,m3,m4
9097
 
!
9098
 
  real(kindr2) &
9099
 
    :: pp(6)
9100
 
  real(kindr2) &
9101
 
    :: mm(4)
9102
 
  complex(kindr2) &
9103
 
    :: ss(6),rr(4)
9104
 
  real(kindr2) &
9105
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
9106
 
  real(kindr2) &
9107
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
9108
 
  integer :: icase,ii,jj
9109
 
  logical :: useboxc
9110
 
  integer ,parameter :: lp(6,3)=&
9111
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
9112
 
  integer ,parameter :: lm(4,3)=&
9113
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
9114
 
  character(25+99) ,parameter :: warning=&
9115
 
                 'WARNING from OneLOop d0: '//warnonshell
9116
 
  if (initz) call init
9117
 
  pp(1) = p1
9118
 
  pp(2) = p2
9119
 
  pp(3) = p3
9120
 
  pp(4) = p4
9121
 
  pp(5) = p12
9122
 
  pp(6) = p23
9123
 
  mm(1) = m1
9124
 
  mm(2) = m2
9125
 
  mm(3) = m3
9126
 
  mm(4) = m4
9127
 
  smax = 0
9128
 
!
9129
 
  do ii=1,6
9130
 
    ap(ii) = abs(pp(ii))
9131
 
    if (ap(ii).gt.smax) smax = ap(ii)
9132
 
  enddo
9133
 
!
9134
 
  do ii=1,4
9135
 
    am(ii) = abs(mm(ii))
9136
 
    if (am(ii).gt.smax) smax = am(ii)
9137
 
  enddo
9138
 
!
9139
 
  small = 0
9140
 
  do ii=1,6
9141
 
    hh = abs(ap(ii))
9142
 
    if (hh.gt.small) small=hh
9143
 
  enddo
9144
 
  small = small*neglig(prcpar)
9145
 
!
9146
 
  mulocal = muscale
9147
 
!
9148
 
  mulocal2 = mulocal*mulocal
9149
 
!
9150
 
  if (smax.eq.RZRO) then
9151
 
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
9152
 
      ,'all input equal zero, returning 0'
9153
 
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
9154
 
    return
9155
 
  endif
9156
 
!
9157
 
  if (mulocal2.gt.smax) smax = mulocal2
9158
 
!
9159
 
  if (nonzerothrs) then
9160
 
    hh = onshellthrs
9161
 
    do ii=1,4
9162
 
      if (ap(ii).lt.hh) ap(ii) = 0
9163
 
      if (am(ii).lt.hh) am(ii) = 0
9164
 
    enddo
9165
 
  else
9166
 
    hh = onshellthrs*smax
9167
 
    if (wunit.gt.0) then
9168
 
    do ii=1,4
9169
 
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
9170
 
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
9171
 
    enddo
9172
 
    endif
9173
 
  endif
9174
 
!
9175
 
  jj = 1
9176
 
  min56 = min(ap(5),ap(6))
9177
 
  if (min56.lt.hh) then
9178
 
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
9179
 
      ,'input does not seem to represent hard kinematics, '&
9180
 
      ,'trying to permutate'
9181
 
    min13=min(ap(1),ap(3))
9182
 
    min24=min(ap(2),ap(4))
9183
 
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
9184
 
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
9185
 
    else
9186
 
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
9187
 
        ,'no permutation helps, errors might follow'
9188
 
    endif
9189
 
  endif
9190
 
!
9191
 
  icase = 0
9192
 
  do ii=1,4
9193
 
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
9194
 
  enddo
9195
 
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
9196
 
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
9197
 
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
9198
 
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
9199
 
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
9200
 
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
9201
 
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
9202
 
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
9203
 
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
9204
 
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
9205
 
  icase = casetable(icase)
9206
 
!
9207
 
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
9208
 
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
9209
 
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
9210
 
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
9211
 
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
9212
 
  if (nonzerothrs) then
9213
 
    if (s1r2.lt.hh) s1r2 = 0
9214
 
    if (s2r2.lt.hh) s2r2 = 0
9215
 
    if (s2r3.lt.hh) s2r3 = 0
9216
 
    if (s3r4.lt.hh) s3r4 = 0
9217
 
    if (s4r4.lt.hh) s4r4 = 0
9218
 
  elseif (wunit.gt.0) then
9219
 
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
9220
 
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
9221
 
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
9222
 
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
9223
 
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
9224
 
  endif
9225
 
!
9226
 
  if     (icase.eq.4) then
9227
 
!4 non-zero internal masses
9228
 
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
9229
 
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
9230
 
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
9231
 
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
9232
 
               .or.(     areal(ss(1)).ge.-small  &
9233
 
                    .and.areal(ss(2)).ge.-small  &
9234
 
                    .and.areal(ss(3)).ge.-small  &
9235
 
                    .and.areal(ss(4)).ge.-small) )
9236
 
    if (useboxc) then
9237
 
      call boxc( rslt ,ss,rr ,as ,smax )
9238
 
    else
9239
 
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
9240
 
    endif
9241
 
  elseif (icase.eq.3) then
9242
 
!3 non-zero internal masses
9243
 
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
9244
 
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
9245
 
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
9246
 
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
9247
 
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
9248
 
                 .or.(     areal(ss(1)).ge.-small  &
9249
 
                      .and.areal(ss(2)).ge.-small  &
9250
 
                      .and.areal(ss(3)).ge.-small  &
9251
 
                      .and.areal(ss(4)).ge.-small) )
9252
 
      if (useboxc) then
9253
 
        call boxc( rslt ,ss,rr ,as ,smax )
9254
 
      else
9255
 
        call boxf3( rslt, ss,rr )
9256
 
      endif
9257
 
    else
9258
 
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
9259
 
    endif
9260
 
  elseif (icase.eq.5) then
9261
 
!2 non-zero internal masses, opposite case
9262
 
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
9263
 
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
9264
 
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
9265
 
      else
9266
 
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9267
 
      endif
9268
 
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
9269
 
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9270
 
    else
9271
 
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
9272
 
    endif
9273
 
  elseif (icase.eq.2) then
9274
 
!2 non-zero internal masses, adjacent case
9275
 
    if     (as(1).ne.RZRO) then
9276
 
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
9277
 
    elseif (s2r3.ne.RZRO) then
9278
 
      if     (s4r4.ne.RZRO) then
9279
 
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9280
 
      else
9281
 
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
9282
 
      endif
9283
 
    elseif (s4r4.ne.RZRO) then
9284
 
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9285
 
    else
9286
 
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
9287
 
    endif
9288
 
  elseif (icase.eq.1) then
9289
 
!1 non-zero internal mass
9290
 
    if     (as(1).ne.RZRO) then
9291
 
      if      (as(2).ne.RZRO) then
9292
 
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
9293
 
      else
9294
 
        if     (s3r4.ne.RZRO) then
9295
 
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9296
 
        else
9297
 
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9298
 
        endif
9299
 
      endif
9300
 
    elseif (as(2).ne.RZRO) then
9301
 
      if      (s4r4.ne.RZRO) then
9302
 
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9303
 
      else
9304
 
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9305
 
      endif
9306
 
    else
9307
 
      if     (s3r4.ne.RZRO) then
9308
 
        if     (s4r4.ne.RZRO) then
9309
 
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9310
 
        else
9311
 
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
9312
 
        endif
9313
 
      elseif (s4r4.ne.RZRO) then
9314
 
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
9315
 
      else
9316
 
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
9317
 
      endif
9318
 
    endif
9319
 
  else
9320
 
!0 non-zero internal mass
9321
 
    call box00( rslt ,ss ,as ,mulocal )
9322
 
  endif
9323
 
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
9324
 
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
9325
 
!
9326
 
  if (punit.gt.0) then
9327
 
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
9328
 
    write(punit,*) 'muscale:',trim(myprint(mulocal))
9329
 
    write(punit,*) ' p1:',trim(myprint(p1))
9330
 
    write(punit,*) ' p2:',trim(myprint(p2))
9331
 
    write(punit,*) ' p3:',trim(myprint(p3))
9332
 
    write(punit,*) ' p4:',trim(myprint(p4))
9333
 
    write(punit,*) 'p12:',trim(myprint(p12))
9334
 
    write(punit,*) 'p23:',trim(myprint(p23))
9335
 
    write(punit,*) ' m1:',trim(myprint(m1))
9336
 
    write(punit,*) ' m2:',trim(myprint(m2))
9337
 
    write(punit,*) ' m3:',trim(myprint(m3))
9338
 
    write(punit,*) ' m4:',trim(myprint(m4))
9339
 
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
9340
 
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
9341
 
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
9342
 
  endif
9343
 
  end subroutine
9344
 
 
9345
 
  subroutine d0rrr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
9346
 
  use avh_olo_dp_box
9347
 
  use avh_olo_dp_boxc
9348
 
!
9349
 
  complex(kindr2) &
9350
 
    ,intent(out) :: rslt(0:2)
9351
 
  real(kindr2) &
9352
 
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
9353
 
  real(kindr2) &
9354
 
    ,intent(in)  :: m1,m2,m3,m4
9355
 
  real(kindr2) &
9356
 
    ,intent(in)  :: rmu
9357
 
!
9358
 
  real(kindr2) &
9359
 
    :: pp(6)
9360
 
  real(kindr2) &
9361
 
    :: mm(4)
9362
 
  complex(kindr2) &
9363
 
    :: ss(6),rr(4)
9364
 
  real(kindr2) &
9365
 
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
9366
 
  real(kindr2) &
9367
 
    :: mulocal,mulocal2,small,hh,min13,min24,min56
9368
 
  integer :: icase,ii,jj
9369
 
  logical :: useboxc
9370
 
  integer ,parameter :: lp(6,3)=&
9371
 
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
9372
 
  integer ,parameter :: lm(4,3)=&
9373
 
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
9374
 
  character(25+99) ,parameter :: warning=&
9375
 
                 'WARNING from OneLOop d0: '//warnonshell
9376
 
  if (initz) call init
9377
 
  pp(1) = p1
9378
 
  pp(2) = p2
9379
 
  pp(3) = p3
9380
 
  pp(4) = p4
9381
 
  pp(5) = p12
9382
 
  pp(6) = p23
9383
 
  mm(1) = m1
9384
 
  mm(2) = m2
9385
 
  mm(3) = m3
9386
 
  mm(4) = m4
9387
 
  smax = 0
9388
 
!
9389
 
  do ii=1,6
9390
 
    ap(ii) = abs(pp(ii))
9391
 
    if (ap(ii).gt.smax) smax = ap(ii)
9392
 
  enddo
9393
 
!
9394
 
  do ii=1,4
9395
 
    am(ii) = abs(mm(ii))
9396
 
    if (am(ii).gt.smax) smax = am(ii)
9397
 
  enddo
9398
 
!
9399
 
  small = 0
9400
 
  do ii=1,6
9401
 
    hh = abs(ap(ii))
9402
 
    if (hh.gt.small) small=hh
9403
 
  enddo
9404
 
  small = small*neglig(prcpar)
9405
 
!
9406
 
  mulocal = rmu
 
9395
  complex(kindr2) &   
 
9396
    ,intent(out) :: rslt(0:2)
 
9397
  complex(kindr2) &   
 
9398
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
9399
  complex(kindr2) &   
 
9400
    ,intent(in)  :: m1,m2,m3,m4
 
9401
!
 
9402
  complex(kindr2) &   
 
9403
    :: pp(6)
 
9404
  complex(kindr2) &   
 
9405
    :: mm(4)
 
9406
  complex(kindr2) &   
 
9407
    :: ss(6),rr(4)
 
9408
  real(kindr2) &  
 
9409
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
9410
  real(kindr2) &  
 
9411
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
9412
  integer :: icase,ii,jj
 
9413
  logical :: useboxc
 
9414
  integer ,parameter :: lp(6,3)=&
 
9415
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
9416
  integer ,parameter :: lm(4,3)=&
 
9417
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
9418
  character(25+99) ,parameter :: warning=&
 
9419
                 'WARNING from OneLOop d0: '//warnonshell
 
9420
  if (initz) call init
 
9421
  pp(1) = p1
 
9422
  pp(2) = p2
 
9423
  pp(3) = p3
 
9424
  pp(4) = p4
 
9425
  pp(5) = p12
 
9426
  pp(6) = p23
 
9427
  mm(1) = m1
 
9428
  mm(2) = m2
 
9429
  mm(3) = m3
 
9430
  mm(4) = m4
 
9431
  smax = 0
 
9432
!
 
9433
  do ii=1,6
 
9434
    ap(ii) = areal(pp(ii))
 
9435
    if (aimag(pp(ii)).ne.RZRO) then
 
9436
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9437
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
9438
      pp(ii) = acmplx( ap(ii) ,0 )
 
9439
    endif
 
9440
    ap(ii) = abs(ap(ii))
 
9441
    if (ap(ii).gt.smax) smax = ap(ii)
 
9442
  enddo
 
9443
!
 
9444
  do ii=1,4
 
9445
    am(ii) = areal(mm(ii))
 
9446
    hh = aimag(mm(ii))
 
9447
    if (hh.gt.RZRO) then
 
9448
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9449
        ,'mass-squared has positive imaginary part, switching its sign.'
 
9450
      mm(ii) = acmplx( am(ii) ,-hh )
 
9451
    endif
 
9452
    am(ii) = abs(am(ii)) + abs(hh)
 
9453
    if (am(ii).gt.smax) smax = am(ii)
 
9454
  enddo
 
9455
!
 
9456
  small = 0
 
9457
  do ii=1,6
 
9458
    hh = abs(ap(ii))
 
9459
    if (hh.gt.small) small=hh
 
9460
  enddo
 
9461
  small = small*neglig(prcpar)
 
9462
!
 
9463
  mulocal = muscale 
 
9464
!
 
9465
  mulocal2 = mulocal*mulocal
 
9466
!
 
9467
  if (smax.eq.RZRO) then
 
9468
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9469
      ,'all input equal zero, returning 0'
 
9470
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
9471
    return
 
9472
  endif
 
9473
!
 
9474
  if (mulocal2.gt.smax) smax = mulocal2
 
9475
!
 
9476
  if (nonzerothrs) then
 
9477
    hh = onshellthrs
 
9478
    do ii=1,4
 
9479
      if (ap(ii).lt.hh) ap(ii) = 0
 
9480
      if (am(ii).lt.hh) am(ii) = 0
 
9481
    enddo
 
9482
  else
 
9483
    hh = onshellthrs*smax
 
9484
    if (wunit.gt.0) then
 
9485
    do ii=1,4
 
9486
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
9487
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
9488
    enddo
 
9489
    endif
 
9490
  endif
 
9491
!
 
9492
  jj = 1
 
9493
  min56 = min(ap(5),ap(6))
 
9494
  if (min56.lt.hh) then
 
9495
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
9496
      ,'input does not seem to represent hard kinematics, '&
 
9497
      ,'trying to permutate'
 
9498
    min13=min(ap(1),ap(3))
 
9499
    min24=min(ap(2),ap(4))
 
9500
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
9501
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
9502
    else
 
9503
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
9504
        ,'no permutation helps, errors might follow'
 
9505
    endif
 
9506
  endif
 
9507
!
 
9508
  icase = 0
 
9509
  do ii=1,4
 
9510
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
9511
  enddo
 
9512
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
9513
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
9514
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
9515
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
9516
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
9517
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
9518
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
9519
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
9520
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
9521
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
9522
  icase = casetable(icase)
 
9523
!
 
9524
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
9525
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
9526
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
9527
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
9528
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
9529
  if (nonzerothrs) then
 
9530
    if (s1r2.lt.hh) s1r2 = 0
 
9531
    if (s2r2.lt.hh) s2r2 = 0
 
9532
    if (s2r3.lt.hh) s2r3 = 0
 
9533
    if (s3r4.lt.hh) s3r4 = 0
 
9534
    if (s4r4.lt.hh) s4r4 = 0
 
9535
  elseif (wunit.gt.0) then
 
9536
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
9537
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
9538
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
9539
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
9540
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
9541
  endif
 
9542
!
 
9543
  if     (icase.eq.4) then
 
9544
!4 non-zero internal masses
 
9545
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
9546
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
9547
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
9548
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
9549
               .or.(     areal(ss(1)).ge.-small  &
 
9550
                    .and.areal(ss(2)).ge.-small  &
 
9551
                    .and.areal(ss(3)).ge.-small  &
 
9552
                    .and.areal(ss(4)).ge.-small) )
 
9553
    if (useboxc) then
 
9554
      call boxc( rslt ,ss,rr ,as ,smax )
 
9555
    else
 
9556
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
9557
    endif
 
9558
  elseif (icase.eq.3) then
 
9559
!3 non-zero internal masses
 
9560
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
9561
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
9562
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
9563
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
9564
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
9565
                 .or.(     areal(ss(1)).ge.-small  &
 
9566
                      .and.areal(ss(2)).ge.-small  &
 
9567
                      .and.areal(ss(3)).ge.-small  &
 
9568
                      .and.areal(ss(4)).ge.-small) )
 
9569
      if (useboxc) then
 
9570
        call boxc( rslt ,ss,rr ,as ,smax )
 
9571
      else
 
9572
        call boxf3( rslt, ss,rr )
 
9573
      endif
 
9574
    else
 
9575
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
9576
    endif
 
9577
  elseif (icase.eq.5) then
 
9578
!2 non-zero internal masses, opposite case
 
9579
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
9580
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
9581
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
9582
      else
 
9583
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9584
      endif
 
9585
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
9586
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9587
    else
 
9588
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9589
    endif
 
9590
  elseif (icase.eq.2) then
 
9591
!2 non-zero internal masses, adjacent case
 
9592
    if     (as(1).ne.RZRO) then
 
9593
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
9594
    elseif (s2r3.ne.RZRO) then
 
9595
      if     (s4r4.ne.RZRO) then
 
9596
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9597
      else
 
9598
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
9599
      endif
 
9600
    elseif (s4r4.ne.RZRO) then
 
9601
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9602
    else
 
9603
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9604
    endif
 
9605
  elseif (icase.eq.1) then
 
9606
!1 non-zero internal mass
 
9607
    if     (as(1).ne.RZRO) then
 
9608
      if      (as(2).ne.RZRO) then
 
9609
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
9610
      else
 
9611
        if     (s3r4.ne.RZRO) then
 
9612
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9613
        else
 
9614
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9615
        endif
 
9616
      endif
 
9617
    elseif (as(2).ne.RZRO) then
 
9618
      if      (s4r4.ne.RZRO) then
 
9619
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9620
      else
 
9621
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9622
      endif
 
9623
    else
 
9624
      if     (s3r4.ne.RZRO) then
 
9625
        if     (s4r4.ne.RZRO) then
 
9626
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9627
        else
 
9628
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9629
        endif
 
9630
      elseif (s4r4.ne.RZRO) then
 
9631
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9632
      else
 
9633
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
9634
      endif
 
9635
    endif
 
9636
  else
 
9637
!0 non-zero internal mass
 
9638
    call box00( rslt ,ss ,as ,mulocal )
 
9639
  endif
 
9640
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
9641
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
9642
!
 
9643
  if (punit.gt.0) then
 
9644
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
9645
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
9646
    write(punit,*) ' p1:',trim(myprint(p1))
 
9647
    write(punit,*) ' p2:',trim(myprint(p2))
 
9648
    write(punit,*) ' p3:',trim(myprint(p3))
 
9649
    write(punit,*) ' p4:',trim(myprint(p4))
 
9650
    write(punit,*) 'p12:',trim(myprint(p12))
 
9651
    write(punit,*) 'p23:',trim(myprint(p23))
 
9652
    write(punit,*) ' m1:',trim(myprint(m1))
 
9653
    write(punit,*) ' m2:',trim(myprint(m2))
 
9654
    write(punit,*) ' m3:',trim(myprint(m3))
 
9655
    write(punit,*) ' m4:',trim(myprint(m4))
 
9656
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
9657
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
9658
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
9659
  endif
 
9660
  end subroutine
 
9661
 
 
9662
  subroutine d0ccr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
9663
  use avh_olo_dp_box
 
9664
  use avh_olo_dp_boxc
 
9665
!
 
9666
  complex(kindr2) &   
 
9667
    ,intent(out) :: rslt(0:2)
 
9668
  complex(kindr2) &   
 
9669
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
9670
  complex(kindr2) &   
 
9671
    ,intent(in)  :: m1,m2,m3,m4
 
9672
  real(kindr2) &  
 
9673
    ,intent(in)  :: rmu      
 
9674
!
 
9675
  complex(kindr2) &   
 
9676
    :: pp(6)
 
9677
  complex(kindr2) &   
 
9678
    :: mm(4)
 
9679
  complex(kindr2) &   
 
9680
    :: ss(6),rr(4)
 
9681
  real(kindr2) &  
 
9682
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
9683
  real(kindr2) &  
 
9684
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
9685
  integer :: icase,ii,jj
 
9686
  logical :: useboxc
 
9687
  integer ,parameter :: lp(6,3)=&
 
9688
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
9689
  integer ,parameter :: lm(4,3)=&
 
9690
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
9691
  character(25+99) ,parameter :: warning=&
 
9692
                 'WARNING from OneLOop d0: '//warnonshell
 
9693
  if (initz) call init
 
9694
  pp(1) = p1
 
9695
  pp(2) = p2
 
9696
  pp(3) = p3
 
9697
  pp(4) = p4
 
9698
  pp(5) = p12
 
9699
  pp(6) = p23
 
9700
  mm(1) = m1
 
9701
  mm(2) = m2
 
9702
  mm(3) = m3
 
9703
  mm(4) = m4
 
9704
  smax = 0
 
9705
!
 
9706
  do ii=1,6
 
9707
    ap(ii) = areal(pp(ii))
 
9708
    if (aimag(pp(ii)).ne.RZRO) then
 
9709
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9710
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
9711
      pp(ii) = acmplx( ap(ii) ,0 )
 
9712
    endif
 
9713
    ap(ii) = abs(ap(ii))
 
9714
    if (ap(ii).gt.smax) smax = ap(ii)
 
9715
  enddo
 
9716
!
 
9717
  do ii=1,4
 
9718
    am(ii) = areal(mm(ii))
 
9719
    hh = aimag(mm(ii))
 
9720
    if (hh.gt.RZRO) then
 
9721
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9722
        ,'mass-squared has positive imaginary part, switching its sign.'
 
9723
      mm(ii) = acmplx( am(ii) ,-hh )
 
9724
    endif
 
9725
    am(ii) = abs(am(ii)) + abs(hh)
 
9726
    if (am(ii).gt.smax) smax = am(ii)
 
9727
  enddo
 
9728
!
 
9729
  small = 0
 
9730
  do ii=1,6
 
9731
    hh = abs(ap(ii))
 
9732
    if (hh.gt.small) small=hh
 
9733
  enddo
 
9734
  small = small*neglig(prcpar)
 
9735
!
 
9736
  mulocal = rmu     
 
9737
!
 
9738
  mulocal2 = mulocal*mulocal
 
9739
!
 
9740
  if (smax.eq.RZRO) then
 
9741
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9742
      ,'all input equal zero, returning 0'
 
9743
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
9744
    return
 
9745
  endif
 
9746
!
 
9747
  if (mulocal2.gt.smax) smax = mulocal2
 
9748
!
 
9749
  if (nonzerothrs) then
 
9750
    hh = onshellthrs
 
9751
    do ii=1,4
 
9752
      if (ap(ii).lt.hh) ap(ii) = 0
 
9753
      if (am(ii).lt.hh) am(ii) = 0
 
9754
    enddo
 
9755
  else
 
9756
    hh = onshellthrs*smax
 
9757
    if (wunit.gt.0) then
 
9758
    do ii=1,4
 
9759
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
9760
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
9761
    enddo
 
9762
    endif
 
9763
  endif
 
9764
!
 
9765
  jj = 1
 
9766
  min56 = min(ap(5),ap(6))
 
9767
  if (min56.lt.hh) then
 
9768
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
9769
      ,'input does not seem to represent hard kinematics, '&
 
9770
      ,'trying to permutate'
 
9771
    min13=min(ap(1),ap(3))
 
9772
    min24=min(ap(2),ap(4))
 
9773
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
9774
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
9775
    else
 
9776
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
9777
        ,'no permutation helps, errors might follow'
 
9778
    endif
 
9779
  endif
 
9780
!
 
9781
  icase = 0
 
9782
  do ii=1,4
 
9783
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
9784
  enddo
 
9785
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
9786
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
9787
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
9788
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
9789
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
9790
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
9791
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
9792
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
9793
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
9794
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
9795
  icase = casetable(icase)
 
9796
!
 
9797
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
9798
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
9799
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
9800
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
9801
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
9802
  if (nonzerothrs) then
 
9803
    if (s1r2.lt.hh) s1r2 = 0
 
9804
    if (s2r2.lt.hh) s2r2 = 0
 
9805
    if (s2r3.lt.hh) s2r3 = 0
 
9806
    if (s3r4.lt.hh) s3r4 = 0
 
9807
    if (s4r4.lt.hh) s4r4 = 0
 
9808
  elseif (wunit.gt.0) then
 
9809
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
9810
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
9811
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
9812
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
9813
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
9814
  endif
 
9815
!
 
9816
  if     (icase.eq.4) then
 
9817
!4 non-zero internal masses
 
9818
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
9819
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
9820
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
9821
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
9822
               .or.(     areal(ss(1)).ge.-small  &
 
9823
                    .and.areal(ss(2)).ge.-small  &
 
9824
                    .and.areal(ss(3)).ge.-small  &
 
9825
                    .and.areal(ss(4)).ge.-small) )
 
9826
    if (useboxc) then
 
9827
      call boxc( rslt ,ss,rr ,as ,smax )
 
9828
    else
 
9829
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
9830
    endif
 
9831
  elseif (icase.eq.3) then
 
9832
!3 non-zero internal masses
 
9833
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
9834
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
9835
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
9836
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
9837
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
9838
                 .or.(     areal(ss(1)).ge.-small  &
 
9839
                      .and.areal(ss(2)).ge.-small  &
 
9840
                      .and.areal(ss(3)).ge.-small  &
 
9841
                      .and.areal(ss(4)).ge.-small) )
 
9842
      if (useboxc) then
 
9843
        call boxc( rslt ,ss,rr ,as ,smax )
 
9844
      else
 
9845
        call boxf3( rslt, ss,rr )
 
9846
      endif
 
9847
    else
 
9848
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
9849
    endif
 
9850
  elseif (icase.eq.5) then
 
9851
!2 non-zero internal masses, opposite case
 
9852
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
9853
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
9854
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
9855
      else
 
9856
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9857
      endif
 
9858
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
9859
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9860
    else
 
9861
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
9862
    endif
 
9863
  elseif (icase.eq.2) then
 
9864
!2 non-zero internal masses, adjacent case
 
9865
    if     (as(1).ne.RZRO) then
 
9866
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
9867
    elseif (s2r3.ne.RZRO) then
 
9868
      if     (s4r4.ne.RZRO) then
 
9869
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9870
      else
 
9871
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
9872
      endif
 
9873
    elseif (s4r4.ne.RZRO) then
 
9874
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9875
    else
 
9876
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
9877
    endif
 
9878
  elseif (icase.eq.1) then
 
9879
!1 non-zero internal mass
 
9880
    if     (as(1).ne.RZRO) then
 
9881
      if      (as(2).ne.RZRO) then
 
9882
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
9883
      else
 
9884
        if     (s3r4.ne.RZRO) then
 
9885
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9886
        else
 
9887
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9888
        endif
 
9889
      endif
 
9890
    elseif (as(2).ne.RZRO) then
 
9891
      if      (s4r4.ne.RZRO) then
 
9892
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9893
      else
 
9894
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9895
      endif
 
9896
    else
 
9897
      if     (s3r4.ne.RZRO) then
 
9898
        if     (s4r4.ne.RZRO) then
 
9899
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9900
        else
 
9901
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
9902
        endif
 
9903
      elseif (s4r4.ne.RZRO) then
 
9904
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
9905
      else
 
9906
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
9907
      endif
 
9908
    endif
 
9909
  else
 
9910
!0 non-zero internal mass
 
9911
    call box00( rslt ,ss ,as ,mulocal )
 
9912
  endif
 
9913
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
9914
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
9915
!
 
9916
  if (punit.gt.0) then
 
9917
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
9918
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
9919
    write(punit,*) ' p1:',trim(myprint(p1))
 
9920
    write(punit,*) ' p2:',trim(myprint(p2))
 
9921
    write(punit,*) ' p3:',trim(myprint(p3))
 
9922
    write(punit,*) ' p4:',trim(myprint(p4))
 
9923
    write(punit,*) 'p12:',trim(myprint(p12))
 
9924
    write(punit,*) 'p23:',trim(myprint(p23))
 
9925
    write(punit,*) ' m1:',trim(myprint(m1))
 
9926
    write(punit,*) ' m2:',trim(myprint(m2))
 
9927
    write(punit,*) ' m3:',trim(myprint(m3))
 
9928
    write(punit,*) ' m4:',trim(myprint(m4))
 
9929
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
9930
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
9931
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
9932
  endif
 
9933
  end subroutine
 
9934
 
 
9935
  subroutine d0rc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
9936
  use avh_olo_dp_box
 
9937
  use avh_olo_dp_boxc
 
9938
!
 
9939
  complex(kindr2) &   
 
9940
    ,intent(out) :: rslt(0:2)
 
9941
  real(kindr2) &  
 
9942
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
9943
  complex(kindr2) &   
 
9944
    ,intent(in)  :: m1,m2,m3,m4
 
9945
!
 
9946
  real(kindr2) &  
 
9947
    :: pp(6)
 
9948
  complex(kindr2) &   
 
9949
    :: mm(4)
 
9950
  complex(kindr2) &   
 
9951
    :: ss(6),rr(4)
 
9952
  real(kindr2) &  
 
9953
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
9954
  real(kindr2) &  
 
9955
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
9956
  integer :: icase,ii,jj
 
9957
  logical :: useboxc
 
9958
  integer ,parameter :: lp(6,3)=&
 
9959
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
9960
  integer ,parameter :: lm(4,3)=&
 
9961
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
9962
  character(25+99) ,parameter :: warning=&
 
9963
                 'WARNING from OneLOop d0: '//warnonshell
 
9964
  if (initz) call init
 
9965
  pp(1) = p1
 
9966
  pp(2) = p2
 
9967
  pp(3) = p3
 
9968
  pp(4) = p4
 
9969
  pp(5) = p12
 
9970
  pp(6) = p23
 
9971
  mm(1) = m1
 
9972
  mm(2) = m2
 
9973
  mm(3) = m3
 
9974
  mm(4) = m4
 
9975
  smax = 0
 
9976
!
 
9977
  do ii=1,6
 
9978
    ap(ii) = abs(pp(ii))
 
9979
    if (ap(ii).gt.smax) smax = ap(ii)
 
9980
  enddo
 
9981
!
 
9982
  do ii=1,4
 
9983
    am(ii) = areal(mm(ii))
 
9984
    hh = aimag(mm(ii))
 
9985
    if (hh.gt.RZRO) then
 
9986
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
9987
        ,'mass-squared has positive imaginary part, switching its sign.'
 
9988
      mm(ii) = acmplx( am(ii) ,-hh )
 
9989
    endif
 
9990
    am(ii) = abs(am(ii)) + abs(hh)
 
9991
    if (am(ii).gt.smax) smax = am(ii)
 
9992
  enddo
 
9993
!
 
9994
  small = 0
 
9995
  do ii=1,6
 
9996
    hh = abs(ap(ii))
 
9997
    if (hh.gt.small) small=hh
 
9998
  enddo
 
9999
  small = small*neglig(prcpar)
 
10000
!
 
10001
  mulocal = muscale 
 
10002
!
 
10003
  mulocal2 = mulocal*mulocal
 
10004
!
 
10005
  if (smax.eq.RZRO) then
 
10006
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
10007
      ,'all input equal zero, returning 0'
 
10008
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
10009
    return
 
10010
  endif
 
10011
!
 
10012
  if (mulocal2.gt.smax) smax = mulocal2
 
10013
!
 
10014
  if (nonzerothrs) then
 
10015
    hh = onshellthrs
 
10016
    do ii=1,4
 
10017
      if (ap(ii).lt.hh) ap(ii) = 0
 
10018
      if (am(ii).lt.hh) am(ii) = 0
 
10019
    enddo
 
10020
  else
 
10021
    hh = onshellthrs*smax
 
10022
    if (wunit.gt.0) then
 
10023
    do ii=1,4
 
10024
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
10025
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
10026
    enddo
 
10027
    endif
 
10028
  endif
 
10029
!
 
10030
  jj = 1
 
10031
  min56 = min(ap(5),ap(6))
 
10032
  if (min56.lt.hh) then
 
10033
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10034
      ,'input does not seem to represent hard kinematics, '&
 
10035
      ,'trying to permutate'
 
10036
    min13=min(ap(1),ap(3))
 
10037
    min24=min(ap(2),ap(4))
 
10038
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
10039
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
10040
    else
 
10041
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10042
        ,'no permutation helps, errors might follow'
 
10043
    endif
 
10044
  endif
 
10045
!
 
10046
  icase = 0
 
10047
  do ii=1,4
 
10048
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
10049
  enddo
 
10050
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
10051
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
10052
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
10053
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
10054
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
10055
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
10056
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
10057
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
10058
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
10059
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
10060
  icase = casetable(icase)
 
10061
!
 
10062
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
10063
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
10064
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
10065
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
10066
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
10067
  if (nonzerothrs) then
 
10068
    if (s1r2.lt.hh) s1r2 = 0
 
10069
    if (s2r2.lt.hh) s2r2 = 0
 
10070
    if (s2r3.lt.hh) s2r3 = 0
 
10071
    if (s3r4.lt.hh) s3r4 = 0
 
10072
    if (s4r4.lt.hh) s4r4 = 0
 
10073
  elseif (wunit.gt.0) then
 
10074
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
10075
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
10076
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
10077
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
10078
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
10079
  endif
 
10080
!
 
10081
  if     (icase.eq.4) then
 
10082
!4 non-zero internal masses
 
10083
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10084
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10085
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10086
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10087
               .or.(     areal(ss(1)).ge.-small  &
 
10088
                    .and.areal(ss(2)).ge.-small  &
 
10089
                    .and.areal(ss(3)).ge.-small  &
 
10090
                    .and.areal(ss(4)).ge.-small) )
 
10091
    if (useboxc) then
 
10092
      call boxc( rslt ,ss,rr ,as ,smax )
 
10093
    else
 
10094
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
10095
    endif
 
10096
  elseif (icase.eq.3) then
 
10097
!3 non-zero internal masses
 
10098
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10099
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10100
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10101
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10102
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10103
                 .or.(     areal(ss(1)).ge.-small  &
 
10104
                      .and.areal(ss(2)).ge.-small  &
 
10105
                      .and.areal(ss(3)).ge.-small  &
 
10106
                      .and.areal(ss(4)).ge.-small) )
 
10107
      if (useboxc) then
 
10108
        call boxc( rslt ,ss,rr ,as ,smax )
 
10109
      else
 
10110
        call boxf3( rslt, ss,rr )
 
10111
      endif
 
10112
    else
 
10113
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
10114
    endif
 
10115
  elseif (icase.eq.5) then
 
10116
!2 non-zero internal masses, opposite case
 
10117
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10118
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10119
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
10120
      else
 
10121
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10122
      endif
 
10123
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10124
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10125
    else
 
10126
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10127
    endif
 
10128
  elseif (icase.eq.2) then
 
10129
!2 non-zero internal masses, adjacent case
 
10130
    if     (as(1).ne.RZRO) then
 
10131
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
10132
    elseif (s2r3.ne.RZRO) then
 
10133
      if     (s4r4.ne.RZRO) then
 
10134
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10135
      else
 
10136
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
10137
      endif
 
10138
    elseif (s4r4.ne.RZRO) then
 
10139
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10140
    else
 
10141
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10142
    endif
 
10143
  elseif (icase.eq.1) then
 
10144
!1 non-zero internal mass
 
10145
    if     (as(1).ne.RZRO) then
 
10146
      if      (as(2).ne.RZRO) then
 
10147
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
10148
      else
 
10149
        if     (s3r4.ne.RZRO) then
 
10150
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10151
        else
 
10152
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10153
        endif
 
10154
      endif
 
10155
    elseif (as(2).ne.RZRO) then
 
10156
      if      (s4r4.ne.RZRO) then
 
10157
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10158
      else
 
10159
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10160
      endif
 
10161
    else
 
10162
      if     (s3r4.ne.RZRO) then
 
10163
        if     (s4r4.ne.RZRO) then
 
10164
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10165
        else
 
10166
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10167
        endif
 
10168
      elseif (s4r4.ne.RZRO) then
 
10169
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10170
      else
 
10171
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
10172
      endif
 
10173
    endif
 
10174
  else
 
10175
!0 non-zero internal mass
 
10176
    call box00( rslt ,ss ,as ,mulocal )
 
10177
  endif
 
10178
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
10179
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
10180
!
 
10181
  if (punit.gt.0) then
 
10182
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
10183
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
10184
    write(punit,*) ' p1:',trim(myprint(p1))
 
10185
    write(punit,*) ' p2:',trim(myprint(p2))
 
10186
    write(punit,*) ' p3:',trim(myprint(p3))
 
10187
    write(punit,*) ' p4:',trim(myprint(p4))
 
10188
    write(punit,*) 'p12:',trim(myprint(p12))
 
10189
    write(punit,*) 'p23:',trim(myprint(p23))
 
10190
    write(punit,*) ' m1:',trim(myprint(m1))
 
10191
    write(punit,*) ' m2:',trim(myprint(m2))
 
10192
    write(punit,*) ' m3:',trim(myprint(m3))
 
10193
    write(punit,*) ' m4:',trim(myprint(m4))
 
10194
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
10195
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
10196
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
10197
  endif
 
10198
  end subroutine
 
10199
 
 
10200
  subroutine d0rcr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
10201
  use avh_olo_dp_box
 
10202
  use avh_olo_dp_boxc
 
10203
!
 
10204
  complex(kindr2) &   
 
10205
    ,intent(out) :: rslt(0:2)
 
10206
  real(kindr2) &  
 
10207
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
10208
  complex(kindr2) &   
 
10209
    ,intent(in)  :: m1,m2,m3,m4
 
10210
  real(kindr2) &  
 
10211
    ,intent(in)  :: rmu      
 
10212
!
 
10213
  real(kindr2) &  
 
10214
    :: pp(6)
 
10215
  complex(kindr2) &   
 
10216
    :: mm(4)
 
10217
  complex(kindr2) &   
 
10218
    :: ss(6),rr(4)
 
10219
  real(kindr2) &  
 
10220
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
10221
  real(kindr2) &  
 
10222
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
10223
  integer :: icase,ii,jj
 
10224
  logical :: useboxc
 
10225
  integer ,parameter :: lp(6,3)=&
 
10226
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
10227
  integer ,parameter :: lm(4,3)=&
 
10228
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
10229
  character(25+99) ,parameter :: warning=&
 
10230
                 'WARNING from OneLOop d0: '//warnonshell
 
10231
  if (initz) call init
 
10232
  pp(1) = p1
 
10233
  pp(2) = p2
 
10234
  pp(3) = p3
 
10235
  pp(4) = p4
 
10236
  pp(5) = p12
 
10237
  pp(6) = p23
 
10238
  mm(1) = m1
 
10239
  mm(2) = m2
 
10240
  mm(3) = m3
 
10241
  mm(4) = m4
 
10242
  smax = 0
 
10243
!
 
10244
  do ii=1,6
 
10245
    ap(ii) = abs(pp(ii))
 
10246
    if (ap(ii).gt.smax) smax = ap(ii)
 
10247
  enddo
 
10248
!
 
10249
  do ii=1,4
 
10250
    am(ii) = areal(mm(ii))
 
10251
    hh = aimag(mm(ii))
 
10252
    if (hh.gt.RZRO) then
 
10253
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
10254
        ,'mass-squared has positive imaginary part, switching its sign.'
 
10255
      mm(ii) = acmplx( am(ii) ,-hh )
 
10256
    endif
 
10257
    am(ii) = abs(am(ii)) + abs(hh)
 
10258
    if (am(ii).gt.smax) smax = am(ii)
 
10259
  enddo
 
10260
!
 
10261
  small = 0
 
10262
  do ii=1,6
 
10263
    hh = abs(ap(ii))
 
10264
    if (hh.gt.small) small=hh
 
10265
  enddo
 
10266
  small = small*neglig(prcpar)
 
10267
!
 
10268
  mulocal = rmu     
 
10269
!
 
10270
  mulocal2 = mulocal*mulocal
 
10271
!
 
10272
  if (smax.eq.RZRO) then
 
10273
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
10274
      ,'all input equal zero, returning 0'
 
10275
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
10276
    return
 
10277
  endif
 
10278
!
 
10279
  if (mulocal2.gt.smax) smax = mulocal2
 
10280
!
 
10281
  if (nonzerothrs) then
 
10282
    hh = onshellthrs
 
10283
    do ii=1,4
 
10284
      if (ap(ii).lt.hh) ap(ii) = 0
 
10285
      if (am(ii).lt.hh) am(ii) = 0
 
10286
    enddo
 
10287
  else
 
10288
    hh = onshellthrs*smax
 
10289
    if (wunit.gt.0) then
 
10290
    do ii=1,4
 
10291
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
10292
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
10293
    enddo
 
10294
    endif
 
10295
  endif
 
10296
!
 
10297
  jj = 1
 
10298
  min56 = min(ap(5),ap(6))
 
10299
  if (min56.lt.hh) then
 
10300
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10301
      ,'input does not seem to represent hard kinematics, '&
 
10302
      ,'trying to permutate'
 
10303
    min13=min(ap(1),ap(3))
 
10304
    min24=min(ap(2),ap(4))
 
10305
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
10306
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
10307
    else
 
10308
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10309
        ,'no permutation helps, errors might follow'
 
10310
    endif
 
10311
  endif
 
10312
!
 
10313
  icase = 0
 
10314
  do ii=1,4
 
10315
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
10316
  enddo
 
10317
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
10318
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
10319
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
10320
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
10321
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
10322
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
10323
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
10324
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
10325
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
10326
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
10327
  icase = casetable(icase)
 
10328
!
 
10329
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
10330
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
10331
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
10332
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
10333
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
10334
  if (nonzerothrs) then
 
10335
    if (s1r2.lt.hh) s1r2 = 0
 
10336
    if (s2r2.lt.hh) s2r2 = 0
 
10337
    if (s2r3.lt.hh) s2r3 = 0
 
10338
    if (s3r4.lt.hh) s3r4 = 0
 
10339
    if (s4r4.lt.hh) s4r4 = 0
 
10340
  elseif (wunit.gt.0) then
 
10341
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
10342
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
10343
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
10344
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
10345
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
10346
  endif
 
10347
!
 
10348
  if     (icase.eq.4) then
 
10349
!4 non-zero internal masses
 
10350
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10351
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10352
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10353
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10354
               .or.(     areal(ss(1)).ge.-small  &
 
10355
                    .and.areal(ss(2)).ge.-small  &
 
10356
                    .and.areal(ss(3)).ge.-small  &
 
10357
                    .and.areal(ss(4)).ge.-small) )
 
10358
    if (useboxc) then
 
10359
      call boxc( rslt ,ss,rr ,as ,smax )
 
10360
    else
 
10361
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
10362
    endif
 
10363
  elseif (icase.eq.3) then
 
10364
!3 non-zero internal masses
 
10365
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10366
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10367
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10368
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10369
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10370
                 .or.(     areal(ss(1)).ge.-small  &
 
10371
                      .and.areal(ss(2)).ge.-small  &
 
10372
                      .and.areal(ss(3)).ge.-small  &
 
10373
                      .and.areal(ss(4)).ge.-small) )
 
10374
      if (useboxc) then
 
10375
        call boxc( rslt ,ss,rr ,as ,smax )
 
10376
      else
 
10377
        call boxf3( rslt, ss,rr )
 
10378
      endif
 
10379
    else
 
10380
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
10381
    endif
 
10382
  elseif (icase.eq.5) then
 
10383
!2 non-zero internal masses, opposite case
 
10384
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10385
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10386
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
10387
      else
 
10388
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10389
      endif
 
10390
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10391
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10392
    else
 
10393
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10394
    endif
 
10395
  elseif (icase.eq.2) then
 
10396
!2 non-zero internal masses, adjacent case
 
10397
    if     (as(1).ne.RZRO) then
 
10398
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
10399
    elseif (s2r3.ne.RZRO) then
 
10400
      if     (s4r4.ne.RZRO) then
 
10401
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10402
      else
 
10403
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
10404
      endif
 
10405
    elseif (s4r4.ne.RZRO) then
 
10406
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10407
    else
 
10408
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10409
    endif
 
10410
  elseif (icase.eq.1) then
 
10411
!1 non-zero internal mass
 
10412
    if     (as(1).ne.RZRO) then
 
10413
      if      (as(2).ne.RZRO) then
 
10414
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
10415
      else
 
10416
        if     (s3r4.ne.RZRO) then
 
10417
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10418
        else
 
10419
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10420
        endif
 
10421
      endif
 
10422
    elseif (as(2).ne.RZRO) then
 
10423
      if      (s4r4.ne.RZRO) then
 
10424
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10425
      else
 
10426
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10427
      endif
 
10428
    else
 
10429
      if     (s3r4.ne.RZRO) then
 
10430
        if     (s4r4.ne.RZRO) then
 
10431
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10432
        else
 
10433
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10434
        endif
 
10435
      elseif (s4r4.ne.RZRO) then
 
10436
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10437
      else
 
10438
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
10439
      endif
 
10440
    endif
 
10441
  else
 
10442
!0 non-zero internal mass
 
10443
    call box00( rslt ,ss ,as ,mulocal )
 
10444
  endif
 
10445
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
10446
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
10447
!
 
10448
  if (punit.gt.0) then
 
10449
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
10450
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
10451
    write(punit,*) ' p1:',trim(myprint(p1))
 
10452
    write(punit,*) ' p2:',trim(myprint(p2))
 
10453
    write(punit,*) ' p3:',trim(myprint(p3))
 
10454
    write(punit,*) ' p4:',trim(myprint(p4))
 
10455
    write(punit,*) 'p12:',trim(myprint(p12))
 
10456
    write(punit,*) 'p23:',trim(myprint(p23))
 
10457
    write(punit,*) ' m1:',trim(myprint(m1))
 
10458
    write(punit,*) ' m2:',trim(myprint(m2))
 
10459
    write(punit,*) ' m3:',trim(myprint(m3))
 
10460
    write(punit,*) ' m4:',trim(myprint(m4))
 
10461
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
10462
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
10463
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
10464
  endif
 
10465
  end subroutine
 
10466
 
 
10467
  subroutine d0rr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
10468
  use avh_olo_dp_box
 
10469
  use avh_olo_dp_boxc
 
10470
!
 
10471
  complex(kindr2) &   
 
10472
    ,intent(out) :: rslt(0:2)
 
10473
  real(kindr2) &  
 
10474
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
10475
  real(kindr2) &  
 
10476
    ,intent(in)  :: m1,m2,m3,m4
 
10477
!
 
10478
  real(kindr2) &  
 
10479
    :: pp(6)
 
10480
  real(kindr2) &  
 
10481
    :: mm(4)
 
10482
  complex(kindr2) &   
 
10483
    :: ss(6),rr(4)
 
10484
  real(kindr2) &  
 
10485
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
10486
  real(kindr2) &  
 
10487
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
10488
  integer :: icase,ii,jj
 
10489
  logical :: useboxc
 
10490
  integer ,parameter :: lp(6,3)=&
 
10491
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
10492
  integer ,parameter :: lm(4,3)=&
 
10493
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
10494
  character(25+99) ,parameter :: warning=&
 
10495
                 'WARNING from OneLOop d0: '//warnonshell
 
10496
  if (initz) call init
 
10497
  pp(1) = p1
 
10498
  pp(2) = p2
 
10499
  pp(3) = p3
 
10500
  pp(4) = p4
 
10501
  pp(5) = p12
 
10502
  pp(6) = p23
 
10503
  mm(1) = m1
 
10504
  mm(2) = m2
 
10505
  mm(3) = m3
 
10506
  mm(4) = m4
 
10507
  smax = 0
 
10508
!
 
10509
  do ii=1,6
 
10510
    ap(ii) = abs(pp(ii))
 
10511
    if (ap(ii).gt.smax) smax = ap(ii)
 
10512
  enddo
 
10513
!
 
10514
  do ii=1,4
 
10515
    am(ii) = abs(mm(ii))
 
10516
    if (am(ii).gt.smax) smax = am(ii)
 
10517
  enddo
 
10518
!
 
10519
  small = 0
 
10520
  do ii=1,6
 
10521
    hh = abs(ap(ii))
 
10522
    if (hh.gt.small) small=hh
 
10523
  enddo
 
10524
  small = small*neglig(prcpar)
 
10525
!
 
10526
  mulocal = muscale 
 
10527
!
 
10528
  mulocal2 = mulocal*mulocal
 
10529
!
 
10530
  if (smax.eq.RZRO) then
 
10531
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
10532
      ,'all input equal zero, returning 0'
 
10533
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
10534
    return
 
10535
  endif
 
10536
!
 
10537
  if (mulocal2.gt.smax) smax = mulocal2
 
10538
!
 
10539
  if (nonzerothrs) then
 
10540
    hh = onshellthrs
 
10541
    do ii=1,4
 
10542
      if (ap(ii).lt.hh) ap(ii) = 0
 
10543
      if (am(ii).lt.hh) am(ii) = 0
 
10544
    enddo
 
10545
  else
 
10546
    hh = onshellthrs*smax
 
10547
    if (wunit.gt.0) then
 
10548
    do ii=1,4
 
10549
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
10550
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
10551
    enddo
 
10552
    endif
 
10553
  endif
 
10554
!
 
10555
  jj = 1
 
10556
  min56 = min(ap(5),ap(6))
 
10557
  if (min56.lt.hh) then
 
10558
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10559
      ,'input does not seem to represent hard kinematics, '&
 
10560
      ,'trying to permutate'
 
10561
    min13=min(ap(1),ap(3))
 
10562
    min24=min(ap(2),ap(4))
 
10563
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
10564
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
10565
    else
 
10566
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10567
        ,'no permutation helps, errors might follow'
 
10568
    endif
 
10569
  endif
 
10570
!
 
10571
  icase = 0
 
10572
  do ii=1,4
 
10573
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
10574
  enddo
 
10575
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
10576
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
10577
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
10578
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
10579
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
10580
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
10581
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
10582
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
10583
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
10584
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
10585
  icase = casetable(icase)
 
10586
!
 
10587
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
10588
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
10589
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
10590
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
10591
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
10592
  if (nonzerothrs) then
 
10593
    if (s1r2.lt.hh) s1r2 = 0
 
10594
    if (s2r2.lt.hh) s2r2 = 0
 
10595
    if (s2r3.lt.hh) s2r3 = 0
 
10596
    if (s3r4.lt.hh) s3r4 = 0
 
10597
    if (s4r4.lt.hh) s4r4 = 0
 
10598
  elseif (wunit.gt.0) then
 
10599
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
10600
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
10601
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
10602
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
10603
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
10604
  endif
 
10605
!
 
10606
  if     (icase.eq.4) then
 
10607
!4 non-zero internal masses
 
10608
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10609
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10610
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10611
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10612
               .or.(     areal(ss(1)).ge.-small  &
 
10613
                    .and.areal(ss(2)).ge.-small  &
 
10614
                    .and.areal(ss(3)).ge.-small  &
 
10615
                    .and.areal(ss(4)).ge.-small) )
 
10616
    if (useboxc) then
 
10617
      call boxc( rslt ,ss,rr ,as ,smax )
 
10618
    else
 
10619
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
10620
    endif
 
10621
  elseif (icase.eq.3) then
 
10622
!3 non-zero internal masses
 
10623
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10624
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10625
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10626
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10627
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10628
                 .or.(     areal(ss(1)).ge.-small  &
 
10629
                      .and.areal(ss(2)).ge.-small  &
 
10630
                      .and.areal(ss(3)).ge.-small  &
 
10631
                      .and.areal(ss(4)).ge.-small) )
 
10632
      if (useboxc) then
 
10633
        call boxc( rslt ,ss,rr ,as ,smax )
 
10634
      else
 
10635
        call boxf3( rslt, ss,rr )
 
10636
      endif
 
10637
    else
 
10638
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
10639
    endif
 
10640
  elseif (icase.eq.5) then
 
10641
!2 non-zero internal masses, opposite case
 
10642
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10643
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10644
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
10645
      else
 
10646
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10647
      endif
 
10648
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10649
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10650
    else
 
10651
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10652
    endif
 
10653
  elseif (icase.eq.2) then
 
10654
!2 non-zero internal masses, adjacent case
 
10655
    if     (as(1).ne.RZRO) then
 
10656
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
10657
    elseif (s2r3.ne.RZRO) then
 
10658
      if     (s4r4.ne.RZRO) then
 
10659
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10660
      else
 
10661
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
10662
      endif
 
10663
    elseif (s4r4.ne.RZRO) then
 
10664
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10665
    else
 
10666
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10667
    endif
 
10668
  elseif (icase.eq.1) then
 
10669
!1 non-zero internal mass
 
10670
    if     (as(1).ne.RZRO) then
 
10671
      if      (as(2).ne.RZRO) then
 
10672
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
10673
      else
 
10674
        if     (s3r4.ne.RZRO) then
 
10675
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10676
        else
 
10677
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10678
        endif
 
10679
      endif
 
10680
    elseif (as(2).ne.RZRO) then
 
10681
      if      (s4r4.ne.RZRO) then
 
10682
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10683
      else
 
10684
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10685
      endif
 
10686
    else
 
10687
      if     (s3r4.ne.RZRO) then
 
10688
        if     (s4r4.ne.RZRO) then
 
10689
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10690
        else
 
10691
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10692
        endif
 
10693
      elseif (s4r4.ne.RZRO) then
 
10694
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10695
      else
 
10696
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
10697
      endif
 
10698
    endif
 
10699
  else
 
10700
!0 non-zero internal mass
 
10701
    call box00( rslt ,ss ,as ,mulocal )
 
10702
  endif
 
10703
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
10704
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
10705
!
 
10706
  if (punit.gt.0) then
 
10707
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
10708
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
10709
    write(punit,*) ' p1:',trim(myprint(p1))
 
10710
    write(punit,*) ' p2:',trim(myprint(p2))
 
10711
    write(punit,*) ' p3:',trim(myprint(p3))
 
10712
    write(punit,*) ' p4:',trim(myprint(p4))
 
10713
    write(punit,*) 'p12:',trim(myprint(p12))
 
10714
    write(punit,*) 'p23:',trim(myprint(p23))
 
10715
    write(punit,*) ' m1:',trim(myprint(m1))
 
10716
    write(punit,*) ' m2:',trim(myprint(m2))
 
10717
    write(punit,*) ' m3:',trim(myprint(m3))
 
10718
    write(punit,*) ' m4:',trim(myprint(m4))
 
10719
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
10720
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
10721
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
10722
  endif
 
10723
  end subroutine
 
10724
 
 
10725
  subroutine d0rrr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
10726
  use avh_olo_dp_box
 
10727
  use avh_olo_dp_boxc
 
10728
!
 
10729
  complex(kindr2) &   
 
10730
    ,intent(out) :: rslt(0:2)
 
10731
  real(kindr2) &  
 
10732
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
10733
  real(kindr2) &  
 
10734
    ,intent(in)  :: m1,m2,m3,m4
 
10735
  real(kindr2) &  
 
10736
    ,intent(in)  :: rmu      
 
10737
!
 
10738
  real(kindr2) &  
 
10739
    :: pp(6)
 
10740
  real(kindr2) &  
 
10741
    :: mm(4)
 
10742
  complex(kindr2) &   
 
10743
    :: ss(6),rr(4)
 
10744
  real(kindr2) &  
 
10745
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
10746
  real(kindr2) &  
 
10747
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
10748
  integer :: icase,ii,jj
 
10749
  logical :: useboxc
 
10750
  integer ,parameter :: lp(6,3)=&
 
10751
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
10752
  integer ,parameter :: lm(4,3)=&
 
10753
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
10754
  character(25+99) ,parameter :: warning=&
 
10755
                 'WARNING from OneLOop d0: '//warnonshell
 
10756
  if (initz) call init
 
10757
  pp(1) = p1
 
10758
  pp(2) = p2
 
10759
  pp(3) = p3
 
10760
  pp(4) = p4
 
10761
  pp(5) = p12
 
10762
  pp(6) = p23
 
10763
  mm(1) = m1
 
10764
  mm(2) = m2
 
10765
  mm(3) = m3
 
10766
  mm(4) = m4
 
10767
  smax = 0
 
10768
!
 
10769
  do ii=1,6
 
10770
    ap(ii) = abs(pp(ii))
 
10771
    if (ap(ii).gt.smax) smax = ap(ii)
 
10772
  enddo
 
10773
!
 
10774
  do ii=1,4
 
10775
    am(ii) = abs(mm(ii))
 
10776
    if (am(ii).gt.smax) smax = am(ii)
 
10777
  enddo
 
10778
!
 
10779
  small = 0
 
10780
  do ii=1,6
 
10781
    hh = abs(ap(ii))
 
10782
    if (hh.gt.small) small=hh
 
10783
  enddo
 
10784
  small = small*neglig(prcpar)
 
10785
!
 
10786
  mulocal = rmu     
 
10787
!
 
10788
  mulocal2 = mulocal*mulocal
 
10789
!
 
10790
  if (smax.eq.RZRO) then
 
10791
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
10792
      ,'all input equal zero, returning 0'
 
10793
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
10794
    return
 
10795
  endif
 
10796
!
 
10797
  if (mulocal2.gt.smax) smax = mulocal2
 
10798
!
 
10799
  if (nonzerothrs) then
 
10800
    hh = onshellthrs
 
10801
    do ii=1,4
 
10802
      if (ap(ii).lt.hh) ap(ii) = 0
 
10803
      if (am(ii).lt.hh) am(ii) = 0
 
10804
    enddo
 
10805
  else
 
10806
    hh = onshellthrs*smax
 
10807
    if (wunit.gt.0) then
 
10808
    do ii=1,4
 
10809
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
10810
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
10811
    enddo
 
10812
    endif
 
10813
  endif
 
10814
!
 
10815
  jj = 1
 
10816
  min56 = min(ap(5),ap(6))
 
10817
  if (min56.lt.hh) then
 
10818
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10819
      ,'input does not seem to represent hard kinematics, '&
 
10820
      ,'trying to permutate'
 
10821
    min13=min(ap(1),ap(3))
 
10822
    min24=min(ap(2),ap(4))
 
10823
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
10824
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
10825
    else
 
10826
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
10827
        ,'no permutation helps, errors might follow'
 
10828
    endif
 
10829
  endif
 
10830
!
 
10831
  icase = 0
 
10832
  do ii=1,4
 
10833
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
10834
  enddo
 
10835
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
10836
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
10837
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
10838
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
10839
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
10840
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
10841
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
10842
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
10843
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
10844
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
10845
  icase = casetable(icase)
 
10846
!
 
10847
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
10848
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
10849
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
10850
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
10851
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
10852
  if (nonzerothrs) then
 
10853
    if (s1r2.lt.hh) s1r2 = 0
 
10854
    if (s2r2.lt.hh) s2r2 = 0
 
10855
    if (s2r3.lt.hh) s2r3 = 0
 
10856
    if (s3r4.lt.hh) s3r4 = 0
 
10857
    if (s4r4.lt.hh) s4r4 = 0
 
10858
  elseif (wunit.gt.0) then
 
10859
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
10860
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
10861
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
10862
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
10863
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
10864
  endif
 
10865
!
 
10866
  if     (icase.eq.4) then
 
10867
!4 non-zero internal masses
 
10868
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10869
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10870
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10871
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10872
               .or.(     areal(ss(1)).ge.-small  &
 
10873
                    .and.areal(ss(2)).ge.-small  &
 
10874
                    .and.areal(ss(3)).ge.-small  &
 
10875
                    .and.areal(ss(4)).ge.-small) )
 
10876
    if (useboxc) then
 
10877
      call boxc( rslt ,ss,rr ,as ,smax )
 
10878
    else
 
10879
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
10880
    endif
 
10881
  elseif (icase.eq.3) then
 
10882
!3 non-zero internal masses
 
10883
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10884
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
10885
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
10886
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
10887
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
10888
                 .or.(     areal(ss(1)).ge.-small  &
 
10889
                      .and.areal(ss(2)).ge.-small  &
 
10890
                      .and.areal(ss(3)).ge.-small  &
 
10891
                      .and.areal(ss(4)).ge.-small) )
 
10892
      if (useboxc) then
 
10893
        call boxc( rslt ,ss,rr ,as ,smax )
 
10894
      else
 
10895
        call boxf3( rslt, ss,rr )
 
10896
      endif
 
10897
    else
 
10898
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
10899
    endif
 
10900
  elseif (icase.eq.5) then
 
10901
!2 non-zero internal masses, opposite case
 
10902
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
10903
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10904
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
10905
      else
 
10906
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10907
      endif
 
10908
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
10909
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10910
    else
 
10911
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
10912
    endif
 
10913
  elseif (icase.eq.2) then
 
10914
!2 non-zero internal masses, adjacent case
 
10915
    if     (as(1).ne.RZRO) then
 
10916
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
10917
    elseif (s2r3.ne.RZRO) then
 
10918
      if     (s4r4.ne.RZRO) then
 
10919
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10920
      else
 
10921
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
10922
      endif
 
10923
    elseif (s4r4.ne.RZRO) then
 
10924
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10925
    else
 
10926
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
10927
    endif
 
10928
  elseif (icase.eq.1) then
 
10929
!1 non-zero internal mass
 
10930
    if     (as(1).ne.RZRO) then
 
10931
      if      (as(2).ne.RZRO) then
 
10932
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
10933
      else
 
10934
        if     (s3r4.ne.RZRO) then
 
10935
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10936
        else
 
10937
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10938
        endif
 
10939
      endif
 
10940
    elseif (as(2).ne.RZRO) then
 
10941
      if      (s4r4.ne.RZRO) then
 
10942
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10943
      else
 
10944
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10945
      endif
 
10946
    else
 
10947
      if     (s3r4.ne.RZRO) then
 
10948
        if     (s4r4.ne.RZRO) then
 
10949
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10950
        else
 
10951
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
10952
        endif
 
10953
      elseif (s4r4.ne.RZRO) then
 
10954
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
10955
      else
 
10956
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
10957
      endif
 
10958
    endif
 
10959
  else
 
10960
!0 non-zero internal mass
 
10961
    call box00( rslt ,ss ,as ,mulocal )
 
10962
  endif
 
10963
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
10964
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
10965
!
 
10966
  if (punit.gt.0) then
 
10967
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
10968
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
10969
    write(punit,*) ' p1:',trim(myprint(p1))
 
10970
    write(punit,*) ' p2:',trim(myprint(p2))
 
10971
    write(punit,*) ' p3:',trim(myprint(p3))
 
10972
    write(punit,*) ' p4:',trim(myprint(p4))
 
10973
    write(punit,*) 'p12:',trim(myprint(p12))
 
10974
    write(punit,*) 'p23:',trim(myprint(p23))
 
10975
    write(punit,*) ' m1:',trim(myprint(m1))
 
10976
    write(punit,*) ' m2:',trim(myprint(m2))
 
10977
    write(punit,*) ' m3:',trim(myprint(m3))
 
10978
    write(punit,*) ' m4:',trim(myprint(m4))
 
10979
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
10980
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
10981
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
10982
  endif
 
10983
  end subroutine
 
10984
 
 
10985
end module
 
10986
 
 
10987
 
 
10988
module avh_olo_qp_kinds
 
10989
  integer ,parameter :: kindr2=16 
 
10990
end module
 
10991
 
 
10992
 
 
10993
module avh_olo_qp_arrays
 
10994
  use avh_olo_units
 
10995
  use avh_olo_qp_kinds 
 
10996
  implicit none
 
10997
  private
 
10998
  public :: shift1,shift2,shift3,resize,enlarge
 
10999
 
 
11000
! Increase the size of the last dimension by one,
 
11001
! and move  x(...,n:nsize)  to  x(...,n+1:nsize+1).
 
11002
  interface shift1 ! for x(:)
 
11003
    module procedure shift1_r,shift1_i
 
11004
  end interface
 
11005
  interface shift2 ! for x(:,:)
 
11006
    module procedure shift2_r,shift2_i
 
11007
  end interface
 
11008
  interface shift3 ! for x(:,:,:)
 
11009
    module procedure shift3_r,shift3_i
 
11010
  end interface
 
11011
 
 
11012
! Resize x to the new bounds. Anything that doesn't fit anymore is lost.
 
11013
  interface resize
 
11014
    module procedure resize1_r,resize2_r
 
11015
  end interface
 
11016
 
 
11017
! Resize x to the maximum of the bounds it has and then new bounds.
 
11018
  interface enlarge
 
11019
    module procedure enlarge1_r,enlarge2_r
 
11020
  end interface
 
11021
 
 
11022
contains
 
11023
 
 
11024
  subroutine shift1_r( xx ,nn )
 
11025
  real(kindr2) &  
 
11026
    ,allocatable ,intent(inout) :: xx(:)
 
11027
  integer        ,intent(in   ) :: nn
 
11028
  real(kindr2) &  
 
11029
    ,allocatable :: tt(:)
 
11030
  integer ,parameter :: dm=1
 
11031
  integer :: lb(dm),ub(dm)
 
11032
  if (.not.allocated(xx)) then
 
11033
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift1_r'
 
11034
    stop
 
11035
  endif
 
11036
  lb=lbound(xx) ;ub=ubound(xx)
 
11037
  allocate(tt(lb(dm):ub(dm)))
 
11038
  tt = xx
 
11039
  deallocate(xx)
 
11040
  ub(dm) = ub(dm)+1
 
11041
  allocate(xx(lb(dm):ub(dm)))
 
11042
  xx(lb(dm):nn-1) = tt(lb(dm):nn-1)
 
11043
  xx(nn+1:ub(dm)) = tt(nn:ub(dm)-1)
 
11044
  deallocate(tt)
 
11045
  end subroutine
 
11046
 
 
11047
  subroutine shift1_i( xx ,nn )
 
11048
  integer ,allocatable ,intent(inout) :: xx(:)
 
11049
  integer              ,intent(in   ) :: nn
 
11050
  integer ,allocatable :: tt(:)
 
11051
  integer ,parameter :: dm=1
 
11052
  integer :: lb(dm),ub(dm)
 
11053
  if (.not.allocated(xx)) then
 
11054
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift1_i'
 
11055
    stop
 
11056
  endif
 
11057
  lb=lbound(xx) ;ub=ubound(xx)
 
11058
  allocate(tt(lb(dm):ub(dm)))
 
11059
  tt = xx
 
11060
  deallocate(xx)
 
11061
  ub(dm) = ub(dm)+1
 
11062
  allocate(xx(lb(dm):ub(dm)))
 
11063
  xx(lb(dm):nn-1) = tt(lb(dm):nn-1)
 
11064
  xx(nn+1:ub(dm)) = tt(nn:ub(dm)-1)
 
11065
  deallocate(tt)
 
11066
  end subroutine
 
11067
 
 
11068
  subroutine shift2_r( xx ,nn )
 
11069
  real(kindr2) &  
 
11070
          ,allocatable ,intent(inout) :: xx(:,:)
 
11071
  integer              ,intent(in   ) :: nn
 
11072
  real(kindr2) &  
 
11073
          ,allocatable :: tt(:,:)
 
11074
  integer ,parameter :: dm=2
 
11075
  integer :: lb(dm),ub(dm)
 
11076
  if (.not.allocated(xx)) then
 
11077
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift2_r'
 
11078
    stop
 
11079
  endif
 
11080
  lb=lbound(xx) ;ub=ubound(xx)
 
11081
  allocate(tt(lb(1):ub(1),lb(dm):ub(dm)))
 
11082
  tt = xx
 
11083
  deallocate(xx)
 
11084
  ub(dm) = ub(dm)+1
 
11085
  allocate(xx(lb(1):ub(1),lb(dm):ub(dm)))
 
11086
  xx(:,lb(dm):nn-1) = tt(:,lb(dm):nn-1)
 
11087
  xx(:,nn+1:ub(dm)) = tt(:,nn:ub(dm)-1)
 
11088
  deallocate(tt)
 
11089
  end subroutine
 
11090
 
 
11091
  subroutine shift2_i( xx ,nn )
 
11092
  integer ,allocatable ,intent(inout) :: xx(:,:)
 
11093
  integer              ,intent(in   ) :: nn
 
11094
  integer ,allocatable :: tt(:,:)
 
11095
  integer ,parameter :: dm=2
 
11096
  integer :: lb(dm),ub(dm)
 
11097
  if (.not.allocated(xx)) then
 
11098
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift2_i'
 
11099
    stop
 
11100
  endif
 
11101
  lb=lbound(xx) ;ub=ubound(xx)
 
11102
  allocate(tt(lb(1):ub(1),lb(dm):ub(dm)))
 
11103
  tt = xx
 
11104
  deallocate(xx)
 
11105
  ub(dm) = ub(dm)+1
 
11106
  allocate(xx(lb(1):ub(1),lb(dm):ub(dm)))
 
11107
  xx(:,lb(dm):nn-1) = tt(:,lb(dm):nn-1)
 
11108
  xx(:,nn+1:ub(dm)) = tt(:,nn:ub(dm)-1)
 
11109
  deallocate(tt)
 
11110
  end subroutine
 
11111
 
 
11112
  subroutine shift3_r( xx ,nn )
 
11113
  real(kindr2) &  
 
11114
    ,allocatable ,intent(inout) :: xx(:,:,:)
 
11115
  integer        ,intent(in   ) :: nn
 
11116
  real(kindr2) &  
 
11117
    ,allocatable :: tt(:,:,:)
 
11118
  integer ,parameter :: dm=3
 
11119
  integer :: lb(dm),ub(dm)
 
11120
  if (.not.allocated(xx)) then
 
11121
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift3_r'
 
11122
    stop
 
11123
  endif
 
11124
  lb=lbound(xx) ;ub=ubound(xx)
 
11125
  allocate(tt(lb(1):ub(1),lb(2):ub(2),lb(dm):ub(dm)))
 
11126
  tt = xx
 
11127
  deallocate(xx)
 
11128
  ub(dm) = ub(dm)+1
 
11129
  allocate(xx(lb(1):ub(1),lb(2):ub(2),lb(dm):ub(dm)))
 
11130
  xx(:,:,lb(dm):nn-1) = tt(:,:,lb(dm):nn-1)
 
11131
  xx(:,:,nn+1:ub(dm)) = tt(:,:,nn:ub(dm)-1)
 
11132
  deallocate(tt)
 
11133
  end subroutine
 
11134
 
 
11135
  subroutine shift3_i( xx ,nn )
 
11136
  integer ,allocatable ,intent(inout) :: xx(:,:,:)
 
11137
  integer              ,intent(in   ) :: nn
 
11138
  integer ,allocatable :: tt(:,:,:)
 
11139
  integer ,parameter :: dm=3
 
11140
  integer :: lb(dm),ub(dm)
 
11141
  if (.not.allocated(xx)) then
 
11142
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop shift3_i'
 
11143
    stop
 
11144
  endif
 
11145
  lb=lbound(xx) ;ub=ubound(xx)
 
11146
  allocate(tt(lb(1):ub(1),lb(2):ub(2),lb(dm):ub(dm)))
 
11147
  tt = xx
 
11148
  deallocate(xx)
 
11149
  ub(dm) = ub(dm)+1
 
11150
  allocate(xx(lb(1):ub(1),lb(2):ub(2),lb(dm):ub(dm)))
 
11151
  xx(:,:,lb(dm):nn-1) = tt(:,:,lb(dm):nn-1)
 
11152
  xx(:,:,nn+1:ub(dm)) = tt(:,:,nn:ub(dm)-1)
 
11153
  deallocate(tt)
 
11154
  end subroutine
 
11155
 
 
11156
 
 
11157
  subroutine resize1_r( xx ,l1,u1 )
 
11158
  real(kindr2) &  
 
11159
    ,allocatable ,intent(inout) :: xx(:)
 
11160
  integer        ,intent(in   ) :: l1,u1
 
11161
  real(kindr2) &  
 
11162
    ,allocatable :: tt(:)
 
11163
  integer :: lb(1),ub(1)
 
11164
  if (.not.allocated(xx)) then
 
11165
    allocate(xx(l1:u1))
 
11166
    return
 
11167
  endif
 
11168
  lb=lbound(xx) ;ub=ubound(xx)
 
11169
  allocate(tt(lb(1):ub(1)))
 
11170
  tt = xx
 
11171
  deallocate(xx)
 
11172
  allocate( xx(l1:u1) )
 
11173
  lb(1)=max(l1,lb(1)) ;ub(1)=min(u1,ub(1))
 
11174
  xx(lb(1):ub(1)) = tt(lb(1):ub(1))
 
11175
  deallocate(tt)
 
11176
  end subroutine 
 
11177
 
 
11178
  subroutine resize2_r( xx ,l1,u1 ,l2,u2 )
 
11179
  real(kindr2) &  
 
11180
    ,allocatable ,intent(inout) :: xx(:,:)
 
11181
  integer        ,intent(in   ) :: l1,u1,l2,u2
 
11182
  real(kindr2) &  
 
11183
    ,allocatable :: tt(:,:)
 
11184
  integer :: lb(2),ub(2)
 
11185
  if (.not.allocated(xx)) then
 
11186
    allocate(xx(l1:u1,l2:u2))
 
11187
    return
 
11188
  endif
 
11189
  lb=lbound(xx) ;ub=ubound(xx)
 
11190
  allocate(tt(lb(1):ub(1),lb(2):ub(2)))
 
11191
  tt = xx
 
11192
  deallocate(xx)
 
11193
  allocate( xx(l1:u1,l2:u2) )
 
11194
  lb(1)=max(l1,lb(1)) ;ub(1)=min(u1,ub(1))
 
11195
  lb(2)=max(l2,lb(2)) ;ub(2)=min(u2,ub(2))
 
11196
  xx(lb(1):ub(1),lb(2):ub(2)) = &
 
11197
  tt(lb(1):ub(1),lb(2):ub(2))
 
11198
  deallocate(tt)
 
11199
  end subroutine 
 
11200
 
 
11201
 
 
11202
  subroutine enlarge1_r( xx ,l1,u1 )
 
11203
  real(kindr2) &  
 
11204
    ,allocatable ,intent(inout) :: xx(:)
 
11205
  integer        ,intent(in   ) :: l1,u1
 
11206
  real(kindr2) &  
 
11207
    ,allocatable :: tt(:)
 
11208
  integer :: lb(1),ub(1)
 
11209
  if (.not.allocated(xx)) then
 
11210
    allocate(xx(l1:u1))
 
11211
    return
 
11212
  endif
 
11213
  lb=lbound(xx) ;ub=ubound(xx)
 
11214
  if (lb(1).le.l1.and.u1.le.ub(1)) return
 
11215
  if (lb(1).gt.ub(1)) then
 
11216
    deallocate( xx )
 
11217
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))) )
 
11218
    return
 
11219
  endif
 
11220
  allocate(tt(lb(1):ub(1)))
 
11221
  tt = xx
 
11222
  deallocate(xx)
 
11223
  allocate( xx(min(l1,lb(1)):max(u1,ub(1))) )
 
11224
  xx(lb(1):ub(1)) = tt(lb(1):ub(1))
 
11225
  deallocate(tt)
 
11226
  end subroutine 
 
11227
 
 
11228
  subroutine enlarge2_r( xx ,l1,u1 ,l2,u2 )
 
11229
  real(kindr2) &  
 
11230
    ,allocatable ,intent(inout) :: xx(:,:)
 
11231
  integer        ,intent(in   ) :: l1,u1,l2,u2
 
11232
  real(kindr2) &  
 
11233
    ,allocatable :: tt(:,:)
 
11234
  integer :: lb(2),ub(2)
 
11235
  if (.not.allocated(xx)) then
 
11236
    allocate(xx(l1:u1,l2:u2))
 
11237
    return
 
11238
  endif
 
11239
  lb=lbound(xx) ;ub=ubound(xx)
 
11240
  if (lb(1).le.l1.and.u1.le.ub(1).and. &
 
11241
      lb(2).le.l2.and.u2.le.ub(2)      ) return
 
11242
  if (lb(1).gt.ub(1).or.lb(2).gt.ub(2)) then
 
11243
    deallocate( xx )
 
11244
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))  &
 
11245
                ,min(l2,lb(2)):max(u2,ub(2))) )
 
11246
    return
 
11247
  endif
 
11248
  allocate(tt(lb(1):ub(1),lb(2):ub(2)))
 
11249
  tt = xx
 
11250
  deallocate(xx)
 
11251
  allocate( xx(min(l1,lb(1)):max(u1,ub(1))  &
 
11252
              ,min(l2,lb(2)):max(u2,ub(2))) )
 
11253
  xx(lb(1):ub(1),lb(2):ub(2)) = &
 
11254
  tt(lb(1):ub(1),lb(2):ub(2))
 
11255
  deallocate(tt)
 
11256
  end subroutine 
 
11257
 
 
11258
end module
 
11259
 
 
11260
 
 
11261
module avh_olo_qp_prec
 
11262
  use avh_olo_qp_kinds
 
11263
 
 
11264
  implicit none
 
11265
  public
 
11266
  private :: IMAG,acmplx_r,acmplx_rr,acmplx_ir,acmplx_ri,acmplx_c
 
11267
 
 
11268
  integer ,save :: prcpar=0
 
11269
  integer ,save :: ndecim(1)
 
11270
  real(kindr2) &
 
11271
          ,save :: epsilo(1),neglig(1)
 
11272
 
 
11273
  real(kindr2) &
 
11274
    ,save :: RZRO ,RONE ,EPSN ,EPSN2 ,TWOPI ,ONEPI
 
11275
  complex(kindr2) &
 
11276
    ,save :: IEPS ,CZRO ,CONE ,IMAG ,PISQo24 ,IPI
 
11277
 
 
11278
  interface acmplx
 
11279
    module procedure acmplx_r,acmplx_rr,acmplx_ir,acmplx_ri,acmplx_c
 
11280
  end interface
 
11281
 
 
11282
contains
 
11283
 
 
11284
 
 
11285
  subroutine set_precision( newprc )
 
11286
!***********************************************************************
 
11287
!***********************************************************************
 
11288
  use avh_olo_units
 
11289
  logical ,intent(out) :: newprc
 
11290
  integer :: ndec                                  
 
11291
  if (prcpar.eq.1) then                    
 
11292
    newprc = .false.                             
 
11293
    return                                       
 
11294
  endif
 
11295
  prcpar = 1                                   
 
11296
  call set_epsn
 
11297
  newprc = .true.                              
 
11298
  RZRO=0
 
11299
  RONE=1
 
11300
  IMAG=cmplx(0,1,kind=kind(IMAG))
 
11301
  CZRO=RZRO
 
11302
  CONE=RONE
 
11303
  ONEPI=4*atan(RONE)
 
11304
  TWOPI=2*ONEPI
 
11305
  PISQo24=CONE*ONEPI*ONEPI/24
 
11306
  IPI=IMAG*ONEPI
 
11307
  EPSN2= EPSN*EPSN
 
11308
  IEPS= EPSN2*IMAG
 
11309
!
 
11310
  contains
 
11311
!
 
11312
  subroutine set_epsn
 
11313
  EPSN = epsilon(EPSN)                         
 
11314
  ndec = -log10(EPSN)                            
 
11315
  ndecim(prcpar) = ndec                          
 
11316
  epsilo(prcpar) = EPSN                        
 
11317
  neglig(prcpar) = EPSN*10**(ndec/7)       
 
11318
  end subroutine
 
11319
!
 
11320
  end subroutine
 
11321
 
 
11322
 
 
11323
  function adble(xx) result(rslt)
 
11324
!***********************************************************************
 
11325
! Turn real(kindr2) into kind(1d0)
 
11326
!***********************************************************************
 
11327
  real(kindr2) ,intent(in) :: xx
 
11328
  real(kind(1d0)) :: rslt
 
11329
  rslt = real(xx,kind=kind(rslt))
 
11330
  end function
 
11331
 
 
11332
  function convert(xx) result(rslt)
 
11333
!***********************************************************************
 
11334
! Turn kind(1d0) into real(kindr2)
 
11335
!***********************************************************************
 
11336
  real(kind(1d0)) ,intent(in) :: xx
 
11337
  real(kindr2) :: rslt
 
11338
  rslt = real(xx,kind=kind(rslt))
 
11339
  end function
 
11340
 
 
11341
  function areal(zz) result(rslt)
 
11342
!***********************************************************************
 
11343
! Get real part of a complex
 
11344
!***********************************************************************
 
11345
  complex(kindr2) &
 
11346
    ,intent(in) :: zz
 
11347
  real(kindr2) &
 
11348
    :: rslt
 
11349
  rslt = zz
 
11350
  end function
 
11351
 
 
11352
  function acmplx_r(xx) result(rslt)
 
11353
!***********************************************************************
 
11354
! Turn a real into a complex
 
11355
!***********************************************************************
 
11356
  real(kindr2) &
 
11357
    ,intent(in) :: xx
 
11358
  complex(kindr2) &
 
11359
    :: rslt
 
11360
  rslt = xx
 
11361
  end function
 
11362
  
 
11363
  function acmplx_rr(xx,yy) result(rslt)
 
11364
!***********************************************************************
 
11365
! Turn two reals into one complex
 
11366
!***********************************************************************
 
11367
  real(kindr2) &
 
11368
    ,intent(in) :: xx,yy
 
11369
  complex(kindr2) &
 
11370
    :: rslt
 
11371
  rslt = cmplx(xx,yy,kind=kind(rslt))
 
11372
  end function
 
11373
  
 
11374
  function acmplx_ri(xx,yy) result(rslt)
 
11375
!***********************************************************************
 
11376
! Turn a real and an integer into one complex
 
11377
!***********************************************************************
 
11378
  real(kindr2) &
 
11379
           ,intent(in) :: xx
 
11380
  integer  ,intent(in) :: yy
 
11381
  complex(kindr2) &
 
11382
    :: rslt
 
11383
  rslt = cmplx(xx,yy,kind=kind(rslt))
 
11384
  end function
 
11385
  
 
11386
  function acmplx_ir(xx,yy) result(rslt)
 
11387
!***********************************************************************
 
11388
! Turn an integer and a real into one complex
 
11389
!***********************************************************************
 
11390
  integer ,intent(in) :: xx
 
11391
  real(kindr2) &
 
11392
          ,intent(in) :: yy
 
11393
  complex(kindr2) &
 
11394
    :: rslt
 
11395
  rslt = cmplx(xx,yy,kind=kind(rslt))
 
11396
  end function
 
11397
  
 
11398
  function acmplx_c(zz) result(rslt)
 
11399
!***********************************************************************
 
11400
! Replaces the real part of zz by its absolute value
 
11401
!***********************************************************************
 
11402
  complex(kindr2) &
 
11403
    ,intent(in) :: zz
 
11404
  complex(kindr2) &
 
11405
    :: rslt
 
11406
  real(kindr2) &
 
11407
    :: xx,yy
 
11408
  xx = zz
 
11409
  xx = abs(xx)
 
11410
  yy = aimag(zz)
 
11411
  rslt = cmplx(xx,yy,kind=kind(rslt))
 
11412
  end function
 
11413
  
 
11414
end module
 
11415
 
 
11416
 
 
11417
module avh_olo_qp_print
 
11418
  use avh_olo_qp_prec
 
11419
  implicit none
 
11420
  private
 
11421
  public :: myprint
 
11422
 
 
11423
  integer ,parameter :: novh=10 !maximally 6 decimals for exponent
 
11424
  integer ,parameter :: nxtr=4  !extra decimals
 
11425
 
 
11426
  interface myprint
 
11427
    module procedure printr,printc,printi
 
11428
  end interface
 
11429
 
 
11430
contains
 
11431
 
 
11432
  function printc( zz ,ndec ) result(rslt)
 
11433
  complex(kindr2) &   
 
11434
    ,intent(in) :: zz
 
11435
  integer,optional,intent(in) :: ndec
 
11436
  character((ndecim(prcpar)+nxtr+novh)*2+3) :: rslt
 
11437
  if (present(ndec)) then
 
11438
    rslt = '('//trim(printr(areal(zz),ndec)) &
 
11439
         //','//trim(printr(aimag(zz),ndec)) &
 
11440
         //')'
 
11441
  else
 
11442
    rslt = '('//trim(printr(areal(zz))) &
 
11443
         //','//trim(printr(aimag(zz))) &
 
11444
         //')'
 
11445
  endif
 
11446
  rslt = adjustl(rslt)
 
11447
  end function
 
11448
 
 
11449
  function printr( xx_in ,ndec_in ) result(rslt)
 
11450
  real(kindr2) &  
 
11451
                  ,intent(in) :: xx_in
 
11452
  integer,optional,intent(in) :: ndec_in
 
11453
  character(ndecim(prcpar)+nxtr+novh  ) :: rslt
 
11454
  character(ndecim(prcpar)+nxtr+novh+1) :: cc
 
11455
  character(10) :: aa,bb
 
11456
  integer :: ndec
 
11457
  real(kindr2) :: xx     
 
11458
  xx = xx_in
 
11459
  if (present(ndec_in)) then ;ndec=ndec_in
 
11460
                        else ;ndec=ndecim(prcpar)+nxtr
 
11461
  endif
 
11462
  write(aa,'(i10)') min(len(cc),ndec+novh+1) ;aa=adjustl(aa)
 
11463
  write(bb,'(i10)') min(len(cc),ndec       ) ;bb=adjustl(bb)
 
11464
  aa = '(e'//trim(aa)//'.'//trim(bb)//')'
 
11465
  write(cc,aa) xx  ;cc=adjustl(cc)
 
11466
  if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:len(cc))
 
11467
  else                      ;rslt = ' '//cc(2:len(cc))
 
11468
  endif
 
11469
  end function
 
11470
 
 
11471
  function printi( ii ) result(rslt)
 
11472
  integer ,intent(in) :: ii
 
11473
  character(ndecim(prcpar)) :: rslt
 
11474
  character(ndecim(prcpar)) :: cc
 
11475
  character(10) :: aa
 
11476
  write(aa,'(i10)') ndecim(prcpar) ;aa=adjustl(aa)
 
11477
  aa = '(i'//trim(aa)//')'
 
11478
  write(cc,aa) ii ;cc=adjustl(cc)
 
11479
  if (cc(1:1).ne.'-') then ;rslt=' '//cc
 
11480
  else                     ;rslt=cc 
 
11481
  endif
 
11482
  end function
 
11483
 
 
11484
end module
 
11485
 
 
11486
 
 
11487
module avh_olo_qp_auxfun
 
11488
  use avh_olo_units
 
11489
  use avh_olo_qp_prec
 
11490
 
 
11491
  implicit none
 
11492
  private
 
11493
  public :: mysqrt,eta5,eta3,eta2,sgnIm,sgnRe,kallen
 
11494
  public :: solabc,rfun,rfun0,solabc_rcc
 
11495
 
 
11496
  interface mysqrt
 
11497
    module procedure mysqrt_c,mysqrt_cr,mysqrt_ci
 
11498
  end interface
 
11499
 
 
11500
  interface eta5
 
11501
    module procedure eta5_0
 
11502
  end interface
 
11503
  interface eta3
 
11504
    module procedure eta3_r,eta3_0
 
11505
  end interface
 
11506
  interface eta2
 
11507
    module procedure eta2_r,eta2_0
 
11508
  end interface
 
11509
 
 
11510
  interface sgnIm
 
11511
    module procedure sgnIm_c,sgnIm_ci
 
11512
  end interface
 
11513
  interface sgnRe
 
11514
    module procedure sgnRe_c,sgnRe_r,sgnRe_ri
 
11515
  end interface
 
11516
 
 
11517
contains
 
11518
 
 
11519
 
 
11520
  function mysqrt_c(xx) result(rslt)
 
11521
!*******************************************************************
 
11522
! Returns the square-root of xx .
 
11523
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
 
11524
! negative imaginary.
 
11525
!*******************************************************************
 
11526
  complex(kindr2) &   
 
11527
    ,intent(in) :: xx
 
11528
  complex(kindr2) &   
 
11529
    :: rslt ,zz
 
11530
  real(kindr2) &  
 
11531
    :: xim,xre
 
11532
  xim = aimag(xx)
 
11533
  if (xim.eq.RZRO) then
 
11534
    xre = areal(xx)
 
11535
    if (xre.ge.RZRO) then
 
11536
      zz = acmplx(sqrt(xre),0)
 
11537
    else
 
11538
      zz = acmplx(0,-sqrt(-xre))
 
11539
    endif
 
11540
  else
 
11541
    zz = sqrt(xx)
 
11542
  endif
 
11543
  rslt = zz
 
11544
  end function
 
11545
 
 
11546
  function mysqrt_cr(xx,sgn) result(rslt)
 
11547
!*******************************************************************
 
11548
! Returns the square-root of xx .
 
11549
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
 
11550
! imaginary and has the same sign as  sgn .
 
11551
!*******************************************************************
 
11552
  complex(kindr2) &   
 
11553
    ,intent(in) :: xx
 
11554
  real(kindr2) &  
 
11555
    ,intent(in) :: sgn
 
11556
  complex(kindr2) &   
 
11557
    :: rslt ,zz
 
11558
  real(kindr2) &  
 
11559
    :: xim,xre
 
11560
  xim = aimag(xx)
 
11561
  if (xim.eq.RZRO) then
 
11562
    xre = areal(xx)
 
11563
    if (xre.ge.RZRO) then
 
11564
      zz = acmplx(sqrt(xre),0)
 
11565
    else
 
11566
      zz = acmplx(0,sign(sqrt(-xre),sgn))
 
11567
    endif
 
11568
  else
 
11569
    zz = sqrt(xx)
 
11570
  endif
 
11571
  rslt = zz
 
11572
  end function
 
11573
 
 
11574
  function mysqrt_ci(xx,sgn) result(rslt)
 
11575
!*******************************************************************
 
11576
! Returns the square-root of xx .
 
11577
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
 
11578
! imaginary and has the same sign as  sgn .
 
11579
!*******************************************************************
 
11580
  complex(kindr2) &   
 
11581
          ,intent(in) :: xx
 
11582
  integer ,intent(in) :: sgn
 
11583
  complex(kindr2) &   
 
11584
    :: rslt ,zz
 
11585
  real(kindr2) &  
 
11586
    :: xim,xre,hh
 
11587
  xim = aimag(xx)
 
11588
  if (xim.eq.RZRO) then
 
11589
    xre = areal(xx)
 
11590
    if (xre.ge.RZRO) then
 
11591
      zz = acmplx(sqrt(xre),0)
 
11592
    else
 
11593
      hh = sgn
 
11594
      zz = acmplx(0,sign(sqrt(-xre),hh))
 
11595
    endif
 
11596
  else
 
11597
    zz = sqrt(xx)
 
11598
  endif
 
11599
  rslt = zz
 
11600
  end function
 
11601
 
 
11602
 
 
11603
  subroutine solabc( x1,x2 ,dd ,aa,bb,cc ,imode )
 
11604
!*******************************************************************
 
11605
! Returns the solutions  x1,x2  to the equation  aa*x^2+bb*x+cc=0
 
11606
! Also returns  dd = aa*(x1-x2)
 
11607
! If  imode=/=0  it uses  dd  as input as value of  sqrt(b^2-4*a*c)
 
11608
!*******************************************************************
 
11609
  complex(kindr2) &   
 
11610
    ,intent(out)   :: x1,x2
 
11611
  complex(kindr2) &   
 
11612
    ,intent(inout) :: dd
 
11613
  complex(kindr2) &   
 
11614
    ,intent(in) :: aa,bb,cc
 
11615
  integer         ,intent(in) :: imode
 
11616
  complex(kindr2) &   
 
11617
    :: qq,hh
 
11618
  real(kindr2) &  
 
11619
    :: r1,r2
 
11620
 
 
11621
  if (aa.eq.CZRO) then
 
11622
    if (bb.eq.CZRO) then
 
11623
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop solabc: ' &
 
11624
        ,'no solutions, returning 0'
 
11625
      x1 = 0
 
11626
      x2 = 0
 
11627
      dd = 0
 
11628
    else
 
11629
      x1 = -cc/bb
 
11630
      x2 = x1
 
11631
      dd = bb
 
11632
    endif
 
11633
  elseif (cc.eq.CZRO) then
 
11634
    dd = -bb
 
11635
    x1 = dd/aa
 
11636
    x2 = 0
 
11637
  else
 
11638
    if (imode.eq.0) dd = sqrt(bb*bb - 4*aa*cc)
 
11639
    qq = -bb+dd
 
11640
    hh = -bb-dd
 
11641
    r1 = abs(qq)
 
11642
    r2 = abs(hh)
 
11643
    if (r1.ge.r2) then
 
11644
      x1 = qq/(2*aa)
 
11645
      x2 = (2*cc)/qq
 
11646
    else
 
11647
      qq = hh
 
11648
      x2 = qq/(2*aa)
 
11649
      x1 = (2*cc)/qq
 
11650
    endif
 
11651
  endif
 
11652
  end subroutine
 
11653
 
 
11654
 
 
11655
  subroutine solabc_rcc( x1,x2 ,aa,bb,cc )
 
11656
!*******************************************************************
 
11657
! Tested
 
11658
!*******************************************************************
 
11659
  intent(out) :: x1,x2
 
11660
  intent(in ) :: aa,bb,cc
 
11661
  complex(kindr2) &   
 
11662
    :: x1,x2,bb,cc ,t1,t2
 
11663
  real(kindr2) &  
 
11664
    :: aa,xx,yy,pp,qq,uu,vv,pq1,pq2,uv1,uv2,dd,xd1,xd2,yd1,yd2 &
 
11665
      ,gg,hh,rx1,rx2,ix1,ix2
 
11666
  if (aa.eq.RZRO) then
 
11667
    if (bb.eq.CZRO) then
 
11668
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop solabc: ' &
 
11669
        ,'no solutions, returning 0'
 
11670
      x1 = 0
 
11671
      x2 = 0
 
11672
    else
 
11673
      x1 = -cc/bb
 
11674
      x2 = x1
 
11675
    endif
 
11676
  elseif (cc.eq.CZRO) then
 
11677
    x1 = -bb/aa
 
11678
    x2 = 0
 
11679
  else
 
11680
    t1 = cc/aa          ;xx= areal(t1) ;yy= aimag(t1)
 
11681
    t2 = bb/(aa*2)      ;pp=-areal(t2) ;uu=-aimag(t2)
 
11682
    t2 = sqrt(t2*t2-t1) ;qq= areal(t2) ;vv= aimag(t2)
 
11683
    pq1=pp+qq ;uv1=uu+vv
 
11684
    pq2=pp-qq ;uv2=uu-vv
 
11685
    dd=pq1*pq1+uv1*uv1 ;xd1=xx/dd ;yd1=yy/dd
 
11686
    dd=pq2*pq2+uv2*uv2 ;xd2=xx/dd ;yd2=yy/dd
 
11687
    if (abs(pq1).gt.abs(pq2)) then
 
11688
      rx1 = pq1
 
11689
      gg=xd1*pq1 ;hh=yd1*uv1
 
11690
      rx2 = gg+hh
 
11691
      if (abs(rx2).lt.neglig(prcpar)*max(abs(gg),abs(hh))) rx2 = 0
 
11692
    else
 
11693
      rx2 = pq2
 
11694
      gg=xd2*pq2 ;hh=yd2*uv2
 
11695
      rx1 = gg+hh
 
11696
      if (abs(rx1).lt.neglig(prcpar)*max(abs(gg),abs(hh))) rx1 = 0
 
11697
    endif
 
11698
    if (abs(uv1).gt.abs(uv2)) then
 
11699
      ix1 = uv1
 
11700
      gg=yd1*pq1 ;hh=xd1*uv1
 
11701
      ix2 = gg-hh
 
11702
      if (abs(ix2).lt.neglig(prcpar)*max(abs(gg),abs(hh))) ix2 = 0
 
11703
    else
 
11704
      ix2 = uv2
 
11705
      gg=yd2*pq2 ;hh=xd2*uv2
 
11706
      ix1 = gg-hh
 
11707
      if (abs(ix1).lt.neglig(prcpar)*max(abs(gg),abs(hh))) ix1 = 0
 
11708
    endif
 
11709
    x1 = acmplx(rx1,ix1)
 
11710
    x2 = acmplx(rx2,ix2)
 
11711
  endif
 
11712
  end subroutine
 
11713
 
 
11714
 
 
11715
  subroutine rfun(rr,dd ,qq)
 
11716
!*******************************************************************
 
11717
! Returns  rr  such that  qq = rr + 1/rr  and  Im(rr)  has the same
 
11718
! sign as  Im(qq) .
 
11719
! If  Im(qq)  is zero, then  Im(rr)  is negative or zero.
 
11720
! If  Im(rr)  is zero, then  |rr| > 1/|rr| .
 
11721
! Also returns  dd = rr - 1/rr .
 
11722
!*******************************************************************
 
11723
  complex(kindr2) &   
 
11724
    ,intent(out) :: rr,dd
 
11725
  complex(kindr2) &   
 
11726
    ,intent(in)  :: qq
 
11727
  complex(kindr2) &   
 
11728
    :: r2
 
11729
  real(kindr2) &  
 
11730
    :: aa,bb
 
11731
  integer :: ir,ik
 
11732
  dd = sqrt(qq*qq-4)
 
11733
  rr = qq+dd
 
11734
  r2 = qq-dd
 
11735
  aa = abs(rr)
 
11736
  bb = abs(r2)
 
11737
  if (bb.gt.aa) then
 
11738
    rr = r2
 
11739
    dd = -dd
 
11740
  endif
 
11741
  aa = aimag(qq)
 
11742
  bb = aimag(rr)
 
11743
  if (aa.eq.RZRO) then
 
11744
    if (bb.le.RZRO) then
 
11745
      rr = rr/2
 
11746
    else
 
11747
      rr = 2/rr
 
11748
      dd = -dd
 
11749
    endif
 
11750
  else
 
11751
    ik = sgnRe(aa)
 
11752
    ir = sgnRe(bb)
 
11753
    if (ir.eq.ik) then
 
11754
      rr = rr/2
 
11755
    else
 
11756
      rr = 2/rr
 
11757
      dd = -dd
 
11758
    endif
 
11759
  endif
 
11760
  end subroutine
 
11761
 
 
11762
  subroutine rfun0(rr ,dd,qq)
 
11763
!*******************************************************************
 
11764
! Like rfun, but now  dd  is input, which may get a minus sign
 
11765
!*******************************************************************
 
11766
  complex(kindr2) &   
 
11767
    ,intent(out)   :: rr
 
11768
  complex(kindr2) &   
 
11769
    ,intent(inout) :: dd
 
11770
  complex(kindr2) &   
 
11771
    ,intent(in)  :: qq
 
11772
  complex(kindr2) &   
 
11773
    :: r2
 
11774
  real(kindr2) &  
 
11775
    :: aa,bb
 
11776
  integer :: ir,ik
 
11777
  rr = qq+dd
 
11778
  r2 = qq-dd
 
11779
  aa = abs(rr)
 
11780
  bb = abs(r2)
 
11781
  if (bb.gt.aa) then
 
11782
    rr = r2
 
11783
    dd = -dd
 
11784
  endif
 
11785
  aa = aimag(qq)
 
11786
  bb = aimag(rr)
 
11787
  if (aa.eq.RZRO) then
 
11788
    if (bb.le.RZRO) then
 
11789
      rr = rr/2
 
11790
    else
 
11791
      rr = 2/rr
 
11792
      dd = -dd
 
11793
    endif
 
11794
  else
 
11795
    ik = sgnRe(aa)
 
11796
    ir = sgnRe(bb)
 
11797
    if (ir.eq.ik) then
 
11798
      rr = rr/2
 
11799
    else
 
11800
      rr = 2/rr
 
11801
      dd = -dd
 
11802
    endif
 
11803
  endif
 
11804
  end subroutine
 
11805
 
 
11806
 
 
11807
  function eta3_r( aa,sa ,bb,sb ,cc,sc ) result(rslt)
 
11808
!*******************************************************************
 
11809
! 2*pi*imag times the result of
 
11810
!     theta(-Im(a))*theta(-Im(b))*theta( Im(c))
 
11811
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
 
11812
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
 
11813
!*******************************************************************
 
11814
  complex(kindr2) &   
 
11815
    ,intent(in) :: aa,bb,cc
 
11816
  real(kindr2) &  
 
11817
    ,intent(in) :: sa,sb,sc
 
11818
  complex(kindr2) &   
 
11819
    :: rslt
 
11820
  real(kindr2) &  
 
11821
    :: ima,imb,imc
 
11822
  ima = aimag(aa)
 
11823
  imb = aimag(bb)
 
11824
  imc = aimag(cc)
 
11825
  if (ima.eq.RZRO) ima = sa
 
11826
  if (imb.eq.RZRO) imb = sb
 
11827
  if (imc.eq.RZRO) imc = sc
 
11828
  ima = sgnRe(ima)
 
11829
  imb = sgnRe(imb)
 
11830
  imc = sgnRe(imc)
 
11831
  if (ima.eq.imb.and.ima.ne.imc) then
 
11832
    rslt = acmplx(0,imc*TWOPI)
 
11833
  else
 
11834
    rslt = 0
 
11835
  endif
 
11836
  end function
 
11837
 
 
11838
  function eta3_0( aa ,bb ,cc ) result(rslt)
 
11839
!*******************************************************************
 
11840
! 2*pi*imag times the result of
 
11841
!     theta(-Im(a))*theta(-Im(b))*theta( Im(c))
 
11842
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
 
11843
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
 
11844
!*******************************************************************
 
11845
  complex(kindr2) &   
 
11846
    ,intent(in) :: aa,bb,cc
 
11847
  complex(kindr2) &   
 
11848
    :: rslt
 
11849
  real(kindr2) &  
 
11850
    :: ima,imb,imc
 
11851
  ima = sgnIm(aa)
 
11852
  imb = sgnIm(bb)
 
11853
  imc = sgnIm(cc)
 
11854
  if (ima.eq.imb.and.ima.ne.imc) then
 
11855
    rslt = acmplx(0,imc*TWOPI)
 
11856
  else
 
11857
    rslt = 0
 
11858
  endif
 
11859
  end function
 
11860
 
 
11861
  function eta5_0( aa ,b1,c1 ,b2,c2 ) result(rslt)
 
11862
!*******************************************************************
 
11863
! eta3(aa,b1,c1) - eta3(aa,b2,c2)
 
11864
!*******************************************************************
 
11865
  complex(kindr2) &   
 
11866
    ,intent(in) :: aa,b1,c1 ,b2,c2
 
11867
  complex(kindr2) &   
 
11868
    :: rslt
 
11869
  real(kindr2) &  
 
11870
    :: imaa,imb1,imc1,imb2,imc2
 
11871
  imaa = sgnIm(aa)
 
11872
  imb1 = sgnIm(b1)
 
11873
  imb2 = sgnIm(b2)
 
11874
  imc1 = sgnIm(c1)
 
11875
  imc2 = sgnIm(c2)
 
11876
  if (imaa.eq.imb1) then
 
11877
    if (imaa.eq.imb2) then
 
11878
      if (imc1.eq.imc2) then
 
11879
        rslt = 0
 
11880
      elseif (imaa.ne.imc1) then
 
11881
        rslt = acmplx(0, imc1*TWOPI)
 
11882
      else
 
11883
        rslt = acmplx(0,-imc2*TWOPI)
 
11884
      endif
 
11885
    elseif (imaa.ne.imc1) then
 
11886
      rslt = acmplx(0, imc1*TWOPI)
 
11887
    else
 
11888
      rslt = 0
 
11889
    endif
 
11890
  elseif (imaa.eq.imb2.and.imaa.ne.imc2) then
 
11891
    rslt = acmplx(0,-imc2*TWOPI)
 
11892
  else
 
11893
    rslt = 0
 
11894
  endif
 
11895
  end function
 
11896
 
 
11897
  function eta2_r( aa,sa ,bb,sb ) result(rslt)
 
11898
!*******************************************************************
 
11899
! The same as  eta3, but with  c=a*b, so that
 
11900
!   eta(a,b) = log(a*b) - log(a) - log(b)
 
11901
!*******************************************************************
 
11902
  complex(kindr2) &   
 
11903
    ,intent(in) :: aa,bb
 
11904
  real(kindr2) &  
 
11905
    ,intent(in) :: sa,sb
 
11906
  complex(kindr2) &   
 
11907
    :: rslt
 
11908
  real(kindr2) &  
 
11909
    :: rea,reb,ima,imb,imab
 
11910
  rea = areal(aa)  ;ima = aimag(aa)
 
11911
  reb = areal(bb)  ;imb = aimag(bb)
 
11912
  imab = rea*imb + reb*ima
 
11913
  if (ima .eq.RZRO) ima = sa
 
11914
  if (imb .eq.RZRO) imb = sb
 
11915
  if (imab.eq.RZRO) imab = sign(rea,sb) + sign(reb,sa)
 
11916
  ima  = sgnRe(ima)
 
11917
  imb  = sgnRe(imb)
 
11918
  imab = sgnRe(imab)
 
11919
  if (ima.eq.imb.and.ima.ne.imab) then
 
11920
    rslt = acmplx(0,imab*TWOPI)
 
11921
  else
 
11922
    rslt = 0
 
11923
  endif
 
11924
  end function
 
11925
 
 
11926
  function eta2_0( aa ,bb ) result(rslt)
 
11927
!*******************************************************************
 
11928
!*******************************************************************
 
11929
  complex(kindr2) &   
 
11930
    ,intent(in) :: aa,bb
 
11931
  complex(kindr2) &   
 
11932
    :: rslt
 
11933
  real(kindr2) &  
 
11934
    :: rea,reb,ima,imb,imab
 
11935
  rea = areal(aa)  ;ima = aimag(aa)
 
11936
  reb = areal(bb)  ;imb = aimag(bb)
 
11937
  rea = rea*imb
 
11938
  reb = reb*ima
 
11939
  imab = rea+reb
 
11940
  ima  = sgnRe(ima)
 
11941
  imb  = sgnRe(imb)
 
11942
  imab = sgnRe(imab)
 
11943
  if (ima.eq.imb.and.ima.ne.imab) then
 
11944
    rslt = acmplx(0,imab*TWOPI)
 
11945
  else
 
11946
    rslt = 0
 
11947
  endif
 
11948
  end function 
 
11949
 
 
11950
 
 
11951
  function kallen( p1,p2,p3 ) result(rslt)
 
11952
!*******************************************************************
 
11953
!  p1^2 + p2^2 + p3^2 - 2*p1*p2 - 2*p2*p3 - 2*p3*p1
 
11954
!*******************************************************************
 
11955
  complex(kindr2) &   
 
11956
    ,intent(in) :: p1,p2,p3
 
11957
  complex(kindr2) &   
 
11958
    :: rslt ,y1,y2,y3
 
11959
  real(kindr2) &  
 
11960
    :: b1,b2,b3
 
11961
  y1=p2*p3 ;b1=areal(y1)
 
11962
  y2=p3*p1 ;b2=areal(y2)
 
11963
  y3=p1*p2 ;b3=areal(y3)
 
11964
      if (b1.le.RZRO) then  ;rslt = (p1-p2-p3)**2 - 4*y1
 
11965
  elseif (b2.le.RZRO) then  ;rslt = (p2-p3-p1)**2 - 4*y2
 
11966
  elseif (b3.le.RZRO) then  ;rslt = (p3-p1-p2)**2 - 4*y3
 
11967
  elseif (b1.le.b2.and.b1.le.b3) then  ;rslt = (p1-p2-p3)**2 - 4*y1
 
11968
  elseif (b2.le.b3.and.b2.le.b1) then  ;rslt = (p2-p3-p1)**2 - 4*y2
 
11969
                                 else  ;rslt = (p3-p1-p2)**2 - 4*y3
 
11970
  endif
 
11971
  end function
 
11972
 
 
11973
 
 
11974
  function sgnIm_c(zz) result(rslt)
 
11975
!*******************************************************************
 
11976
!*******************************************************************
 
11977
  complex(kindr2) &   
 
11978
    ,intent(in) :: zz
 
11979
  integer :: rslt
 
11980
  real(kindr2) &  
 
11981
    :: imz
 
11982
  imz = aimag(zz)
 
11983
  if (imz.ge.RZRO) then ;rslt= 1
 
11984
                   else ;rslt=-1
 
11985
  endif
 
11986
  end function
 
11987
 
 
11988
  function sgnIm_ci(zz,ii) result(rslt)
 
11989
!*******************************************************************
 
11990
!*******************************************************************
 
11991
  complex(kindr2) &   
 
11992
          ,intent(in) :: zz
 
11993
  integer ,intent(in) :: ii
 
11994
  integer :: rslt
 
11995
  real(kindr2) &  
 
11996
    :: imz
 
11997
  imz = aimag(zz)
 
11998
  if     (imz.gt.RZRO) then ;rslt= 1
 
11999
  elseif (imz.lt.RZRO) then ;rslt=-1
 
12000
                       else ;rslt= sign(1,ii)
 
12001
  endif
 
12002
  end function
 
12003
 
 
12004
  function sgnRe_c(zz) result(rslt)
 
12005
!*******************************************************************
 
12006
!*******************************************************************
 
12007
  complex(kindr2) &   
 
12008
    ,intent(in) :: zz
 
12009
  integer :: rslt
 
12010
  real(kindr2) &  
 
12011
    :: rez
 
12012
  rez = zz
 
12013
  if (rez.ge.RZRO) then ;rslt= 1
 
12014
                   else ;rslt=-1
 
12015
  endif
 
12016
  end function
 
12017
 
 
12018
  function sgnRe_r(rez) result(rslt)
 
12019
!*******************************************************************
 
12020
!*******************************************************************
 
12021
  real(kindr2) &  
 
12022
    ,intent(in) :: rez
 
12023
  integer :: rslt
 
12024
  if (rez.ge.RZRO) then ;rslt= 1
 
12025
                   else ;rslt=-1
 
12026
  endif
 
12027
  end function
 
12028
 
 
12029
  function sgnRe_ri(rez,ii) result(rslt)
 
12030
!*******************************************************************
 
12031
!*******************************************************************
 
12032
  real(kindr2) &  
 
12033
          ,intent(in) :: rez
 
12034
  integer ,intent(in) :: ii
 
12035
  integer :: rslt
 
12036
  if     (rez.gt.RZRO) then ;rslt= 1
 
12037
  elseif (rez.lt.RZRO) then ;rslt=-1
 
12038
                       else ;rslt=sign(1,ii)
 
12039
  endif
 
12040
  end function
 
12041
 
 
12042
end module
 
12043
 
 
12044
 
 
12045
module avh_olo_qp_olog
 
12046
!***********************************************************************
 
12047
! Provides the functions
 
12048
!   olog(x,n) = log(x) + n*pi*imag  
 
12049
!   olog2(x,n) = olog(x,n)/(x-1)
 
12050
! In the vicinity of x=1,n=0, the logarithm of complex argument is
 
12051
! evaluated with a series expansion.
 
12052
!***********************************************************************
 
12053
  use avh_olo_units
 
12054
  use avh_olo_qp_prec
 
12055
  use avh_olo_qp_print
 
12056
  use avh_olo_qp_auxfun
 
12057
  implicit none
 
12058
  private
 
12059
  public :: update_olog,olog,olog2
 
12060
 
 
12061
  real(kindr2) &  
 
12062
         ,allocatable,save :: thrs(:,:)
 
12063
  integer,allocatable,save :: ntrm(:,:)
 
12064
  integer,parameter :: nStp=6
 
12065
 
 
12066
  interface olog
 
12067
    module procedure log_c,log_r
 
12068
  end interface
 
12069
  interface olog2
 
12070
    module procedure log2_c,log2_r
 
12071
  end interface
 
12072
 
 
12073
contains
 
12074
 
 
12075
  subroutine update_olog
 
12076
!***********************************************************************
 
12077
!***********************************************************************
 
12078
  use avh_olo_qp_arrays
 
12079
  real(kindr2) &  
 
12080
    :: tt
 
12081
  integer :: nn,mm,ii,jj
 
12082
!  real(kind(1d0)) :: xx(6) !DEBUG
 
12083
  if (allocated(thrs)) then
 
12084
    call shift2( thrs ,prcpar )
 
12085
    call shift2( ntrm ,prcpar )
 
12086
  else
 
12087
    allocate(thrs(1:nStp,1:1))
 
12088
    allocate(ntrm(1:nStp,1:1))
 
12089
    if (prcpar.ne.1) then
 
12090
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop update_olog'
 
12091
      stop
 
12092
    endif
 
12093
  endif
 
12094
  if (prcpar.gt.1) then ;nn=ntrm(nStp,prcpar-1)-1
 
12095
                   else ;nn=1
 
12096
  endif
 
12097
  do
 
12098
    nn = nn+1
 
12099
    mm = 2*nn-1
 
12100
    tt = 1
 
12101
    tt = (EPSN*mm)**(tt/(mm-1))
 
12102
    tt = 2*tt/(1-tt)
 
12103
! expansion from x=1+d with |d|=1/1000
 
12104
    if (1000*tt.gt.RONE) exit
 
12105
  enddo
 
12106
  ntrm(nStp,prcpar) = nn
 
12107
  thrs(nStp,prcpar) = tt
 
12108
  nn = max(1,nint(nn*1d0/nStp))
 
12109
  do ii=nStp-1,1,-1
 
12110
    ntrm(ii,prcpar) = ntrm(ii+1,prcpar)-nn
 
12111
    if (ntrm(ii,prcpar).le.1) then
 
12112
      do jj=1,ii
 
12113
        ntrm(jj,prcpar) = ntrm(ii,prcpar)
 
12114
        thrs(jj,prcpar) = 0 
 
12115
      enddo
 
12116
      exit
 
12117
    endif
 
12118
    mm = 2*ntrm(ii,prcpar)-1
 
12119
    tt = 1
 
12120
    tt = (EPSN*mm)**(tt/(mm-1))
 
12121
    thrs(ii,prcpar) = 2*tt/(1-tt)
 
12122
  enddo
 
12123
!  do ii=lbound(thrs,2),ubound(thrs,2) !DEBUG
 
12124
!    do jj=1,nStp                      !DEBUG
 
12125
!      xx(jj) = thrs(jj,ii)            !DEBUG
 
12126
!    enddo                             !DEBUG
 
12127
!    write(*,'(99e10.3)') xx(:)        !DEBUG
 
12128
!    write(*,'(99i10)'  ) ntrm(:,ii)   !DEBUG
 
12129
!  enddo                               !DEBUG
 
12130
  end subroutine
 
12131
 
 
12132
 
 
12133
  function log_c(xx,iph) result(rslt)
 
12134
!***********************************************************************
 
12135
!***********************************************************************
 
12136
  complex(kindr2) &   
 
12137
          ,intent(in) :: xx
 
12138
  integer ,intent(in) :: iph
 
12139
  complex(kindr2) &   
 
12140
    :: rslt ,yy,zz,z2
 
12141
  real(kindr2) &  
 
12142
    :: aa,rex,imx
 
12143
  integer :: nn,ii,iyy
 
12144
!
 
12145
  rex = areal(xx)
 
12146
  imx = aimag(xx)
 
12147
  iyy = iph
 
12148
!
 
12149
  if (abs(imx).le.EPSN*abs(rex)) then
 
12150
    if (rex.ge.RZRO) then
 
12151
      rslt = log_r( rex, iyy )
 
12152
    else
 
12153
      rslt = log_r(-rex, iyy+sgnRe(imx) )
 
12154
    endif
 
12155
    return
 
12156
  endif
 
12157
!
 
12158
  if (mod(iyy,2).eq.0) then
 
12159
    yy = acmplx(rex,imx)
 
12160
  else
 
12161
    yy = acmplx(-rex,-imx)
 
12162
    iyy = iyy+sgnRe(imx)
 
12163
  endif
 
12164
!
 
12165
  if (iyy.ne.0) then
 
12166
    rslt = log(yy) + IPI*iyy
 
12167
    return
 
12168
  endif
 
12169
!
 
12170
  zz = yy-1
 
12171
  aa = abs(zz)
 
12172
  if     (aa.ge.thrs(6,prcpar)) then
 
12173
    rslt = log(yy)
 
12174
    return
 
12175
  elseif (aa.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12176
  elseif (aa.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12177
  elseif (aa.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12178
  elseif (aa.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12179
  elseif (aa.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12180
                                else ;nn=ntrm(1,prcpar)
 
12181
  endif
 
12182
  zz = zz/(yy+1)
 
12183
  z2 = zz*zz
 
12184
  aa = 2
 
12185
  nn = 2*nn-1
 
12186
  rslt = aa/nn
 
12187
  do ii=nn-2,1,-2
 
12188
    rslt = aa/ii + z2*rslt
 
12189
  enddo
 
12190
  rslt = zz*rslt
 
12191
  end function
 
12192
 
 
12193
 
 
12194
  function log_r(xx,iph) result(rslt)
 
12195
!***********************************************************************
 
12196
!***********************************************************************
 
12197
  real(kindr2) &  
 
12198
          ,intent(in) :: xx
 
12199
  integer ,intent(in) :: iph
 
12200
  complex(kindr2) &   
 
12201
    :: rslt
 
12202
  real(kindr2) &  
 
12203
    :: rr
 
12204
  integer :: jj
 
12205
!
 
12206
  if (xx.eq.RZRO) then
 
12207
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop log_r: ' &
 
12208
       ,'xx =',trim(myprint(xx)),', returning 0'
 
12209
    rslt = 0
 
12210
    return
 
12211
  elseif (xx.gt.RZRO) then ;rr= xx ;jj= iph
 
12212
                      else ;rr=-xx ;jj= iph+1 ! log(-1)=i*pi
 
12213
  endif
 
12214
!
 
12215
  rslt = log(rr) + IPI*jj
 
12216
  end function
 
12217
 
 
12218
 
 
12219
  function log2_c(xx,iph) result(rslt)
 
12220
!***********************************************************************
 
12221
!***********************************************************************
 
12222
  complex(kindr2) &   
 
12223
          ,intent(in) :: xx
 
12224
  integer ,intent(in) :: iph
 
12225
  complex(kindr2) &   
 
12226
    :: rslt ,yy,zz,z2
 
12227
  real(kindr2) &  
 
12228
    :: aa,rex,imx
 
12229
  integer :: nn,ii,jj
 
12230
!
 
12231
  rex = areal(xx)
 
12232
  imx = aimag(xx)
 
12233
!
 
12234
  if (abs(imx).le.EPSN*abs(rex)) then
 
12235
    if (rex.ge.RZRO) then
 
12236
      rslt = log2_r( rex, iph )
 
12237
    else
 
12238
      rslt = log2_r(-rex, iph+sgnRe(imx) )
 
12239
    endif
 
12240
    return
 
12241
  endif
 
12242
!
 
12243
  if (mod(iph,2).eq.0) then ;yy= xx ;jj=iph
 
12244
                       else ;yy=-xx ;jj=iph+sgnRe(imx)
 
12245
  endif
 
12246
!
 
12247
  if (jj.ne.0) then
 
12248
    rslt = ( log(yy) + IPI*jj )/(yy-1)
 
12249
    return
 
12250
  endif
 
12251
!
 
12252
  zz = yy-1
 
12253
  aa = abs(zz)
 
12254
  if     (aa.ge.thrs(6,prcpar)) then
 
12255
    rslt = log(yy)/zz
 
12256
    return
 
12257
  elseif (aa.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12258
  elseif (aa.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12259
  elseif (aa.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12260
  elseif (aa.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12261
  elseif (aa.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12262
                                else ;nn=ntrm(1,prcpar)
 
12263
  endif
 
12264
  zz = zz/(yy+1)
 
12265
  z2 = zz*zz
 
12266
  aa = 2
 
12267
  nn = 2*nn-1
 
12268
  rslt = aa/nn
 
12269
  do ii=nn-2,1,-2
 
12270
    rslt = aa/ii + z2*rslt
 
12271
  enddo
 
12272
  rslt = rslt/(yy+1)
 
12273
  end function
 
12274
 
 
12275
 
 
12276
  function log2_r(xx,iph) result(rslt)
 
12277
!***********************************************************************
 
12278
!***********************************************************************
 
12279
  real(kindr2) &  
 
12280
          ,intent(in) :: xx
 
12281
  integer ,intent(in) :: iph
 
12282
  complex(kindr2) &   
 
12283
    :: rslt
 
12284
  real(kindr2) &  
 
12285
    :: rr,yy
 
12286
  integer :: jj
 
12287
!  include 'avh_olo_qp_real.h90'
 
12288
!    :: aa,zz,z2
 
12289
!  integer :: nn,ii
 
12290
!
 
12291
  if (xx.eq.RZRO) then
 
12292
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop log2_r: ' &
 
12293
       ,'xx =',trim(myprint(xx)),', returning 0'
 
12294
    rslt = 0
 
12295
    return
 
12296
  elseif (xx.gt.RZRO) then ;rr= xx ;jj=iph
 
12297
                      else ;rr=-xx ;jj=iph+1 ! log(-1)=i*pi
 
12298
  endif
 
12299
!
 
12300
  yy=rr ;if (mod(jj,2).ne.0) yy=-rr
 
12301
!
 
12302
  if (abs(yy-1).le.10*EPSN) then
 
12303
    if (jj.ne.0) then
 
12304
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop log2_r: ' &
 
12305
        ,'rr,jj =',trim(myprint(rr)),jj,', putting jj to 0'
 
12306
    endif
 
12307
    rslt = 1 - (yy-1)/2
 
12308
    return
 
12309
  endif
 
12310
!
 
12311
  rslt = ( log(rr) + IPI*jj )/(yy-1)
 
12312
  end function
 
12313
 
 
12314
end module
 
12315
 
 
12316
 
 
12317
module avh_olo_qp_dilog
 
12318
!***********************************************************************
 
12319
!                     /1    ln(1-zz*t)
 
12320
!   dilog(xx,iph) = - |  dt ---------- 
 
12321
!                     /0        t
 
12322
! with  zz = 1 - xx*exp(imag*pi*iph)  [pi, NOT 2*pi]
 
12323
!
 
12324
!   dilog(x1,i1,x2,i2) = ( dilog(x1,i1)-dilog(x2,i2) )/( x1-x2 )
 
12325
!
 
12326
! Arguments xx,x1,x2, may be all real or all complex,
 
12327
! arguments iph,i1,i2 must be all integer.
 
12328
!***********************************************************************
 
12329
  use avh_olo_units
 
12330
  use avh_olo_qp_prec
 
12331
  use avh_olo_qp_print
 
12332
  use avh_olo_qp_auxfun
 
12333
  use avh_olo_qp_arrays
 
12334
  implicit none
 
12335
  private
 
12336
  public :: update_dilog,dilog
 
12337
 
 
12338
  real(kindr2) &  
 
12339
         ,allocatable,save :: coeff(:)
 
12340
  real(kindr2) &  
 
12341
         ,allocatable,save :: thrs(:,:)
 
12342
  integer,allocatable,save :: ntrm(:,:)
 
12343
  integer,parameter :: nStp=6
 
12344
 
 
12345
  real(kindr2) &  
 
12346
         ,allocatable :: bern(:),fact(:)
 
12347
 
 
12348
  interface dilog
 
12349
    module procedure dilog_c,dilog_r,dilog2_c,dilog2_r
 
12350
  end interface
 
12351
 
 
12352
contains
 
12353
 
 
12354
  subroutine update_dilog
 
12355
!***********************************************************************
 
12356
!***********************************************************************
 
12357
  real(kindr2) &  
 
12358
    :: tt
 
12359
  integer :: nn,ii,jj
 
12360
  logical :: highestSoFar
 
12361
!  real(kind(1d0)) :: xx(6) !DEBUG
 
12362
!
 
12363
  if (allocated(thrs)) then
 
12364
    call shift2( thrs ,prcpar )
 
12365
    call shift2( ntrm ,prcpar )
 
12366
  else
 
12367
    allocate(thrs(1:nStp,1:1))
 
12368
    allocate(ntrm(1:nStp,1:1))
 
12369
    if (prcpar.ne.1) then
 
12370
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop update_dilog'
 
12371
      stop
 
12372
    endif
 
12373
  endif
 
12374
!
 
12375
  highestSoFar = prcpar.eq.ubound(ntrm,2)
 
12376
  if (highestSoFar) then
 
12377
    if (allocated(coeff)) deallocate(coeff)
 
12378
    allocate(coeff(0:-1)) ! allocate at size=0
 
12379
  endif
 
12380
!
 
12381
  if (prcpar.gt.1) then ;nn=ntrm(nStp,prcpar-1)-1
 
12382
                   else ;nn=2
 
12383
  endif
 
12384
!
 
12385
  do
 
12386
    nn = nn+1
 
12387
    if (nn.gt.ubound(coeff,1)) call update_coeff( 2*nn )
 
12388
    tt = 1
 
12389
    tt = (EPSN/abs(coeff(nn)))**(tt/(2*nn))
 
12390
! expansion parameter is smaller than 1.05
 
12391
    if (100*tt.gt.105*RONE) exit
 
12392
  enddo
 
12393
!
 
12394
  if (highestSoFar) call resize( coeff ,0,nn )
 
12395
!
 
12396
  ntrm(nStp,prcpar) = nn
 
12397
  thrs(nStp,prcpar) = tt
 
12398
  nn = max(1,nint(nn*1d0/nStp))
 
12399
  do ii=nStp-1,1,-1
 
12400
    ntrm(ii,prcpar) = ntrm(ii+1,prcpar)-nn
 
12401
    if (ntrm(ii,prcpar).le.2) then
 
12402
      do jj=1,ii
 
12403
        ntrm(jj,prcpar) = max(2,ntrm(ii,prcpar))
 
12404
        thrs(jj,prcpar) = 0 
 
12405
      enddo
 
12406
      exit
 
12407
    endif
 
12408
    jj = ntrm(ii,prcpar)
 
12409
    tt = 1
 
12410
    tt = (EPSN/abs(coeff(jj)))**(tt/(2*jj))
 
12411
    thrs(ii,prcpar) = tt
 
12412
  enddo
 
12413
!
 
12414
  if (allocated(bern)) deallocate(bern)
 
12415
  if (allocated(fact)) deallocate(fact)
 
12416
!
 
12417
!  do ii=lbound(thrs,2),ubound(thrs,2) !DEBUG
 
12418
!    do jj=1,nStp                      !DEBUG
 
12419
!      xx(jj) = thrs(jj,ii)            !DEBUG
 
12420
!    enddo                             !DEBUG
 
12421
!    write(*,'(99e10.3)') xx(:)        !DEBUG
 
12422
!    write(*,'(99i10)'  ) ntrm(:,ii)   !DEBUG
 
12423
!  enddo                               !DEBUG
 
12424
  end subroutine
 
12425
 
 
12426
 
 
12427
  subroutine update_coeff( ncf )
 
12428
!*******************************************************************
 
12429
!   coeff(0)=-1/4
 
12430
!   coeff(n)=bern(2*n)/(2*n+1)
 
12431
!    bern(n)=bernoulli(n)/n!
 
12432
!    fact(n)=n!
 
12433
! DO NOT SKIP THE ODD bern IN THE RECURSIVE LOOP
 
12434
! DO NOT PUT THE ODD bern TO ZERO
 
12435
!*******************************************************************
 
12436
  integer ,intent(in) :: ncf
 
12437
  integer :: ii,jj,nbern,nold
 
12438
!
 
12439
  if (allocated(bern)) then ;nold=ubound(bern,1)
 
12440
                       else ;nold=0
 
12441
  endif
 
12442
!
 
12443
  nbern = 2*ncf
 
12444
!
 
12445
  call enlarge( bern  ,1,nbern   )
 
12446
  call enlarge( fact  ,0,nbern+1 )
 
12447
  call enlarge( coeff ,0,ncf     )
 
12448
!
 
12449
  fact(0) = 1
 
12450
  do ii=nold+1,nbern+1
 
12451
    fact(ii) = fact(ii-1)*ii
 
12452
  enddo
 
12453
!
 
12454
  do ii=nold+1,nbern
 
12455
    bern(ii) = -1/fact(ii+1)
 
12456
    do jj=1,ii-1
 
12457
      bern(ii) = bern(ii) - bern(jj)/fact(ii+1-jj)
 
12458
    enddo
 
12459
  enddo
 
12460
!
 
12461
  coeff(0) = 1
 
12462
  coeff(0) =-coeff(0)/4
 
12463
  do ii=nold+2,nbern,2
 
12464
    coeff(ii/2) = bern(ii)/(ii+1)
 
12465
  enddo
 
12466
!
 
12467
  end subroutine
 
12468
 
 
12469
 
 
12470
  function dilog_c(xx,iph) result(rslt)
 
12471
!*******************************************************************
 
12472
!*******************************************************************
 
12473
  complex(kindr2) &   
 
12474
          ,intent(in) :: xx
 
12475
  integer ,intent(in) :: iph
 
12476
  complex(kindr2) &   
 
12477
    :: rslt ,yy,lyy,loy,zz,z2
 
12478
  real(kindr2) &  
 
12479
    :: rex,imx,az
 
12480
  integer :: ii,jj,ntwo,odd,nn
 
12481
  logical :: r_gt_1 , y_lt_h
 
12482
!
 
12483
  rex = areal(xx)
 
12484
  imx = aimag(xx)
 
12485
!
 
12486
  if (abs(imx).le.EPSN*abs(rex)) then
 
12487
    if (rex.ge.RZRO) then
 
12488
      rslt = dilog_r( rex, iph )
 
12489
    else
 
12490
      rslt = dilog_r(-rex, iph+sgnRe(imx) )
 
12491
    endif
 
12492
    return
 
12493
  endif
 
12494
!
 
12495
  if (rex.gt.RZRO) then ;yy= xx ;jj=iph
 
12496
                   else ;yy=-xx ;jj=iph+sgnRe(imx)
 
12497
  endif
 
12498
!
 
12499
  odd = mod(jj,2)
 
12500
  ntwo = jj-odd
 
12501
! 
 
12502
  r_gt_1 = (rex*rex+imx*imx.gt.RONE)
 
12503
  lyy = log(yy)
 
12504
  if (odd.ne.0) yy = -yy
 
12505
!
 
12506
  if (r_gt_1) then
 
12507
    yy   = 1/yy
 
12508
    lyy  =-lyy
 
12509
    ntwo =-ntwo
 
12510
    odd  =-odd
 
12511
  endif
 
12512
  loy = log(1-yy)
 
12513
!
 
12514
  y_lt_h = (2*areal(yy).lt.RONE)
 
12515
  if (y_lt_h) then ;zz=-loy
 
12516
              else ;zz=-lyy
 
12517
  endif
 
12518
!
 
12519
  az = abs(zz)
 
12520
! if (az.gt.thrs(6,prcpar)) ERROR az to big 
 
12521
  if     (az.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12522
  elseif (az.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12523
  elseif (az.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12524
  elseif (az.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12525
  elseif (az.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12526
                                else ;nn=ntrm(1,prcpar)
 
12527
  endif
 
12528
  z2 = zz*zz
 
12529
  rslt = coeff(nn)
 
12530
  do ii=nn,2,-1
 
12531
    rslt = coeff(ii-1) + z2*rslt
 
12532
  enddo
 
12533
  rslt = zz*( 1 + zz*( coeff(0) + zz*rslt ) )
 
12534
!
 
12535
  if (y_lt_h) then
 
12536
    rslt = 4*PISQo24 - rslt - loy*(lyy+IPI*(ntwo+odd))
 
12537
  else
 
12538
    rslt = rslt - loy*IPI*ntwo
 
12539
  endif
 
12540
!
 
12541
  if (r_gt_1) rslt = -rslt - (lyy+IPI*(ntwo+odd))**2/2
 
12542
  end function
 
12543
 
 
12544
 
 
12545
 
 
12546
  function dilog_r(xx,iph) result(rslt)
 
12547
!*******************************************************************
 
12548
!*******************************************************************
 
12549
  real(kindr2) &  
 
12550
          ,intent(in) :: xx
 
12551
  integer ,intent(in) :: iph
 
12552
  complex(kindr2) &   
 
12553
    :: rslt
 
12554
  real(kindr2) &  
 
12555
    :: yy,lyy,loy,zz,z2,liox,az
 
12556
  integer :: jj,ii,ntwo,odd,nn
 
12557
  logical :: r_gt_1 , y_lt_h
 
12558
!
 
12559
  if (xx.eq.RZRO) then
 
12560
    rslt = 4*PISQo24
 
12561
    return
 
12562
  elseif (xx.gt.RZRO) then ;yy= xx ;jj=iph
 
12563
                      else ;yy=-xx ;jj=iph+1 ! log(-1)=i*pi
 
12564
  endif
 
12565
!
 
12566
  odd = mod(jj,2)
 
12567
  ntwo = jj-odd
 
12568
! 
 
12569
  if (yy.eq.RONE.and.odd.eq.0) then
 
12570
    if (ntwo.ne.0) then
 
12571
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog_r: ' &
 
12572
        ,'|x|,iph = ',trim(myprint(yy)),',',jj,', returning 0'
 
12573
    endif
 
12574
    rslt = 0
 
12575
    return
 
12576
  endif
 
12577
!
 
12578
  r_gt_1 = (yy.gt.RONE)
 
12579
  lyy = log(yy)
 
12580
  if (odd.ne.0) yy = -yy
 
12581
!
 
12582
  if (r_gt_1) then
 
12583
    yy   = 1/yy
 
12584
    lyy  =-lyy
 
12585
    ntwo =-ntwo
 
12586
    odd  =-odd
 
12587
  endif
 
12588
  loy = log(1-yy) ! log(1-yy) is always real
 
12589
!
 
12590
  y_lt_h = (2*yy.lt.RONE)
 
12591
  if (y_lt_h) then
 
12592
    zz = -loy ! log(1-yy) is real
 
12593
  else
 
12594
    zz = -lyy ! yy>0.5 => log(yy) is real
 
12595
  endif
 
12596
!
 
12597
  az = abs(zz)
 
12598
! if (az.gt.thrs(6,prcpar)) ERROR az to big 
 
12599
  if     (az.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12600
  elseif (az.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12601
  elseif (az.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12602
  elseif (az.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12603
  elseif (az.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12604
                                else ;nn=ntrm(1,prcpar)
 
12605
  endif
 
12606
  z2 = zz*zz
 
12607
  liox = coeff(nn)
 
12608
  do ii=nn,2,-1
 
12609
    liox = coeff(ii-1) + z2*liox
 
12610
  enddo
 
12611
  liox = zz*( 1 + zz*( coeff(0) + zz*liox ) )
 
12612
!
 
12613
  rslt = acmplx(liox)
 
12614
!
 
12615
  if (y_lt_h) then
 
12616
    rslt = 4*PISQo24 - rslt - acmplx(loy*lyy,loy*ONEPI*(ntwo+odd))
 
12617
  else
 
12618
    rslt = rslt + acmplx( 0 ,-loy*ONEPI*ntwo )
 
12619
  endif
 
12620
!
 
12621
  if (r_gt_1) rslt = -rslt - acmplx(lyy,ONEPI*(ntwo+odd))**2/2
 
12622
  end function
 
12623
 
 
12624
 
 
12625
  function dilog2_c( x1,i1 ,x2,i2 ) result(rslt)
 
12626
!*******************************************************************
 
12627
!*******************************************************************
 
12628
  use avh_olo_qp_olog
 
12629
  complex(kindr2) &   
 
12630
          ,intent(in) :: x1,x2
 
12631
  integer ,intent(in) :: i1,i2
 
12632
  complex(kindr2) &   
 
12633
    :: rslt ,y1,y2 ,ff,gg,logr1,logr2,logo1,logo2,r1,r2,rr
 
12634
  real(kindr2) &  
 
12635
    :: eps ,re1,im1,re2,im2,a1,a2,aa,ao1,ao2
 
12636
  integer :: j1,j2,ii,nn,oo
 
12637
  integer,parameter :: pp(-1:1,-1:1)=&
 
12638
                      reshape((/-2,-2,2 ,-2,0,2 ,-2,2,2/),(/3,3/))
 
12639
!
 
12640
  re1=areal(x1) ;re2=areal(x2)
 
12641
  im1=aimag(x1) ;im2=aimag(x2)
 
12642
!
 
12643
  if (abs(im1).le.EPSN*abs(re1).and.abs(im2).le.EPSN*abs(re2)) then
 
12644
    if (re1.ge.RZRO) then
 
12645
      if (re2.ge.RZRO) then
 
12646
        rslt = dilog2_r( re1,i1 , re2,i2 )
 
12647
      else
 
12648
        rslt = dilog2_r( re1,i1 ,-re2,i2+sgnRe(im2) )
 
12649
      endif
 
12650
    elseif (re2.ge.RZRO) then
 
12651
      rslt = dilog2_r(-re1,i1+sgnRe(im1) , re2,i2 )
 
12652
    else
 
12653
      rslt = dilog2_r(-re1,i1+sgnRe(im1) ,-re2,i2+sgnRe(im2) )
 
12654
    endif
 
12655
    return
 
12656
  endif
 
12657
!
 
12658
  if (re1.ge.RZRO) then ;r1= x1 ;j1=i1
 
12659
                   else ;r1=-x1 ;j1=i1+sgnRe(im1,1)
 
12660
  endif
 
12661
  if (re2.ge.RZRO) then ;r2= x2 ;j2=i2
 
12662
                   else ;r2=-x2 ;j2=i2+sgnRe(im2,1)
 
12663
  endif
 
12664
!
 
12665
  a1=abs(r1) ;a2=abs(r2)
 
12666
  if (a1.gt.a2) then
 
12667
    aa=a1;a1=a2;a2=aa
 
12668
    rr=r1;r1=r2;r2=rr
 
12669
    ii=j1;j1=j2;j2=ii
 
12670
  endif
 
12671
!
 
12672
  oo=mod(j1,2) ;nn=j1-oo ;y1=r1 ;if (oo.ne.0) y1=-y1
 
12673
  oo=mod(j2,2) ;nn=j2-oo ;y2=r2 ;if (oo.ne.0) y2=-y2
 
12674
!
 
12675
  eps = 10*EPSN
 
12676
!
 
12677
  if (j1.ne.j2) then
 
12678
    if (r1.eq.r2) then
 
12679
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
12680
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
12681
      rslt = 0
 
12682
!      write(*,*) 'dilog2_c j1=/=j2,r1=r2' !DEBUG
 
12683
      return
 
12684
    else
 
12685
      rslt = ( dilog_c(r1,j1)-dilog_c(r2,j2) )/(y1-y2)
 
12686
!      write(*,*) 'dilog2_c j1=/=j2' !DEBUG
 
12687
      return
 
12688
    endif
 
12689
  endif
 
12690
!
 
12691
  if (a1.lt.eps) then
 
12692
    if (a2.lt.eps) then
 
12693
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
12694
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
12695
      rslt = 0
 
12696
!      write(*,*) 'dilog2_c r1<eps,r2<eps' !DEBUG
 
12697
      return
 
12698
    else
 
12699
      rslt = (dilog_c(r2,j2)-4*PISQo24)/y2
 
12700
!      write(*,*) 'dilog2_c r1<eps' !DEBUG
 
12701
      return
 
12702
    endif
 
12703
  endif
 
12704
!
 
12705
  logr1=log(r1) ;logr2=log(r2)
 
12706
!
 
12707
  ao1=abs(1-y1) ;ao2=abs(1-y2)
 
12708
  if (10*ao1.lt.RONE.or.10*ao2.lt.RONE) then
 
12709
    aa = abs(r1/r2-1)
 
12710
    if (10*aa.gt.RONE) then
 
12711
      rslt = (dilog_c(r1,j1)-dilog_c(r2,j2))/(y1-y2)
 
12712
!      write(*,*) 'dilog2_c ||1-y1|/|1-y2|-1|>0.1' !DEBUG
 
12713
      return
 
12714
    elseif (oo.eq.0.and.ao1.lt.eps) then
 
12715
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
12716
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
12717
      if (ao2.lt.eps) then
 
12718
        rslt = -1
 
12719
!        write(*,*) 'dilog2_c |1-y1|' !DEBUG
 
12720
        return
 
12721
      else
 
12722
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
 
12723
      endif
 
12724
    elseif (oo.eq.0.and.ao2.lt.eps) then
 
12725
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
12726
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
12727
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
 
12728
    endif
 
12729
  else
 
12730
    aa = abs((logr1+oo*IPI)/(logr2+oo*IPI)-1)
 
12731
    if (10*aa.gt.RONE) then
 
12732
      rslt = (dilog_c(r1,j1)-dilog_c(r2,j2))/(y1-y2)
 
12733
!      write(*,*) 'dilog2_c |logr1/logr2-1|>0.1',logr1,logr2 !DEBUG
 
12734
      return
 
12735
    elseif (aa.lt.eps) then
 
12736
      ii = 0
 
12737
      if (a1.gt.RONE) ii = ii + (nn+pp(oo,sgnIm(y2)))
 
12738
      if (a2.gt.RONE) ii = ii - (nn+pp(oo,sgnIm(y2)))
 
12739
      ii = nn*ii
 
12740
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
12741
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
12742
        ,', putting nn=0'
 
12743
      rslt = -olog2(y2,0)
 
12744
!      write(*,*) 'dilog2_c |logr1/lorg2|<eps' !DEBUG
 
12745
      return
 
12746
    endif
 
12747
  endif
 
12748
!
 
12749
  if (a1.gt.RONE) then
 
12750
    y1=1/y1 ;logr1=-logr1
 
12751
    y2=1/y2 ;logr2=-logr2
 
12752
    nn=-nn ;oo=-oo
 
12753
  endif
 
12754
!
 
12755
  ff=y1/y2         ;ff=-olog2(ff,0)/y2
 
12756
  gg=(1-y1)/(1-y2) ;gg=-olog2(gg,0)/(1-y2)
 
12757
!
 
12758
  if (2*areal(y1).ge.RONE) then
 
12759
!    write(*,*) 'dilog2_c re>1/2' !DEBUG
 
12760
    rslt = ff*sumterms_c(-logr1,-logr2) - nn*IPI*gg
 
12761
  else
 
12762
!    write(*,*) 'dilog2_c re<1/2' !DEBUG
 
12763
    logo1 = log(1-y1)
 
12764
    logo2 = log(1-y2)
 
12765
    rslt = gg*( sumterms_c(-logo1,-logo2) - (nn+oo)*IPI - logr2 ) + ff*logo1
 
12766
  endif
 
12767
!
 
12768
  if (a1.gt.RONE) then !implies also r2>1
 
12769
!    write(*,*) 'dilog2_c r1>1,r2>1' !DEBUG
 
12770
    rslt = y1*y2*( rslt - ff*((logr1+logr2)/2 + (nn+oo)*IPI) )
 
12771
  elseif (a2.gt.RONE.and.nn.ne.0) then
 
12772
!    write(*,*) 'dilog2_c r1<1,r2>1',oo,sgnIm(y2)!DEBUG
 
12773
    rslt = rslt - 12*nn*( nn + pp(oo,sgnIm(y2)) )*PISQo24/(y1-y2)
 
12774
  endif
 
12775
!
 
12776
  end function
 
12777
 
 
12778
 
 
12779
  function dilog2_r( x1,i1 ,x2,i2 ) result(rslt)
 
12780
!*******************************************************************
 
12781
!*******************************************************************
 
12782
  use avh_olo_qp_olog
 
12783
  real(kindr2) &  
 
12784
          ,intent(in) :: x1,x2
 
12785
  integer ,intent(in) :: i1,i2
 
12786
  complex(kindr2) &   
 
12787
    :: rslt
 
12788
  real(kindr2) &  
 
12789
    :: y1,y2 ,ff,gg,logr1,logr2,logo1,logo2
 
12790
  real(kindr2) &  
 
12791
    :: eps,r1,r2,rr,ro1,ro2
 
12792
  integer :: j1,j2,ii,nn,oo
 
12793
!
 
12794
  if (x1.ge.RZRO) then ;r1= x1 ;j1=i1
 
12795
                  else ;r1=-x1 ;j1=i1+1 ! log(-1)=i*pi
 
12796
  endif
 
12797
  if (x2.ge.RZRO) then ;r2= x2 ;j2=i2
 
12798
                  else ;r2=-x2 ;j2=i2+1 ! log(-1)=i*pi
 
12799
  endif
 
12800
!
 
12801
  if (r1.gt.r2) then
 
12802
    rr=r1;r1=r2;r2=rr
 
12803
    ii=j1;j1=j2;j2=ii
 
12804
  endif
 
12805
!
 
12806
  oo=mod(j1,2) ;nn=j1-oo ;y1=r1 ;if (oo.ne.0) y1=-y1
 
12807
  oo=mod(j2,2) ;nn=j2-oo ;y2=r2 ;if (oo.ne.0) y2=-y2
 
12808
!
 
12809
  eps = 10*EPSN
 
12810
!
 
12811
  if (j1.ne.j2) then
 
12812
    if (r1.eq.r2) then
 
12813
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
12814
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
12815
      rslt = 0
 
12816
!      write(*,*) 'dilog2_r j1=/=j2,r1=r2' !DEBUG
 
12817
      return
 
12818
    else
 
12819
      rslt = ( dilog_r(r1,j1)-dilog_r(r2,j2) )/(y1-y2)
 
12820
!      write(*,*) 'dilog2_r j1=/=j2' !DEBUG
 
12821
      return
 
12822
    endif
 
12823
  endif
 
12824
!
 
12825
  if (r1.lt.eps) then
 
12826
    if (r2.lt.eps) then
 
12827
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
12828
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
12829
      rslt = 0
 
12830
!      write(*,*) 'dilog2_r r1<eps,r2<eps' !DEBUG
 
12831
      return
 
12832
    else
 
12833
      rslt = (dilog_r(r2,j2)-4*PISQo24)/y2
 
12834
!      write(*,*) 'dilog2_r r1<eps' !DEBUG
 
12835
      return
 
12836
    endif
 
12837
  endif
 
12838
!
 
12839
  logr1=log(r1) ;logr2=log(r2)
 
12840
!
 
12841
  ro1=abs(1-y1) ;ro2=abs(1-y2)
 
12842
  if (10*ro1.lt.RONE.or.10*ro2.lt.RONE) then
 
12843
    rr = abs(r1/r2-1)
 
12844
    if (10*rr.gt.RONE) then
 
12845
      rslt = (dilog_r(r1,j1)-dilog_r(r2,j2))/(y1-y2)
 
12846
!      write(*,*) 'dilog2_r ||1-y1|/|1-y2|-1|>0.1' !DEBUG
 
12847
      return
 
12848
    elseif (oo.eq.0.and.ro1.lt.eps) then
 
12849
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
12850
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
12851
      if (ro2.lt.eps) then
 
12852
        rslt = -1
 
12853
!        write(*,*) 'dilog2_r |1-y1|' !DEBUG
 
12854
        return
 
12855
      else
 
12856
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
 
12857
      endif
 
12858
    elseif (oo.eq.0.and.ro2.lt.eps) then
 
12859
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
12860
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
12861
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
 
12862
    endif
 
12863
  else
 
12864
    rr = abs((logr1+oo*IPI)/(logr2+oo*IPI)-1)
 
12865
    if (10*rr.gt.RONE) then
 
12866
      rslt = (dilog_r(r1,j1)-dilog_r(r2,j2))/(y1-y2)
 
12867
!      write(*,*) 'dilog2_r |logr1/logr2-1|>0.1',logr1,logr2 !DEBUG
 
12868
      return
 
12869
    elseif (rr.lt.eps) then
 
12870
      ii = 0
 
12871
      if (r1.gt.RONE) ii = ii + (nn+2*oo)
 
12872
      if (r2.gt.RONE) ii = ii - (nn+2*oo)
 
12873
      ii = nn*ii
 
12874
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
12875
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
12876
        ,', putting nn=0'
 
12877
      rslt = -olog2(y2,0)
 
12878
!      write(*,*) 'dilog2_r |logr1/lorg2|<eps' !DEBUG
 
12879
      return
 
12880
    endif
 
12881
  endif
 
12882
!
 
12883
  if (r1.gt.RONE) then
 
12884
    y1=1/y1 ;logr1=-logr1
 
12885
    y2=1/y2 ;logr2=-logr2
 
12886
    nn=-nn ;oo=-oo
 
12887
  endif
 
12888
!
 
12889
  ff=y1/y2         ;ff=-olog2(ff,0)/y2
 
12890
  gg=(1-y1)/(1-y2) ;gg=-olog2(gg,0)/(1-y2)
 
12891
!
 
12892
  if (2*y1.ge.RONE) then
 
12893
!    write(*,*) 'dilog2_r re>1/2' !DEBUG
 
12894
    rslt = ff*sumterms_r(-logr1,-logr2) - nn*IPI*gg
 
12895
  else
 
12896
!    write(*,*) 'dilog2_r re<1/2' !DEBUG
 
12897
    logo1 = log(1-y1)
 
12898
    logo2 = log(1-y2)
 
12899
    rslt = gg*( sumterms_r(-logo1,-logo2) - (nn+oo)*IPI - logr2 ) + ff*logo1
 
12900
  endif
 
12901
!
 
12902
  if (r1.gt.RONE) then !implies also r2>1
 
12903
!    write(*,*) 'dilog2_r r1>1,r2>1' !DEBUG
 
12904
    rslt = y1*y2*( rslt - ff*((logr1+logr2)/2 + (nn+oo)*IPI) )
 
12905
  elseif (r2.gt.RONE.and.nn.ne.0) then
 
12906
!    write(*,*) 'dilog2_r r1<1,r2>1' !DEBUG
 
12907
    rslt = rslt - 12*nn*PISQo24*(nn+2*oo)/(y1-y2)
 
12908
  endif
 
12909
!
 
12910
  end function
 
12911
 
 
12912
 
 
12913
  function sumterms_c( z1,z2 ) result(rslt)
 
12914
!***********************************************************************
 
12915
! ( f(z1)-f(z2) )/( z1-z2 ), where
 
12916
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
 
12917
!***********************************************************************
 
12918
  complex(kindr2) &   
 
12919
    ,intent(in) :: z1,z2
 
12920
  complex(kindr2) &   
 
12921
    :: rslt,yy,zz
 
12922
  real(kindr2) &  
 
12923
    :: az
 
12924
  integer :: ii,nn
 
12925
  az = max(abs(z1),abs(z2))
 
12926
  if     (az.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12927
  elseif (az.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12928
  elseif (az.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12929
  elseif (az.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12930
  elseif (az.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12931
                                else ;nn=ntrm(1,prcpar)
 
12932
  endif
 
12933
! calculates all z(i)=(z1^i-z2^i)/(z1-z2) numerically stable
 
12934
!  zz(1) = 1
 
12935
!  yy    = 1
 
12936
!  do ii=2,2*nn+1
 
12937
!    yy = z2*yy
 
12938
!    zz(ii) = z1*zz(ii-1) + yy
 
12939
!  enddo
 
12940
  zz = 1
 
12941
  yy = 1
 
12942
  rslt = zz
 
12943
  yy = z2*yy
 
12944
  zz = z1*zz+yy
 
12945
  rslt = rslt + coeff(0)*zz
 
12946
  do ii=1,nn
 
12947
    yy = z2*yy
 
12948
    zz = z1*zz+yy
 
12949
    rslt = rslt + coeff(ii)*zz
 
12950
    yy = z2*yy
 
12951
    zz = z1*zz+yy
 
12952
  enddo
 
12953
  end function  
 
12954
 
 
12955
 
 
12956
  function sumterms_r( z1,z2 ) result(rslt)
 
12957
!***********************************************************************
 
12958
! ( f(z1)-f(z2) )/( z1-z2 ), where
 
12959
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
 
12960
!***********************************************************************
 
12961
  real(kindr2) &  
 
12962
    ,intent(in) :: z1,z2
 
12963
  real(kindr2) &  
 
12964
    :: rslt,yy,zz
 
12965
  real(kindr2) &  
 
12966
    :: az
 
12967
  integer :: ii,nn
 
12968
  az = max(abs(z1),abs(z2))
 
12969
  if     (az.ge.thrs(5,prcpar)) then ;nn=ntrm(6,prcpar)
 
12970
  elseif (az.ge.thrs(4,prcpar)) then ;nn=ntrm(5,prcpar)
 
12971
  elseif (az.ge.thrs(3,prcpar)) then ;nn=ntrm(4,prcpar)
 
12972
  elseif (az.ge.thrs(2,prcpar)) then ;nn=ntrm(3,prcpar)
 
12973
  elseif (az.ge.thrs(1,prcpar)) then ;nn=ntrm(2,prcpar)
 
12974
                                else ;nn=ntrm(1,prcpar)
 
12975
  endif
 
12976
  zz = 1
 
12977
  yy = 1
 
12978
  rslt = zz
 
12979
  yy = z2*yy
 
12980
  zz = z1*zz+yy
 
12981
  rslt = rslt + coeff(0)*zz
 
12982
  do ii=1,nn
 
12983
    yy = z2*yy
 
12984
    zz = z1*zz+yy
 
12985
    rslt = rslt + coeff(ii)*zz
 
12986
    yy = z2*yy
 
12987
    zz = z1*zz+yy
 
12988
  enddo
 
12989
  end function  
 
12990
 
 
12991
end module
 
12992
 
 
12993
 
 
12994
module avh_olo_qp_bnlog
 
12995
!***********************************************************************
 
12996
!                      /1    
 
12997
!   bnlog(n,x) = (n+1) |  dt t^n ln(1-t/x) 
 
12998
!                      /0 
 
12999
!***********************************************************************
 
13000
  use avh_olo_units
 
13001
  use avh_olo_qp_prec
 
13002
  use avh_olo_qp_auxfun
 
13003
  use avh_olo_qp_arrays
 
13004
  use avh_olo_qp_olog
 
13005
  use avh_olo_qp_print
 
13006
  implicit none
 
13007
  private
 
13008
  public :: update_bnlog,bnlog
 
13009
 
 
13010
  real(kindr2) &  
 
13011
         ,allocatable,save :: coeff(:,:)
 
13012
  real(kindr2) &  
 
13013
         ,allocatable,save :: thrs(:,:,:)
 
13014
  integer,allocatable,save :: ntrm(:,:,:)
 
13015
  integer,parameter :: nStp=6
 
13016
  integer,parameter :: rank=4
 
13017
  integer,parameter :: aCoef(0:rank,0:rank)=reshape((/ &
 
13018
                         1, 0, 0, 0, 0 & ! 1
 
13019
                       , 1, 2, 0, 0, 0 & ! 1/2,1
 
13020
                       , 2, 3, 6, 0, 0 & ! 1/3,1/2,1
 
13021
                       , 3, 4, 6,12, 0 & ! 1/4,1/3,1/2,1
 
13022
                       ,12,15,20,30,60 & ! 1/5,1/4,1/3,1/2,1
 
13023
                       /),(/rank+1,rank+1/))
 
13024
 
 
13025
  interface bnlog
 
13026
    module procedure bnlog_c,bnlog_r
 
13027
  end interface
 
13028
 
 
13029
contains
 
13030
 
 
13031
 
 
13032
  subroutine update_bnlog
 
13033
!***********************************************************************
 
13034
!***********************************************************************
 
13035
  real(kindr2) &  
 
13036
    :: tt
 
13037
  integer :: nn,ii,jj,n1,nmax,irank
 
13038
  logical :: highestSoFar
 
13039
!  real(kind(1d0)) :: xx(6) !DEBUG
 
13040
!
 
13041
  if (allocated(thrs)) then
 
13042
    call shift3( thrs ,prcpar )
 
13043
    call shift3( ntrm ,prcpar )
 
13044
  else
 
13045
    allocate(thrs(1:nStp,0:rank,1:1))
 
13046
    allocate(ntrm(1:nStp,0:rank,1:1))
 
13047
    if (prcpar.ne.1) then
 
13048
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop update_bnlog'
 
13049
      stop
 
13050
    endif
 
13051
  endif
 
13052
!
 
13053
  highestSoFar = prcpar.eq.ubound(ntrm,3)
 
13054
!
 
13055
  if (highestSoFar) then
 
13056
    if (allocated(coeff)) deallocate(coeff)
 
13057
    allocate(coeff(0:-1,0:2)) ! allocate at size=0
 
13058
  endif
 
13059
!
 
13060
  nmax = 0
 
13061
!
 
13062
  do irank=0,rank
 
13063
!
 
13064
    n1 = 2+irank
 
13065
!
 
13066
    if (prcpar.gt.1) then ;nn=ntrm(nStp,irank,prcpar-1)-1
 
13067
                     else ;nn=n1
 
13068
    endif
 
13069
!  
 
13070
    do
 
13071
      nn = nn+1
 
13072
      if (highestSoFar.and.nn.gt.ubound(coeff,1)) call update_coeff( 2*nn )
 
13073
      tt = 1
 
13074
      tt = (EPSN*abs(coeff(n1,irank)/coeff(nn,irank)))**(tt/(nn-n1))
 
13075
      if (8*(irank+1)*tt.gt.RONE) exit
 
13076
    enddo
 
13077
!
 
13078
    if (nn.gt.nmax) nmax=nn
 
13079
!  
 
13080
    ntrm(nStp,irank,prcpar) = nn
 
13081
    thrs(nStp,irank,prcpar) = tt
 
13082
    nn = max(1,nint(nn*1d0/nStp))
 
13083
    do ii=nStp-1,1,-1
 
13084
      ntrm(ii,irank,prcpar) = ntrm(ii+1,irank,prcpar)-nn
 
13085
      if (ntrm(ii,irank,prcpar).le.n1) then
 
13086
        do jj=1,ii
 
13087
          ntrm(jj,irank,prcpar) = max(n1,ntrm(ii,irank,prcpar))
 
13088
          thrs(jj,irank,prcpar) = 0 
 
13089
        enddo
 
13090
        exit
 
13091
      endif
 
13092
      jj = ntrm(ii,irank,prcpar)
 
13093
      tt = 1
 
13094
      tt = (EPSN*abs(coeff(n1,irank)/coeff(jj,irank)))**(tt/(jj-n1))
 
13095
      thrs(ii,irank,prcpar) = tt
 
13096
    enddo
 
13097
!  
 
13098
  enddo!irank=1,nrank
 
13099
!  
 
13100
  if (highestSoFar) call resize( coeff ,2,nmax ,0,rank )
 
13101
!
 
13102
!  do ii=lbound(thrs,3),ubound(thrs,3)        !DEBUG
 
13103
!  do irank=0,rank                            !DEBUG
 
13104
!    do jj=1,nStp                             !DEBUG
 
13105
!      xx(jj) = thrs(jj,irank,ii)             !DEBUG
 
13106
!    enddo                                    !DEBUG
 
13107
!    write(*,'(i2,99e10.3)') irank,xx(:)      !DEBUG
 
13108
!    write(*,'(2x,99i10)'  ) ntrm(:,irank,ii) !DEBUG
 
13109
!  enddo                                      !DEBUG
 
13110
!  enddo                                      !DEBUG
 
13111
  end subroutine
 
13112
 
 
13113
 
 
13114
  subroutine update_coeff( ncf )
 
13115
!*******************************************************************
 
13116
! Coefficients of the expansion of
 
13117
!   f(n,x) = -int( t^n*log(1-t*x) ,t=0..1 )
 
13118
! in terms of log(1-x)
 
13119
!*******************************************************************
 
13120
  integer ,intent(in) :: ncf
 
13121
  integer :: ii,jj
 
13122
  real(kindr2) &  
 
13123
    :: fact,tt(rank)
 
13124
!
 
13125
  call enlarge( coeff ,2,ncf ,0,rank )
 
13126
!
 
13127
  do jj=0,rank
 
13128
  do ii=2,1+jj
 
13129
    coeff(ii,jj) = 0
 
13130
  enddo
 
13131
  enddo
 
13132
  fact = 1
 
13133
  do ii=1,rank ;tt(ii)=1 ;enddo
 
13134
  do ii=2,ncf
 
13135
    fact = fact*ii
 
13136
    coeff(ii,0) = (ii-1)/fact
 
13137
    if (ii.eq.2) cycle
 
13138
    do jj=1,rank ;tt(jj)=tt(jj)*(jj+1) ;enddo
 
13139
    coeff(ii,1) = coeff(ii,0)*(1-tt(1))
 
13140
    if (ii.eq.3) cycle
 
13141
    coeff(ii,2) = coeff(ii,0)*(1-2*tt(1)+tt(2))
 
13142
    if (ii.eq.4) cycle
 
13143
    coeff(ii,3) = coeff(ii,0)*(1-3*tt(1)+3*tt(2)-tt(3))
 
13144
    if (ii.eq.5) cycle
 
13145
    coeff(ii,4) = coeff(ii,0)*(1-4*tt(1)+6*tt(2)-4*tt(3)+tt(4))
 
13146
!   if (ii.eq.n+1) cycle
 
13147
!   coeff(ii,n) = coeff(ii,0)
 
13148
!               * ( 1 - binom(n,1)*tt(1) + binom(n,2)*tt(2)...)
 
13149
  enddo
 
13150
!
 
13151
  end subroutine
 
13152
 
 
13153
 
 
13154
  function bnlog_c( irank ,xx ) result(rslt)
 
13155
!*******************************************************************
 
13156
!*******************************************************************
 
13157
  integer ,intent(in) :: irank
 
13158
  complex(kindr2) &   
 
13159
    ,intent(in) :: xx
 
13160
  complex(kindr2) &   
 
13161
    :: rslt,yy,omx
 
13162
  real(kindr2) &  
 
13163
    :: aa,rex,imx
 
13164
  integer :: ii,nn
 
13165
!
 
13166
  rex = areal(xx)
 
13167
  imx = aimag(xx)
 
13168
!
 
13169
  if (abs(imx).le.EPSN*abs(rex)) then
 
13170
    rslt = bnlog_r( irank ,rex ,sgnRe(imx,1) )
 
13171
    return
 
13172
  endif
 
13173
!
 
13174
  if (abs(xx-1).le.EPSN*10) then
 
13175
    aa = 1
 
13176
    rslt = -1
 
13177
    do ii=2,irank+1
 
13178
      rslt = rslt - aa/ii
 
13179
    enddo
 
13180
    return
 
13181
  endif
 
13182
!
 
13183
  yy = olog(1-1/xx,0)
 
13184
  aa = abs(yy)
 
13185
  if     (aa.ge.thrs(6,irank,prcpar)) then
 
13186
     omx = 1
 
13187
    rslt = aCoef(irank,irank)
 
13188
    do ii=irank,1,-1
 
13189
       omx = 1 + xx*omx
 
13190
      rslt = aCoef(ii-1,irank) + xx*rslt
 
13191
    enddo
 
13192
     omx = (1-xx)*omx
 
13193
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
13194
!    if     (irank.eq.0) then
 
13195
!      rslt = (1-xx)*yy - 1
 
13196
!    elseif (irank.eq.1) then
 
13197
!      rslt = (1-xx)*(1+xx)*yy - (1+xx*2)/2
 
13198
!    elseif (irank.eq.2) then
 
13199
!      rslt = (1-xx)*(1+xx*(1+xx))*yy - (2+xx*(3+xx*6))/6
 
13200
!    elseif (irank.eq.3) then
 
13201
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx)))*yy &
 
13202
!           - (3+xx*(4+xx*(6+xx*12)))/12
 
13203
!    elseif (irank.eq.4) then
 
13204
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx*(1+xx))))*yy &
 
13205
!           - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
13206
!    endif
 
13207
    return
 
13208
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
 
13209
  elseif (aa.ge.thrs(4,irank,prcpar)) then ;nn=ntrm(5,irank,prcpar)
 
13210
  elseif (aa.ge.thrs(3,irank,prcpar)) then ;nn=ntrm(4,irank,prcpar)
 
13211
  elseif (aa.ge.thrs(2,irank,prcpar)) then ;nn=ntrm(3,irank,prcpar)
 
13212
  elseif (aa.ge.thrs(1,irank,prcpar)) then ;nn=ntrm(2,irank,prcpar)
 
13213
                                      else ;nn=ntrm(1,irank,prcpar)
 
13214
  endif
 
13215
!
 
13216
  rslt = coeff(nn,irank)
 
13217
  do ii=nn-1,2+irank,-1
 
13218
    rslt = coeff(ii,irank) + yy*rslt
 
13219
  enddo
 
13220
  rslt = -(irank+1)*rslt*yy*(yy*xx)**(irank+1)
 
13221
!
 
13222
  aa = areal(rslt)
 
13223
  if (abs(aimag(rslt)).le.EPSN*abs(aa)) rslt = acmplx(aa)
 
13224
!
 
13225
  end function
 
13226
 
 
13227
 
 
13228
  function bnlog_r( irank ,xx ,sgn ) result(rslt)
 
13229
!*******************************************************************
 
13230
!*******************************************************************
 
13231
  integer ,intent(in) :: irank
 
13232
  real(kindr2) &  
 
13233
          ,intent(in) :: xx
 
13234
  integer ,intent(in) :: sgn
 
13235
  complex(kindr2) &   
 
13236
    :: rslt
 
13237
  real(kindr2) &  
 
13238
    :: yy,aa,omx
 
13239
  integer :: ii,nn
 
13240
  logical :: y_lt_0
 
13241
!
 
13242
  if (abs(xx).eq.RZRO) then
 
13243
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop bnlog_r: ' &
 
13244
      ,'argument xx=',trim(myprint(xx,8)),', returning 0'
 
13245
    rslt = 0
 
13246
    return
 
13247
  elseif (abs(xx-1).le.EPSN*10) then
 
13248
    aa = 1
 
13249
    rslt = -1
 
13250
    do ii=2,irank+1
 
13251
      rslt = rslt - aa/ii
 
13252
    enddo
 
13253
    return
 
13254
  endif
 
13255
!
 
13256
  yy = 1-1/xx
 
13257
  y_lt_0 = (yy.lt.RZRO)
 
13258
  if (y_lt_0) then 
 
13259
    yy = log(-yy)
 
13260
    aa = sqrt(yy*yy+ONEPI*ONEPI)
 
13261
  else
 
13262
    yy = log( yy)
 
13263
    aa = abs(yy)
 
13264
  endif
 
13265
!
 
13266
  omx = 1
 
13267
  do ii=irank,1,-1
 
13268
    omx = 1+xx*omx
 
13269
  enddo
 
13270
  omx = (1-xx)*omx ! (1-x^{rank+1})
 
13271
!
 
13272
  if     (aa.ge.thrs(6,irank,prcpar)) then
 
13273
    rslt = aCoef(irank,irank)
 
13274
    do ii=irank,1,-1
 
13275
      rslt = aCoef(ii-1,irank) + xx*rslt
 
13276
    enddo
 
13277
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
13278
!    if     (irank.eq.0) then
 
13279
!      rslt = omx*yy - 1
 
13280
!    elseif (irank.eq.1) then
 
13281
!      rslt = omx*yy - (1+xx*2)/2
 
13282
!    elseif (irank.eq.2) then
 
13283
!      rslt = omx*yy - (2+xx*(3+xx*6))/6
 
13284
!    elseif (irank.eq.3) then
 
13285
!      rslt = omx*yy - (3+xx*(4+xx*(6+xx*12)))/12
 
13286
!    elseif (irank.eq.4) then
 
13287
!      rslt = omx*yy - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
13288
!    endif
 
13289
    if (y_lt_0) rslt = rslt + sgn*omx*IPI
 
13290
    return
 
13291
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
 
13292
  elseif (aa.ge.thrs(4,irank,prcpar)) then ;nn=ntrm(5,irank,prcpar)
 
13293
  elseif (aa.ge.thrs(3,irank,prcpar)) then ;nn=ntrm(4,irank,prcpar)
 
13294
  elseif (aa.ge.thrs(2,irank,prcpar)) then ;nn=ntrm(3,irank,prcpar)
 
13295
  elseif (aa.ge.thrs(1,irank,prcpar)) then ;nn=ntrm(2,irank,prcpar)
 
13296
                                      else ;nn=ntrm(1,irank,prcpar)
 
13297
  endif
 
13298
!
 
13299
  aa = coeff(nn,irank)
 
13300
  do ii=nn-1,2+irank,-1
 
13301
    aa = coeff(ii,irank) + yy*aa
 
13302
  enddo
 
13303
  rslt = -(irank+1)*aa*yy*(yy*xx)**(irank+1)
 
13304
  if (y_lt_0) rslt = rslt + sgn*omx*IPI
 
13305
!  
 
13306
  end function
 
13307
 
 
13308
end module
 
13309
 
 
13310
 
 
13311
module avh_olo_qp_qmplx
 
13312
  use avh_olo_units
 
13313
  use avh_olo_qp_prec
 
13314
  use avh_olo_qp_auxfun
 
13315
  use avh_olo_qp_olog
 
13316
  use avh_olo_qp_dilog
 
13317
 
 
13318
  implicit none
 
13319
  private
 
13320
  public :: qmplx_type,qonv,directly,sheet,logc,logc2,li2c,li2c2
 
13321
  public :: operator (*) ,operator (/)
 
13322
 
 
13323
  type :: qmplx_type
 
13324
  complex(kindr2) &   
 
13325
          :: c
 
13326
  integer :: p
 
13327
  end type
 
13328
 
 
13329
  interface qonv
 
13330
    module procedure qonv_cr,qonv_ci,qonv_c,qonv_i
 
13331
  end interface
 
13332
 
 
13333
  interface operator (*)
 
13334
    module procedure prduct_qq,prduct_qr
 
13335
  end interface
 
13336
  interface operator (/)
 
13337
    module procedure ratio_qq,ratio_qr
 
13338
  end interface
 
13339
 
 
13340
contains
 
13341
 
 
13342
 
 
13343
  function qonv_cr(xx,sgn) result(rslt)
 
13344
!*******************************************************************
 
13345
! zz=rslt%c ,iz=rslt%p
 
13346
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
 
13347
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
 
13348
! sign of  sgn .
 
13349
!*******************************************************************
 
13350
  complex(kindr2) &   
 
13351
    ,intent(in) :: xx
 
13352
  real(kindr2) &  
 
13353
    ,intent(in) :: sgn
 
13354
  type(qmplx_type) :: rslt
 
13355
  real(kindr2) &  
 
13356
    :: xre,xim
 
13357
  xre = areal(xx)
 
13358
  if (xre.ge.RZRO) then
 
13359
    rslt%c = xx
 
13360
    rslt%p = 0
 
13361
  else
 
13362
    xim = aimag(xx)
 
13363
    if (xim.eq.RZRO) then
 
13364
      rslt%c = -xre
 
13365
      rslt%p = sgnRe(sgn)
 
13366
    else
 
13367
      rslt%c = -xx
 
13368
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
 
13369
    endif
 
13370
  endif
 
13371
  end function
 
13372
 
 
13373
  function qonv_ci(xx,sgn) result(rslt)
 
13374
!*******************************************************************
 
13375
! zz=rslt%c ,iz=rslt%p
 
13376
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
 
13377
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
 
13378
! sign of  sgn .
 
13379
!*******************************************************************
 
13380
  complex(kindr2) &   
 
13381
    ,intent(in) :: xx
 
13382
  integer         ,intent(in) :: sgn
 
13383
  type(qmplx_type) :: rslt
 
13384
  real(kindr2) &  
 
13385
    :: xre,xim
 
13386
  xre = areal(xx)
 
13387
  if (xre.ge.RZRO) then
 
13388
    rslt%c = xx
 
13389
    rslt%p = 0
 
13390
  else
 
13391
    xim = aimag(xx)
 
13392
    if (xim.eq.RZRO) then
 
13393
      rslt%c = -xre
 
13394
      rslt%p = sign(1,sgn)
 
13395
    else
 
13396
      rslt%c = -xx
 
13397
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
 
13398
    endif
 
13399
  endif
 
13400
  end function
 
13401
 
 
13402
  function qonv_c(xx) result(rslt)
 
13403
!*******************************************************************
 
13404
! zz=rslt%c ,iz=rslt%p
 
13405
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
 
13406
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
 
13407
!*******************************************************************
 
13408
  complex(kindr2) &   
 
13409
    ,intent(in) :: xx
 
13410
  type(qmplx_type) :: rslt
 
13411
  real(kindr2) &  
 
13412
    :: xre,xim
 
13413
  xre = areal(xx)
 
13414
  if (xre.ge.RZRO) then
 
13415
    rslt%c = xx
 
13416
    rslt%p = 0
 
13417
  else
 
13418
    xim = aimag(xx)
 
13419
    if (xim.eq.RZRO) then
 
13420
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop qonv_c: ' &
 
13421
        ,'negative input with undefined sign for the imaginary part, ' &
 
13422
        ,'putting +ieps'
 
13423
      rslt%c = -xre
 
13424
      rslt%p = 1
 
13425
    else
 
13426
      rslt%c = -xx
 
13427
      rslt%p = sgnRe(xim) ! xim = -Im(rslt%c)
 
13428
    endif
 
13429
  endif
 
13430
  end function
 
13431
 
 
13432
  function qonv_i(xx) result(rslt)
 
13433
!*******************************************************************
 
13434
! zz=rslt%c ,iz=rslt%p
 
13435
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
 
13436
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
 
13437
!*******************************************************************
 
13438
  integer ,intent(in) :: xx
 
13439
  type(qmplx_type) :: rslt
 
13440
  if (xx.ge.0) then
 
13441
    rslt%c = xx
 
13442
    rslt%p = 0
 
13443
  else
 
13444
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop qonv_i: ' &
 
13445
      ,'negative input with undefined sign for the imaginary part, ' &
 
13446
      ,'putting +ieps'
 
13447
    rslt%c = -xx
 
13448
    rslt%p = 1
 
13449
  endif
 
13450
  end function
 
13451
 
 
13452
  function directly(xx,ix) result(rslt)
 
13453
!*******************************************************************
 
13454
!*******************************************************************
 
13455
  complex(kindr2) &   
 
13456
    ,intent(in) :: xx
 
13457
  integer         ,intent(in) :: ix
 
13458
  type(qmplx_type) :: rslt
 
13459
  rslt%c = xx
 
13460
  rslt%p = ix
 
13461
  end function
 
13462
 
 
13463
 
 
13464
  function sheet(xx) result(ii)
 
13465
!*******************************************************************
 
13466
! Returns the number of the Riemann-sheet (times 2) for the complex
 
13467
! number  xx*exp(ix*imag*pi) . The real part of xx is assumed to be
 
13468
! positive or zero. Examples:
 
13469
! xx=1+imag, ix=-1 -> ii= 0 
 
13470
! xx=1+imag, ix= 1 -> ii= 2 
 
13471
! xx=1-imag, ix=-1 -> ii=-2 
 
13472
! xx=1-imag, ix= 1 -> ii= 0 
 
13473
! xx=1     , ix= 1 -> ii= 0  convention that log(-1)=pi on
 
13474
! xx=1     , ix=-1 -> ii=-2  the principal Riemann-sheet
 
13475
!*******************************************************************
 
13476
  type(qmplx_type) ,intent(in) :: xx
 
13477
  integer :: ii,jj
 
13478
  real(kindr2) &  
 
13479
    :: xim
 
13480
  jj = mod(xx%p,2)
 
13481
  ii = xx%p-jj
 
13482
  xim = aimag(xx%c)
 
13483
  if (xim.le.RZRO) then ! also xim=0 <==> log(-1)=pi, not -pi
 
13484
    if (jj.eq.-1) ii = ii-2
 
13485
  else
 
13486
    if (jj.eq. 1) ii = ii+2
 
13487
  endif
 
13488
  end function
 
13489
 
 
13490
 
 
13491
  function prduct_qq(yy,xx) result(zz)
 
13492
!*******************************************************************
 
13493
! Return the product  zz  of  yy  and  xx  
 
13494
! keeping track of (the multiple of pi of) the phase %p such that
 
13495
! the real part of  zz%c  remains positive 
 
13496
!*******************************************************************
 
13497
  type(qmplx_type) ,intent(in) :: yy,xx
 
13498
  type(qmplx_type) :: zz
 
13499
  zz%c = yy%c*xx%c
 
13500
  zz%p = yy%p+xx%p
 
13501
  if (areal(zz%c).lt.RZRO) then
 
13502
    zz%p = zz%p + sgnIm(xx%c)
 
13503
    zz%c = -zz%c
 
13504
  endif
 
13505
  end function
 
13506
 
 
13507
  function prduct_qr(yy,xx) result(zz)
 
13508
!*******************************************************************
 
13509
! Return the product  zz  of  yy  and  xx  
 
13510
! keeping track of (the multiple of pi of) the phase %p such that
 
13511
! the real part of  zz%c  remains positive 
 
13512
!*******************************************************************
 
13513
  type(qmplx_type) ,intent(in) :: yy
 
13514
  real(kindr2) &  
 
13515
    ,intent(in) :: xx
 
13516
  type(qmplx_type) :: zz
 
13517
  zz%c = yy%c*abs(xx)
 
13518
  zz%p = yy%p
 
13519
  end function
 
13520
 
 
13521
  function ratio_qq(yy,xx) result(zz)
 
13522
!*******************************************************************
 
13523
! Return the ratio  zz  of  yy  and  xx  
 
13524
! keeping track of (the multiple of pi of) the phase %p such that
 
13525
! the real part of  zz%c  remains positive 
 
13526
!*******************************************************************
 
13527
  type(qmplx_type) ,intent(in) :: yy,xx
 
13528
  type(qmplx_type) :: zz
 
13529
  zz%c = yy%c/xx%c
 
13530
  zz%p = yy%p-xx%p
 
13531
  if (areal(zz%c).lt.RZRO) then
 
13532
    zz%p = zz%p - sgnIm(xx%c)
 
13533
    zz%c = -zz%c
 
13534
  endif
 
13535
  end function
 
13536
 
 
13537
  function ratio_qr(yy,xx) result(zz)
 
13538
!*******************************************************************
 
13539
!*******************************************************************
 
13540
  type(qmplx_type) ,intent(in) :: yy
 
13541
  real(kindr2) &  
 
13542
    ,intent(in) :: xx
 
13543
  type(qmplx_type) :: zz
 
13544
  zz%c = yy%c/abs(xx)
 
13545
  zz%p = yy%p
 
13546
  end function
 
13547
 
 
13548
 
 
13549
  function logc(xx) result(rslt)
 
13550
!*******************************************************************
 
13551
! log(xx)
 
13552
!*******************************************************************
 
13553
  type(qmplx_type) ,intent(in) :: xx
 
13554
  complex(kindr2) &   
 
13555
    :: rslt
 
13556
!  rslt = olog(acmplx(xx%c),xx%p)
 
13557
  rslt = olog(xx%c,xx%p)
 
13558
  end function
 
13559
 
 
13560
  function logc2(xx) result(rslt)
 
13561
!*******************************************************************
 
13562
! log(xx)/(1-xx)
 
13563
!*******************************************************************
 
13564
  type(qmplx_type) ,intent(in) :: xx
 
13565
  complex(kindr2) &   
 
13566
    :: rslt
 
13567
!  rslt = -olog2(acmplx(xx%c),xx%p)
 
13568
  rslt = -olog2(xx%c,xx%p)
 
13569
  end function
 
13570
 
 
13571
  function li2c(xx) result(rslt)
 
13572
!*******************************************************************
 
13573
!    /1    ln(1-(1-xx)*t)
 
13574
!  - |  dt -------------- 
 
13575
!    /0        t
 
13576
!*******************************************************************
 
13577
  type(qmplx_type) ,intent(in) :: xx
 
13578
  complex(kindr2) &   
 
13579
    :: rslt
 
13580
!  rslt = dilog(acmplx(xx%c),xx%p)
 
13581
  rslt = dilog(xx%c,xx%p)
 
13582
  end function
 
13583
 
 
13584
  function li2c2(xx,yy) result(rslt)
 
13585
!*******************************************************************
 
13586
! ( li2(xx) - li2(yy) )/(xx-yy)
 
13587
!*******************************************************************
 
13588
  type(qmplx_type) ,intent(in) :: xx,yy
 
13589
  complex(kindr2) &   
 
13590
    :: rslt
 
13591
!  rslt = dilog( acmplx(xx%c),xx%p ,acmplx(yy%c),yy%p )
 
13592
!  write(*,*) 'li2c2 x:',xx%c,xx%p !DEBUG
 
13593
!  write(*,*) 'li2c2 y:',yy%c,yy%p !DEBUG
 
13594
  rslt = dilog( xx%c,xx%p ,yy%c,yy%p )
 
13595
!  write(*,*) 'li2c2 out:',rslt !DEBUG
 
13596
  end function
 
13597
 
 
13598
 
 
13599
end module
 
13600
 
 
13601
 
 
13602
module avh_olo_qp_bub
 
13603
  use avh_olo_units
 
13604
  use avh_olo_qp_prec
 
13605
  use avh_olo_qp_auxfun
 
13606
  use avh_olo_qp_bnlog
 
13607
  use avh_olo_qp_qmplx
 
13608
  implicit none
 
13609
  private
 
13610
  public :: tadp ,tadpn ,bub0 ,bub1 ,bub11 ,bub111 ,bub1111
 
13611
 
 
13612
contains
 
13613
 
 
13614
  subroutine tadp( rslt ,mm ,amm ,rmu2 )
 
13615
!*******************************************************************
 
13616
! The 1-loop scalar 1-point function.
 
13617
!*******************************************************************
 
13618
  complex(kindr2) &   
 
13619
    ,intent(out) :: rslt(0:2)
 
13620
  complex(kindr2) &   
 
13621
    ,intent(in)  :: mm
 
13622
  real(kindr2) &  
 
13623
    ,intent(in)  :: amm,rmu2
 
13624
!
 
13625
  rslt(2) = 0
 
13626
  if (amm.eq.RZRO.or.mm.eq.CZRO) then
 
13627
    rslt(1) = 0
 
13628
    rslt(0) = 0
 
13629
  else
 
13630
    rslt(1) = mm
 
13631
    rslt(0) = mm - mm*logc( qonv(mm/rmu2,-1) )
 
13632
  endif
 
13633
  end subroutine
 
13634
 
 
13635
 
 
13636
  subroutine tadpn( rslt ,rank ,mm ,amm ,rmu2 )
 
13637
!*******************************************************************
 
13638
! The 1-loop tensor 1-point functions.
 
13639
!   rslt(:,0) = A0
 
13640
!   rslt(:,1) = A00
 
13641
!   rslt(:,2) = A0000  etc.
 
13642
! For input  rank  only  rslt(:,0:rank/2)  is filled.
 
13643
!*******************************************************************
 
13644
  complex(kindr2) &   
 
13645
    ,intent(out) :: rslt(0:,0:)
 
13646
  complex(kindr2) &   
 
13647
    ,intent(in)  :: mm
 
13648
  real(kindr2) &  
 
13649
    ,intent(in)  :: amm,rmu2
 
13650
  integer ,intent(in) :: rank
 
13651
  complex(kindr2) &   
 
13652
    :: aa
 
13653
  real(kindr2) &  
 
13654
    :: bb
 
13655
  integer :: ii
 
13656
!
 
13657
  do ii=0,rank
 
13658
    rslt(2,ii) = 0
 
13659
    rslt(1,ii) = 0
 
13660
    rslt(0,ii) = 0
 
13661
  enddo
 
13662
  if (amm.eq.RZRO.or.mm.eq.CZRO) then
 
13663
    return
 
13664
  else
 
13665
    rslt(1,0) = mm
 
13666
    rslt(0,0) = mm - mm*logc( qonv(mm/rmu2,-1) )
 
13667
    aa = 1
 
13668
    bb = 0
 
13669
    do ii=1,rank/2
 
13670
      aa = aa*mm/(2*(ii+1))
 
13671
      bb = bb + RONE/(ii+1)
 
13672
      rslt(1,ii) = aa*( rslt(1,0) )
 
13673
      rslt(0,ii) = aa*( rslt(0,0) + mm*bb )
 
13674
    enddo
 
13675
  endif
 
13676
  end subroutine
 
13677
 
 
13678
 
 
13679
!*******************************************************************
 
13680
! Return the Passarino-Veltman functions
 
13681
!
 
13682
!      C   /      d^(Dim)q
 
13683
!   ------ | -------------------- = b0
 
13684
!   i*pi^2 / [q^2-m0][(q+p)^2-m1]
 
13685
!
 
13686
!      C   /    d^(Dim)q q^mu
 
13687
!   ------ | -------------------- = p^mu b1
 
13688
!   i*pi^2 / [q^2-m0][(q+p)^2-m1]
 
13689
!
 
13690
!      C   /  d^(Dim)q q^mu q^nu
 
13691
!   ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
 
13692
!   i*pi^2 / [q^2-m0][(q+p)^2-m1]
 
13693
!
 
13694
!   etc.
 
13695
!
 
13696
! Based on the formulas from
 
13697
! A. Denner, M. Dittmaier, Nucl.Phys. B734 (2006) 62-115
 
13698
!*******************************************************************
 
13699
 
 
13700
  subroutine bub0( b0 &
 
13701
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
13702
  complex(kindr2) &   
 
13703
    ,intent(out) :: b0(0:2)
 
13704
  complex(kindr2) &   
 
13705
    ,intent(in)  :: pp,m0i,m1i
 
13706
  real(kindr2) &  
 
13707
    ,intent(in)  :: app,am0i,am1i,rmu2
 
13708
  complex(kindr2) &   
 
13709
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
13710
  real(kindr2) &  
 
13711
    :: am0,am1,maxm
 
13712
  integer :: rank
 
13713
!
 
13714
  maxm = max(am0i,am1i)
 
13715
  if (maxm.eq.RZRO) then
 
13716
    if (app.eq.RZRO) then
 
13717
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
13718
      return
 
13719
    endif
 
13720
  endif
 
13721
!
 
13722
  if (am1i.ge.maxm) then
 
13723
    m0=m0i ;am0=am0i
 
13724
    m1=m1i ;am1=am1i
 
13725
  else
 
13726
    m0=m1i ;am0=am1i
 
13727
    m1=m0i ;am1=am0i
 
13728
  endif
 
13729
!
 
13730
  b0(2) = 0
 
13731
  b0(1) = CONE
 
13732
!
 
13733
  if (app.eq.RZRO) then
 
13734
    if (abs(m0-m1).le.am1*EPSN*10) then
 
13735
      lna = -logc(qonv(m1/rmu2,-1))
 
13736
      b0(0) = lna
 
13737
    else
 
13738
      lna = -logc(qonv(m1/rmu2,-1))
 
13739
      x1 = (m1-am1*IEPS)/(m1-m0)
 
13740
      b0(0) =   lna - bnlog(0,x1)
 
13741
    endif
 
13742
  elseif (am0.eq.RZRO) then
 
13743
    if (abs(pp-m1).le.am1*EPSN*10) then
 
13744
      lna = -logc(qonv(m1/rmu2,-1))
 
13745
      b0(0) = ( lna   + 2 )
 
13746
    else
 
13747
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
13748
      x1  = (pp-m1+am1*IEPS)/pp
 
13749
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
13750
    endif
 
13751
  else
 
13752
    lna = -logc(qonv(m0/rmu2,-1))
 
13753
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
13754
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
13755
  endif
 
13756
!
 
13757
  end subroutine
 
13758
 
 
13759
  subroutine bub1( b1,b0 &
 
13760
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
13761
  complex(kindr2) &   
 
13762
    ,intent(out) :: b1(0:2),b0(0:2)
 
13763
  complex(kindr2) &   
 
13764
    ,intent(in)  :: pp,m0i,m1i
 
13765
  real(kindr2) &  
 
13766
    ,intent(in)  :: app,am0i,am1i,rmu2
 
13767
  complex(kindr2) &   
 
13768
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
13769
  real(kindr2) &  
 
13770
    :: am0,am1,maxm
 
13771
  logical :: switch 
 
13772
  integer :: rank
 
13773
!
 
13774
  maxm = max(am0i,am1i)
 
13775
  if (maxm.eq.RZRO) then
 
13776
    if (app.eq.RZRO) then
 
13777
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
13778
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
13779
      return
 
13780
    endif
 
13781
  endif
 
13782
!
 
13783
  if (am1i.ge.maxm) then
 
13784
    m0=m0i ;am0=am0i
 
13785
    m1=m1i ;am1=am1i
 
13786
    switch = .false. 
 
13787
  else
 
13788
    m0=m1i ;am0=am1i
 
13789
    m1=m0i ;am1=am0i
 
13790
    switch = .true. 
 
13791
  endif
 
13792
!
 
13793
  b0(2) = 0
 
13794
  b0(1) = CONE
 
13795
  b1(2) = 0      
 
13796
  b1(1) =-CONE/2 
 
13797
!
 
13798
  if (app.eq.RZRO) then
 
13799
    if (abs(m0-m1).le.am1*EPSN*10) then
 
13800
      lna = -logc(qonv(m1/rmu2,-1))
 
13801
      b0(0) = lna
 
13802
      b1(0) =-lna/2 
 
13803
    else
 
13804
      lna = -logc(qonv(m1/rmu2,-1))
 
13805
      x1 = (m1-am1*IEPS)/(m1-m0)
 
13806
      b0(0) =   lna - bnlog(0,x1)
 
13807
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
13808
    endif
 
13809
    if (switch) then
 
13810
      x2=m0;m0=m1;m1=x2
 
13811
    else
 
13812
      b1(0) =-b0(0)-b1(0)
 
13813
    endif
 
13814
  elseif (am0.eq.RZRO) then
 
13815
    if (abs(pp-m1).le.am1*EPSN*10) then
 
13816
      lna = -logc(qonv(m1/rmu2,-1))
 
13817
      b0(0) = ( lna   + 2 )
 
13818
      b1(0) =-( lna*2 + 2 )/4 
 
13819
    else
 
13820
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
13821
      x1  = (pp-m1+am1*IEPS)/pp
 
13822
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
13823
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
13824
    endif
 
13825
    if (switch) then
 
13826
      x2=m0;m0=m1;m1=x2
 
13827
      b1(0) =-b0(0)-b1(0)
 
13828
    endif
 
13829
  else
 
13830
    lna = -logc(qonv(m0/rmu2,-1))
 
13831
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
13832
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
13833
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
13834
    if (switch) then
 
13835
      x2=m0;m0=m1;m1=x2
 
13836
      b1(0) =-b0(0)-b1(0)
 
13837
    endif
 
13838
  endif
 
13839
!
 
13840
  end subroutine
 
13841
 
 
13842
  subroutine bub11( b11,b00,b1,b0 &
 
13843
                   ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
13844
  complex(kindr2) &   
 
13845
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
13846
  complex(kindr2) &   
 
13847
    ,intent(in)  :: pp,m0i,m1i
 
13848
  real(kindr2) &  
 
13849
    ,intent(in)  :: app,am0i,am1i,rmu2
 
13850
  complex(kindr2) &   
 
13851
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
13852
  real(kindr2) &  
 
13853
    :: am0,am1,maxm
 
13854
  logical :: switch 
 
13855
  integer :: rank
 
13856
!
 
13857
  maxm = max(am0i,am1i)
 
13858
  if (maxm.eq.RZRO) then
 
13859
    if (app.eq.RZRO) then
 
13860
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
13861
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
13862
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
13863
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
13864
      return
 
13865
    endif
 
13866
  endif
 
13867
!
 
13868
  if (am1i.ge.maxm) then
 
13869
    m0=m0i ;am0=am0i
 
13870
    m1=m1i ;am1=am1i
 
13871
    switch = .false. 
 
13872
  else
 
13873
    m0=m1i ;am0=am1i
 
13874
    m1=m0i ;am1=am0i
 
13875
    switch = .true. 
 
13876
  endif
 
13877
!
 
13878
  b0(2) = 0
 
13879
  b0(1) = CONE
 
13880
  b1(2) = 0      
 
13881
  b1(1) =-CONE/2 
 
13882
  b11(2) = 0      
 
13883
  b11(1) = CONE/3 
 
13884
!
 
13885
  if (app.eq.RZRO) then
 
13886
    if (abs(m0-m1).le.am1*EPSN*10) then
 
13887
      lna = -logc(qonv(m1/rmu2,-1))
 
13888
      b0(0) = lna
 
13889
      b1(0) =-lna/2 
 
13890
      b11(0) = lna/3 
 
13891
    else
 
13892
      lna = -logc(qonv(m1/rmu2,-1))
 
13893
      x1 = (m1-am1*IEPS)/(m1-m0)
 
13894
      b0(0) =   lna - bnlog(0,x1)
 
13895
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
13896
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
13897
    endif
 
13898
    if (switch) then
 
13899
      x2=m0;m0=m1;m1=x2
 
13900
    else
 
13901
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
13902
      b1(0) =-b0(0)-b1(0)
 
13903
    endif
 
13904
  elseif (am0.eq.RZRO) then
 
13905
    if (abs(pp-m1).le.am1*EPSN*10) then
 
13906
      lna = -logc(qonv(m1/rmu2,-1))
 
13907
      b0(0) = ( lna   + 2 )
 
13908
      b1(0) =-( lna*2 + 2 )/4 
 
13909
      b11(0) = ( lna*3 + 2 )/9 
 
13910
    else
 
13911
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
13912
      x1  = (pp-m1+am1*IEPS)/pp
 
13913
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
13914
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
13915
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
13916
    endif
 
13917
    if (switch) then
 
13918
      x2=m0;m0=m1;m1=x2
 
13919
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
13920
      b1(0) =-b0(0)-b1(0)
 
13921
    endif
 
13922
  else
 
13923
    lna = -logc(qonv(m0/rmu2,-1))
 
13924
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
13925
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
13926
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
13927
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
13928
    if (switch) then
 
13929
      x2=m0;m0=m1;m1=x2
 
13930
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
13931
      b1(0) =-b0(0)-b1(0)
 
13932
    endif
 
13933
  endif
 
13934
!
 
13935
  rank = 0 
 
13936
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
13937
  x1 = (m1-m0)-pp
 
13938
  x2 = 2*m0
 
13939
  b00(2) = 0
 
13940
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
13941
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
13942
  end subroutine
 
13943
 
 
13944
  subroutine bub111( b111,b001,b11,b00,b1,b0 &
 
13945
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
13946
  complex(kindr2) &   
 
13947
    ,intent(out) :: b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
13948
  complex(kindr2) &   
 
13949
    ,intent(in)  :: pp,m0i,m1i
 
13950
  real(kindr2) &  
 
13951
    ,intent(in)  :: app,am0i,am1i,rmu2
 
13952
  complex(kindr2) &   
 
13953
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
13954
  real(kindr2) &  
 
13955
    :: am0,am1,maxm
 
13956
  logical :: switch 
 
13957
  integer :: rank
 
13958
!
 
13959
  maxm = max(am0i,am1i)
 
13960
  if (maxm.eq.RZRO) then
 
13961
    if (app.eq.RZRO) then
 
13962
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
13963
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
13964
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
13965
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
13966
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
13967
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
13968
      return
 
13969
    endif
 
13970
  endif
 
13971
!
 
13972
  if (am1i.ge.maxm) then
 
13973
    m0=m0i ;am0=am0i
 
13974
    m1=m1i ;am1=am1i
 
13975
    switch = .false. 
 
13976
  else
 
13977
    m0=m1i ;am0=am1i
 
13978
    m1=m0i ;am1=am0i
 
13979
    switch = .true. 
 
13980
  endif
 
13981
!
 
13982
  b0(2) = 0
 
13983
  b0(1) = CONE
 
13984
  b1(2) = 0      
 
13985
  b1(1) =-CONE/2 
 
13986
  b11(2) = 0      
 
13987
  b11(1) = CONE/3 
 
13988
  b111(2) = 0      
 
13989
  b111(1) =-CONE/4 
 
13990
!
 
13991
  if (app.eq.RZRO) then
 
13992
    if (abs(m0-m1).le.am1*EPSN*10) then
 
13993
      lna = -logc(qonv(m1/rmu2,-1))
 
13994
      b0(0) = lna
 
13995
      b1(0) =-lna/2 
 
13996
      b11(0) = lna/3 
 
13997
      b111(0) =-lna/4 
 
13998
    else
 
13999
      lna = -logc(qonv(m1/rmu2,-1))
 
14000
      x1 = (m1-am1*IEPS)/(m1-m0)
 
14001
      b0(0) =   lna - bnlog(0,x1)
 
14002
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
14003
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
14004
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
14005
    endif
 
14006
    if (switch) then
 
14007
      x2=m0;m0=m1;m1=x2
 
14008
    else
 
14009
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14010
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14011
      b1(0) =-b0(0)-b1(0)
 
14012
    endif
 
14013
  elseif (am0.eq.RZRO) then
 
14014
    if (abs(pp-m1).le.am1*EPSN*10) then
 
14015
      lna = -logc(qonv(m1/rmu2,-1))
 
14016
      b0(0) = ( lna   + 2 )
 
14017
      b1(0) =-( lna*2 + 2 )/4 
 
14018
      b11(0) = ( lna*3 + 2 )/9 
 
14019
      b111(0) =-( lna*4 + 2 )/16 
 
14020
    else
 
14021
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
14022
      x1  = (pp-m1+am1*IEPS)/pp
 
14023
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
14024
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
14025
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
14026
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
14027
    endif
 
14028
    if (switch) then
 
14029
      x2=m0;m0=m1;m1=x2
 
14030
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14031
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14032
      b1(0) =-b0(0)-b1(0)
 
14033
    endif
 
14034
  else
 
14035
    lna = -logc(qonv(m0/rmu2,-1))
 
14036
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
14037
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
14038
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
14039
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
14040
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
14041
    if (switch) then
 
14042
      x2=m0;m0=m1;m1=x2
 
14043
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14044
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14045
      b1(0) =-b0(0)-b1(0)
 
14046
    endif
 
14047
  endif
 
14048
!
 
14049
  rank = 0 
 
14050
  rank = 1 
 
14051
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
14052
  x1 = (m1-m0)-pp
 
14053
  x2 = 2*m0
 
14054
  b00(2) = 0
 
14055
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
14056
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
14057
  b001(2) = 0
 
14058
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
14059
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
14060
  end subroutine
 
14061
 
 
14062
  subroutine bub1111( b1111,b0011,b0000,b111,b001,b11,b00,b1,b0 &
 
14063
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
14064
  complex(kindr2) &   
 
14065
    ,intent(out) :: b1111(0:2),b0011(0:2),b0000(0:2) &
 
14066
                   ,b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
14067
  complex(kindr2) &   
 
14068
    ,intent(in)  :: pp,m0i,m1i
 
14069
  real(kindr2) &  
 
14070
    ,intent(in)  :: app,am0i,am1i,rmu2
 
14071
  complex(kindr2) &   
 
14072
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
14073
  real(kindr2) &  
 
14074
    :: am0,am1,maxm
 
14075
  logical :: switch 
 
14076
  integer :: rank
 
14077
!
 
14078
  maxm = max(am0i,am1i)
 
14079
  if (maxm.eq.RZRO) then
 
14080
    if (app.eq.RZRO) then
 
14081
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
14082
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
14083
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
14084
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
14085
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
14086
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
14087
      b0000(0)=0 ;b0000(1)=0 ;b0000(2)=0 
 
14088
      b0011(0)=0 ;b0011(1)=0 ;b0011(2)=0 
 
14089
      b1111(0)=0 ;b1111(1)=0 ;b1111(2)=0 
 
14090
      return
 
14091
    endif
 
14092
  endif
 
14093
!
 
14094
  if (am1i.ge.maxm) then
 
14095
    m0=m0i ;am0=am0i
 
14096
    m1=m1i ;am1=am1i
 
14097
    switch = .false. 
 
14098
  else
 
14099
    m0=m1i ;am0=am1i
 
14100
    m1=m0i ;am1=am0i
 
14101
    switch = .true. 
 
14102
  endif
 
14103
!
 
14104
  b0(2) = 0
 
14105
  b0(1) = CONE
 
14106
  b1(2) = 0      
 
14107
  b1(1) =-CONE/2 
 
14108
  b11(2) = 0      
 
14109
  b11(1) = CONE/3 
 
14110
  b111(2) = 0      
 
14111
  b111(1) =-CONE/4 
 
14112
  b1111(2) = 0      
 
14113
  b1111(1) = CONE/5 
 
14114
!
 
14115
  if (app.eq.RZRO) then
 
14116
    if (abs(m0-m1).le.am1*EPSN*10) then
 
14117
      lna = -logc(qonv(m1/rmu2,-1))
 
14118
      b0(0) = lna
 
14119
      b1(0) =-lna/2 
 
14120
      b11(0) = lna/3 
 
14121
      b111(0) =-lna/4 
 
14122
      b1111(0) = lna/5 
 
14123
    else
 
14124
      lna = -logc(qonv(m1/rmu2,-1))
 
14125
      x1 = (m1-am1*IEPS)/(m1-m0)
 
14126
      b0(0) =   lna - bnlog(0,x1)
 
14127
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
14128
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
14129
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
14130
      b1111(0) = ( lna - bnlog(4,x1) )/5 
 
14131
    endif
 
14132
    if (switch) then
 
14133
      x2=m0;m0=m1;m1=x2
 
14134
    else
 
14135
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
14136
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14137
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14138
      b1(0) =-b0(0)-b1(0)
 
14139
    endif
 
14140
  elseif (am0.eq.RZRO) then
 
14141
    if (abs(pp-m1).le.am1*EPSN*10) then
 
14142
      lna = -logc(qonv(m1/rmu2,-1))
 
14143
      b0(0) = ( lna   + 2 )
 
14144
      b1(0) =-( lna*2 + 2 )/4 
 
14145
      b11(0) = ( lna*3 + 2 )/9 
 
14146
      b111(0) =-( lna*4 + 2 )/16 
 
14147
      b1111(0) = ( lna*5 + 2 )/25 
 
14148
    else
 
14149
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
14150
      x1  = (pp-m1+am1*IEPS)/pp
 
14151
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
14152
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
14153
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
14154
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
14155
      b1111(0) = ( (lna-bnlog(4,x1))*5 + 1 )/25 
 
14156
    endif
 
14157
    if (switch) then
 
14158
      x2=m0;m0=m1;m1=x2
 
14159
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
14160
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14161
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14162
      b1(0) =-b0(0)-b1(0)
 
14163
    endif
 
14164
  else
 
14165
    lna = -logc(qonv(m0/rmu2,-1))
 
14166
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
14167
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
14168
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
14169
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
14170
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
14171
    b1111(0) = ( lna - bnlog(4,x1) - bnlog(4,x2) )/5 
 
14172
    if (switch) then
 
14173
      x2=m0;m0=m1;m1=x2
 
14174
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
14175
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
14176
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
14177
      b1(0) =-b0(0)-b1(0)
 
14178
    endif
 
14179
  endif
 
14180
!
 
14181
  rank = 0 
 
14182
  rank = 1 
 
14183
  rank = 2 
 
14184
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
14185
  x1 = (m1-m0)-pp
 
14186
  x2 = 2*m0
 
14187
  b00(2) = 0
 
14188
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
14189
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
14190
  b001(2) = 0
 
14191
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
14192
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
14193
  b0000(2) = 0
 
14194
  b0000(1) = ( a0(1,1) - x1*b001(1) + x2*b00(1) )/10
 
14195
  b0000(0) = ( a0(0,1) - x1*b001(0) + x2*b00(0) + 4*b0000(1) )/10
 
14196
  b0011(2) = 0
 
14197
  b0011(1) = ( a0(1,0) - x1*b111(1) + x2*b11(1) )/10
 
14198
  b0011(0) = ( a0(0,0) - x1*b111(0) + x2*b11(0) + 4*b0011(1) )/10
 
14199
  end subroutine
 
14200
 
 
14201
end module
 
14202
 
 
14203
 
 
14204
module avh_olo_qp_tri
 
14205
  use avh_olo_units
 
14206
  use avh_olo_qp_prec
 
14207
  use avh_olo_qp_auxfun
 
14208
  use avh_olo_qp_qmplx
 
14209
  implicit none
 
14210
  private
 
14211
  public :: tria0,tria1,tria2,tria3,tria4,trif0,trif1,trif2,trif3 &
 
14212
           ,trif3HV &
 
14213
           ,permtable,casetable,base
 
14214
  integer ,parameter :: permtable(3,0:7)=reshape((/ &
 
14215
       1,2,3 &! 0, 0 masses non-zero, no permutation
 
14216
      ,1,2,3 &! 1, 1 mass non-zero,   no permutation
 
14217
      ,3,1,2 &! 2, 1 mass non-zero,   1 cyclic permutation
 
14218
      ,1,2,3 &! 3, 2 masses non-zero, no permutation
 
14219
      ,2,3,1 &! 4, 1 mass non-zero,   2 cyclic permutations
 
14220
      ,2,3,1 &! 5, 2 masses non-zero, 2 cyclic permutations
 
14221
      ,3,1,2 &! 6, 2 masses non-zero, 1 cyclic permutation
 
14222
      ,1,2,3 &! 7, 3 masses non-zero, no permutation
 
14223
      /) ,(/3,8/))                     ! 0,1,2,3,4,5,6,7
 
14224
  integer ,parameter :: casetable(0:7)=(/0,1,1,2,1,2,2,3/)
 
14225
  integer ,parameter :: base(3)=(/4,2,1/)
 
14226
 
 
14227
contains
 
14228
 
 
14229
   subroutine tria4( rslt ,cpp,cm2,cm3 ,rmu2 )
 
14230
!*******************************************************************
 
14231
! calculates
 
14232
!               C   /             d^(Dim)q
 
14233
!            ------ | ----------------------------------
 
14234
!            i*pi^2 / q^2 [(q+k1)^2-m2] [(q+k1+k2)^2-m3]
 
14235
!
 
14236
! with  k1^2=m2, k2^2=pp, (k1+k2)^2=m3.
 
14237
! m2,m3 should NOT be identically 0d0.
 
14238
!*******************************************************************
 
14239
  complex(kindr2) &   
 
14240
     ,intent(out) :: rslt(0:2)
 
14241
  complex(kindr2) &   
 
14242
     ,intent(in)  :: cm2,cm3,cpp
 
14243
  real(kindr2) &  
 
14244
     ,intent(in)  :: rmu2
 
14245
   type(qmplx_type) :: q23,qm3,q32
 
14246
  complex(kindr2) &   
 
14247
     :: sm2,sm3,k23,r23,d23,cc
 
14248
!
 
14249
   sm2 = mysqrt(cm2)
 
14250
   sm3 = mysqrt(cm3)
 
14251
   k23 = (cm2+cm3-cpp)/(sm2*sm3)
 
14252
   call rfun( r23,d23, k23 )
 
14253
   if (r23.eq.-CONE) then
 
14254
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop tria4: ' &
 
14255
       ,'threshold singularity, returning 0'
 
14256
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14257
     return
 
14258
   endif
 
14259
   q23 = qonv(r23,-1)
 
14260
   qm3 = qonv(cm3/rmu2,-1)
 
14261
   q32 = qonv(sm3)/qonv(sm2)
 
14262
!
 
14263
   rslt(2) = 0
 
14264
   cc = logc2(q23) * r23/(1+r23)/(sm2*sm3)
 
14265
   rslt(1) = -cc
 
14266
   rslt(0) = cc*( logc(qm3) - logc(q23) ) &
 
14267
           - li2c2(q32*q23,q32/q23) / cm2 &
 
14268
           + li2c2(q23*q23,qonv(1)) * r23/(sm2*sm3)
 
14269
   end subroutine
 
14270
 
 
14271
 
 
14272
   subroutine tria3( rslt ,cp2,cp3,cm3 ,rmu2 )
 
14273
!*******************************************************************
 
14274
! calculates
 
14275
!               C   /          d^(Dim)q
 
14276
!            ------ | -----------------------------
 
14277
!            i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
 
14278
!
 
14279
! with  p2=k2^2, p3=(k1+k2)^2.
 
14280
! mm should NOT be identically 0d0,
 
14281
! and p2 NOR p3 should be identical to mm. 
 
14282
!*******************************************************************
 
14283
  complex(kindr2) &   
 
14284
     ,intent(out) :: rslt(0:2)
 
14285
  complex(kindr2) &   
 
14286
     ,intent(in)  :: cp2,cp3,cm3
 
14287
  real(kindr2) &  
 
14288
     ,intent(in)  :: rmu2
 
14289
   type(qmplx_type) :: q13,q23,qm3,x1,x2
 
14290
  complex(kindr2) &   
 
14291
     :: r13,r23
 
14292
!
 
14293
   r13 = cm3-cp3
 
14294
   r23 = cm3-cp2
 
14295
   q13 = qonv(r13,-1)
 
14296
   q23 = qonv(r23,-1)
 
14297
   qm3 = qonv(cm3,-1)
 
14298
   x1 = q23/qm3
 
14299
   x2 = q13/qm3
 
14300
   rslt(2) = 0
 
14301
   rslt(1) = -logc2( q23/q13 )/r13
 
14302
   rslt(0) = -li2c2( x1,x2 )/cm3 &
 
14303
           - rslt(1)*( logc(x1*x2)+logc(qm3/rmu2) )
 
14304
   end subroutine
 
14305
 
 
14306
 
 
14307
   subroutine tria2( rslt ,cp3,cm3 ,rmu2 )
 
14308
!*******************************************************************
 
14309
! calculates
 
14310
!               C   /          d^(Dim)q
 
14311
!            ------ | -----------------------------
 
14312
!            i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
 
14313
!
 
14314
! with  k1^2 = 0 , k2^2 = m3  and  (k1+k2)^2 = p3.
 
14315
! mm should NOT be identically 0d0,
 
14316
! and pp should NOT be identical to mm. 
 
14317
!*******************************************************************
 
14318
  complex(kindr2) &   
 
14319
     ,intent(out) :: rslt(0:2)
 
14320
  complex(kindr2) &   
 
14321
     ,intent(in)  :: cp3,cm3
 
14322
  real(kindr2) &  
 
14323
     ,intent(in)  :: rmu2
 
14324
   type(qmplx_type) :: q13,qm3,qxx
 
14325
  complex(kindr2) &   
 
14326
     :: r13,logm,z2,z1,z0,cc
 
14327
!
 
14328
   r13 = cm3-cp3
 
14329
   q13 = qonv(r13,-1)
 
14330
   qm3 = qonv(cm3,-1)
 
14331
   logm = logc( qm3/rmu2 )
 
14332
   qxx = qm3/q13
 
14333
   z2 = 1 
 
14334
   z2 = z2/2
 
14335
   z1 = logc(qxx)
 
14336
   z0 = PISQo24 + z1*z1/2 - li2c(qxx)
 
14337
   cc = -1/r13
 
14338
   rslt(2) = cc*z2
 
14339
   rslt(1) = cc*(z1 - z2*logm)
 
14340
   rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
 
14341
   end subroutine
 
14342
 
 
14343
 
 
14344
   subroutine tria1( rslt ,cm3 ,rmu2 )
 
14345
!*******************************************************************
 
14346
! calculates
 
14347
!               C   /          d^(Dim)q
 
14348
!            ------ | -----------------------------
 
14349
!            i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3]
 
14350
!
 
14351
! with  k1^2 = (k1+k2)^2 = m3.
 
14352
! mm should NOT be identically 0d0.
 
14353
!*******************************************************************
 
14354
  complex(kindr2) &   
 
14355
     ,intent(out) :: rslt(0:2)
 
14356
  complex(kindr2) &   
 
14357
     ,intent(in)  :: cm3
 
14358
  real(kindr2) &  
 
14359
     ,intent(in)  :: rmu2
 
14360
  complex(kindr2) &   
 
14361
     :: zm
 
14362
!
 
14363
   zm = 1/(2*cm3)
 
14364
   rslt(2) = 0
 
14365
   rslt(1) = -zm
 
14366
   rslt(0) = zm*( 2 + logc(qonv(cm3/rmu2,-1)) )
 
14367
   end subroutine
 
14368
 
 
14369
 
 
14370
   subroutine tria0( rslt ,cp ,ap ,rmu2 )
 
14371
!*******************************************************************
 
14372
! calculates
 
14373
!               C   /         d^(Dim)q
 
14374
!            ------ | ------------------------
 
14375
!            i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2
 
14376
!
 
14377
! with  Dim = 4-2*eps
 
14378
!         C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
 
14379
!
 
14380
! input:  p1 = k1^2,  p2 = k2^2,  p3 = k3^2
 
14381
! output: rslt(0) = eps^0   -coefficient
 
14382
!         rslt(1) = eps^(-1)-coefficient
 
14383
!         rslt(2) = eps^(-2)-coefficient
 
14384
!
 
14385
! If any of these numbers is IDENTICALLY 0d0, the corresponding
 
14386
! IR-singular case is returned.
 
14387
!*******************************************************************
 
14388
   use avh_olo_qp_olog
 
14389
  complex(kindr2) &   
 
14390
     ,intent(out) :: rslt(0:2)
 
14391
  complex(kindr2) &   
 
14392
     ,intent(in)  :: cp(3)
 
14393
  real(kindr2) &  
 
14394
     ,intent(in)  :: ap(3),rmu2
 
14395
  real(kindr2) &  
 
14396
     :: pp(3),rp1,rp2,rp3
 
14397
  complex(kindr2) &   
 
14398
     :: log2,log3
 
14399
   integer :: icase,i1,i2,i3
 
14400
!
 
14401
   pp(1)=areal(cp(1))
 
14402
   pp(2)=areal(cp(2))
 
14403
   pp(3)=areal(cp(3))
 
14404
!
 
14405
   icase = 0
 
14406
   if (ap(1).gt.RZRO) icase = icase + base(1)
 
14407
   if (ap(2).gt.RZRO) icase = icase + base(2)
 
14408
   if (ap(3).gt.RZRO) icase = icase + base(3)
 
14409
   rp1 = pp(permtable(1,icase))
 
14410
   rp2 = pp(permtable(2,icase))
 
14411
   rp3 = pp(permtable(3,icase))
 
14412
   icase  = casetable(  icase)
 
14413
!
 
14414
   i1=0 ;if (-rp1.lt.RZRO) i1=-1
 
14415
   i2=0 ;if (-rp2.lt.RZRO) i2=-1
 
14416
   i3=0 ;if (-rp3.lt.RZRO) i3=-1
 
14417
!
 
14418
   if     (icase.eq.0) then
 
14419
! 0 masses non-zero
 
14420
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop tria0: ' &
 
14421
       ,'all external masses equal zero, returning 0'
 
14422
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14423
   elseif (icase.eq.1) then
 
14424
! 1 mass non-zero
 
14425
    log3 = olog( abs(rp3/rmu2) ,i3 )
 
14426
    rslt(2) = 1/rp3
 
14427
    rslt(1) = -log3/rp3
 
14428
    rslt(0) = ( log3**2/2 - 2*PISQo24 )/rp3
 
14429
  elseif (icase.eq.2) then
 
14430
! 2 masses non-zero
 
14431
    log2 = olog( abs(rp2/rmu2) ,i2 )
 
14432
    log3 = olog( abs(rp3/rmu2) ,i3 )
 
14433
    rslt(2) = 0
 
14434
    rslt(1) = -olog2( abs(rp3/rp2) ,i3-i2 )/rp2
 
14435
    rslt(0) = -rslt(1)*(log3+log2)/2
 
14436
  elseif (icase.eq.3) then
 
14437
! 3 masses non-zero
 
14438
    call trif0( rslt ,cp(1),cp(2),cp(3) )
 
14439
  endif
 
14440
  end subroutine
 
14441
 
 
14442
 
 
14443
   subroutine trif0( rslt ,p1,p2,p3 )
 
14444
!*******************************************************************
 
14445
! Finite 1-loop scalar 3-point function with all internal masses
 
14446
! equal zero. Obtained from the formulas for 4-point functions in
 
14447
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
14448
! by sending one internal mass to infinity.
 
14449
!*******************************************************************
 
14450
  complex(kindr2) &   
 
14451
     ,intent(out) :: rslt(0:2)
 
14452
  complex(kindr2) &   
 
14453
     ,intent(in)  :: p1,p2,p3
 
14454
   type(qmplx_type) :: q23,q24,q34,qx1,qx2
 
14455
  complex(kindr2) &   
 
14456
     :: r23,r24,r34,aa,bb,cc,dd,x1,x2
 
14457
  real(kindr2) &  
 
14458
     :: hh
 
14459
!
 
14460
   r23 = -p1
 
14461
   r24 = -p3
 
14462
   r34 = -p2
 
14463
!
 
14464
   aa = r34*r24
 
14465
   bb = r24 + r34 - r23
 
14466
   cc = 1
 
14467
   hh = areal(r23)
 
14468
   dd = mysqrt( bb*bb - 4*aa*cc , -areal(aa)*hh )
 
14469
   call solabc( x1,x2,dd ,aa,bb,cc ,1 )
 
14470
   x1 = -x1
 
14471
   x2 = -x2
 
14472
!
 
14473
   qx1 = qonv(x1, hh)
 
14474
   qx2 = qonv(x2,-hh)
 
14475
   q23 = qonv(r23,-1)
 
14476
   q24 = qonv(r24,-1)
 
14477
   q34 = qonv(r34,-1)
 
14478
!
 
14479
   rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14480
!
 
14481
   rslt(0) = li2c2( qx1*q34 ,qx2*q34 )*r34 &
 
14482
           + li2c2( qx1*q24 ,qx2*q24 )*r24 &
 
14483
           - logc2( qx1/qx2 )*logc( qx1*qx2 )/(x2*2) &
 
14484
           - logc2( qx1/qx2 )*logc( q23 )/x2
 
14485
!
 
14486
   rslt(0) = rslt(0)/aa
 
14487
   end subroutine
 
14488
 
 
14489
 
 
14490
   subroutine trif1( rslt ,p1i,p2i,p3i ,m3i )
 
14491
!*******************************************************************
 
14492
! Finite 1-loop scalar 3-point function with one internal masses
 
14493
! non-zero. Obtained from the formulas for 4-point functions in
 
14494
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
14495
! by sending one internal mass to infinity.
 
14496
!*******************************************************************
 
14497
  complex(kindr2) &   
 
14498
     ,intent(out) :: rslt(0:2)
 
14499
  complex(kindr2) &   
 
14500
     ,intent(in)  :: p1i,p2i,p3i ,m3i 
 
14501
   type(qmplx_type) :: q23,q24,q34,qm4,qx1,qx2,qss
 
14502
  complex(kindr2) &   
 
14503
     :: p2,p3,p4,p12,p23,m4,sm2,sm3,sm4 &
 
14504
                     ,aa,bb,cc,dd,x1,x2,r23,r24,r34
 
14505
  real(kindr2) &  
 
14506
     :: mhh
 
14507
   logical :: r24Not0,r34Not0
 
14508
!
 
14509
!   p1 = nul
 
14510
   p2 = p1i
 
14511
   p3 = p2i
 
14512
   p4 = p3i
 
14513
   p12 = p1i
 
14514
   p23 = p3i
 
14515
!   m1 = infinite
 
14516
!   m2 = m1i = 0
 
14517
!   m3 = m2i = 0
 
14518
   m4 = m3i
 
14519
!
 
14520
   sm4 = mysqrt(m4)
 
14521
   mhh = abs(sm4)
 
14522
   sm3 = mhh
 
14523
   sm2 = sm3
 
14524
!
 
14525
   r23 = (   -p2 -p2 *IEPS )/(sm2*sm3)
 
14526
   r24 = ( m4-p23-p23*IEPS )/(sm2*sm4)
 
14527
   r34 = ( m4-p3 -p3 *IEPS )/(sm3*sm4)
 
14528
!
 
14529
   r24Not0 = (abs(areal(r24))+abs(aimag(r24)).ge.neglig(prcpar))
 
14530
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
 
14531
!
 
14532
   aa = r34*r24 - r23
 
14533
!
 
14534
   if (aa.eq.CZRO) then
 
14535
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif1: ' &
 
14536
       ,'threshold singularity, returning 0'
 
14537
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14538
     return
 
14539
   endif
 
14540
!
 
14541
   bb = r24/sm3 + r34/sm2 - r23/sm4
 
14542
   cc = 1/(sm2*sm3)
 
14543
!   hh = areal(r23)
 
14544
!   dd = mysqrt( bb*bb - 4*aa*cc , -areal(aa)*hh )
 
14545
   call solabc( x1,x2,dd ,aa,bb,cc ,0 )
 
14546
   x1 = -x1
 
14547
   x2 = -x2
 
14548
!
 
14549
   qx1 = qonv(x1 ,1) ! x1 SHOULD HAVE im. part
 
14550
   qx2 = qonv(x2 ,1) ! x2 SHOULD HAVE im. part
 
14551
   q23 = qonv(r23,-1)
 
14552
   q24 = qonv(r24,-1)
 
14553
   q34 = qonv(r34,-1)
 
14554
   qm4 = qonv(sm4,-1)
 
14555
!
 
14556
   rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14557
!
 
14558
   rslt(0) = -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) )/(x2*2) &
 
14559
             -li2c2( qx1*qm4 ,qx2*qm4 )*sm4
 
14560
!
 
14561
   if (r34Not0) then
 
14562
     qss = q34*mhh
 
14563
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
 
14564
   endif
 
14565
!
 
14566
   if (r24Not0) then
 
14567
     qss = q24*mhh
 
14568
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24*sm2
 
14569
   endif
 
14570
!
 
14571
   rslt(0) = rslt(0) - logc2( qx1/qx2 )*logc( q23*(mhh*mhh) )/x2
 
14572
!
 
14573
   rslt(0) = rslt(0)/(aa*sm2*sm3*sm4)
 
14574
   end subroutine
 
14575
 
 
14576
 
 
14577
   subroutine trif2( rslt ,p1i,p2i,p3i ,m2i,m3i )
 
14578
!*******************************************************************
 
14579
! Finite 1-loop scalar 3-point function with two internal masses
 
14580
! non-zero. Obtained from the formulas for 4-point functions in
 
14581
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
14582
! by sending one internal mass to infinity.
 
14583
!*******************************************************************
 
14584
  complex(kindr2) &   
 
14585
     ,intent(out) :: rslt(0:2)
 
14586
  complex(kindr2) &   
 
14587
     ,intent(in)  :: p1i,p2i,p3i ,m2i,m3i
 
14588
   type(qmplx_type) :: q23,q34,q24,qm2,qm3,qm4,qx1,qx2,qss,qy1,qy2
 
14589
  complex(kindr2) &   
 
14590
     :: p2,p3,p23,m2,m4,sm2,sm3,sm4,aa,bb,cc,dd,x1,x2 &
 
14591
                     ,r23,k24,r34,r24,d24
 
14592
   logical :: r23Not0,r34Not0
 
14593
!
 
14594
!   p1 = nul
 
14595
   p2 = p3i
 
14596
   p3 = p1i
 
14597
!   p4 = p2i
 
14598
!   p12 = p3i
 
14599
   p23 = p2i
 
14600
!   m1 = infinite
 
14601
   m2 = m3i
 
14602
!   m3 = m1i = 0
 
14603
   m4 = m2i
 
14604
!
 
14605
!   sm1 = infinite
 
14606
   sm2 = mysqrt(m2)
 
14607
   sm3 = abs(sm2) !mysqrt(m3)
 
14608
   sm4 = mysqrt(m4)
 
14609
!
 
14610
   r23 = (    m2-p2 -p2 *IEPS )/(sm2*sm3) ! p2
 
14611
   k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
 
14612
   r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
14613
!
 
14614
   r23Not0 = (abs(areal(r23))+abs(aimag(r23)).ge.neglig(prcpar))
 
14615
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
 
14616
!
 
14617
   call rfun( r24,d24 ,k24 )
 
14618
!
 
14619
   aa = r34/r24 - r23
 
14620
!
 
14621
   if (aa.eq.CZRO) then
 
14622
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif2: ' &
 
14623
       ,'threshold singularity, returning 0'
 
14624
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14625
     return
 
14626
   endif
 
14627
!
 
14628
   bb = -d24/sm3 + r34/sm2 - r23/sm4
 
14629
   cc = (sm4/sm2 - r24)/(sm3*sm4)
 
14630
!   hh = areal(r23 - r24*r34)
 
14631
!   dd = mysqrt( bb*bb - 4*aa*cc , -areal(aa)*hh )
 
14632
   call solabc(x1,x2,dd ,aa,bb,cc ,0)
 
14633
   x1 = -x1
 
14634
   x2 = -x2
 
14635
!
 
14636
   qx1 = qonv(x1 ,1 ) ! x1 SHOULD HAVE im. part
 
14637
   qx2 = qonv(x2 ,1 ) ! x2 SHOULD HAVE im. part
 
14638
   q23 = qonv(r23,-1)
 
14639
   q24 = qonv(r24,-1)
 
14640
   q34 = qonv(r34,-1)
 
14641
   qm2 = qonv(sm2,-1)
 
14642
   qm3 = qonv(sm3,-1)
 
14643
   qm4 = qonv(sm4,-1)
 
14644
!
 
14645
   rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14646
!
 
14647
   qy1 = qx1/q24
 
14648
   qy2 = qx2/q24
 
14649
!
 
14650
   rslt(0) = li2c2( qy1*qm2 ,qy2*qm2 )/r24*sm2
 
14651
!
 
14652
   if (x2.ne.CZRO) then ! better to put a threshold on cc 
 
14653
     rslt(0) = rslt(0) + ( logc2( qy1/qy2 )*logc( qy1*qy2/(qm2*qm2) ) &
 
14654
                          -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) ) )/(x2*2)
 
14655
   endif
 
14656
!
 
14657
   rslt(0) = rslt(0) - li2c2( qx1*qm4 ,qx2*qm4 )*sm4
 
14658
!
 
14659
   if (r23Not0) then
 
14660
     qss = q23*qm3/q24
 
14661
     rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23*sm3/r24
 
14662
   endif
 
14663
!
 
14664
   if (r34Not0) then
 
14665
     qss = q34*qm3
 
14666
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
 
14667
   endif
 
14668
!
 
14669
   rslt(0) = rslt(0)/(aa*sm2*sm3*sm4)
 
14670
   end subroutine
 
14671
 
 
14672
 
 
14673
   subroutine trif3( rslt ,p1i,p2i,p3i ,m1i,m2i,m3i )
 
14674
!*******************************************************************
 
14675
! Finite 1-loop scalar 3-point function with all internal masses
 
14676
! non-zero. Obtained from the formulas for 4-point functions in
 
14677
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
14678
! by sending one internal mass to infinity.
 
14679
!*******************************************************************
 
14680
  complex(kindr2) &   
 
14681
     ,intent(out) :: rslt(0:2)
 
14682
  complex(kindr2) &   
 
14683
     ,intent(in)  :: p1i,p2i,p3i,m1i,m2i,m3i
 
14684
   type(qmplx_type) :: q12,q13,q23,qm1,qm2,qm3,qx1,qx2,qz1,qz2,qtt
 
14685
  complex(kindr2) &   
 
14686
     :: p1,p2,p3,m1,m2,m3,sm1,sm2,sm3,aa,bb,cc,dd,x1,x2 &
 
14687
                     ,k12,k13,k23,r12,r13,r23,d12,d13,d23 
 
14688
  real(kindr2) &  
 
14689
     :: h1,h2,h3
 
14690
!
 
14691
   h1 = -aimag(m1i)
 
14692
   h2 = -aimag(m2i)
 
14693
   h3 = -aimag(m3i)
 
14694
   if (h2.ge.h1.and.h2.ge.h3) then
 
14695
     p1=p3i ;p2=p1i ;p3=p2i ;m1=m3i ;m2=m1i ;m3=m2i
 
14696
   else
 
14697
     p1=p1i ;p2=p2i ;p3=p3i ;m1=m1i ;m2=m2i ;m3=m3i
 
14698
   endif
 
14699
!
 
14700
   sm1 = mysqrt(m1)
 
14701
   sm2 = mysqrt(m2)
 
14702
   sm3 = mysqrt(m3)
 
14703
!
 
14704
   k12 = 0
 
14705
   k13 = 0
 
14706
   k23 = 0
 
14707
   if (m1+m2.ne.p1) k12 = ( m1+m2-p1-p1*IEPS )/(sm1*sm2) ! p1
 
14708
   if (m1+m3.ne.p3) k13 = ( m1+m3-p3-p3*IEPS )/(sm1*sm3) ! p1+p2 => p12
 
14709
   if (m2+m3.ne.p2) k23 = ( m2+m3-p2-p2*IEPS )/(sm2*sm3) ! p2
 
14710
!
 
14711
   call rfun( r12,d12 ,k12 )
 
14712
   call rfun( r13,d13 ,k13 )
 
14713
   call rfun( r23,d23 ,k23 )
 
14714
!
 
14715
   aa = sm2/sm3 - k23 + r13*(k12 - sm2/sm1)
 
14716
!
 
14717
   if (aa.eq.CZRO) then
 
14718
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3: ' &
 
14719
       ,'threshold singularity, returning 0'
 
14720
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14721
     return
 
14722
   endif
 
14723
!
 
14724
   bb = d13/sm2 + k12/sm3 - k23/sm1
 
14725
   cc = ( sm1/sm3 - 1/r13 )/(sm1*sm2)
 
14726
!   hh = areal( (r13-sm1/sm3)/(sm1*sm2) )
 
14727
!   dd = mysqrt( bb*bb - 4*aa*cc , -areal(aa)*hh )
 
14728
   call solabc( x1,x2,dd ,aa,bb,cc ,0 )
 
14729
   x1 = -x1
 
14730
   x2 = -x2
 
14731
!
 
14732
   qx1 = qonv(x1 ,1) ! x1 SHOULD HAVE im. part
 
14733
   qx2 = qonv(x2 ,1) ! x2 SHOULD HAVE im. part
 
14734
   q12 = qonv(r12,-1)
 
14735
   q13 = qonv(r13,-1)
 
14736
   q23 = qonv(r23,-1)
 
14737
   qm1 = qonv(sm1,-1)
 
14738
   qm2 = qonv(sm2,-1)
 
14739
   qm3 = qonv(sm3,-1)
 
14740
!
 
14741
   rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14742
!
 
14743
   qz1 = qx1*qm2
 
14744
   qz2 = qx2*qm2
 
14745
   rslt(0) = rslt(0) + ( li2c2( qz1*q12 ,qz2*q12 )*r12 &
 
14746
                        +li2c2( qz1/q12 ,qz2/q12 )/r12 )*sm2
 
14747
   qtt = q13*qm2
 
14748
   qz1 = qx1*qtt
 
14749
   qz2 = qx2*qtt
 
14750
   rslt(0) = rslt(0) - ( li2c2( qz1*q23 ,qz2*q23 )*r23 &
 
14751
                        +li2c2( qz1/q23 ,qz2/q23 )/r23 )*r13*sm2
 
14752
   qz1 = qx1*q13
 
14753
   qz2 = qx2*q13
 
14754
   rslt(0) = rslt(0) + li2c2( qz1*qm3 ,qz2*qm3 )*r13*sm3 &
 
14755
                     - li2c2( qx1*qm1 ,qx2*qm1 )*sm1
 
14756
   if (x2.ne.CZRO) then
 
14757
     rslt(0) = rslt(0) + ( logc2( qz1/qz2 )*logc( qz1*qz2/(qm3*qm3) ) &
 
14758
                          -logc2( qx1/qx2 )*logc( qx1*qx2/(qm1*qm1) ) )/(x2*2)
 
14759
   endif
 
14760
!
 
14761
   rslt(0) = rslt(0)/(aa*sm1*sm2*sm3)
 
14762
   end subroutine
 
14763
   
 
14764
 
 
14765
   subroutine trif3HV( rslt ,pp,mm ,ap ,smax ,lam )
 
14766
!*******************************************************************
 
14767
! Finite 1-loop scalar 3-point function with all internal masses
 
14768
! non-zero. Based on the fomula of 't Hooft & Veltman
 
14769
!*******************************************************************
 
14770
  complex(kindr2) &   
 
14771
     ,intent(out) :: rslt(0:2)
 
14772
  complex(kindr2) &   
 
14773
     ,intent(in)  :: pp(3),mm(3)
 
14774
  real(kindr2) &  
 
14775
     ,intent(in)  :: ap(3),smax
 
14776
  complex(kindr2) &   
 
14777
     ,optional ,intent(in) :: lam
 
14778
  complex(kindr2) &   
 
14779
     :: p1,p2,p3,m1,m2,m3,slam,yy
 
14780
  complex(kindr2) &   
 
14781
     :: sm1,sm2,sm3
 
14782
   type(qmplx_type) :: qm1,qm2,qm3
 
14783
  real(kindr2) &  
 
14784
     :: a12,a23,a31,thrs,a1,a2,a3
 
14785
!
 
14786
! Order squared momenta, first one smallest
 
14787
   if     (ap(1).le.ap(2).and.ap(1).le.ap(3)) then
 
14788
     if (ap(2).le.ap(3)) then
 
14789
       a1=ap(1) ;a2=ap(2) ;a3=ap(3)
 
14790
       p1=pp(1) ;p2=pp(2) ;p3=pp(3)
 
14791
       m1=mm(1) ;m2=mm(2) ;m3=mm(3)
 
14792
     else
 
14793
       a1=ap(1) ;a2=ap(3) ;a3=ap(2)
 
14794
       p1=pp(1) ;p2=pp(3) ;p3=pp(2)
 
14795
       m1=mm(2) ;m2=mm(1) ;m3=mm(3)
 
14796
     endif
 
14797
   elseif (ap(2).le.ap(3).and.ap(2).le.ap(1)) then
 
14798
     if (ap(3).le.ap(1)) then
 
14799
       a1=ap(2) ;a2=ap(3) ;a3=ap(1)
 
14800
       p1=pp(2) ;p2=pp(3) ;p3=pp(1)
 
14801
       m1=mm(2) ;m2=mm(3) ;m3=mm(1)
 
14802
     else
 
14803
       a1=ap(2) ;a2=ap(1) ;a3=ap(3)
 
14804
       p1=pp(2) ;p2=pp(1) ;p3=pp(3)
 
14805
       m1=mm(3) ;m2=mm(2) ;m3=mm(1)
 
14806
     endif
 
14807
   else
 
14808
     if (ap(1).le.ap(2)) then
 
14809
       a1=ap(3) ;a2=ap(1) ;a3=ap(2)
 
14810
       p1=pp(3) ;p2=pp(1) ;p3=pp(2)
 
14811
       m1=mm(3) ;m2=mm(1) ;m3=mm(2)
 
14812
     else
 
14813
       a1=ap(3) ;a2=ap(2) ;a3=ap(1)
 
14814
       p1=pp(3) ;p2=pp(2) ;p3=pp(1)
 
14815
       m1=mm(1) ;m2=mm(3) ;m3=mm(2)
 
14816
     endif
 
14817
   endif
 
14818
!
 
14819
! Need to cut out negligible squared momenta
 
14820
   thrs = smax*neglig(prcpar)
 
14821
!
 
14822
! Add infinitesimal imaginary parts to masses
 
14823
   m1 = m1 - abs(areal(m1))*IEPS
 
14824
   m2 = m2 - abs(areal(m2))*IEPS
 
14825
   m3 = m3 - abs(areal(m3))*IEPS
 
14826
!       
 
14827
   if (a1.gt.thrs) then ! 3 non-zero squared momenta
 
14828
     if (present(lam)) then ;slam=lam
 
14829
                       else ;slam=kallen(p1,p2,p3)
 
14830
     endif
 
14831
     if (slam.eq.CZRO) then
 
14832
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3HV: ' &
 
14833
         ,'threshold singularity, returning 0'
 
14834
       rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14835
       return
 
14836
     endif
 
14837
     slam = mysqrt( slam ,1 )
 
14838
     sm1=mysqrt(m1,-1) ;sm2=mysqrt(m2,-1) ;sm3=mysqrt(m3,-1)
 
14839
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14840
     rslt(0) = s3fun( p1,sm1,sm2 , (m2-m3)+p2    ,p3-p1-p2 ,p2 ,slam ) &
 
14841
             - s3fun( p3,sm1,sm3 ,-(m1-m2)+p3-p2 ,p2-p1-p3 ,p1 ,slam ) &
 
14842
             + s3fun( p2,sm2,sm3 ,-(m1-m2)+p3-p2 ,p1+p2-p3 ,p1 ,slam )
 
14843
     rslt(0) = -rslt(0)/slam
 
14844
!
 
14845
   elseif (a2.gt.thrs) then ! 2 non-zero squared momenta
 
14846
     if (p2.eq.p3) then
 
14847
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop trif3HV: ' &
 
14848
         ,'threshold singularity, returning 0'
 
14849
       rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14850
       return
 
14851
     endif
 
14852
     sm1=mysqrt(m1,-1) ;sm2=mysqrt(m2,-1) ;sm3=mysqrt(m3,-1)
 
14853
     yy = ( (m1-m2)-p3+p2 )/( p2-p3 )
 
14854
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14855
     rslt(0) = s3fun( p3,sm1,sm3 ,yy ) - s3fun( p2,sm2,sm3 ,yy )
 
14856
     rslt(0) = rslt(0)/(p2-p3)
 
14857
!
 
14858
   elseif (a3.gt.thrs) then ! 1 non-zero squared momentum
 
14859
     sm1=mysqrt(m1,-1) ;sm3=mysqrt(m3,-1)
 
14860
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14861
     yy = -( (m1-m2)-p3 )/p3
 
14862
     rslt(0) = s3fun( p3,sm1,sm3 ,yy ) - s2fun( m2-m3 ,m3 ,yy )
 
14863
     rslt(0) = -rslt(0)/p3
 
14864
!
 
14865
   else ! all squared momenta zero
 
14866
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
14867
     a12=abs(m1-m2) ;a23=abs(m2-m3) ;a31=abs(m3-m1)
 
14868
     if     (a12.ge.a23.and.a12.ge.a31) then
 
14869
       if (a12.eq.RZRO) then ;rslt(0)=-1/(2*m3) ;else
 
14870
       qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
 
14871
       rslt(0) = ( logc2(qm3/qm1) - logc2(qm3/qm2) )/(m1-m2)
 
14872
       endif
 
14873
     elseif (a23.ge.a12.and.a23.ge.a31) then
 
14874
       if (a23.eq.RZRO) then ;rslt(0)=-1/(2*m1) ;else
 
14875
       qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
 
14876
       rslt(0) = ( logc2(qm1/qm2) - logc2(qm1/qm3) )/(m2-m3)
 
14877
       endif
 
14878
     else
 
14879
       if (a31.eq.RZRO) then ;rslt(0)=-1/(2*m2) ;else
 
14880
       qm1=qonv(m1) ;qm2=qonv(m2) ;qm3=qonv(m3)
 
14881
       rslt(0) = ( logc2(qm2/qm3) - logc2(qm2/qm1) )/(m3-m1)
 
14882
       endif
 
14883
     endif
 
14884
   endif
 
14885
!
 
14886
   contains
 
14887
!
 
14888
     function s3fun( aa,s1,s2 ,t1,t2,t3,t4 ) result(rslt)
 
14889
!***************************************************************
 
14890
! int( ( ln(a*y^2+b*y+c) - ln(a*y0^2+b*y0+c) )/(y-y0) ,y=0..1 )
 
14891
! with  b=s1^2-s2^2-aa  and  c=s2^2
 
14892
! and with  y0  in terms of t1,t2,t3,t4 defined at the "present"
 
14893
! function below.
 
14894
! t4  should be  sqrt(lambda(aa,t2,t3))
 
14895
!***************************************************************
 
14896
  complex(kindr2) &   
 
14897
       ,intent(in) :: aa,s1,s2,t1
 
14898
  complex(kindr2) &   
 
14899
       ,optional,intent(in) :: t2,t3
 
14900
  complex(kindr2) &   
 
14901
       ,optional,intent(inout) :: t4
 
14902
  complex(kindr2) &   
 
14903
       :: rslt ,cc,bb,dd,y0,y1,y2,zz,hh,alpha
 
14904
  real(kindr2) &  
 
14905
       :: rez,arez,aimz
 
14906
     type(qmplx_type) :: q1,q2
 
14907
!
 
14908
     bb = (s1+s2)*(s1-s2)-aa
 
14909
     cc = s2*s2
 
14910
     dd = (aa-(s1+s2)**2)*(aa-(s1-s2)**2)
 
14911
     dd = sqrt( dd )!+ sign(abs(dd),areal(aa))*IEPS )
 
14912
     call solabc( y1,y2 ,dd ,aa,bb,cc ,1 )
 
14913
!
 
14914
     if (present(t4)) then
 
14915
       call solabc( alpha,hh ,t4 ,aa,t2,t3 ,1 )
 
14916
       y0 = -(t1+bb*alpha)/t4
 
14917
     else
 
14918
       y0 = t1
 
14919
     endif
 
14920
!
 
14921
     q1 = qonv(y0-y1)
 
14922
     q2 = qonv(y0-y2)
 
14923
     rslt = li2c(qonv(-y1)/q1) - li2c(qonv(1-y1)/q1) &
 
14924
          + li2c(qonv(-y2)/q2) - li2c(qonv(1-y2)/q2)
 
14925
! Take some care about the imaginary part of  a*y0^2+b*y0+c=a*(y0-y1)*(y0-y2)
 
14926
     zz = y0*(aa*y0+bb)
 
14927
     rez=areal(zz)  ;arez=abs(rez) ;aimz=abs(aimag(zz))
 
14928
     if (arez*EPSN*EPSN.le.aimz*neglig(prcpar).and.aimz.le.arez*neglig(prcpar)) then
 
14929
! Here, the value of Imz is just numerical noise due to cancellations.
 
14930
! Realize that |Imz|~eps^2 indicates there were no such cancellations,
 
14931
! so the lower limit is needed in in the if-statement!
 
14932
       zz = (rez + cc)/aa
 
14933
     else
 
14934
       zz = (zz + cc)/aa
 
14935
     endif
 
14936
     hh = eta3(-y1,-y2,cc/aa) - eta3(y0-y1,y0-y2,zz)
 
14937
     if (areal(aa).lt.RZRO.and.aimag(zz).lt.RZRO) hh = hh - 2*IPI
 
14938
     if (hh.ne.CZRO) rslt = rslt + hh*logc(qonv((y0-1)/y0,1))
 
14939
!
 
14940
     end function
 
14941
!
 
14942
     function s2fun( aa,bb ,y0 ) result(rslt)
 
14943
!**************************************************
 
14944
! int( ( ln(a*y+b) - ln(a*y0+b) )/(y-y0) ,y=0..1 )
 
14945
!**************************************************
 
14946
  complex(kindr2) &   
 
14947
       ,intent(in) :: aa,bb,y0
 
14948
  complex(kindr2) &   
 
14949
       :: rslt ,y1,hh
 
14950
     type(qmplx_type) :: q1
 
14951
     y1 = -bb/aa
 
14952
     q1 = qonv(y0-y1)
 
14953
     rslt = li2c(qonv(-y1,-1)/q1) - li2c(qonv(1-y1,-1)/q1)
 
14954
! aa may have imaginary part, so  theta(-aa)*theta(-Im(y0-y1))  is not
 
14955
! sufficient and need the following:
 
14956
     hh = eta5( aa ,-y1,bb ,y0-y1,aa*(y0-y1) )
 
14957
     if (hh.ne.CZRO) rslt = rslt + hh*logc(qonv((y0-1)/y0,1))
 
14958
     end function
 
14959
!
 
14960
   end subroutine
 
14961
 
 
14962
 
 
14963
end module
 
14964
 
 
14965
 
 
14966
module avh_olo_qp_box
 
14967
  use avh_olo_units
 
14968
  use avh_olo_qp_prec
 
14969
  use avh_olo_qp_auxfun
 
14970
  use avh_olo_qp_qmplx
 
14971
  implicit none
 
14972
  private
 
14973
  public :: box00,box03,box05,box06,box07,box08,box09,box10,box11,box12 &
 
14974
           ,box13,box14,box15,box16,boxf1,boxf2,boxf3,boxf5,boxf4 &
 
14975
           ,permtable,casetable,base
 
14976
  integer ,parameter ::  permtable(6,0:15)=reshape((/ &
 
14977
     1,2,3,4 ,5,6 &! 0, 0 masses non-zero,           no perm
 
14978
    ,1,2,3,4 ,5,6 &! 1, 1 mass non-zero,             no perm
 
14979
    ,4,1,2,3 ,6,5 &! 2, 1 mass non-zero,             1 cyclic perm
 
14980
    ,1,2,3,4 ,5,6 &! 3, 2 neighbour masses non-zero, no perm
 
14981
    ,3,4,1,2 ,5,6 &! 4, 1 mass   non-zero,           2 cyclic perm's
 
14982
    ,1,2,3,4 ,5,6 &! 5, 2 opposite masses non-zero,  no perm
 
14983
    ,4,1,2,3 ,6,5 &! 6, 2 neighbour masses non-zero, 1 cyclic perm
 
14984
    ,1,2,3,4 ,5,6 &! 7, 3 masses non-zero,           no perm
 
14985
    ,2,3,4,1 ,6,5 &! 8, 1 mass   non-zero,           3 cyclic perm's
 
14986
    ,2,3,4,1 ,6,5 &! 9, 2 neighbour masses non-zero, 3 cyclic perm's
 
14987
    ,4,1,2,3 ,6,5 &!10, 2 opposite masses non-zero,  1 cyclic perm
 
14988
    ,2,3,4,1 ,6,5 &!11, 3 masses non-zero,           3 cyclic perm's
 
14989
    ,3,4,1,2 ,5,6 &!12, 2 neighbour masses non-zero, 2 cyclic perm's
 
14990
    ,3,4,1,2 ,5,6 &!13, 3 masses non-zero,           2 cyclic perm's
 
14991
    ,4,1,2,3 ,6,5 &!14, 3 masses non-zero,           1 cyclic perm
 
14992
    ,1,2,3,4 ,5,6 &!15, 4 masses non-zero,           no perm
 
14993
    /),(/6,16/)) !          0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15
 
14994
  integer ,parameter :: casetable(0:15)= &
 
14995
                          (/0,1,1,2,1,5,2,3,1,2, 5, 3, 2, 3, 3, 4/)
 
14996
  integer ,parameter :: base(4)=(/8,4,2,1/)
 
14997
contains
 
14998
 
 
14999
   subroutine box16( rslt ,p2,p3,p12,p23 ,m2,m3,m4 ,rmu )
 
15000
!*******************************************************************
 
15001
! calculates
 
15002
!
 
15003
!    C   /                     d^(Dim)q
 
15004
! ------ | ------------------------------------------------------
 
15005
! i*pi^2 / q^2 [(q+k1)^2-m2] [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
 
15006
!
 
15007
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
 
15008
! m2,m4 should NOT be identically 0d0
 
15009
!*******************************************************************
 
15010
  complex(kindr2) &   
 
15011
     ,intent(out) :: rslt(0:2)
 
15012
  complex(kindr2) &   
 
15013
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m3,m4
 
15014
  real(kindr2) &  
 
15015
     ,intent(in)  :: rmu
 
15016
  complex(kindr2) &   
 
15017
     :: cp2,cp3,cp12,cp23,cm2,cm3,cm4,sm1,sm2,sm3,sm4 &
 
15018
                     ,r13,r23,r24,r34,d23,d24,d34,log24,cc
 
15019
   type(qmplx_type) :: q13,q23,q24,q34,qss,qy1,qy2,qz1,qz2
 
15020
!
 
15021
   if (abs(m2).gt.abs(m4)) then
 
15022
     cm2=m2 ;cm4=m4 ;cp2=p2 ;cp3=p3
 
15023
   else
 
15024
     cm2=m4 ;cm4=m2 ;cp2=p3 ;cp3=p2
 
15025
   endif
 
15026
   cm3=m3 ;cp12=p12 ;cp23=p23
 
15027
!
 
15028
   if (cp12.eq.cm3) then
 
15029
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box16: ' &
 
15030
       ,'p12=m3, returning 0'
 
15031
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15032
     return
 
15033
   endif
 
15034
!
 
15035
   sm1 = abs(rmu)
 
15036
   sm2 = mysqrt(cm2)
 
15037
   sm3 = mysqrt(cm3)
 
15038
   sm4 = mysqrt(cm4)
 
15039
!
 
15040
   r13 = (cm3-cp12)/(sm1*sm3)
 
15041
   call rfun( r23,d23 ,(cm2+cm3-cp2 )/(sm2*sm3) )
 
15042
   call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
 
15043
   call rfun( r34,d34 ,(cm3+cm4-cp3 )/(sm3*sm4) )
 
15044
   q13 = qonv(r13,-1)
 
15045
   q23 = qonv(r23,-1)
 
15046
   q24 = qonv(r24,-1)
 
15047
   q34 = qonv(r34,-1)
 
15048
!
 
15049
   if (r24.eq.-CONE) then 
 
15050
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box16: ' &
 
15051
       ,'threshold singularity, returning 0'
 
15052
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15053
     return
 
15054
   endif
 
15055
!
 
15056
   qss = q23*q34
 
15057
   qy1 = qss*q24
 
15058
   qy2 = qss/q24
 
15059
!
 
15060
   qss = q23/q34
 
15061
   qz1 = qss*q24
 
15062
   qz2 = qss/q24
 
15063
!
 
15064
   qss = q13*q23
 
15065
   qss = (qss*qss)/q24
 
15066
!
 
15067
   cc = 1/( sm2*sm4*(cp12-cm3) )
 
15068
   log24 = logc2(q24)*r24/(1+r24)
 
15069
   rslt(2) = 0
 
15070
   rslt(1) = -log24
 
15071
   rslt(0) = log24*logc(qss) + li2c2(q24*q24,qonv(1))*r24 &
 
15072
           - li2c2(qy1,qy2)*r23*r34 - li2c2(qz1,qz2)*r23/r34
 
15073
   rslt(1) = cc*rslt(1)
 
15074
   rslt(0) = cc*rslt(0)
 
15075
   end subroutine
 
15076
 
 
15077
 
 
15078
   subroutine box15( rslt ,p2,p3,p12,p23 ,m2,m4 ,rmu )
 
15079
!*******************************************************************
 
15080
! calculates
 
15081
!
 
15082
!    C   /                  d^(Dim)q
 
15083
! ------ | -------------------------------------------------
 
15084
! i*pi^2 / q^2 [(q+k1)^2-m2] (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15085
!
 
15086
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
 
15087
! m2,m4 should NOT be identically 0d0
 
15088
!*******************************************************************
 
15089
  complex(kindr2) &   
 
15090
     ,intent(out) :: rslt(0:2)
 
15091
  complex(kindr2) &   
 
15092
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m4
 
15093
  real(kindr2) &  
 
15094
     ,intent(in)  :: rmu
 
15095
  complex(kindr2) &   
 
15096
     :: cp2,cp3,cp12,cp23,cm2,cm4,sm1,sm2,sm3,sm4 &
 
15097
                     ,r13,r23,r24,r34,d24,log24,cc
 
15098
   type(qmplx_type) :: q13,q23,q24,q34,qss,qz1,qz2
 
15099
!
 
15100
   if (abs(m2-p2).gt.abs(m4-p3)) then
 
15101
     cm2=m2 ;cm4=m4 ;cp2=p2 ;cp3=p3
 
15102
   else
 
15103
     cm2=m4 ;cm4=m2 ;cp2=p3 ;cp3=p2
 
15104
   endif
 
15105
   cp12=p12 ;cp23=p23
 
15106
!
 
15107
   if (cp12.eq.CZRO) then
 
15108
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box15: ' &
 
15109
       ,'p12=0, returning 0'
 
15110
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15111
     return
 
15112
   endif
 
15113
!
 
15114
   sm1 = abs(rmu)
 
15115
   sm2 = mysqrt(cm2)
 
15116
   sm4 = mysqrt(cm4)
 
15117
   sm3 = abs(sm2)
 
15118
   r13 = (       -cp12)/(sm1*sm3)
 
15119
   r23 = (cm2    -cp2 )/(sm2*sm3)
 
15120
   r34 = (    cm4-cp3 )/(sm3*sm4)
 
15121
   call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
 
15122
!
 
15123
   if (r24.eq.-CONE) then 
 
15124
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box15: ' &
 
15125
       ,'threshold singularity, returning 0'
 
15126
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15127
     return
 
15128
   endif
 
15129
!
 
15130
   q13 = qonv(r13,-1)
 
15131
   q23 = qonv(r23,-1)
 
15132
   q24 = qonv(r24,-1)
 
15133
   q34 = qonv(r34,-1)
 
15134
!
 
15135
   qss = q13/q23
 
15136
   qss = (qss*qss)/q24
 
15137
!
 
15138
   cc = r24/(sm2*sm4*cp12)
 
15139
   log24 = logc2(q24)/(1+r24)
 
15140
   rslt(2) = 0
 
15141
   rslt(1) = -log24
 
15142
   rslt(0) = log24 * logc(qss) + li2c2(q24*q24,qonv(1))
 
15143
   if (r34.ne.CZRO) then
 
15144
     qss = q34/q23
 
15145
     qz1 = qss*q24
 
15146
     qz2 = qss/q24
 
15147
     rslt(0) = rslt(0) - li2c2(qz1,qz2)*r34/(r23*r24)
 
15148
   endif
 
15149
   rslt(1) = cc*rslt(1)
 
15150
   rslt(0) = cc*rslt(0)
 
15151
   end subroutine
 
15152
 
 
15153
 
 
15154
   subroutine box14( rslt ,cp12,cp23 ,cm2,cm4 ,rmu )
 
15155
!*******************************************************************
 
15156
! calculates
 
15157
!
 
15158
!    C   /                  d^(Dim)q
 
15159
! ------ | -------------------------------------------------
 
15160
! i*pi^2 / q^2 [(q+k1)^2-m2] (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15161
!
 
15162
! with  k1^2=m2, k2^2=m2, k3^2=m4, (k1+k2+k3)^2=m4
 
15163
! m2,m4 should NOT be identically 0d0
 
15164
!*******************************************************************
 
15165
  complex(kindr2) &   
 
15166
     ,intent(out) :: rslt(0:2)
 
15167
  complex(kindr2) &   
 
15168
     ,intent(in)  :: cp12,cp23,cm2,cm4
 
15169
  real(kindr2) &  
 
15170
     ,intent(in)  :: rmu
 
15171
  complex(kindr2) &   
 
15172
     :: sm2,sm4,r24,d24,cc
 
15173
!
 
15174
   if (cp12.eq.CZRO) then
 
15175
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box14: ' &
 
15176
       ,'p12=0, returning 0'
 
15177
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15178
     return
 
15179
   endif
 
15180
!
 
15181
   sm2 = mysqrt(cm2)
 
15182
   sm4 = mysqrt(cm4)
 
15183
   call rfun( r24,d24 ,(cm2+cm4-cp23)/(sm2*sm4) )
 
15184
!
 
15185
   if (r24.eq.-CONE) then 
 
15186
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box14: ' &
 
15187
       ,'threshold singularity, returning 0'
 
15188
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15189
     return
 
15190
   endif
 
15191
!
 
15192
   cc = -2*logc2(qonv(r24,-1))*r24/(1+r24)/(sm2*sm4*cp12)
 
15193
!
 
15194
   rslt(2) = 0
 
15195
   rslt(1) = cc
 
15196
   rslt(0) = -cc*logc(qonv(-cp12/(rmu*rmu),-1))
 
15197
   end subroutine
 
15198
 
 
15199
 
 
15200
   subroutine box13( rslt ,p2,p3,p4,p12,p23 ,m3,m4 ,rmu )
 
15201
!*******************************************************************
 
15202
! calculates
 
15203
!
 
15204
!    C   /                  d^(Dim)q
 
15205
! ------ | -------------------------------------------------
 
15206
! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
 
15207
!
 
15208
! with  k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=p4
 
15209
! m3,m4 should NOT be identically 0d0
 
15210
! p4 should NOT be identical to m4
 
15211
! p2 should NOT be identical to m3
 
15212
!*******************************************************************
 
15213
  complex(kindr2) &   
 
15214
     ,intent(out) :: rslt(0:2)
 
15215
  complex(kindr2) &   
 
15216
     ,intent(in)  :: p2,p3,p4,p12,p23,m3,m4
 
15217
  real(kindr2) &  
 
15218
     ,intent(in)  :: rmu
 
15219
  complex(kindr2) &   
 
15220
     :: cp2,cp3,cp4,cp12,cp23,cm3,cm4,sm3,sm4,sm1,sm2 &
 
15221
             ,r13,r14,r23,r24,r34,d34,cc,logd,li2d,loge,li2f,li2b,li2e
 
15222
   type(qmplx_type) :: q13,q14,q23,q24,q34,qy1,qy2
 
15223
  real(kindr2) &  
 
15224
     :: h1,h2
 
15225
!
 
15226
   if (p12.eq.m3) then
 
15227
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
15228
       ,'p12=m3, returning 0'
 
15229
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15230
     return
 
15231
   endif
 
15232
   if (p23.eq.m4) then
 
15233
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
15234
       ,'p23=m4, returning 0'
 
15235
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15236
     return
 
15237
   endif
 
15238
!
 
15239
   h1 = abs((m3-p12)*(m4-p23))
 
15240
   h2 = abs((m3-p2 )*(m4-p4 ))
 
15241
   if (h1.ge.h2) then
 
15242
     cp2=p2  ;cp3=p3 ;cp4=p4  ;cp12=p12 ;cp23=p23 ;cm3=m3 ;cm4=m4
 
15243
   else
 
15244
     cp2=p12 ;cp3=p3 ;cp4=p23 ;cp12=p2  ;cp23=p4  ;cm3=m3 ;cm4=m4
 
15245
   endif
 
15246
!
 
15247
   sm3 = mysqrt(cm3)
 
15248
   sm4 = mysqrt(cm4)
 
15249
   sm1 = abs(rmu)
 
15250
   sm2 = sm1
 
15251
!
 
15252
   r13 = (cm3-cp12)/(sm1*sm3)
 
15253
   r14 = (cm4-cp4 )/(sm1*sm4)
 
15254
   r23 = (cm3-cp2 )/(sm2*sm3)
 
15255
   r24 = (cm4-cp23)/(sm2*sm4)
 
15256
   call rfun( r34,d34 ,(cm3+cm4-cp3)/(sm3*sm4) )
 
15257
!
 
15258
   q13 = qonv(r13,-1)
 
15259
   q14 = qonv(r14,-1)
 
15260
   q23 = qonv(r23,-1)
 
15261
   q24 = qonv(r24,-1)
 
15262
   q34 = qonv(r34,-1) 
 
15263
!
 
15264
   qy1 = q14*q23/q13/q24
 
15265
   logd = logc2(qy1     )/(r13*r24)
 
15266
   li2d = li2c2(qy1,qonv(1))/(r13*r24)
 
15267
   loge = logc(q13)
 
15268
!
 
15269
   qy1 = q23/q24
 
15270
   qy2 = q13/q14
 
15271
   li2f = li2c2( qy1*q34,qy2*q34 )*r34/(r14*r24)
 
15272
   li2b = li2c2( qy1/q34,qy2/q34 )/(r34*r14*r24)
 
15273
   li2e = li2c2( q14/q24,q13/q23 )/(r23*r24)
 
15274
!
 
15275
   rslt(2) = 0
 
15276
   rslt(1) = logd
 
15277
   rslt(0) = li2f + li2b + 2*li2e - 2*li2d - 2*logd*loge
 
15278
   cc = sm1*sm2*sm3*sm4
 
15279
   rslt(1) = rslt(1)/cc
 
15280
   rslt(0) = rslt(0)/cc
 
15281
   end subroutine
 
15282
 
 
15283
 
 
15284
   subroutine box12( rslt ,cp3,cp4,cp12,cp23 ,cm3,cm4 ,rmu )
 
15285
!*******************************************************************
 
15286
! calculates
 
15287
!
 
15288
!    C   /                  d^(Dim)q
 
15289
! ------ | -------------------------------------------------
 
15290
! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
 
15291
!
 
15292
! with  k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=p4
 
15293
! m3,m4 should NOT be indentiallcy 0d0
 
15294
! p4 should NOT be identical to m4
 
15295
!*******************************************************************
 
15296
  complex(kindr2) &   
 
15297
     ,intent(out) :: rslt(0:2)
 
15298
  complex(kindr2) &   
 
15299
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm3,cm4
 
15300
  real(kindr2) &  
 
15301
     ,intent(in)  :: rmu
 
15302
  complex(kindr2) &   
 
15303
     :: sm3,sm4,sm1,sm2,r13,r14,r24,r34,d34,cc &
 
15304
                     ,log13,log14,log24,log34,li2f,li2b,li2d
 
15305
   type(qmplx_type) :: q13,q14,q24,q34,qyy
 
15306
!
 
15307
   if (cp12.eq.cm3) then
 
15308
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box12: ' &
 
15309
       ,'p12=m3, returning 0'
 
15310
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15311
     return
 
15312
   endif
 
15313
   if (cp23.eq.cm4) then
 
15314
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box12: ' &
 
15315
       ,'p23=m4, returning 0'
 
15316
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15317
     return
 
15318
   endif
 
15319
!
 
15320
   sm3 = mysqrt(cm3)
 
15321
   sm4 = mysqrt(cm4)
 
15322
   sm1 = abs(rmu)
 
15323
   sm2 = sm1
 
15324
!
 
15325
   r13 = (cm3-cp12)/(sm1*sm3)
 
15326
   r14 = (cm4-cp4 )/(sm1*sm4)
 
15327
   r24 = (cm4-cp23)/(sm2*sm4)
 
15328
   call rfun( r34,d34 ,(cm3+cm4-cp3)/(sm3*sm4) )
 
15329
!
 
15330
   q13 = qonv(r13,-1)
 
15331
   q14 = qonv(r14,-1)
 
15332
   q24 = qonv(r24,-1)
 
15333
   q34 = qonv(r34,-1) 
 
15334
!
 
15335
   log13 = logc(q13) 
 
15336
   log14 = logc(q14) 
 
15337
   log24 = logc(q24) 
 
15338
   log34 = logc(q34) 
 
15339
!
 
15340
   qyy = q14/q13
 
15341
   li2f = li2c(qyy*q34)
 
15342
   li2b = li2c(qyy/q34)
 
15343
   li2d = li2c(q14/q24)
 
15344
!
 
15345
   rslt(2) = 1
 
15346
   rslt(2) = rslt(2)/2
 
15347
   rslt(1) = log14 - log24 - log13
 
15348
   rslt(0) = 2*log13*log24 - log14*log14 - log34*log34 &
 
15349
           - 2*li2d - li2f - li2b - 3*PISQo24
 
15350
   cc = (cm3-cp12)*(cm4-cp23) ! = sm1*sm2*sm3*sm4*r13*r24
 
15351
   rslt(2) = rslt(2)/cc
 
15352
   rslt(1) = rslt(1)/cc
 
15353
   rslt(0) = rslt(0)/cc
 
15354
   end subroutine
 
15355
 
 
15356
 
 
15357
   subroutine box11( rslt ,cp3,cp12,cp23 ,cm3,cm4 ,rmu )
 
15358
!*******************************************************************
 
15359
! calculates
 
15360
!
 
15361
!    C   /                  d^(Dim)q
 
15362
! ------ | -------------------------------------------------
 
15363
! i*pi^2 / q^2 (q+k1)^2 [(q+k1+k2)^2-m3] [(q+k1+k2+k3)^2-m4]
 
15364
!
 
15365
! with  k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=m4
 
15366
! m3,m4 should NOT be indentiallcy 0d0
 
15367
!*******************************************************************
 
15368
  complex(kindr2) &   
 
15369
     ,intent(out) :: rslt(0:2)
 
15370
  complex(kindr2) &   
 
15371
     ,intent(in)  :: cp3,cp12,cp23,cm3,cm4
 
15372
  real(kindr2) &  
 
15373
     ,intent(in)  :: rmu
 
15374
  complex(kindr2) &   
 
15375
     :: sm3,sm4,sm1,sm2,r13,r24,r34,d34 &
 
15376
                     ,cc,log13,log24,log34
 
15377
!
 
15378
   if (cp12.eq.cm3) then
 
15379
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box11: ' &
 
15380
       ,'p12=m3, returning 0'
 
15381
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15382
     return
 
15383
   endif
 
15384
   if (cp23.eq.cm4) then
 
15385
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box11: ' &
 
15386
       ,'p23=m4, returning 0'
 
15387
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15388
     return
 
15389
   endif
 
15390
!
 
15391
   sm3 = mysqrt(cm3)
 
15392
   sm4 = mysqrt(cm4)
 
15393
   sm1 = abs(rmu)
 
15394
   sm2 = sm1
 
15395
!
 
15396
   r13 = (cm3-cp12)/(sm1*sm3)
 
15397
   r24 = (cm4-cp23)/(sm2*sm4)
 
15398
   call rfun( r34,d34 ,(cm3+cm4-cp3 )/(sm3*sm4) )
 
15399
!
 
15400
   log13 = logc(qonv(r13,-1)) 
 
15401
   log24 = logc(qonv(r24,-1)) 
 
15402
   log34 = logc(qonv(r34,-1)) 
 
15403
!
 
15404
   rslt(2) = 1
 
15405
   rslt(1) = -log13-log24
 
15406
   rslt(0) = 2*log13*log24 - log34*log34 - 14*PISQo24
 
15407
   cc = (cm3-cp12)*(cm4-cp23) ! = sm1*sm2*sm3*sm4*r13*r24
 
15408
   rslt(2) = rslt(2)/cc
 
15409
   rslt(1) = rslt(1)/cc
 
15410
   rslt(0) = rslt(0)/cc
 
15411
   end subroutine
 
15412
 
 
15413
 
 
15414
   subroutine box10( rslt ,p2,p3,p4,p12,p23 ,m4 ,rmu )
 
15415
!*******************************************************************
 
15416
! calculates
 
15417
!
 
15418
!     C   /               d^(Dim)q
 
15419
!  ------ | --------------------------------------------
 
15420
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15421
!
 
15422
! with  k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=p4
 
15423
! m4 should NOT be identically 0d0
 
15424
! p2 should NOT be identically 0d0
 
15425
! p4 should NOT be identical to m4
 
15426
!*******************************************************************
 
15427
  complex(kindr2) &   
 
15428
     ,intent(out) :: rslt(0:2)
 
15429
  complex(kindr2) &   
 
15430
     ,intent(in)  :: p2,p3,p4,p12,p23,m4
 
15431
  real(kindr2) &  
 
15432
     ,intent(in)  :: rmu
 
15433
  complex(kindr2) &   
 
15434
     :: cp2,cp3,cp4,cp12,cp23,cm4,r13,r14,r23,r24,r34,z1,z0
 
15435
   type(qmplx_type) :: q13,q14,q23,q24,q34,qm4,qxx,qx1,qx2
 
15436
  real(kindr2) &  
 
15437
     :: h1,h2
 
15438
!
 
15439
   if (p12.eq.CZRO) then
 
15440
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box10: ' &
 
15441
       ,'p12=0, returning 0'
 
15442
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15443
     return
 
15444
   endif
 
15445
   if (p23.eq.m4) then
 
15446
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box10: ' &
 
15447
       ,'p23=mm, returning 0'
 
15448
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15449
     return
 
15450
   endif
 
15451
!
 
15452
   h1 = abs(p12*(m4-p23))
 
15453
   h2 = abs( p2*(m4-p4 ))
 
15454
   if (h1.ge.h2) then
 
15455
     cp2=p2  ;cp3=p3 ;cp4=p4  ;cp12=p12 ;cp23=p23 ;cm4=m4
 
15456
   else
 
15457
     cp2=p12 ;cp3=p3 ;cp4=p23 ;cp12=p2  ;cp23=p4  ;cm4=m4
 
15458
   endif
 
15459
!
 
15460
   r23 =    -cp2
 
15461
   r13 =    -cp12
 
15462
   r34 = cm4-cp3
 
15463
   r14 = cm4-cp4
 
15464
   r24 = cm4-cp23
 
15465
   q23 = qonv(r23,-1)
 
15466
   q13 = qonv(r13,-1)
 
15467
   q34 = qonv(r34,-1)
 
15468
   q14 = qonv(r14,-1)
 
15469
   q24 = qonv(r24,-1)
 
15470
   qm4 = qonv(cm4,-1)
 
15471
!
 
15472
   if (r34.ne.CZRO) then
 
15473
     qx1 = q34/qm4
 
15474
     qx2 = qx1*q14/q13
 
15475
     qx1 = qx1*q24/q23
 
15476
     z0 = -li2c2(qx1,qx2)*r34/(2*cm4*r23)
 
15477
   else
 
15478
     z0 = 0
 
15479
   endif
 
15480
!
 
15481
   qx1 = q23/q13
 
15482
   qx2 = q24/q14
 
15483
   qxx = qx1/qx2
 
15484
   z1 = -logc2(qxx)/r24
 
15485
   z0 = z0 - li2c2(qx1,qx2)/r14
 
15486
   z0 = z0 + li2c2(qxx,qonv(1))/r24
 
15487
   z0 = z0 + z1*( logc(qm4/q24) - logc(qm4/(rmu*rmu))/2 )
 
15488
!
 
15489
   rslt(2) = 0
 
15490
   rslt(1) = -z1/r13
 
15491
   rslt(0) = -2*z0/r13
 
15492
   end subroutine
 
15493
 
 
15494
 
 
15495
   subroutine box09( rslt ,cp2,cp3,cp12,cp23 ,cm4 ,rmu )
 
15496
!*******************************************************************
 
15497
! calculates
 
15498
!
 
15499
!     C   /               d^(Dim)q
 
15500
!  ------ | --------------------------------------------
 
15501
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15502
!
 
15503
! with  k1^2=0, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
 
15504
! m4 should NOT be identically 0d0
 
15505
! p2 should NOT be identically 0d0
 
15506
!*******************************************************************
 
15507
  complex(kindr2) &   
 
15508
     ,intent(out) :: rslt(0:2)
 
15509
  complex(kindr2) &   
 
15510
     ,intent(in)  :: cp2,cp3,cp12,cp23,cm4
 
15511
  real(kindr2) &  
 
15512
     ,intent(in)  :: rmu
 
15513
  complex(kindr2) &   
 
15514
     :: logm,log12,log23,li12,li23,z2,z1,z0,cc &
 
15515
                     ,r13,r23,r24,r34
 
15516
   type(qmplx_type) :: q13,q23,q24,q34,qm4,qxx
 
15517
!
 
15518
   if (cp12.eq.CZRO) then
 
15519
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box09: ' &
 
15520
       ,'p12=0, returning 0'
 
15521
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15522
     return
 
15523
   endif
 
15524
   if (cp23.eq.cm4) then
 
15525
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box09: ' &
 
15526
       ,'p23=mm, returning 0'
 
15527
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15528
     return
 
15529
   endif
 
15530
!
 
15531
   r23 =    -cp2
 
15532
   r13 =    -cp12
 
15533
   r34 = cm4-cp3
 
15534
   r24 = cm4-cp23
 
15535
   q23 = qonv(r23,-1)
 
15536
   q13 = qonv(r13,-1)
 
15537
   q34 = qonv(r34,-1)
 
15538
   q24 = qonv(r24,-1)
 
15539
   qm4 = qonv(cm4,-1)
 
15540
!
 
15541
   logm  = logc(qm4/(rmu*rmu))
 
15542
   qxx = q13/q23
 
15543
   log12 = logc(qxx)
 
15544
   li12  = li2c(qxx)
 
15545
!
 
15546
   qxx = q24/qm4
 
15547
   log23 = logc(qxx)
 
15548
   li23  = li2c(qxx*q34/q23)
 
15549
!
 
15550
   z2 = 1
 
15551
   z2 = z2/2
 
15552
   z1 = -log12 - log23
 
15553
   z0 = li23 + 2*li12 + z1*z1 + PISQo24
 
15554
   cc = 1/(r13*r24)
 
15555
   rslt(2) = cc*z2
 
15556
   rslt(1) = cc*(z1 - z2*logm)
 
15557
   rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
 
15558
   end subroutine
 
15559
 
 
15560
 
 
15561
   subroutine box08( rslt ,cp3,cp4,cp12,cp23 ,cm4 ,rmu )
 
15562
!*******************************************************************
 
15563
! calculates
 
15564
!
 
15565
!     C   /               d^(Dim)q
 
15566
!  ------ | --------------------------------------------
 
15567
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15568
!
 
15569
! with  k1^2=k2^2=0, k3^2=p3, (k1+k2+k3)^2=p4
 
15570
! mm should NOT be identically 0d0
 
15571
! p3 NOR p4 should be identically m4
 
15572
!*******************************************************************
 
15573
  complex(kindr2) &   
 
15574
     ,intent(out) :: rslt(0:2)
 
15575
  complex(kindr2) &   
 
15576
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm4
 
15577
  real(kindr2) &  
 
15578
     ,intent(in)  :: rmu
 
15579
   type(qmplx_type) :: q13,q14,q24,q34,qm4,qxx,qx1,qx2,qx3
 
15580
  complex(kindr2) &   
 
15581
     :: r13,r14,r24,r34,z1,z0,cc
 
15582
  real(kindr2) &  
 
15583
     :: rmu2
 
15584
!
 
15585
   if (cp12.eq.CZRO) then
 
15586
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box08: ' &
 
15587
       ,'p12=0, returning 0'
 
15588
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15589
     return
 
15590
   endif
 
15591
   if (cp23.eq.cm4) then
 
15592
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box08: ' &
 
15593
       ,'p23=mm, returning 0'
 
15594
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15595
     return
 
15596
   endif
 
15597
!
 
15598
   rmu2 = rmu*rmu
 
15599
   r13 =    -cp12
 
15600
   r34 = cm4-cp3
 
15601
   r14 = cm4-cp4
 
15602
   r24 = cm4-cp23
 
15603
   q13 = qonv(r13,-1)
 
15604
   q34 = qonv(r34,-1)
 
15605
   q14 = qonv(r14,-1)
 
15606
   q24 = qonv(r24,-1)
 
15607
   qm4 = qonv(cm4,-1)
 
15608
!
 
15609
   qx1 = q34/q24
 
15610
   qx2 = q14/q24
 
15611
   qx3 = q13/rmu2
 
15612
   z1 = logc(qx1*qx2/qx3)
 
15613
   z0 = 2*( logc(q24/rmu2)*logc(qx3) - (li2c(qx1)+li2c(qx2)) )
 
15614
!
 
15615
   qx1 = q34/rmu2
 
15616
   qx2 = q14/rmu2
 
15617
   qxx = qx1*qx2/qx3
 
15618
   z0 = z0 - logc(qx1)**2 - logc(qx2)**2 &
 
15619
           + logc(qxx)**2/2 + li2c(qm4/qxx/rmu2)
 
15620
!
 
15621
   cc = 1/(r13*r24)
 
15622
   rslt(2) = cc
 
15623
   rslt(1) = cc*z1
 
15624
   rslt(0) = cc*( z0 - 6*PISQo24 )
 
15625
   end subroutine
 
15626
 
 
15627
 
 
15628
   subroutine box07( rslt ,cp4,cp12,cp23 ,cm4 ,rmu )
 
15629
!*******************************************************************
 
15630
! calculates
 
15631
!
 
15632
!     C   /               d^(Dim)q
 
15633
!  ------ | --------------------------------------------
 
15634
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15635
!
 
15636
! with  k1^2=k2^2=0, k3^2=m4, (k1+k2+k3)^2=p4
 
15637
! m3 should NOT be identically 0d0
 
15638
! p4 should NOT be identically m4
 
15639
!*******************************************************************
 
15640
  complex(kindr2) &   
 
15641
     ,intent(out) :: rslt(0:2)
 
15642
  complex(kindr2) &   
 
15643
     ,intent(in)  :: cp4,cp12,cp23,cm4
 
15644
  real(kindr2) &  
 
15645
     ,intent(in)  :: rmu
 
15646
   type(qmplx_type) :: q13,q14,q24,qm4
 
15647
  complex(kindr2) &   
 
15648
     :: r13,r14,r24,logm,log12,log23,log4,li423 &
 
15649
                     ,z2,z1,z0,cc
 
15650
!
 
15651
   if (cp12.eq.CZRO) then
 
15652
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box07: ' &
 
15653
       ,'p12=0, returning 0'
 
15654
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15655
     return
 
15656
   endif
 
15657
   if (cp23.eq.cm4) then
 
15658
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box07: ' &
 
15659
       ,'p23=mm, returning 0'
 
15660
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15661
     return
 
15662
   endif
 
15663
!
 
15664
   r13 =    -cp12
 
15665
   r14 = cm4-cp4
 
15666
   r24 = cm4-cp23
 
15667
   q13 = qonv(r13,-1)
 
15668
   q14 = qonv(r14,-1)
 
15669
   q24 = qonv(r24,-1)
 
15670
   qm4 = qonv(cm4,-1)
 
15671
!
 
15672
   logm  = logc(qm4/(rmu*rmu))
 
15673
   log12 = logc(q13/qm4)
 
15674
   log23 = logc(q24/qm4)
 
15675
   log4  = logc(q14/qm4)
 
15676
   li423 = li2c(q14/q24)
 
15677
!
 
15678
   z2 = 3
 
15679
   z2 = z2/2
 
15680
   z1 = -2*log23 - log12 + log4
 
15681
   z0 = 2*(log12*log23 - li423) - log4*log4 - 13*PISQo24
 
15682
   cc = 1/(r13*r24)
 
15683
   rslt(2) = cc*z2
 
15684
   rslt(1) = cc*(z1 - z2*logm)
 
15685
   rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
 
15686
   end subroutine
 
15687
 
 
15688
 
 
15689
   subroutine box06( rslt ,cp12,cp23 ,cm4 ,rmu )
 
15690
!*******************************************************************
 
15691
! calculates
 
15692
!
 
15693
!     C   /               d^(Dim)q
 
15694
!  ------ | --------------------------------------------
 
15695
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 [(q+k1+k2+k3)^2-m4]
 
15696
!
 
15697
! with  k1^2=k2^2=0, k3^2=(k1+k2+k3)^2=m4
 
15698
! m3 should NOT be identically 0d0
 
15699
!*******************************************************************
 
15700
  complex(kindr2) &   
 
15701
     ,intent(out) :: rslt(0:2)
 
15702
  complex(kindr2) &   
 
15703
     ,intent(in)  :: cp12,cp23,cm4
 
15704
  real(kindr2) &  
 
15705
     ,intent(in)  :: rmu
 
15706
   type(qmplx_type) :: q13,q24,qm4
 
15707
  complex(kindr2) &   
 
15708
     :: r13,r24,logm,log1,log2,z2,z1,z0,cc
 
15709
!
 
15710
   if (cp12.eq.CZRO) then
 
15711
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box06: ' &
 
15712
       ,'p12=0, returning 0'
 
15713
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15714
     return
 
15715
   endif
 
15716
   if (cp23.eq.cm4) then
 
15717
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box06: ' &
 
15718
       ,'p23=mm, returning 0'
 
15719
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
15720
     return
 
15721
   endif
 
15722
!
 
15723
   r13 =    -cp12
 
15724
   r24 = cm4-cp23
 
15725
   q13 = qonv(r13,-1)
 
15726
   q24 = qonv(r24,-1)
 
15727
   qm4 = qonv(cm4,-1)
 
15728
!
 
15729
   logm = logc(qm4/(rmu*rmu))
 
15730
   log1 = logc(q13/qm4)
 
15731
   log2 = logc(q24/qm4)
 
15732
!
 
15733
   z2 = 2
 
15734
   z1 = -2*log2 - log1
 
15735
   z0 = 2*(log2*log1 - 8*PISQo24)
 
15736
   cc = 1/(r13*r24)
 
15737
   rslt(2) = cc*z2
 
15738
   rslt(1) = cc*(z1 - z2*logm)
 
15739
   rslt(0) = cc*(z0 + (z2*logm/2-z1)*logm)
 
15740
   end subroutine
 
15741
 
 
15742
 
 
15743
   subroutine box03( rslt ,p2,p4,p5,p6 ,rmu )
 
15744
!*******************************************************************
 
15745
! calculates
 
15746
!
 
15747
!     C   /               d^(Dim)q
 
15748
!  ------ | ---------------------------------------
 
15749
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
 
15750
!
 
15751
! with  k1^2=k3^2=0
 
15752
!*******************************************************************
 
15753
  complex(kindr2) &   
 
15754
     ,intent(out) :: rslt(0:2)
 
15755
  complex(kindr2) &   
 
15756
     ,intent(in)  :: p2,p4,p5,p6 
 
15757
  real(kindr2) &  
 
15758
     ,intent(in)  :: rmu
 
15759
   type(qmplx_type) :: q2,q4,q5,q6,q26,q54,qy
 
15760
  complex(kindr2) &   
 
15761
     :: logy
 
15762
  real(kindr2) &  
 
15763
     :: rmu2
 
15764
!
 
15765
   rmu2 = rmu*rmu
 
15766
   q2 = qonv(-p2,-1)
 
15767
   q4 = qonv(-p4,-1)
 
15768
   q5 = qonv(-p5,-1)
 
15769
   q6 = qonv(-p6,-1)
 
15770
   q26 = q2/q6
 
15771
   q54 = q5/q4
 
15772
   qy = q26/q54
 
15773
   logy = logc2(qy)/(p5*p6)
 
15774
   rslt(1) = logy
 
15775
   rslt(0) = li2c2(q6/q4,q2/q5)/(p4*p5) &
 
15776
           + li2c2(q54,q26)/(p4*p6)     &
 
15777
           - li2c2(qonv(1),qy)/(p5*p6) &
 
15778
           - logy*logc(q54*q2*q6/(rmu2*rmu2))/2
 
15779
   rslt(2) = 0
 
15780
   rslt(1) = 2*rslt(1)
 
15781
   rslt(0) = 2*rslt(0)
 
15782
   end subroutine
 
15783
 
 
15784
 
 
15785
   subroutine box05( rslt ,p2,p3,p4,p5,p6 ,rmu )
 
15786
!*******************************************************************
 
15787
! calculates
 
15788
!
 
15789
!     C   /               d^(Dim)q
 
15790
!  ------ | ---------------------------------------
 
15791
!  i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
 
15792
!
 
15793
! with  k1^2=0
 
15794
!*******************************************************************
 
15795
  complex(kindr2) &   
 
15796
     ,intent(out) :: rslt(0:2)
 
15797
  complex(kindr2) &   
 
15798
     ,intent(in)  :: p2,p3,p4,p5,p6
 
15799
  real(kindr2) &  
 
15800
     ,intent(in)  :: rmu
 
15801
   type(qmplx_type) ::q2,q3,q4,q5,q6 ,q25,q64,qy,qz
 
15802
  complex(kindr2) &   
 
15803
     :: logy
 
15804
  real(kindr2) &  
 
15805
     :: rmu2
 
15806
!
 
15807
   rmu2 = rmu*rmu
 
15808
   q2 = qonv(-p2,-1)
 
15809
   q3 = qonv(-p3,-1)
 
15810
   q4 = qonv(-p4,-1)
 
15811
   q5 = qonv(-p5,-1)
 
15812
   q6 = qonv(-p6,-1)
 
15813
   q25 = q2/q5
 
15814
   q64 = q6/q4
 
15815
   qy = q25/q64
 
15816
   qz = q64*q2*q5*q6*q6/q3/q3/(rmu2*rmu2)
 
15817
!
 
15818
   logy = logc2(qy)/(p5*p6)
 
15819
   rslt(2) = 0
 
15820
   rslt(1) = logy
 
15821
   rslt(0) = li2c2(q64,q25)/(p4*p5) &
 
15822
           - li2c2(qonv(1),qy)/(p5*p6) &
 
15823
           - logy*logc(qz)/4
 
15824
   rslt(0) = 2*rslt(0)
 
15825
   end subroutine
 
15826
 
 
15827
 
 
15828
   subroutine box00( rslt ,cp ,api ,rmu )
 
15829
!*******************************************************************
 
15830
! calculates
 
15831
!               C   /              d^(Dim)q
 
15832
!            ------ | ---------------------------------------
 
15833
!            i*pi^2 / q^2 (q+k1)^2 (q+k1+k2)^2 (q+k1+k2+k3)^2
 
15834
!
 
15835
! with  Dim = 4-2*eps
 
15836
!         C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
 
15837
!
 
15838
! input:  p1 = k1^2,  p2 = k2^2,  p3 = k3^2,  p4 = (k1+k2+k3)^2,
 
15839
!         p12 = (k1+k2)^2,  p23 = (k2+k3)^2
 
15840
! output: rslt(0) = eps^0   -coefficient
 
15841
!         rslt(1) = eps^(-1)-coefficient
 
15842
!         rslt(2) = eps^(-2)-coefficient
 
15843
!
 
15844
! If any of these numbers is IDENTICALLY 0d0, the corresponding
 
15845
! IR-singular case is returned.
 
15846
!*******************************************************************
 
15847
   use avh_olo_qp_olog
 
15848
   use avh_olo_qp_dilog
 
15849
  complex(kindr2) &   
 
15850
     ,intent(out) :: rslt(0:2)
 
15851
  complex(kindr2) &   
 
15852
     ,intent(in)  :: cp(6)
 
15853
  real(kindr2) &  
 
15854
     ,intent(in)  :: api(6),rmu
 
15855
  complex(kindr2) &   
 
15856
     :: log3,log4,log5,log6,li24,li25,li26 &
 
15857
                     ,li254,li263
 
15858
  real(kindr2) &  
 
15859
     :: rp1,rp2,rp3,rp4,rp5,rp6,pp(6),ap(6),gg,ff,hh,arg,rmu2
 
15860
   integer :: icase,sf,sgn,i3,i4,i5,i6
 
15861
   integer ,parameter :: base(4)=(/8,4,2,1/)
 
15862
!
 
15863
   rmu2 = rmu*rmu
 
15864
   ff = api(5)*api(6)
 
15865
   gg = api(2)*api(4)
 
15866
   hh = api(1)*api(3)
 
15867
   if     (ff.ge.gg.and.ff.ge.hh) then
 
15868
     pp(1)=areal(cp(1)) ;ap(1)=api(1)
 
15869
     pp(2)=areal(cp(2)) ;ap(2)=api(2)
 
15870
     pp(3)=areal(cp(3)) ;ap(3)=api(3)
 
15871
     pp(4)=areal(cp(4)) ;ap(4)=api(4)
 
15872
     pp(5)=areal(cp(5)) ;ap(5)=api(5)
 
15873
     pp(6)=areal(cp(6)) ;ap(6)=api(6)
 
15874
   elseif (gg.ge.ff.and.gg.ge.hh) then
 
15875
     pp(1)=areal(cp(1)) ;ap(1)=api(1)
 
15876
     pp(2)=areal(cp(6)) ;ap(2)=api(6)
 
15877
     pp(3)=areal(cp(3)) ;ap(3)=api(3)
 
15878
     pp(4)=areal(cp(5)) ;ap(4)=api(5)
 
15879
     pp(5)=areal(cp(4)) ;ap(5)=api(4)
 
15880
     pp(6)=areal(cp(2)) ;ap(6)=api(2)
 
15881
   else
 
15882
     pp(1)=areal(cp(5)) ;ap(1)=api(5)
 
15883
     pp(2)=areal(cp(2)) ;ap(2)=api(2)
 
15884
     pp(3)=areal(cp(6)) ;ap(3)=api(6)
 
15885
     pp(4)=areal(cp(4)) ;ap(4)=api(4)
 
15886
     pp(5)=areal(cp(1)) ;ap(5)=api(1)
 
15887
     pp(6)=areal(cp(3)) ;ap(6)=api(3)
 
15888
   endif
 
15889
!
 
15890
   icase = 0
 
15891
   if (ap(1).gt.RZRO) icase = icase + base(1)
 
15892
   if (ap(2).gt.RZRO) icase = icase + base(2)
 
15893
   if (ap(3).gt.RZRO) icase = icase + base(3)
 
15894
   if (ap(4).gt.RZRO) icase = icase + base(4)
 
15895
   rp1 = pp(permtable(1,icase))
 
15896
   rp2 = pp(permtable(2,icase))
 
15897
   rp3 = pp(permtable(3,icase))
 
15898
   rp4 = pp(permtable(4,icase))
 
15899
   rp5 = pp(permtable(5,icase))
 
15900
   rp6 = pp(permtable(6,icase))
 
15901
   icase = casetable(   icase)
 
15902
!
 
15903
   i3=0 ;if (-rp3.lt.RZRO) i3=-1
 
15904
   i4=0 ;if (-rp4.lt.RZRO) i4=-1
 
15905
   i5=0 ;if (-rp5.lt.RZRO) i5=-1
 
15906
   i6=0 ;if (-rp6.lt.RZRO) i6=-1
 
15907
!
 
15908
   if     (icase.eq.0) then
 
15909
! 0 masses non-zero
 
15910
     gg = 1/( rp5 * rp6 )
 
15911
     log5 = olog(abs(rp5/rmu2),i5)
 
15912
     log6 = olog(abs(rp6/rmu2),i6)
 
15913
     rslt(2) = gg*( 4 )
 
15914
     rslt(1) = gg*(-2*(log5 + log6) )
 
15915
     rslt(0) = gg*( log5**2 + log6**2 - olog(abs(rp5/rp6),i5-i6)**2 - 32*PISQo24 )
 
15916
   elseif (icase.eq.1) then
 
15917
! 1 mass non-zero
 
15918
     gg = 1/( rp5 * rp6 )
 
15919
     ff =  gg*( rp5 + rp6 - rp4 )
 
15920
     log4 = olog(abs(rp4/rmu2),i4)
 
15921
     log5 = olog(abs(rp5/rmu2),i5)
 
15922
     log6 = olog(abs(rp6/rmu2),i6)
 
15923
     sf = sgnRe(ff)
 
15924
     sgn = 0
 
15925
       arg = rp4*ff 
 
15926
       if (arg.lt.RZRO) sgn = sf
 
15927
       li24 = dilog(abs(arg),sgn)
 
15928
     sgn = 0
 
15929
       arg = rp5*ff 
 
15930
       if (arg.lt.RZRO) sgn = sf
 
15931
       li25 = dilog(abs(arg),sgn)
 
15932
     sgn = 0
 
15933
       arg = rp6*ff 
 
15934
       if (arg.lt.RZRO) sgn = sf
 
15935
       li26 = dilog(abs(arg),sgn)
 
15936
     rslt(2) = gg*( 2 )
 
15937
     rslt(1) = gg*( 2*(log4-log5-log6) )
 
15938
     rslt(0) = gg*( log5**2 + log6**2 - log4**2 - 12*PISQo24 &
 
15939
                   + 2*(li25 + li26 - li24) )
 
15940
   elseif (icase.eq.2) then
 
15941
! 2 neighbour masses non-zero
 
15942
     gg = 1/( rp5 * rp6 )
 
15943
     ff =  gg*( rp5 + rp6 - rp4 )
 
15944
     log3 = olog(abs(rp3/rmu2),i3)
 
15945
     log4 = olog(abs(rp4/rmu2),i4)
 
15946
     log5 = olog(abs(rp5/rmu2),i5)
 
15947
     log6 = olog(abs(rp6/rmu2),i6)
 
15948
     li254 = dilog( abs(rp4/rp5) ,i4-i5 )
 
15949
     li263 = dilog( abs(rp3/rp6) ,i3-i6 )
 
15950
     sf = sgnRe(ff)
 
15951
     sgn = 0
 
15952
       arg = rp4*ff 
 
15953
       if (arg.lt.RZRO) sgn = sf
 
15954
       li24 = dilog(abs(arg),sgn)
 
15955
     sgn = 0
 
15956
       arg = rp5*ff 
 
15957
       if (arg.lt.RZRO) sgn = sf
 
15958
       li25 = dilog(abs(arg),sgn)
 
15959
     sgn = 0
 
15960
       arg = rp6*ff 
 
15961
       if (arg.lt.RZRO) sgn = sf
 
15962
       li26 = dilog(abs(arg),sgn)
 
15963
     rslt(2) = gg
 
15964
     rslt(1) = gg*( log4 + log3 - log5 - 2*log6 )
 
15965
     rslt(0) = gg*( log5**2 + log6**2 - log3**2 - log4**2 &
 
15966
                   + (log3 + log4 - log5)**2/2 &
 
15967
                   - 2*PISQo24 + 2*(li254 - li263 + li25 + li26 - li24) )
 
15968
   elseif (icase.eq.5) then
 
15969
! 2 opposite masses non-zero
 
15970
     call box03( rslt ,acmplx(rp2),acmplx(rp4) &
 
15971
                      ,acmplx(rp5),acmplx(rp6) ,rmu )
 
15972
   elseif (icase.eq.3) then
 
15973
! 3 masses non-zero
 
15974
     call box05( rslt ,acmplx(rp2),acmplx(rp3) &
 
15975
                      ,acmplx(rp4),acmplx(rp5) &
 
15976
                      ,acmplx(rp6) ,rmu )
 
15977
   elseif (icase.eq.4) then
 
15978
! 4 masses non-zero
 
15979
     call boxf0( rslt ,acmplx(rp1),acmplx(rp2) &
 
15980
                      ,acmplx(rp3),acmplx(rp4) &
 
15981
                      ,acmplx(rp5),acmplx(rp6) )
 
15982
   endif
 
15983
   end subroutine
 
15984
 
 
15985
  
 
15986
  subroutine boxf0( rslt ,p1,p2,p3,p4,p12,p23 )
 
15987
!*******************************************************************
 
15988
! Finite 1-loop scalar 4-point function with all internal masses
 
15989
! equal zero. Based on the formulas from
 
15990
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
15991
!*******************************************************************
 
15992
  complex(kindr2) &   
 
15993
    ,intent(out) :: rslt(0:2) 
 
15994
  complex(kindr2) &   
 
15995
    ,intent(in) :: p1,p2,p3,p4,p12,p23
 
15996
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qss
 
15997
  complex(kindr2) &   
 
15998
    :: aa,bb,cc,dd,x1,x2,ss,r12,r13,r14,r23,r24,r34
 
15999
  real(kindr2) &  
 
16000
    :: hh
 
16001
!
 
16002
  r12 = -p1  !  p1
 
16003
  r13 = -p12 !  p1+p2
 
16004
  r14 = -p4  !  p1+p2+p3
 
16005
  r23 = -p2  !  p2
 
16006
  r24 = -p23 !  p2+p3
 
16007
  r34 = -p3  !  p3      
 
16008
!
 
16009
  aa = r34*r24
 
16010
!
 
16011
  if (r13.eq.CZRO.or.aa.eq.CZRO) then
 
16012
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf0: ' &
 
16013
       ,'threshold singularity, returning 0'
 
16014
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16015
    return
 
16016
  endif
 
16017
!
 
16018
  bb = r13*r24 + r12*r34 - r14*r23
 
16019
  cc = r12*r13
 
16020
  hh = areal(r23)
 
16021
  dd = mysqrt( bb*bb - 4*aa*cc , -areal(aa)*hh )
 
16022
  call solabc(x1,x2,dd ,aa,bb,cc ,1)
 
16023
  x1 = -x1
 
16024
  x2 = -x2
 
16025
!
 
16026
  qx1 = qonv(x1 , hh)
 
16027
  qx2 = qonv(x2 ,-hh)
 
16028
  q12 = qonv(r12,-1)
 
16029
  q13 = qonv(r13,-1)
 
16030
  q14 = qonv(r14,-1)
 
16031
  q23 = qonv(r23,-1)
 
16032
  q24 = qonv(r24,-1)
 
16033
  q34 = qonv(r34,-1)
 
16034
!
 
16035
  rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16036
!
 
16037
  qss = q34/q13
 
16038
  rslt(0) = rslt(0) + li2c2(qx1*qss,qx2*qss) * r34/r13
 
16039
!
 
16040
  qss = q24/q12
 
16041
  rslt(0) = rslt(0) + li2c2(qx1*qss,qx2*qss) * r24/r12
 
16042
!
 
16043
  ss = -logc2(qx1/qx2) / x2
 
16044
  rslt(0) = rslt(0) + ss*( logc(qx1*qx2)/2 - logc(q12*q13/q14/q23) )
 
16045
!
 
16046
  rslt(0) = -rslt(0) / aa
 
16047
  end subroutine
 
16048
 
 
16049
 
 
16050
  subroutine boxf1( rslt ,p1,p2,p3,p4,p12,p23 ,m4 )
 
16051
!*******************************************************************
 
16052
! Finite 1-loop scalar 4-point function with one internal mass
 
16053
! non-zero. Based on the formulas from
 
16054
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
16055
!*******************************************************************
 
16056
  complex(kindr2) &   
 
16057
    ,intent(out) :: rslt(0:2) 
 
16058
  complex(kindr2) &   
 
16059
    ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m4
 
16060
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
 
16061
  complex(kindr2) &   
 
16062
    :: smm,sm4,aa,bb,cc,dd,x1,x2,r12,r13,r14,r23,r24,r34
 
16063
  logical :: r12zero,r13zero,r14zero
 
16064
!
 
16065
  sm4 = mysqrt(m4)
 
16066
  smm = abs(sm4) 
 
16067
!
 
16068
  r12 = ( m4-p4 -p4 *IEPS )/(smm*sm4)
 
16069
  r13 = ( m4-p23-p23*IEPS )/(smm*sm4)
 
16070
  r14 = ( m4-p3 -p3 *IEPS )/(smm*sm4)
 
16071
  r23 = (   -p1 -p1 *IEPS )/(smm*smm)
 
16072
  r24 = (   -p12-p12*IEPS )/(smm*smm)
 
16073
  r34 = (   -p2 -p2 *IEPS )/(smm*smm)
 
16074
!
 
16075
  r12zero=(abs(areal(r12))+abs(aimag(r12)).lt.neglig(prcpar))
 
16076
  r13zero=(abs(areal(r13))+abs(aimag(r13)).lt.neglig(prcpar))
 
16077
  r14zero=(abs(areal(r14))+abs(aimag(r14)).lt.neglig(prcpar))
 
16078
!
 
16079
  aa = r34*r24
 
16080
!
 
16081
  if (aa.eq.CZRO) then
 
16082
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf1: ' &
 
16083
       ,'threshold singularity, returning 0'
 
16084
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16085
    return
 
16086
  endif
 
16087
!
 
16088
  bb = r13*r24 + r12*r34 - r14*r23
 
16089
  cc = r12*r13 - r23
 
16090
  call solabc(x1,x2,dd ,aa,bb,cc ,0)
 
16091
  x1 = -x1
 
16092
  x2 = -x2
 
16093
!
 
16094
  qx1 = qonv(x1 ,1 )
 
16095
  qx2 = qonv(x2 ,1 )
 
16096
  q12 = qonv(r12,-1)
 
16097
  q13 = qonv(r13,-1)
 
16098
  q14 = qonv(r14,-1)
 
16099
  q23 = qonv(r23,-1)
 
16100
  q24 = qonv(r24,-1)
 
16101
  q34 = qonv(r34,-1)
 
16102
!
 
16103
  rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16104
!
 
16105
  if (r12zero.and.r13zero) then
 
16106
    qss = qx1*qx2*q34*q24/q23
 
16107
    qss = qss*qss
 
16108
    rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16109
  else
 
16110
    if (r13zero) then
 
16111
      qss = q34*q12/q23
 
16112
      qss = qx1*qx2*qss*qss
 
16113
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16114
    else
 
16115
      qss = q34/q13
 
16116
      rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
 
16117
    endif
 
16118
    if (r12zero) then
 
16119
      qss = q24*q13/q23
 
16120
      qss = qx1*qx2*qss*qss
 
16121
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16122
    else
 
16123
      qss = q24/q12
 
16124
      rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24/r12
 
16125
    endif
 
16126
    if (.not.r12zero.and..not.r13zero) then
 
16127
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( q12*q13/q23 )/x2
 
16128
    endif
 
16129
  endif
 
16130
!
 
16131
  if (.not.r14zero) then
 
16132
    rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
 
16133
  endif
 
16134
!
 
16135
  rslt(0) = -rslt(0)/(aa*smm*smm*smm*sm4)
 
16136
  end subroutine
 
16137
 
 
16138
 
 
16139
  subroutine boxf5( rslt ,p1,p2,p3,p4,p12,p23, m2,m4 )
 
16140
!*******************************************************************
 
16141
! Finite 1-loop scalar 4-point function with two opposite internal
 
16142
! masses non-zero. Based on the formulas from
 
16143
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
16144
!*******************************************************************
 
16145
  complex(kindr2) &   
 
16146
    ,intent(out) :: rslt(0:2) 
 
16147
  complex(kindr2) &   
 
16148
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m2,m4
 
16149
  call boxf2( rslt ,p12,p2,p23,p4,p1,p3 ,m2,m4 )
 
16150
  end subroutine
 
16151
 
 
16152
 
 
16153
  subroutine boxf2( rslt ,p1,p2,p3,p4,p12,p23 ,m3,m4 )
 
16154
!*******************************************************************
 
16155
! Finite 1-loop scalar 4-point function with two adjacent internal
 
16156
! masses non-zero. Based on the formulas from
 
16157
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
16158
!*******************************************************************
 
16159
  complex(kindr2) &   
 
16160
    ,intent(out) :: rslt(0:2) 
 
16161
  complex(kindr2) &   
 
16162
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m3,m4
 
16163
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
 
16164
  complex(kindr2) &   
 
16165
    :: smm,sm3,sm4,aa,bb,cc,dd,x1,x2 &
 
16166
                    ,r12,r13,r14,r23,r24,r34,d14,k14
 
16167
  logical :: r12zero,r13zero,r24zero,r34zero
 
16168
!
 
16169
  sm3 = mysqrt(m3)
 
16170
  sm4 = mysqrt(m4)
 
16171
!
 
16172
  smm = abs(sm3)
 
16173
!
 
16174
  r12 = (    m4-p4 -p4 *IEPS )/(smm*sm4)
 
16175
  r13 = (    m4-p23-p23*IEPS )/(smm*sm4)
 
16176
  k14 = ( m3+m4-p3 -p3 *IEPS )/(sm3*sm4)
 
16177
  r23 = (      -p1 -p1 *IEPS )/(smm*smm)
 
16178
  r24 = (    m3-p12-p12*IEPS )/(smm*sm3)
 
16179
  r34 = (    m3-p2 -p2 *IEPS )/(smm*sm3)
 
16180
!
 
16181
  r12zero = (abs(areal(r12))+abs(aimag(r12)).lt.neglig(prcpar))
 
16182
  r13zero = (abs(areal(r13))+abs(aimag(r13)).lt.neglig(prcpar))
 
16183
  r24zero = (abs(areal(r24))+abs(aimag(r24)).lt.neglig(prcpar))
 
16184
  r34zero = (abs(areal(r34))+abs(aimag(r34)).lt.neglig(prcpar))
 
16185
!
 
16186
  if (r12zero.and.r24zero) then
 
16187
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
 
16188
       ,'m4=p4 and m3=p12, returning 0'
 
16189
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16190
    return
 
16191
  endif
 
16192
  if (r13zero.and.r34zero) then
 
16193
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
 
16194
       ,'m4=p23 and m3=p2, returning 0'
 
16195
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16196
    return
 
16197
  endif
 
16198
!
 
16199
  call rfun( r14,d14 ,k14 )
 
16200
!
 
16201
  aa = r34*r24 - r23
 
16202
!
 
16203
  if (aa.eq.CZRO) then
 
16204
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf2: ' &
 
16205
       ,'threshold singularity, returning 0'
 
16206
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16207
    return
 
16208
  endif
 
16209
!
 
16210
  bb = r13*r24 + r12*r34 - k14*r23
 
16211
  cc = r12*r13 - r23
 
16212
  call solabc(x1,x2,dd ,aa,bb,cc ,0)
 
16213
  x1 = -x1
 
16214
  x2 = -x2
 
16215
!
 
16216
  qx1 = qonv(x1 ,1 )
 
16217
  qx2 = qonv(x2 ,1 )
 
16218
  q12 = qonv(r12,-1)
 
16219
  q13 = qonv(r13,-1)
 
16220
  q14 = qonv(r14,-1)
 
16221
  q23 = qonv(r23,-1)
 
16222
  q24 = qonv(r24,-1)
 
16223
  q34 = qonv(r34,-1)
 
16224
!
 
16225
  rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16226
!
 
16227
  rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
 
16228
  rslt(0) = rslt(0) - li2c2( qx1/q14 ,qx2/q14 )/r14
 
16229
!
 
16230
  if (r12zero.and.r13zero) then
 
16231
    qss = qx1*qx2*q34*q24/q23
 
16232
    qss = qss*qss
 
16233
    rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16234
  else
 
16235
    if (r13zero) then
 
16236
      qss = q34*q12/q23
 
16237
      qss = qx1*qx2*qss*qss
 
16238
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16239
    elseif (.not.r34zero) then
 
16240
      qss = q34/q13
 
16241
      rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
 
16242
    endif
 
16243
    if (r12zero) then
 
16244
      qss = q24*q13/q23
 
16245
      qss = qx1*qx2*qss*qss
 
16246
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( qss )/(x2*2)
 
16247
    elseif (.not.r24zero) then
 
16248
      qss = q24/q12
 
16249
      rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24/r12
 
16250
    endif
 
16251
    if (.not.r12zero.and..not.r13zero) then
 
16252
      rslt(0) = rslt(0) + logc2( qx1/qx2 )*logc( q12*q13/q23 )/x2 
 
16253
    endif
 
16254
  endif
 
16255
!
 
16256
  rslt(0) = -rslt(0)/(aa*smm*smm*sm3*sm4)
 
16257
  end subroutine
 
16258
 
 
16259
 
 
16260
  subroutine boxf3( rslt ,pp ,mm )
 
16261
!*******************************************************************
 
16262
! Finite 1-loop scalar 4-point function with three internal masses
 
16263
! non-zero.
 
16264
!*******************************************************************
 
16265
  complex(kindr2) &   
 
16266
    ,intent(out) :: rslt(0:2) 
 
16267
  complex(kindr2) &   
 
16268
    ,intent(in) :: pp(6),mm(4)
 
16269
  integer :: j
 
16270
  integer ,parameter :: ip(6)=(/4,5,2,6,3,1/)
 
16271
  integer ,parameter :: im(4)=(/4,1,3,2/)
 
16272
  integer ,parameter :: ic(4,6)=reshape((/1,2,3,4 ,2,3,4,1 ,3,4,1,2 &
 
16273
                                  ,4,1,2,3 ,5,6,5,6 ,6,5,6,5/),(/4,6/))
 
16274
!
 
16275
  if     (mm(1).eq.CZRO) then ;j=3
 
16276
  elseif (mm(2).eq.CZRO) then ;j=4
 
16277
  elseif (mm(3).eq.CZRO) then ;j=1
 
16278
  else                        ;j=2
 
16279
  endif
 
16280
  call boxf33( rslt ,pp(ic(j,ip(1))) ,pp(ic(j,ip(2))) ,pp(ic(j,ip(3))) &
 
16281
                    ,pp(ic(j,ip(4))) ,pp(ic(j,ip(5))) ,pp(ic(j,ip(6))) &
 
16282
                    ,mm(ic(j,im(1))) ,mm(ic(j,im(2))) ,mm(ic(j,im(4))) )
 
16283
  end subroutine
 
16284
 
 
16285
  subroutine boxf33( rslt ,p1,p2,p3,p4,p12,p23, m1,m2,m4 )
 
16286
!*******************************************************************
 
16287
! Finite 1-loop scalar 4-point function with three internal masses
 
16288
! non-zero, and m3=0. Based on the formulas from
 
16289
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
16290
!*******************************************************************
 
16291
  complex(kindr2) &   
 
16292
    ,intent(out) :: rslt(0:2) 
 
16293
  complex(kindr2) &   
 
16294
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m4
 
16295
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34,qy1,qy2
 
16296
  complex(kindr2) &   
 
16297
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2 &
 
16298
                    ,r12,r13,r14,r23,r24,r34,d12,d14,d24,k12,k14,k24
 
16299
  logical ::r13zero,r23zero,r34zero
 
16300
!
 
16301
  sm1 = mysqrt(m1)
 
16302
  sm2 = mysqrt(m2)
 
16303
  sm4 = mysqrt(m4)
 
16304
  sm3 = abs(sm2)
 
16305
!
 
16306
  k12 = ( m1+m2-p1 -p1 *IEPS )/(sm1*sm2) ! p1
 
16307
  r13 = ( m1   -p12-p12*IEPS )/(sm1*sm3) ! p1+p2
 
16308
  k14 = ( m1+m4-p4 -p4 *IEPS )/(sm1*sm4) ! p1+p2+p3
 
16309
  r23 = ( m2   -p2 -p2 *IEPS )/(sm2*sm3) ! p2
 
16310
  k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
 
16311
  r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
16312
!
 
16313
  r13zero = (abs(areal(r13))+abs(aimag(r13)).lt.neglig(prcpar))
 
16314
  r23zero = (abs(areal(r23))+abs(aimag(r23)).lt.neglig(prcpar))
 
16315
  r34zero = (abs(areal(r34))+abs(aimag(r34)).lt.neglig(prcpar))
 
16316
!
 
16317
  if (r13zero) then
 
16318
    if     (r23zero) then
 
16319
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
 
16320
       ,'m4=p4 and m3=p12, returning 0'
 
16321
      rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16322
      return
 
16323
    elseif (r34zero) then
 
16324
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
 
16325
       ,'m2=p1 and m3=p12, returning 0'
 
16326
      rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16327
      return
 
16328
    endif
 
16329
  endif
 
16330
!
 
16331
  call rfun( r12,d12 ,k12 )
 
16332
  call rfun( r14,d14 ,k14 )
 
16333
  call rfun( r24,d24 ,k24 )
 
16334
!
 
16335
  aa = r34/r24 - r23
 
16336
!
 
16337
  if (aa.eq.CZRO) then
 
16338
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf33: ' &
 
16339
       ,'threshold singularity, returning 0'
 
16340
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16341
    return
 
16342
  endif
 
16343
!
 
16344
  bb = -r13*d24 + k12*r34 - k14*r23
 
16345
  cc = k12*r13 + r24*r34 - k14*r24*r13 - r23
 
16346
  call solabc(x1,x2,dd ,aa,bb,cc ,0)
 
16347
  x1 = -x1
 
16348
  x2 = -x2
 
16349
!
 
16350
  qx1 = qonv(x1 ,1 ) ! x1 SHOULD HAVE im. part
 
16351
  qx2 = qonv(x2 ,1 ) ! x2 SHOULD HAVE im. part
 
16352
  q12 = qonv(r12,-1)
 
16353
  q13 = qonv(r13,-1)
 
16354
  q14 = qonv(r14,-1)
 
16355
  q23 = qonv(r23,-1)
 
16356
  q24 = qonv(r24,-1)
 
16357
  q34 = qonv(r34,-1)
 
16358
!
 
16359
  rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16360
!
 
16361
  qy1 = qx1/q24
 
16362
  qy2 = qx2/q24
 
16363
  rslt(0) = rslt(0) + li2c2( qy1*q12 ,qy2*q12 )/r24*r12
 
16364
  rslt(0) = rslt(0) + li2c2( qy1/q12 ,qy2/q12 )/r24/r12
 
16365
  rslt(0) = rslt(0) - li2c2( qx1*q14 ,qx2*q14 )*r14
 
16366
  rslt(0) = rslt(0) - li2c2( qx1/q14 ,qx2/q14 )/r14
 
16367
!
 
16368
  if (.not.r13zero) then
 
16369
    if (.not.r23zero) then
 
16370
      qss = q23/q13/q24
 
16371
      rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23/(r13*r24)
 
16372
    endif
 
16373
    if (.not.r34zero) then
 
16374
      qss = q34/q13
 
16375
      rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34/r13
 
16376
    endif
 
16377
  else
 
16378
    rslt(0) = rslt(0) - logc2( qx1/qx2 )*logc( q23/q24/q34 )/x2 
 
16379
  endif
 
16380
!
 
16381
  rslt(0) = -rslt(0)/(aa*sm1*sm2*sm3*sm4)
 
16382
  end subroutine
 
16383
 
 
16384
 
 
16385
  subroutine boxf4( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
16386
!*******************************************************************
 
16387
! Finite 1-loop scalar 4-point function with all internal masses
 
16388
! non-zero. Based on the formulas from
 
16389
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
 
16390
!*******************************************************************
 
16391
  complex(kindr2) &   
 
16392
    ,intent(out) :: rslt(0:2) 
 
16393
  complex(kindr2) &   
 
16394
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4
 
16395
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qy1,qy2,qtt
 
16396
  complex(kindr2) &   
 
16397
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2,tt &
 
16398
                    ,k12,k13,k14,k23,k24,k34 &
 
16399
                    ,r12,r13,r14,r23,r24,r34 &
 
16400
                    ,d12,d13,d14,d23,d24,d34
 
16401
  real(kindr2) &  
 
16402
    :: h1,h2
 
16403
!
 
16404
  sm1 = mysqrt(m1)
 
16405
  sm2 = mysqrt(m2)
 
16406
  sm3 = mysqrt(m3)
 
16407
  sm4 = mysqrt(m4)
 
16408
!
 
16409
  k12 = ( m1+m2-p1 -p1 *IEPS)/(sm1*sm2) ! p1
 
16410
  k13 = ( m1+m3-p12-p12*IEPS)/(sm1*sm3) ! p1+p2
 
16411
  k14 = ( m1+m4-p4 -p4 *IEPS)/(sm1*sm4) ! p1+p2+p3
 
16412
  k23 = ( m2+m3-p2 -p2 *IEPS)/(sm2*sm3) ! p2
 
16413
  k24 = ( m2+m4-p23-p23*IEPS)/(sm2*sm4) ! p2+p3
 
16414
  k34 = ( m3+m4-p3 -p3 *IEPS)/(sm3*sm4) ! p3
 
16415
!
 
16416
  call rfun( r12,d12 ,k12 )
 
16417
  call rfun( r13,d13 ,k13 )
 
16418
  call rfun( r14,d14 ,k14 )
 
16419
  call rfun( r23,d23 ,k23 )
 
16420
  call rfun( r24,d24 ,k24 )
 
16421
  call rfun( r34,d34 ,k34 )
 
16422
!
 
16423
  aa = k34/r24 + r13*k12 - k14*r13/r24 - k23
 
16424
!
 
16425
  if (aa.eq.CZRO) then
 
16426
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxf4: ' &
 
16427
       ,'threshold singularity, returning 0'
 
16428
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16429
    return
 
16430
  endif
 
16431
!
 
16432
  bb = d13*d24 + k12*k34 - k14*k23
 
16433
  cc = k12/r13 + r24*k34 - k14*r24/r13 - k23
 
16434
  call solabc(x1,x2,dd ,aa,bb,cc ,0)
 
16435
!
 
16436
  h1 = areal(k23 - r13*k12 - r24*k34 + r13*r24*k14)
 
16437
  h2 = h1*areal(aa)*areal(x1)
 
16438
  h1 = h1*areal(aa)*areal(x2)
 
16439
!
 
16440
  qx1 = qonv(-x1,-h1) ! x1 should have im. part
 
16441
  qx2 = qonv(-x2,-h2) ! x2 should have im. part
 
16442
  q12 = qonv(r12,-1)
 
16443
  q13 = qonv(r13,-1)
 
16444
  q14 = qonv(r14,-1)
 
16445
  q23 = qonv(r23,-1)
 
16446
  q24 = qonv(r24,-1)
 
16447
  q34 = qonv(r34,-1)
 
16448
!
 
16449
  rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16450
!
 
16451
  qy1 = qx1/q24
 
16452
  qy2 = qx2/q24
 
16453
  rslt(0) = rslt(0) + ( li2c2( qy1*q12 ,qy2*q12 )*r12 &
 
16454
                      + li2c2( qy1/q12 ,qy2/q12 )/r12 )/r24
 
16455
  tt = r13/r24
 
16456
  qtt = qonv(tt,-areal(r24) )
 
16457
  qy1 = qx1*qtt
 
16458
  qy2 = qx2*qtt
 
16459
  rslt(0) = rslt(0) - ( li2c2( qy1*q23 ,qy2*q23 )*r23 &
 
16460
                      + li2c2( qy1/q23 ,qy2/q23 )/r23 )*tt
 
16461
  qy1 = qx1*q13
 
16462
  qy2 = qx2*q13
 
16463
  rslt(0) = rslt(0) + ( li2c2( qy1*q34 ,qy2*q34 )*r34 &
 
16464
                      + li2c2( qy1/q34 ,qy2/q34 )/r34 )*r13
 
16465
!
 
16466
  rslt(0) = rslt(0) - ( li2c2( qx1*q14 ,qx2*q14 )*r14 &
 
16467
                      + li2c2( qx1/q14 ,qx2/q14 )/r14 )
 
16468
!
 
16469
  rslt(0) = -rslt(0)/(aa*sm1*sm2*sm3*sm4)
 
16470
  end subroutine
 
16471
 
 
16472
end module
 
16473
 
 
16474
 
 
16475
module avh_olo_qp_boxc
 
16476
   use avh_olo_units
 
16477
   use avh_olo_qp_prec
 
16478
   use avh_olo_qp_auxfun
 
16479
   use avh_olo_qp_qmplx
 
16480
   implicit none
 
16481
   private
 
16482
   public :: boxc
 
16483
 
 
16484
contains
 
16485
 
 
16486
   subroutine boxc( rslt ,pp_in ,mm_in ,ap_in ,smax )
 
16487
!*******************************************************************
 
16488
! Finite 1-loop scalar 4-point function for complex internal masses
 
16489
! Based on the formulas from
 
16490
!   Dao Thi Nhung and Le Duc Ninh, arXiv:0902.0325 [hep-ph]
 
16491
!   G. 't Hooft and M.J.G. Veltman, Nucl.Phys.B153:365-401,1979 
 
16492
!*******************************************************************
 
16493
   use avh_olo_qp_box ,only: base,casetable,ll=>permtable
 
16494
  complex(kindr2) &   
 
16495
     ,intent(out) :: rslt(0:2)
 
16496
  complex(kindr2) &   
 
16497
     ,intent(in)  :: pp_in(6),mm_in(4)
 
16498
  real(kindr2) &  
 
16499
     ,intent(in)  :: ap_in(6),smax
 
16500
  complex(kindr2) &   
 
16501
     :: pp(6),mm(4)
 
16502
  real(kindr2) &  
 
16503
     :: ap(6),aptmp(6),rem,imm,hh
 
16504
  complex(kindr2) &   
 
16505
     :: a,b,c,d,e,f,g,h,j,k,dpe,epk,x1,x2,sdnt,o1,j1,e1 &
 
16506
       ,dek,dpf,def,dpk,abc,bgj,jph,cph
 
16507
   integer :: icase,jcase,ii
 
16508
!
 
16509
   rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
16510
!
 
16511
   hh = neglig(prcpar)*smax
 
16512
   do ii=1,6
 
16513
     if (ap_in(ii).ge.hh) then ;ap(ii)=ap_in(ii)
 
16514
                          else ;ap(ii)=0
 
16515
     endif
 
16516
   enddo
 
16517
!
 
16518
   do ii=1,4
 
16519
     if (ap(ii).eq.RZRO) then ;pp(ii)=0
 
16520
                         else ;pp(ii)=pp_in(ii)
 
16521
     endif
 
16522
   enddo
 
16523
   if (ap(5).eq.RZRO) then
 
16524
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
 
16525
       ,' |s| too small, putting it by hand'
 
16526
     ap(5) = hh
 
16527
     pp(5) = acmplx(sign(hh,areal(pp_in(5))))
 
16528
   else
 
16529
     pp(5) = pp_in(5)
 
16530
   endif
 
16531
   if (ap(6).eq.RZRO) then
 
16532
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
 
16533
       ,' |t| too small, putting it by hand'
 
16534
     ap(6) = hh
 
16535
     pp(6) = acmplx(sign(hh,areal(pp_in(6))))
 
16536
   else
 
16537
     pp(6) = pp_in(6)
 
16538
   endif
 
16539
!
 
16540
   do ii=1,4
 
16541
     rem = areal(mm_in(ii))
 
16542
     imm = aimag(mm_in(ii))
 
16543
     hh = EPSN*abs(rem)
 
16544
     if (abs(imm).lt.hh) imm = -hh
 
16545
     mm(ii) = acmplx(rem,imm)
 
16546
   enddo
 
16547
!
 
16548
   icase = 0
 
16549
   do ii=1,4
 
16550
     if (ap(ii).gt.RZRO) icase = icase + base(ii)
 
16551
   enddo
 
16552
!
 
16553
   if (icase.lt.15) then
 
16554
! at least one exernal mass equal zero
 
16555
     jcase = casetable(icase)
 
16556
     if (jcase.eq.0.or.jcase.eq.1.or.jcase.eq.5) then
 
16557
! two opposite masses equal zero
 
16558
       a = pp(ll(5,icase)) - pp(ll(1,icase))
 
16559
       c = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(3,icase))
 
16560
       g = pp(ll(2,icase))
 
16561
       h = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
 
16562
       d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
 
16563
       e = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
 
16564
       f = mm(ll(4,icase))
 
16565
       k = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
 
16566
       dpe = (mm(ll(1,icase)) - mm(ll(4,icase))) - pp(ll(4,icase))
 
16567
       dpk = (mm(ll(2,icase)) - mm(ll(4,icase))) - pp(ll(6,icase))
 
16568
       dpf = mm(ll(3,icase)) - pp(ll(3,icase))
 
16569
       rslt(0) = t13fun( a,c,g,h ,d,e,f,k ,dpe,dpk,dpf )
 
16570
     else
 
16571
       a = pp(ll(3,icase))
 
16572
       b = pp(ll(2,icase))
 
16573
       c = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
 
16574
       h = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(6,icase)) + pp(ll(2,icase))
 
16575
       j = pp(ll(5,icase)) - pp(ll(1,icase)) - pp(ll(2,icase))
 
16576
       d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
 
16577
       e = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
 
16578
       k = (mm(ll(1,icase)) - mm(ll(2,icase))) + pp(ll(6,icase)) - pp(ll(4,icase))
 
16579
       f = mm(ll(4,icase))
 
16580
       cph = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(3,icase))
 
16581
       dpe = (mm(ll(2,icase)) - mm(ll(4,icase))) - pp(ll(6,icase))
 
16582
       epk = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
 
16583
       dek = (mm(ll(1,icase)) - mm(ll(4,icase))) - pp(ll(4,icase))
 
16584
       dpf = mm(ll(3,icase)) - pp(ll(3,icase))
 
16585
       rslt(0) = tfun( a,b  ,c  ,h,j ,d,e  ,f ,k ,dpe,dpf ) &
 
16586
               - tfun( a,b+j,cph,h,j ,d,epk,f ,k ,dek,dpf )
 
16587
     endif
 
16588
   else
 
16589
! no extenal mass equal zero
 
16590
     if    (areal((pp(5)-pp(1)-pp(2))**2-4*pp(1)*pp(2)).gt.RZRO)then ;icase=0 !12, no permutation
 
16591
     elseif(areal((pp(6)-pp(2)-pp(3))**2-4*pp(2)*pp(3)).gt.RZRO)then ;icase=8 !23, 1 cyclic permutation
 
16592
     elseif(areal((pp(4)-pp(5)-pp(3))**2-4*pp(5)*pp(3)).gt.RZRO)then ;icase=4 !34, 2 cyclic permutations
 
16593
     elseif(areal((pp(4)-pp(1)-pp(6))**2-4*pp(1)*pp(6)).gt.RZRO)then ;icase=2 !41, 3 cyclic permutations
 
16594
     else
 
16595
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
 
16596
         ,'no positive lambda, returning 0'
 
16597
       return
 
16598
     endif
 
16599
     a = pp(ll(3,icase))
 
16600
     b = pp(ll(2,icase))
 
16601
     g = pp(ll(1,icase))
 
16602
     c = pp(ll(6,icase)) - pp(ll(2,icase)) - pp(ll(3,icase))
 
16603
     h = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(6,icase)) + pp(ll(2,icase))
 
16604
     j = pp(ll(5,icase)) - pp(ll(1,icase)) - pp(ll(2,icase))
 
16605
     d = (mm(ll(3,icase)) - mm(ll(4,icase))) - pp(ll(3,icase))
 
16606
     e = (mm(ll(2,icase)) - mm(ll(3,icase))) - pp(ll(6,icase)) + pp(ll(3,icase))
 
16607
     k = (mm(ll(1,icase)) - mm(ll(2,icase))) + pp(ll(6,icase)) - pp(ll(4,icase))
 
16608
     f = mm(ll(4,icase))
 
16609
     abc = pp(ll(6,icase))
 
16610
     bgj = pp(ll(5,icase))
 
16611
     jph = pp(ll(4,icase)) - pp(ll(1,icase)) - pp(ll(6,icase))
 
16612
     cph = pp(ll(4,icase)) - pp(ll(5,icase)) - pp(ll(3,icase))
 
16613
     dpe = (mm(ll(2,icase)) - mm(ll(4,icase))) - pp(ll(6,icase))
 
16614
     epk = (mm(ll(1,icase)) - mm(ll(3,icase))) + pp(ll(3,icase)) - pp(ll(4,icase))
 
16615
     dek = (mm(ll(1,icase)) - mm(ll(4,icase))) - pp(ll(4,icase))
 
16616
     dpf = mm(ll(3,icase)) - pp(ll(3,icase))
 
16617
     def = mm(ll(2,icase)) - pp(ll(6,icase))
 
16618
     call solabc( x1,x2 ,sdnt ,g,j,b ,0 )
 
16619
     if (aimag(sdnt).ne.RZRO) then
 
16620
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop boxc: ' &
 
16621
         ,'no real solution for alpha, returning 0'
 
16622
       return
 
16623
     endif
 
16624
!BAD        if (abs(areal(x1)).gt.abs(areal(x2))) then
 
16625
     if (abs(areal(x1)).lt.abs(areal(x2))) then !BETTER
 
16626
       sdnt = x1
 
16627
       x1 = x2
 
16628
       x2 = sdnt
 
16629
     endif
 
16630
     o1 = 1-x1
 
16631
     j1 = j+2*g*x1
 
16632
     e1 = e+k*x1
 
16633
     rslt(0) =   -tfun( abc,g  ,jph,c+2*b+(h+j)*x1, j1   ,dpe,k  ,f,e1 ,dek,def ) &
 
16634
             + o1*tfun( a  ,bgj,cph,c+h*x1        , o1*j1,d  ,epk,f,e1 ,dek,dpf ) &
 
16635
             + x1*tfun( a  ,b  ,c  ,c+h*x1        ,-j1*x1,d  ,e  ,f,e1 ,dpe,dpf )
 
16636
   endif
 
16637
   end subroutine
 
16638
 
 
16639
 
 
16640
   function t13fun( aa,cc,gg,hh ,dd,ee,ff,jj ,dpe,dpj,dpf ) result(rslt)
 
16641
!*******************************************************************
 
16642
! /1   /x                             y
 
16643
! | dx |  dy -----------------------------------------------------
 
16644
! /0   /0    (gy^2 + hxy + dx + jy + f)*(ax^2 + cxy + dx + ey + f)
 
16645
!
 
16646
! jj should have negative imaginary part
 
16647
!*******************************************************************
 
16648
  complex(kindr2) &   
 
16649
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj ,dpe,dpj,dpf
 
16650
  complex(kindr2) &   
 
16651
     :: rslt ,kk,ll,nn,y1,y2,sdnt
 
16652
!
 
16653
!
 
16654
   kk = hh*aa - cc*gg
 
16655
   ll = aa*dd + hh*ee - dd*gg - cc*jj
 
16656
   nn = dd*(ee - jj) + (hh - cc)*(ff-IEPS*abs(areal(ff)))
 
16657
   call solabc( y1,y2 ,sdnt ,kk,ll,nn ,0 )
 
16658
!
 
16659
   rslt = - s3fun( y1,y2 ,CZRO,CONE ,aa   ,ee+cc,dpf ) &
 
16660
          + s3fun( y1,y2 ,CZRO,CONE ,gg   ,jj+hh,dpf ) &
 
16661
          - s3fun( y1,y2 ,CZRO,CONE ,gg+hh,dpj  ,ff  ) &
 
16662
          + s3fun( y1,y2 ,CZRO,CONE ,aa+cc,dpe  ,ff  )
 
16663
!
 
16664
   rslt = rslt/kk
 
16665
   end function
 
16666
 
 
16667
 
 
16668
   function t1fun( aa,cc,gg,hh ,dd,ee,ff,jj ,dpe ) result(rslt)
 
16669
!*******************************************************************
 
16670
! /1   /x                         1
 
16671
! | dx |  dy ----------------------------------------------
 
16672
! /0   /0    (g*x + h*x + j)*(a*x^2 + c*xy + d*x + e*y + f)
 
16673
!
 
16674
! jj should have negative imaginary part
 
16675
!*******************************************************************
 
16676
  complex(kindr2) &   
 
16677
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj,dpe
 
16678
  complex(kindr2) &   
 
16679
     ::rslt ,kk,ll,nn,y1,y2,sdnt
 
16680
!
 
16681
!
 
16682
   kk = hh*aa - cc*gg
 
16683
   ll = hh*dd - cc*jj - ee*gg
 
16684
   nn = hh*(ff-IEPS*abs(areal(ff))) - ee*jj
 
16685
   call solabc( y1,y2 ,sdnt ,kk,ll,nn ,0 )
 
16686
!
 
16687
   rslt = - s3fun( y1,y2 ,CZRO,CONE ,aa+cc,dpe  ,ff ) &
 
16688
          + s3fun( y1,y2 ,CZRO,CONE ,CZRO ,gg+hh,jj ) &
 
16689
          - s3fun( y1,y2 ,CZRO,CONE ,CZRO ,gg   ,jj ) &
 
16690
          + s3fun( y1,y2 ,CZRO,CONE ,aa   ,dd   ,ff )
 
16691
!
 
16692
   rslt = rslt/kk
 
16693
   end function
 
16694
 
 
16695
 
 
16696
   function tfun( aa,bb,cc ,gin,hin ,dd,ee,ff ,jin ,dpe ,dpf ) result(rslt)
 
16697
!*******************************************************************
 
16698
! /1   /x                             1
 
16699
! | dx |  dy ------------------------------------------------------
 
16700
! /0   /0    (g*x + h*x + j)*(a*x^2 + b*y^2 + c*xy + d*x + e*y + f)
 
16701
!*******************************************************************
 
16702
  complex(kindr2) &   
 
16703
     ,intent(in) :: aa,bb,cc ,gin,hin ,dd,ee,ff ,jin ,dpe ,dpf
 
16704
  complex(kindr2) &   
 
16705
     :: rslt ,gg,hh,jj,zz(2),beta,tmpa(2),tmpb(2) &
 
16706
       ,tmpc(2),kiz(2),ll,nn,kk,y1,y2,yy(2,2),sdnt
 
16707
  real(kindr2) &  
 
16708
     :: ab1,ab2,ac1,ac2,abab,acac,abac,det,ap1,ap2 &
 
16709
                  ,apab,apac,x1(2,2),x2(2,2),xmin
 
16710
   integer :: iz,iy,izmin,sj
 
16711
   logical :: pp(2,2),p1,p2
 
16712
!
 
16713
!
 
16714
   sj = sgnIm(jin,-1)
 
16715
   gg = -sj*gin
 
16716
   hh = -sj*hin
 
16717
   jj = -sj*jin
 
16718
!
 
16719
   if     (bb.eq.CZRO) then
 
16720
     rslt = -sj*t1fun( aa,cc,gg,hh ,dd,ee,ff,jj ,dpe )
 
16721
     return
 
16722
   elseif (aa.eq.CZRO) then
 
16723
     rslt = -sj*t1fun( bb+cc,-cc,-gg-hh,gg, -dpe-2*(bb+cc),dd+cc &
 
16724
                      ,dpe+bb+cc+ff,gg+hh+jj ,-ee-2*bb-cc )
 
16725
     return
 
16726
   endif
 
16727
!
 
16728
   call solabc( zz(1),zz(2) ,sdnt ,bb,cc,aa ,0 )
 
16729
   if (abs(zz(1)).gt.abs(zz(2))) then
 
16730
     beta = zz(1)
 
16731
     zz(1) = zz(2)
 
16732
     zz(2) = beta
 
16733
   endif
 
16734
!
 
16735
   do iz=1,2
 
16736
     beta = zz(iz)
 
16737
     tmpa(iz) = gg + beta*hh
 
16738
     tmpb(iz) = cc + 2*beta*bb
 
16739
     tmpc(iz) = dd + beta*ee
 
16740
     kiz(iz) =        bb*tmpa(iz)               - hh*tmpb(iz)
 
16741
     ll      =        ee*tmpa(iz) - hh*tmpc(iz) - jj*tmpb(iz)
 
16742
     nn      = (ff-IEPS*abs(areal(ff)))*tmpa(iz) - jj*tmpc(iz)
 
16743
     call solabc( yy(iz,1),yy(iz,2) ,sdnt ,kiz(iz),ll,nn ,0 )
 
16744
     if (abs(aimag(beta)).ne.RZRO) then
 
16745
       ab1 = areal(-beta)
 
16746
       ab2 = aimag(-beta)
 
16747
       ac1 = ab1+1 !areal(1-beta)
 
16748
       ac2 = ab2   !aimag(1-beta)
 
16749
       abab = ab1*ab1 + ab2*ab2
 
16750
       acac = ac1*ac1 + ac2*ac2
 
16751
       abac = ab1*ac1 + ab2*ac2
 
16752
       det = abab*acac - abac*abac
 
16753
       do iy=1,2
 
16754
         ap1 = areal(yy(iz,iy))
 
16755
         ap2 = aimag(yy(iz,iy))
 
16756
         apab = ap1*ab1 + ap2*ab2
 
16757
         apac = ap1*ac1 + ap2*ac2
 
16758
         x1(iz,iy) = ( acac*apab - abac*apac )/det
 
16759
         x2(iz,iy) = (-abac*apab + abab*apac )/det
 
16760
       enddo
 
16761
     else
 
16762
       do iy=1,2
 
16763
         x1(iz,iy) = -1
 
16764
         x2(iz,iy) = -1
 
16765
       enddo
 
16766
     endif
 
16767
   enddo
 
16768
   xmin = 1
 
16769
   izmin = 2
 
16770
   do iz=1,2
 
16771
   do iy=1,2
 
16772
     if ( x1(iz,iy).ge.RZRO.and.x2(iz,iy).ge.RZRO &
 
16773
                 .and.x1(iz,iy)+x2(iz,iy).le.RONE ) then
 
16774
       pp(iz,iy) = .true.
 
16775
       if (x1(iz,iy).lt.xmin) then
 
16776
         xmin = x1(iz,iy)
 
16777
         izmin = iz
 
16778
       endif
 
16779
       if (x2(iz,iy).lt.xmin) then
 
16780
         xmin = x2(iz,iy)
 
16781
         izmin = iz
 
16782
       endif
 
16783
     else
 
16784
       pp(iz,iy) = .false.
 
16785
     endif
 
16786
   enddo
 
16787
   enddo
 
16788
   iz = izmin+1
 
16789
   if (iz.eq.3) iz = 1
 
16790
!
 
16791
   beta = zz(iz)
 
16792
   kk = kiz(iz)
 
16793
   y1 = yy(iz,1)
 
16794
   y2 = yy(iz,2)
 
16795
   p1 = pp(iz,1)
 
16796
   p2 = pp(iz,2)
 
16797
!
 
16798
   rslt =   s3fun( y1,y2 ,beta ,CONE      ,CZRO    ,hh   ,gg+jj  ) &
 
16799
          - s3fun( y1,y2 ,CZRO ,CONE-beta ,CZRO    ,gg+hh,   jj  ) &
 
16800
          + s3fun( y1,y2 ,CZRO ,    -beta ,CZRO    ,gg   ,   jj  ) &
 
16801
          - s3fun( y1,y2 ,beta ,CONE      ,bb      ,cc+ee,aa+dpf ) &
 
16802
          + s3fun( y1,y2 ,CZRO ,CONE-beta ,aa+bb+cc,dpe  ,ff     ) &
 
16803
          - s3fun( y1,y2 ,CZRO ,    -beta ,aa      ,dd   ,ff     )
 
16804
!
 
16805
   sdnt = plnr( y1,y2 ,p1,p2, tmpa(iz),tmpb(iz),tmpc(iz) )
 
16806
   if (aimag(beta).le.RZRO) then ;rslt = rslt + sdnt
 
16807
                            else ;rslt = rslt - sdnt
 
16808
   endif
 
16809
!
 
16810
   rslt = -sj*rslt/kk
 
16811
   end function
 
16812
 
 
16813
 
 
16814
   function s3fun( y1i,y2i ,dd,ee ,aa,bb,cin ) result(rslt)
 
16815
!*******************************************************************
 
16816
! Calculate
 
16817
!            ( S3(y1i) - S3(y2i) )/( y1i - y2i )
 
16818
! where
 
16819
!               /1    ee * ln( aa*x^2 + bb*x + cc )
 
16820
!       S3(y) = |  dx -----------------------------
 
16821
!               /0           ee*x - y - dd
 
16822
!
 
16823
! y1i,y2i should have a non-zero imaginary part
 
16824
!*******************************************************************
 
16825
  complex(kindr2) &   
 
16826
     ,intent(in) ::  y1i,y2i ,dd,ee ,aa,bb,cin
 
16827
  complex(kindr2) &   
 
16828
     :: rslt ,y1,y2,fy1y2,z1,z2,tmp,cc
 
16829
  real(kindr2) &  
 
16830
     ::rea,reb,rez1,rez2,imz1,imz2,simc,hh
 
16831
!
 
16832
!
 
16833
   if (ee.eq.CZRO) then
 
16834
     rslt = 0
 
16835
     return
 
16836
   endif
 
16837
!
 
16838
   cc = cin
 
16839
   rea = abs(aa)
 
16840
   reb = abs(bb)
 
16841
   simc = abs(cc)
 
16842
   if (simc.lt.10*neglig(prcpar)*min(rea,reb)) cc = 0
 
16843
!
 
16844
   simc = aimag(cc)
 
16845
   if (simc.eq.RZRO) then
 
16846
     simc = aimag(bb)
 
16847
     if (simc.eq.RZRO) simc = -1
 
16848
   endif
 
16849
   simc = sgnRe(simc)
 
16850
!
 
16851
   y1 = (dd+y1i)/ee
 
16852
   y2 = (dd+y2i)/ee
 
16853
   if (aimag(y1).eq.RZRO) then
 
16854
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
 
16855
       ,'y1 has zero imaginary part'
 
16856
   endif
 
16857
   if (aimag(y2).eq.RZRO) then
 
16858
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
 
16859
       ,'y2 has zero imaginary part'
 
16860
   endif
 
16861
   fy1y2 = r0fun( y1,y2 )
 
16862
!
 
16863
   if     (aa.ne.CZRO) then
 
16864
!
 
16865
!     call solabc( z1,z2 ,tmp ,aa,bb,cc ,0 )
 
16866
     call solabc_rcc( z1,z2 ,areal(aa),bb,cc )
 
16867
     rea  = sgnRe(aa)
 
16868
     rez1 = areal(z1)
 
16869
     rez2 = areal(z2) 
 
16870
     imz1 = aimag(z1) ! sign(Im(a*z1*z2)) = simc
 
16871
     imz2 = aimag(z2)
 
16872
     hh = abs(EPSN2*rez1)
 
16873
!     if (abs(imz1).lt.EPSN*hh) imz1 = simc*rea*sgnRe(rez2)*hh
 
16874
     if (imz1.eq.RZRO) imz1 = simc*rea*sgnRe(rez2)*hh
 
16875
     hh = abs(EPSN2*rez2)
 
16876
!     if (abs(imz2).lt.EPSN*hh) imz2 = simc*rea*sgnRe(rez1)*hh
 
16877
     if (imz2.eq.RZRO) imz2 = simc*rea*sgnRe(rez1)*hh
 
16878
     z1 = acmplx( rez1,imz1)
 
16879
     z2 = acmplx( rez2,imz2)
 
16880
     rslt = fy1y2 * ( logc(qonv(aa,simc)) &
 
16881
                    + eta3( -z1,-imz1,-z2,-imz2,CZRO,simc*rea ) ) &
 
16882
          + r1fun( z1,y1,y2,fy1y2 ) &
 
16883
          + r1fun( z2,y1,y2,fy1y2 )
 
16884
!
 
16885
   elseif (bb.ne.CZRO) then
 
16886
!
 
16887
     z1 = -cc/bb ! - i|eps|Re(b)
 
16888
     reb  = areal(bb)
 
16889
     rez1 = areal(z1)
 
16890
     imz1 = aimag(z1)
 
16891
     if (abs(imz1).eq.RZRO) then
 
16892
       imz1 = -simc*reb*abs(EPSN2*rez1/reb)
 
16893
       z1 = acmplx( rez1,imz1)
 
16894
     endif
 
16895
     rslt = fy1y2 * ( logc(qonv(bb,simc)) &
 
16896
                    + eta3(bb,simc ,-z1,-imz1 ,cc,simc) ) &
 
16897
          + r1fun( z1,y1,y2,fy1y2 )
 
16898
!
 
16899
   elseif (cc.ne.CZRO) then
 
16900
!
 
16901
     rslt = logc( qonv(cc,simc) )*fy1y2
 
16902
!
 
16903
   else!if (aa=bb=cc=0)
 
16904
!
 
16905
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop s3fun: ' &
 
16906
       ,'cc equal zero, returning 0'
 
16907
     rslt = 0
 
16908
!
 
16909
   endif
 
16910
!
 
16911
   rslt = rslt/ee
 
16912
   end function
 
16913
 
 
16914
 
 
16915
   function r1fun( zz,y1,y2,fy1y2 ) result(rslt)
 
16916
!*******************************************************************
 
16917
! calculates  ( R1(y1,z) - R1(y2,z) )/( y1 - y2 )
 
16918
! where
 
16919
!                          /     / 1-y \       / 1-z \ \
 
16920
!      R1(y,z) = ln(y-z) * | log |-----| - log |-----| |
 
16921
!                          \     \ -y  /       \ -z  / / 
 
16922
!
 
16923
!                      /    y-z \       /    y-z \
 
16924
!                - Li2 |1 - ----| + Li2 |1 - ----|
 
16925
!                      \    -z  /       \    1-z /
 
16926
!
 
16927
!                                     / 1-y1 \       / 1-y2 \
 
16928
!                                 log |------| - log |------| 
 
16929
! input fy1y2 should be equal to      \  -y1 /       \  -y2 /
 
16930
!                                 ---------------------------
 
16931
!                                           y1 - y2
 
16932
!*******************************************************************
 
16933
  complex(kindr2) &   
 
16934
     ,intent(in) :: y1,y2,zz,fy1y2
 
16935
  complex(kindr2) &   
 
16936
     :: rslt ,oz
 
16937
   type(qmplx_type) :: q1z,q2z,qq
 
16938
  real(kindr2) &  
 
16939
     :: h12,hz1,hz2,hzz,hoz
 
16940
   logical :: zzsmall,ozsmall
 
16941
!
 
16942
!
 
16943
   oz = 1-zz
 
16944
   h12 = abs(y1-y2)
 
16945
   hz1 = abs(y1-zz)
 
16946
   hz2 = abs(y2-zz)
 
16947
   hzz = abs(zz)
 
16948
   hoz = abs(oz)
 
16949
   q1z = qonv(y1-zz)
 
16950
   q2z = qonv(y2-zz)
 
16951
!
 
16952
   zzsmall = .false.
 
16953
   ozsmall = .false.
 
16954
   if     (hzz.lt.hz1.and.hzz.lt.hz2.and.hzz.lt.hoz) then ! |z| < |y1-z|,|y2-z|
 
16955
     zzsmall = .true.
 
16956
     rslt = fy1y2*logc( q1z ) &
 
16957
          - ( logc(q1z*q2z)/2 + logc(qonv((y2-1)/y2)) &
 
16958
                                     - logc(qonv(oz)) )*logc2(q1z/q2z)/(y2-zz)
 
16959
   elseif (hoz.lt.hz1.and.hoz.lt.hz2) then ! |1-z| < |y1-z|,|y2-z|
 
16960
     ozsmall = .true.
 
16961
     rslt = fy1y2*logc( q1z ) &
 
16962
          - (-logc(q1z*q2z)/2 + logc(qonv((y2-1)/y2)) &
 
16963
                                    + logc(qonv(-zz)) )*logc2(q1z/q2z)/(y2-zz)
 
16964
   elseif (h12.le.hz2.and.hz2.le.hz1) then ! |y1-y2| < |y2-z| < |y1-z|
 
16965
     rslt = fy1y2*logc( q1z ) - r0fun( y2,zz )*logc2( q1z/q2z )        
 
16966
   elseif (h12.le.hz1.and.hz1.le.hz2) then ! |y1-y2| < |y2-z| < |y1-z|
 
16967
     rslt = fy1y2*logc( q2z ) - r0fun( y1,zz )*logc2( q2z/q1z )        
 
16968
   else!if(hz1.lt.h12.or.hz2.lt.h12) then ! |y2-z|,|y1-z| < |y1-y2|
 
16969
     rslt = 0
 
16970
     if (hz1.ne.RZRO) rslt = rslt + (y1-zz)*logc( q1z )*r0fun( y1,zz )
 
16971
     if (hz2.ne.RZRO) rslt = rslt - (y2-zz)*logc( q2z )*r0fun( y2,zz )
 
16972
     rslt = rslt/(y1-y2)
 
16973
   endif
 
16974
!
 
16975
   if (zzsmall) then ! |z| < |y1-z|,|y2-z|
 
16976
     qq  = qonv(-zz)
 
16977
     rslt = rslt + ( li2c( qq/q1z ) - li2c( qq/q2z ) )/(y1-y2)
 
16978
   else
 
16979
     qq  = qonv(-zz)
 
16980
     rslt = rslt + li2c2( q1z/qq ,q2z/qq )/zz
 
16981
   endif
 
16982
!
 
16983
   if (ozsmall) then ! |1-z| < |y1-z|,|y2-z|
 
16984
     qq  = qonv(oz)
 
16985
     rslt = rslt - ( li2c( qq/q1z ) - li2c( qq/q2z ) )/(y1-y2)
 
16986
   else
 
16987
     qq = qonv(oz)
 
16988
     rslt = rslt + li2c2( q1z/qq ,q2z/qq )/oz
 
16989
   endif
 
16990
   end function
 
16991
 
 
16992
 
 
16993
   function r0fun( y1,y2 ) result(rslt)
 
16994
!*******************************************************************
 
16995
!      / 1-y1 \       / 1-y2 \
 
16996
!  log |------| - log |------| 
 
16997
!      \  -y1 /       \  -y2 /
 
16998
!  ---------------------------
 
16999
!            y1 - y2
 
17000
!
 
17001
! y1,y2 should have non-zero imaginary parts
 
17002
!*******************************************************************
 
17003
  complex(kindr2) &   
 
17004
     ,intent(in) :: y1,y2
 
17005
  complex(kindr2) &   
 
17006
     :: rslt ,oy1,oy2
 
17007
   oy1 = 1-y1
 
17008
   oy2 = 1-y2
 
17009
   rslt = logc2( qonv(-y2)/qonv(-y1) )/y1 &
 
17010
        + logc2( qonv(oy2)/qonv(oy1) )/oy1
 
17011
   end function
 
17012
 
 
17013
 
 
17014
   function plnr( y1,y2 ,p1,p2 ,aa,bb,cc ) result(rslt)
 
17015
!*******************************************************************
 
17016
!                   /   a    \          /   a    \
 
17017
!            p1*log |--------| - p2*log |--------| 
 
17018
!                   \ b*y1+c /          \ b*y2+c /
 
17019
! 2*pi*imag* -------------------------------------
 
17020
!                           y1 - y2
 
17021
! 
 
17022
! p1,p2 are logical, to be interpreted as 0,1 in the formula above 
 
17023
!*******************************************************************
 
17024
  complex(kindr2) &   
 
17025
     ,intent(in) :: y1,y2 ,aa,bb,cc
 
17026
   logical         ,intent(in) :: p1,p2
 
17027
  complex(kindr2) &   
 
17028
     :: rslt ,x1,x2,xx
 
17029
   type(qmplx_type) :: q1,q2
 
17030
!
 
17031
   if (p1) then
 
17032
     x1 = bb*y1 + cc
 
17033
     xx = aa/x1
 
17034
     if (aimag(xx).eq.RZRO) then
 
17035
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop plnr: ' &
 
17036
         ,'aa/x1 has zero imaginary part'
 
17037
     endif
 
17038
     q1 = qonv(xx)
 
17039
   endif
 
17040
   if (p2) then
 
17041
     x2 = bb*y2 + cc
 
17042
     xx = aa/x2
 
17043
     if (aimag(xx).eq.RZRO) then
 
17044
       if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop plnr: ' &
 
17045
         ,'aa/x2 has zero imaginary part'
 
17046
     endif
 
17047
     q2 = qonv(xx)
 
17048
   endif
 
17049
   if (p1) then
 
17050
     if (p2) then
 
17051
       rslt = logc2( q2/q1 ) * 2*IPI*bb/x2
 
17052
     else
 
17053
       rslt = logc( q1 ) * 2*IPI/(y1-y2)
 
17054
     endif
 
17055
   elseif (p2) then
 
17056
     rslt = logc( q2 ) * 2*IPI/(y2-y1) ! minus sign
 
17057
   else
 
17058
     rslt = 0
 
17059
   endif
 
17060
   end function
 
17061
 
 
17062
 
 
17063
end module
 
17064
 
 
17065
 
 
17066
module avh_olo_qp
 
17067
  use avh_olo_units
 
17068
  use avh_olo_qp_print
 
17069
  use avh_olo_qp_prec
 
17070
!
 
17071
  implicit none
 
17072
  private
 
17073
  public :: olo_unit ,olo_scale ,olo_onshell ,olo_setting
 
17074
  public :: olo_precision
 
17075
  public :: olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
 
17076
  public :: olo_an ,olo_bn
 
17077
  public :: olo
 
17078
  public :: olo_get_scale ,olo_get_onshell ,olo_get_precision
 
17079
!
 
17080
  integer ,public ,parameter :: olo_kind=kindr2    
 
17081
!
 
17082
  real(kindr2) &  
 
17083
         ,save :: onshellthrs
 
17084
  logical,save :: nonzerothrs = .false.
 
17085
!
 
17086
  real(kindr2) &  
 
17087
         ,save :: muscale
 
17088
!
 
17089
  character(99) ,parameter :: warnonshell=&
 
17090
       'it seems you forgot to put some input explicitly on shell. ' &
 
17091
     //'You may  call olo_onshell  to cure this.'
 
17092
!
 
17093
  logical ,save :: initz=.true.
 
17094
!
 
17095
  interface olo_a0
 
17096
    module procedure a0_r,a0rr,a0_c,a0cr
 
17097
  end interface 
 
17098
  interface olo_an
 
17099
    module procedure an_r,anrr,an_c,ancr
 
17100
  end interface 
 
17101
  interface olo_b0
 
17102
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
 
17103
  end interface 
 
17104
  interface olo_b11
 
17105
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
 
17106
  end interface 
 
17107
  interface olo_bn
 
17108
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
 
17109
  end interface 
 
17110
  interface olo_c0
 
17111
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
 
17112
  end interface 
 
17113
  interface olo_d0
 
17114
    module procedure d0rr,d0rrr,d0rc,d0rcr,d0cc,d0ccr
 
17115
  end interface 
 
17116
!
 
17117
  interface olo
 
17118
    module procedure a0_r,a0rr,a0_c,a0cr
 
17119
    module procedure an_r,anrr,an_c,ancr
 
17120
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
 
17121
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
 
17122
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
 
17123
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
 
17124
    module procedure d0rr,d0rrr,d0rc,d0rcr,d0cc,d0ccr
 
17125
  end interface 
 
17126
 
 
17127
contains
 
17128
 
 
17129
 
 
17130
  subroutine init( ndec )
 
17131
!*******************************************************************
 
17132
!*******************************************************************
 
17133
  use avh_olo_version
 
17134
  integer,optional,intent(in) :: ndec
 
17135
!
 
17136
  call olo_version
 
17137
!
 
17138
  initz = .false.
 
17139
!
 
17140
  if (present(ndec)) then
 
17141
    call olo_precision( ndec )
 
17142
  else
 
17143
    call olo_precision( 15 )
 
17144
  endif
 
17145
!
 
17146
  onshellthrs = 0
 
17147
  muscale = 1
 
17148
  if (.not.nonzerothrs) onshellthrs = neglig(prcpar)
 
17149
!
 
17150
  end subroutine
 
17151
 
 
17152
 
 
17153
  recursive subroutine olo_precision( ndec )
 
17154
!*******************************************************************
 
17155
!*******************************************************************
 
17156
  use avh_olo_qp_olog  ,only: update_olog
 
17157
  use avh_olo_qp_dilog ,only: update_dilog
 
17158
  use avh_olo_qp_bnlog ,only: update_bnlog
 
17159
  integer ,intent(in) :: ndec
 
17160
  logical :: newprc
 
17161
  if (initz) then
 
17162
    call init( ndec )
 
17163
  else
 
17164
    call set_precision( newprc )       
 
17165
    if (newprc) then
 
17166
      call update_olog
 
17167
      call update_dilog
 
17168
      call update_bnlog
 
17169
    endif
 
17170
    if (.not.nonzerothrs) onshellthrs = neglig(prcpar)
 
17171
  endif
 
17172
  end subroutine
 
17173
 
 
17174
 
 
17175
  subroutine olo_unit( val ,message )
 
17176
!*******************************************************************
 
17177
!*******************************************************************
 
17178
  integer     ,intent(in) :: val
 
17179
  character(*),intent(in),optional :: message
 
17180
  if (initz) call init
 
17181
  if (present(message)) then ;call set_unit( message ,val )
 
17182
  else                       ;call set_unit( 'all'   ,val )
 
17183
  endif
 
17184
  end subroutine
 
17185
 
 
17186
 
 
17187
  subroutine olo_scale( val )
 
17188
!*******************************************************************
 
17189
!*******************************************************************
 
17190
  real(kind(1d0)) ,intent(in) :: val
 
17191
  if (initz) call init
 
17192
  muscale = convert(val)
 
17193
  end subroutine
 
17194
 
 
17195
 
 
17196
  subroutine olo_onshell( thrs )
 
17197
!*******************************************************************
 
17198
!*******************************************************************
 
17199
  real(kind(1d0)) ,intent(in) :: thrs
 
17200
  if (initz) call init
 
17201
  nonzerothrs = .true.
 
17202
  onshellthrs = convert(thrs)
 
17203
  end subroutine
 
17204
 
 
17205
 
 
17206
  function olo_get_precision() result(rslt)
 
17207
!*******************************************************************
 
17208
!*******************************************************************
 
17209
  use avh_olo_qp_prec ,only: ndecim,prcpar
 
17210
  integer :: rslt
 
17211
  if (initz) call init
 
17212
  rslt = ndecim(prcpar)
 
17213
  end function
 
17214
 
 
17215
  function olo_get_scale() result(rslt)
 
17216
!*******************************************************************
 
17217
!*******************************************************************
 
17218
  real(kind(1d0)) :: rslt
 
17219
  if (initz) call init
 
17220
  rslt = adble(muscale)
 
17221
  end function
 
17222
 
 
17223
  function olo_get_onshell() result(rslt)
 
17224
!*******************************************************************
 
17225
!*******************************************************************
 
17226
  real(kind(1d0)) :: rslt
 
17227
  if (initz) call init
 
17228
  rslt = adble(onshellthrs)
 
17229
  end function
 
17230
 
 
17231
 
 
17232
  subroutine olo_setting( iunit )
 
17233
!*******************************************************************
 
17234
!*******************************************************************
 
17235
  integer,optional,intent(in) :: iunit
 
17236
  integer :: nunit
 
17237
  if (initz) call init
 
17238
  nunit = munit
 
17239
  if (present(iunit)) nunit = iunit
 
17240
  if (nunit.le.0) return
 
17241
!
 
17242
  write(nunit,*) 'MESSAGE from OneLOop: real kind parameter =',trim(myprint(kindr2)) 
 
17243
  write(nunit,*) 'MESSAGE from OneLOop: number of decimals  =',trim(myprint(ndecim(prcpar)))
 
17244
!
 
17245
  if (nonzerothrs) then
 
17246
    write(nunit,*) 'MESSAGE from OneLOop: on-shell threshold =',trim(myprint(onshellthrs,12))
 
17247
  else
 
17248
    write(nunit,*) 'MESSAGE from OneLOop: on-shell threshold is not set'
 
17249
  endif
 
17250
!
 
17251
  write(nunit,*) 'MESSAGE from OneLOop: default scale (mu, not mu^2) =',trim(myprint(muscale,12))
 
17252
!
 
17253
  end subroutine
 
17254
 
 
17255
 
 
17256
!*******************************************************************
 
17257
!
 
17258
!           C   / d^(Dim)q
 
17259
! rslt = ------ | -------- 
 
17260
!        i*pi^2 / (q^2-mm)
 
17261
!
 
17262
! with  Dim = 4-2*eps
 
17263
!         C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
 
17264
!
 
17265
! input:  mm = mass squared
 
17266
! output: rslt(0) = eps^0   -coefficient
 
17267
!         rslt(1) = eps^(-1)-coefficient
 
17268
!         rslt(2) = eps^(-2)-coefficient
 
17269
!
 
17270
! Check the comments in  subroutine olo_onshell  to find out how
 
17271
! this routine decides when to return IR-divergent cases.
 
17272
!*******************************************************************
 
17273
 
 
17274
  subroutine a0_c( rslt ,mm )
 
17275
!
 
17276
  use avh_olo_qp_bub ,only: tadp
 
17277
!
 
17278
  complex(kindr2) &   
 
17279
    ,intent(out) :: rslt(0:2)
 
17280
  complex(kindr2) &   
 
17281
    ,intent(in)  :: mm
 
17282
!
 
17283
  complex(kindr2) &   
 
17284
    :: ss
 
17285
  real(kindr2) &  
 
17286
    :: am,hh,mulocal,mulocal2
 
17287
  character(25+99) ,parameter :: warning=&
 
17288
                     'WARNING from OneLOop a0: '//warnonshell
 
17289
  if (initz) call init
 
17290
!
 
17291
  mulocal = muscale 
 
17292
!
 
17293
  am = abs(mm)
 
17294
!
 
17295
  mulocal2 = mulocal*mulocal
 
17296
!
 
17297
  if (nonzerothrs) then
 
17298
    hh = onshellthrs
 
17299
    if (am.lt.hh) am = 0
 
17300
  elseif (wunit.gt.0) then
 
17301
    hh = onshellthrs*max(am,mulocal2)
 
17302
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17303
  endif
 
17304
!
 
17305
  ss = mm
 
17306
  call tadp( rslt ,ss ,am ,mulocal2 )
 
17307
!
 
17308
  if (punit.gt.0) then
 
17309
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17310
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17311
    write(punit,*) ' mm:',trim(myprint(mm))
 
17312
    write(punit,*) 'a0(2):',trim(myprint(rslt(2)))
 
17313
    write(punit,*) 'a0(1):',trim(myprint(rslt(1)))
 
17314
    write(punit,*) 'a0(0):',trim(myprint(rslt(0)))
 
17315
  endif
 
17316
  end subroutine
 
17317
 
 
17318
  subroutine a0cr( rslt ,mm ,rmu )
 
17319
!
 
17320
  use avh_olo_qp_bub ,only: tadp
 
17321
!
 
17322
  complex(kindr2) &   
 
17323
    ,intent(out) :: rslt(0:2)
 
17324
  complex(kindr2) &   
 
17325
    ,intent(in)  :: mm
 
17326
  real(kindr2) &  
 
17327
   ,intent(in)  :: rmu       
 
17328
!
 
17329
  complex(kindr2) &   
 
17330
    :: ss
 
17331
  real(kindr2) &  
 
17332
    :: am,hh,mulocal,mulocal2
 
17333
  character(25+99) ,parameter :: warning=&
 
17334
                     'WARNING from OneLOop a0: '//warnonshell
 
17335
  if (initz) call init
 
17336
!
 
17337
  mulocal = rmu     
 
17338
!
 
17339
  am = abs(mm)
 
17340
!
 
17341
  mulocal2 = mulocal*mulocal
 
17342
!
 
17343
  if (nonzerothrs) then
 
17344
    hh = onshellthrs
 
17345
    if (am.lt.hh) am = 0
 
17346
  elseif (wunit.gt.0) then
 
17347
    hh = onshellthrs*max(am,mulocal2)
 
17348
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17349
  endif
 
17350
!
 
17351
  ss = mm
 
17352
  call tadp( rslt ,ss ,am ,mulocal2 )
 
17353
!
 
17354
  if (punit.gt.0) then
 
17355
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17356
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17357
    write(punit,*) ' mm:',trim(myprint(mm))
 
17358
    write(punit,*) 'a0(2):',trim(myprint(rslt(2)))
 
17359
    write(punit,*) 'a0(1):',trim(myprint(rslt(1)))
 
17360
    write(punit,*) 'a0(0):',trim(myprint(rslt(0)))
 
17361
  endif
 
17362
  end subroutine
 
17363
 
 
17364
  subroutine a0_r( rslt ,mm  )
 
17365
!
 
17366
  use avh_olo_qp_bub ,only: tadp
 
17367
!
 
17368
  complex(kindr2) &   
 
17369
    ,intent(out) :: rslt(0:2)
 
17370
  real(kindr2) &  
 
17371
    ,intent(in)  :: mm
 
17372
!
 
17373
  complex(kindr2) &   
 
17374
    :: ss
 
17375
  real(kindr2) &  
 
17376
    :: am,hh,mulocal,mulocal2
 
17377
  character(25+99) ,parameter :: warning=&
 
17378
                     'WARNING from OneLOop a0: '//warnonshell
 
17379
  if (initz) call init
 
17380
!
 
17381
  mulocal = muscale 
 
17382
!
 
17383
  am = abs(mm)
 
17384
!
 
17385
  mulocal2 = mulocal*mulocal
 
17386
!
 
17387
  if (nonzerothrs) then
 
17388
    hh = onshellthrs
 
17389
    if (am.lt.hh) am = 0
 
17390
  elseif (wunit.gt.0) then
 
17391
    hh = onshellthrs*max(am,mulocal2)
 
17392
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17393
  endif
 
17394
!
 
17395
  ss = mm
 
17396
  call tadp( rslt ,ss ,am ,mulocal2 )
 
17397
!
 
17398
  if (punit.gt.0) then
 
17399
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17400
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17401
    write(punit,*) ' mm:',trim(myprint(mm))
 
17402
    write(punit,*) 'a0(2):',trim(myprint(rslt(2)))
 
17403
    write(punit,*) 'a0(1):',trim(myprint(rslt(1)))
 
17404
    write(punit,*) 'a0(0):',trim(myprint(rslt(0)))
 
17405
  endif
 
17406
  end subroutine
 
17407
 
 
17408
  subroutine a0rr( rslt ,mm ,rmu )
 
17409
!
 
17410
  use avh_olo_qp_bub ,only: tadp
 
17411
!
 
17412
  complex(kindr2) &   
 
17413
    ,intent(out) :: rslt(0:2)
 
17414
  real(kindr2) &  
 
17415
    ,intent(in)  :: mm
 
17416
  real(kindr2) &  
 
17417
   ,intent(in)  :: rmu       
 
17418
!
 
17419
  complex(kindr2) &   
 
17420
    :: ss
 
17421
  real(kindr2) &  
 
17422
    :: am,hh,mulocal,mulocal2
 
17423
  character(25+99) ,parameter :: warning=&
 
17424
                     'WARNING from OneLOop a0: '//warnonshell
 
17425
  if (initz) call init
 
17426
!
 
17427
  mulocal = rmu     
 
17428
!
 
17429
  am = abs(mm)
 
17430
!
 
17431
  mulocal2 = mulocal*mulocal
 
17432
!
 
17433
  if (nonzerothrs) then
 
17434
    hh = onshellthrs
 
17435
    if (am.lt.hh) am = 0
 
17436
  elseif (wunit.gt.0) then
 
17437
    hh = onshellthrs*max(am,mulocal2)
 
17438
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17439
  endif
 
17440
!
 
17441
  ss = mm
 
17442
  call tadp( rslt ,ss ,am ,mulocal2 )
 
17443
!
 
17444
  if (punit.gt.0) then
 
17445
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17446
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17447
    write(punit,*) ' mm:',trim(myprint(mm))
 
17448
    write(punit,*) 'a0(2):',trim(myprint(rslt(2)))
 
17449
    write(punit,*) 'a0(1):',trim(myprint(rslt(1)))
 
17450
    write(punit,*) 'a0(0):',trim(myprint(rslt(0)))
 
17451
  endif
 
17452
  end subroutine
 
17453
 
 
17454
 
 
17455
  subroutine an_c( rslt ,rank ,mm )
 
17456
!
 
17457
  use avh_olo_qp_bub ,only: tadpn
 
17458
!
 
17459
  complex(kindr2) &   
 
17460
    ,intent(out) :: rslt(0:,0:)   
 
17461
  complex(kindr2) &   
 
17462
    ,intent(in)  :: mm
 
17463
  integer,intent(in) :: rank
 
17464
!
 
17465
  complex(kindr2) &   
 
17466
    :: ss
 
17467
  real(kindr2) &  
 
17468
    :: am,hh,mulocal,mulocal2
 
17469
  integer :: ii
 
17470
  character(25+99) ,parameter :: warning=&
 
17471
                     'WARNING from OneLOop An: '//warnonshell
 
17472
  if (initz) call init
 
17473
!
 
17474
  mulocal = muscale 
 
17475
!
 
17476
  am = abs(mm)
 
17477
!
 
17478
  mulocal2 = mulocal*mulocal
 
17479
!
 
17480
  if (nonzerothrs) then
 
17481
    hh = onshellthrs
 
17482
    if (am.lt.hh) am = 0
 
17483
  elseif (wunit.gt.0) then
 
17484
    hh = onshellthrs*max(am,mulocal2)
 
17485
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17486
  endif
 
17487
!
 
17488
  ss = mm
 
17489
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
17490
!
 
17491
  if (punit.gt.0) then
 
17492
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17493
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17494
    write(punit,*) ' mm:',trim(myprint(mm))
 
17495
    do ii=0,rank/2
 
17496
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
17497
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
17498
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
17499
    enddo
 
17500
  endif
 
17501
  end subroutine
 
17502
 
 
17503
  subroutine ancr( rslt ,rank ,mm ,rmu )
 
17504
!
 
17505
  use avh_olo_qp_bub ,only: tadpn
 
17506
!
 
17507
  complex(kindr2) &   
 
17508
    ,intent(out) :: rslt(0:,0:)   
 
17509
  complex(kindr2) &   
 
17510
    ,intent(in)  :: mm
 
17511
  real(kindr2) &  
 
17512
   ,intent(in)  :: rmu       
 
17513
  integer,intent(in) :: rank
 
17514
!
 
17515
  complex(kindr2) &   
 
17516
    :: ss
 
17517
  real(kindr2) &  
 
17518
    :: am,hh,mulocal,mulocal2
 
17519
  integer :: ii
 
17520
  character(25+99) ,parameter :: warning=&
 
17521
                     'WARNING from OneLOop An: '//warnonshell
 
17522
  if (initz) call init
 
17523
!
 
17524
  mulocal = rmu     
 
17525
!
 
17526
  am = abs(mm)
 
17527
!
 
17528
  mulocal2 = mulocal*mulocal
 
17529
!
 
17530
  if (nonzerothrs) then
 
17531
    hh = onshellthrs
 
17532
    if (am.lt.hh) am = 0
 
17533
  elseif (wunit.gt.0) then
 
17534
    hh = onshellthrs*max(am,mulocal2)
 
17535
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17536
  endif
 
17537
!
 
17538
  ss = mm
 
17539
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
17540
!
 
17541
  if (punit.gt.0) then
 
17542
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17543
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17544
    write(punit,*) ' mm:',trim(myprint(mm))
 
17545
    do ii=0,rank/2
 
17546
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
17547
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
17548
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
17549
    enddo
 
17550
  endif
 
17551
  end subroutine
 
17552
 
 
17553
  subroutine an_r( rslt ,rank ,mm  )
 
17554
!
 
17555
  use avh_olo_qp_bub ,only: tadpn
 
17556
!
 
17557
  complex(kindr2) &   
 
17558
    ,intent(out) :: rslt(0:,0:)   
 
17559
  real(kindr2) &  
 
17560
    ,intent(in)  :: mm
 
17561
  integer,intent(in) :: rank
 
17562
!
 
17563
  complex(kindr2) &   
 
17564
    :: ss
 
17565
  real(kindr2) &  
 
17566
    :: am,hh,mulocal,mulocal2
 
17567
  integer :: ii
 
17568
  character(25+99) ,parameter :: warning=&
 
17569
                     'WARNING from OneLOop An: '//warnonshell
 
17570
  if (initz) call init
 
17571
!
 
17572
  mulocal = muscale 
 
17573
!
 
17574
  am = abs(mm)
 
17575
!
 
17576
  mulocal2 = mulocal*mulocal
 
17577
!
 
17578
  if (nonzerothrs) then
 
17579
    hh = onshellthrs
 
17580
    if (am.lt.hh) am = 0
 
17581
  elseif (wunit.gt.0) then
 
17582
    hh = onshellthrs*max(am,mulocal2)
 
17583
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17584
  endif
 
17585
!
 
17586
  ss = mm
 
17587
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
17588
!
 
17589
  if (punit.gt.0) then
 
17590
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17591
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17592
    write(punit,*) ' mm:',trim(myprint(mm))
 
17593
    do ii=0,rank/2
 
17594
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
17595
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
17596
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
17597
    enddo
 
17598
  endif
 
17599
  end subroutine
 
17600
 
 
17601
  subroutine anrr( rslt ,rank ,mm ,rmu )
 
17602
!
 
17603
  use avh_olo_qp_bub ,only: tadpn
 
17604
!
 
17605
  complex(kindr2) &   
 
17606
    ,intent(out) :: rslt(0:,0:)   
 
17607
  real(kindr2) &  
 
17608
    ,intent(in)  :: mm
 
17609
  real(kindr2) &  
 
17610
   ,intent(in)  :: rmu       
 
17611
  integer,intent(in) :: rank
 
17612
!
 
17613
  complex(kindr2) &   
 
17614
    :: ss
 
17615
  real(kindr2) &  
 
17616
    :: am,hh,mulocal,mulocal2
 
17617
  integer :: ii
 
17618
  character(25+99) ,parameter :: warning=&
 
17619
                     'WARNING from OneLOop An: '//warnonshell
 
17620
  if (initz) call init
 
17621
!
 
17622
  mulocal = rmu     
 
17623
!
 
17624
  am = abs(mm)
 
17625
!
 
17626
  mulocal2 = mulocal*mulocal
 
17627
!
 
17628
  if (nonzerothrs) then
 
17629
    hh = onshellthrs
 
17630
    if (am.lt.hh) am = 0
 
17631
  elseif (wunit.gt.0) then
 
17632
    hh = onshellthrs*max(am,mulocal2)
 
17633
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
17634
  endif
 
17635
!
 
17636
  ss = mm
 
17637
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
17638
!
 
17639
  if (punit.gt.0) then
 
17640
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17641
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17642
    write(punit,*) ' mm:',trim(myprint(mm))
 
17643
    do ii=0,rank/2
 
17644
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
17645
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
17646
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
17647
    enddo
 
17648
  endif
 
17649
  end subroutine
 
17650
 
 
17651
 
 
17652
!*******************************************************************
 
17653
!
 
17654
!           C   /      d^(Dim)q
 
17655
! rslt = ------ | --------------------
 
17656
!        i*pi^2 / [q^2-m1][(q+k)^2-m2]
 
17657
!
 
17658
! with  Dim = 4-2*eps
 
17659
!         C = pi^eps * mu^(2*eps) * exp(gamma_Euler*eps)
 
17660
!
 
17661
! input:  pp = k^2, m1,m2 = mass squared
 
17662
! output: rslt(0) = eps^0   -coefficient
 
17663
!         rslt(1) = eps^(-1)-coefficient
 
17664
!         rslt(2) = eps^(-2)-coefficient
 
17665
!
 
17666
! Check the comments in  subroutine olo_onshell  to find out how
 
17667
! this routine decides when to return IR-divergent cases.
 
17668
!*******************************************************************
 
17669
 
 
17670
  subroutine b0cc( rslt ,pp,m1,m2 )
 
17671
!
 
17672
  use avh_olo_qp_bub ,only: bub0
 
17673
!
 
17674
  complex(kindr2) &   
 
17675
    ,intent(out) :: rslt(0:2)
 
17676
  complex(kindr2) &   
 
17677
    ,intent(in)  :: pp
 
17678
  complex(kindr2) &   
 
17679
    ,intent(in)  :: m1,m2
 
17680
!
 
17681
  complex(kindr2) &   
 
17682
    :: ss,r1,r2
 
17683
  real(kindr2) &  
 
17684
    :: app,am1,am2,hh,mulocal,mulocal2
 
17685
  character(25+99) ,parameter :: warning=&
 
17686
                     'WARNING from OneLOop b0: '//warnonshell
 
17687
  if (initz) call init
 
17688
  ss = pp
 
17689
  r1 = m1
 
17690
  r2 = m2
 
17691
!
 
17692
  app = areal(ss)
 
17693
  if (aimag(ss).ne.RZRO) then
 
17694
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17695
      ,'ss has non-zero imaginary part, putting it to zero.'
 
17696
    ss = acmplx( app )
 
17697
  endif
 
17698
  app = abs(app)
 
17699
!
 
17700
  am1 = areal(r1)
 
17701
  hh  = aimag(r1)
 
17702
  if (hh.gt.RZRO) then
 
17703
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17704
      ,'r1 has positive imaginary part, switching its sign.'
 
17705
    r1 = acmplx( am1 ,-hh )
 
17706
  endif
 
17707
  am1 = abs(am1) + abs(hh)
 
17708
!
 
17709
  am2 = areal(r2)
 
17710
  hh  = aimag(r2)
 
17711
  if (hh.gt.RZRO) then
 
17712
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17713
      ,'r2 has positive imaginary part, switching its sign.'
 
17714
    r2 = acmplx( am2 ,-hh )
 
17715
  endif
 
17716
  am2 = abs(am2) + abs(hh)
 
17717
!
 
17718
  mulocal = muscale 
 
17719
!
 
17720
  mulocal2 = mulocal*mulocal
 
17721
!
 
17722
  if (nonzerothrs) then
 
17723
    hh = onshellthrs
 
17724
    if (app.lt.hh) app = 0
 
17725
    if (am1.lt.hh) am1 = 0
 
17726
    if (am2.lt.hh) am2 = 0
 
17727
  elseif (wunit.gt.0) then
 
17728
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
17729
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
17730
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
17731
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
17732
  endif
 
17733
!
 
17734
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
17735
!
 
17736
  if (punit.gt.0) then
 
17737
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17738
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17739
    write(punit,*) ' pp:',trim(myprint(pp))
 
17740
    write(punit,*) ' m1:',trim(myprint(m1))
 
17741
    write(punit,*) ' m2:',trim(myprint(m2))
 
17742
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
17743
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
17744
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
17745
  endif
 
17746
  end subroutine
 
17747
 
 
17748
  subroutine b0ccr( rslt ,pp,m1,m2 ,rmu )
 
17749
!
 
17750
  use avh_olo_qp_bub ,only: bub0
 
17751
!
 
17752
  complex(kindr2) &   
 
17753
    ,intent(out) :: rslt(0:2)
 
17754
  complex(kindr2) &   
 
17755
    ,intent(in)  :: pp
 
17756
  complex(kindr2) &   
 
17757
    ,intent(in)  :: m1,m2
 
17758
  real(kindr2) &  
 
17759
   ,intent(in)  :: rmu       
 
17760
!
 
17761
  complex(kindr2) &   
 
17762
    :: ss,r1,r2
 
17763
  real(kindr2) &  
 
17764
    :: app,am1,am2,hh,mulocal,mulocal2
 
17765
  character(25+99) ,parameter :: warning=&
 
17766
                     'WARNING from OneLOop b0: '//warnonshell
 
17767
  if (initz) call init
 
17768
  ss = pp
 
17769
  r1 = m1
 
17770
  r2 = m2
 
17771
!
 
17772
  app = areal(ss)
 
17773
  if (aimag(ss).ne.RZRO) then
 
17774
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17775
      ,'ss has non-zero imaginary part, putting it to zero.'
 
17776
    ss = acmplx( app )
 
17777
  endif
 
17778
  app = abs(app)
 
17779
!
 
17780
  am1 = areal(r1)
 
17781
  hh  = aimag(r1)
 
17782
  if (hh.gt.RZRO) then
 
17783
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17784
      ,'r1 has positive imaginary part, switching its sign.'
 
17785
    r1 = acmplx( am1 ,-hh )
 
17786
  endif
 
17787
  am1 = abs(am1) + abs(hh)
 
17788
!
 
17789
  am2 = areal(r2)
 
17790
  hh  = aimag(r2)
 
17791
  if (hh.gt.RZRO) then
 
17792
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17793
      ,'r2 has positive imaginary part, switching its sign.'
 
17794
    r2 = acmplx( am2 ,-hh )
 
17795
  endif
 
17796
  am2 = abs(am2) + abs(hh)
 
17797
!
 
17798
  mulocal = rmu     
 
17799
!
 
17800
  mulocal2 = mulocal*mulocal
 
17801
!
 
17802
  if (nonzerothrs) then
 
17803
    hh = onshellthrs
 
17804
    if (app.lt.hh) app = 0
 
17805
    if (am1.lt.hh) am1 = 0
 
17806
    if (am2.lt.hh) am2 = 0
 
17807
  elseif (wunit.gt.0) then
 
17808
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
17809
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
17810
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
17811
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
17812
  endif
 
17813
!
 
17814
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
17815
!
 
17816
  if (punit.gt.0) then
 
17817
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17818
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17819
    write(punit,*) ' pp:',trim(myprint(pp))
 
17820
    write(punit,*) ' m1:',trim(myprint(m1))
 
17821
    write(punit,*) ' m2:',trim(myprint(m2))
 
17822
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
17823
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
17824
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
17825
  endif
 
17826
  end subroutine
 
17827
 
 
17828
  subroutine b0rc( rslt ,pp ,m1,m2 )
 
17829
!
 
17830
  use avh_olo_qp_bub ,only: bub0
 
17831
!
 
17832
  complex(kindr2) &   
 
17833
    ,intent(out) :: rslt(0:2)
 
17834
  real(kindr2) &  
 
17835
    ,intent(in)  :: pp
 
17836
  complex(kindr2) &   
 
17837
    ,intent(in)  :: m1,m2
 
17838
!
 
17839
  complex(kindr2) &   
 
17840
    :: ss,r1,r2
 
17841
  real(kindr2) &  
 
17842
    :: app,am1,am2,hh,mulocal,mulocal2
 
17843
  character(25+99) ,parameter :: warning=&
 
17844
                     'WARNING from OneLOop b0: '//warnonshell
 
17845
  if (initz) call init
 
17846
  ss = pp
 
17847
  r1 = m1
 
17848
  r2 = m2
 
17849
!
 
17850
  app = abs(pp)
 
17851
!
 
17852
  am1 = areal(r1)
 
17853
  hh  = aimag(r1)
 
17854
  if (hh.gt.RZRO) then
 
17855
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17856
      ,'r1 has positive imaginary part, switching its sign.'
 
17857
    r1 = acmplx( am1 ,-hh )
 
17858
  endif
 
17859
  am1 = abs(am1) + abs(hh)
 
17860
!
 
17861
  am2 = areal(r2)
 
17862
  hh  = aimag(r2)
 
17863
  if (hh.gt.RZRO) then
 
17864
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17865
      ,'r2 has positive imaginary part, switching its sign.'
 
17866
    r2 = acmplx( am2 ,-hh )
 
17867
  endif
 
17868
  am2 = abs(am2) + abs(hh)
 
17869
!
 
17870
  mulocal = muscale 
 
17871
!
 
17872
  mulocal2 = mulocal*mulocal
 
17873
!
 
17874
  if (nonzerothrs) then
 
17875
    hh = onshellthrs
 
17876
    if (app.lt.hh) app = 0
 
17877
    if (am1.lt.hh) am1 = 0
 
17878
    if (am2.lt.hh) am2 = 0
 
17879
  elseif (wunit.gt.0) then
 
17880
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
17881
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
17882
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
17883
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
17884
  endif
 
17885
!
 
17886
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
17887
!
 
17888
  if (punit.gt.0) then
 
17889
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17890
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17891
    write(punit,*) ' pp:',trim(myprint(pp))
 
17892
    write(punit,*) ' m1:',trim(myprint(m1))
 
17893
    write(punit,*) ' m2:',trim(myprint(m2))
 
17894
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
17895
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
17896
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
17897
  endif
 
17898
  end subroutine
 
17899
 
 
17900
  subroutine b0rcr( rslt ,pp,m1,m2 ,rmu )
 
17901
!
 
17902
  use avh_olo_qp_bub ,only: bub0
 
17903
!
 
17904
  complex(kindr2) &   
 
17905
    ,intent(out) :: rslt(0:2)
 
17906
  real(kindr2) &  
 
17907
    ,intent(in)  :: pp
 
17908
  complex(kindr2) &   
 
17909
    ,intent(in)  :: m1,m2
 
17910
  real(kindr2) &  
 
17911
   ,intent(in)  :: rmu       
 
17912
!
 
17913
  complex(kindr2) &   
 
17914
    :: ss,r1,r2
 
17915
  real(kindr2) &  
 
17916
    :: app,am1,am2,hh,mulocal,mulocal2
 
17917
  character(25+99) ,parameter :: warning=&
 
17918
                     'WARNING from OneLOop b0: '//warnonshell
 
17919
  if (initz) call init
 
17920
  ss = pp
 
17921
  r1 = m1
 
17922
  r2 = m2
 
17923
!
 
17924
  app = abs(pp)
 
17925
!
 
17926
  am1 = areal(r1)
 
17927
  hh  = aimag(r1)
 
17928
  if (hh.gt.RZRO) then
 
17929
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17930
      ,'r1 has positive imaginary part, switching its sign.'
 
17931
    r1 = acmplx( am1 ,-hh )
 
17932
  endif
 
17933
  am1 = abs(am1) + abs(hh)
 
17934
!
 
17935
  am2 = areal(r2)
 
17936
  hh  = aimag(r2)
 
17937
  if (hh.gt.RZRO) then
 
17938
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b0: ' &
 
17939
      ,'r2 has positive imaginary part, switching its sign.'
 
17940
    r2 = acmplx( am2 ,-hh )
 
17941
  endif
 
17942
  am2 = abs(am2) + abs(hh)
 
17943
!
 
17944
  mulocal = rmu     
 
17945
!
 
17946
  mulocal2 = mulocal*mulocal
 
17947
!
 
17948
  if (nonzerothrs) then
 
17949
    hh = onshellthrs
 
17950
    if (app.lt.hh) app = 0
 
17951
    if (am1.lt.hh) am1 = 0
 
17952
    if (am2.lt.hh) am2 = 0
 
17953
  elseif (wunit.gt.0) then
 
17954
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
17955
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
17956
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
17957
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
17958
  endif
 
17959
!
 
17960
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
17961
!
 
17962
  if (punit.gt.0) then
 
17963
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
17964
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
17965
    write(punit,*) ' pp:',trim(myprint(pp))
 
17966
    write(punit,*) ' m1:',trim(myprint(m1))
 
17967
    write(punit,*) ' m2:',trim(myprint(m2))
 
17968
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
17969
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
17970
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
17971
  endif
 
17972
  end subroutine
 
17973
 
 
17974
  subroutine b0rr( rslt ,pp ,m1,m2 )
 
17975
!
 
17976
  use avh_olo_qp_bub ,only: bub0
 
17977
!
 
17978
  complex(kindr2) &   
 
17979
    ,intent(out) :: rslt(0:2)
 
17980
  real(kindr2) &  
 
17981
    ,intent(in)  :: pp
 
17982
  real(kindr2) &  
 
17983
    ,intent(in)  :: m1,m2
 
17984
!
 
17985
  complex(kindr2) &   
 
17986
    :: ss,r1,r2
 
17987
  real(kindr2) &  
 
17988
    :: app,am1,am2,hh,mulocal,mulocal2
 
17989
  character(25+99) ,parameter :: warning=&
 
17990
                     'WARNING from OneLOop b0: '//warnonshell
 
17991
  if (initz) call init
 
17992
  ss = pp
 
17993
  r1 = m1
 
17994
  r2 = m2
 
17995
!
 
17996
  app = abs(pp)
 
17997
!
 
17998
  am1 = abs(m1)
 
17999
  am2 = abs(m2)
 
18000
!
 
18001
  mulocal = muscale 
 
18002
!
 
18003
  mulocal2 = mulocal*mulocal
 
18004
!
 
18005
  if (nonzerothrs) then
 
18006
    hh = onshellthrs
 
18007
    if (app.lt.hh) app = 0
 
18008
    if (am1.lt.hh) am1 = 0
 
18009
    if (am2.lt.hh) am2 = 0
 
18010
  elseif (wunit.gt.0) then
 
18011
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18012
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18013
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18014
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18015
  endif
 
18016
!
 
18017
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18018
!
 
18019
  if (punit.gt.0) then
 
18020
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18021
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18022
    write(punit,*) ' pp:',trim(myprint(pp))
 
18023
    write(punit,*) ' m1:',trim(myprint(m1))
 
18024
    write(punit,*) ' m2:',trim(myprint(m2))
 
18025
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
18026
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
18027
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
18028
  endif
 
18029
  end subroutine
 
18030
 
 
18031
  subroutine b0rrr( rslt ,pp ,m1,m2 ,rmu )
 
18032
!
 
18033
  use avh_olo_qp_bub ,only: bub0
 
18034
!
 
18035
  complex(kindr2) &   
 
18036
    ,intent(out) :: rslt(0:2)
 
18037
  real(kindr2) &  
 
18038
    ,intent(in)  :: pp
 
18039
  real(kindr2) &  
 
18040
    ,intent(in)  :: m1,m2
 
18041
  real(kindr2) &  
 
18042
   ,intent(in)  :: rmu       
 
18043
!
 
18044
  complex(kindr2) &   
 
18045
    :: ss,r1,r2
 
18046
  real(kindr2) &  
 
18047
    :: app,am1,am2,hh,mulocal,mulocal2
 
18048
  character(25+99) ,parameter :: warning=&
 
18049
                     'WARNING from OneLOop b0: '//warnonshell
 
18050
  if (initz) call init
 
18051
  ss = pp
 
18052
  r1 = m1
 
18053
  r2 = m2
 
18054
!
 
18055
  app = abs(pp)
 
18056
!
 
18057
  am1 = abs(m1)
 
18058
  am2 = abs(m2)
 
18059
!
 
18060
  mulocal = rmu     
 
18061
!
 
18062
  mulocal2 = mulocal*mulocal
 
18063
!
 
18064
  if (nonzerothrs) then
 
18065
    hh = onshellthrs
 
18066
    if (app.lt.hh) app = 0
 
18067
    if (am1.lt.hh) am1 = 0
 
18068
    if (am2.lt.hh) am2 = 0
 
18069
  elseif (wunit.gt.0) then
 
18070
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18071
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18072
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18073
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18074
  endif
 
18075
!
 
18076
  call bub0( rslt ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18077
!
 
18078
  if (punit.gt.0) then
 
18079
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18080
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18081
    write(punit,*) ' pp:',trim(myprint(pp))
 
18082
    write(punit,*) ' m1:',trim(myprint(m1))
 
18083
    write(punit,*) ' m2:',trim(myprint(m2))
 
18084
    write(punit,*) 'b0(2):',trim(myprint(rslt(2)))
 
18085
    write(punit,*) 'b0(1):',trim(myprint(rslt(1)))
 
18086
    write(punit,*) 'b0(0):',trim(myprint(rslt(0)))
 
18087
  endif
 
18088
  end subroutine
 
18089
 
 
18090
 
 
18091
!*******************************************************************
 
18092
! Return the Papparino-Veltman functions b11,b00,b1,b0 , for
 
18093
!
 
18094
!      C   /      d^(Dim)q
 
18095
!   ------ | -------------------- = b0
 
18096
!   i*pi^2 / [q^2-m1][(q+p)^2-m2]
 
18097
!
 
18098
!      C   /    d^(Dim)q q^mu
 
18099
!   ------ | -------------------- = p^mu b1
 
18100
!   i*pi^2 / [q^2-m1][(q+p)^2-m2]
 
18101
!
 
18102
!      C   /  d^(Dim)q q^mu q^nu
 
18103
!   ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
 
18104
!   i*pi^2 / [q^2-m1][(q+p)^2-m2]
 
18105
!
 
18106
! Check the comments in  subroutine olo_onshell  to find out how
 
18107
! this routine decides when to return IR-divergent cases.
 
18108
!*******************************************************************
 
18109
 
 
18110
  subroutine b11cc( b11,b00,b1,b0 ,pp,m1,m2 )
 
18111
!
 
18112
  use avh_olo_qp_bub ,only: bub11
 
18113
!
 
18114
  complex(kindr2) &   
 
18115
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18116
  complex(kindr2) &   
 
18117
    ,intent(in)  :: pp
 
18118
  complex(kindr2) &   
 
18119
    ,intent(in)  :: m1,m2
 
18120
!
 
18121
  complex(kindr2) &   
 
18122
    :: ss,r1,r2
 
18123
  real(kindr2) &  
 
18124
    :: app,am1,am2,hh,mulocal,mulocal2
 
18125
  character(26+99) ,parameter :: warning=&
 
18126
                     'WARNING from OneLOop b11: '//warnonshell
 
18127
  if (initz) call init
 
18128
  ss = pp
 
18129
  r1 = m1
 
18130
  r2 = m2
 
18131
!
 
18132
  app = areal(ss)
 
18133
  if (aimag(ss).ne.RZRO) then
 
18134
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18135
      ,'ss has non-zero imaginary part, putting it to zero.'
 
18136
    ss = acmplx( app )
 
18137
  endif
 
18138
  app = abs(app)
 
18139
!
 
18140
  am1 = areal(r1)
 
18141
  hh  = aimag(r1)
 
18142
  if (hh.gt.RZRO) then
 
18143
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18144
      ,'r1 has positive imaginary part, switching its sign.'
 
18145
    r1 = acmplx( am1 ,-hh )
 
18146
  endif
 
18147
  am1 = abs(am1) + abs(hh)
 
18148
!
 
18149
  am2 = areal(r2)
 
18150
  hh  = aimag(r2)
 
18151
  if (hh.gt.RZRO) then
 
18152
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18153
      ,'r2 has positive imaginary part, switching its sign.'
 
18154
    r2 = acmplx( am2 ,-hh )
 
18155
  endif
 
18156
  am2 = abs(am2) + abs(hh)
 
18157
!
 
18158
  mulocal = muscale 
 
18159
!
 
18160
  mulocal2 = mulocal*mulocal
 
18161
!
 
18162
  if (nonzerothrs) then
 
18163
    hh = onshellthrs
 
18164
    if (app.lt.hh) app = 0
 
18165
    if (am1.lt.hh) am1 = 0
 
18166
    if (am2.lt.hh) am2 = 0
 
18167
  elseif (wunit.gt.0) then
 
18168
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18169
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18170
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18171
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18172
  endif
 
18173
!
 
18174
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18175
!
 
18176
  if (punit.gt.0) then
 
18177
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18178
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18179
    write(punit,*) ' pp:',trim(myprint(pp))
 
18180
    write(punit,*) ' m1:',trim(myprint(m1))
 
18181
    write(punit,*) ' m2:',trim(myprint(m2))
 
18182
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18183
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18184
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18185
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18186
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18187
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18188
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18189
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18190
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18191
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18192
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18193
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18194
  endif
 
18195
  end subroutine
 
18196
 
 
18197
  subroutine b11ccr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
 
18198
!
 
18199
  use avh_olo_qp_bub ,only: bub11
 
18200
!
 
18201
  complex(kindr2) &   
 
18202
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18203
  complex(kindr2) &   
 
18204
    ,intent(in)  :: pp
 
18205
  complex(kindr2) &   
 
18206
    ,intent(in)  :: m1,m2
 
18207
  real(kindr2) &  
 
18208
   ,intent(in)  :: rmu       
 
18209
!
 
18210
  complex(kindr2) &   
 
18211
    :: ss,r1,r2
 
18212
  real(kindr2) &  
 
18213
    :: app,am1,am2,hh,mulocal,mulocal2
 
18214
  character(26+99) ,parameter :: warning=&
 
18215
                     'WARNING from OneLOop b11: '//warnonshell
 
18216
  if (initz) call init
 
18217
  ss = pp
 
18218
  r1 = m1
 
18219
  r2 = m2
 
18220
!
 
18221
  app = areal(ss)
 
18222
  if (aimag(ss).ne.RZRO) then
 
18223
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18224
      ,'ss has non-zero imaginary part, putting it to zero.'
 
18225
    ss = acmplx( app )
 
18226
  endif
 
18227
  app = abs(app)
 
18228
!
 
18229
  am1 = areal(r1)
 
18230
  hh  = aimag(r1)
 
18231
  if (hh.gt.RZRO) then
 
18232
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18233
      ,'r1 has positive imaginary part, switching its sign.'
 
18234
    r1 = acmplx( am1 ,-hh )
 
18235
  endif
 
18236
  am1 = abs(am1) + abs(hh)
 
18237
!
 
18238
  am2 = areal(r2)
 
18239
  hh  = aimag(r2)
 
18240
  if (hh.gt.RZRO) then
 
18241
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18242
      ,'r2 has positive imaginary part, switching its sign.'
 
18243
    r2 = acmplx( am2 ,-hh )
 
18244
  endif
 
18245
  am2 = abs(am2) + abs(hh)
 
18246
!
 
18247
  mulocal = rmu     
 
18248
!
 
18249
  mulocal2 = mulocal*mulocal
 
18250
!
 
18251
  if (nonzerothrs) then
 
18252
    hh = onshellthrs
 
18253
    if (app.lt.hh) app = 0
 
18254
    if (am1.lt.hh) am1 = 0
 
18255
    if (am2.lt.hh) am2 = 0
 
18256
  elseif (wunit.gt.0) then
 
18257
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18258
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18259
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18260
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18261
  endif
 
18262
!
 
18263
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18264
!
 
18265
  if (punit.gt.0) then
 
18266
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18267
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18268
    write(punit,*) ' pp:',trim(myprint(pp))
 
18269
    write(punit,*) ' m1:',trim(myprint(m1))
 
18270
    write(punit,*) ' m2:',trim(myprint(m2))
 
18271
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18272
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18273
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18274
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18275
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18276
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18277
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18278
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18279
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18280
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18281
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18282
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18283
  endif
 
18284
  end subroutine
 
18285
 
 
18286
  subroutine b11rc( b11,b00,b1,b0 ,pp,m1,m2 )
 
18287
!
 
18288
  use avh_olo_qp_bub ,only: bub11
 
18289
!
 
18290
  complex(kindr2) &   
 
18291
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18292
  real(kindr2) &  
 
18293
    ,intent(in)  :: pp
 
18294
  complex(kindr2) &   
 
18295
    ,intent(in)  :: m1,m2
 
18296
!
 
18297
  complex(kindr2) &   
 
18298
    :: ss,r1,r2
 
18299
  real(kindr2) &  
 
18300
    :: app,am1,am2,hh,mulocal,mulocal2
 
18301
  character(26+99) ,parameter :: warning=&
 
18302
                     'WARNING from OneLOop b11: '//warnonshell
 
18303
  if (initz) call init
 
18304
  ss = pp
 
18305
  r1 = m1
 
18306
  r2 = m2
 
18307
!
 
18308
  app = abs(pp)
 
18309
!
 
18310
  am1 = areal(r1)
 
18311
  hh  = aimag(r1)
 
18312
  if (hh.gt.RZRO) then
 
18313
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18314
      ,'r1 has positive imaginary part, switching its sign.'
 
18315
    r1 = acmplx( am1 ,-hh )
 
18316
  endif
 
18317
  am1 = abs(am1) + abs(hh)
 
18318
!
 
18319
  am2 = areal(r2)
 
18320
  hh  = aimag(r2)
 
18321
  if (hh.gt.RZRO) then
 
18322
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18323
      ,'r2 has positive imaginary part, switching its sign.'
 
18324
    r2 = acmplx( am2 ,-hh )
 
18325
  endif
 
18326
  am2 = abs(am2) + abs(hh)
 
18327
!
 
18328
  mulocal = muscale 
 
18329
!
 
18330
  mulocal2 = mulocal*mulocal
 
18331
!
 
18332
  if (nonzerothrs) then
 
18333
    hh = onshellthrs
 
18334
    if (app.lt.hh) app = 0
 
18335
    if (am1.lt.hh) am1 = 0
 
18336
    if (am2.lt.hh) am2 = 0
 
18337
  elseif (wunit.gt.0) then
 
18338
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18339
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18340
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18341
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18342
  endif
 
18343
!
 
18344
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18345
!
 
18346
  if (punit.gt.0) then
 
18347
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18348
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18349
    write(punit,*) ' pp:',trim(myprint(pp))
 
18350
    write(punit,*) ' m1:',trim(myprint(m1))
 
18351
    write(punit,*) ' m2:',trim(myprint(m2))
 
18352
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18353
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18354
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18355
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18356
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18357
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18358
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18359
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18360
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18361
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18362
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18363
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18364
  endif
 
18365
  end subroutine
 
18366
 
 
18367
  subroutine b11rcr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
 
18368
!
 
18369
  use avh_olo_qp_bub ,only: bub11
 
18370
!
 
18371
  complex(kindr2) &   
 
18372
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18373
  real(kindr2) &  
 
18374
    ,intent(in)  :: pp
 
18375
  complex(kindr2) &   
 
18376
    ,intent(in)  :: m1,m2
 
18377
  real(kindr2) &  
 
18378
   ,intent(in)  :: rmu       
 
18379
!
 
18380
  complex(kindr2) &   
 
18381
    :: ss,r1,r2
 
18382
  real(kindr2) &  
 
18383
    :: app,am1,am2,hh,mulocal,mulocal2
 
18384
  character(26+99) ,parameter :: warning=&
 
18385
                     'WARNING from OneLOop b11: '//warnonshell
 
18386
  if (initz) call init
 
18387
  ss = pp
 
18388
  r1 = m1
 
18389
  r2 = m2
 
18390
!
 
18391
  app = abs(pp)
 
18392
!
 
18393
  am1 = areal(r1)
 
18394
  hh  = aimag(r1)
 
18395
  if (hh.gt.RZRO) then
 
18396
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18397
      ,'r1 has positive imaginary part, switching its sign.'
 
18398
    r1 = acmplx( am1 ,-hh )
 
18399
  endif
 
18400
  am1 = abs(am1) + abs(hh)
 
18401
!
 
18402
  am2 = areal(r2)
 
18403
  hh  = aimag(r2)
 
18404
  if (hh.gt.RZRO) then
 
18405
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop b11: ' &
 
18406
      ,'r2 has positive imaginary part, switching its sign.'
 
18407
    r2 = acmplx( am2 ,-hh )
 
18408
  endif
 
18409
  am2 = abs(am2) + abs(hh)
 
18410
!
 
18411
  mulocal = rmu     
 
18412
!
 
18413
  mulocal2 = mulocal*mulocal
 
18414
!
 
18415
  if (nonzerothrs) then
 
18416
    hh = onshellthrs
 
18417
    if (app.lt.hh) app = 0
 
18418
    if (am1.lt.hh) am1 = 0
 
18419
    if (am2.lt.hh) am2 = 0
 
18420
  elseif (wunit.gt.0) then
 
18421
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18422
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18423
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18424
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18425
  endif
 
18426
!
 
18427
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18428
!
 
18429
  if (punit.gt.0) then
 
18430
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18431
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18432
    write(punit,*) ' pp:',trim(myprint(pp))
 
18433
    write(punit,*) ' m1:',trim(myprint(m1))
 
18434
    write(punit,*) ' m2:',trim(myprint(m2))
 
18435
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18436
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18437
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18438
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18439
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18440
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18441
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18442
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18443
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18444
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18445
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18446
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18447
  endif
 
18448
  end subroutine
 
18449
 
 
18450
  subroutine b11rr( b11,b00,b1,b0 ,pp,m1,m2 )
 
18451
!
 
18452
  use avh_olo_qp_bub ,only: bub11
 
18453
!
 
18454
  complex(kindr2) &   
 
18455
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18456
  real(kindr2) &  
 
18457
    ,intent(in)  :: pp
 
18458
  real(kindr2) &  
 
18459
    ,intent(in)  :: m1,m2
 
18460
!
 
18461
  complex(kindr2) &   
 
18462
    :: ss,r1,r2
 
18463
  real(kindr2) &  
 
18464
    :: app,am1,am2,hh,mulocal,mulocal2
 
18465
  character(26+99) ,parameter :: warning=&
 
18466
                     'WARNING from OneLOop b11: '//warnonshell
 
18467
  if (initz) call init
 
18468
  ss = pp
 
18469
  r1 = m1
 
18470
  r2 = m2
 
18471
!
 
18472
  app = abs(pp)
 
18473
!
 
18474
  am1 = abs(m1)
 
18475
  am2 = abs(m2)
 
18476
!
 
18477
  mulocal = muscale 
 
18478
!
 
18479
  mulocal2 = mulocal*mulocal
 
18480
!
 
18481
  if (nonzerothrs) then
 
18482
    hh = onshellthrs
 
18483
    if (app.lt.hh) app = 0
 
18484
    if (am1.lt.hh) am1 = 0
 
18485
    if (am2.lt.hh) am2 = 0
 
18486
  elseif (wunit.gt.0) then
 
18487
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18488
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18489
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18490
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18491
  endif
 
18492
!
 
18493
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18494
!
 
18495
  if (punit.gt.0) then
 
18496
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18497
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18498
    write(punit,*) ' pp:',trim(myprint(pp))
 
18499
    write(punit,*) ' m1:',trim(myprint(m1))
 
18500
    write(punit,*) ' m2:',trim(myprint(m2))
 
18501
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18502
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18503
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18504
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18505
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18506
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18507
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18508
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18509
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18510
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18511
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18512
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18513
  endif
 
18514
  end subroutine
 
18515
 
 
18516
  subroutine b11rrr( b11,b00,b1,b0 ,pp,m1,m2 ,rmu )
 
18517
!
 
18518
  use avh_olo_qp_bub ,only: bub11
 
18519
!
 
18520
  complex(kindr2) &   
 
18521
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
18522
  real(kindr2) &  
 
18523
    ,intent(in)  :: pp
 
18524
  real(kindr2) &  
 
18525
    ,intent(in)  :: m1,m2
 
18526
  real(kindr2) &  
 
18527
   ,intent(in)  :: rmu       
 
18528
!
 
18529
  complex(kindr2) &   
 
18530
    :: ss,r1,r2
 
18531
  real(kindr2) &  
 
18532
    :: app,am1,am2,hh,mulocal,mulocal2
 
18533
  character(26+99) ,parameter :: warning=&
 
18534
                     'WARNING from OneLOop b11: '//warnonshell
 
18535
  if (initz) call init
 
18536
  ss = pp
 
18537
  r1 = m1
 
18538
  r2 = m2
 
18539
!
 
18540
  app = abs(pp)
 
18541
!
 
18542
  am1 = abs(m1)
 
18543
  am2 = abs(m2)
 
18544
!
 
18545
  mulocal = rmu     
 
18546
!
 
18547
  mulocal2 = mulocal*mulocal
 
18548
!
 
18549
  if (nonzerothrs) then
 
18550
    hh = onshellthrs
 
18551
    if (app.lt.hh) app = 0
 
18552
    if (am1.lt.hh) am1 = 0
 
18553
    if (am2.lt.hh) am2 = 0
 
18554
  elseif (wunit.gt.0) then
 
18555
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18556
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18557
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18558
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18559
  endif
 
18560
!
 
18561
  call bub11( b11,b00,b1,b0 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18562
!
 
18563
  if (punit.gt.0) then
 
18564
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18565
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18566
    write(punit,*) ' pp:',trim(myprint(pp))
 
18567
    write(punit,*) ' m1:',trim(myprint(m1))
 
18568
    write(punit,*) ' m2:',trim(myprint(m2))
 
18569
    write(punit,*) 'b11(2):',trim(myprint(b11(2)))
 
18570
    write(punit,*) 'b11(1):',trim(myprint(b11(1)))
 
18571
    write(punit,*) 'b11(0):',trim(myprint(b11(0)))
 
18572
    write(punit,*) 'b00(2):',trim(myprint(b00(2)))
 
18573
    write(punit,*) 'b00(1):',trim(myprint(b00(1)))
 
18574
    write(punit,*) 'b00(0):',trim(myprint(b00(0)))
 
18575
    write(punit,*) ' b1(2):',trim(myprint(b1(2) ))
 
18576
    write(punit,*) ' b1(1):',trim(myprint(b1(1) ))
 
18577
    write(punit,*) ' b1(0):',trim(myprint(b1(0) ))
 
18578
    write(punit,*) ' b0(2):',trim(myprint(b0(2) ))
 
18579
    write(punit,*) ' b0(1):',trim(myprint(b0(1) ))
 
18580
    write(punit,*) ' b0(0):',trim(myprint(b0(0) ))
 
18581
  endif
 
18582
  end subroutine
 
18583
 
 
18584
 
 
18585
  subroutine bncc( rslt ,rank ,pp,m1,m2 )
 
18586
!
 
18587
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
18588
!
 
18589
  complex(kindr2) &   
 
18590
    ,intent(out) :: rslt(0:,0:)   
 
18591
  complex(kindr2) &   
 
18592
    ,intent(in)  :: pp
 
18593
  complex(kindr2) &   
 
18594
    ,intent(in)  :: m1,m2
 
18595
  integer,intent(in) :: rank
 
18596
!
 
18597
  complex(kindr2) &   
 
18598
    :: ss,r1,r2
 
18599
  real(kindr2) &  
 
18600
    :: app,am1,am2,hh,mulocal,mulocal2
 
18601
  character(26+99) ,parameter :: warning=&
 
18602
                     'WARNING from OneLOop bn: '//warnonshell
 
18603
  if (initz) call init
 
18604
  ss = pp
 
18605
  r1 = m1
 
18606
  r2 = m2
 
18607
!
 
18608
  app = areal(ss)
 
18609
  if (aimag(ss).ne.RZRO) then
 
18610
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18611
      ,'ss has non-zero imaginary part, putting it to zero.'
 
18612
    ss = acmplx( app )
 
18613
  endif
 
18614
  app = abs(app)
 
18615
!
 
18616
  am1 = areal(r1)
 
18617
  hh  = aimag(r1)
 
18618
  if (hh.gt.RZRO) then
 
18619
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18620
      ,'r1 has positive imaginary part, switching its sign.'
 
18621
    r1 = acmplx( am1 ,-hh )
 
18622
  endif
 
18623
  am1 = abs(am1) + abs(hh)
 
18624
!
 
18625
  am2 = areal(r2)
 
18626
  hh  = aimag(r2)
 
18627
  if (hh.gt.RZRO) then
 
18628
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18629
      ,'r2 has positive imaginary part, switching its sign.'
 
18630
    r2 = acmplx( am2 ,-hh )
 
18631
  endif
 
18632
  am2 = abs(am2) + abs(hh)
 
18633
!
 
18634
  mulocal = muscale 
 
18635
!
 
18636
  mulocal2 = mulocal*mulocal
 
18637
!
 
18638
  if (nonzerothrs) then
 
18639
    hh = onshellthrs
 
18640
    if (app.lt.hh) app = 0
 
18641
    if (am1.lt.hh) am1 = 0
 
18642
    if (am2.lt.hh) am2 = 0
 
18643
  elseif (wunit.gt.0) then
 
18644
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18645
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18646
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18647
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18648
  endif
 
18649
!
 
18650
  if     (rank.eq.0) then
 
18651
    call bub0( rslt(:,0) &
 
18652
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18653
  elseif (rank.eq.1) then
 
18654
    call bub1( rslt(:,1),rslt(:,0) &
 
18655
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18656
  elseif (rank.eq.2) then
 
18657
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18658
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18659
  elseif (rank.eq.3) then
 
18660
    call bub111( rslt(:,5),rslt(:,4) &
 
18661
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18662
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18663
  elseif (rank.eq.4) then
 
18664
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
18665
                 ,rslt(:,5),rslt(:,4) &
 
18666
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18667
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18668
  else
 
18669
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18670
      ,'rank=',rank,' not implemented'
 
18671
  endif
 
18672
!
 
18673
  if (punit.gt.0) then
 
18674
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18675
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18676
    write(punit,*) 'pp:',trim(myprint(pp))
 
18677
    write(punit,*) 'm1:',trim(myprint(m1))
 
18678
    write(punit,*) 'm2:',trim(myprint(m2))
 
18679
    if (rank.ge.0) then
 
18680
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
18681
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
18682
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
18683
    if (rank.ge.1) then
 
18684
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
18685
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
18686
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
18687
    if (rank.ge.2) then
 
18688
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
18689
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
18690
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
18691
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
18692
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
18693
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
18694
    if (rank.ge.3) then
 
18695
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
18696
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
18697
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
18698
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
18699
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
18700
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
18701
    if (rank.ge.4) then
 
18702
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
18703
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
18704
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
18705
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
18706
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
18707
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
18708
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
18709
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
18710
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
18711
    endif;endif;endif;endif;endif
 
18712
  endif
 
18713
  end subroutine
 
18714
 
 
18715
  subroutine bnccr( rslt ,rank ,pp,m1,m2 ,rmu )
 
18716
!
 
18717
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
18718
!
 
18719
  complex(kindr2) &   
 
18720
    ,intent(out) :: rslt(0:,0:)   
 
18721
  complex(kindr2) &   
 
18722
    ,intent(in)  :: pp
 
18723
  complex(kindr2) &   
 
18724
    ,intent(in)  :: m1,m2
 
18725
  real(kindr2) &  
 
18726
   ,intent(in)  :: rmu       
 
18727
  integer,intent(in) :: rank
 
18728
!
 
18729
  complex(kindr2) &   
 
18730
    :: ss,r1,r2
 
18731
  real(kindr2) &  
 
18732
    :: app,am1,am2,hh,mulocal,mulocal2
 
18733
  character(26+99) ,parameter :: warning=&
 
18734
                     'WARNING from OneLOop bn: '//warnonshell
 
18735
  if (initz) call init
 
18736
  ss = pp
 
18737
  r1 = m1
 
18738
  r2 = m2
 
18739
!
 
18740
  app = areal(ss)
 
18741
  if (aimag(ss).ne.RZRO) then
 
18742
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18743
      ,'ss has non-zero imaginary part, putting it to zero.'
 
18744
    ss = acmplx( app )
 
18745
  endif
 
18746
  app = abs(app)
 
18747
!
 
18748
  am1 = areal(r1)
 
18749
  hh  = aimag(r1)
 
18750
  if (hh.gt.RZRO) then
 
18751
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18752
      ,'r1 has positive imaginary part, switching its sign.'
 
18753
    r1 = acmplx( am1 ,-hh )
 
18754
  endif
 
18755
  am1 = abs(am1) + abs(hh)
 
18756
!
 
18757
  am2 = areal(r2)
 
18758
  hh  = aimag(r2)
 
18759
  if (hh.gt.RZRO) then
 
18760
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18761
      ,'r2 has positive imaginary part, switching its sign.'
 
18762
    r2 = acmplx( am2 ,-hh )
 
18763
  endif
 
18764
  am2 = abs(am2) + abs(hh)
 
18765
!
 
18766
  mulocal = rmu     
 
18767
!
 
18768
  mulocal2 = mulocal*mulocal
 
18769
!
 
18770
  if (nonzerothrs) then
 
18771
    hh = onshellthrs
 
18772
    if (app.lt.hh) app = 0
 
18773
    if (am1.lt.hh) am1 = 0
 
18774
    if (am2.lt.hh) am2 = 0
 
18775
  elseif (wunit.gt.0) then
 
18776
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18777
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18778
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18779
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18780
  endif
 
18781
!
 
18782
  if     (rank.eq.0) then
 
18783
    call bub0( rslt(:,0) &
 
18784
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18785
  elseif (rank.eq.1) then
 
18786
    call bub1( rslt(:,1),rslt(:,0) &
 
18787
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18788
  elseif (rank.eq.2) then
 
18789
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18790
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18791
  elseif (rank.eq.3) then
 
18792
    call bub111( rslt(:,5),rslt(:,4) &
 
18793
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18794
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18795
  elseif (rank.eq.4) then
 
18796
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
18797
                 ,rslt(:,5),rslt(:,4) &
 
18798
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18799
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18800
  else
 
18801
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18802
      ,'rank=',rank,' not implemented'
 
18803
  endif
 
18804
!
 
18805
  if (punit.gt.0) then
 
18806
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18807
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18808
    write(punit,*) 'pp:',trim(myprint(pp))
 
18809
    write(punit,*) 'm1:',trim(myprint(m1))
 
18810
    write(punit,*) 'm2:',trim(myprint(m2))
 
18811
    if (rank.ge.0) then
 
18812
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
18813
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
18814
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
18815
    if (rank.ge.1) then
 
18816
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
18817
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
18818
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
18819
    if (rank.ge.2) then
 
18820
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
18821
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
18822
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
18823
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
18824
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
18825
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
18826
    if (rank.ge.3) then
 
18827
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
18828
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
18829
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
18830
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
18831
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
18832
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
18833
    if (rank.ge.4) then
 
18834
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
18835
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
18836
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
18837
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
18838
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
18839
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
18840
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
18841
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
18842
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
18843
    endif;endif;endif;endif;endif
 
18844
  endif
 
18845
  end subroutine
 
18846
 
 
18847
  subroutine bnrc( rslt ,rank ,pp,m1,m2 )
 
18848
!
 
18849
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
18850
!
 
18851
  complex(kindr2) &   
 
18852
    ,intent(out) :: rslt(0:,0:)   
 
18853
  real(kindr2) &  
 
18854
    ,intent(in)  :: pp
 
18855
  complex(kindr2) &   
 
18856
    ,intent(in)  :: m1,m2
 
18857
  integer,intent(in) :: rank
 
18858
!
 
18859
  complex(kindr2) &   
 
18860
    :: ss,r1,r2
 
18861
  real(kindr2) &  
 
18862
    :: app,am1,am2,hh,mulocal,mulocal2
 
18863
  character(26+99) ,parameter :: warning=&
 
18864
                     'WARNING from OneLOop bn: '//warnonshell
 
18865
  if (initz) call init
 
18866
  ss = pp
 
18867
  r1 = m1
 
18868
  r2 = m2
 
18869
!
 
18870
  app = abs(pp)
 
18871
!
 
18872
  am1 = areal(r1)
 
18873
  hh  = aimag(r1)
 
18874
  if (hh.gt.RZRO) then
 
18875
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18876
      ,'r1 has positive imaginary part, switching its sign.'
 
18877
    r1 = acmplx( am1 ,-hh )
 
18878
  endif
 
18879
  am1 = abs(am1) + abs(hh)
 
18880
!
 
18881
  am2 = areal(r2)
 
18882
  hh  = aimag(r2)
 
18883
  if (hh.gt.RZRO) then
 
18884
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18885
      ,'r2 has positive imaginary part, switching its sign.'
 
18886
    r2 = acmplx( am2 ,-hh )
 
18887
  endif
 
18888
  am2 = abs(am2) + abs(hh)
 
18889
!
 
18890
  mulocal = muscale 
 
18891
!
 
18892
  mulocal2 = mulocal*mulocal
 
18893
!
 
18894
  if (nonzerothrs) then
 
18895
    hh = onshellthrs
 
18896
    if (app.lt.hh) app = 0
 
18897
    if (am1.lt.hh) am1 = 0
 
18898
    if (am2.lt.hh) am2 = 0
 
18899
  elseif (wunit.gt.0) then
 
18900
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
18901
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
18902
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
18903
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
18904
  endif
 
18905
!
 
18906
  if     (rank.eq.0) then
 
18907
    call bub0( rslt(:,0) &
 
18908
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18909
  elseif (rank.eq.1) then
 
18910
    call bub1( rslt(:,1),rslt(:,0) &
 
18911
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18912
  elseif (rank.eq.2) then
 
18913
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18914
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18915
  elseif (rank.eq.3) then
 
18916
    call bub111( rslt(:,5),rslt(:,4) &
 
18917
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18918
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18919
  elseif (rank.eq.4) then
 
18920
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
18921
                 ,rslt(:,5),rslt(:,4) &
 
18922
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
18923
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
18924
  else
 
18925
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
18926
      ,'rank=',rank,' not implemented'
 
18927
  endif
 
18928
!
 
18929
  if (punit.gt.0) then
 
18930
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
18931
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
18932
    write(punit,*) 'pp:',trim(myprint(pp))
 
18933
    write(punit,*) 'm1:',trim(myprint(m1))
 
18934
    write(punit,*) 'm2:',trim(myprint(m2))
 
18935
    if (rank.ge.0) then
 
18936
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
18937
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
18938
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
18939
    if (rank.ge.1) then
 
18940
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
18941
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
18942
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
18943
    if (rank.ge.2) then
 
18944
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
18945
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
18946
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
18947
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
18948
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
18949
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
18950
    if (rank.ge.3) then
 
18951
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
18952
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
18953
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
18954
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
18955
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
18956
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
18957
    if (rank.ge.4) then
 
18958
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
18959
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
18960
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
18961
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
18962
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
18963
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
18964
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
18965
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
18966
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
18967
    endif;endif;endif;endif;endif
 
18968
  endif
 
18969
  end subroutine
 
18970
 
 
18971
  subroutine bnrcr( rslt ,rank ,pp,m1,m2 ,rmu )
 
18972
!
 
18973
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
18974
!
 
18975
  complex(kindr2) &   
 
18976
    ,intent(out) :: rslt(0:,0:)   
 
18977
  real(kindr2) &  
 
18978
    ,intent(in)  :: pp
 
18979
  complex(kindr2) &   
 
18980
    ,intent(in)  :: m1,m2
 
18981
  real(kindr2) &  
 
18982
   ,intent(in)  :: rmu       
 
18983
  integer,intent(in) :: rank
 
18984
!
 
18985
  complex(kindr2) &   
 
18986
    :: ss,r1,r2
 
18987
  real(kindr2) &  
 
18988
    :: app,am1,am2,hh,mulocal,mulocal2
 
18989
  character(26+99) ,parameter :: warning=&
 
18990
                     'WARNING from OneLOop bn: '//warnonshell
 
18991
  if (initz) call init
 
18992
  ss = pp
 
18993
  r1 = m1
 
18994
  r2 = m2
 
18995
!
 
18996
  app = abs(pp)
 
18997
!
 
18998
  am1 = areal(r1)
 
18999
  hh  = aimag(r1)
 
19000
  if (hh.gt.RZRO) then
 
19001
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
19002
      ,'r1 has positive imaginary part, switching its sign.'
 
19003
    r1 = acmplx( am1 ,-hh )
 
19004
  endif
 
19005
  am1 = abs(am1) + abs(hh)
 
19006
!
 
19007
  am2 = areal(r2)
 
19008
  hh  = aimag(r2)
 
19009
  if (hh.gt.RZRO) then
 
19010
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
19011
      ,'r2 has positive imaginary part, switching its sign.'
 
19012
    r2 = acmplx( am2 ,-hh )
 
19013
  endif
 
19014
  am2 = abs(am2) + abs(hh)
 
19015
!
 
19016
  mulocal = rmu     
 
19017
!
 
19018
  mulocal2 = mulocal*mulocal
 
19019
!
 
19020
  if (nonzerothrs) then
 
19021
    hh = onshellthrs
 
19022
    if (app.lt.hh) app = 0
 
19023
    if (am1.lt.hh) am1 = 0
 
19024
    if (am2.lt.hh) am2 = 0
 
19025
  elseif (wunit.gt.0) then
 
19026
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
19027
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
19028
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
19029
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
19030
  endif
 
19031
!
 
19032
  if     (rank.eq.0) then
 
19033
    call bub0( rslt(:,0) &
 
19034
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19035
  elseif (rank.eq.1) then
 
19036
    call bub1( rslt(:,1),rslt(:,0) &
 
19037
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19038
  elseif (rank.eq.2) then
 
19039
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19040
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19041
  elseif (rank.eq.3) then
 
19042
    call bub111( rslt(:,5),rslt(:,4) &
 
19043
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19044
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19045
  elseif (rank.eq.4) then
 
19046
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
19047
                 ,rslt(:,5),rslt(:,4) &
 
19048
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19049
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19050
  else
 
19051
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
19052
      ,'rank=',rank,' not implemented'
 
19053
  endif
 
19054
!
 
19055
  if (punit.gt.0) then
 
19056
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19057
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19058
    write(punit,*) 'pp:',trim(myprint(pp))
 
19059
    write(punit,*) 'm1:',trim(myprint(m1))
 
19060
    write(punit,*) 'm2:',trim(myprint(m2))
 
19061
    if (rank.ge.0) then
 
19062
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
19063
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
19064
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
19065
    if (rank.ge.1) then
 
19066
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
19067
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
19068
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
19069
    if (rank.ge.2) then
 
19070
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
19071
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
19072
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
19073
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
19074
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
19075
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
19076
    if (rank.ge.3) then
 
19077
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
19078
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
19079
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
19080
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
19081
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
19082
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
19083
    if (rank.ge.4) then
 
19084
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
19085
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
19086
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
19087
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
19088
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
19089
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
19090
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
19091
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
19092
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
19093
    endif;endif;endif;endif;endif
 
19094
  endif
 
19095
  end subroutine
 
19096
 
 
19097
  subroutine bnrr( rslt ,rank ,pp,m1,m2 )
 
19098
!
 
19099
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
19100
!
 
19101
  complex(kindr2) &   
 
19102
    ,intent(out) :: rslt(0:,0:)   
 
19103
  real(kindr2) &  
 
19104
    ,intent(in)  :: pp
 
19105
  real(kindr2) &  
 
19106
    ,intent(in)  :: m1,m2
 
19107
  integer,intent(in) :: rank
 
19108
!
 
19109
  complex(kindr2) &   
 
19110
    :: ss,r1,r2
 
19111
  real(kindr2) &  
 
19112
    :: app,am1,am2,hh,mulocal,mulocal2
 
19113
  character(26+99) ,parameter :: warning=&
 
19114
                     'WARNING from OneLOop bn: '//warnonshell
 
19115
  if (initz) call init
 
19116
  ss = pp
 
19117
  r1 = m1
 
19118
  r2 = m2
 
19119
!
 
19120
  app = abs(pp)
 
19121
!
 
19122
  am1 = abs(m1)
 
19123
  am2 = abs(m2)
 
19124
!
 
19125
  mulocal = muscale 
 
19126
!
 
19127
  mulocal2 = mulocal*mulocal
 
19128
!
 
19129
  if (nonzerothrs) then
 
19130
    hh = onshellthrs
 
19131
    if (app.lt.hh) app = 0
 
19132
    if (am1.lt.hh) am1 = 0
 
19133
    if (am2.lt.hh) am2 = 0
 
19134
  elseif (wunit.gt.0) then
 
19135
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
19136
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
19137
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
19138
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
19139
  endif
 
19140
!
 
19141
  if     (rank.eq.0) then
 
19142
    call bub0( rslt(:,0) &
 
19143
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19144
  elseif (rank.eq.1) then
 
19145
    call bub1( rslt(:,1),rslt(:,0) &
 
19146
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19147
  elseif (rank.eq.2) then
 
19148
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19149
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19150
  elseif (rank.eq.3) then
 
19151
    call bub111( rslt(:,5),rslt(:,4) &
 
19152
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19153
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19154
  elseif (rank.eq.4) then
 
19155
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
19156
                 ,rslt(:,5),rslt(:,4) &
 
19157
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19158
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19159
  else
 
19160
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
19161
      ,'rank=',rank,' not implemented'
 
19162
  endif
 
19163
!
 
19164
  if (punit.gt.0) then
 
19165
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19166
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19167
    write(punit,*) 'pp:',trim(myprint(pp))
 
19168
    write(punit,*) 'm1:',trim(myprint(m1))
 
19169
    write(punit,*) 'm2:',trim(myprint(m2))
 
19170
    if (rank.ge.0) then
 
19171
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
19172
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
19173
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
19174
    if (rank.ge.1) then
 
19175
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
19176
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
19177
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
19178
    if (rank.ge.2) then
 
19179
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
19180
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
19181
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
19182
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
19183
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
19184
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
19185
    if (rank.ge.3) then
 
19186
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
19187
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
19188
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
19189
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
19190
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
19191
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
19192
    if (rank.ge.4) then
 
19193
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
19194
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
19195
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
19196
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
19197
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
19198
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
19199
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
19200
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
19201
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
19202
    endif;endif;endif;endif;endif
 
19203
  endif
 
19204
  end subroutine
 
19205
 
 
19206
  subroutine bnrrr( rslt ,rank ,pp,m1,m2 ,rmu )
 
19207
!
 
19208
  use avh_olo_qp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
19209
!
 
19210
  complex(kindr2) &   
 
19211
    ,intent(out) :: rslt(0:,0:)   
 
19212
  real(kindr2) &  
 
19213
    ,intent(in)  :: pp
 
19214
  real(kindr2) &  
 
19215
    ,intent(in)  :: m1,m2
 
19216
  real(kindr2) &  
 
19217
   ,intent(in)  :: rmu       
 
19218
  integer,intent(in) :: rank
 
19219
!
 
19220
  complex(kindr2) &   
 
19221
    :: ss,r1,r2
 
19222
  real(kindr2) &  
 
19223
    :: app,am1,am2,hh,mulocal,mulocal2
 
19224
  character(26+99) ,parameter :: warning=&
 
19225
                     'WARNING from OneLOop bn: '//warnonshell
 
19226
  if (initz) call init
 
19227
  ss = pp
 
19228
  r1 = m1
 
19229
  r2 = m2
 
19230
!
 
19231
  app = abs(pp)
 
19232
!
 
19233
  am1 = abs(m1)
 
19234
  am2 = abs(m2)
 
19235
!
 
19236
  mulocal = rmu     
 
19237
!
 
19238
  mulocal2 = mulocal*mulocal
 
19239
!
 
19240
  if (nonzerothrs) then
 
19241
    hh = onshellthrs
 
19242
    if (app.lt.hh) app = 0
 
19243
    if (am1.lt.hh) am1 = 0
 
19244
    if (am2.lt.hh) am2 = 0
 
19245
  elseif (wunit.gt.0) then
 
19246
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
19247
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
19248
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
19249
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
19250
  endif
 
19251
!
 
19252
  if     (rank.eq.0) then
 
19253
    call bub0( rslt(:,0) &
 
19254
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19255
  elseif (rank.eq.1) then
 
19256
    call bub1( rslt(:,1),rslt(:,0) &
 
19257
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19258
  elseif (rank.eq.2) then
 
19259
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19260
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19261
  elseif (rank.eq.3) then
 
19262
    call bub111( rslt(:,5),rslt(:,4) &
 
19263
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19264
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19265
  elseif (rank.eq.4) then
 
19266
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
19267
                 ,rslt(:,5),rslt(:,4) &
 
19268
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
19269
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
19270
  else
 
19271
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
19272
      ,'rank=',rank,' not implemented'
 
19273
  endif
 
19274
!
 
19275
  if (punit.gt.0) then
 
19276
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19277
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19278
    write(punit,*) 'pp:',trim(myprint(pp))
 
19279
    write(punit,*) 'm1:',trim(myprint(m1))
 
19280
    write(punit,*) 'm2:',trim(myprint(m2))
 
19281
    if (rank.ge.0) then
 
19282
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
19283
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
19284
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
19285
    if (rank.ge.1) then
 
19286
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
19287
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
19288
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
19289
    if (rank.ge.2) then
 
19290
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
19291
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
19292
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
19293
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
19294
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
19295
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
19296
    if (rank.ge.3) then
 
19297
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
19298
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
19299
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
19300
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
19301
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
19302
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
19303
    if (rank.ge.4) then
 
19304
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
19305
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
19306
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
19307
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
19308
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
19309
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
19310
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
19311
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
19312
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
19313
    endif;endif;endif;endif;endif
 
19314
  endif
 
19315
  end subroutine
 
19316
 
 
19317
 
 
19318
!*******************************************************************
 
19319
! calculates
 
19320
!               C   /               d^(Dim)q
 
19321
!            ------ | ---------------------------------------
 
19322
!            i*pi^2 / [q^2-m1] [(q+k1)^2-m2] [(q+k1+k2)^2-m3]
 
19323
!
 
19324
! with  Dim = 4-2*eps
 
19325
!         C = pi^eps * mu^(2*eps)
 
19326
!             * GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
19327
!
 
19328
! input:  p1=k1^2, p2=k2^2, p3=(k1+k2)^2,  m1,m2,m3=squared masses
 
19329
! output: rslt(0) = eps^0   -coefficient
 
19330
!         rslt(1) = eps^(-1)-coefficient
 
19331
!         rslt(2) = eps^(-2)-coefficient
 
19332
!
 
19333
! Check the comments in  subroutine olo_onshell  to find out how
 
19334
! this routine decides when to return IR-divergent cases.
 
19335
!*******************************************************************
 
19336
 
 
19337
  subroutine c0cc( rslt ,p1,p2,p3 ,m1,m2,m3 )
 
19338
  use avh_olo_qp_tri
 
19339
  use avh_olo_qp_auxfun ,only: kallen
 
19340
!
 
19341
  complex(kindr2) &   
 
19342
    ,intent(out) :: rslt(0:2)
 
19343
  complex(kindr2) &   
 
19344
    ,intent(in)  :: p1,p2,p3
 
19345
  complex(kindr2) &   
 
19346
    ,intent(in)  :: m1,m2,m3
 
19347
!
 
19348
  complex(kindr2) &   
 
19349
    :: pp(3)
 
19350
  complex(kindr2) &   
 
19351
    :: mm(3)
 
19352
  complex(kindr2) &   
 
19353
    :: ss(3),rr(3),lambda
 
19354
  real(kindr2) &  
 
19355
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
19356
  real(kindr2) &  
 
19357
    :: mulocal,mulocal2
 
19358
  integer :: icase,ii
 
19359
  character(25+99) ,parameter :: warning=&
 
19360
                     'WARNING from OneLOop c0: '//warnonshell
 
19361
  if (initz) call init
 
19362
  pp(1) = p1
 
19363
  pp(2) = p2
 
19364
  pp(3) = p3
 
19365
  mm(1) = m1
 
19366
  mm(2) = m2
 
19367
  mm(3) = m3
 
19368
  smax = 0
 
19369
!
 
19370
  do ii=1,3
 
19371
    ap(ii) = areal(pp(ii))
 
19372
    if (aimag(pp(ii)).ne.RZRO) then
 
19373
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19374
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
19375
      pp(ii) = acmplx( ap(ii) )
 
19376
    endif
 
19377
    ap(ii) = abs(ap(ii))
 
19378
    if (ap(ii).gt.smax) smax = ap(ii)
 
19379
  enddo
 
19380
!
 
19381
  do ii=1,3
 
19382
    am(ii) = areal(mm(ii))
 
19383
    hh     = aimag(mm(ii))
 
19384
    if (hh.gt.RZRO) then
 
19385
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19386
        ,'mass-squared has positive imaginary part, switching its sign.'
 
19387
      mm(ii) = acmplx( am(ii) ,-hh )
 
19388
    endif
 
19389
    am(ii) = abs(am(ii)) + abs(hh)
 
19390
    if (am(ii).gt.smax) smax = am(ii)
 
19391
  enddo
 
19392
!
 
19393
  mulocal = muscale 
 
19394
!
 
19395
  mulocal2 = mulocal*mulocal
 
19396
!
 
19397
  if (smax.eq.RZRO) then
 
19398
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19399
      ,'all input equal zero, returning 0'
 
19400
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
19401
    return
 
19402
  endif
 
19403
!
 
19404
  if (mulocal2.gt.smax) smax = mulocal2
 
19405
!
 
19406
  if (nonzerothrs) then
 
19407
    hh = onshellthrs
 
19408
    do ii=1,3
 
19409
      if (ap(ii).lt.hh) ap(ii) = 0
 
19410
      if (am(ii).lt.hh) am(ii) = 0
 
19411
    enddo
 
19412
  else
 
19413
    hh = onshellthrs*smax
 
19414
    if (wunit.gt.0) then
 
19415
    do ii=1,3
 
19416
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
19417
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
19418
    enddo
 
19419
    endif
 
19420
  endif
 
19421
!
 
19422
  icase = 0
 
19423
  do ii=1,3
 
19424
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
19425
  enddo
 
19426
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
19427
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
19428
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
19429
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
19430
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
19431
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
19432
  icase = casetable(icase)
 
19433
!
 
19434
  s1r2 = abs(ss(1)-rr(2))
 
19435
  s2r3 = abs(ss(2)-rr(3))
 
19436
  s3r3 = abs(ss(3)-rr(3))
 
19437
  if (nonzerothrs) then
 
19438
    if (s1r2.lt.hh) s1r2 = 0
 
19439
    if (s2r3.lt.hh) s2r3 = 0
 
19440
    if (s3r3.lt.hh) s3r3 = 0
 
19441
  elseif (wunit.gt.0) then
 
19442
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
19443
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
19444
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
19445
  endif
 
19446
!
 
19447
  if     (icase.eq.3) then
 
19448
! 3 non-zero internal masses
 
19449
    lambda = kallen( ss(1),ss(2),ss(3) )
 
19450
    if (areal(lambda).lt.RZRO) then
 
19451
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
19452
    else
 
19453
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
19454
    endif
 
19455
  elseif (icase.eq.2) then
 
19456
! 2 non-zero internal masses
 
19457
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
19458
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
19459
    else
 
19460
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
19461
    endif
 
19462
  elseif (icase.eq.1) then
 
19463
! 1 non-zero internal mass
 
19464
    if     (as(1).ne.RZRO) then
 
19465
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
19466
    elseif (s2r3.ne.RZRO) then
 
19467
      if   (s3r3.ne.RZRO) then
 
19468
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
19469
      else
 
19470
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
19471
      endif
 
19472
    elseif (s3r3.ne.RZRO) then
 
19473
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
19474
    else
 
19475
      call tria1( rslt ,rr(3) ,mulocal2 )
 
19476
    endif
 
19477
  else
 
19478
! 0 non-zero internal masses
 
19479
    call tria0( rslt ,ss ,as ,mulocal2 )
 
19480
  endif
 
19481
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
19482
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
19483
!
 
19484
  if (punit.gt.0) then
 
19485
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19486
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19487
    write(punit,*) ' p1:',trim(myprint(p1))
 
19488
    write(punit,*) ' p2:',trim(myprint(p2))
 
19489
    write(punit,*) ' p3:',trim(myprint(p3))
 
19490
    write(punit,*) ' m1:',trim(myprint(m1))
 
19491
    write(punit,*) ' m2:',trim(myprint(m2))
 
19492
    write(punit,*) ' m3:',trim(myprint(m3))
 
19493
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
19494
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
19495
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
19496
  endif
 
19497
  end subroutine
 
19498
 
 
19499
  subroutine c0ccr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
 
19500
  use avh_olo_qp_tri
 
19501
  use avh_olo_qp_auxfun ,only: kallen
 
19502
!
 
19503
  complex(kindr2) &   
 
19504
    ,intent(out) :: rslt(0:2)
 
19505
  complex(kindr2) &   
 
19506
    ,intent(in)  :: p1,p2,p3
 
19507
  complex(kindr2) &   
 
19508
    ,intent(in)  :: m1,m2,m3
 
19509
  real(kindr2) &  
 
19510
    ,intent(in)  :: rmu      
 
19511
!
 
19512
  complex(kindr2) &   
 
19513
    :: pp(3)
 
19514
  complex(kindr2) &   
 
19515
    :: mm(3)
 
19516
  complex(kindr2) &   
 
19517
    :: ss(3),rr(3),lambda
 
19518
  real(kindr2) &  
 
19519
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
19520
  real(kindr2) &  
 
19521
    :: mulocal,mulocal2
 
19522
  integer :: icase,ii
 
19523
  character(25+99) ,parameter :: warning=&
 
19524
                     'WARNING from OneLOop c0: '//warnonshell
 
19525
  if (initz) call init
 
19526
  pp(1) = p1
 
19527
  pp(2) = p2
 
19528
  pp(3) = p3
 
19529
  mm(1) = m1
 
19530
  mm(2) = m2
 
19531
  mm(3) = m3
 
19532
  smax = 0
 
19533
!
 
19534
  do ii=1,3
 
19535
    ap(ii) = areal(pp(ii))
 
19536
    if (aimag(pp(ii)).ne.RZRO) then
 
19537
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19538
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
19539
      pp(ii) = acmplx( ap(ii) )
 
19540
    endif
 
19541
    ap(ii) = abs(ap(ii))
 
19542
    if (ap(ii).gt.smax) smax = ap(ii)
 
19543
  enddo
 
19544
!
 
19545
  do ii=1,3
 
19546
    am(ii) = areal(mm(ii))
 
19547
    hh     = aimag(mm(ii))
 
19548
    if (hh.gt.RZRO) then
 
19549
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19550
        ,'mass-squared has positive imaginary part, switching its sign.'
 
19551
      mm(ii) = acmplx( am(ii) ,-hh )
 
19552
    endif
 
19553
    am(ii) = abs(am(ii)) + abs(hh)
 
19554
    if (am(ii).gt.smax) smax = am(ii)
 
19555
  enddo
 
19556
!
 
19557
  mulocal = rmu     
 
19558
!
 
19559
  mulocal2 = mulocal*mulocal
 
19560
!
 
19561
  if (smax.eq.RZRO) then
 
19562
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19563
      ,'all input equal zero, returning 0'
 
19564
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
19565
    return
 
19566
  endif
 
19567
!
 
19568
  if (mulocal2.gt.smax) smax = mulocal2
 
19569
!
 
19570
  if (nonzerothrs) then
 
19571
    hh = onshellthrs
 
19572
    do ii=1,3
 
19573
      if (ap(ii).lt.hh) ap(ii) = 0
 
19574
      if (am(ii).lt.hh) am(ii) = 0
 
19575
    enddo
 
19576
  else
 
19577
    hh = onshellthrs*smax
 
19578
    if (wunit.gt.0) then
 
19579
    do ii=1,3
 
19580
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
19581
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
19582
    enddo
 
19583
    endif
 
19584
  endif
 
19585
!
 
19586
  icase = 0
 
19587
  do ii=1,3
 
19588
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
19589
  enddo
 
19590
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
19591
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
19592
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
19593
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
19594
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
19595
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
19596
  icase = casetable(icase)
 
19597
!
 
19598
  s1r2 = abs(ss(1)-rr(2))
 
19599
  s2r3 = abs(ss(2)-rr(3))
 
19600
  s3r3 = abs(ss(3)-rr(3))
 
19601
  if (nonzerothrs) then
 
19602
    if (s1r2.lt.hh) s1r2 = 0
 
19603
    if (s2r3.lt.hh) s2r3 = 0
 
19604
    if (s3r3.lt.hh) s3r3 = 0
 
19605
  elseif (wunit.gt.0) then
 
19606
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
19607
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
19608
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
19609
  endif
 
19610
!
 
19611
  if     (icase.eq.3) then
 
19612
! 3 non-zero internal masses
 
19613
    lambda = kallen( ss(1),ss(2),ss(3) )
 
19614
    if (areal(lambda).lt.RZRO) then
 
19615
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
19616
    else
 
19617
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
19618
    endif
 
19619
  elseif (icase.eq.2) then
 
19620
! 2 non-zero internal masses
 
19621
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
19622
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
19623
    else
 
19624
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
19625
    endif
 
19626
  elseif (icase.eq.1) then
 
19627
! 1 non-zero internal mass
 
19628
    if     (as(1).ne.RZRO) then
 
19629
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
19630
    elseif (s2r3.ne.RZRO) then
 
19631
      if   (s3r3.ne.RZRO) then
 
19632
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
19633
      else
 
19634
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
19635
      endif
 
19636
    elseif (s3r3.ne.RZRO) then
 
19637
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
19638
    else
 
19639
      call tria1( rslt ,rr(3) ,mulocal2 )
 
19640
    endif
 
19641
  else
 
19642
! 0 non-zero internal masses
 
19643
    call tria0( rslt ,ss ,as ,mulocal2 )
 
19644
  endif
 
19645
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
19646
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
19647
!
 
19648
  if (punit.gt.0) then
 
19649
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19650
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19651
    write(punit,*) ' p1:',trim(myprint(p1))
 
19652
    write(punit,*) ' p2:',trim(myprint(p2))
 
19653
    write(punit,*) ' p3:',trim(myprint(p3))
 
19654
    write(punit,*) ' m1:',trim(myprint(m1))
 
19655
    write(punit,*) ' m2:',trim(myprint(m2))
 
19656
    write(punit,*) ' m3:',trim(myprint(m3))
 
19657
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
19658
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
19659
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
19660
  endif
 
19661
  end subroutine
 
19662
 
 
19663
  subroutine c0rc( rslt ,p1,p2,p3 ,m1,m2,m3 )
 
19664
  use avh_olo_qp_tri
 
19665
  use avh_olo_qp_auxfun ,only: kallen
 
19666
!
 
19667
  complex(kindr2) &   
 
19668
    ,intent(out) :: rslt(0:2)
 
19669
  real(kindr2) &  
 
19670
    ,intent(in)  :: p1,p2,p3
 
19671
  complex(kindr2) &   
 
19672
    ,intent(in)  :: m1,m2,m3
 
19673
!
 
19674
  real(kindr2) &  
 
19675
    :: pp(3)
 
19676
  complex(kindr2) &   
 
19677
    :: mm(3)
 
19678
  complex(kindr2) &   
 
19679
    :: ss(3),rr(3),lambda
 
19680
  real(kindr2) &  
 
19681
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
19682
  real(kindr2) &  
 
19683
    :: mulocal,mulocal2
 
19684
  integer :: icase,ii
 
19685
  character(25+99) ,parameter :: warning=&
 
19686
                     'WARNING from OneLOop c0: '//warnonshell
 
19687
  if (initz) call init
 
19688
  pp(1) = p1
 
19689
  pp(2) = p2
 
19690
  pp(3) = p3
 
19691
  mm(1) = m1
 
19692
  mm(2) = m2
 
19693
  mm(3) = m3
 
19694
  smax = 0
 
19695
!
 
19696
  do ii=1,3
 
19697
    ap(ii) = abs(pp(ii))
 
19698
    if (ap(ii).gt.smax) smax = ap(ii)
 
19699
  enddo
 
19700
!
 
19701
  do ii=1,3
 
19702
    am(ii) = areal(mm(ii))
 
19703
    hh     = aimag(mm(ii))
 
19704
    if (hh.gt.RZRO) then
 
19705
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19706
        ,'mass-squared has positive imaginary part, switching its sign.'
 
19707
      mm(ii) = acmplx( am(ii) ,-hh )
 
19708
    endif
 
19709
    am(ii) = abs(am(ii)) + abs(hh)
 
19710
    if (am(ii).gt.smax) smax = am(ii)
 
19711
  enddo
 
19712
!
 
19713
  mulocal = muscale 
 
19714
!
 
19715
  mulocal2 = mulocal*mulocal
 
19716
!
 
19717
  if (smax.eq.RZRO) then
 
19718
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19719
      ,'all input equal zero, returning 0'
 
19720
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
19721
    return
 
19722
  endif
 
19723
!
 
19724
  if (mulocal2.gt.smax) smax = mulocal2
 
19725
!
 
19726
  if (nonzerothrs) then
 
19727
    hh = onshellthrs
 
19728
    do ii=1,3
 
19729
      if (ap(ii).lt.hh) ap(ii) = 0
 
19730
      if (am(ii).lt.hh) am(ii) = 0
 
19731
    enddo
 
19732
  else
 
19733
    hh = onshellthrs*smax
 
19734
    if (wunit.gt.0) then
 
19735
    do ii=1,3
 
19736
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
19737
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
19738
    enddo
 
19739
    endif
 
19740
  endif
 
19741
!
 
19742
  icase = 0
 
19743
  do ii=1,3
 
19744
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
19745
  enddo
 
19746
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
19747
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
19748
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
19749
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
19750
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
19751
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
19752
  icase = casetable(icase)
 
19753
!
 
19754
  s1r2 = abs(ss(1)-rr(2))
 
19755
  s2r3 = abs(ss(2)-rr(3))
 
19756
  s3r3 = abs(ss(3)-rr(3))
 
19757
  if (nonzerothrs) then
 
19758
    if (s1r2.lt.hh) s1r2 = 0
 
19759
    if (s2r3.lt.hh) s2r3 = 0
 
19760
    if (s3r3.lt.hh) s3r3 = 0
 
19761
  elseif (wunit.gt.0) then
 
19762
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
19763
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
19764
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
19765
  endif
 
19766
!
 
19767
  if     (icase.eq.3) then
 
19768
! 3 non-zero internal masses
 
19769
    lambda = kallen( ss(1),ss(2),ss(3) )
 
19770
    if (areal(lambda).lt.RZRO) then
 
19771
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
19772
    else
 
19773
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
19774
    endif
 
19775
  elseif (icase.eq.2) then
 
19776
! 2 non-zero internal masses
 
19777
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
19778
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
19779
    else
 
19780
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
19781
    endif
 
19782
  elseif (icase.eq.1) then
 
19783
! 1 non-zero internal mass
 
19784
    if     (as(1).ne.RZRO) then
 
19785
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
19786
    elseif (s2r3.ne.RZRO) then
 
19787
      if   (s3r3.ne.RZRO) then
 
19788
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
19789
      else
 
19790
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
19791
      endif
 
19792
    elseif (s3r3.ne.RZRO) then
 
19793
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
19794
    else
 
19795
      call tria1( rslt ,rr(3) ,mulocal2 )
 
19796
    endif
 
19797
  else
 
19798
! 0 non-zero internal masses
 
19799
    call tria0( rslt ,ss ,as ,mulocal2 )
 
19800
  endif
 
19801
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
19802
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
19803
!
 
19804
  if (punit.gt.0) then
 
19805
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19806
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19807
    write(punit,*) ' p1:',trim(myprint(p1))
 
19808
    write(punit,*) ' p2:',trim(myprint(p2))
 
19809
    write(punit,*) ' p3:',trim(myprint(p3))
 
19810
    write(punit,*) ' m1:',trim(myprint(m1))
 
19811
    write(punit,*) ' m2:',trim(myprint(m2))
 
19812
    write(punit,*) ' m3:',trim(myprint(m3))
 
19813
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
19814
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
19815
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
19816
  endif
 
19817
  end subroutine
 
19818
 
 
19819
  subroutine c0rcr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
 
19820
  use avh_olo_qp_tri
 
19821
  use avh_olo_qp_auxfun ,only: kallen
 
19822
!
 
19823
  complex(kindr2) &   
 
19824
    ,intent(out) :: rslt(0:2)
 
19825
  real(kindr2) &  
 
19826
    ,intent(in)  :: p1,p2,p3
 
19827
  complex(kindr2) &   
 
19828
    ,intent(in)  :: m1,m2,m3
 
19829
  real(kindr2) &  
 
19830
    ,intent(in)  :: rmu      
 
19831
!
 
19832
  real(kindr2) &  
 
19833
    :: pp(3)
 
19834
  complex(kindr2) &   
 
19835
    :: mm(3)
 
19836
  complex(kindr2) &   
 
19837
    :: ss(3),rr(3),lambda
 
19838
  real(kindr2) &  
 
19839
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
19840
  real(kindr2) &  
 
19841
    :: mulocal,mulocal2
 
19842
  integer :: icase,ii
 
19843
  character(25+99) ,parameter :: warning=&
 
19844
                     'WARNING from OneLOop c0: '//warnonshell
 
19845
  if (initz) call init
 
19846
  pp(1) = p1
 
19847
  pp(2) = p2
 
19848
  pp(3) = p3
 
19849
  mm(1) = m1
 
19850
  mm(2) = m2
 
19851
  mm(3) = m3
 
19852
  smax = 0
 
19853
!
 
19854
  do ii=1,3
 
19855
    ap(ii) = abs(pp(ii))
 
19856
    if (ap(ii).gt.smax) smax = ap(ii)
 
19857
  enddo
 
19858
!
 
19859
  do ii=1,3
 
19860
    am(ii) = areal(mm(ii))
 
19861
    hh     = aimag(mm(ii))
 
19862
    if (hh.gt.RZRO) then
 
19863
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19864
        ,'mass-squared has positive imaginary part, switching its sign.'
 
19865
      mm(ii) = acmplx( am(ii) ,-hh )
 
19866
    endif
 
19867
    am(ii) = abs(am(ii)) + abs(hh)
 
19868
    if (am(ii).gt.smax) smax = am(ii)
 
19869
  enddo
 
19870
!
 
19871
  mulocal = rmu     
 
19872
!
 
19873
  mulocal2 = mulocal*mulocal
 
19874
!
 
19875
  if (smax.eq.RZRO) then
 
19876
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
19877
      ,'all input equal zero, returning 0'
 
19878
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
19879
    return
 
19880
  endif
 
19881
!
 
19882
  if (mulocal2.gt.smax) smax = mulocal2
 
19883
!
 
19884
  if (nonzerothrs) then
 
19885
    hh = onshellthrs
 
19886
    do ii=1,3
 
19887
      if (ap(ii).lt.hh) ap(ii) = 0
 
19888
      if (am(ii).lt.hh) am(ii) = 0
 
19889
    enddo
 
19890
  else
 
19891
    hh = onshellthrs*smax
 
19892
    if (wunit.gt.0) then
 
19893
    do ii=1,3
 
19894
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
19895
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
19896
    enddo
 
19897
    endif
 
19898
  endif
 
19899
!
 
19900
  icase = 0
 
19901
  do ii=1,3
 
19902
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
19903
  enddo
 
19904
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
19905
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
19906
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
19907
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
19908
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
19909
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
19910
  icase = casetable(icase)
 
19911
!
 
19912
  s1r2 = abs(ss(1)-rr(2))
 
19913
  s2r3 = abs(ss(2)-rr(3))
 
19914
  s3r3 = abs(ss(3)-rr(3))
 
19915
  if (nonzerothrs) then
 
19916
    if (s1r2.lt.hh) s1r2 = 0
 
19917
    if (s2r3.lt.hh) s2r3 = 0
 
19918
    if (s3r3.lt.hh) s3r3 = 0
 
19919
  elseif (wunit.gt.0) then
 
19920
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
19921
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
19922
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
19923
  endif
 
19924
!
 
19925
  if     (icase.eq.3) then
 
19926
! 3 non-zero internal masses
 
19927
    lambda = kallen( ss(1),ss(2),ss(3) )
 
19928
    if (areal(lambda).lt.RZRO) then
 
19929
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
19930
    else
 
19931
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
19932
    endif
 
19933
  elseif (icase.eq.2) then
 
19934
! 2 non-zero internal masses
 
19935
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
19936
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
19937
    else
 
19938
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
19939
    endif
 
19940
  elseif (icase.eq.1) then
 
19941
! 1 non-zero internal mass
 
19942
    if     (as(1).ne.RZRO) then
 
19943
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
19944
    elseif (s2r3.ne.RZRO) then
 
19945
      if   (s3r3.ne.RZRO) then
 
19946
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
19947
      else
 
19948
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
19949
      endif
 
19950
    elseif (s3r3.ne.RZRO) then
 
19951
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
19952
    else
 
19953
      call tria1( rslt ,rr(3) ,mulocal2 )
 
19954
    endif
 
19955
  else
 
19956
! 0 non-zero internal masses
 
19957
    call tria0( rslt ,ss ,as ,mulocal2 )
 
19958
  endif
 
19959
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
19960
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
19961
!
 
19962
  if (punit.gt.0) then
 
19963
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
19964
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
19965
    write(punit,*) ' p1:',trim(myprint(p1))
 
19966
    write(punit,*) ' p2:',trim(myprint(p2))
 
19967
    write(punit,*) ' p3:',trim(myprint(p3))
 
19968
    write(punit,*) ' m1:',trim(myprint(m1))
 
19969
    write(punit,*) ' m2:',trim(myprint(m2))
 
19970
    write(punit,*) ' m3:',trim(myprint(m3))
 
19971
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
19972
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
19973
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
19974
  endif
 
19975
  end subroutine
 
19976
 
 
19977
  subroutine c0rr( rslt ,p1,p2,p3 ,m1,m2,m3 )
 
19978
  use avh_olo_qp_tri
 
19979
  use avh_olo_qp_auxfun ,only: kallen
 
19980
!
 
19981
  complex(kindr2) &   
 
19982
    ,intent(out) :: rslt(0:2)
 
19983
  real(kindr2) &  
 
19984
    ,intent(in)  :: p1,p2,p3
 
19985
  real(kindr2) &  
 
19986
    ,intent(in)  :: m1,m2,m3
 
19987
!
 
19988
  real(kindr2) &  
 
19989
    :: pp(3)
 
19990
  real(kindr2) &  
 
19991
    :: mm(3)
 
19992
  complex(kindr2) &   
 
19993
    :: ss(3),rr(3),lambda
 
19994
  real(kindr2) &  
 
19995
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
19996
  real(kindr2) &  
 
19997
    :: mulocal,mulocal2
 
19998
  integer :: icase,ii
 
19999
  character(25+99) ,parameter :: warning=&
 
20000
                     'WARNING from OneLOop c0: '//warnonshell
 
20001
  if (initz) call init
 
20002
  pp(1) = p1
 
20003
  pp(2) = p2
 
20004
  pp(3) = p3
 
20005
  mm(1) = m1
 
20006
  mm(2) = m2
 
20007
  mm(3) = m3
 
20008
  smax = 0
 
20009
!
 
20010
  do ii=1,3
 
20011
    ap(ii) = abs(pp(ii))
 
20012
    if (ap(ii).gt.smax) smax = ap(ii)
 
20013
  enddo
 
20014
!
 
20015
  do ii=1,3
 
20016
    am(ii) = abs(mm(ii))
 
20017
    if (am(ii).gt.smax) smax = am(ii)
 
20018
  enddo
 
20019
!
 
20020
  mulocal = muscale 
 
20021
!
 
20022
  mulocal2 = mulocal*mulocal
 
20023
!
 
20024
  if (smax.eq.RZRO) then
 
20025
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
20026
      ,'all input equal zero, returning 0'
 
20027
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
20028
    return
 
20029
  endif
 
20030
!
 
20031
  if (mulocal2.gt.smax) smax = mulocal2
 
20032
!
 
20033
  if (nonzerothrs) then
 
20034
    hh = onshellthrs
 
20035
    do ii=1,3
 
20036
      if (ap(ii).lt.hh) ap(ii) = 0
 
20037
      if (am(ii).lt.hh) am(ii) = 0
 
20038
    enddo
 
20039
  else
 
20040
    hh = onshellthrs*smax
 
20041
    if (wunit.gt.0) then
 
20042
    do ii=1,3
 
20043
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
20044
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
20045
    enddo
 
20046
    endif
 
20047
  endif
 
20048
!
 
20049
  icase = 0
 
20050
  do ii=1,3
 
20051
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
20052
  enddo
 
20053
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
20054
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
20055
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
20056
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
20057
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
20058
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
20059
  icase = casetable(icase)
 
20060
!
 
20061
  s1r2 = abs(ss(1)-rr(2))
 
20062
  s2r3 = abs(ss(2)-rr(3))
 
20063
  s3r3 = abs(ss(3)-rr(3))
 
20064
  if (nonzerothrs) then
 
20065
    if (s1r2.lt.hh) s1r2 = 0
 
20066
    if (s2r3.lt.hh) s2r3 = 0
 
20067
    if (s3r3.lt.hh) s3r3 = 0
 
20068
  elseif (wunit.gt.0) then
 
20069
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
20070
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
20071
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
20072
  endif
 
20073
!
 
20074
  if     (icase.eq.3) then
 
20075
! 3 non-zero internal masses
 
20076
    lambda = kallen( ss(1),ss(2),ss(3) )
 
20077
    if (areal(lambda).lt.RZRO) then
 
20078
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
20079
    else
 
20080
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
20081
    endif
 
20082
  elseif (icase.eq.2) then
 
20083
! 2 non-zero internal masses
 
20084
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
20085
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
20086
    else
 
20087
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
20088
    endif
 
20089
  elseif (icase.eq.1) then
 
20090
! 1 non-zero internal mass
 
20091
    if     (as(1).ne.RZRO) then
 
20092
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
20093
    elseif (s2r3.ne.RZRO) then
 
20094
      if   (s3r3.ne.RZRO) then
 
20095
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
20096
      else
 
20097
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
20098
      endif
 
20099
    elseif (s3r3.ne.RZRO) then
 
20100
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
20101
    else
 
20102
      call tria1( rslt ,rr(3) ,mulocal2 )
 
20103
    endif
 
20104
  else
 
20105
! 0 non-zero internal masses
 
20106
    call tria0( rslt ,ss ,as ,mulocal2 )
 
20107
  endif
 
20108
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
20109
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
20110
!
 
20111
  if (punit.gt.0) then
 
20112
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
20113
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
20114
    write(punit,*) ' p1:',trim(myprint(p1))
 
20115
    write(punit,*) ' p2:',trim(myprint(p2))
 
20116
    write(punit,*) ' p3:',trim(myprint(p3))
 
20117
    write(punit,*) ' m1:',trim(myprint(m1))
 
20118
    write(punit,*) ' m2:',trim(myprint(m2))
 
20119
    write(punit,*) ' m3:',trim(myprint(m3))
 
20120
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
20121
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
20122
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
20123
  endif
 
20124
  end subroutine
 
20125
 
 
20126
  subroutine c0rrr( rslt ,p1,p2,p3 ,m1,m2,m3 ,rmu )
 
20127
  use avh_olo_qp_tri
 
20128
  use avh_olo_qp_auxfun ,only: kallen
 
20129
!
 
20130
  complex(kindr2) &   
 
20131
    ,intent(out) :: rslt(0:2)
 
20132
  real(kindr2) &  
 
20133
    ,intent(in)  :: p1,p2,p3
 
20134
  real(kindr2) &  
 
20135
    ,intent(in)  :: m1,m2,m3
 
20136
  real(kindr2) &  
 
20137
    ,intent(in)  :: rmu      
 
20138
!
 
20139
  real(kindr2) &  
 
20140
    :: pp(3)
 
20141
  real(kindr2) &  
 
20142
    :: mm(3)
 
20143
  complex(kindr2) &   
 
20144
    :: ss(3),rr(3),lambda
 
20145
  real(kindr2) &  
 
20146
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
 
20147
  real(kindr2) &  
 
20148
    :: mulocal,mulocal2
 
20149
  integer :: icase,ii
 
20150
  character(25+99) ,parameter :: warning=&
 
20151
                     'WARNING from OneLOop c0: '//warnonshell
 
20152
  if (initz) call init
 
20153
  pp(1) = p1
 
20154
  pp(2) = p2
 
20155
  pp(3) = p3
 
20156
  mm(1) = m1
 
20157
  mm(2) = m2
 
20158
  mm(3) = m3
 
20159
  smax = 0
 
20160
!
 
20161
  do ii=1,3
 
20162
    ap(ii) = abs(pp(ii))
 
20163
    if (ap(ii).gt.smax) smax = ap(ii)
 
20164
  enddo
 
20165
!
 
20166
  do ii=1,3
 
20167
    am(ii) = abs(mm(ii))
 
20168
    if (am(ii).gt.smax) smax = am(ii)
 
20169
  enddo
 
20170
!
 
20171
  mulocal = rmu     
 
20172
!
 
20173
  mulocal2 = mulocal*mulocal
 
20174
!
 
20175
  if (smax.eq.RZRO) then
 
20176
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop c0: ' &
 
20177
      ,'all input equal zero, returning 0'
 
20178
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
20179
    return
 
20180
  endif
 
20181
!
 
20182
  if (mulocal2.gt.smax) smax = mulocal2
 
20183
!
 
20184
  if (nonzerothrs) then
 
20185
    hh = onshellthrs
 
20186
    do ii=1,3
 
20187
      if (ap(ii).lt.hh) ap(ii) = 0
 
20188
      if (am(ii).lt.hh) am(ii) = 0
 
20189
    enddo
 
20190
  else
 
20191
    hh = onshellthrs*smax
 
20192
    if (wunit.gt.0) then
 
20193
    do ii=1,3
 
20194
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
20195
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
20196
    enddo
 
20197
    endif
 
20198
  endif
 
20199
!
 
20200
  icase = 0
 
20201
  do ii=1,3
 
20202
    if (am(ii).gt.RZRO) icase = icase + base(ii)
 
20203
  enddo
 
20204
  ss(1)=pp(permtable(1,icase)) ;as(1)=ap(permtable(1,icase))
 
20205
  ss(2)=pp(permtable(2,icase)) ;as(2)=ap(permtable(2,icase))
 
20206
  ss(3)=pp(permtable(3,icase)) ;as(3)=ap(permtable(3,icase))
 
20207
  rr(1)=mm(permtable(1,icase)) ;ar(1)=am(permtable(1,icase))
 
20208
  rr(2)=mm(permtable(2,icase)) ;ar(2)=am(permtable(2,icase))
 
20209
  rr(3)=mm(permtable(3,icase)) ;ar(3)=am(permtable(3,icase))
 
20210
  icase = casetable(icase)
 
20211
!
 
20212
  s1r2 = abs(ss(1)-rr(2))
 
20213
  s2r3 = abs(ss(2)-rr(3))
 
20214
  s3r3 = abs(ss(3)-rr(3))
 
20215
  if (nonzerothrs) then
 
20216
    if (s1r2.lt.hh) s1r2 = 0
 
20217
    if (s2r3.lt.hh) s2r3 = 0
 
20218
    if (s3r3.lt.hh) s3r3 = 0
 
20219
  elseif (wunit.gt.0) then
 
20220
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
20221
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
20222
    if (RZRO.lt.s3r3.and.s3r3.lt.hh) write(wunit,*) warning
 
20223
  endif
 
20224
!
 
20225
  if     (icase.eq.3) then
 
20226
! 3 non-zero internal masses
 
20227
    lambda = kallen( ss(1),ss(2),ss(3) )
 
20228
    if (areal(lambda).lt.RZRO) then
 
20229
      call trif3HV( rslt ,ss,rr ,as ,smax ,lambda )
 
20230
    else
 
20231
      call trif3( rslt ,ss(1),ss(2),ss(3) ,rr(1),rr(2),rr(3) )
 
20232
    endif
 
20233
  elseif (icase.eq.2) then
 
20234
! 2 non-zero internal masses
 
20235
    if (s1r2.ne.RZRO.or.s3r3.ne.RZRO) then
 
20236
      call trif2( rslt ,ss(1),ss(2),ss(3) ,rr(2),rr(3) )
 
20237
    else
 
20238
      call tria4( rslt ,ss(2) ,rr(2),rr(3) ,mulocal2 )
 
20239
    endif
 
20240
  elseif (icase.eq.1) then
 
20241
! 1 non-zero internal mass
 
20242
    if     (as(1).ne.RZRO) then
 
20243
      call trif1( rslt ,ss(1),ss(2),ss(3), rr(3) )
 
20244
    elseif (s2r3.ne.RZRO) then
 
20245
      if   (s3r3.ne.RZRO) then
 
20246
        call tria3( rslt ,ss(2),ss(3) ,rr(3) ,mulocal2 )
 
20247
      else
 
20248
        call tria2( rslt ,ss(2) ,rr(3) ,mulocal2 )
 
20249
      endif
 
20250
    elseif (s3r3.ne.RZRO) then
 
20251
      call tria2( rslt ,ss(3) ,rr(3) ,mulocal2 )
 
20252
    else
 
20253
      call tria1( rslt ,rr(3) ,mulocal2 )
 
20254
    endif
 
20255
  else
 
20256
! 0 non-zero internal masses
 
20257
    call tria0( rslt ,ss ,as ,mulocal2 )
 
20258
  endif
 
20259
! exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
20260
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
20261
!
 
20262
  if (punit.gt.0) then
 
20263
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
20264
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
20265
    write(punit,*) ' p1:',trim(myprint(p1))
 
20266
    write(punit,*) ' p2:',trim(myprint(p2))
 
20267
    write(punit,*) ' p3:',trim(myprint(p3))
 
20268
    write(punit,*) ' m1:',trim(myprint(m1))
 
20269
    write(punit,*) ' m2:',trim(myprint(m2))
 
20270
    write(punit,*) ' m3:',trim(myprint(m3))
 
20271
    write(punit,*) 'c0(2):',trim(myprint(rslt(2)))
 
20272
    write(punit,*) 'c0(1):',trim(myprint(rslt(1)))
 
20273
    write(punit,*) 'c0(0):',trim(myprint(rslt(0)))
 
20274
  endif
 
20275
  end subroutine
 
20276
 
 
20277
 
 
20278
!*******************************************************************
 
20279
! calculates
 
20280
!
 
20281
!    C   /                      d^(Dim)q
 
20282
! ------ | --------------------------------------------------------
 
20283
! i*pi^2 / [q^2-m1][(q+k1)^2-m2][(q+k1+k2)^2-m3][(q+k1+k2+k3)^2-m4]
 
20284
!
 
20285
! with  Dim = 4-2*eps
 
20286
!         C = pi^eps * mu^(2*eps)
 
20287
!             * GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
20288
!
 
20289
! input:  p1=k1^2, p2=k2^2, p3=k3^2, p4=(k1+k2+k3)^2, 
 
20290
!         p12=(k1+k2)^2, p23=(k2+k3)^2, 
 
20291
!         m1,m2,m3,m4=squared masses
 
20292
! output: rslt(0) = eps^0   -coefficient
 
20293
!         rslt(1) = eps^(-1)-coefficient
 
20294
!         rslt(2) = eps^(-2)-coefficient
 
20295
!
 
20296
! Check the comments in  avh_olo_qp_onshell  to find out how this
 
20297
! routines decides when to return IR-divergent cases.
 
20298
!*******************************************************************
 
20299
 
 
20300
  subroutine d0cc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
20301
  use avh_olo_qp_box
 
20302
  use avh_olo_qp_boxc
 
20303
!
 
20304
  complex(kindr2) &   
 
20305
    ,intent(out) :: rslt(0:2)
 
20306
  complex(kindr2) &   
 
20307
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
20308
  complex(kindr2) &   
 
20309
    ,intent(in)  :: m1,m2,m3,m4
 
20310
!
 
20311
  complex(kindr2) &   
 
20312
    :: pp(6)
 
20313
  complex(kindr2) &   
 
20314
    :: mm(4)
 
20315
  complex(kindr2) &   
 
20316
    :: ss(6),rr(4)
 
20317
  real(kindr2) &  
 
20318
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
20319
  real(kindr2) &  
 
20320
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
20321
  integer :: icase,ii,jj
 
20322
  logical :: useboxc
 
20323
  integer ,parameter :: lp(6,3)=&
 
20324
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
20325
  integer ,parameter :: lm(4,3)=&
 
20326
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
20327
  character(25+99) ,parameter :: warning=&
 
20328
                 'WARNING from OneLOop d0: '//warnonshell
 
20329
  if (initz) call init
 
20330
  pp(1) = p1
 
20331
  pp(2) = p2
 
20332
  pp(3) = p3
 
20333
  pp(4) = p4
 
20334
  pp(5) = p12
 
20335
  pp(6) = p23
 
20336
  mm(1) = m1
 
20337
  mm(2) = m2
 
20338
  mm(3) = m3
 
20339
  mm(4) = m4
 
20340
  smax = 0
 
20341
!
 
20342
  do ii=1,6
 
20343
    ap(ii) = areal(pp(ii))
 
20344
    if (aimag(pp(ii)).ne.RZRO) then
 
20345
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20346
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
20347
      pp(ii) = acmplx( ap(ii) ,0 )
 
20348
    endif
 
20349
    ap(ii) = abs(ap(ii))
 
20350
    if (ap(ii).gt.smax) smax = ap(ii)
 
20351
  enddo
 
20352
!
 
20353
  do ii=1,4
 
20354
    am(ii) = areal(mm(ii))
 
20355
    hh = aimag(mm(ii))
 
20356
    if (hh.gt.RZRO) then
 
20357
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20358
        ,'mass-squared has positive imaginary part, switching its sign.'
 
20359
      mm(ii) = acmplx( am(ii) ,-hh )
 
20360
    endif
 
20361
    am(ii) = abs(am(ii)) + abs(hh)
 
20362
    if (am(ii).gt.smax) smax = am(ii)
 
20363
  enddo
 
20364
!
 
20365
  small = 0
 
20366
  do ii=1,6
 
20367
    hh = abs(ap(ii))
 
20368
    if (hh.gt.small) small=hh
 
20369
  enddo
 
20370
  small = small*neglig(prcpar)
 
20371
!
 
20372
  mulocal = muscale 
 
20373
!
 
20374
  mulocal2 = mulocal*mulocal
 
20375
!
 
20376
  if (smax.eq.RZRO) then
 
20377
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20378
      ,'all input equal zero, returning 0'
 
20379
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
20380
    return
 
20381
  endif
 
20382
!
 
20383
  if (mulocal2.gt.smax) smax = mulocal2
 
20384
!
 
20385
  if (nonzerothrs) then
 
20386
    hh = onshellthrs
 
20387
    do ii=1,4
 
20388
      if (ap(ii).lt.hh) ap(ii) = 0
 
20389
      if (am(ii).lt.hh) am(ii) = 0
 
20390
    enddo
 
20391
  else
 
20392
    hh = onshellthrs*smax
 
20393
    if (wunit.gt.0) then
 
20394
    do ii=1,4
 
20395
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
20396
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
20397
    enddo
 
20398
    endif
 
20399
  endif
 
20400
!
 
20401
  jj = 1
 
20402
  min56 = min(ap(5),ap(6))
 
20403
  if (min56.lt.hh) then
 
20404
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20405
      ,'input does not seem to represent hard kinematics, '&
 
20406
      ,'trying to permutate'
 
20407
    min13=min(ap(1),ap(3))
 
20408
    min24=min(ap(2),ap(4))
 
20409
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
20410
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
20411
    else
 
20412
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20413
        ,'no permutation helps, errors might follow'
 
20414
    endif
 
20415
  endif
 
20416
!
 
20417
  icase = 0
 
20418
  do ii=1,4
 
20419
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
20420
  enddo
 
20421
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
20422
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
20423
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
20424
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
20425
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
20426
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
20427
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
20428
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
20429
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
20430
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
20431
  icase = casetable(icase)
 
20432
!
 
20433
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
20434
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
20435
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
20436
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
20437
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
20438
  if (nonzerothrs) then
 
20439
    if (s1r2.lt.hh) s1r2 = 0
 
20440
    if (s2r2.lt.hh) s2r2 = 0
 
20441
    if (s2r3.lt.hh) s2r3 = 0
 
20442
    if (s3r4.lt.hh) s3r4 = 0
 
20443
    if (s4r4.lt.hh) s4r4 = 0
 
20444
  elseif (wunit.gt.0) then
 
20445
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
20446
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
20447
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
20448
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
20449
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
20450
  endif
 
20451
!
 
20452
  if     (icase.eq.4) then
 
20453
!4 non-zero internal masses
 
20454
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
20455
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
20456
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
20457
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
20458
               .or.(     areal(ss(1)).ge.-small  &
 
20459
                    .and.areal(ss(2)).ge.-small  &
 
20460
                    .and.areal(ss(3)).ge.-small  &
 
20461
                    .and.areal(ss(4)).ge.-small) )
 
20462
    if (useboxc) then
 
20463
      call boxc( rslt ,ss,rr ,as ,smax )
 
20464
    else
 
20465
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
20466
    endif
 
20467
  elseif (icase.eq.3) then
 
20468
!3 non-zero internal masses
 
20469
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
20470
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
20471
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
20472
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
20473
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
20474
                 .or.(     areal(ss(1)).ge.-small  &
 
20475
                      .and.areal(ss(2)).ge.-small  &
 
20476
                      .and.areal(ss(3)).ge.-small  &
 
20477
                      .and.areal(ss(4)).ge.-small) )
 
20478
      if (useboxc) then
 
20479
        call boxc( rslt ,ss,rr ,as ,smax )
 
20480
      else
 
20481
        call boxf3( rslt, ss,rr )
 
20482
      endif
 
20483
    else
 
20484
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
20485
    endif
 
20486
  elseif (icase.eq.5) then
 
20487
!2 non-zero internal masses, opposite case
 
20488
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
20489
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
20490
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
20491
      else
 
20492
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20493
      endif
 
20494
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
20495
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20496
    else
 
20497
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20498
    endif
 
20499
  elseif (icase.eq.2) then
 
20500
!2 non-zero internal masses, adjacent case
 
20501
    if     (as(1).ne.RZRO) then
 
20502
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
20503
    elseif (s2r3.ne.RZRO) then
 
20504
      if     (s4r4.ne.RZRO) then
 
20505
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20506
      else
 
20507
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
20508
      endif
 
20509
    elseif (s4r4.ne.RZRO) then
 
20510
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20511
    else
 
20512
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20513
    endif
 
20514
  elseif (icase.eq.1) then
 
20515
!1 non-zero internal mass
 
20516
    if     (as(1).ne.RZRO) then
 
20517
      if      (as(2).ne.RZRO) then
 
20518
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
20519
      else
 
20520
        if     (s3r4.ne.RZRO) then
 
20521
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20522
        else
 
20523
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20524
        endif
 
20525
      endif
 
20526
    elseif (as(2).ne.RZRO) then
 
20527
      if      (s4r4.ne.RZRO) then
 
20528
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20529
      else
 
20530
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20531
      endif
 
20532
    else
 
20533
      if     (s3r4.ne.RZRO) then
 
20534
        if     (s4r4.ne.RZRO) then
 
20535
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20536
        else
 
20537
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20538
        endif
 
20539
      elseif (s4r4.ne.RZRO) then
 
20540
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20541
      else
 
20542
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
20543
      endif
 
20544
    endif
 
20545
  else
 
20546
!0 non-zero internal mass
 
20547
    call box00( rslt ,ss ,as ,mulocal )
 
20548
  endif
 
20549
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
20550
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
20551
!
 
20552
  if (punit.gt.0) then
 
20553
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
20554
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
20555
    write(punit,*) ' p1:',trim(myprint(p1))
 
20556
    write(punit,*) ' p2:',trim(myprint(p2))
 
20557
    write(punit,*) ' p3:',trim(myprint(p3))
 
20558
    write(punit,*) ' p4:',trim(myprint(p4))
 
20559
    write(punit,*) 'p12:',trim(myprint(p12))
 
20560
    write(punit,*) 'p23:',trim(myprint(p23))
 
20561
    write(punit,*) ' m1:',trim(myprint(m1))
 
20562
    write(punit,*) ' m2:',trim(myprint(m2))
 
20563
    write(punit,*) ' m3:',trim(myprint(m3))
 
20564
    write(punit,*) ' m4:',trim(myprint(m4))
 
20565
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
20566
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
20567
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
20568
  endif
 
20569
  end subroutine
 
20570
 
 
20571
  subroutine d0ccr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
20572
  use avh_olo_qp_box
 
20573
  use avh_olo_qp_boxc
 
20574
!
 
20575
  complex(kindr2) &   
 
20576
    ,intent(out) :: rslt(0:2)
 
20577
  complex(kindr2) &   
 
20578
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
20579
  complex(kindr2) &   
 
20580
    ,intent(in)  :: m1,m2,m3,m4
 
20581
  real(kindr2) &  
 
20582
    ,intent(in)  :: rmu      
 
20583
!
 
20584
  complex(kindr2) &   
 
20585
    :: pp(6)
 
20586
  complex(kindr2) &   
 
20587
    :: mm(4)
 
20588
  complex(kindr2) &   
 
20589
    :: ss(6),rr(4)
 
20590
  real(kindr2) &  
 
20591
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
20592
  real(kindr2) &  
 
20593
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
20594
  integer :: icase,ii,jj
 
20595
  logical :: useboxc
 
20596
  integer ,parameter :: lp(6,3)=&
 
20597
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
20598
  integer ,parameter :: lm(4,3)=&
 
20599
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
20600
  character(25+99) ,parameter :: warning=&
 
20601
                 'WARNING from OneLOop d0: '//warnonshell
 
20602
  if (initz) call init
 
20603
  pp(1) = p1
 
20604
  pp(2) = p2
 
20605
  pp(3) = p3
 
20606
  pp(4) = p4
 
20607
  pp(5) = p12
 
20608
  pp(6) = p23
 
20609
  mm(1) = m1
 
20610
  mm(2) = m2
 
20611
  mm(3) = m3
 
20612
  mm(4) = m4
 
20613
  smax = 0
 
20614
!
 
20615
  do ii=1,6
 
20616
    ap(ii) = areal(pp(ii))
 
20617
    if (aimag(pp(ii)).ne.RZRO) then
 
20618
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20619
        ,'momentum with non-zero imaginary part, putting it to zero.'
 
20620
      pp(ii) = acmplx( ap(ii) ,0 )
 
20621
    endif
 
20622
    ap(ii) = abs(ap(ii))
 
20623
    if (ap(ii).gt.smax) smax = ap(ii)
 
20624
  enddo
 
20625
!
 
20626
  do ii=1,4
 
20627
    am(ii) = areal(mm(ii))
 
20628
    hh = aimag(mm(ii))
 
20629
    if (hh.gt.RZRO) then
 
20630
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20631
        ,'mass-squared has positive imaginary part, switching its sign.'
 
20632
      mm(ii) = acmplx( am(ii) ,-hh )
 
20633
    endif
 
20634
    am(ii) = abs(am(ii)) + abs(hh)
 
20635
    if (am(ii).gt.smax) smax = am(ii)
 
20636
  enddo
 
20637
!
 
20638
  small = 0
 
20639
  do ii=1,6
 
20640
    hh = abs(ap(ii))
 
20641
    if (hh.gt.small) small=hh
 
20642
  enddo
 
20643
  small = small*neglig(prcpar)
 
20644
!
 
20645
  mulocal = rmu     
 
20646
!
 
20647
  mulocal2 = mulocal*mulocal
 
20648
!
 
20649
  if (smax.eq.RZRO) then
 
20650
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20651
      ,'all input equal zero, returning 0'
 
20652
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
20653
    return
 
20654
  endif
 
20655
!
 
20656
  if (mulocal2.gt.smax) smax = mulocal2
 
20657
!
 
20658
  if (nonzerothrs) then
 
20659
    hh = onshellthrs
 
20660
    do ii=1,4
 
20661
      if (ap(ii).lt.hh) ap(ii) = 0
 
20662
      if (am(ii).lt.hh) am(ii) = 0
 
20663
    enddo
 
20664
  else
 
20665
    hh = onshellthrs*smax
 
20666
    if (wunit.gt.0) then
 
20667
    do ii=1,4
 
20668
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
20669
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
20670
    enddo
 
20671
    endif
 
20672
  endif
 
20673
!
 
20674
  jj = 1
 
20675
  min56 = min(ap(5),ap(6))
 
20676
  if (min56.lt.hh) then
 
20677
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20678
      ,'input does not seem to represent hard kinematics, '&
 
20679
      ,'trying to permutate'
 
20680
    min13=min(ap(1),ap(3))
 
20681
    min24=min(ap(2),ap(4))
 
20682
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
20683
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
20684
    else
 
20685
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20686
        ,'no permutation helps, errors might follow'
 
20687
    endif
 
20688
  endif
 
20689
!
 
20690
  icase = 0
 
20691
  do ii=1,4
 
20692
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
20693
  enddo
 
20694
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
20695
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
20696
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
20697
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
20698
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
20699
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
20700
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
20701
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
20702
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
20703
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
20704
  icase = casetable(icase)
 
20705
!
 
20706
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
20707
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
20708
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
20709
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
20710
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
20711
  if (nonzerothrs) then
 
20712
    if (s1r2.lt.hh) s1r2 = 0
 
20713
    if (s2r2.lt.hh) s2r2 = 0
 
20714
    if (s2r3.lt.hh) s2r3 = 0
 
20715
    if (s3r4.lt.hh) s3r4 = 0
 
20716
    if (s4r4.lt.hh) s4r4 = 0
 
20717
  elseif (wunit.gt.0) then
 
20718
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
20719
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
20720
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
20721
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
20722
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
20723
  endif
 
20724
!
 
20725
  if     (icase.eq.4) then
 
20726
!4 non-zero internal masses
 
20727
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
20728
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
20729
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
20730
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
20731
               .or.(     areal(ss(1)).ge.-small  &
 
20732
                    .and.areal(ss(2)).ge.-small  &
 
20733
                    .and.areal(ss(3)).ge.-small  &
 
20734
                    .and.areal(ss(4)).ge.-small) )
 
20735
    if (useboxc) then
 
20736
      call boxc( rslt ,ss,rr ,as ,smax )
 
20737
    else
 
20738
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
20739
    endif
 
20740
  elseif (icase.eq.3) then
 
20741
!3 non-zero internal masses
 
20742
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
20743
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
20744
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
20745
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
20746
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
20747
                 .or.(     areal(ss(1)).ge.-small  &
 
20748
                      .and.areal(ss(2)).ge.-small  &
 
20749
                      .and.areal(ss(3)).ge.-small  &
 
20750
                      .and.areal(ss(4)).ge.-small) )
 
20751
      if (useboxc) then
 
20752
        call boxc( rslt ,ss,rr ,as ,smax )
 
20753
      else
 
20754
        call boxf3( rslt, ss,rr )
 
20755
      endif
 
20756
    else
 
20757
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
20758
    endif
 
20759
  elseif (icase.eq.5) then
 
20760
!2 non-zero internal masses, opposite case
 
20761
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
20762
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
20763
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
20764
      else
 
20765
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20766
      endif
 
20767
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
20768
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20769
    else
 
20770
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
20771
    endif
 
20772
  elseif (icase.eq.2) then
 
20773
!2 non-zero internal masses, adjacent case
 
20774
    if     (as(1).ne.RZRO) then
 
20775
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
20776
    elseif (s2r3.ne.RZRO) then
 
20777
      if     (s4r4.ne.RZRO) then
 
20778
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20779
      else
 
20780
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
20781
      endif
 
20782
    elseif (s4r4.ne.RZRO) then
 
20783
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20784
    else
 
20785
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
20786
    endif
 
20787
  elseif (icase.eq.1) then
 
20788
!1 non-zero internal mass
 
20789
    if     (as(1).ne.RZRO) then
 
20790
      if      (as(2).ne.RZRO) then
 
20791
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
20792
      else
 
20793
        if     (s3r4.ne.RZRO) then
 
20794
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20795
        else
 
20796
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20797
        endif
 
20798
      endif
 
20799
    elseif (as(2).ne.RZRO) then
 
20800
      if      (s4r4.ne.RZRO) then
 
20801
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20802
      else
 
20803
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20804
      endif
 
20805
    else
 
20806
      if     (s3r4.ne.RZRO) then
 
20807
        if     (s4r4.ne.RZRO) then
 
20808
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20809
        else
 
20810
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
20811
        endif
 
20812
      elseif (s4r4.ne.RZRO) then
 
20813
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
20814
      else
 
20815
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
20816
      endif
 
20817
    endif
 
20818
  else
 
20819
!0 non-zero internal mass
 
20820
    call box00( rslt ,ss ,as ,mulocal )
 
20821
  endif
 
20822
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
20823
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
20824
!
 
20825
  if (punit.gt.0) then
 
20826
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
20827
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
20828
    write(punit,*) ' p1:',trim(myprint(p1))
 
20829
    write(punit,*) ' p2:',trim(myprint(p2))
 
20830
    write(punit,*) ' p3:',trim(myprint(p3))
 
20831
    write(punit,*) ' p4:',trim(myprint(p4))
 
20832
    write(punit,*) 'p12:',trim(myprint(p12))
 
20833
    write(punit,*) 'p23:',trim(myprint(p23))
 
20834
    write(punit,*) ' m1:',trim(myprint(m1))
 
20835
    write(punit,*) ' m2:',trim(myprint(m2))
 
20836
    write(punit,*) ' m3:',trim(myprint(m3))
 
20837
    write(punit,*) ' m4:',trim(myprint(m4))
 
20838
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
20839
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
20840
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
20841
  endif
 
20842
  end subroutine
 
20843
 
 
20844
  subroutine d0rc( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
20845
  use avh_olo_qp_box
 
20846
  use avh_olo_qp_boxc
 
20847
!
 
20848
  complex(kindr2) &   
 
20849
    ,intent(out) :: rslt(0:2)
 
20850
  real(kindr2) &  
 
20851
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
20852
  complex(kindr2) &   
 
20853
    ,intent(in)  :: m1,m2,m3,m4
 
20854
!
 
20855
  real(kindr2) &  
 
20856
    :: pp(6)
 
20857
  complex(kindr2) &   
 
20858
    :: mm(4)
 
20859
  complex(kindr2) &   
 
20860
    :: ss(6),rr(4)
 
20861
  real(kindr2) &  
 
20862
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
20863
  real(kindr2) &  
 
20864
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
20865
  integer :: icase,ii,jj
 
20866
  logical :: useboxc
 
20867
  integer ,parameter :: lp(6,3)=&
 
20868
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
20869
  integer ,parameter :: lm(4,3)=&
 
20870
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
20871
  character(25+99) ,parameter :: warning=&
 
20872
                 'WARNING from OneLOop d0: '//warnonshell
 
20873
  if (initz) call init
 
20874
  pp(1) = p1
 
20875
  pp(2) = p2
 
20876
  pp(3) = p3
 
20877
  pp(4) = p4
 
20878
  pp(5) = p12
 
20879
  pp(6) = p23
 
20880
  mm(1) = m1
 
20881
  mm(2) = m2
 
20882
  mm(3) = m3
 
20883
  mm(4) = m4
 
20884
  smax = 0
 
20885
!
 
20886
  do ii=1,6
 
20887
    ap(ii) = abs(pp(ii))
 
20888
    if (ap(ii).gt.smax) smax = ap(ii)
 
20889
  enddo
 
20890
!
 
20891
  do ii=1,4
 
20892
    am(ii) = areal(mm(ii))
 
20893
    hh = aimag(mm(ii))
 
20894
    if (hh.gt.RZRO) then
 
20895
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20896
        ,'mass-squared has positive imaginary part, switching its sign.'
 
20897
      mm(ii) = acmplx( am(ii) ,-hh )
 
20898
    endif
 
20899
    am(ii) = abs(am(ii)) + abs(hh)
 
20900
    if (am(ii).gt.smax) smax = am(ii)
 
20901
  enddo
 
20902
!
 
20903
  small = 0
 
20904
  do ii=1,6
 
20905
    hh = abs(ap(ii))
 
20906
    if (hh.gt.small) small=hh
 
20907
  enddo
 
20908
  small = small*neglig(prcpar)
 
20909
!
 
20910
  mulocal = muscale 
 
20911
!
 
20912
  mulocal2 = mulocal*mulocal
 
20913
!
 
20914
  if (smax.eq.RZRO) then
 
20915
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
20916
      ,'all input equal zero, returning 0'
 
20917
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
20918
    return
 
20919
  endif
 
20920
!
 
20921
  if (mulocal2.gt.smax) smax = mulocal2
 
20922
!
 
20923
  if (nonzerothrs) then
 
20924
    hh = onshellthrs
 
20925
    do ii=1,4
 
20926
      if (ap(ii).lt.hh) ap(ii) = 0
 
20927
      if (am(ii).lt.hh) am(ii) = 0
 
20928
    enddo
 
20929
  else
 
20930
    hh = onshellthrs*smax
 
20931
    if (wunit.gt.0) then
 
20932
    do ii=1,4
 
20933
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
20934
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
20935
    enddo
 
20936
    endif
 
20937
  endif
 
20938
!
 
20939
  jj = 1
 
20940
  min56 = min(ap(5),ap(6))
 
20941
  if (min56.lt.hh) then
 
20942
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20943
      ,'input does not seem to represent hard kinematics, '&
 
20944
      ,'trying to permutate'
 
20945
    min13=min(ap(1),ap(3))
 
20946
    min24=min(ap(2),ap(4))
 
20947
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
20948
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
20949
    else
 
20950
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
20951
        ,'no permutation helps, errors might follow'
 
20952
    endif
 
20953
  endif
 
20954
!
 
20955
  icase = 0
 
20956
  do ii=1,4
 
20957
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
20958
  enddo
 
20959
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
20960
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
20961
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
20962
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
20963
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
20964
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
20965
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
20966
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
20967
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
20968
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
20969
  icase = casetable(icase)
 
20970
!
 
20971
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
20972
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
20973
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
20974
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
20975
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
20976
  if (nonzerothrs) then
 
20977
    if (s1r2.lt.hh) s1r2 = 0
 
20978
    if (s2r2.lt.hh) s2r2 = 0
 
20979
    if (s2r3.lt.hh) s2r3 = 0
 
20980
    if (s3r4.lt.hh) s3r4 = 0
 
20981
    if (s4r4.lt.hh) s4r4 = 0
 
20982
  elseif (wunit.gt.0) then
 
20983
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
20984
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
20985
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
20986
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
20987
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
20988
  endif
 
20989
!
 
20990
  if     (icase.eq.4) then
 
20991
!4 non-zero internal masses
 
20992
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
20993
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
20994
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
20995
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
20996
               .or.(     areal(ss(1)).ge.-small  &
 
20997
                    .and.areal(ss(2)).ge.-small  &
 
20998
                    .and.areal(ss(3)).ge.-small  &
 
20999
                    .and.areal(ss(4)).ge.-small) )
 
21000
    if (useboxc) then
 
21001
      call boxc( rslt ,ss,rr ,as ,smax )
 
21002
    else
 
21003
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
21004
    endif
 
21005
  elseif (icase.eq.3) then
 
21006
!3 non-zero internal masses
 
21007
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21008
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
21009
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
21010
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
21011
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
21012
                 .or.(     areal(ss(1)).ge.-small  &
 
21013
                      .and.areal(ss(2)).ge.-small  &
 
21014
                      .and.areal(ss(3)).ge.-small  &
 
21015
                      .and.areal(ss(4)).ge.-small) )
 
21016
      if (useboxc) then
 
21017
        call boxc( rslt ,ss,rr ,as ,smax )
 
21018
      else
 
21019
        call boxf3( rslt, ss,rr )
 
21020
      endif
 
21021
    else
 
21022
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
21023
    endif
 
21024
  elseif (icase.eq.5) then
 
21025
!2 non-zero internal masses, opposite case
 
21026
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21027
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21028
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
21029
      else
 
21030
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21031
      endif
 
21032
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21033
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21034
    else
 
21035
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21036
    endif
 
21037
  elseif (icase.eq.2) then
 
21038
!2 non-zero internal masses, adjacent case
 
21039
    if     (as(1).ne.RZRO) then
 
21040
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
21041
    elseif (s2r3.ne.RZRO) then
 
21042
      if     (s4r4.ne.RZRO) then
 
21043
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21044
      else
 
21045
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
21046
      endif
 
21047
    elseif (s4r4.ne.RZRO) then
 
21048
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21049
    else
 
21050
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21051
    endif
 
21052
  elseif (icase.eq.1) then
 
21053
!1 non-zero internal mass
 
21054
    if     (as(1).ne.RZRO) then
 
21055
      if      (as(2).ne.RZRO) then
 
21056
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
21057
      else
 
21058
        if     (s3r4.ne.RZRO) then
 
21059
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21060
        else
 
21061
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21062
        endif
 
21063
      endif
 
21064
    elseif (as(2).ne.RZRO) then
 
21065
      if      (s4r4.ne.RZRO) then
 
21066
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21067
      else
 
21068
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21069
      endif
 
21070
    else
 
21071
      if     (s3r4.ne.RZRO) then
 
21072
        if     (s4r4.ne.RZRO) then
 
21073
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21074
        else
 
21075
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21076
        endif
 
21077
      elseif (s4r4.ne.RZRO) then
 
21078
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21079
      else
 
21080
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
21081
      endif
 
21082
    endif
 
21083
  else
 
21084
!0 non-zero internal mass
 
21085
    call box00( rslt ,ss ,as ,mulocal )
 
21086
  endif
 
21087
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
21088
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
21089
!
 
21090
  if (punit.gt.0) then
 
21091
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
21092
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
21093
    write(punit,*) ' p1:',trim(myprint(p1))
 
21094
    write(punit,*) ' p2:',trim(myprint(p2))
 
21095
    write(punit,*) ' p3:',trim(myprint(p3))
 
21096
    write(punit,*) ' p4:',trim(myprint(p4))
 
21097
    write(punit,*) 'p12:',trim(myprint(p12))
 
21098
    write(punit,*) 'p23:',trim(myprint(p23))
 
21099
    write(punit,*) ' m1:',trim(myprint(m1))
 
21100
    write(punit,*) ' m2:',trim(myprint(m2))
 
21101
    write(punit,*) ' m3:',trim(myprint(m3))
 
21102
    write(punit,*) ' m4:',trim(myprint(m4))
 
21103
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
21104
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
21105
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
21106
  endif
 
21107
  end subroutine
 
21108
 
 
21109
  subroutine d0rcr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
21110
  use avh_olo_qp_box
 
21111
  use avh_olo_qp_boxc
 
21112
!
 
21113
  complex(kindr2) &   
 
21114
    ,intent(out) :: rslt(0:2)
 
21115
  real(kindr2) &  
 
21116
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
21117
  complex(kindr2) &   
 
21118
    ,intent(in)  :: m1,m2,m3,m4
 
21119
  real(kindr2) &  
 
21120
    ,intent(in)  :: rmu      
 
21121
!
 
21122
  real(kindr2) &  
 
21123
    :: pp(6)
 
21124
  complex(kindr2) &   
 
21125
    :: mm(4)
 
21126
  complex(kindr2) &   
 
21127
    :: ss(6),rr(4)
 
21128
  real(kindr2) &  
 
21129
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
21130
  real(kindr2) &  
 
21131
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
21132
  integer :: icase,ii,jj
 
21133
  logical :: useboxc
 
21134
  integer ,parameter :: lp(6,3)=&
 
21135
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
21136
  integer ,parameter :: lm(4,3)=&
 
21137
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
21138
  character(25+99) ,parameter :: warning=&
 
21139
                 'WARNING from OneLOop d0: '//warnonshell
 
21140
  if (initz) call init
 
21141
  pp(1) = p1
 
21142
  pp(2) = p2
 
21143
  pp(3) = p3
 
21144
  pp(4) = p4
 
21145
  pp(5) = p12
 
21146
  pp(6) = p23
 
21147
  mm(1) = m1
 
21148
  mm(2) = m2
 
21149
  mm(3) = m3
 
21150
  mm(4) = m4
 
21151
  smax = 0
 
21152
!
 
21153
  do ii=1,6
 
21154
    ap(ii) = abs(pp(ii))
 
21155
    if (ap(ii).gt.smax) smax = ap(ii)
 
21156
  enddo
 
21157
!
 
21158
  do ii=1,4
 
21159
    am(ii) = areal(mm(ii))
 
21160
    hh = aimag(mm(ii))
 
21161
    if (hh.gt.RZRO) then
 
21162
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
21163
        ,'mass-squared has positive imaginary part, switching its sign.'
 
21164
      mm(ii) = acmplx( am(ii) ,-hh )
 
21165
    endif
 
21166
    am(ii) = abs(am(ii)) + abs(hh)
 
21167
    if (am(ii).gt.smax) smax = am(ii)
 
21168
  enddo
 
21169
!
 
21170
  small = 0
 
21171
  do ii=1,6
 
21172
    hh = abs(ap(ii))
 
21173
    if (hh.gt.small) small=hh
 
21174
  enddo
 
21175
  small = small*neglig(prcpar)
 
21176
!
 
21177
  mulocal = rmu     
 
21178
!
 
21179
  mulocal2 = mulocal*mulocal
 
21180
!
 
21181
  if (smax.eq.RZRO) then
 
21182
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
21183
      ,'all input equal zero, returning 0'
 
21184
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
21185
    return
 
21186
  endif
 
21187
!
 
21188
  if (mulocal2.gt.smax) smax = mulocal2
 
21189
!
 
21190
  if (nonzerothrs) then
 
21191
    hh = onshellthrs
 
21192
    do ii=1,4
 
21193
      if (ap(ii).lt.hh) ap(ii) = 0
 
21194
      if (am(ii).lt.hh) am(ii) = 0
 
21195
    enddo
 
21196
  else
 
21197
    hh = onshellthrs*smax
 
21198
    if (wunit.gt.0) then
 
21199
    do ii=1,4
 
21200
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
21201
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
21202
    enddo
 
21203
    endif
 
21204
  endif
 
21205
!
 
21206
  jj = 1
 
21207
  min56 = min(ap(5),ap(6))
 
21208
  if (min56.lt.hh) then
 
21209
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
21210
      ,'input does not seem to represent hard kinematics, '&
 
21211
      ,'trying to permutate'
 
21212
    min13=min(ap(1),ap(3))
 
21213
    min24=min(ap(2),ap(4))
 
21214
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
21215
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
21216
    else
 
21217
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
21218
        ,'no permutation helps, errors might follow'
 
21219
    endif
 
21220
  endif
 
21221
!
 
21222
  icase = 0
 
21223
  do ii=1,4
 
21224
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
21225
  enddo
 
21226
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
21227
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
21228
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
21229
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
21230
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
21231
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
21232
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
21233
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
21234
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
21235
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
21236
  icase = casetable(icase)
 
21237
!
 
21238
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
21239
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
21240
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
21241
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
21242
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
21243
  if (nonzerothrs) then
 
21244
    if (s1r2.lt.hh) s1r2 = 0
 
21245
    if (s2r2.lt.hh) s2r2 = 0
 
21246
    if (s2r3.lt.hh) s2r3 = 0
 
21247
    if (s3r4.lt.hh) s3r4 = 0
 
21248
    if (s4r4.lt.hh) s4r4 = 0
 
21249
  elseif (wunit.gt.0) then
 
21250
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
21251
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
21252
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
21253
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
21254
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
21255
  endif
 
21256
!
 
21257
  if     (icase.eq.4) then
 
21258
!4 non-zero internal masses
 
21259
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
21260
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
21261
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
21262
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
21263
               .or.(     areal(ss(1)).ge.-small  &
 
21264
                    .and.areal(ss(2)).ge.-small  &
 
21265
                    .and.areal(ss(3)).ge.-small  &
 
21266
                    .and.areal(ss(4)).ge.-small) )
 
21267
    if (useboxc) then
 
21268
      call boxc( rslt ,ss,rr ,as ,smax )
 
21269
    else
 
21270
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
21271
    endif
 
21272
  elseif (icase.eq.3) then
 
21273
!3 non-zero internal masses
 
21274
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21275
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
21276
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
21277
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
21278
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
21279
                 .or.(     areal(ss(1)).ge.-small  &
 
21280
                      .and.areal(ss(2)).ge.-small  &
 
21281
                      .and.areal(ss(3)).ge.-small  &
 
21282
                      .and.areal(ss(4)).ge.-small) )
 
21283
      if (useboxc) then
 
21284
        call boxc( rslt ,ss,rr ,as ,smax )
 
21285
      else
 
21286
        call boxf3( rslt, ss,rr )
 
21287
      endif
 
21288
    else
 
21289
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
21290
    endif
 
21291
  elseif (icase.eq.5) then
 
21292
!2 non-zero internal masses, opposite case
 
21293
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21294
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21295
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
21296
      else
 
21297
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21298
      endif
 
21299
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21300
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21301
    else
 
21302
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21303
    endif
 
21304
  elseif (icase.eq.2) then
 
21305
!2 non-zero internal masses, adjacent case
 
21306
    if     (as(1).ne.RZRO) then
 
21307
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
21308
    elseif (s2r3.ne.RZRO) then
 
21309
      if     (s4r4.ne.RZRO) then
 
21310
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21311
      else
 
21312
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
21313
      endif
 
21314
    elseif (s4r4.ne.RZRO) then
 
21315
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21316
    else
 
21317
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21318
    endif
 
21319
  elseif (icase.eq.1) then
 
21320
!1 non-zero internal mass
 
21321
    if     (as(1).ne.RZRO) then
 
21322
      if      (as(2).ne.RZRO) then
 
21323
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
21324
      else
 
21325
        if     (s3r4.ne.RZRO) then
 
21326
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21327
        else
 
21328
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21329
        endif
 
21330
      endif
 
21331
    elseif (as(2).ne.RZRO) then
 
21332
      if      (s4r4.ne.RZRO) then
 
21333
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21334
      else
 
21335
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21336
      endif
 
21337
    else
 
21338
      if     (s3r4.ne.RZRO) then
 
21339
        if     (s4r4.ne.RZRO) then
 
21340
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21341
        else
 
21342
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21343
        endif
 
21344
      elseif (s4r4.ne.RZRO) then
 
21345
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21346
      else
 
21347
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
21348
      endif
 
21349
    endif
 
21350
  else
 
21351
!0 non-zero internal mass
 
21352
    call box00( rslt ,ss ,as ,mulocal )
 
21353
  endif
 
21354
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
21355
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
21356
!
 
21357
  if (punit.gt.0) then
 
21358
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
21359
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
21360
    write(punit,*) ' p1:',trim(myprint(p1))
 
21361
    write(punit,*) ' p2:',trim(myprint(p2))
 
21362
    write(punit,*) ' p3:',trim(myprint(p3))
 
21363
    write(punit,*) ' p4:',trim(myprint(p4))
 
21364
    write(punit,*) 'p12:',trim(myprint(p12))
 
21365
    write(punit,*) 'p23:',trim(myprint(p23))
 
21366
    write(punit,*) ' m1:',trim(myprint(m1))
 
21367
    write(punit,*) ' m2:',trim(myprint(m2))
 
21368
    write(punit,*) ' m3:',trim(myprint(m3))
 
21369
    write(punit,*) ' m4:',trim(myprint(m4))
 
21370
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
21371
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
21372
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
21373
  endif
 
21374
  end subroutine
 
21375
 
 
21376
  subroutine d0rr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 )
 
21377
  use avh_olo_qp_box
 
21378
  use avh_olo_qp_boxc
 
21379
!
 
21380
  complex(kindr2) &   
 
21381
    ,intent(out) :: rslt(0:2)
 
21382
  real(kindr2) &  
 
21383
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
21384
  real(kindr2) &  
 
21385
    ,intent(in)  :: m1,m2,m3,m4
 
21386
!
 
21387
  real(kindr2) &  
 
21388
    :: pp(6)
 
21389
  real(kindr2) &  
 
21390
    :: mm(4)
 
21391
  complex(kindr2) &   
 
21392
    :: ss(6),rr(4)
 
21393
  real(kindr2) &  
 
21394
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
21395
  real(kindr2) &  
 
21396
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
21397
  integer :: icase,ii,jj
 
21398
  logical :: useboxc
 
21399
  integer ,parameter :: lp(6,3)=&
 
21400
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
21401
  integer ,parameter :: lm(4,3)=&
 
21402
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
21403
  character(25+99) ,parameter :: warning=&
 
21404
                 'WARNING from OneLOop d0: '//warnonshell
 
21405
  if (initz) call init
 
21406
  pp(1) = p1
 
21407
  pp(2) = p2
 
21408
  pp(3) = p3
 
21409
  pp(4) = p4
 
21410
  pp(5) = p12
 
21411
  pp(6) = p23
 
21412
  mm(1) = m1
 
21413
  mm(2) = m2
 
21414
  mm(3) = m3
 
21415
  mm(4) = m4
 
21416
  smax = 0
 
21417
!
 
21418
  do ii=1,6
 
21419
    ap(ii) = abs(pp(ii))
 
21420
    if (ap(ii).gt.smax) smax = ap(ii)
 
21421
  enddo
 
21422
!
 
21423
  do ii=1,4
 
21424
    am(ii) = abs(mm(ii))
 
21425
    if (am(ii).gt.smax) smax = am(ii)
 
21426
  enddo
 
21427
!
 
21428
  small = 0
 
21429
  do ii=1,6
 
21430
    hh = abs(ap(ii))
 
21431
    if (hh.gt.small) small=hh
 
21432
  enddo
 
21433
  small = small*neglig(prcpar)
 
21434
!
 
21435
  mulocal = muscale 
 
21436
!
 
21437
  mulocal2 = mulocal*mulocal
 
21438
!
 
21439
  if (smax.eq.RZRO) then
 
21440
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop d0: ' &
 
21441
      ,'all input equal zero, returning 0'
 
21442
    rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
 
21443
    return
 
21444
  endif
 
21445
!
 
21446
  if (mulocal2.gt.smax) smax = mulocal2
 
21447
!
 
21448
  if (nonzerothrs) then
 
21449
    hh = onshellthrs
 
21450
    do ii=1,4
 
21451
      if (ap(ii).lt.hh) ap(ii) = 0
 
21452
      if (am(ii).lt.hh) am(ii) = 0
 
21453
    enddo
 
21454
  else
 
21455
    hh = onshellthrs*smax
 
21456
    if (wunit.gt.0) then
 
21457
    do ii=1,4
 
21458
      if (RZRO.lt.ap(ii).and.ap(ii).lt.hh) write(wunit,*) warning
 
21459
      if (RZRO.lt.am(ii).and.am(ii).lt.hh) write(wunit,*) warning
 
21460
    enddo
 
21461
    endif
 
21462
  endif
 
21463
!
 
21464
  jj = 1
 
21465
  min56 = min(ap(5),ap(6))
 
21466
  if (min56.lt.hh) then
 
21467
    if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
21468
      ,'input does not seem to represent hard kinematics, '&
 
21469
      ,'trying to permutate'
 
21470
    min13=min(ap(1),ap(3))
 
21471
    min24=min(ap(2),ap(4))
 
21472
    if     (min13.gt.min24.and.min13.gt.min56) then ;jj=2
 
21473
    elseif (min24.gt.min13.and.min24.gt.min56) then ;jj=3
 
21474
    else
 
21475
      if (wunit.gt.0) write(wunit,*) 'WARNING from OneLOop d0: ' &
 
21476
        ,'no permutation helps, errors might follow'
 
21477
    endif
 
21478
  endif
 
21479
!
 
21480
  icase = 0
 
21481
  do ii=1,4
 
21482
    if (am(lm(ii,jj)).gt.RZRO) icase = icase + base(ii)
 
21483
  enddo
 
21484
  ss(1)=pp(lp(permtable(1,icase),jj)) ;as(1)=ap(lp(permtable(1,icase),jj))
 
21485
  ss(2)=pp(lp(permtable(2,icase),jj)) ;as(2)=ap(lp(permtable(2,icase),jj))
 
21486
  ss(3)=pp(lp(permtable(3,icase),jj)) ;as(3)=ap(lp(permtable(3,icase),jj))
 
21487
  ss(4)=pp(lp(permtable(4,icase),jj)) ;as(4)=ap(lp(permtable(4,icase),jj))
 
21488
  ss(5)=pp(lp(permtable(5,icase),jj)) ;as(5)=ap(lp(permtable(5,icase),jj))
 
21489
  ss(6)=pp(lp(permtable(6,icase),jj)) ;as(6)=ap(lp(permtable(6,icase),jj))
 
21490
  rr(1)=mm(lm(permtable(1,icase),jj)) ;ar(1)=am(lm(permtable(1,icase),jj))
 
21491
  rr(2)=mm(lm(permtable(2,icase),jj)) ;ar(2)=am(lm(permtable(2,icase),jj))
 
21492
  rr(3)=mm(lm(permtable(3,icase),jj)) ;ar(3)=am(lm(permtable(3,icase),jj))
 
21493
  rr(4)=mm(lm(permtable(4,icase),jj)) ;ar(4)=am(lm(permtable(4,icase),jj))
 
21494
  icase = casetable(icase)
 
21495
!
 
21496
  s1r2 = abs(areal(ss(1)-rr(2))) + abs(aimag(ss(1)-rr(2)))
 
21497
  s2r2 = abs(areal(ss(2)-rr(2))) + abs(aimag(ss(2)-rr(2)))
 
21498
  s2r3 = abs(areal(ss(2)-rr(3))) + abs(aimag(ss(2)-rr(3)))
 
21499
  s3r4 = abs(areal(ss(3)-rr(4))) + abs(aimag(ss(3)-rr(4)))
 
21500
  s4r4 = abs(areal(ss(4)-rr(4))) + abs(aimag(ss(4)-rr(4)))
 
21501
  if (nonzerothrs) then
 
21502
    if (s1r2.lt.hh) s1r2 = 0
 
21503
    if (s2r2.lt.hh) s2r2 = 0
 
21504
    if (s2r3.lt.hh) s2r3 = 0
 
21505
    if (s3r4.lt.hh) s3r4 = 0
 
21506
    if (s4r4.lt.hh) s4r4 = 0
 
21507
  elseif (wunit.gt.0) then
 
21508
    if (RZRO.lt.s1r2.and.s1r2.lt.hh) write(wunit,*) warning
 
21509
    if (RZRO.lt.s2r2.and.s2r2.lt.hh) write(wunit,*) warning
 
21510
    if (RZRO.lt.s2r3.and.s2r3.lt.hh) write(wunit,*) warning
 
21511
    if (RZRO.lt.s3r4.and.s3r4.lt.hh) write(wunit,*) warning
 
21512
    if (RZRO.lt.s4r4.and.s4r4.lt.hh) write(wunit,*) warning
 
21513
  endif
 
21514
!
 
21515
  if     (icase.eq.4) then
 
21516
!4 non-zero internal masses
 
21517
    useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
21518
               .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
21519
               .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
21520
               .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
21521
               .or.(     areal(ss(1)).ge.-small  &
 
21522
                    .and.areal(ss(2)).ge.-small  &
 
21523
                    .and.areal(ss(3)).ge.-small  &
 
21524
                    .and.areal(ss(4)).ge.-small) )
 
21525
    if (useboxc) then
 
21526
      call boxc( rslt ,ss,rr ,as ,smax )
 
21527
    else
 
21528
      call boxf4( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(1),rr(2),rr(3),rr(4) )
 
21529
    endif
 
21530
  elseif (icase.eq.3) then
 
21531
!3 non-zero internal masses
 
21532
    if (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21533
      useboxc = (    (ar(1).ne.RZRO.and.aimag(rr(1)).ne.RZRO) &
 
21534
                 .or.(ar(2).ne.RZRO.and.aimag(rr(2)).ne.RZRO) &
 
21535
                 .or.(ar(3).ne.RZRO.and.aimag(rr(3)).ne.RZRO) &
 
21536
                 .or.(ar(4).ne.RZRO.and.aimag(rr(4)).ne.RZRO) &
 
21537
                 .or.(     areal(ss(1)).ge.-small  &
 
21538
                      .and.areal(ss(2)).ge.-small  &
 
21539
                      .and.areal(ss(3)).ge.-small  &
 
21540
                      .and.areal(ss(4)).ge.-small) )
 
21541
      if (useboxc) then
 
21542
        call boxc( rslt ,ss,rr ,as ,smax )
 
21543
      else
 
21544
        call boxf3( rslt, ss,rr )
 
21545
      endif
 
21546
    else
 
21547
      call box16( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(3),rr(4) ,mulocal )
 
21548
    endif
 
21549
  elseif (icase.eq.5) then
 
21550
!2 non-zero internal masses, opposite case
 
21551
    if     (s1r2.ne.RZRO.or.s4r4.ne.RZRO) then
 
21552
      if     (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21553
        call boxf5( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(2),rr(4) )
 
21554
      else
 
21555
        call box15( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21556
      endif
 
21557
    elseif (s2r2.ne.RZRO.or.s3r4.ne.RZRO) then
 
21558
      call box15( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21559
    else
 
21560
      call box14( rslt ,ss(5),ss(6) ,rr(2),rr(4) ,mulocal )
 
21561
    endif
 
21562
  elseif (icase.eq.2) then
 
21563
!2 non-zero internal masses, adjacent case
 
21564
    if     (as(1).ne.RZRO) then
 
21565
      call boxf2( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) )
 
21566
    elseif (s2r3.ne.RZRO) then
 
21567
      if     (s4r4.ne.RZRO) then
 
21568
        call box13( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21569
      else
 
21570
        call box12( rslt ,ss(3),ss(2),ss(6),ss(5) ,rr(4),rr(3) ,mulocal )
 
21571
      endif
 
21572
    elseif (s4r4.ne.RZRO) then
 
21573
      call box12( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21574
    else
 
21575
      call box11( rslt ,ss(3),ss(5),ss(6) ,rr(3),rr(4) ,mulocal )
 
21576
    endif
 
21577
  elseif (icase.eq.1) then
 
21578
!1 non-zero internal mass
 
21579
    if     (as(1).ne.RZRO) then
 
21580
      if      (as(2).ne.RZRO) then
 
21581
        call boxf1( rslt ,ss(1),ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) )
 
21582
      else
 
21583
        if     (s3r4.ne.RZRO) then
 
21584
          call box10( rslt ,ss(1),ss(4),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21585
        else
 
21586
          call box09( rslt ,ss(1),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21587
        endif
 
21588
      endif
 
21589
    elseif (as(2).ne.RZRO) then
 
21590
      if      (s4r4.ne.RZRO) then
 
21591
        call box10( rslt ,ss(2),ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21592
      else
 
21593
        call box09( rslt ,ss(2),ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21594
      endif
 
21595
    else
 
21596
      if     (s3r4.ne.RZRO) then
 
21597
        if     (s4r4.ne.RZRO) then
 
21598
          call box08( rslt ,ss(3),ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21599
        else
 
21600
          call box07( rslt ,ss(3),ss(5),ss(6) ,rr(4) ,mulocal )
 
21601
        endif
 
21602
      elseif (s4r4.ne.RZRO) then
 
21603
        call box07( rslt ,ss(4),ss(5),ss(6) ,rr(4) ,mulocal )
 
21604
      else
 
21605
        call box06( rslt ,ss(5),ss(6) ,rr(4) ,mulocal )
 
21606
      endif
 
21607
    endif
 
21608
  else
 
21609
!0 non-zero internal mass
 
21610
    call box00( rslt ,ss ,as ,mulocal )
 
21611
  endif
 
21612
!exp(eps*gamma_EULER) -> GAMMA(1-2*eps)/GAMMA(1-eps)^2/GAMMA(1+eps)
 
21613
  rslt(0) = rslt(0) + 2*PISQo24*rslt(2)
 
21614
!
 
21615
  if (punit.gt.0) then
 
21616
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
21617
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
21618
    write(punit,*) ' p1:',trim(myprint(p1))
 
21619
    write(punit,*) ' p2:',trim(myprint(p2))
 
21620
    write(punit,*) ' p3:',trim(myprint(p3))
 
21621
    write(punit,*) ' p4:',trim(myprint(p4))
 
21622
    write(punit,*) 'p12:',trim(myprint(p12))
 
21623
    write(punit,*) 'p23:',trim(myprint(p23))
 
21624
    write(punit,*) ' m1:',trim(myprint(m1))
 
21625
    write(punit,*) ' m2:',trim(myprint(m2))
 
21626
    write(punit,*) ' m3:',trim(myprint(m3))
 
21627
    write(punit,*) ' m4:',trim(myprint(m4))
 
21628
    write(punit,*) 'd0(2):',trim(myprint(rslt(2)))
 
21629
    write(punit,*) 'd0(1):',trim(myprint(rslt(1)))
 
21630
    write(punit,*) 'd0(0):',trim(myprint(rslt(0)))
 
21631
  endif
 
21632
  end subroutine
 
21633
 
 
21634
  subroutine d0rrr( rslt ,p1,p2,p3,p4,p12,p23 ,m1,m2,m3,m4 ,rmu )
 
21635
  use avh_olo_qp_box
 
21636
  use avh_olo_qp_boxc
 
21637
!
 
21638
  complex(kindr2) &   
 
21639
    ,intent(out) :: rslt(0:2)
 
21640
  real(kindr2) &  
 
21641
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
 
21642
  real(kindr2) &  
 
21643
    ,intent(in)  :: m1,m2,m3,m4
 
21644
  real(kindr2) &  
 
21645
    ,intent(in)  :: rmu      
 
21646
!
 
21647
  real(kindr2) &  
 
21648
    :: pp(6)
 
21649
  real(kindr2) &  
 
21650
    :: mm(4)
 
21651
  complex(kindr2) &   
 
21652
    :: ss(6),rr(4)
 
21653
  real(kindr2) &  
 
21654
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
 
21655
  real(kindr2) &  
 
21656
    :: mulocal,mulocal2,small,hh,min13,min24,min56
 
21657
  integer :: icase,ii,jj
 
21658
  logical :: useboxc
 
21659
  integer ,parameter :: lp(6,3)=&
 
21660
           reshape((/1,2,3,4,5,6 ,5,2,6,4,1,3 ,1,6,3,5,4,2/),(/6,3/))
 
21661
  integer ,parameter :: lm(4,3)=&
 
21662
           reshape((/1,2,3,4     ,1,3,2,4     ,1,2,4,3    /),(/4,3/))
 
21663
  character(25+99) ,parameter :: warning=&
 
21664
                 'WARNING from OneLOop d0: '//warnonshell
 
21665
  if (initz) call init
 
21666
  pp(1) = p1
 
21667
  pp(2) = p2
 
21668
  pp(3) = p3
 
21669
  pp(4) = p4
 
21670
  pp(5) = p12
 
21671
  pp(6) = p23
 
21672
  mm(1) = m1
 
21673
  mm(2) = m2
 
21674
  mm(3) = m3
 
21675
  mm(4) = m4
 
21676
  smax = 0
 
21677
!
 
21678
  do ii=1,6
 
21679
    ap(ii) = abs(pp(ii))
 
21680
    if (ap(ii).gt.smax) smax = ap(ii)
 
21681
  enddo
 
21682
!
 
21683
  do ii=1,4
 
21684
    am(ii) = abs(mm(ii))
 
21685
    if (am(ii).gt.smax) smax = am(ii)
 
21686
  enddo
 
21687
!
 
21688
  small = 0
 
21689
  do ii=1,6
 
21690
    hh = abs(ap(ii))
 
21691
    if (hh.gt.small) small=hh
 
21692
  enddo
 
21693
  small = small*neglig(prcpar)
 
21694
!
 
21695
  mulocal = rmu     
9407
21696
!
9408
21697
  mulocal2 = mulocal*mulocal
9409
21698
!
9607
21896
 
9608
21897
module avh_olo_mp_arrays
9609
21898
  use avh_olo_units
9610
 
  include 'cts_mprec.h'
 
21899
  use mpmodule     
9611
21900
  implicit none
9612
21901
  private
9613
21902
  public :: shift1,shift2,shift3,resize,enlarge
9637
21926
contains
9638
21927
 
9639
21928
  subroutine shift1_r( xx ,nn )
9640
 
  include 'cts_mpr.h'
 
21929
  type(mp_real) & 
9641
21930
    ,allocatable ,intent(inout) :: xx(:)
9642
21931
  integer        ,intent(in   ) :: nn
9643
 
  include 'cts_mpr.h'
 
21932
  type(mp_real) & 
9644
21933
    ,allocatable :: tt(:)
9645
21934
  integer ,parameter :: dm=1
9646
21935
  integer :: lb(dm),ub(dm)
9681
21970
  end subroutine
9682
21971
 
9683
21972
  subroutine shift2_r( xx ,nn )
9684
 
  include 'cts_mpr.h'
 
21973
  type(mp_real) & 
9685
21974
          ,allocatable ,intent(inout) :: xx(:,:)
9686
21975
  integer              ,intent(in   ) :: nn
9687
 
  include 'cts_mpr.h'
 
21976
  type(mp_real) & 
9688
21977
          ,allocatable :: tt(:,:)
9689
21978
  integer ,parameter :: dm=2
9690
21979
  integer :: lb(dm),ub(dm)
9725
22014
  end subroutine
9726
22015
 
9727
22016
  subroutine shift3_r( xx ,nn )
9728
 
  include 'cts_mpr.h'
 
22017
  type(mp_real) & 
9729
22018
    ,allocatable ,intent(inout) :: xx(:,:,:)
9730
22019
  integer        ,intent(in   ) :: nn
9731
 
  include 'cts_mpr.h'
 
22020
  type(mp_real) & 
9732
22021
    ,allocatable :: tt(:,:,:)
9733
22022
  integer ,parameter :: dm=3
9734
22023
  integer :: lb(dm),ub(dm)
9770
22059
 
9771
22060
 
9772
22061
  subroutine resize1_r( xx ,l1,u1 )
9773
 
  include 'cts_mpr.h'
 
22062
  type(mp_real) & 
9774
22063
    ,allocatable ,intent(inout) :: xx(:)
9775
22064
  integer        ,intent(in   ) :: l1,u1
9776
 
  include 'cts_mpr.h'
 
22065
  type(mp_real) & 
9777
22066
    ,allocatable :: tt(:)
9778
22067
  integer :: lb(1),ub(1)
9779
22068
  if (.not.allocated(xx)) then
9791
22080
  end subroutine 
9792
22081
 
9793
22082
  subroutine resize2_r( xx ,l1,u1 ,l2,u2 )
9794
 
  include 'cts_mpr.h'
 
22083
  type(mp_real) & 
9795
22084
    ,allocatable ,intent(inout) :: xx(:,:)
9796
22085
  integer        ,intent(in   ) :: l1,u1,l2,u2
9797
 
  include 'cts_mpr.h'
 
22086
  type(mp_real) & 
9798
22087
    ,allocatable :: tt(:,:)
9799
22088
  integer :: lb(2),ub(2)
9800
22089
  if (.not.allocated(xx)) then
9815
22104
 
9816
22105
 
9817
22106
  subroutine enlarge1_r( xx ,l1,u1 )
9818
 
  include 'cts_mpr.h'
 
22107
  type(mp_real) & 
9819
22108
    ,allocatable ,intent(inout) :: xx(:)
9820
22109
  integer        ,intent(in   ) :: l1,u1
9821
 
  include 'cts_mpr.h'
 
22110
  type(mp_real) & 
9822
22111
    ,allocatable :: tt(:)
9823
22112
  integer :: lb(1),ub(1)
9824
22113
  if (.not.allocated(xx)) then
9827
22116
  endif
9828
22117
  lb=lbound(xx) ;ub=ubound(xx)
9829
22118
  if (lb(1).le.l1.and.u1.le.ub(1)) return
 
22119
  if (lb(1).gt.ub(1)) then
 
22120
    deallocate( xx )
 
22121
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))) )
 
22122
    return
 
22123
  endif
9830
22124
  allocate(tt(lb(1):ub(1)))
9831
22125
  tt = xx
9832
22126
  deallocate(xx)
9836
22130
  end subroutine 
9837
22131
 
9838
22132
  subroutine enlarge2_r( xx ,l1,u1 ,l2,u2 )
9839
 
  include 'cts_mpr.h'
 
22133
  type(mp_real) & 
9840
22134
    ,allocatable ,intent(inout) :: xx(:,:)
9841
22135
  integer        ,intent(in   ) :: l1,u1,l2,u2
9842
 
  include 'cts_mpr.h'
 
22136
  type(mp_real) & 
9843
22137
    ,allocatable :: tt(:,:)
9844
22138
  integer :: lb(2),ub(2)
9845
22139
  if (.not.allocated(xx)) then
9849
22143
  lb=lbound(xx) ;ub=ubound(xx)
9850
22144
  if (lb(1).le.l1.and.u1.le.ub(1).and. &
9851
22145
      lb(2).le.l2.and.u2.le.ub(2)      ) return
 
22146
  if (lb(1).gt.ub(1).or.lb(2).gt.ub(2)) then
 
22147
    deallocate( xx )
 
22148
    allocate( xx(min(l1,lb(1)):max(u1,ub(1))  &
 
22149
                ,min(l2,lb(2)):max(u2,ub(2))) )
 
22150
    return
 
22151
  endif
9852
22152
  allocate(tt(lb(1):ub(1),lb(2):ub(2)))
9853
22153
  tt = xx
9854
22154
  deallocate(xx)
9863
22163
 
9864
22164
 
9865
22165
module avh_olo_mp_prec
9866
 
  include 'cts_mprec.h'
 
22166
  use mpmodule
9867
22167
 
9868
22168
  implicit none
9869
22169
  public
9871
22171
 
9872
22172
  integer             ,save :: prcpar=1
9873
22173
  integer ,allocatable,save :: ndecim(:)
9874
 
  include 'cts_mpr.h'
 
22174
  type(mp_real) &
9875
22175
          ,allocatable,save :: epsilo(:),neglig(:)
9876
22176
 
9877
 
  include 'cts_mpr.h'
 
22177
  type(mp_real) &
9878
22178
    ,save :: RZRO ,RONE ,EPSN ,EPSN2 ,TWOPI ,ONEPI
9879
 
  include 'cts_mpc.h'
 
22179
  type(mp_complex) &
9880
22180
    ,save :: IEPS ,CZRO ,CONE ,IMAG ,PISQo24 ,IPI
9881
22181
 
9882
22182
 
9904
22204
      elseif (ndecim(ii).lt.ndec) then            
9905
22205
        i0 = ii                                   
9906
22206
      else                                        
9907
 
        i1 = ii                                   
9908
22207
        exit                                      
9909
22208
      endif                                       
9910
22209
    enddo                                         
9911
 
    if (ndecim(i0).eq.ndec) i0=i1                 
9912
 
    prcpar = i1                                   
9913
 
    newprc = (ndecim(prcpar).ne.ndec)             
9914
 
    if (newprc) then                              
 
22210
    newprc = (ndecim(ii).ne.ndec)
 
22211
    if (newprc) then
 
22212
      prcpar = i0+1                              
9915
22213
      call shift1( ndecim ,prcpar )               
9916
22214
      call shift1( epsilo ,prcpar )               
9917
22215
      call shift1( neglig ,prcpar )               
9918
22216
      call set_epsn          
9919
 
    else                                          
 
22217
    else           
 
22218
      prcpar = ii
9920
22219
      EPSN = epsilo(prcpar)                       
9921
22220
    endif                                         
9922
22221
  else                                            
9941
22240
  contains
9942
22241
!
9943
22242
  subroutine set_epsn
9944
 
  include 'cts_mpr.h'
 
22243
  type(mp_real) &
9945
22244
    :: ten
9946
22245
  ten = 10                                       
9947
22246
  EPSN = ten**(-ndec)                            
9957
22256
!***********************************************************************
9958
22257
! Turn mp_real into kind(1d0)
9959
22258
!***********************************************************************
9960
 
  include 'cts_mpr.h'
9961
 
   ,intent(in) :: xx
 
22259
  type(mp_real) ,intent(in) :: xx
9962
22260
  real(kind(1d0)) :: rslt
9963
22261
  rslt = xx
9964
22262
  end function
9968
22266
! Turn kind(1d0) into mp_real
9969
22267
!***********************************************************************
9970
22268
  real(kind(1d0)) ,intent(in) :: xx
9971
 
  include 'cts_mpr.h'
9972
 
   :: rslt
 
22269
  type(mp_real) :: rslt
9973
22270
  rslt = xx
9974
22271
  end function
9975
22272
 
9977
22274
!***********************************************************************
9978
22275
! Get real part of a complex
9979
22276
!***********************************************************************
9980
 
  include 'cts_mpc.h'
 
22277
  type(mp_complex) &
9981
22278
    ,intent(in) :: zz
9982
 
  include 'cts_mpr.h'
 
22279
  type(mp_real) &
9983
22280
    :: rslt
9984
22281
  rslt = zz
9985
22282
  end function
9988
22285
!***********************************************************************
9989
22286
! Turn a real into a complex
9990
22287
!***********************************************************************
9991
 
  include 'cts_mpr.h'
 
22288
  type(mp_real) &
9992
22289
    ,intent(in) :: xx
9993
 
  include 'cts_mpc.h'
 
22290
  type(mp_complex) &
9994
22291
    :: rslt
9995
22292
  rslt = xx
9996
22293
  end function
9999
22296
!***********************************************************************
10000
22297
! Turn two reals into one complex
10001
22298
!***********************************************************************
10002
 
  include 'cts_mpr.h'
 
22299
  type(mp_real) &
10003
22300
    ,intent(in) :: xx,yy
10004
 
  include 'cts_mpc.h'
 
22301
  type(mp_complex) &
10005
22302
    :: rslt
10006
22303
  rslt = xx + yy*IMAG
10007
22304
  end function
10010
22307
!***********************************************************************
10011
22308
! Turn a real and an integer into one complex
10012
22309
!***********************************************************************
10013
 
  include 'cts_mpr.h'
 
22310
  type(mp_real) &
10014
22311
          ,intent(in) :: xx
10015
22312
  integer ,intent(in) :: yy
10016
 
  include 'cts_mpc.h'
 
22313
  type(mp_complex) &
10017
22314
    :: rslt
10018
22315
  rslt = xx + yy*IMAG
10019
22316
  end function
10023
22320
! Turn an integer and a real into one complex
10024
22321
!***********************************************************************
10025
22322
  integer ,intent(in) :: xx
10026
 
  include 'cts_mpr.h'
 
22323
  type(mp_real) &
10027
22324
          ,intent(in) :: yy
10028
 
  include 'cts_mpc.h'
 
22325
  type(mp_complex) &
10029
22326
    :: rslt
10030
22327
  rslt = xx + yy*IMAG
10031
22328
  end function
10034
22331
!***********************************************************************
10035
22332
! Replaces the real part of zz by its absolute value
10036
22333
!***********************************************************************
10037
 
  include 'cts_mpc.h'
 
22334
  type(mp_complex) &
10038
22335
    ,intent(in) :: zz
10039
 
  include 'cts_mpc.h'
 
22336
  type(mp_complex) &
10040
22337
    :: rslt
10041
 
  include 'cts_mpr.h'
 
22338
  type(mp_real) &
10042
22339
    :: xx,yy
10043
22340
  xx = zz
10044
22341
  xx = abs(xx)
10065
22362
contains
10066
22363
 
10067
22364
  function printc( zz ,ndec ) result(rslt)
10068
 
  include 'cts_mpc.h'
 
22365
  type(mp_complex) &  
10069
22366
    ,intent(in) :: zz
10070
22367
  integer,optional,intent(in) :: ndec
10071
22368
  character((ndecim(prcpar)+nxtr+novh)*2+3) :: rslt
10082
22379
  end function
10083
22380
 
10084
22381
  function printr( xx_in ,ndec_in ) result(rslt)
10085
 
  include 'cts_mpr.h'
 
22382
  type(mp_real) & 
10086
22383
                  ,intent(in) :: xx_in
10087
22384
  integer,optional,intent(in) :: ndec_in
10088
22385
  character(ndecim(prcpar)+nxtr+novh  ) :: rslt
10089
22386
  character(ndecim(prcpar)+nxtr+novh+1) :: cc
10090
22387
  character(10) :: aa,bb
10091
22388
  integer :: ndec
10092
 
  real(kind(1d0)) :: xx
 
22389
  real(kind(1d0)) :: xx 
10093
22390
  xx = xx_in
10094
22391
  if (present(ndec_in)) then ;ndec=ndec_in
10095
22392
                        else ;ndec=ndecim(prcpar)+nxtr
10096
22393
  endif
10097
 
  write(aa,'(i10)') ndec+novh+1 ;aa=adjustl(aa)
10098
 
  write(bb,'(i10)') ndec        ;bb=adjustl(bb)
 
22394
  write(aa,'(i10)') min(len(cc),ndec+novh+1) ;aa=adjustl(aa)
 
22395
  write(bb,'(i10)') min(len(cc),ndec       ) ;bb=adjustl(bb)
10099
22396
  aa = '(e'//trim(aa)//'.'//trim(bb)//')'
10100
22397
  write(cc,aa) xx  ;cc=adjustl(cc)
10101
 
  if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:ndec*2)
10102
 
  else                      ;rslt = ' '//cc(2:ndec*2)
 
22398
  if (cc(1:2).eq.'-0') then ;rslt = '-'//cc(3:len(cc))
 
22399
  else                      ;rslt = ' '//cc(2:len(cc))
10103
22400
  endif
10104
22401
  end function
10105
22402
 
10158
22455
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
10159
22456
! negative imaginary.
10160
22457
!*******************************************************************
10161
 
  include 'cts_mpc.h'
 
22458
  type(mp_complex) &  
10162
22459
    ,intent(in) :: xx
10163
 
  include 'cts_mpc.h'
 
22460
  type(mp_complex) &  
10164
22461
    :: rslt ,zz
10165
 
  include 'cts_mpr.h'
 
22462
  type(mp_real) & 
10166
22463
    :: xim,xre
10167
22464
  xim = aimag(xx)
10168
22465
  if (xim.eq.RZRO) then
10184
22481
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
10185
22482
! imaginary and has the same sign as  sgn .
10186
22483
!*******************************************************************
10187
 
  include 'cts_mpc.h'
 
22484
  type(mp_complex) &  
10188
22485
    ,intent(in) :: xx
10189
 
  include 'cts_mpr.h'
 
22486
  type(mp_real) & 
10190
22487
    ,intent(in) :: sgn
10191
 
  include 'cts_mpc.h'
 
22488
  type(mp_complex) &  
10192
22489
    :: rslt ,zz
10193
 
  include 'cts_mpr.h'
 
22490
  type(mp_real) & 
10194
22491
    :: xim,xre
10195
22492
  xim = aimag(xx)
10196
22493
  if (xim.eq.RZRO) then
10212
22509
! If  Im(xx)  is equal zero and  Re(xx)  is negative, the result is
10213
22510
! imaginary and has the same sign as  sgn .
10214
22511
!*******************************************************************
10215
 
  include 'cts_mpc.h'
 
22512
  type(mp_complex) &  
10216
22513
          ,intent(in) :: xx
10217
22514
  integer ,intent(in) :: sgn
10218
 
  include 'cts_mpc.h'
 
22515
  type(mp_complex) &  
10219
22516
    :: rslt ,zz
10220
 
  include 'cts_mpr.h'
 
22517
  type(mp_real) & 
10221
22518
    :: xim,xre,hh
10222
22519
  xim = aimag(xx)
10223
22520
  if (xim.eq.RZRO) then
10241
22538
! Also returns  dd = aa*(x1-x2)
10242
22539
! If  imode=/=0  it uses  dd  as input as value of  sqrt(b^2-4*a*c)
10243
22540
!*******************************************************************
10244
 
  include 'cts_mpc.h'
 
22541
  type(mp_complex) &  
10245
22542
    ,intent(out)   :: x1,x2
10246
 
  include 'cts_mpc.h'
 
22543
  type(mp_complex) &  
10247
22544
    ,intent(inout) :: dd
10248
 
  include 'cts_mpc.h'
 
22545
  type(mp_complex) &  
10249
22546
    ,intent(in) :: aa,bb,cc
10250
22547
  integer         ,intent(in) :: imode
10251
 
  include 'cts_mpc.h'
 
22548
  type(mp_complex) &  
10252
22549
    :: qq,hh
10253
 
  include 'cts_mpr.h'
 
22550
  type(mp_real) & 
10254
22551
    :: r1,r2
10255
22552
 
10256
22553
  if (aa.eq.CZRO) then
10293
22590
!*******************************************************************
10294
22591
  intent(out) :: x1,x2
10295
22592
  intent(in ) :: aa,bb,cc
10296
 
  include 'cts_mpc.h'
 
22593
  type(mp_complex) &  
10297
22594
    :: x1,x2,bb,cc ,t1,t2
10298
 
  include 'cts_mpr.h'
 
22595
  type(mp_real) & 
10299
22596
    :: aa,xx,yy,pp,qq,uu,vv,pq1,pq2,uv1,uv2,dd,xd1,xd2,yd1,yd2 &
10300
22597
      ,gg,hh,rx1,rx2,ix1,ix2
10301
22598
  if (aa.eq.RZRO) then
10355
22652
! If  Im(rr)  is zero, then  |rr| > 1/|rr| .
10356
22653
! Also returns  dd = rr - 1/rr .
10357
22654
!*******************************************************************
10358
 
  include 'cts_mpc.h'
 
22655
  type(mp_complex) &  
10359
22656
    ,intent(out) :: rr,dd
10360
 
  include 'cts_mpc.h'
 
22657
  type(mp_complex) &  
10361
22658
    ,intent(in)  :: qq
10362
 
  include 'cts_mpc.h'
 
22659
  type(mp_complex) &  
10363
22660
    :: r2
10364
 
  include 'cts_mpr.h'
 
22661
  type(mp_real) & 
10365
22662
    :: aa,bb
10366
22663
  integer :: ir,ik
10367
22664
  dd = sqrt(qq*qq-4)
10398
22695
!*******************************************************************
10399
22696
! Like rfun, but now  dd  is input, which may get a minus sign
10400
22697
!*******************************************************************
10401
 
  include 'cts_mpc.h'
 
22698
  type(mp_complex) &  
10402
22699
    ,intent(out)   :: rr
10403
 
  include 'cts_mpc.h'
 
22700
  type(mp_complex) &  
10404
22701
    ,intent(inout) :: dd
10405
 
  include 'cts_mpc.h'
 
22702
  type(mp_complex) &  
10406
22703
    ,intent(in)  :: qq
10407
 
  include 'cts_mpc.h'
 
22704
  type(mp_complex) &  
10408
22705
    :: r2
10409
 
  include 'cts_mpr.h'
 
22706
  type(mp_real) & 
10410
22707
    :: aa,bb
10411
22708
  integer :: ir,ik
10412
22709
  rr = qq+dd
10446
22743
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
10447
22744
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
10448
22745
!*******************************************************************
10449
 
  include 'cts_mpc.h'
 
22746
  type(mp_complex) &  
10450
22747
    ,intent(in) :: aa,bb,cc
10451
 
  include 'cts_mpr.h'
 
22748
  type(mp_real) & 
10452
22749
    ,intent(in) :: sa,sb,sc
10453
 
  include 'cts_mpc.h'
 
22750
  type(mp_complex) &  
10454
22751
    :: rslt
10455
 
  include 'cts_mpr.h'
 
22752
  type(mp_real) & 
10456
22753
    :: ima,imb,imc
10457
22754
  ima = aimag(aa)
10458
22755
  imb = aimag(bb)
10477
22774
!   - theta( Im(a))*theta( Im(b))*theta(-Im(c))
10478
22775
! where a,b,c are interpreted as a+i|eps|sa, b+i|eps|sb, c+i|eps|sc
10479
22776
!*******************************************************************
10480
 
  include 'cts_mpc.h'
 
22777
  type(mp_complex) &  
10481
22778
    ,intent(in) :: aa,bb,cc
10482
 
  include 'cts_mpc.h'
 
22779
  type(mp_complex) &  
10483
22780
    :: rslt
10484
 
  include 'cts_mpr.h'
 
22781
  type(mp_real) & 
10485
22782
    :: ima,imb,imc
10486
22783
  ima = sgnIm(aa)
10487
22784
  imb = sgnIm(bb)
10497
22794
!*******************************************************************
10498
22795
! eta3(aa,b1,c1) - eta3(aa,b2,c2)
10499
22796
!*******************************************************************
10500
 
  include 'cts_mpc.h'
 
22797
  type(mp_complex) &  
10501
22798
    ,intent(in) :: aa,b1,c1 ,b2,c2
10502
 
  include 'cts_mpc.h'
 
22799
  type(mp_complex) &  
10503
22800
    :: rslt
10504
 
  include 'cts_mpr.h'
 
22801
  type(mp_real) & 
10505
22802
    :: imaa,imb1,imc1,imb2,imc2
10506
22803
  imaa = sgnIm(aa)
10507
22804
  imb1 = sgnIm(b1)
10534
22831
! The same as  eta3, but with  c=a*b, so that
10535
22832
!   eta(a,b) = log(a*b) - log(a) - log(b)
10536
22833
!*******************************************************************
10537
 
  include 'cts_mpc.h'
 
22834
  type(mp_complex) &  
10538
22835
    ,intent(in) :: aa,bb
10539
 
  include 'cts_mpr.h'
 
22836
  type(mp_real) & 
10540
22837
    ,intent(in) :: sa,sb
10541
 
  include 'cts_mpc.h'
 
22838
  type(mp_complex) &  
10542
22839
    :: rslt
10543
 
  include 'cts_mpr.h'
 
22840
  type(mp_real) & 
10544
22841
    :: rea,reb,ima,imb,imab
10545
22842
  rea = areal(aa)  ;ima = aimag(aa)
10546
22843
  reb = areal(bb)  ;imb = aimag(bb)
10561
22858
  function eta2_0( aa ,bb ) result(rslt)
10562
22859
!*******************************************************************
10563
22860
!*******************************************************************
10564
 
  include 'cts_mpc.h'
 
22861
  type(mp_complex) &  
10565
22862
    ,intent(in) :: aa,bb
10566
 
  include 'cts_mpc.h'
 
22863
  type(mp_complex) &  
10567
22864
    :: rslt
10568
 
  include 'cts_mpr.h'
 
22865
  type(mp_real) & 
10569
22866
    :: rea,reb,ima,imb,imab
10570
22867
  rea = areal(aa)  ;ima = aimag(aa)
10571
22868
  reb = areal(bb)  ;imb = aimag(bb)
10587
22884
!*******************************************************************
10588
22885
!  p1^2 + p2^2 + p3^2 - 2*p1*p2 - 2*p2*p3 - 2*p3*p1
10589
22886
!*******************************************************************
10590
 
  include 'cts_mpc.h'
 
22887
  type(mp_complex) &  
10591
22888
    ,intent(in) :: p1,p2,p3
10592
 
  include 'cts_mpc.h'
 
22889
  type(mp_complex) &  
10593
22890
    :: rslt ,y1,y2,y3
10594
 
  include 'cts_mpr.h'
 
22891
  type(mp_real) & 
10595
22892
    :: b1,b2,b3
10596
22893
  y1=p2*p3 ;b1=areal(y1)
10597
22894
  y2=p3*p1 ;b2=areal(y2)
10609
22906
  function sgnIm_c(zz) result(rslt)
10610
22907
!*******************************************************************
10611
22908
!*******************************************************************
10612
 
  include 'cts_mpc.h'
 
22909
  type(mp_complex) &  
10613
22910
    ,intent(in) :: zz
10614
22911
  integer :: rslt
10615
 
  include 'cts_mpr.h'
 
22912
  type(mp_real) & 
10616
22913
    :: imz
10617
22914
  imz = aimag(zz)
10618
22915
  if (imz.ge.RZRO) then ;rslt= 1
10623
22920
  function sgnIm_ci(zz,ii) result(rslt)
10624
22921
!*******************************************************************
10625
22922
!*******************************************************************
10626
 
  include 'cts_mpc.h'
 
22923
  type(mp_complex) &  
10627
22924
          ,intent(in) :: zz
10628
22925
  integer ,intent(in) :: ii
10629
22926
  integer :: rslt
10630
 
  include 'cts_mpr.h'
 
22927
  type(mp_real) & 
10631
22928
    :: imz
10632
22929
  imz = aimag(zz)
10633
22930
  if     (imz.gt.RZRO) then ;rslt= 1
10639
22936
  function sgnRe_c(zz) result(rslt)
10640
22937
!*******************************************************************
10641
22938
!*******************************************************************
10642
 
  include 'cts_mpc.h'
 
22939
  type(mp_complex) &  
10643
22940
    ,intent(in) :: zz
10644
22941
  integer :: rslt
10645
 
  include 'cts_mpr.h'
 
22942
  type(mp_real) & 
10646
22943
    :: rez
10647
22944
  rez = zz
10648
22945
  if (rez.ge.RZRO) then ;rslt= 1
10653
22950
  function sgnRe_r(rez) result(rslt)
10654
22951
!*******************************************************************
10655
22952
!*******************************************************************
10656
 
  include 'cts_mpr.h'
 
22953
  type(mp_real) & 
10657
22954
    ,intent(in) :: rez
10658
22955
  integer :: rslt
10659
22956
  if (rez.ge.RZRO) then ;rslt= 1
10664
22961
  function sgnRe_ri(rez,ii) result(rslt)
10665
22962
!*******************************************************************
10666
22963
!*******************************************************************
10667
 
  include 'cts_mpr.h'
 
22964
  type(mp_real) & 
10668
22965
          ,intent(in) :: rez
10669
22966
  integer ,intent(in) :: ii
10670
22967
  integer :: rslt
10693
22990
  private
10694
22991
  public :: update_olog,olog,olog2
10695
22992
 
10696
 
  include 'cts_mpr.h'
 
22993
  type(mp_real) & 
10697
22994
         ,allocatable,save :: thrs(:,:)
10698
22995
  integer,allocatable,save :: ntrm(:,:)
10699
22996
  integer,parameter :: nStp=6
10711
23008
!***********************************************************************
10712
23009
!***********************************************************************
10713
23010
  use avh_olo_mp_arrays
10714
 
  include 'cts_mpr.h'
 
23011
  type(mp_real) & 
10715
23012
    :: tt
10716
23013
  integer :: nn,mm,ii,jj
10717
23014
!  real(kind(1d0)) :: xx(6) !DEBUG
10768
23065
  function log_c(xx,iph) result(rslt)
10769
23066
!***********************************************************************
10770
23067
!***********************************************************************
10771
 
  include 'cts_mpc.h'
 
23068
  type(mp_complex) &  
10772
23069
          ,intent(in) :: xx
10773
23070
  integer ,intent(in) :: iph
10774
 
  include 'cts_mpc.h'
 
23071
  type(mp_complex) &  
10775
23072
    :: rslt ,yy,zz,z2
10776
 
  include 'cts_mpr.h'
 
23073
  type(mp_real) & 
10777
23074
    :: aa,rex,imx
10778
23075
  integer :: nn,ii,iyy
10779
23076
!
10829
23126
  function log_r(xx,iph) result(rslt)
10830
23127
!***********************************************************************
10831
23128
!***********************************************************************
10832
 
  include 'cts_mpr.h'
 
23129
  type(mp_real) & 
10833
23130
          ,intent(in) :: xx
10834
23131
  integer ,intent(in) :: iph
10835
 
  include 'cts_mpc.h'
 
23132
  type(mp_complex) &  
10836
23133
    :: rslt
10837
 
  include 'cts_mpr.h'
 
23134
  type(mp_real) & 
10838
23135
    :: rr
10839
23136
  integer :: jj
10840
23137
!
10854
23151
  function log2_c(xx,iph) result(rslt)
10855
23152
!***********************************************************************
10856
23153
!***********************************************************************
10857
 
  include 'cts_mpc.h'
 
23154
  type(mp_complex) &  
10858
23155
          ,intent(in) :: xx
10859
23156
  integer ,intent(in) :: iph
10860
 
  include 'cts_mpc.h'
 
23157
  type(mp_complex) &  
10861
23158
    :: rslt ,yy,zz,z2
10862
 
  include 'cts_mpr.h'
 
23159
  type(mp_real) & 
10863
23160
    :: aa,rex,imx
10864
23161
  integer :: nn,ii,jj
10865
23162
!
10911
23208
  function log2_r(xx,iph) result(rslt)
10912
23209
!***********************************************************************
10913
23210
!***********************************************************************
10914
 
  include 'cts_mpr.h'
 
23211
  type(mp_real) & 
10915
23212
          ,intent(in) :: xx
10916
23213
  integer ,intent(in) :: iph
10917
 
  include 'cts_mpc.h'
 
23214
  type(mp_complex) &  
10918
23215
    :: rslt
10919
 
  include 'cts_mpr.h'
 
23216
  type(mp_real) & 
10920
23217
    :: rr,yy
10921
23218
  integer :: jj
10922
23219
!  include 'avh_olo_mp_real.h90'
10970
23267
  private
10971
23268
  public :: update_dilog,dilog
10972
23269
 
10973
 
  include 'cts_mpr.h'
 
23270
  type(mp_real) & 
10974
23271
         ,allocatable,save :: coeff(:)
10975
 
  include 'cts_mpr.h'
 
23272
  type(mp_real) & 
10976
23273
         ,allocatable,save :: thrs(:,:)
10977
23274
  integer,allocatable,save :: ntrm(:,:)
10978
23275
  integer,parameter :: nStp=6
10979
23276
 
10980
 
  include 'cts_mpr.h'
 
23277
  type(mp_real) & 
10981
23278
         ,allocatable :: bern(:),fact(:)
10982
23279
 
10983
23280
  interface dilog
10989
23286
  subroutine update_dilog
10990
23287
!***********************************************************************
10991
23288
!***********************************************************************
10992
 
  include 'cts_mpr.h'
 
23289
  type(mp_real) & 
10993
23290
    :: tt
10994
23291
  integer :: nn,ii,jj
10995
23292
  logical :: highestSoFar
11105
23402
  function dilog_c(xx,iph) result(rslt)
11106
23403
!*******************************************************************
11107
23404
!*******************************************************************
11108
 
  include 'cts_mpc.h'
 
23405
  type(mp_complex) &  
11109
23406
          ,intent(in) :: xx
11110
23407
  integer ,intent(in) :: iph
11111
 
  include 'cts_mpc.h'
 
23408
  type(mp_complex) &  
11112
23409
    :: rslt ,yy,lyy,loy,zz,z2
11113
 
  include 'cts_mpr.h'
 
23410
  type(mp_real) & 
11114
23411
    :: rex,imx,az
11115
23412
  integer :: ii,jj,ntwo,odd,nn
11116
23413
  logical :: r_gt_1 , y_lt_h
11181
23478
  function dilog_r(xx,iph) result(rslt)
11182
23479
!*******************************************************************
11183
23480
!*******************************************************************
11184
 
  include 'cts_mpr.h'
 
23481
  type(mp_real) & 
11185
23482
          ,intent(in) :: xx
11186
23483
  integer ,intent(in) :: iph
11187
 
  include 'cts_mpc.h'
 
23484
  type(mp_complex) &  
11188
23485
    :: rslt
11189
 
  include 'cts_mpr.h'
 
23486
  type(mp_real) & 
11190
23487
    :: yy,lyy,loy,zz,z2,liox,az
11191
23488
  integer :: jj,ii,ntwo,odd,nn
11192
23489
  logical :: r_gt_1 , y_lt_h
11202
23499
  ntwo = jj-odd
11203
23500
! 
11204
23501
  if (yy.eq.RONE.and.odd.eq.0) then
11205
 
!!$    if (ntwo.ne.0) then
11206
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog_r: ' &
11207
 
!!$        ,'|x|,iph = ',trim(myprint(yy)),',',jj,', returning 0'
11208
 
!!$    endif
 
23502
    if (ntwo.ne.0) then
 
23503
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog_r: ' &
 
23504
        ,'|x|,iph = ',trim(myprint(yy)),',',jj,', returning 0'
 
23505
    endif
11209
23506
    rslt = 0
11210
23507
    return
11211
23508
  endif
11261
23558
!*******************************************************************
11262
23559
!*******************************************************************
11263
23560
  use avh_olo_mp_olog
11264
 
  include 'cts_mpc.h'
 
23561
  type(mp_complex) &  
11265
23562
          ,intent(in) :: x1,x2
11266
23563
  integer ,intent(in) :: i1,i2
11267
 
  include 'cts_mpc.h'
 
23564
  type(mp_complex) &  
11268
23565
    :: rslt ,y1,y2 ,ff,gg,logr1,logr2,logo1,logo2,r1,r2,rr
11269
 
  include 'cts_mpr.h'
 
23566
  type(mp_real) & 
11270
23567
    :: eps ,re1,im1,re2,im2,a1,a2,aa,ao1,ao2
11271
23568
  integer :: j1,j2,ii,nn,oo
11272
23569
  integer,parameter :: pp(-1:1,-1:1)=&
11311
23608
!
11312
23609
  if (j1.ne.j2) then
11313
23610
    if (r1.eq.r2) then
11314
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
11315
 
!!$        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
23611
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
23612
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
11316
23613
      rslt = 0
11317
23614
!      write(*,*) 'dilog2_c j1=/=j2,r1=r2' !DEBUG
11318
23615
      return
11325
23622
!
11326
23623
  if (a1.lt.eps) then
11327
23624
    if (a2.lt.eps) then
11328
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
11329
 
!!$        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
23625
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
23626
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
11330
23627
      rslt = 0
11331
23628
!      write(*,*) 'dilog2_c r1<eps,r2<eps' !DEBUG
11332
23629
      return
11347
23644
!      write(*,*) 'dilog2_c ||1-y1|/|1-y2|-1|>0.1' !DEBUG
11348
23645
      return
11349
23646
    elseif (oo.eq.0.and.ao1.lt.eps) then
11350
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
11351
 
!!$        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
23647
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
23648
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
11352
23649
      if (ao2.lt.eps) then
11353
23650
        rslt = -1
11354
23651
!        write(*,*) 'dilog2_c |1-y1|' !DEBUG
11357
23654
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
11358
23655
      endif
11359
23656
    elseif (oo.eq.0.and.ao2.lt.eps) then
11360
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
11361
 
!!$        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
23657
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
23658
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
11362
23659
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
11363
23660
    endif
11364
23661
  else
11372
23669
      if (a1.gt.RONE) ii = ii + (nn+pp(oo,sgnIm(y2)))
11373
23670
      if (a2.gt.RONE) ii = ii - (nn+pp(oo,sgnIm(y2)))
11374
23671
      ii = nn*ii
11375
 
!!$      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
11376
 
!!$        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
11377
 
!!$        ,', putting nn=0'
 
23672
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_c: ' &
 
23673
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
23674
        ,', putting nn=0'
11378
23675
      rslt = -olog2(y2,0)
11379
23676
!      write(*,*) 'dilog2_c |logr1/lorg2|<eps' !DEBUG
11380
23677
      return
11415
23712
!*******************************************************************
11416
23713
!*******************************************************************
11417
23714
  use avh_olo_mp_olog
11418
 
  include 'cts_mpr.h'
 
23715
  type(mp_real) & 
11419
23716
          ,intent(in) :: x1,x2
11420
23717
  integer ,intent(in) :: i1,i2
11421
 
  include 'cts_mpc.h'
 
23718
  type(mp_complex) &  
11422
23719
    :: rslt
11423
 
  include 'cts_mpr.h'
 
23720
  type(mp_real) & 
11424
23721
    :: y1,y2 ,ff,gg,logr1,logr2,logo1,logo2
11425
 
  include 'cts_mpr.h'
 
23722
  type(mp_real) & 
11426
23723
    :: eps,r1,r2,rr,ro1,ro2
11427
23724
  integer :: j1,j2,ii,nn,oo
11428
23725
!
11445
23742
!
11446
23743
  if (j1.ne.j2) then
11447
23744
    if (r1.eq.r2) then
11448
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
11449
 
!!$        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
 
23745
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
23746
        ,'j1,j2,r1-r2',j1,j2,',',trim(myprint(r1-r2)),', returning 0'
11450
23747
      rslt = 0
11451
23748
!      write(*,*) 'dilog2_r j1=/=j2,r1=r2' !DEBUG
11452
23749
      return
11459
23756
!
11460
23757
  if (r1.lt.eps) then
11461
23758
    if (r2.lt.eps) then
11462
 
!!$      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
11463
 
!!$        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
 
23759
      if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
23760
        ,'r1,r2 =',trim(myprint(r1)),',',trim(myprint(r2)),', returning 0'
11464
23761
      rslt = 0
11465
23762
!      write(*,*) 'dilog2_r r1<eps,r2<eps' !DEBUG
11466
23763
      return
11481
23778
!      write(*,*) 'dilog2_r ||1-y1|/|1-y2|-1|>0.1' !DEBUG
11482
23779
      return
11483
23780
    elseif (oo.eq.0.and.ro1.lt.eps) then
11484
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
11485
 
!!$        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
 
23781
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
23782
        ,'r1,oo,nn =',trim(myprint(r1)),',',oo,nn,', putting nn=0'
11486
23783
      if (ro2.lt.eps) then
11487
23784
        rslt = -1
11488
23785
!        write(*,*) 'dilog2_r |1-y1|' !DEBUG
11491
23788
        y1=1-eps ;nn=0 ;logr1=0 ;r1=1-eps
11492
23789
      endif
11493
23790
    elseif (oo.eq.0.and.ro2.lt.eps) then
11494
 
!!$      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
11495
 
!!$        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
 
23791
      if (nn.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
23792
        ,'r2,oo,nn =',trim(myprint(r2)),',',oo,nn,', putting nn=0'
11496
23793
      y2=1-eps ;nn=0 ;logr2=0 ;r2=1-eps
11497
23794
    endif
11498
23795
  else
11506
23803
      if (r1.gt.RONE) ii = ii + (nn+2*oo)
11507
23804
      if (r2.gt.RONE) ii = ii - (nn+2*oo)
11508
23805
      ii = nn*ii
11509
 
!!$      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
11510
 
!!$        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
11511
 
!!$        ,', putting nn=0'
 
23806
      if (ii.ne.0.and.eunit.gt.0) write(eunit,*) 'ERROR in OneLOop dilog2_r: ' &
 
23807
        ,'r1,r2,nn =',trim(myprint(r1)),',',trim(myprint(r2)),',',nn &
 
23808
        ,', putting nn=0'
11512
23809
      rslt = -olog2(y2,0)
11513
23810
!      write(*,*) 'dilog2_r |logr1/lorg2|<eps' !DEBUG
11514
23811
      return
11550
23847
! ( f(z1)-f(z2) )/( z1-z2 ), where
11551
23848
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
11552
23849
!***********************************************************************
11553
 
  include 'cts_mpc.h'
 
23850
  type(mp_complex) &  
11554
23851
    ,intent(in) :: z1,z2
11555
 
  include 'cts_mpc.h'
 
23852
  type(mp_complex) &  
11556
23853
    :: rslt,yy,zz
11557
 
  include 'cts_mpr.h'
 
23854
  type(mp_real) & 
11558
23855
    :: az
11559
23856
  integer :: ii,nn
11560
23857
  az = max(abs(z1),abs(z2))
11593
23890
! ( f(z1)-f(z2) )/( z1-z2 ), where
11594
23891
! f(z)= z + c0*z^2 + c1*z^3 + c2*z^5 + c3*z^7 + ...
11595
23892
!***********************************************************************
11596
 
  include 'cts_mpr.h'
 
23893
  type(mp_real) & 
11597
23894
    ,intent(in) :: z1,z2
11598
 
  include 'cts_mpr.h'
 
23895
  type(mp_real) & 
11599
23896
    :: rslt,yy,zz
11600
 
  include 'cts_mpr.h'
 
23897
  type(mp_real) & 
11601
23898
    :: az
11602
23899
  integer :: ii,nn
11603
23900
  az = max(abs(z1),abs(z2))
11642
23939
  private
11643
23940
  public :: update_bnlog,bnlog
11644
23941
 
11645
 
  include 'cts_mpr.h'
 
23942
  type(mp_real) & 
11646
23943
         ,allocatable,save :: coeff(:,:)
11647
 
  include 'cts_mpr.h'
 
23944
  type(mp_real) & 
11648
23945
         ,allocatable,save :: thrs(:,:,:)
11649
23946
  integer,allocatable,save :: ntrm(:,:,:)
11650
23947
  integer,parameter :: nStp=6
11651
 
  integer,parameter :: rank=2
 
23948
  integer,parameter :: rank=4
 
23949
  integer,parameter :: aCoef(0:rank,0:rank)=reshape((/ &
 
23950
                         1, 0, 0, 0, 0 & ! 1
 
23951
                       , 1, 2, 0, 0, 0 & ! 1/2,1
 
23952
                       , 2, 3, 6, 0, 0 & ! 1/3,1/2,1
 
23953
                       , 3, 4, 6,12, 0 & ! 1/4,1/3,1/2,1
 
23954
                       ,12,15,20,30,60 & ! 1/5,1/4,1/3,1/2,1
 
23955
                       /),(/rank+1,rank+1/))
11652
23956
 
11653
23957
  interface bnlog
11654
23958
    module procedure bnlog_c,bnlog_r
11660
23964
  subroutine update_bnlog
11661
23965
!***********************************************************************
11662
23966
!***********************************************************************
11663
 
  include 'cts_mpr.h'
 
23967
  type(mp_real) & 
11664
23968
    :: tt
11665
23969
  integer :: nn,ii,jj,n1,nmax,irank
11666
23970
  logical :: highestSoFar
11747
24051
!*******************************************************************
11748
24052
  integer ,intent(in) :: ncf
11749
24053
  integer :: ii,jj
11750
 
  include 'cts_mpr.h'
 
24054
  type(mp_real) & 
11751
24055
    :: fact,tt(rank)
11752
24056
!
11753
24057
  call enlarge( coeff ,2,ncf ,0,rank )
11767
24071
    coeff(ii,1) = coeff(ii,0)*(1-tt(1))
11768
24072
    if (ii.eq.3) cycle
11769
24073
    coeff(ii,2) = coeff(ii,0)*(1-2*tt(1)+tt(2))
 
24074
    if (ii.eq.4) cycle
 
24075
    coeff(ii,3) = coeff(ii,0)*(1-3*tt(1)+3*tt(2)-tt(3))
 
24076
    if (ii.eq.5) cycle
 
24077
    coeff(ii,4) = coeff(ii,0)*(1-4*tt(1)+6*tt(2)-4*tt(3)+tt(4))
11770
24078
!   if (ii.eq.n+1) cycle
11771
24079
!   coeff(ii,n) = coeff(ii,0)
11772
24080
!               * ( 1 - binom(n,1)*tt(1) + binom(n,2)*tt(2)...)
11779
24087
!*******************************************************************
11780
24088
!*******************************************************************
11781
24089
  integer ,intent(in) :: irank
11782
 
  include 'cts_mpc.h'
 
24090
  type(mp_complex) &  
11783
24091
    ,intent(in) :: xx
11784
 
  include 'cts_mpc.h'
11785
 
    :: rslt,yy
11786
 
  include 'cts_mpr.h'
 
24092
  type(mp_complex) &  
 
24093
    :: rslt,yy,omx
 
24094
  type(mp_real) & 
11787
24095
    :: aa,rex,imx
11788
24096
  integer :: ii,nn
11789
24097
!
11807
24115
  yy = olog(1-1/xx,0)
11808
24116
  aa = abs(yy)
11809
24117
  if     (aa.ge.thrs(6,irank,prcpar)) then
11810
 
    if     (irank.eq.0) then
11811
 
      rslt = (1-xx)*yy-1
11812
 
    elseif (irank.eq.1) then
11813
 
      rslt = (1-xx)*(1+xx)*yy-xx-CONE/2
11814
 
    elseif (irank.eq.2) then
11815
 
      rslt = (1-xx)*(1+(1+xx)*xx)*yy-xx*xx-xx/2-CONE/3
11816
 
    endif
 
24118
     omx = 1
 
24119
    rslt = aCoef(irank,irank)
 
24120
    do ii=irank,1,-1
 
24121
       omx = 1 + xx*omx
 
24122
      rslt = aCoef(ii-1,irank) + xx*rslt
 
24123
    enddo
 
24124
     omx = (1-xx)*omx
 
24125
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
24126
!    if     (irank.eq.0) then
 
24127
!      rslt = (1-xx)*yy - 1
 
24128
!    elseif (irank.eq.1) then
 
24129
!      rslt = (1-xx)*(1+xx)*yy - (1+xx*2)/2
 
24130
!    elseif (irank.eq.2) then
 
24131
!      rslt = (1-xx)*(1+xx*(1+xx))*yy - (2+xx*(3+xx*6))/6
 
24132
!    elseif (irank.eq.3) then
 
24133
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx)))*yy &
 
24134
!           - (3+xx*(4+xx*(6+xx*12)))/12
 
24135
!    elseif (irank.eq.4) then
 
24136
!      rslt = (1-xx)*(1+xx*(1+xx*(1+xx*(1+xx))))*yy &
 
24137
!           - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
24138
!    endif
11817
24139
    return
11818
24140
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
11819
24141
  elseif (aa.ge.thrs(4,irank,prcpar)) then ;nn=ntrm(5,irank,prcpar)
11839
24161
!*******************************************************************
11840
24162
!*******************************************************************
11841
24163
  integer ,intent(in) :: irank
11842
 
  include 'cts_mpr.h'
 
24164
  type(mp_real) & 
11843
24165
          ,intent(in) :: xx
11844
24166
  integer ,intent(in) :: sgn
11845
 
  include 'cts_mpc.h'
 
24167
  type(mp_complex) &  
11846
24168
    :: rslt
11847
 
  include 'cts_mpr.h'
 
24169
  type(mp_real) & 
11848
24170
    :: yy,aa,omx
11849
24171
  integer :: ii,nn
11850
24172
  logical :: y_lt_0
11865
24187
!
11866
24188
  yy = 1-1/xx
11867
24189
  y_lt_0 = (yy.lt.RZRO)
11868
 
  if (y_lt_0) then ;yy=log(-yy)
11869
 
              else ;yy=log( yy)
11870
 
  endif
11871
 
!
11872
 
  if     (irank.eq.0) then ;omx=1-xx
11873
 
  elseif (irank.eq.1) then ;omx=(1-xx)*(1+xx) ! 1-x^2
11874
 
  elseif (irank.eq.2) then ;omx=(1-xx)*(1+(1+xx)*xx) ! 1-x^3
11875
 
  endif
11876
 
!
11877
 
  aa = abs(yy)
 
24190
  if (y_lt_0) then 
 
24191
    yy = log(-yy)
 
24192
    aa = sqrt(yy*yy+ONEPI*ONEPI)
 
24193
  else
 
24194
    yy = log( yy)
 
24195
    aa = abs(yy)
 
24196
  endif
 
24197
!
 
24198
  omx = 1
 
24199
  do ii=irank,1,-1
 
24200
    omx = 1+xx*omx
 
24201
  enddo
 
24202
  omx = (1-xx)*omx ! (1-x^{rank+1})
 
24203
!
11878
24204
  if     (aa.ge.thrs(6,irank,prcpar)) then
11879
 
    if     (irank.eq.0) then
11880
 
      rslt = omx*yy-1
11881
 
    elseif (irank.eq.1) then
11882
 
      rslt = omx*yy-xx-RONE/2
11883
 
    elseif (irank.eq.2) then
11884
 
      rslt = omx*yy-xx*xx-xx/2-RONE/3
11885
 
    endif
 
24205
    rslt = aCoef(irank,irank)
 
24206
    do ii=irank,1,-1
 
24207
      rslt = aCoef(ii-1,irank) + xx*rslt
 
24208
    enddo
 
24209
    rslt = omx*yy - rslt/aCoef(irank,irank)
 
24210
!    if     (irank.eq.0) then
 
24211
!      rslt = omx*yy - 1
 
24212
!    elseif (irank.eq.1) then
 
24213
!      rslt = omx*yy - (1+xx*2)/2
 
24214
!    elseif (irank.eq.2) then
 
24215
!      rslt = omx*yy - (2+xx*(3+xx*6))/6
 
24216
!    elseif (irank.eq.3) then
 
24217
!      rslt = omx*yy - (3+xx*(4+xx*(6+xx*12)))/12
 
24218
!    elseif (irank.eq.4) then
 
24219
!      rslt = omx*yy - (12+xx*(15+xx*(20+xx*(30+xx*60))))/60
 
24220
!    endif
11886
24221
    if (y_lt_0) rslt = rslt + sgn*omx*IPI
11887
24222
    return
11888
24223
  elseif (aa.ge.thrs(5,irank,prcpar)) then ;nn=ntrm(6,irank,prcpar)
11918
24253
  public :: operator (*) ,operator (/)
11919
24254
 
11920
24255
  type :: qmplx_type
11921
 
  include 'cts_mpc.h'
 
24256
  type(mp_complex) &  
11922
24257
          :: c
11923
24258
  integer :: p
11924
24259
  end type
11944
24279
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
11945
24280
! sign of  sgn .
11946
24281
!*******************************************************************
11947
 
  include 'cts_mpc.h'
 
24282
  type(mp_complex) &  
11948
24283
    ,intent(in) :: xx
11949
 
  include 'cts_mpr.h'
 
24284
  type(mp_real) & 
11950
24285
    ,intent(in) :: sgn
11951
24286
  type(qmplx_type) :: rslt
11952
 
  include 'cts_mpr.h'
 
24287
  type(mp_real) & 
11953
24288
    :: xre,xim
11954
24289
  xre = areal(xx)
11955
24290
  if (xre.ge.RZRO) then
11974
24309
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz  becomes the
11975
24310
! sign of  sgn .
11976
24311
!*******************************************************************
11977
 
  include 'cts_mpc.h'
 
24312
  type(mp_complex) &  
11978
24313
    ,intent(in) :: xx
11979
24314
  integer         ,intent(in) :: sgn
11980
24315
  type(qmplx_type) :: rslt
11981
 
  include 'cts_mpr.h'
 
24316
  type(mp_real) & 
11982
24317
    :: xre,xim
11983
24318
  xre = areal(xx)
11984
24319
  if (xre.ge.RZRO) then
12002
24337
! Determine  zz,iz  such that  xx = zz*exp(iz*imag*pi)  and  Re(zz)
12003
24338
! is positive. If  Im(x)=0  and  Re(x)<0  then  iz=1
12004
24339
!*******************************************************************
12005
 
  include 'cts_mpc.h'
 
24340
  type(mp_complex) &  
12006
24341
    ,intent(in) :: xx
12007
24342
  type(qmplx_type) :: rslt
12008
 
  include 'cts_mpr.h'
 
24343
  type(mp_real) & 
12009
24344
    :: xre,xim
12010
24345
  xre = areal(xx)
12011
24346
  if (xre.ge.RZRO) then
12049
24384
  function directly(xx,ix) result(rslt)
12050
24385
!*******************************************************************
12051
24386
!*******************************************************************
12052
 
  include 'cts_mpc.h'
 
24387
  type(mp_complex) &  
12053
24388
    ,intent(in) :: xx
12054
24389
  integer         ,intent(in) :: ix
12055
24390
  type(qmplx_type) :: rslt
12072
24407
!*******************************************************************
12073
24408
  type(qmplx_type) ,intent(in) :: xx
12074
24409
  integer :: ii,jj
12075
 
  include 'cts_mpr.h'
 
24410
  type(mp_real) & 
12076
24411
    :: xim
12077
24412
  jj = mod(xx%p,2)
12078
24413
  ii = xx%p-jj
12108
24443
! the real part of  zz%c  remains positive 
12109
24444
!*******************************************************************
12110
24445
  type(qmplx_type) ,intent(in) :: yy
12111
 
  include 'cts_mpr.h'
 
24446
  type(mp_real) & 
12112
24447
    ,intent(in) :: xx
12113
24448
  type(qmplx_type) :: zz
12114
24449
  zz%c = yy%c*abs(xx)
12135
24470
!*******************************************************************
12136
24471
!*******************************************************************
12137
24472
  type(qmplx_type) ,intent(in) :: yy
12138
 
  include 'cts_mpr.h'
 
24473
  type(mp_real) & 
12139
24474
    ,intent(in) :: xx
12140
24475
  type(qmplx_type) :: zz
12141
24476
  zz%c = yy%c/abs(xx)
12148
24483
! log(xx)
12149
24484
!*******************************************************************
12150
24485
  type(qmplx_type) ,intent(in) :: xx
12151
 
  include 'cts_mpc.h'
 
24486
  type(mp_complex) &  
12152
24487
    :: rslt
12153
24488
!  rslt = olog(acmplx(xx%c),xx%p)
12154
24489
  rslt = olog(xx%c,xx%p)
12159
24494
! log(xx)/(1-xx)
12160
24495
!*******************************************************************
12161
24496
  type(qmplx_type) ,intent(in) :: xx
12162
 
  include 'cts_mpc.h'
 
24497
  type(mp_complex) &  
12163
24498
    :: rslt
12164
24499
!  rslt = -olog2(acmplx(xx%c),xx%p)
12165
24500
  rslt = -olog2(xx%c,xx%p)
12172
24507
!    /0        t
12173
24508
!*******************************************************************
12174
24509
  type(qmplx_type) ,intent(in) :: xx
12175
 
  include 'cts_mpc.h'
 
24510
  type(mp_complex) &  
12176
24511
    :: rslt
12177
24512
!  rslt = dilog(acmplx(xx%c),xx%p)
12178
24513
  rslt = dilog(xx%c,xx%p)
12183
24518
! ( li2(xx) - li2(yy) )/(xx-yy)
12184
24519
!*******************************************************************
12185
24520
  type(qmplx_type) ,intent(in) :: xx,yy
12186
 
  include 'cts_mpc.h'
 
24521
  type(mp_complex) &  
12187
24522
    :: rslt
12188
24523
!  rslt = dilog( acmplx(xx%c),xx%p ,acmplx(yy%c),yy%p )
12189
24524
!  write(*,*) 'li2c2 x:',xx%c,xx%p !DEBUG
12204
24539
  use avh_olo_mp_qmplx
12205
24540
  implicit none
12206
24541
  private
12207
 
  public :: tadp ,bub0 ,bub11
 
24542
  public :: tadp ,tadpn ,bub0 ,bub1 ,bub11 ,bub111 ,bub1111
12208
24543
 
12209
24544
contains
12210
24545
 
12212
24547
!*******************************************************************
12213
24548
! The 1-loop scalar 1-point function.
12214
24549
!*******************************************************************
12215
 
  include 'cts_mpc.h'
 
24550
  type(mp_complex) &  
12216
24551
    ,intent(out) :: rslt(0:2)
12217
 
  include 'cts_mpc.h'
 
24552
  type(mp_complex) &  
12218
24553
    ,intent(in)  :: mm
12219
 
  include 'cts_mpr.h'
 
24554
  type(mp_real) & 
12220
24555
    ,intent(in)  :: amm,rmu2
12221
24556
!
12222
24557
  rslt(2) = 0
12230
24565
  end subroutine
12231
24566
 
12232
24567
 
12233
 
  subroutine bub0( rslt ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
12234
 
!*******************************************************************
12235
 
! The 1-loop scalar 2-point function. Based on the formulas from
12236
 
! A. Denner, M. Dittmaier, Nucl.Phys. B734 (2006) 62-115
12237
 
!*******************************************************************
12238
 
  include 'cts_mpc.h'
12239
 
    ,intent(out) :: rslt(0:2)
12240
 
  include 'cts_mpc.h'
12241
 
    ,intent(in)  :: pp,m0i,m1i
12242
 
  include 'cts_mpr.h'
12243
 
    ,intent(in)  :: app,am0i,am1i,rmu2
12244
 
  include 'cts_mpc.h'
12245
 
    :: m0,m1,x1,x2,lambda
12246
 
  include 'cts_mpr.h'
12247
 
    :: am0,am1,maxm
12248
 
!
12249
 
  maxm = max(am0i,am1i)
12250
 
  if (maxm.eq.RZRO) then
12251
 
    if (app.eq.RZRO) then
12252
 
      rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
12253
 
      return
12254
 
    endif
12255
 
  endif
12256
 
!
12257
 
  if (am1i.ge.maxm) then
12258
 
    m0=m0i ;am0=am0i
12259
 
    m1=m1i ;am1=am1i
12260
 
  else
12261
 
    m0=m1i ;am0=am1i
12262
 
    m1=m0i ;am1=am0i
12263
 
  endif
12264
 
!
12265
 
  rslt(2) = 0
12266
 
  rslt(1) = 1
12267
 
!
12268
 
  if (app.eq.RZRO) then
12269
 
    if (abs(m0-m1).le.am1*EPSN*10) then
12270
 
      rslt(0) = -logc(qonv(m1/rmu2,-1))
12271
 
    else
12272
 
      x1 = (m1-am1*IEPS)/(m1-m0)
12273
 
      rslt(0) = -logc(qonv(m1/rmu2,-1)) - bnlog(0,x1)
12274
 
    endif
12275
 
  elseif (am0.eq.RZRO) then
12276
 
    if (abs(pp-m1).le.am1*EPSN*10) then
12277
 
      rslt(0) = 2 - logc(qonv(m1/rmu2,-1))
12278
 
    else
12279
 
      x1 = (pp-m1+am1*IEPS)/pp
12280
 
      rslt(0) = 1 - logc(qonv((m1-pp)/rmu2,-1)) - bnlog(0,x1)
12281
 
    endif
12282
 
  else
12283
 
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
12284
 
    rslt(0) = -logc(qonv(m0/rmu2,-1)) - bnlog(0,x1) - bnlog(0,x2)
12285
 
  endif
12286
 
!
 
24568
  subroutine tadpn( rslt ,rank ,mm ,amm ,rmu2 )
 
24569
!*******************************************************************
 
24570
! The 1-loop tensor 1-point functions.
 
24571
!   rslt(:,0) = A0
 
24572
!   rslt(:,1) = A00
 
24573
!   rslt(:,2) = A0000  etc.
 
24574
! For input  rank  only  rslt(:,0:rank/2)  is filled.
 
24575
!*******************************************************************
 
24576
  type(mp_complex) &  
 
24577
    ,intent(out) :: rslt(0:,0:)
 
24578
  type(mp_complex) &  
 
24579
    ,intent(in)  :: mm
 
24580
  type(mp_real) & 
 
24581
    ,intent(in)  :: amm,rmu2
 
24582
  integer ,intent(in) :: rank
 
24583
  type(mp_complex) &  
 
24584
    :: aa
 
24585
  type(mp_real) & 
 
24586
    :: bb
 
24587
  integer :: ii
 
24588
!
 
24589
  do ii=0,rank
 
24590
    rslt(2,ii) = 0
 
24591
    rslt(1,ii) = 0
 
24592
    rslt(0,ii) = 0
 
24593
  enddo
 
24594
  if (amm.eq.RZRO.or.mm.eq.CZRO) then
 
24595
    return
 
24596
  else
 
24597
    rslt(1,0) = mm
 
24598
    rslt(0,0) = mm - mm*logc( qonv(mm/rmu2,-1) )
 
24599
    aa = 1
 
24600
    bb = 0
 
24601
    do ii=1,rank/2
 
24602
      aa = aa*mm/(2*(ii+1))
 
24603
      bb = bb + RONE/(ii+1)
 
24604
      rslt(1,ii) = aa*( rslt(1,0) )
 
24605
      rslt(0,ii) = aa*( rslt(0,0) + mm*bb )
 
24606
    enddo
 
24607
  endif
12287
24608
  end subroutine
12288
24609
 
12289
24610
 
12290
 
  subroutine bub11( b11,b00,b1,b0 ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
12291
24611
!*******************************************************************
12292
 
! Return the Passarino-Veltman functions b11,b00,b1,b0 , for
 
24612
! Return the Passarino-Veltman functions
12293
24613
!
12294
24614
!      C   /      d^(Dim)q
12295
24615
!   ------ | -------------------- = b0
12303
24623
!   ------ | -------------------- = g^{mu,nu} b00 + p^mu p^nu b11
12304
24624
!   i*pi^2 / [q^2-m0][(q+p)^2-m1]
12305
24625
!
 
24626
!   etc.
 
24627
!
12306
24628
! Based on the formulas from
12307
24629
! A. Denner, M. Dittmaier, Nucl.Phys. B734 (2006) 62-115
12308
24630
!*******************************************************************
12309
 
  include 'cts_mpc.h'
 
24631
 
 
24632
  subroutine bub0( b0 &
 
24633
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
24634
  type(mp_complex) &  
 
24635
    ,intent(out) :: b0(0:2)
 
24636
  type(mp_complex) &  
 
24637
    ,intent(in)  :: pp,m0i,m1i
 
24638
  type(mp_real) & 
 
24639
    ,intent(in)  :: app,am0i,am1i,rmu2
 
24640
  type(mp_complex) &  
 
24641
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
24642
  type(mp_real) & 
 
24643
    :: am0,am1,maxm
 
24644
  integer :: rank
 
24645
!
 
24646
  maxm = max(am0i,am1i)
 
24647
  if (maxm.eq.RZRO) then
 
24648
    if (app.eq.RZRO) then
 
24649
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
24650
      return
 
24651
    endif
 
24652
  endif
 
24653
!
 
24654
  if (am1i.ge.maxm) then
 
24655
    m0=m0i ;am0=am0i
 
24656
    m1=m1i ;am1=am1i
 
24657
  else
 
24658
    m0=m1i ;am0=am1i
 
24659
    m1=m0i ;am1=am0i
 
24660
  endif
 
24661
!
 
24662
  b0(2) = 0
 
24663
  b0(1) = CONE
 
24664
!
 
24665
  if (app.eq.RZRO) then
 
24666
    if (abs(m0-m1).le.am1*EPSN*10) then
 
24667
      lna = -logc(qonv(m1/rmu2,-1))
 
24668
      b0(0) = lna
 
24669
    else
 
24670
      lna = -logc(qonv(m1/rmu2,-1))
 
24671
      x1 = (m1-am1*IEPS)/(m1-m0)
 
24672
      b0(0) =   lna - bnlog(0,x1)
 
24673
    endif
 
24674
  elseif (am0.eq.RZRO) then
 
24675
    if (abs(pp-m1).le.am1*EPSN*10) then
 
24676
      lna = -logc(qonv(m1/rmu2,-1))
 
24677
      b0(0) = ( lna   + 2 )
 
24678
    else
 
24679
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
24680
      x1  = (pp-m1+am1*IEPS)/pp
 
24681
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
24682
    endif
 
24683
  else
 
24684
    lna = -logc(qonv(m0/rmu2,-1))
 
24685
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
24686
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
24687
  endif
 
24688
!
 
24689
  end subroutine
 
24690
 
 
24691
  subroutine bub1( b1,b0 &
 
24692
                  ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
24693
  type(mp_complex) &  
 
24694
    ,intent(out) :: b1(0:2),b0(0:2)
 
24695
  type(mp_complex) &  
 
24696
    ,intent(in)  :: pp,m0i,m1i
 
24697
  type(mp_real) & 
 
24698
    ,intent(in)  :: app,am0i,am1i,rmu2
 
24699
  type(mp_complex) &  
 
24700
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
24701
  type(mp_real) & 
 
24702
    :: am0,am1,maxm
 
24703
  logical :: switch 
 
24704
  integer :: rank
 
24705
!
 
24706
  maxm = max(am0i,am1i)
 
24707
  if (maxm.eq.RZRO) then
 
24708
    if (app.eq.RZRO) then
 
24709
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
24710
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
24711
      return
 
24712
    endif
 
24713
  endif
 
24714
!
 
24715
  if (am1i.ge.maxm) then
 
24716
    m0=m0i ;am0=am0i
 
24717
    m1=m1i ;am1=am1i
 
24718
    switch = .false. 
 
24719
  else
 
24720
    m0=m1i ;am0=am1i
 
24721
    m1=m0i ;am1=am0i
 
24722
    switch = .true. 
 
24723
  endif
 
24724
!
 
24725
  b0(2) = 0
 
24726
  b0(1) = CONE
 
24727
  b1(2) = 0      
 
24728
  b1(1) =-CONE/2 
 
24729
!
 
24730
  if (app.eq.RZRO) then
 
24731
    if (abs(m0-m1).le.am1*EPSN*10) then
 
24732
      lna = -logc(qonv(m1/rmu2,-1))
 
24733
      b0(0) = lna
 
24734
      b1(0) =-lna/2 
 
24735
    else
 
24736
      lna = -logc(qonv(m1/rmu2,-1))
 
24737
      x1 = (m1-am1*IEPS)/(m1-m0)
 
24738
      b0(0) =   lna - bnlog(0,x1)
 
24739
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
24740
    endif
 
24741
    if (switch) then
 
24742
      x2=m0;m0=m1;m1=x2
 
24743
    else
 
24744
      b1(0) =-b0(0)-b1(0)
 
24745
    endif
 
24746
  elseif (am0.eq.RZRO) then
 
24747
    if (abs(pp-m1).le.am1*EPSN*10) then
 
24748
      lna = -logc(qonv(m1/rmu2,-1))
 
24749
      b0(0) = ( lna   + 2 )
 
24750
      b1(0) =-( lna*2 + 2 )/4 
 
24751
    else
 
24752
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
24753
      x1  = (pp-m1+am1*IEPS)/pp
 
24754
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
24755
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
24756
    endif
 
24757
    if (switch) then
 
24758
      x2=m0;m0=m1;m1=x2
 
24759
      b1(0) =-b0(0)-b1(0)
 
24760
    endif
 
24761
  else
 
24762
    lna = -logc(qonv(m0/rmu2,-1))
 
24763
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
24764
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
24765
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
24766
    if (switch) then
 
24767
      x2=m0;m0=m1;m1=x2
 
24768
      b1(0) =-b0(0)-b1(0)
 
24769
    endif
 
24770
  endif
 
24771
!
 
24772
  end subroutine
 
24773
 
 
24774
  subroutine bub11( b11,b00,b1,b0 &
 
24775
                   ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
24776
  type(mp_complex) &  
12310
24777
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
12311
 
  include 'cts_mpc.h'
12312
 
    ,intent(in)  :: pp,m0i,m1i
12313
 
  include 'cts_mpr.h'
12314
 
    ,intent(in)  :: app,am0i,am1i,rmu2
12315
 
  include 'cts_mpc.h'
12316
 
    :: m0,m1,a0(0:2),lna,x1,x2,lambda
12317
 
  include 'cts_mpr.h'
12318
 
    :: am0,am1,maxm
12319
 
  logical :: switch
12320
 
!
12321
 
  maxm = max(am0i,am1i)
12322
 
  if (maxm.eq.RZRO) then
12323
 
    if (app.eq.RZRO) then
12324
 
       b0(0)=0 ; b0(1)=0 ; b0(2)=0
12325
 
       b1(0)=0 ; b1(1)=0 ; b1(2)=0
12326
 
      b00(0)=0 ;b00(1)=0 ;b00(2)=0
12327
 
      b11(0)=0 ;b11(1)=0 ;b11(2)=0
12328
 
      return
12329
 
    endif
12330
 
  endif
12331
 
!
12332
 
  if (am1i.ge.maxm) then
12333
 
    m0=m0i ;am0=am0i
12334
 
    m1=m1i ;am1=am1i
12335
 
    switch = .false.
12336
 
  else
12337
 
    m0=m1i ;am0=am1i
12338
 
    m1=m0i ;am1=am0i
12339
 
    switch = .true.
12340
 
  endif
12341
 
!
12342
 
  b0(2)  = 0
12343
 
  b1(2)  = 0
12344
 
  b11(2) = 0
12345
 
  b0(1)  = 1
12346
 
  b1(1)  =-CONE/2
12347
 
  b11(1) = CONE/3
12348
 
!
12349
 
  if (app.eq.RZRO) then
12350
 
    if (abs(m0-m1).le.am1*EPSN*10) then
12351
 
      lna = -logc(qonv(m1/rmu2,-1))
12352
 
      b0(0)  = lna
12353
 
      b1(0)  =-lna/2
12354
 
      b11(0) = lna/3
12355
 
    else
12356
 
      lna = -logc(qonv(m1/rmu2,-1))
12357
 
      x1 = (m1-am1*IEPS)/(m1-m0)
12358
 
      b0(0)  =   lna - bnlog(0,x1)
12359
 
      b1(0)  =-( lna - bnlog(1,x1) )/2
12360
 
      b11(0) = ( lna - bnlog(2,x1) )/3
12361
 
    endif
12362
 
    if (switch) then
12363
 
      x2=m0;m0=m1;m1=x2
12364
 
    else
12365
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
12366
 
      b1(0) = -b0(0)-b1(0)
12367
 
    endif
12368
 
  elseif (am0.eq.RZRO) then
12369
 
    if (abs(pp-m1).le.am1*EPSN*10) then
12370
 
      lna = -logc(qonv(m1/rmu2,-1))
12371
 
      b0(0)  = ( lna + 2*CONE   )
12372
 
      b1(0)  =-( lna +   CONE   )/2
12373
 
      b11(0) = ( lna + 2*CONE/3 )/3
12374
 
    else
12375
 
      lna = -logc(qonv((m1-pp)/rmu2,-1))
12376
 
      x1  = (pp-m1+am1*IEPS)/pp
12377
 
      b0(0)  = ( lna - bnlog(0,x1) + CONE   )
12378
 
      b1(0)  =-( lna - bnlog(1,x1) + CONE/2 )/2
12379
 
      b11(0) = ( lna - bnlog(2,x1) + CONE/3 )/3
12380
 
    endif
12381
 
    if (switch) then
12382
 
      x2=m0;m0=m1;m1=x2
12383
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
12384
 
      b1(0) = -b0(0)-b1(0)
12385
 
    endif
12386
 
  else
12387
 
    lna = -logc(qonv(m0/rmu2,-1))
12388
 
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
12389
 
    b0(0)  = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
12390
 
    b1(0)  =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
12391
 
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
12392
 
    if (switch) then
12393
 
      x2=m0;m0=m1;m1=x2
12394
 
      b11(0) = b11(0) + 2*b1(0) + b0(0) 
12395
 
      b1(0) = -b0(0)-b1(0)
12396
 
    endif
12397
 
  endif
12398
 
!
12399
 
  call tadp( a0 ,m1 ,am1 ,rmu2 )
12400
 
  b00(2) = 0
12401
 
  b00(1) = m0 + m1 - pp/3
12402
 
  b00(0) = ( a0(0) - ((m1-m0)-pp)*b1(0) + 2*m0*b0(0) + b00(1) )/6
12403
 
  b00(1) = b00(1)/4
12404
 
!
 
24778
  type(mp_complex) &  
 
24779
    ,intent(in)  :: pp,m0i,m1i
 
24780
  type(mp_real) & 
 
24781
    ,intent(in)  :: app,am0i,am1i,rmu2
 
24782
  type(mp_complex) &  
 
24783
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
24784
  type(mp_real) & 
 
24785
    :: am0,am1,maxm
 
24786
  logical :: switch 
 
24787
  integer :: rank
 
24788
!
 
24789
  maxm = max(am0i,am1i)
 
24790
  if (maxm.eq.RZRO) then
 
24791
    if (app.eq.RZRO) then
 
24792
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
24793
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
24794
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
24795
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
24796
      return
 
24797
    endif
 
24798
  endif
 
24799
!
 
24800
  if (am1i.ge.maxm) then
 
24801
    m0=m0i ;am0=am0i
 
24802
    m1=m1i ;am1=am1i
 
24803
    switch = .false. 
 
24804
  else
 
24805
    m0=m1i ;am0=am1i
 
24806
    m1=m0i ;am1=am0i
 
24807
    switch = .true. 
 
24808
  endif
 
24809
!
 
24810
  b0(2) = 0
 
24811
  b0(1) = CONE
 
24812
  b1(2) = 0      
 
24813
  b1(1) =-CONE/2 
 
24814
  b11(2) = 0      
 
24815
  b11(1) = CONE/3 
 
24816
!
 
24817
  if (app.eq.RZRO) then
 
24818
    if (abs(m0-m1).le.am1*EPSN*10) then
 
24819
      lna = -logc(qonv(m1/rmu2,-1))
 
24820
      b0(0) = lna
 
24821
      b1(0) =-lna/2 
 
24822
      b11(0) = lna/3 
 
24823
    else
 
24824
      lna = -logc(qonv(m1/rmu2,-1))
 
24825
      x1 = (m1-am1*IEPS)/(m1-m0)
 
24826
      b0(0) =   lna - bnlog(0,x1)
 
24827
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
24828
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
24829
    endif
 
24830
    if (switch) then
 
24831
      x2=m0;m0=m1;m1=x2
 
24832
    else
 
24833
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24834
      b1(0) =-b0(0)-b1(0)
 
24835
    endif
 
24836
  elseif (am0.eq.RZRO) then
 
24837
    if (abs(pp-m1).le.am1*EPSN*10) then
 
24838
      lna = -logc(qonv(m1/rmu2,-1))
 
24839
      b0(0) = ( lna   + 2 )
 
24840
      b1(0) =-( lna*2 + 2 )/4 
 
24841
      b11(0) = ( lna*3 + 2 )/9 
 
24842
    else
 
24843
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
24844
      x1  = (pp-m1+am1*IEPS)/pp
 
24845
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
24846
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
24847
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
24848
    endif
 
24849
    if (switch) then
 
24850
      x2=m0;m0=m1;m1=x2
 
24851
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24852
      b1(0) =-b0(0)-b1(0)
 
24853
    endif
 
24854
  else
 
24855
    lna = -logc(qonv(m0/rmu2,-1))
 
24856
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
24857
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
24858
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
24859
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
24860
    if (switch) then
 
24861
      x2=m0;m0=m1;m1=x2
 
24862
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24863
      b1(0) =-b0(0)-b1(0)
 
24864
    endif
 
24865
  endif
 
24866
!
 
24867
  rank = 0 
 
24868
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
24869
  x1 = (m1-m0)-pp
 
24870
  x2 = 2*m0
 
24871
  b00(2) = 0
 
24872
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
24873
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
24874
  end subroutine
 
24875
 
 
24876
  subroutine bub111( b111,b001,b11,b00,b1,b0 &
 
24877
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
24878
  type(mp_complex) &  
 
24879
    ,intent(out) :: b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
24880
  type(mp_complex) &  
 
24881
    ,intent(in)  :: pp,m0i,m1i
 
24882
  type(mp_real) & 
 
24883
    ,intent(in)  :: app,am0i,am1i,rmu2
 
24884
  type(mp_complex) &  
 
24885
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
24886
  type(mp_real) & 
 
24887
    :: am0,am1,maxm
 
24888
  logical :: switch 
 
24889
  integer :: rank
 
24890
!
 
24891
  maxm = max(am0i,am1i)
 
24892
  if (maxm.eq.RZRO) then
 
24893
    if (app.eq.RZRO) then
 
24894
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
24895
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
24896
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
24897
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
24898
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
24899
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
24900
      return
 
24901
    endif
 
24902
  endif
 
24903
!
 
24904
  if (am1i.ge.maxm) then
 
24905
    m0=m0i ;am0=am0i
 
24906
    m1=m1i ;am1=am1i
 
24907
    switch = .false. 
 
24908
  else
 
24909
    m0=m1i ;am0=am1i
 
24910
    m1=m0i ;am1=am0i
 
24911
    switch = .true. 
 
24912
  endif
 
24913
!
 
24914
  b0(2) = 0
 
24915
  b0(1) = CONE
 
24916
  b1(2) = 0      
 
24917
  b1(1) =-CONE/2 
 
24918
  b11(2) = 0      
 
24919
  b11(1) = CONE/3 
 
24920
  b111(2) = 0      
 
24921
  b111(1) =-CONE/4 
 
24922
!
 
24923
  if (app.eq.RZRO) then
 
24924
    if (abs(m0-m1).le.am1*EPSN*10) then
 
24925
      lna = -logc(qonv(m1/rmu2,-1))
 
24926
      b0(0) = lna
 
24927
      b1(0) =-lna/2 
 
24928
      b11(0) = lna/3 
 
24929
      b111(0) =-lna/4 
 
24930
    else
 
24931
      lna = -logc(qonv(m1/rmu2,-1))
 
24932
      x1 = (m1-am1*IEPS)/(m1-m0)
 
24933
      b0(0) =   lna - bnlog(0,x1)
 
24934
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
24935
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
24936
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
24937
    endif
 
24938
    if (switch) then
 
24939
      x2=m0;m0=m1;m1=x2
 
24940
    else
 
24941
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
24942
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24943
      b1(0) =-b0(0)-b1(0)
 
24944
    endif
 
24945
  elseif (am0.eq.RZRO) then
 
24946
    if (abs(pp-m1).le.am1*EPSN*10) then
 
24947
      lna = -logc(qonv(m1/rmu2,-1))
 
24948
      b0(0) = ( lna   + 2 )
 
24949
      b1(0) =-( lna*2 + 2 )/4 
 
24950
      b11(0) = ( lna*3 + 2 )/9 
 
24951
      b111(0) =-( lna*4 + 2 )/16 
 
24952
    else
 
24953
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
24954
      x1  = (pp-m1+am1*IEPS)/pp
 
24955
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
24956
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
24957
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
24958
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
24959
    endif
 
24960
    if (switch) then
 
24961
      x2=m0;m0=m1;m1=x2
 
24962
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
24963
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24964
      b1(0) =-b0(0)-b1(0)
 
24965
    endif
 
24966
  else
 
24967
    lna = -logc(qonv(m0/rmu2,-1))
 
24968
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
24969
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
24970
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
24971
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
24972
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
24973
    if (switch) then
 
24974
      x2=m0;m0=m1;m1=x2
 
24975
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
24976
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
24977
      b1(0) =-b0(0)-b1(0)
 
24978
    endif
 
24979
  endif
 
24980
!
 
24981
  rank = 0 
 
24982
  rank = 1 
 
24983
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
24984
  x1 = (m1-m0)-pp
 
24985
  x2 = 2*m0
 
24986
  b00(2) = 0
 
24987
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
24988
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
24989
  b001(2) = 0
 
24990
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
24991
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
24992
  end subroutine
 
24993
 
 
24994
  subroutine bub1111( b1111,b0011,b0000,b111,b001,b11,b00,b1,b0 &
 
24995
                    ,pp,m0i,m1i ,app,am0i,am1i ,rmu2 )
 
24996
  type(mp_complex) &  
 
24997
    ,intent(out) :: b1111(0:2),b0011(0:2),b0000(0:2) &
 
24998
                   ,b111(0:2),b001(0:2),b11(0:2),b00(0:2),b1(0:2),b0(0:2)
 
24999
  type(mp_complex) &  
 
25000
    ,intent(in)  :: pp,m0i,m1i
 
25001
  type(mp_real) & 
 
25002
    ,intent(in)  :: app,am0i,am1i,rmu2
 
25003
  type(mp_complex) &  
 
25004
    :: m0,m1,a0(0:2,0:1),lna,x1,x2,lambda
 
25005
  type(mp_real) & 
 
25006
    :: am0,am1,maxm
 
25007
  logical :: switch 
 
25008
  integer :: rank
 
25009
!
 
25010
  maxm = max(am0i,am1i)
 
25011
  if (maxm.eq.RZRO) then
 
25012
    if (app.eq.RZRO) then
 
25013
      b0(0)=0 ;b0(1)=0 ;b0(2)=0
 
25014
      b1(0)=0 ;b1(1)=0 ;b1(2)=0 
 
25015
      b00(0)=0 ;b00(1)=0 ;b00(2)=0 
 
25016
      b11(0)=0 ;b11(1)=0 ;b11(2)=0 
 
25017
      b001(0)=0 ;b001(1)=0 ;b001(2)=0 
 
25018
      b111(0)=0 ;b111(1)=0 ;b111(2)=0 
 
25019
      b0000(0)=0 ;b0000(1)=0 ;b0000(2)=0 
 
25020
      b0011(0)=0 ;b0011(1)=0 ;b0011(2)=0 
 
25021
      b1111(0)=0 ;b1111(1)=0 ;b1111(2)=0 
 
25022
      return
 
25023
    endif
 
25024
  endif
 
25025
!
 
25026
  if (am1i.ge.maxm) then
 
25027
    m0=m0i ;am0=am0i
 
25028
    m1=m1i ;am1=am1i
 
25029
    switch = .false. 
 
25030
  else
 
25031
    m0=m1i ;am0=am1i
 
25032
    m1=m0i ;am1=am0i
 
25033
    switch = .true. 
 
25034
  endif
 
25035
!
 
25036
  b0(2) = 0
 
25037
  b0(1) = CONE
 
25038
  b1(2) = 0      
 
25039
  b1(1) =-CONE/2 
 
25040
  b11(2) = 0      
 
25041
  b11(1) = CONE/3 
 
25042
  b111(2) = 0      
 
25043
  b111(1) =-CONE/4 
 
25044
  b1111(2) = 0      
 
25045
  b1111(1) = CONE/5 
 
25046
!
 
25047
  if (app.eq.RZRO) then
 
25048
    if (abs(m0-m1).le.am1*EPSN*10) then
 
25049
      lna = -logc(qonv(m1/rmu2,-1))
 
25050
      b0(0) = lna
 
25051
      b1(0) =-lna/2 
 
25052
      b11(0) = lna/3 
 
25053
      b111(0) =-lna/4 
 
25054
      b1111(0) = lna/5 
 
25055
    else
 
25056
      lna = -logc(qonv(m1/rmu2,-1))
 
25057
      x1 = (m1-am1*IEPS)/(m1-m0)
 
25058
      b0(0) =   lna - bnlog(0,x1)
 
25059
      b1(0) =-( lna - bnlog(1,x1) )/2 
 
25060
      b11(0) = ( lna - bnlog(2,x1) )/3 
 
25061
      b111(0) =-( lna - bnlog(3,x1) )/4 
 
25062
      b1111(0) = ( lna - bnlog(4,x1) )/5 
 
25063
    endif
 
25064
    if (switch) then
 
25065
      x2=m0;m0=m1;m1=x2
 
25066
    else
 
25067
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
25068
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
25069
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
25070
      b1(0) =-b0(0)-b1(0)
 
25071
    endif
 
25072
  elseif (am0.eq.RZRO) then
 
25073
    if (abs(pp-m1).le.am1*EPSN*10) then
 
25074
      lna = -logc(qonv(m1/rmu2,-1))
 
25075
      b0(0) = ( lna   + 2 )
 
25076
      b1(0) =-( lna*2 + 2 )/4 
 
25077
      b11(0) = ( lna*3 + 2 )/9 
 
25078
      b111(0) =-( lna*4 + 2 )/16 
 
25079
      b1111(0) = ( lna*5 + 2 )/25 
 
25080
    else
 
25081
      lna = -logc(qonv((m1-pp)/rmu2,-1))
 
25082
      x1  = (pp-m1+am1*IEPS)/pp
 
25083
      b0(0) = ( lna-bnlog(0,x1) + 1 )
 
25084
      b1(0) =-( (lna-bnlog(1,x1))*2 + 1 )/4 
 
25085
      b11(0) = ( (lna-bnlog(2,x1))*3 + 1 )/9 
 
25086
      b111(0) =-( (lna-bnlog(3,x1))*4 + 1 )/16 
 
25087
      b1111(0) = ( (lna-bnlog(4,x1))*5 + 1 )/25 
 
25088
    endif
 
25089
    if (switch) then
 
25090
      x2=m0;m0=m1;m1=x2
 
25091
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
25092
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
25093
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
25094
      b1(0) =-b0(0)-b1(0)
 
25095
    endif
 
25096
  else
 
25097
    lna = -logc(qonv(m0/rmu2,-1))
 
25098
    call solabc( x1,x2 ,lambda ,pp ,(m1-m0)-pp ,m0-am0*IEPS ,0 )
 
25099
    b0(0) = ( lna - bnlog(0,x1) - bnlog(0,x2) ) 
 
25100
    b1(0) =-( lna - bnlog(1,x1) - bnlog(1,x2) )/2 
 
25101
    b11(0) = ( lna - bnlog(2,x1) - bnlog(2,x2) )/3 
 
25102
    b111(0) =-( lna - bnlog(3,x1) - bnlog(3,x2) )/4 
 
25103
    b1111(0) = ( lna - bnlog(4,x1) - bnlog(4,x2) )/5 
 
25104
    if (switch) then
 
25105
      x2=m0;m0=m1;m1=x2
 
25106
      b1111(0) =-b1111(0)-4*b111(0)-6*b11(0)-4*b1(0)-b0(0) 
 
25107
      b111(0) =-b111(0)-3*b11(0)-3*b1(0)-b0(0) 
 
25108
      b11(0) = b11(0)+2*b1(0)+b0(0) 
 
25109
      b1(0) =-b0(0)-b1(0)
 
25110
    endif
 
25111
  endif
 
25112
!
 
25113
  rank = 0 
 
25114
  rank = 1 
 
25115
  rank = 2 
 
25116
  call tadpn( a0 ,rank ,m1 ,am1 ,rmu2 )
 
25117
  x1 = (m1-m0)-pp
 
25118
  x2 = 2*m0
 
25119
  b00(2) = 0
 
25120
  b00(1) = ( a0(1,0) - x1*b1(1) + x2*b0(1) )/6
 
25121
  b00(0) = ( a0(0,0) - x1*b1(0) + x2*b0(0) + 4*b00(1) )/6
 
25122
  b001(2) = 0
 
25123
  b001(1) = (-a0(1,0) - x1*b11(1) + x2*b1(1) )/8
 
25124
  b001(0) = (-a0(0,0) - x1*b11(0) + x2*b1(0) + 4*b001(1) )/8
 
25125
  b0000(2) = 0
 
25126
  b0000(1) = ( a0(1,1) - x1*b001(1) + x2*b00(1) )/10
 
25127
  b0000(0) = ( a0(0,1) - x1*b001(0) + x2*b00(0) + 4*b0000(1) )/10
 
25128
  b0011(2) = 0
 
25129
  b0011(1) = ( a0(1,0) - x1*b111(1) + x2*b11(1) )/10
 
25130
  b0011(0) = ( a0(0,0) - x1*b111(0) + x2*b11(0) + 4*b0011(1) )/10
12405
25131
  end subroutine
12406
25132
 
12407
25133
end module
12442
25168
! with  k1^2=m2, k2^2=pp, (k1+k2)^2=m3.
12443
25169
! m2,m3 should NOT be identically 0d0.
12444
25170
!*******************************************************************
12445
 
  include 'cts_mpc.h'
 
25171
  type(mp_complex) &  
12446
25172
     ,intent(out) :: rslt(0:2)
12447
 
  include 'cts_mpc.h'
 
25173
  type(mp_complex) &  
12448
25174
     ,intent(in)  :: cm2,cm3,cpp
12449
 
  include 'cts_mpr.h'
 
25175
  type(mp_real) & 
12450
25176
     ,intent(in)  :: rmu2
12451
25177
   type(qmplx_type) :: q23,qm3,q32
12452
 
  include 'cts_mpc.h'
 
25178
  type(mp_complex) &  
12453
25179
     :: sm2,sm3,k23,r23,d23,cc
12454
25180
!
12455
25181
   sm2 = mysqrt(cm2)
12486
25212
! mm should NOT be identically 0d0,
12487
25213
! and p2 NOR p3 should be identical to mm. 
12488
25214
!*******************************************************************
12489
 
  include 'cts_mpc.h'
 
25215
  type(mp_complex) &  
12490
25216
     ,intent(out) :: rslt(0:2)
12491
 
  include 'cts_mpc.h'
 
25217
  type(mp_complex) &  
12492
25218
     ,intent(in)  :: cp2,cp3,cm3
12493
 
  include 'cts_mpr.h'
 
25219
  type(mp_real) & 
12494
25220
     ,intent(in)  :: rmu2
12495
25221
   type(qmplx_type) :: q13,q23,qm3,x1,x2
12496
 
  include 'cts_mpc.h'
 
25222
  type(mp_complex) &  
12497
25223
     :: r13,r23
12498
25224
!
12499
25225
   r13 = cm3-cp3
12521
25247
! mm should NOT be identically 0d0,
12522
25248
! and pp should NOT be identical to mm. 
12523
25249
!*******************************************************************
12524
 
  include 'cts_mpc.h'
 
25250
  type(mp_complex) &  
12525
25251
     ,intent(out) :: rslt(0:2)
12526
 
  include 'cts_mpc.h'
 
25252
  type(mp_complex) &  
12527
25253
     ,intent(in)  :: cp3,cm3
12528
 
  include 'cts_mpr.h'
 
25254
  type(mp_real) & 
12529
25255
     ,intent(in)  :: rmu2
12530
25256
   type(qmplx_type) :: q13,qm3,qxx
12531
 
  include 'cts_mpc.h'
 
25257
  type(mp_complex) &  
12532
25258
     :: r13,logm,z2,z1,z0,cc
12533
25259
!
12534
25260
   r13 = cm3-cp3
12557
25283
! with  k1^2 = (k1+k2)^2 = m3.
12558
25284
! mm should NOT be identically 0d0.
12559
25285
!*******************************************************************
12560
 
  include 'cts_mpc.h'
 
25286
  type(mp_complex) &  
12561
25287
     ,intent(out) :: rslt(0:2)
12562
 
  include 'cts_mpc.h'
 
25288
  type(mp_complex) &  
12563
25289
     ,intent(in)  :: cm3
12564
 
  include 'cts_mpr.h'
 
25290
  type(mp_real) & 
12565
25291
     ,intent(in)  :: rmu2
12566
 
  include 'cts_mpc.h'
 
25292
  type(mp_complex) &  
12567
25293
     :: zm
12568
25294
!
12569
25295
   zm = 1/(2*cm3)
12592
25318
! IR-singular case is returned.
12593
25319
!*******************************************************************
12594
25320
   use avh_olo_mp_olog
12595
 
  include 'cts_mpc.h'
 
25321
  type(mp_complex) &  
12596
25322
     ,intent(out) :: rslt(0:2)
12597
 
  include 'cts_mpc.h'
 
25323
  type(mp_complex) &  
12598
25324
     ,intent(in)  :: cp(3)
12599
 
  include 'cts_mpr.h'
 
25325
  type(mp_real) & 
12600
25326
     ,intent(in)  :: ap(3),rmu2
12601
 
  include 'cts_mpr.h'
 
25327
  type(mp_real) & 
12602
25328
     :: pp(3),rp1,rp2,rp3
12603
 
  include 'cts_mpc.h'
 
25329
  type(mp_complex) &  
12604
25330
     :: log2,log3
12605
25331
   integer :: icase,i1,i2,i3
12606
25332
!
12653
25379
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
12654
25380
! by sending one internal mass to infinity.
12655
25381
!*******************************************************************
12656
 
  include 'cts_mpc.h'
 
25382
  type(mp_complex) &  
12657
25383
     ,intent(out) :: rslt(0:2)
12658
 
  include 'cts_mpc.h'
 
25384
  type(mp_complex) &  
12659
25385
     ,intent(in)  :: p1,p2,p3
12660
25386
   type(qmplx_type) :: q23,q24,q34,qx1,qx2
12661
 
  include 'cts_mpc.h'
 
25387
  type(mp_complex) &  
12662
25388
     :: r23,r24,r34,aa,bb,cc,dd,x1,x2
12663
 
  include 'cts_mpr.h'
 
25389
  type(mp_real) & 
12664
25390
     :: hh
12665
25391
!
12666
25392
   r23 = -p1
12700
25426
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
12701
25427
! by sending one internal mass to infinity.
12702
25428
!*******************************************************************
12703
 
  include 'cts_mpc.h'
 
25429
  type(mp_complex) &  
12704
25430
     ,intent(out) :: rslt(0:2)
12705
 
  include 'cts_mpc.h'
 
25431
  type(mp_complex) &  
12706
25432
     ,intent(in)  :: p1i,p2i,p3i ,m3i 
12707
25433
   type(qmplx_type) :: q23,q24,q34,qm4,qx1,qx2,qss
12708
 
  include 'cts_mpc.h'
 
25434
  type(mp_complex) &  
12709
25435
     :: p2,p3,p4,p12,p23,m4,sm2,sm3,sm4 &
12710
25436
                     ,aa,bb,cc,dd,x1,x2,r23,r24,r34
12711
 
  include 'cts_mpr.h'
 
25437
  type(mp_real) & 
12712
25438
     :: mhh
 
25439
   logical :: r24Not0,r34Not0
12713
25440
!
12714
25441
!   p1 = nul
12715
25442
   p2 = p1i
12727
25454
   sm3 = mhh
12728
25455
   sm2 = sm3
12729
25456
!
12730
 
   r24 = 0
12731
 
   r34 = 0
12732
 
                  r23 = (   -p2 -p2 *IEPS )/(sm2*sm3)
12733
 
   if (m4.ne.p23) r24 = ( m4-p23-p23*IEPS )/(sm2*sm4)
12734
 
   if (m4.ne.p3 ) r34 = ( m4-p3 -p3 *IEPS )/(sm3*sm4)     
 
25457
   r23 = (   -p2 -p2 *IEPS )/(sm2*sm3)
 
25458
   r24 = ( m4-p23-p23*IEPS )/(sm2*sm4)
 
25459
   r34 = ( m4-p3 -p3 *IEPS )/(sm3*sm4)
 
25460
!
 
25461
   r24Not0 = (abs(areal(r24))+abs(aimag(r24)).ge.neglig(prcpar))
 
25462
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
12735
25463
!
12736
25464
   aa = r34*r24 - r23
12737
25465
!
12762
25490
   rslt(0) = -logc2( qx1/qx2 )*logc( qx1*qx2/(qm4*qm4) )/(x2*2) &
12763
25491
             -li2c2( qx1*qm4 ,qx2*qm4 )*sm4
12764
25492
!
12765
 
   if (r34.ne.CZRO) then
 
25493
   if (r34Not0) then
12766
25494
     qss = q34*mhh
12767
25495
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
12768
25496
   endif
12769
25497
!
12770
 
   if (r24.ne.CZRO) then
 
25498
   if (r24Not0) then
12771
25499
     qss = q24*mhh
12772
25500
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r24*sm2
12773
25501
   endif
12785
25513
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
12786
25514
! by sending one internal mass to infinity.
12787
25515
!*******************************************************************
12788
 
  include 'cts_mpc.h'
 
25516
  type(mp_complex) &  
12789
25517
     ,intent(out) :: rslt(0:2)
12790
 
  include 'cts_mpc.h'
 
25518
  type(mp_complex) &  
12791
25519
     ,intent(in)  :: p1i,p2i,p3i ,m2i,m3i
12792
25520
   type(qmplx_type) :: q23,q34,q24,qm2,qm3,qm4,qx1,qx2,qss,qy1,qy2
12793
 
  include 'cts_mpc.h'
 
25521
  type(mp_complex) &  
12794
25522
     :: p2,p3,p23,m2,m4,sm2,sm3,sm4,aa,bb,cc,dd,x1,x2 &
12795
25523
                     ,r23,k24,r34,r24,d24
 
25524
   logical :: r23Not0,r34Not0
12796
25525
!
12797
25526
!   p1 = nul
12798
25527
   p2 = p3i
12810
25539
   sm3 = abs(sm2) !mysqrt(m3)
12811
25540
   sm4 = mysqrt(m4)
12812
25541
!
12813
 
   r23 = 0
12814
 
   k24 = 0
12815
 
   r34 = 0
12816
 
   if (m2   .ne.p2 ) r23 = (    m2-p2 -p2 *IEPS )/(sm2*sm3) ! p2
12817
 
   if (m2+m4.ne.p23) k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
12818
 
   if (m4   .ne.p3 ) r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
25542
   r23 = (    m2-p2 -p2 *IEPS )/(sm2*sm3) ! p2
 
25543
   k24 = ( m2+m4-p23-p23*IEPS )/(sm2*sm4) ! p2+p3
 
25544
   r34 = (    m4-p3 -p3 *IEPS )/(sm3*sm4) ! p3
 
25545
!
 
25546
   r23Not0 = (abs(areal(r23))+abs(aimag(r23)).ge.neglig(prcpar))
 
25547
   r34Not0 = (abs(areal(r34))+abs(aimag(r34)).ge.neglig(prcpar))
12819
25548
!
12820
25549
   call rfun( r24,d24 ,k24 )
12821
25550
!
12859
25588
!
12860
25589
   rslt(0) = rslt(0) - li2c2( qx1*qm4 ,qx2*qm4 )*sm4
12861
25590
!
12862
 
   if (r23.ne.CZRO) then
 
25591
   if (r23Not0) then
12863
25592
     qss = q23*qm3/q24
12864
25593
     rslt(0) = rslt(0) - li2c2( qx1*qss ,qx2*qss )*r23*sm3/r24
12865
25594
   endif
12866
25595
!
12867
 
   if (r34.ne.CZRO) then
 
25596
   if (r34Not0) then
12868
25597
     qss = q34*qm3
12869
25598
     rslt(0) = rslt(0) + li2c2( qx1*qss ,qx2*qss )*r34*sm3
12870
25599
   endif
12880
25609
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
12881
25610
! by sending one internal mass to infinity.
12882
25611
!*******************************************************************
12883
 
  include 'cts_mpc.h'
 
25612
  type(mp_complex) &  
12884
25613
     ,intent(out) :: rslt(0:2)
12885
 
  include 'cts_mpc.h'
 
25614
  type(mp_complex) &  
12886
25615
     ,intent(in)  :: p1i,p2i,p3i,m1i,m2i,m3i
12887
25616
   type(qmplx_type) :: q12,q13,q23,qm1,qm2,qm3,qx1,qx2,qz1,qz2,qtt
12888
 
  include 'cts_mpc.h'
 
25617
  type(mp_complex) &  
12889
25618
     :: p1,p2,p3,m1,m2,m3,sm1,sm2,sm3,aa,bb,cc,dd,x1,x2 &
12890
25619
                     ,k12,k13,k23,r12,r13,r23,d12,d13,d23 
12891
 
  include 'cts_mpr.h'
 
25620
  type(mp_real) & 
12892
25621
     :: h1,h2,h3
12893
25622
!
12894
25623
   h1 = -aimag(m1i)
12970
25699
! Finite 1-loop scalar 3-point function with all internal masses
12971
25700
! non-zero. Based on the fomula of 't Hooft & Veltman
12972
25701
!*******************************************************************
12973
 
  include 'cts_mpc.h'
 
25702
  type(mp_complex) &  
12974
25703
     ,intent(out) :: rslt(0:2)
12975
 
  include 'cts_mpc.h'
 
25704
  type(mp_complex) &  
12976
25705
     ,intent(in)  :: pp(3),mm(3)
12977
 
  include 'cts_mpr.h'
 
25706
  type(mp_real) & 
12978
25707
     ,intent(in)  :: ap(3),smax
12979
 
  include 'cts_mpc.h'
 
25708
  type(mp_complex) &  
12980
25709
     ,optional ,intent(in) :: lam
12981
 
  include 'cts_mpc.h'
 
25710
  type(mp_complex) &  
12982
25711
     :: p1,p2,p3,m1,m2,m3,slam,yy
12983
 
  include 'cts_mpc.h'
 
25712
  type(mp_complex) &  
12984
25713
     :: sm1,sm2,sm3
12985
25714
   type(qmplx_type) :: qm1,qm2,qm3
12986
 
  include 'cts_mpr.h'
 
25715
  type(mp_real) & 
12987
25716
     :: a12,a23,a31,thrs,a1,a2,a3
12988
25717
!
12989
25718
! Order squared momenta, first one smallest
13096
25825
! function below.
13097
25826
! t4  should be  sqrt(lambda(aa,t2,t3))
13098
25827
!***************************************************************
13099
 
  include 'cts_mpc.h'
 
25828
  type(mp_complex) &  
13100
25829
       ,intent(in) :: aa,s1,s2,t1
13101
 
  include 'cts_mpc.h'
 
25830
  type(mp_complex) &  
13102
25831
       ,optional,intent(in) :: t2,t3
13103
 
  include 'cts_mpc.h'
 
25832
  type(mp_complex) &  
13104
25833
       ,optional,intent(inout) :: t4
13105
 
  include 'cts_mpc.h'
 
25834
  type(mp_complex) &  
13106
25835
       :: rslt ,cc,bb,dd,y0,y1,y2,zz,hh,alpha
13107
 
  include 'cts_mpr.h'
 
25836
  type(mp_real) & 
13108
25837
       :: rez,arez,aimz
13109
25838
     type(qmplx_type) :: q1,q2
13110
25839
!
13146
25875
!**************************************************
13147
25876
! int( ( ln(a*y+b) - ln(a*y0+b) )/(y-y0) ,y=0..1 )
13148
25877
!**************************************************
13149
 
  include 'cts_mpc.h'
 
25878
  type(mp_complex) &  
13150
25879
       ,intent(in) :: aa,bb,y0
13151
 
  include 'cts_mpc.h'
 
25880
  type(mp_complex) &  
13152
25881
       :: rslt ,y1,hh
13153
25882
     type(qmplx_type) :: q1
13154
25883
     y1 = -bb/aa
13210
25939
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
13211
25940
! m2,m4 should NOT be identically 0d0
13212
25941
!*******************************************************************
13213
 
  include 'cts_mpc.h'
 
25942
  type(mp_complex) &  
13214
25943
     ,intent(out) :: rslt(0:2)
13215
 
  include 'cts_mpc.h'
 
25944
  type(mp_complex) &  
13216
25945
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m3,m4
13217
 
  include 'cts_mpr.h'
 
25946
  type(mp_real) & 
13218
25947
     ,intent(in)  :: rmu
13219
 
  include 'cts_mpc.h'
 
25948
  type(mp_complex) &  
13220
25949
     :: cp2,cp3,cp12,cp23,cm2,cm3,cm4,sm1,sm2,sm3,sm4 &
13221
25950
                     ,r13,r23,r24,r34,d23,d24,d34,log24,cc
13222
25951
   type(qmplx_type) :: q13,q23,q24,q34,qss,qy1,qy2,qz1,qz2
13289
26018
! with  k1^2=m2, k2^2=p2, k3^2=p3, (k1+k2+k3)^2=m4
13290
26019
! m2,m4 should NOT be identically 0d0
13291
26020
!*******************************************************************
13292
 
  include 'cts_mpc.h'
 
26021
  type(mp_complex) &  
13293
26022
     ,intent(out) :: rslt(0:2)
13294
 
  include 'cts_mpc.h'
 
26023
  type(mp_complex) &  
13295
26024
     ,intent(in)  :: p2,p3,p12,p23 ,m2,m4
13296
 
  include 'cts_mpr.h'
 
26025
  type(mp_real) & 
13297
26026
     ,intent(in)  :: rmu
13298
 
  include 'cts_mpc.h'
 
26027
  type(mp_complex) &  
13299
26028
     :: cp2,cp3,cp12,cp23,cm2,cm4,sm1,sm2,sm3,sm4 &
13300
26029
                     ,r13,r23,r24,r34,d24,log24,cc
13301
26030
   type(qmplx_type) :: q13,q23,q24,q34,qss,qz1,qz2
13365
26094
! with  k1^2=m2, k2^2=m2, k3^2=m4, (k1+k2+k3)^2=m4
13366
26095
! m2,m4 should NOT be identically 0d0
13367
26096
!*******************************************************************
13368
 
  include 'cts_mpc.h'
 
26097
  type(mp_complex) &  
13369
26098
     ,intent(out) :: rslt(0:2)
13370
 
  include 'cts_mpc.h'
 
26099
  type(mp_complex) &  
13371
26100
     ,intent(in)  :: cp12,cp23,cm2,cm4
13372
 
  include 'cts_mpr.h'
 
26101
  type(mp_real) & 
13373
26102
     ,intent(in)  :: rmu
13374
 
  include 'cts_mpc.h'
 
26103
  type(mp_complex) &  
13375
26104
     :: sm2,sm4,r24,d24,cc
13376
26105
!
13377
26106
   if (cp12.eq.CZRO) then
13413
26142
! p4 should NOT be identical to m4
13414
26143
! p2 should NOT be identical to m3
13415
26144
!*******************************************************************
13416
 
  include 'cts_mpc.h'
 
26145
  type(mp_complex) &  
13417
26146
     ,intent(out) :: rslt(0:2)
13418
 
  include 'cts_mpc.h'
 
26147
  type(mp_complex) &  
13419
26148
     ,intent(in)  :: p2,p3,p4,p12,p23,m3,m4
13420
 
  include 'cts_mpr.h'
 
26149
  type(mp_real) & 
13421
26150
     ,intent(in)  :: rmu
13422
 
  include 'cts_mpc.h'
 
26151
  type(mp_complex) &  
13423
26152
     :: cp2,cp3,cp4,cp12,cp23,cm3,cm4,sm3,sm4,sm1,sm2 &
13424
26153
             ,r13,r14,r23,r24,r34,d34,cc,logd,li2d,loge,li2f,li2b,li2e
13425
26154
   type(qmplx_type) :: q13,q14,q23,q24,q34,qy1,qy2
13426
 
  include 'cts_mpr.h'
 
26155
  type(mp_real) & 
13427
26156
     :: h1,h2
13428
26157
!
13429
26158
   if (p12.eq.m3) then
13430
 
!     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
13431
 
!       ,'p12=m3, returning 0'
 
26159
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
26160
       ,'p12=m3, returning 0'
13432
26161
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
13433
26162
     return
13434
26163
   endif
13435
26164
   if (p23.eq.m4) then
13436
 
!     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
13437
 
!       ,'p23=m4, returning 0'
 
26165
     if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop box13: ' &
 
26166
       ,'p23=m4, returning 0'
13438
26167
     rslt(0)=0 ;rslt(1)=0 ;rslt(2)=0
13439
26168
     return
13440
26169
   endif
13496
26225
! m3,m4 should NOT be indentiallcy 0d0
13497
26226
! p4 should NOT be identical to m4
13498
26227
!*******************************************************************
13499
 
  include 'cts_mpc.h'
 
26228
  type(mp_complex) &  
13500
26229
     ,intent(out) :: rslt(0:2)
13501
 
  include 'cts_mpc.h'
 
26230
  type(mp_complex) &  
13502
26231
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm3,cm4
13503
 
  include 'cts_mpr.h'
 
26232
  type(mp_real) & 
13504
26233
     ,intent(in)  :: rmu
13505
 
  include 'cts_mpc.h'
 
26234
  type(mp_complex) &  
13506
26235
     :: sm3,sm4,sm1,sm2,r13,r14,r24,r34,d34,cc &
13507
26236
                     ,log13,log14,log24,log34,li2f,li2b,li2d
13508
26237
   type(qmplx_type) :: q13,q14,q24,q34,qyy
13568
26297
! with  k1^2=0, k2^2=m3, k3^2=p3, (k1+k2+k3)^2=m4
13569
26298
! m3,m4 should NOT be indentiallcy 0d0
13570
26299
!*******************************************************************
13571
 
  include 'cts_mpc.h'
 
26300
  type(mp_complex) &  
13572
26301
     ,intent(out) :: rslt(0:2)
13573
 
  include 'cts_mpc.h'
 
26302
  type(mp_complex) &  
13574
26303
     ,intent(in)  :: cp3,cp12,cp23,cm3,cm4
13575
 
  include 'cts_mpr.h'
 
26304
  type(mp_real) & 
13576
26305
     ,intent(in)  :: rmu
13577
 
  include 'cts_mpc.h'
 
26306
  type(mp_complex) &  
13578
26307
     :: sm3,sm4,sm1,sm2,r13,r24,r34,d34 &
13579
26308
                     ,cc,log13,log24,log34
13580
26309
!
13627
26356
! p2 should NOT be identically 0d0
13628
26357
! p4 should NOT be identical to m4
13629
26358
!*******************************************************************
13630
 
  include 'cts_mpc.h'
 
26359
  type(mp_complex) &  
13631
26360
     ,intent(out) :: rslt(0:2)
13632
 
  include 'cts_mpc.h'
 
26361
  type(mp_complex) &  
13633
26362
     ,intent(in)  :: p2,p3,p4,p12,p23,m4
13634
 
  include 'cts_mpr.h'
 
26363
  type(mp_real) & 
13635
26364
     ,intent(in)  :: rmu
13636
 
  include 'cts_mpc.h'
 
26365
  type(mp_complex) &  
13637
26366
     :: cp2,cp3,cp4,cp12,cp23,cm4,r13,r14,r23,r24,r34,z1,z0
13638
26367
   type(qmplx_type) :: q13,q14,q23,q24,q34,qm4,qxx,qx1,qx2
13639
 
  include 'cts_mpr.h'
 
26368
  type(mp_real) & 
13640
26369
     :: h1,h2
13641
26370
!
13642
26371
   if (p12.eq.CZRO) then
13707
26436
! m4 should NOT be identically 0d0
13708
26437
! p2 should NOT be identically 0d0
13709
26438
!*******************************************************************
13710
 
  include 'cts_mpc.h'
 
26439
  type(mp_complex) &  
13711
26440
     ,intent(out) :: rslt(0:2)
13712
 
  include 'cts_mpc.h'
 
26441
  type(mp_complex) &  
13713
26442
     ,intent(in)  :: cp2,cp3,cp12,cp23,cm4
13714
 
  include 'cts_mpr.h'
 
26443
  type(mp_real) & 
13715
26444
     ,intent(in)  :: rmu
13716
 
  include 'cts_mpc.h'
 
26445
  type(mp_complex) &  
13717
26446
     :: logm,log12,log23,li12,li23,z2,z1,z0,cc &
13718
26447
                     ,r13,r23,r24,r34
13719
26448
   type(qmplx_type) :: q13,q23,q24,q34,qm4,qxx
13773
26502
! mm should NOT be identically 0d0
13774
26503
! p3 NOR p4 should be identically m4
13775
26504
!*******************************************************************
13776
 
  include 'cts_mpc.h'
 
26505
  type(mp_complex) &  
13777
26506
     ,intent(out) :: rslt(0:2)
13778
 
  include 'cts_mpc.h'
 
26507
  type(mp_complex) &  
13779
26508
     ,intent(in)  :: cp3,cp4,cp12,cp23,cm4
13780
 
  include 'cts_mpr.h'
 
26509
  type(mp_real) & 
13781
26510
     ,intent(in)  :: rmu
13782
26511
   type(qmplx_type) :: q13,q14,q24,q34,qm4,qxx,qx1,qx2,qx3
13783
 
  include 'cts_mpc.h'
 
26512
  type(mp_complex) &  
13784
26513
     :: r13,r14,r24,r34,z1,z0,cc
13785
 
  include 'cts_mpr.h'
 
26514
  type(mp_real) & 
13786
26515
     :: rmu2
13787
26516
!
13788
26517
   if (cp12.eq.CZRO) then
13840
26569
! m3 should NOT be identically 0d0
13841
26570
! p4 should NOT be identically m4
13842
26571
!*******************************************************************
13843
 
  include 'cts_mpc.h'
 
26572
  type(mp_complex) &  
13844
26573
     ,intent(out) :: rslt(0:2)
13845
 
  include 'cts_mpc.h'
 
26574
  type(mp_complex) &  
13846
26575
     ,intent(in)  :: cp4,cp12,cp23,cm4
13847
 
  include 'cts_mpr.h'
 
26576
  type(mp_real) & 
13848
26577
     ,intent(in)  :: rmu
13849
26578
   type(qmplx_type) :: q13,q14,q24,qm4
13850
 
  include 'cts_mpc.h'
 
26579
  type(mp_complex) &  
13851
26580
     :: r13,r14,r24,logm,log12,log23,log4,li423 &
13852
26581
                     ,z2,z1,z0,cc
13853
26582
!
13900
26629
! with  k1^2=k2^2=0, k3^2=(k1+k2+k3)^2=m4
13901
26630
! m3 should NOT be identically 0d0
13902
26631
!*******************************************************************
13903
 
  include 'cts_mpc.h'
 
26632
  type(mp_complex) &  
13904
26633
     ,intent(out) :: rslt(0:2)
13905
 
  include 'cts_mpc.h'
 
26634
  type(mp_complex) &  
13906
26635
     ,intent(in)  :: cp12,cp23,cm4
13907
 
  include 'cts_mpr.h'
 
26636
  type(mp_real) & 
13908
26637
     ,intent(in)  :: rmu
13909
26638
   type(qmplx_type) :: q13,q24,qm4
13910
 
  include 'cts_mpc.h'
 
26639
  type(mp_complex) &  
13911
26640
     :: r13,r24,logm,log1,log2,z2,z1,z0,cc
13912
26641
!
13913
26642
   if (cp12.eq.CZRO) then
13953
26682
!
13954
26683
! with  k1^2=k3^2=0
13955
26684
!*******************************************************************
13956
 
  include 'cts_mpc.h'
 
26685
  type(mp_complex) &  
13957
26686
     ,intent(out) :: rslt(0:2)
13958
 
  include 'cts_mpc.h'
 
26687
  type(mp_complex) &  
13959
26688
     ,intent(in)  :: p2,p4,p5,p6 
13960
 
  include 'cts_mpr.h'
 
26689
  type(mp_real) & 
13961
26690
     ,intent(in)  :: rmu
13962
26691
   type(qmplx_type) :: q2,q4,q5,q6,q26,q54,qy
13963
 
  include 'cts_mpc.h'
 
26692
  type(mp_complex) &  
13964
26693
     :: logy
13965
 
  include 'cts_mpr.h'
 
26694
  type(mp_real) & 
13966
26695
     :: rmu2
13967
26696
!
13968
26697
   rmu2 = rmu*rmu
13995
26724
!
13996
26725
! with  k1^2=0
13997
26726
!*******************************************************************
13998
 
  include 'cts_mpc.h'
 
26727
  type(mp_complex) &  
13999
26728
     ,intent(out) :: rslt(0:2)
14000
 
  include 'cts_mpc.h'
 
26729
  type(mp_complex) &  
14001
26730
     ,intent(in)  :: p2,p3,p4,p5,p6
14002
 
  include 'cts_mpr.h'
 
26731
  type(mp_real) & 
14003
26732
     ,intent(in)  :: rmu
14004
26733
   type(qmplx_type) ::q2,q3,q4,q5,q6 ,q25,q64,qy,qz
14005
 
  include 'cts_mpc.h'
 
26734
  type(mp_complex) &  
14006
26735
     :: logy
14007
 
  include 'cts_mpr.h'
 
26736
  type(mp_real) & 
14008
26737
     :: rmu2
14009
26738
!
14010
26739
   rmu2 = rmu*rmu
14049
26778
!*******************************************************************
14050
26779
   use avh_olo_mp_olog
14051
26780
   use avh_olo_mp_dilog
14052
 
  include 'cts_mpc.h'
 
26781
  type(mp_complex) &  
14053
26782
     ,intent(out) :: rslt(0:2)
14054
 
  include 'cts_mpc.h'
 
26783
  type(mp_complex) &  
14055
26784
     ,intent(in)  :: cp(6)
14056
 
  include 'cts_mpr.h'
 
26785
  type(mp_real) & 
14057
26786
     ,intent(in)  :: api(6),rmu
14058
 
  include 'cts_mpc.h'
 
26787
  type(mp_complex) &  
14059
26788
     :: log3,log4,log5,log6,li24,li25,li26 &
14060
26789
                     ,li254,li263
14061
 
  include 'cts_mpr.h'
 
26790
  type(mp_real) & 
14062
26791
     :: rp1,rp2,rp3,rp4,rp5,rp6,pp(6),ap(6),gg,ff,hh,arg,rmu2
14063
26792
   integer :: icase,sf,sgn,i3,i4,i5,i6
14064
26793
   integer ,parameter :: base(4)=(/8,4,2,1/)
14192
26921
! equal zero. Based on the formulas from
14193
26922
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14194
26923
!*******************************************************************
14195
 
  include 'cts_mpc.h'
 
26924
  type(mp_complex) &  
14196
26925
    ,intent(out) :: rslt(0:2) 
14197
 
  include 'cts_mpc.h'
 
26926
  type(mp_complex) &  
14198
26927
    ,intent(in) :: p1,p2,p3,p4,p12,p23
14199
26928
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qss
14200
 
  include 'cts_mpc.h'
 
26929
  type(mp_complex) &  
14201
26930
    :: aa,bb,cc,dd,x1,x2,ss,r12,r13,r14,r23,r24,r34
14202
 
  include 'cts_mpr.h'
 
26931
  type(mp_real) & 
14203
26932
    :: hh
14204
26933
!
14205
26934
  r12 = -p1  !  p1
14256
26985
! non-zero. Based on the formulas from
14257
26986
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14258
26987
!*******************************************************************
14259
 
  include 'cts_mpc.h'
 
26988
  type(mp_complex) &  
14260
26989
    ,intent(out) :: rslt(0:2) 
14261
 
  include 'cts_mpc.h'
 
26990
  type(mp_complex) &  
14262
26991
    ,intent(in) :: p1,p2,p3,p4,p12,p23 ,m4
14263
26992
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
14264
 
  include 'cts_mpc.h'
 
26993
  type(mp_complex) &  
14265
26994
    :: smm,sm4,aa,bb,cc,dd,x1,x2,r12,r13,r14,r23,r24,r34
14266
26995
  logical :: r12zero,r13zero,r14zero
14267
26996
!
14345
27074
! masses non-zero. Based on the formulas from
14346
27075
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14347
27076
!*******************************************************************
14348
 
  include 'cts_mpc.h'
 
27077
  type(mp_complex) &  
14349
27078
    ,intent(out) :: rslt(0:2) 
14350
 
  include 'cts_mpc.h'
 
27079
  type(mp_complex) &  
14351
27080
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m2,m4
14352
27081
  call boxf2( rslt ,p12,p2,p23,p4,p1,p3 ,m2,m4 )
14353
27082
  end subroutine
14359
27088
! masses non-zero. Based on the formulas from
14360
27089
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14361
27090
!*******************************************************************
14362
 
  include 'cts_mpc.h'
 
27091
  type(mp_complex) &  
14363
27092
    ,intent(out) :: rslt(0:2) 
14364
 
  include 'cts_mpc.h'
 
27093
  type(mp_complex) &  
14365
27094
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m3,m4
14366
27095
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34
14367
 
  include 'cts_mpc.h'
 
27096
  type(mp_complex) &  
14368
27097
    :: smm,sm3,sm4,aa,bb,cc,dd,x1,x2 &
14369
27098
                    ,r12,r13,r14,r23,r24,r34,d14,k14
14370
27099
  logical :: r12zero,r13zero,r24zero,r34zero
14465
27194
! Finite 1-loop scalar 4-point function with three internal masses
14466
27195
! non-zero.
14467
27196
!*******************************************************************
14468
 
  include 'cts_mpc.h'
 
27197
  type(mp_complex) &  
14469
27198
    ,intent(out) :: rslt(0:2) 
14470
 
  include 'cts_mpc.h'
 
27199
  type(mp_complex) &  
14471
27200
    ,intent(in) :: pp(6),mm(4)
14472
27201
  integer :: j
14473
27202
  integer ,parameter :: ip(6)=(/4,5,2,6,3,1/)
14491
27220
! non-zero, and m3=0. Based on the formulas from
14492
27221
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14493
27222
!*******************************************************************
14494
 
  include 'cts_mpc.h'
 
27223
  type(mp_complex) &  
14495
27224
    ,intent(out) :: rslt(0:2) 
14496
 
  include 'cts_mpc.h'
 
27225
  type(mp_complex) &  
14497
27226
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m4
14498
27227
  type(qmplx_type) :: qx1,qx2,qss,q12,q13,q14,q23,q24,q34,qy1,qy2
14499
 
  include 'cts_mpc.h'
 
27228
  type(mp_complex) &  
14500
27229
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2 &
14501
27230
                    ,r12,r13,r14,r23,r24,r34,d12,d14,d24,k12,k14,k24
14502
27231
  logical ::r13zero,r23zero,r34zero
14591
27320
! non-zero. Based on the formulas from
14592
27321
! A. Denner, U. Nierste, R. Scharf, Nucl.Phys.B367(1991)637-656
14593
27322
!*******************************************************************
14594
 
  include 'cts_mpc.h'
 
27323
  type(mp_complex) &  
14595
27324
    ,intent(out) :: rslt(0:2) 
14596
 
  include 'cts_mpc.h'
 
27325
  type(mp_complex) &  
14597
27326
    ,intent(in) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4
14598
27327
  type(qmplx_type) :: q12,q13,q14,q23,q24,q34,qx1,qx2,qy1,qy2,qtt
14599
 
  include 'cts_mpc.h'
 
27328
  type(mp_complex) &  
14600
27329
    :: sm1,sm2,sm3,sm4 ,aa,bb,cc,dd,x1,x2,tt &
14601
27330
                    ,k12,k13,k14,k23,k24,k34 &
14602
27331
                    ,r12,r13,r14,r23,r24,r34 &
14603
27332
                    ,d12,d13,d14,d23,d24,d34
14604
 
  include 'cts_mpr.h'
 
27333
  type(mp_real) & 
14605
27334
    :: h1,h2
14606
27335
!
14607
27336
  sm1 = mysqrt(m1)
14694
27423
!   G. 't Hooft and M.J.G. Veltman, Nucl.Phys.B153:365-401,1979 
14695
27424
!*******************************************************************
14696
27425
   use avh_olo_mp_box ,only: base,casetable,ll=>permtable
14697
 
  include 'cts_mpc.h'
 
27426
  type(mp_complex) &  
14698
27427
     ,intent(out) :: rslt(0:2)
14699
 
  include 'cts_mpc.h'
 
27428
  type(mp_complex) &  
14700
27429
     ,intent(in)  :: pp_in(6),mm_in(4)
14701
 
  include 'cts_mpr.h'
 
27430
  type(mp_real) & 
14702
27431
     ,intent(in)  :: ap_in(6),smax
14703
 
  include 'cts_mpc.h'
 
27432
  type(mp_complex) &  
14704
27433
     :: pp(6),mm(4)
14705
 
  include 'cts_mpr.h'
 
27434
  type(mp_real) & 
14706
27435
     :: ap(6),aptmp(6),rem,imm,hh
14707
 
  include 'cts_mpc.h'
 
27436
  type(mp_complex) &  
14708
27437
     :: a,b,c,d,e,f,g,h,j,k,dpe,epk,x1,x2,sdnt,o1,j1,e1 &
14709
27438
       ,dek,dpf,def,dpk,abc,bgj,jph,cph
14710
27439
   integer :: icase,jcase,ii
14743
27472
   do ii=1,4
14744
27473
     rem = areal(mm_in(ii))
14745
27474
     imm = aimag(mm_in(ii))
14746
 
     hh = EPSN2*abs(rem)
 
27475
     hh = EPSN*abs(rem)
14747
27476
     if (abs(imm).lt.hh) imm = -hh
14748
27477
     mm(ii) = acmplx(rem,imm)
14749
27478
   enddo
14848
27577
!
14849
27578
! jj should have negative imaginary part
14850
27579
!*******************************************************************
14851
 
  include 'cts_mpc.h'
 
27580
  type(mp_complex) &  
14852
27581
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj ,dpe,dpj,dpf
14853
 
  include 'cts_mpc.h'
 
27582
  type(mp_complex) &  
14854
27583
     :: rslt ,kk,ll,nn,y1,y2,sdnt
14855
27584
!
14856
27585
!
14876
27605
!
14877
27606
! jj should have negative imaginary part
14878
27607
!*******************************************************************
14879
 
  include 'cts_mpc.h'
 
27608
  type(mp_complex) &  
14880
27609
     ,intent(in) :: aa,cc,gg,hh ,dd,ee,ff,jj,dpe
14881
 
  include 'cts_mpc.h'
 
27610
  type(mp_complex) &  
14882
27611
     ::rslt ,kk,ll,nn,y1,y2,sdnt
14883
27612
!
14884
27613
!
14902
27631
! | dx |  dy ------------------------------------------------------
14903
27632
! /0   /0    (g*x + h*x + j)*(a*x^2 + b*y^2 + c*xy + d*x + e*y + f)
14904
27633
!*******************************************************************
14905
 
  include 'cts_mpc.h'
 
27634
  type(mp_complex) &  
14906
27635
     ,intent(in) :: aa,bb,cc ,gin,hin ,dd,ee,ff ,jin ,dpe ,dpf
14907
 
  include 'cts_mpc.h'
 
27636
  type(mp_complex) &  
14908
27637
     :: rslt ,gg,hh,jj,zz(2),beta,tmpa(2),tmpb(2) &
14909
27638
       ,tmpc(2),kiz(2),ll,nn,kk,y1,y2,yy(2,2),sdnt
14910
 
  include 'cts_mpr.h'
 
27639
  type(mp_real) & 
14911
27640
     :: ab1,ab2,ac1,ac2,abab,acac,abac,det,ap1,ap2 &
14912
27641
                  ,apab,apac,x1(2,2),x2(2,2),xmin
14913
27642
   integer :: iz,iy,izmin,sj
15025
27754
!
15026
27755
! y1i,y2i should have a non-zero imaginary part
15027
27756
!*******************************************************************
15028
 
  include 'cts_mpc.h'
 
27757
  type(mp_complex) &  
15029
27758
     ,intent(in) ::  y1i,y2i ,dd,ee ,aa,bb,cin
15030
 
  include 'cts_mpc.h'
 
27759
  type(mp_complex) &  
15031
27760
     :: rslt ,y1,y2,fy1y2,z1,z2,tmp,cc
15032
 
  include 'cts_mpr.h'
 
27761
  type(mp_real) & 
15033
27762
     ::rea,reb,rez1,rez2,imz1,imz2,simc,hh
15034
27763
!
15035
27764
!
15133
27862
!                                 ---------------------------
15134
27863
!                                           y1 - y2
15135
27864
!*******************************************************************
15136
 
  include 'cts_mpc.h'
 
27865
  type(mp_complex) &  
15137
27866
     ,intent(in) :: y1,y2,zz,fy1y2
15138
 
  include 'cts_mpc.h'
 
27867
  type(mp_complex) &  
15139
27868
     :: rslt ,oz
15140
27869
   type(qmplx_type) :: q1z,q2z,qq
15141
 
  include 'cts_mpr.h'
 
27870
  type(mp_real) & 
15142
27871
     :: h12,hz1,hz2,hzz,hoz
15143
27872
   logical :: zzsmall,ozsmall
15144
27873
!
15203
27932
!
15204
27933
! y1,y2 should have non-zero imaginary parts
15205
27934
!*******************************************************************
15206
 
  include 'cts_mpc.h'
 
27935
  type(mp_complex) &  
15207
27936
     ,intent(in) :: y1,y2
15208
 
  include 'cts_mpc.h'
 
27937
  type(mp_complex) &  
15209
27938
     :: rslt ,oy1,oy2
15210
27939
   oy1 = 1-y1
15211
27940
   oy2 = 1-y2
15224
27953
! 
15225
27954
! p1,p2 are logical, to be interpreted as 0,1 in the formula above 
15226
27955
!*******************************************************************
15227
 
  include 'cts_mpc.h'
 
27956
  type(mp_complex) &  
15228
27957
     ,intent(in) :: y1,y2 ,aa,bb,cc
15229
27958
   logical         ,intent(in) :: p1,p2
15230
 
  include 'cts_mpc.h'
 
27959
  type(mp_complex) &  
15231
27960
     :: rslt ,x1,x2,xx
15232
27961
   type(qmplx_type) :: q1,q2
15233
27962
!
15276
28005
  public :: olo_unit ,olo_scale ,olo_onshell ,olo_setting
15277
28006
  public :: olo_precision
15278
28007
  public :: olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
 
28008
  public :: olo_an ,olo_bn
15279
28009
  public :: olo
15280
28010
  public :: olo_get_scale ,olo_get_onshell ,olo_get_precision
15281
28011
!
15282
 
 integer ,public ,parameter :: olo_kind=kind(1d0)
 
28012
 integer ,public ,parameter :: olo_kind=kind(1d0) 
15283
28013
!
15284
 
  include 'cts_mpr.h'
 
28014
  type(mp_real) & 
15285
28015
         ,save :: onshellthrs
15286
28016
  logical,save :: nonzerothrs = .false.
15287
28017
!
15288
 
  include 'cts_mpr.h'
 
28018
  type(mp_real) & 
15289
28019
         ,save :: muscale
15290
28020
!
15291
28021
  character(99) ,parameter :: warnonshell=&
15297
28027
  interface olo_a0
15298
28028
    module procedure a0_r,a0rr,a0_c,a0cr
15299
28029
  end interface 
 
28030
  interface olo_an
 
28031
    module procedure an_r,anrr,an_c,ancr
 
28032
  end interface 
15300
28033
  interface olo_b0
15301
28034
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
15302
28035
  end interface 
15303
28036
  interface olo_b11
15304
28037
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
15305
28038
  end interface 
 
28039
  interface olo_bn
 
28040
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
 
28041
  end interface 
15306
28042
  interface olo_c0
15307
28043
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
15308
28044
  end interface 
15312
28048
!
15313
28049
  interface olo
15314
28050
    module procedure a0_r,a0rr,a0_c,a0cr
 
28051
    module procedure an_r,anrr,an_c,ancr
15315
28052
    module procedure b0rr,b0rrr,b0rc,b0rcr,b0cc,b0ccr
15316
28053
    module procedure b11rr,b11rrr,b11rc,b11rcr,b11cc,b11ccr
 
28054
    module procedure bnrr,bnrrr,bnrc,bnrcr,bncc,bnccr
15317
28055
    module procedure c0rr,c0rrr,c0rc,c0rcr,c0cc,c0ccr
15318
28056
    module procedure d0rr,d0rrr,d0rc,d0rcr,d0cc,d0ccr
15319
28057
  end interface 
15355
28093
  if (initz) then
15356
28094
    call init( ndec )
15357
28095
  else
15358
 
   call set_precision( ndec ,newprc )
 
28096
   call set_precision( ndec ,newprc ) 
15359
28097
    if (newprc) then
15360
28098
      call update_olog
15361
28099
      call update_dilog
15433
28171
  if (present(iunit)) nunit = iunit
15434
28172
  if (nunit.le.0) return
15435
28173
!
15436
 
 write(nunit,*) 'MESSAGE from OneLOop: operating at arbitrary precision'
 
28174
 write(nunit,*) 'MESSAGE from OneLOop: operating at arbitrary precision'            
15437
28175
  write(nunit,*) 'MESSAGE from OneLOop: number of decimals  =',trim(myprint(ndecim(prcpar)))
15438
28176
!
15439
28177
  if (nonzerothrs) then
15469
28207
!
15470
28208
  use avh_olo_mp_bub ,only: tadp
15471
28209
!
15472
 
  include 'cts_mpc.h'
 
28210
  type(mp_complex) &  
15473
28211
    ,intent(out) :: rslt(0:2)
15474
 
  include 'cts_mpc.h'
 
28212
  type(mp_complex) &  
15475
28213
    ,intent(in)  :: mm
15476
28214
!
15477
 
  include 'cts_mpc.h'
 
28215
  type(mp_complex) &  
15478
28216
    :: ss
15479
 
  include 'cts_mpr.h'
 
28217
  type(mp_real) & 
15480
28218
    :: am,hh,mulocal,mulocal2
15481
28219
  character(25+99) ,parameter :: warning=&
15482
28220
                     'WARNING from OneLOop a0: '//warnonshell
15483
28221
  if (initz) call init
15484
28222
!
15485
 
  mulocal = muscale
 
28223
  mulocal = muscale 
15486
28224
!
15487
28225
  am = abs(mm)
15488
28226
!
15513
28251
!
15514
28252
  use avh_olo_mp_bub ,only: tadp
15515
28253
!
15516
 
  include 'cts_mpc.h'
 
28254
  type(mp_complex) &  
15517
28255
    ,intent(out) :: rslt(0:2)
15518
 
  include 'cts_mpc.h'
 
28256
  type(mp_complex) &  
15519
28257
    ,intent(in)  :: mm
15520
 
  include 'cts_mpr.h'
15521
 
   ,intent(in)  :: rmu
 
28258
  type(mp_real) & 
 
28259
   ,intent(in)  :: rmu       
15522
28260
!
15523
 
  include 'cts_mpc.h'
 
28261
  type(mp_complex) &  
15524
28262
    :: ss
15525
 
  include 'cts_mpr.h'
 
28263
  type(mp_real) & 
15526
28264
    :: am,hh,mulocal,mulocal2
15527
28265
  character(25+99) ,parameter :: warning=&
15528
28266
                     'WARNING from OneLOop a0: '//warnonshell
15529
28267
  if (initz) call init
15530
28268
!
15531
 
  mulocal = rmu
 
28269
  mulocal = rmu     
15532
28270
!
15533
28271
  am = abs(mm)
15534
28272
!
15559
28297
!
15560
28298
  use avh_olo_mp_bub ,only: tadp
15561
28299
!
15562
 
  include 'cts_mpc.h'
 
28300
  type(mp_complex) &  
15563
28301
    ,intent(out) :: rslt(0:2)
15564
 
  include 'cts_mpr.h'
 
28302
  type(mp_real) & 
15565
28303
    ,intent(in)  :: mm
15566
28304
!
15567
 
  include 'cts_mpc.h'
 
28305
  type(mp_complex) &  
15568
28306
    :: ss
15569
 
  include 'cts_mpr.h'
 
28307
  type(mp_real) & 
15570
28308
    :: am,hh,mulocal,mulocal2
15571
28309
  character(25+99) ,parameter :: warning=&
15572
28310
                     'WARNING from OneLOop a0: '//warnonshell
15573
28311
  if (initz) call init
15574
28312
!
15575
 
  mulocal = muscale
 
28313
  mulocal = muscale 
15576
28314
!
15577
28315
  am = abs(mm)
15578
28316
!
15603
28341
!
15604
28342
  use avh_olo_mp_bub ,only: tadp
15605
28343
!
15606
 
  include 'cts_mpc.h'
 
28344
  type(mp_complex) &  
15607
28345
    ,intent(out) :: rslt(0:2)
15608
 
  include 'cts_mpr.h'
 
28346
  type(mp_real) & 
15609
28347
    ,intent(in)  :: mm
15610
 
  include 'cts_mpr.h'
15611
 
   ,intent(in)  :: rmu
 
28348
  type(mp_real) & 
 
28349
   ,intent(in)  :: rmu       
15612
28350
!
15613
 
  include 'cts_mpc.h'
 
28351
  type(mp_complex) &  
15614
28352
    :: ss
15615
 
  include 'cts_mpr.h'
 
28353
  type(mp_real) & 
15616
28354
    :: am,hh,mulocal,mulocal2
15617
28355
  character(25+99) ,parameter :: warning=&
15618
28356
                     'WARNING from OneLOop a0: '//warnonshell
15619
28357
  if (initz) call init
15620
28358
!
15621
 
  mulocal = rmu
 
28359
  mulocal = rmu     
15622
28360
!
15623
28361
  am = abs(mm)
15624
28362
!
15646
28384
  end subroutine
15647
28385
 
15648
28386
 
 
28387
  subroutine an_c( rslt ,rank ,mm )
 
28388
!
 
28389
  use avh_olo_mp_bub ,only: tadpn
 
28390
!
 
28391
  type(mp_complex) &  
 
28392
    ,intent(out) :: rslt(0:,0:)   
 
28393
  type(mp_complex) &  
 
28394
    ,intent(in)  :: mm
 
28395
  integer,intent(in) :: rank
 
28396
!
 
28397
  type(mp_complex) &  
 
28398
    :: ss
 
28399
  type(mp_real) & 
 
28400
    :: am,hh,mulocal,mulocal2
 
28401
  integer :: ii
 
28402
  character(25+99) ,parameter :: warning=&
 
28403
                     'WARNING from OneLOop An: '//warnonshell
 
28404
  if (initz) call init
 
28405
!
 
28406
  mulocal = muscale 
 
28407
!
 
28408
  am = abs(mm)
 
28409
!
 
28410
  mulocal2 = mulocal*mulocal
 
28411
!
 
28412
  if (nonzerothrs) then
 
28413
    hh = onshellthrs
 
28414
    if (am.lt.hh) am = 0
 
28415
  elseif (wunit.gt.0) then
 
28416
    hh = onshellthrs*max(am,mulocal2)
 
28417
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
28418
  endif
 
28419
!
 
28420
  ss = mm
 
28421
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
28422
!
 
28423
  if (punit.gt.0) then
 
28424
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
28425
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
28426
    write(punit,*) ' mm:',trim(myprint(mm))
 
28427
    do ii=0,rank/2
 
28428
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
28429
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
28430
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
28431
    enddo
 
28432
  endif
 
28433
  end subroutine
 
28434
 
 
28435
  subroutine ancr( rslt ,rank ,mm ,rmu )
 
28436
!
 
28437
  use avh_olo_mp_bub ,only: tadpn
 
28438
!
 
28439
  type(mp_complex) &  
 
28440
    ,intent(out) :: rslt(0:,0:)   
 
28441
  type(mp_complex) &  
 
28442
    ,intent(in)  :: mm
 
28443
  type(mp_real) & 
 
28444
   ,intent(in)  :: rmu       
 
28445
  integer,intent(in) :: rank
 
28446
!
 
28447
  type(mp_complex) &  
 
28448
    :: ss
 
28449
  type(mp_real) & 
 
28450
    :: am,hh,mulocal,mulocal2
 
28451
  integer :: ii
 
28452
  character(25+99) ,parameter :: warning=&
 
28453
                     'WARNING from OneLOop An: '//warnonshell
 
28454
  if (initz) call init
 
28455
!
 
28456
  mulocal = rmu     
 
28457
!
 
28458
  am = abs(mm)
 
28459
!
 
28460
  mulocal2 = mulocal*mulocal
 
28461
!
 
28462
  if (nonzerothrs) then
 
28463
    hh = onshellthrs
 
28464
    if (am.lt.hh) am = 0
 
28465
  elseif (wunit.gt.0) then
 
28466
    hh = onshellthrs*max(am,mulocal2)
 
28467
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
28468
  endif
 
28469
!
 
28470
  ss = mm
 
28471
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
28472
!
 
28473
  if (punit.gt.0) then
 
28474
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
28475
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
28476
    write(punit,*) ' mm:',trim(myprint(mm))
 
28477
    do ii=0,rank/2
 
28478
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
28479
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
28480
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
28481
    enddo
 
28482
  endif
 
28483
  end subroutine
 
28484
 
 
28485
  subroutine an_r( rslt ,rank ,mm  )
 
28486
!
 
28487
  use avh_olo_mp_bub ,only: tadpn
 
28488
!
 
28489
  type(mp_complex) &  
 
28490
    ,intent(out) :: rslt(0:,0:)   
 
28491
  type(mp_real) & 
 
28492
    ,intent(in)  :: mm
 
28493
  integer,intent(in) :: rank
 
28494
!
 
28495
  type(mp_complex) &  
 
28496
    :: ss
 
28497
  type(mp_real) & 
 
28498
    :: am,hh,mulocal,mulocal2
 
28499
  integer :: ii
 
28500
  character(25+99) ,parameter :: warning=&
 
28501
                     'WARNING from OneLOop An: '//warnonshell
 
28502
  if (initz) call init
 
28503
!
 
28504
  mulocal = muscale 
 
28505
!
 
28506
  am = abs(mm)
 
28507
!
 
28508
  mulocal2 = mulocal*mulocal
 
28509
!
 
28510
  if (nonzerothrs) then
 
28511
    hh = onshellthrs
 
28512
    if (am.lt.hh) am = 0
 
28513
  elseif (wunit.gt.0) then
 
28514
    hh = onshellthrs*max(am,mulocal2)
 
28515
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
28516
  endif
 
28517
!
 
28518
  ss = mm
 
28519
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
28520
!
 
28521
  if (punit.gt.0) then
 
28522
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
28523
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
28524
    write(punit,*) ' mm:',trim(myprint(mm))
 
28525
    do ii=0,rank/2
 
28526
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
28527
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
28528
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
28529
    enddo
 
28530
  endif
 
28531
  end subroutine
 
28532
 
 
28533
  subroutine anrr( rslt ,rank ,mm ,rmu )
 
28534
!
 
28535
  use avh_olo_mp_bub ,only: tadpn
 
28536
!
 
28537
  type(mp_complex) &  
 
28538
    ,intent(out) :: rslt(0:,0:)   
 
28539
  type(mp_real) & 
 
28540
    ,intent(in)  :: mm
 
28541
  type(mp_real) & 
 
28542
   ,intent(in)  :: rmu       
 
28543
  integer,intent(in) :: rank
 
28544
!
 
28545
  type(mp_complex) &  
 
28546
    :: ss
 
28547
  type(mp_real) & 
 
28548
    :: am,hh,mulocal,mulocal2
 
28549
  integer :: ii
 
28550
  character(25+99) ,parameter :: warning=&
 
28551
                     'WARNING from OneLOop An: '//warnonshell
 
28552
  if (initz) call init
 
28553
!
 
28554
  mulocal = rmu     
 
28555
!
 
28556
  am = abs(mm)
 
28557
!
 
28558
  mulocal2 = mulocal*mulocal
 
28559
!
 
28560
  if (nonzerothrs) then
 
28561
    hh = onshellthrs
 
28562
    if (am.lt.hh) am = 0
 
28563
  elseif (wunit.gt.0) then
 
28564
    hh = onshellthrs*max(am,mulocal2)
 
28565
    if (RZRO.lt.am.and.am.lt.hh) write(wunit,*) warning
 
28566
  endif
 
28567
!
 
28568
  ss = mm
 
28569
  call tadpn( rslt ,rank ,ss ,am ,mulocal2 )
 
28570
!
 
28571
  if (punit.gt.0) then
 
28572
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
28573
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
28574
    write(punit,*) ' mm:',trim(myprint(mm))
 
28575
    do ii=0,rank/2
 
28576
    write(punit,*) 'A(2,',trim(myprint(ii)),'):',trim(myprint(rslt(2,ii)))
 
28577
    write(punit,*) 'A(1,',trim(myprint(ii)),'):',trim(myprint(rslt(1,ii)))
 
28578
    write(punit,*) 'A(0,',trim(myprint(ii)),'):',trim(myprint(rslt(0,ii)))
 
28579
    enddo
 
28580
  endif
 
28581
  end subroutine
 
28582
 
 
28583
 
15649
28584
!*******************************************************************
15650
28585
!
15651
28586
!           C   /      d^(Dim)q
15668
28603
!
15669
28604
  use avh_olo_mp_bub ,only: bub0
15670
28605
!
15671
 
  include 'cts_mpc.h'
 
28606
  type(mp_complex) &  
15672
28607
    ,intent(out) :: rslt(0:2)
15673
 
  include 'cts_mpc.h'
 
28608
  type(mp_complex) &  
15674
28609
    ,intent(in)  :: pp
15675
 
  include 'cts_mpc.h'
 
28610
  type(mp_complex) &  
15676
28611
    ,intent(in)  :: m1,m2
15677
28612
!
15678
 
  include 'cts_mpc.h'
 
28613
  type(mp_complex) &  
15679
28614
    :: ss,r1,r2
15680
 
  include 'cts_mpr.h'
 
28615
  type(mp_real) & 
15681
28616
    :: app,am1,am2,hh,mulocal,mulocal2
15682
28617
  character(25+99) ,parameter :: warning=&
15683
28618
                     'WARNING from OneLOop b0: '//warnonshell
15702
28637
    r1 = acmplx( am1 ,-hh )
15703
28638
  endif
15704
28639
  am1 = abs(am1) + abs(hh)
15705
 
 
 
28640
!
15706
28641
  am2 = areal(r2)
15707
28642
  hh  = aimag(r2)
15708
28643
  if (hh.gt.RZRO) then
15712
28647
  endif
15713
28648
  am2 = abs(am2) + abs(hh)
15714
28649
!
15715
 
  mulocal = muscale
 
28650
  mulocal = muscale 
15716
28651
!
15717
28652
  mulocal2 = mulocal*mulocal
15718
28653
!
15746
28681
!
15747
28682
  use avh_olo_mp_bub ,only: bub0
15748
28683
!
15749
 
  include 'cts_mpc.h'
 
28684
  type(mp_complex) &  
15750
28685
    ,intent(out) :: rslt(0:2)
15751
 
  include 'cts_mpc.h'
 
28686
  type(mp_complex) &  
15752
28687
    ,intent(in)  :: pp
15753
 
  include 'cts_mpc.h'
 
28688
  type(mp_complex) &  
15754
28689
    ,intent(in)  :: m1,m2
15755
 
  include 'cts_mpr.h'
15756
 
   ,intent(in)  :: rmu
 
28690
  type(mp_real) & 
 
28691
   ,intent(in)  :: rmu       
15757
28692
!
15758
 
  include 'cts_mpc.h'
 
28693
  type(mp_complex) &  
15759
28694
    :: ss,r1,r2
15760
 
  include 'cts_mpr.h'
 
28695
  type(mp_real) & 
15761
28696
    :: app,am1,am2,hh,mulocal,mulocal2
15762
28697
  character(25+99) ,parameter :: warning=&
15763
28698
                     'WARNING from OneLOop b0: '//warnonshell
15782
28717
    r1 = acmplx( am1 ,-hh )
15783
28718
  endif
15784
28719
  am1 = abs(am1) + abs(hh)
15785
 
 
 
28720
!
15786
28721
  am2 = areal(r2)
15787
28722
  hh  = aimag(r2)
15788
28723
  if (hh.gt.RZRO) then
15792
28727
  endif
15793
28728
  am2 = abs(am2) + abs(hh)
15794
28729
!
15795
 
  mulocal = rmu
 
28730
  mulocal = rmu     
15796
28731
!
15797
28732
  mulocal2 = mulocal*mulocal
15798
28733
!
15826
28761
!
15827
28762
  use avh_olo_mp_bub ,only: bub0
15828
28763
!
15829
 
  include 'cts_mpc.h'
 
28764
  type(mp_complex) &  
15830
28765
    ,intent(out) :: rslt(0:2)
15831
 
  include 'cts_mpr.h'
 
28766
  type(mp_real) & 
15832
28767
    ,intent(in)  :: pp
15833
 
  include 'cts_mpc.h'
 
28768
  type(mp_complex) &  
15834
28769
    ,intent(in)  :: m1,m2
15835
28770
!
15836
 
  include 'cts_mpc.h'
 
28771
  type(mp_complex) &  
15837
28772
    :: ss,r1,r2
15838
 
  include 'cts_mpr.h'
 
28773
  type(mp_real) & 
15839
28774
    :: app,am1,am2,hh,mulocal,mulocal2
15840
28775
  character(25+99) ,parameter :: warning=&
15841
28776
                     'WARNING from OneLOop b0: '//warnonshell
15844
28779
  r1 = m1
15845
28780
  r2 = m2
15846
28781
!
15847
 
  app=abs(pp)
 
28782
  app = abs(pp)
15848
28783
!
15849
28784
  am1 = areal(r1)
15850
28785
  hh  = aimag(r1)
15854
28789
    r1 = acmplx( am1 ,-hh )
15855
28790
  endif
15856
28791
  am1 = abs(am1) + abs(hh)
15857
 
 
 
28792
!
15858
28793
  am2 = areal(r2)
15859
28794
  hh  = aimag(r2)
15860
28795
  if (hh.gt.RZRO) then
15864
28799
  endif
15865
28800
  am2 = abs(am2) + abs(hh)
15866
28801
!
15867
 
  mulocal = muscale
 
28802
  mulocal = muscale 
15868
28803
!
15869
28804
  mulocal2 = mulocal*mulocal
15870
28805
!
15898
28833
!
15899
28834
  use avh_olo_mp_bub ,only: bub0
15900
28835
!
15901
 
  include 'cts_mpc.h'
 
28836
  type(mp_complex) &  
15902
28837
    ,intent(out) :: rslt(0:2)
15903
 
  include 'cts_mpr.h'
 
28838
  type(mp_real) & 
15904
28839
    ,intent(in)  :: pp
15905
 
  include 'cts_mpc.h'
 
28840
  type(mp_complex) &  
15906
28841
    ,intent(in)  :: m1,m2
15907
 
  include 'cts_mpr.h'
15908
 
   ,intent(in)  :: rmu
 
28842
  type(mp_real) & 
 
28843
   ,intent(in)  :: rmu       
15909
28844
!
15910
 
  include 'cts_mpc.h'
 
28845
  type(mp_complex) &  
15911
28846
    :: ss,r1,r2
15912
 
  include 'cts_mpr.h'
 
28847
  type(mp_real) & 
15913
28848
    :: app,am1,am2,hh,mulocal,mulocal2
15914
28849
  character(25+99) ,parameter :: warning=&
15915
28850
                     'WARNING from OneLOop b0: '//warnonshell
15918
28853
  r1 = m1
15919
28854
  r2 = m2
15920
28855
!
15921
 
  app=abs(pp)
 
28856
  app = abs(pp)
15922
28857
!
15923
28858
  am1 = areal(r1)
15924
28859
  hh  = aimag(r1)
15928
28863
    r1 = acmplx( am1 ,-hh )
15929
28864
  endif
15930
28865
  am1 = abs(am1) + abs(hh)
15931
 
 
 
28866
!
15932
28867
  am2 = areal(r2)
15933
28868
  hh  = aimag(r2)
15934
28869
  if (hh.gt.RZRO) then
15938
28873
  endif
15939
28874
  am2 = abs(am2) + abs(hh)
15940
28875
!
15941
 
  mulocal = rmu
 
28876
  mulocal = rmu     
15942
28877
!
15943
28878
  mulocal2 = mulocal*mulocal
15944
28879
!
15972
28907
!
15973
28908
  use avh_olo_mp_bub ,only: bub0
15974
28909
!
15975
 
  include 'cts_mpc.h'
 
28910
  type(mp_complex) &  
15976
28911
    ,intent(out) :: rslt(0:2)
15977
 
  include 'cts_mpr.h'
 
28912
  type(mp_real) & 
15978
28913
    ,intent(in)  :: pp
15979
 
  include 'cts_mpr.h'
 
28914
  type(mp_real) & 
15980
28915
    ,intent(in)  :: m1,m2
15981
28916
!
15982
 
  include 'cts_mpc.h'
 
28917
  type(mp_complex) &  
15983
28918
    :: ss,r1,r2
15984
 
  include 'cts_mpr.h'
 
28919
  type(mp_real) & 
15985
28920
    :: app,am1,am2,hh,mulocal,mulocal2
15986
28921
  character(25+99) ,parameter :: warning=&
15987
28922
                     'WARNING from OneLOop b0: '//warnonshell
15990
28925
  r1 = m1
15991
28926
  r2 = m2
15992
28927
!
15993
 
  app=abs(pp)
 
28928
  app = abs(pp)
15994
28929
!
15995
28930
  am1 = abs(m1)
15996
28931
  am2 = abs(m2)
15997
28932
!
15998
 
  mulocal = muscale
 
28933
  mulocal = muscale 
15999
28934
!
16000
28935
  mulocal2 = mulocal*mulocal
16001
28936
!
16029
28964
!
16030
28965
  use avh_olo_mp_bub ,only: bub0
16031
28966
!
16032
 
  include 'cts_mpc.h'
 
28967
  type(mp_complex) &  
16033
28968
    ,intent(out) :: rslt(0:2)
16034
 
  include 'cts_mpr.h'
 
28969
  type(mp_real) & 
16035
28970
    ,intent(in)  :: pp
16036
 
  include 'cts_mpr.h'
 
28971
  type(mp_real) & 
16037
28972
    ,intent(in)  :: m1,m2
16038
 
  include 'cts_mpr.h'
16039
 
   ,intent(in)  :: rmu
 
28973
  type(mp_real) & 
 
28974
   ,intent(in)  :: rmu       
16040
28975
!
16041
 
  include 'cts_mpc.h'
 
28976
  type(mp_complex) &  
16042
28977
    :: ss,r1,r2
16043
 
  include 'cts_mpr.h'
 
28978
  type(mp_real) & 
16044
28979
    :: app,am1,am2,hh,mulocal,mulocal2
16045
28980
  character(25+99) ,parameter :: warning=&
16046
28981
                     'WARNING from OneLOop b0: '//warnonshell
16049
28984
  r1 = m1
16050
28985
  r2 = m2
16051
28986
!
16052
 
  app=abs(pp)
 
28987
  app = abs(pp)
16053
28988
!
16054
28989
  am1 = abs(m1)
16055
28990
  am2 = abs(m2)
16056
28991
!
16057
 
  mulocal = rmu
 
28992
  mulocal = rmu     
16058
28993
!
16059
28994
  mulocal2 = mulocal*mulocal
16060
28995
!
16108
29043
!
16109
29044
  use avh_olo_mp_bub ,only: bub11
16110
29045
!
16111
 
  include 'cts_mpc.h'
 
29046
  type(mp_complex) &  
16112
29047
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16113
 
  include 'cts_mpc.h'
 
29048
  type(mp_complex) &  
16114
29049
    ,intent(in)  :: pp
16115
 
  include 'cts_mpc.h'
 
29050
  type(mp_complex) &  
16116
29051
    ,intent(in)  :: m1,m2
16117
29052
!
16118
 
  include 'cts_mpc.h'
 
29053
  type(mp_complex) &  
16119
29054
    :: ss,r1,r2
16120
 
  include 'cts_mpr.h'
 
29055
  type(mp_real) & 
16121
29056
    :: app,am1,am2,hh,mulocal,mulocal2
16122
29057
  character(26+99) ,parameter :: warning=&
16123
29058
                     'WARNING from OneLOop b11: '//warnonshell
16142
29077
    r1 = acmplx( am1 ,-hh )
16143
29078
  endif
16144
29079
  am1 = abs(am1) + abs(hh)
16145
 
 
 
29080
!
16146
29081
  am2 = areal(r2)
16147
29082
  hh  = aimag(r2)
16148
29083
  if (hh.gt.RZRO) then
16152
29087
  endif
16153
29088
  am2 = abs(am2) + abs(hh)
16154
29089
!
16155
 
  mulocal = muscale
 
29090
  mulocal = muscale 
16156
29091
!
16157
29092
  mulocal2 = mulocal*mulocal
16158
29093
!
16195
29130
!
16196
29131
  use avh_olo_mp_bub ,only: bub11
16197
29132
!
16198
 
  include 'cts_mpc.h'
 
29133
  type(mp_complex) &  
16199
29134
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16200
 
  include 'cts_mpc.h'
 
29135
  type(mp_complex) &  
16201
29136
    ,intent(in)  :: pp
16202
 
  include 'cts_mpc.h'
 
29137
  type(mp_complex) &  
16203
29138
    ,intent(in)  :: m1,m2
16204
 
  include 'cts_mpr.h'
16205
 
   ,intent(in)  :: rmu
 
29139
  type(mp_real) & 
 
29140
   ,intent(in)  :: rmu       
16206
29141
!
16207
 
  include 'cts_mpc.h'
 
29142
  type(mp_complex) &  
16208
29143
    :: ss,r1,r2
16209
 
  include 'cts_mpr.h'
 
29144
  type(mp_real) & 
16210
29145
    :: app,am1,am2,hh,mulocal,mulocal2
16211
29146
  character(26+99) ,parameter :: warning=&
16212
29147
                     'WARNING from OneLOop b11: '//warnonshell
16231
29166
    r1 = acmplx( am1 ,-hh )
16232
29167
  endif
16233
29168
  am1 = abs(am1) + abs(hh)
16234
 
 
 
29169
!
16235
29170
  am2 = areal(r2)
16236
29171
  hh  = aimag(r2)
16237
29172
  if (hh.gt.RZRO) then
16241
29176
  endif
16242
29177
  am2 = abs(am2) + abs(hh)
16243
29178
!
16244
 
  mulocal = rmu
 
29179
  mulocal = rmu     
16245
29180
!
16246
29181
  mulocal2 = mulocal*mulocal
16247
29182
!
16284
29219
!
16285
29220
  use avh_olo_mp_bub ,only: bub11
16286
29221
!
16287
 
  include 'cts_mpc.h'
 
29222
  type(mp_complex) &  
16288
29223
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16289
 
  include 'cts_mpr.h'
 
29224
  type(mp_real) & 
16290
29225
    ,intent(in)  :: pp
16291
 
  include 'cts_mpc.h'
 
29226
  type(mp_complex) &  
16292
29227
    ,intent(in)  :: m1,m2
16293
29228
!
16294
 
  include 'cts_mpc.h'
 
29229
  type(mp_complex) &  
16295
29230
    :: ss,r1,r2
16296
 
  include 'cts_mpr.h'
 
29231
  type(mp_real) & 
16297
29232
    :: app,am1,am2,hh,mulocal,mulocal2
16298
29233
  character(26+99) ,parameter :: warning=&
16299
29234
                     'WARNING from OneLOop b11: '//warnonshell
16302
29237
  r1 = m1
16303
29238
  r2 = m2
16304
29239
!
16305
 
  app=abs(pp)
 
29240
  app = abs(pp)
16306
29241
!
16307
29242
  am1 = areal(r1)
16308
29243
  hh  = aimag(r1)
16312
29247
    r1 = acmplx( am1 ,-hh )
16313
29248
  endif
16314
29249
  am1 = abs(am1) + abs(hh)
16315
 
 
 
29250
!
16316
29251
  am2 = areal(r2)
16317
29252
  hh  = aimag(r2)
16318
29253
  if (hh.gt.RZRO) then
16322
29257
  endif
16323
29258
  am2 = abs(am2) + abs(hh)
16324
29259
!
16325
 
  mulocal = muscale
 
29260
  mulocal = muscale 
16326
29261
!
16327
29262
  mulocal2 = mulocal*mulocal
16328
29263
!
16365
29300
!
16366
29301
  use avh_olo_mp_bub ,only: bub11
16367
29302
!
16368
 
  include 'cts_mpc.h'
 
29303
  type(mp_complex) &  
16369
29304
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16370
 
  include 'cts_mpr.h'
 
29305
  type(mp_real) & 
16371
29306
    ,intent(in)  :: pp
16372
 
  include 'cts_mpc.h'
 
29307
  type(mp_complex) &  
16373
29308
    ,intent(in)  :: m1,m2
16374
 
  include 'cts_mpr.h'
16375
 
   ,intent(in)  :: rmu
 
29309
  type(mp_real) & 
 
29310
   ,intent(in)  :: rmu       
16376
29311
!
16377
 
  include 'cts_mpc.h'
 
29312
  type(mp_complex) &  
16378
29313
    :: ss,r1,r2
16379
 
  include 'cts_mpr.h'
 
29314
  type(mp_real) & 
16380
29315
    :: app,am1,am2,hh,mulocal,mulocal2
16381
29316
  character(26+99) ,parameter :: warning=&
16382
29317
                     'WARNING from OneLOop b11: '//warnonshell
16385
29320
  r1 = m1
16386
29321
  r2 = m2
16387
29322
!
16388
 
  app=abs(pp)
 
29323
  app = abs(pp)
16389
29324
!
16390
29325
  am1 = areal(r1)
16391
29326
  hh  = aimag(r1)
16395
29330
    r1 = acmplx( am1 ,-hh )
16396
29331
  endif
16397
29332
  am1 = abs(am1) + abs(hh)
16398
 
 
 
29333
!
16399
29334
  am2 = areal(r2)
16400
29335
  hh  = aimag(r2)
16401
29336
  if (hh.gt.RZRO) then
16405
29340
  endif
16406
29341
  am2 = abs(am2) + abs(hh)
16407
29342
!
16408
 
  mulocal = rmu
 
29343
  mulocal = rmu     
16409
29344
!
16410
29345
  mulocal2 = mulocal*mulocal
16411
29346
!
16448
29383
!
16449
29384
  use avh_olo_mp_bub ,only: bub11
16450
29385
!
16451
 
  include 'cts_mpc.h'
 
29386
  type(mp_complex) &  
16452
29387
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16453
 
  include 'cts_mpr.h'
 
29388
  type(mp_real) & 
16454
29389
    ,intent(in)  :: pp
16455
 
  include 'cts_mpr.h'
 
29390
  type(mp_real) & 
16456
29391
    ,intent(in)  :: m1,m2
16457
29392
!
16458
 
  include 'cts_mpc.h'
 
29393
  type(mp_complex) &  
16459
29394
    :: ss,r1,r2
16460
 
  include 'cts_mpr.h'
 
29395
  type(mp_real) & 
16461
29396
    :: app,am1,am2,hh,mulocal,mulocal2
16462
29397
  character(26+99) ,parameter :: warning=&
16463
29398
                     'WARNING from OneLOop b11: '//warnonshell
16466
29401
  r1 = m1
16467
29402
  r2 = m2
16468
29403
!
16469
 
  app=abs(pp)
 
29404
  app = abs(pp)
16470
29405
!
16471
29406
  am1 = abs(m1)
16472
29407
  am2 = abs(m2)
16473
29408
!
16474
 
  mulocal = muscale
 
29409
  mulocal = muscale 
16475
29410
!
16476
29411
  mulocal2 = mulocal*mulocal
16477
29412
!
16514
29449
!
16515
29450
  use avh_olo_mp_bub ,only: bub11
16516
29451
!
16517
 
  include 'cts_mpc.h'
 
29452
  type(mp_complex) &  
16518
29453
    ,intent(out) :: b11(0:2),b00(0:2),b1(0:2),b0(0:2)
16519
 
  include 'cts_mpr.h'
 
29454
  type(mp_real) & 
16520
29455
    ,intent(in)  :: pp
16521
 
  include 'cts_mpr.h'
 
29456
  type(mp_real) & 
16522
29457
    ,intent(in)  :: m1,m2
16523
 
  include 'cts_mpr.h'
16524
 
   ,intent(in)  :: rmu
 
29458
  type(mp_real) & 
 
29459
   ,intent(in)  :: rmu       
16525
29460
!
16526
 
  include 'cts_mpc.h'
 
29461
  type(mp_complex) &  
16527
29462
    :: ss,r1,r2
16528
 
  include 'cts_mpr.h'
 
29463
  type(mp_real) & 
16529
29464
    :: app,am1,am2,hh,mulocal,mulocal2
16530
29465
  character(26+99) ,parameter :: warning=&
16531
29466
                     'WARNING from OneLOop b11: '//warnonshell
16534
29469
  r1 = m1
16535
29470
  r2 = m2
16536
29471
!
16537
 
  app=abs(pp)
 
29472
  app = abs(pp)
16538
29473
!
16539
29474
  am1 = abs(m1)
16540
29475
  am2 = abs(m2)
16541
29476
!
16542
 
  mulocal = rmu
 
29477
  mulocal = rmu     
16543
29478
!
16544
29479
  mulocal2 = mulocal*mulocal
16545
29480
!
16579
29514
  end subroutine
16580
29515
 
16581
29516
 
 
29517
  subroutine bncc( rslt ,rank ,pp,m1,m2 )
 
29518
!
 
29519
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
29520
!
 
29521
  type(mp_complex) &  
 
29522
    ,intent(out) :: rslt(0:,0:)   
 
29523
  type(mp_complex) &  
 
29524
    ,intent(in)  :: pp
 
29525
  type(mp_complex) &  
 
29526
    ,intent(in)  :: m1,m2
 
29527
  integer,intent(in) :: rank
 
29528
!
 
29529
  type(mp_complex) &  
 
29530
    :: ss,r1,r2
 
29531
  type(mp_real) & 
 
29532
    :: app,am1,am2,hh,mulocal,mulocal2
 
29533
  character(26+99) ,parameter :: warning=&
 
29534
                     'WARNING from OneLOop bn: '//warnonshell
 
29535
  if (initz) call init
 
29536
  ss = pp
 
29537
  r1 = m1
 
29538
  r2 = m2
 
29539
!
 
29540
  app = areal(ss)
 
29541
  if (aimag(ss).ne.RZRO) then
 
29542
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29543
      ,'ss has non-zero imaginary part, putting it to zero.'
 
29544
    ss = acmplx( app )
 
29545
  endif
 
29546
  app = abs(app)
 
29547
!
 
29548
  am1 = areal(r1)
 
29549
  hh  = aimag(r1)
 
29550
  if (hh.gt.RZRO) then
 
29551
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29552
      ,'r1 has positive imaginary part, switching its sign.'
 
29553
    r1 = acmplx( am1 ,-hh )
 
29554
  endif
 
29555
  am1 = abs(am1) + abs(hh)
 
29556
!
 
29557
  am2 = areal(r2)
 
29558
  hh  = aimag(r2)
 
29559
  if (hh.gt.RZRO) then
 
29560
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29561
      ,'r2 has positive imaginary part, switching its sign.'
 
29562
    r2 = acmplx( am2 ,-hh )
 
29563
  endif
 
29564
  am2 = abs(am2) + abs(hh)
 
29565
!
 
29566
  mulocal = muscale 
 
29567
!
 
29568
  mulocal2 = mulocal*mulocal
 
29569
!
 
29570
  if (nonzerothrs) then
 
29571
    hh = onshellthrs
 
29572
    if (app.lt.hh) app = 0
 
29573
    if (am1.lt.hh) am1 = 0
 
29574
    if (am2.lt.hh) am2 = 0
 
29575
  elseif (wunit.gt.0) then
 
29576
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
29577
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
29578
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
29579
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
29580
  endif
 
29581
!
 
29582
  if     (rank.eq.0) then
 
29583
    call bub0( rslt(:,0) &
 
29584
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29585
  elseif (rank.eq.1) then
 
29586
    call bub1( rslt(:,1),rslt(:,0) &
 
29587
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29588
  elseif (rank.eq.2) then
 
29589
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29590
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29591
  elseif (rank.eq.3) then
 
29592
    call bub111( rslt(:,5),rslt(:,4) &
 
29593
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29594
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29595
  elseif (rank.eq.4) then
 
29596
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
29597
                 ,rslt(:,5),rslt(:,4) &
 
29598
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29599
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29600
  else
 
29601
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29602
      ,'rank=',rank,' not implemented'
 
29603
  endif
 
29604
!
 
29605
  if (punit.gt.0) then
 
29606
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
29607
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
29608
    write(punit,*) 'pp:',trim(myprint(pp))
 
29609
    write(punit,*) 'm1:',trim(myprint(m1))
 
29610
    write(punit,*) 'm2:',trim(myprint(m2))
 
29611
    if (rank.ge.0) then
 
29612
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
29613
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
29614
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
29615
    if (rank.ge.1) then
 
29616
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
29617
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
29618
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
29619
    if (rank.ge.2) then
 
29620
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
29621
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
29622
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
29623
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
29624
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
29625
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
29626
    if (rank.ge.3) then
 
29627
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
29628
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
29629
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
29630
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
29631
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
29632
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
29633
    if (rank.ge.4) then
 
29634
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
29635
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
29636
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
29637
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
29638
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
29639
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
29640
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
29641
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
29642
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
29643
    endif;endif;endif;endif;endif
 
29644
  endif
 
29645
  end subroutine
 
29646
 
 
29647
  subroutine bnccr( rslt ,rank ,pp,m1,m2 ,rmu )
 
29648
!
 
29649
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
29650
!
 
29651
  type(mp_complex) &  
 
29652
    ,intent(out) :: rslt(0:,0:)   
 
29653
  type(mp_complex) &  
 
29654
    ,intent(in)  :: pp
 
29655
  type(mp_complex) &  
 
29656
    ,intent(in)  :: m1,m2
 
29657
  type(mp_real) & 
 
29658
   ,intent(in)  :: rmu       
 
29659
  integer,intent(in) :: rank
 
29660
!
 
29661
  type(mp_complex) &  
 
29662
    :: ss,r1,r2
 
29663
  type(mp_real) & 
 
29664
    :: app,am1,am2,hh,mulocal,mulocal2
 
29665
  character(26+99) ,parameter :: warning=&
 
29666
                     'WARNING from OneLOop bn: '//warnonshell
 
29667
  if (initz) call init
 
29668
  ss = pp
 
29669
  r1 = m1
 
29670
  r2 = m2
 
29671
!
 
29672
  app = areal(ss)
 
29673
  if (aimag(ss).ne.RZRO) then
 
29674
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29675
      ,'ss has non-zero imaginary part, putting it to zero.'
 
29676
    ss = acmplx( app )
 
29677
  endif
 
29678
  app = abs(app)
 
29679
!
 
29680
  am1 = areal(r1)
 
29681
  hh  = aimag(r1)
 
29682
  if (hh.gt.RZRO) then
 
29683
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29684
      ,'r1 has positive imaginary part, switching its sign.'
 
29685
    r1 = acmplx( am1 ,-hh )
 
29686
  endif
 
29687
  am1 = abs(am1) + abs(hh)
 
29688
!
 
29689
  am2 = areal(r2)
 
29690
  hh  = aimag(r2)
 
29691
  if (hh.gt.RZRO) then
 
29692
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29693
      ,'r2 has positive imaginary part, switching its sign.'
 
29694
    r2 = acmplx( am2 ,-hh )
 
29695
  endif
 
29696
  am2 = abs(am2) + abs(hh)
 
29697
!
 
29698
  mulocal = rmu     
 
29699
!
 
29700
  mulocal2 = mulocal*mulocal
 
29701
!
 
29702
  if (nonzerothrs) then
 
29703
    hh = onshellthrs
 
29704
    if (app.lt.hh) app = 0
 
29705
    if (am1.lt.hh) am1 = 0
 
29706
    if (am2.lt.hh) am2 = 0
 
29707
  elseif (wunit.gt.0) then
 
29708
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
29709
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
29710
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
29711
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
29712
  endif
 
29713
!
 
29714
  if     (rank.eq.0) then
 
29715
    call bub0( rslt(:,0) &
 
29716
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29717
  elseif (rank.eq.1) then
 
29718
    call bub1( rslt(:,1),rslt(:,0) &
 
29719
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29720
  elseif (rank.eq.2) then
 
29721
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29722
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29723
  elseif (rank.eq.3) then
 
29724
    call bub111( rslt(:,5),rslt(:,4) &
 
29725
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29726
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29727
  elseif (rank.eq.4) then
 
29728
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
29729
                 ,rslt(:,5),rslt(:,4) &
 
29730
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29731
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29732
  else
 
29733
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29734
      ,'rank=',rank,' not implemented'
 
29735
  endif
 
29736
!
 
29737
  if (punit.gt.0) then
 
29738
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
29739
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
29740
    write(punit,*) 'pp:',trim(myprint(pp))
 
29741
    write(punit,*) 'm1:',trim(myprint(m1))
 
29742
    write(punit,*) 'm2:',trim(myprint(m2))
 
29743
    if (rank.ge.0) then
 
29744
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
29745
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
29746
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
29747
    if (rank.ge.1) then
 
29748
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
29749
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
29750
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
29751
    if (rank.ge.2) then
 
29752
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
29753
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
29754
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
29755
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
29756
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
29757
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
29758
    if (rank.ge.3) then
 
29759
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
29760
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
29761
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
29762
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
29763
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
29764
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
29765
    if (rank.ge.4) then
 
29766
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
29767
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
29768
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
29769
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
29770
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
29771
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
29772
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
29773
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
29774
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
29775
    endif;endif;endif;endif;endif
 
29776
  endif
 
29777
  end subroutine
 
29778
 
 
29779
  subroutine bnrc( rslt ,rank ,pp,m1,m2 )
 
29780
!
 
29781
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
29782
!
 
29783
  type(mp_complex) &  
 
29784
    ,intent(out) :: rslt(0:,0:)   
 
29785
  type(mp_real) & 
 
29786
    ,intent(in)  :: pp
 
29787
  type(mp_complex) &  
 
29788
    ,intent(in)  :: m1,m2
 
29789
  integer,intent(in) :: rank
 
29790
!
 
29791
  type(mp_complex) &  
 
29792
    :: ss,r1,r2
 
29793
  type(mp_real) & 
 
29794
    :: app,am1,am2,hh,mulocal,mulocal2
 
29795
  character(26+99) ,parameter :: warning=&
 
29796
                     'WARNING from OneLOop bn: '//warnonshell
 
29797
  if (initz) call init
 
29798
  ss = pp
 
29799
  r1 = m1
 
29800
  r2 = m2
 
29801
!
 
29802
  app = abs(pp)
 
29803
!
 
29804
  am1 = areal(r1)
 
29805
  hh  = aimag(r1)
 
29806
  if (hh.gt.RZRO) then
 
29807
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29808
      ,'r1 has positive imaginary part, switching its sign.'
 
29809
    r1 = acmplx( am1 ,-hh )
 
29810
  endif
 
29811
  am1 = abs(am1) + abs(hh)
 
29812
!
 
29813
  am2 = areal(r2)
 
29814
  hh  = aimag(r2)
 
29815
  if (hh.gt.RZRO) then
 
29816
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29817
      ,'r2 has positive imaginary part, switching its sign.'
 
29818
    r2 = acmplx( am2 ,-hh )
 
29819
  endif
 
29820
  am2 = abs(am2) + abs(hh)
 
29821
!
 
29822
  mulocal = muscale 
 
29823
!
 
29824
  mulocal2 = mulocal*mulocal
 
29825
!
 
29826
  if (nonzerothrs) then
 
29827
    hh = onshellthrs
 
29828
    if (app.lt.hh) app = 0
 
29829
    if (am1.lt.hh) am1 = 0
 
29830
    if (am2.lt.hh) am2 = 0
 
29831
  elseif (wunit.gt.0) then
 
29832
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
29833
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
29834
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
29835
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
29836
  endif
 
29837
!
 
29838
  if     (rank.eq.0) then
 
29839
    call bub0( rslt(:,0) &
 
29840
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29841
  elseif (rank.eq.1) then
 
29842
    call bub1( rslt(:,1),rslt(:,0) &
 
29843
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29844
  elseif (rank.eq.2) then
 
29845
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29846
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29847
  elseif (rank.eq.3) then
 
29848
    call bub111( rslt(:,5),rslt(:,4) &
 
29849
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29850
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29851
  elseif (rank.eq.4) then
 
29852
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
29853
                 ,rslt(:,5),rslt(:,4) &
 
29854
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29855
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29856
  else
 
29857
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29858
      ,'rank=',rank,' not implemented'
 
29859
  endif
 
29860
!
 
29861
  if (punit.gt.0) then
 
29862
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
29863
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
29864
    write(punit,*) 'pp:',trim(myprint(pp))
 
29865
    write(punit,*) 'm1:',trim(myprint(m1))
 
29866
    write(punit,*) 'm2:',trim(myprint(m2))
 
29867
    if (rank.ge.0) then
 
29868
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
29869
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
29870
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
29871
    if (rank.ge.1) then
 
29872
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
29873
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
29874
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
29875
    if (rank.ge.2) then
 
29876
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
29877
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
29878
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
29879
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
29880
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
29881
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
29882
    if (rank.ge.3) then
 
29883
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
29884
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
29885
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
29886
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
29887
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
29888
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
29889
    if (rank.ge.4) then
 
29890
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
29891
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
29892
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
29893
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
29894
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
29895
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
29896
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
29897
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
29898
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
29899
    endif;endif;endif;endif;endif
 
29900
  endif
 
29901
  end subroutine
 
29902
 
 
29903
  subroutine bnrcr( rslt ,rank ,pp,m1,m2 ,rmu )
 
29904
!
 
29905
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
29906
!
 
29907
  type(mp_complex) &  
 
29908
    ,intent(out) :: rslt(0:,0:)   
 
29909
  type(mp_real) & 
 
29910
    ,intent(in)  :: pp
 
29911
  type(mp_complex) &  
 
29912
    ,intent(in)  :: m1,m2
 
29913
  type(mp_real) & 
 
29914
   ,intent(in)  :: rmu       
 
29915
  integer,intent(in) :: rank
 
29916
!
 
29917
  type(mp_complex) &  
 
29918
    :: ss,r1,r2
 
29919
  type(mp_real) & 
 
29920
    :: app,am1,am2,hh,mulocal,mulocal2
 
29921
  character(26+99) ,parameter :: warning=&
 
29922
                     'WARNING from OneLOop bn: '//warnonshell
 
29923
  if (initz) call init
 
29924
  ss = pp
 
29925
  r1 = m1
 
29926
  r2 = m2
 
29927
!
 
29928
  app = abs(pp)
 
29929
!
 
29930
  am1 = areal(r1)
 
29931
  hh  = aimag(r1)
 
29932
  if (hh.gt.RZRO) then
 
29933
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29934
      ,'r1 has positive imaginary part, switching its sign.'
 
29935
    r1 = acmplx( am1 ,-hh )
 
29936
  endif
 
29937
  am1 = abs(am1) + abs(hh)
 
29938
!
 
29939
  am2 = areal(r2)
 
29940
  hh  = aimag(r2)
 
29941
  if (hh.gt.RZRO) then
 
29942
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29943
      ,'r2 has positive imaginary part, switching its sign.'
 
29944
    r2 = acmplx( am2 ,-hh )
 
29945
  endif
 
29946
  am2 = abs(am2) + abs(hh)
 
29947
!
 
29948
  mulocal = rmu     
 
29949
!
 
29950
  mulocal2 = mulocal*mulocal
 
29951
!
 
29952
  if (nonzerothrs) then
 
29953
    hh = onshellthrs
 
29954
    if (app.lt.hh) app = 0
 
29955
    if (am1.lt.hh) am1 = 0
 
29956
    if (am2.lt.hh) am2 = 0
 
29957
  elseif (wunit.gt.0) then
 
29958
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
29959
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
29960
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
29961
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
29962
  endif
 
29963
!
 
29964
  if     (rank.eq.0) then
 
29965
    call bub0( rslt(:,0) &
 
29966
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29967
  elseif (rank.eq.1) then
 
29968
    call bub1( rslt(:,1),rslt(:,0) &
 
29969
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29970
  elseif (rank.eq.2) then
 
29971
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29972
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29973
  elseif (rank.eq.3) then
 
29974
    call bub111( rslt(:,5),rslt(:,4) &
 
29975
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29976
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29977
  elseif (rank.eq.4) then
 
29978
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
29979
                 ,rslt(:,5),rslt(:,4) &
 
29980
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
29981
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
29982
  else
 
29983
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
29984
      ,'rank=',rank,' not implemented'
 
29985
  endif
 
29986
!
 
29987
  if (punit.gt.0) then
 
29988
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
29989
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
29990
    write(punit,*) 'pp:',trim(myprint(pp))
 
29991
    write(punit,*) 'm1:',trim(myprint(m1))
 
29992
    write(punit,*) 'm2:',trim(myprint(m2))
 
29993
    if (rank.ge.0) then
 
29994
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
29995
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
29996
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
29997
    if (rank.ge.1) then
 
29998
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
29999
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
30000
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
30001
    if (rank.ge.2) then
 
30002
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
30003
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
30004
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
30005
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
30006
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
30007
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
30008
    if (rank.ge.3) then
 
30009
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
30010
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
30011
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
30012
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
30013
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
30014
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
30015
    if (rank.ge.4) then
 
30016
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
30017
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
30018
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
30019
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
30020
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
30021
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
30022
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
30023
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
30024
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
30025
    endif;endif;endif;endif;endif
 
30026
  endif
 
30027
  end subroutine
 
30028
 
 
30029
  subroutine bnrr( rslt ,rank ,pp,m1,m2 )
 
30030
!
 
30031
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
30032
!
 
30033
  type(mp_complex) &  
 
30034
    ,intent(out) :: rslt(0:,0:)   
 
30035
  type(mp_real) & 
 
30036
    ,intent(in)  :: pp
 
30037
  type(mp_real) & 
 
30038
    ,intent(in)  :: m1,m2
 
30039
  integer,intent(in) :: rank
 
30040
!
 
30041
  type(mp_complex) &  
 
30042
    :: ss,r1,r2
 
30043
  type(mp_real) & 
 
30044
    :: app,am1,am2,hh,mulocal,mulocal2
 
30045
  character(26+99) ,parameter :: warning=&
 
30046
                     'WARNING from OneLOop bn: '//warnonshell
 
30047
  if (initz) call init
 
30048
  ss = pp
 
30049
  r1 = m1
 
30050
  r2 = m2
 
30051
!
 
30052
  app = abs(pp)
 
30053
!
 
30054
  am1 = abs(m1)
 
30055
  am2 = abs(m2)
 
30056
!
 
30057
  mulocal = muscale 
 
30058
!
 
30059
  mulocal2 = mulocal*mulocal
 
30060
!
 
30061
  if (nonzerothrs) then
 
30062
    hh = onshellthrs
 
30063
    if (app.lt.hh) app = 0
 
30064
    if (am1.lt.hh) am1 = 0
 
30065
    if (am2.lt.hh) am2 = 0
 
30066
  elseif (wunit.gt.0) then
 
30067
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
30068
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
30069
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
30070
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
30071
  endif
 
30072
!
 
30073
  if     (rank.eq.0) then
 
30074
    call bub0( rslt(:,0) &
 
30075
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30076
  elseif (rank.eq.1) then
 
30077
    call bub1( rslt(:,1),rslt(:,0) &
 
30078
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30079
  elseif (rank.eq.2) then
 
30080
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30081
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30082
  elseif (rank.eq.3) then
 
30083
    call bub111( rslt(:,5),rslt(:,4) &
 
30084
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30085
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30086
  elseif (rank.eq.4) then
 
30087
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
30088
                 ,rslt(:,5),rslt(:,4) &
 
30089
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30090
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30091
  else
 
30092
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
30093
      ,'rank=',rank,' not implemented'
 
30094
  endif
 
30095
!
 
30096
  if (punit.gt.0) then
 
30097
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
30098
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
30099
    write(punit,*) 'pp:',trim(myprint(pp))
 
30100
    write(punit,*) 'm1:',trim(myprint(m1))
 
30101
    write(punit,*) 'm2:',trim(myprint(m2))
 
30102
    if (rank.ge.0) then
 
30103
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
30104
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
30105
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
30106
    if (rank.ge.1) then
 
30107
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
30108
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
30109
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
30110
    if (rank.ge.2) then
 
30111
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
30112
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
30113
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
30114
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
30115
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
30116
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
30117
    if (rank.ge.3) then
 
30118
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
30119
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
30120
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
30121
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
30122
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
30123
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
30124
    if (rank.ge.4) then
 
30125
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
30126
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
30127
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
30128
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
30129
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
30130
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
30131
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
30132
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
30133
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
30134
    endif;endif;endif;endif;endif
 
30135
  endif
 
30136
  end subroutine
 
30137
 
 
30138
  subroutine bnrrr( rslt ,rank ,pp,m1,m2 ,rmu )
 
30139
!
 
30140
  use avh_olo_mp_bub ,only: bub0,bub1,bub11,bub111,bub1111
 
30141
!
 
30142
  type(mp_complex) &  
 
30143
    ,intent(out) :: rslt(0:,0:)   
 
30144
  type(mp_real) & 
 
30145
    ,intent(in)  :: pp
 
30146
  type(mp_real) & 
 
30147
    ,intent(in)  :: m1,m2
 
30148
  type(mp_real) & 
 
30149
   ,intent(in)  :: rmu       
 
30150
  integer,intent(in) :: rank
 
30151
!
 
30152
  type(mp_complex) &  
 
30153
    :: ss,r1,r2
 
30154
  type(mp_real) & 
 
30155
    :: app,am1,am2,hh,mulocal,mulocal2
 
30156
  character(26+99) ,parameter :: warning=&
 
30157
                     'WARNING from OneLOop bn: '//warnonshell
 
30158
  if (initz) call init
 
30159
  ss = pp
 
30160
  r1 = m1
 
30161
  r2 = m2
 
30162
!
 
30163
  app = abs(pp)
 
30164
!
 
30165
  am1 = abs(m1)
 
30166
  am2 = abs(m2)
 
30167
!
 
30168
  mulocal = rmu     
 
30169
!
 
30170
  mulocal2 = mulocal*mulocal
 
30171
!
 
30172
  if (nonzerothrs) then
 
30173
    hh = onshellthrs
 
30174
    if (app.lt.hh) app = 0
 
30175
    if (am1.lt.hh) am1 = 0
 
30176
    if (am2.lt.hh) am2 = 0
 
30177
  elseif (wunit.gt.0) then
 
30178
    hh = onshellthrs*max(app,max(am1,max(am2,mulocal2)))
 
30179
    if (RZRO.lt.app.and.app.lt.hh) write(wunit,*) warning
 
30180
    if (RZRO.lt.am1.and.am1.lt.hh) write(wunit,*) warning
 
30181
    if (RZRO.lt.am2.and.am2.lt.hh) write(wunit,*) warning
 
30182
  endif
 
30183
!
 
30184
  if     (rank.eq.0) then
 
30185
    call bub0( rslt(:,0) &
 
30186
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30187
  elseif (rank.eq.1) then
 
30188
    call bub1( rslt(:,1),rslt(:,0) &
 
30189
              ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30190
  elseif (rank.eq.2) then
 
30191
    call bub11( rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30192
               ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30193
  elseif (rank.eq.3) then
 
30194
    call bub111( rslt(:,5),rslt(:,4) &
 
30195
                ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30196
                ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30197
  elseif (rank.eq.4) then
 
30198
    call bub1111( rslt(:,8),rslt(:,7),rslt(:,6) &
 
30199
                 ,rslt(:,5),rslt(:,4) &
 
30200
                 ,rslt(:,3),rslt(:,2),rslt(:,1),rslt(:,0) &
 
30201
                 ,ss,r1,r2 ,app,am1,am2 ,mulocal2 )
 
30202
  else
 
30203
    if (eunit.gt.0) write(eunit,*) 'ERROR in OneLOop Bn: ' &
 
30204
      ,'rank=',rank,' not implemented'
 
30205
  endif
 
30206
!
 
30207
  if (punit.gt.0) then
 
30208
    if (nonzerothrs) write(punit,*) 'onshell:',trim(myprint(onshellthrs))
 
30209
    write(punit,*) 'muscale:',trim(myprint(mulocal))
 
30210
    write(punit,*) 'pp:',trim(myprint(pp))
 
30211
    write(punit,*) 'm1:',trim(myprint(m1))
 
30212
    write(punit,*) 'm2:',trim(myprint(m2))
 
30213
    if (rank.ge.0) then
 
30214
    write(punit,*) 'b0(2):',trim(myprint(rslt(2,0) ))
 
30215
    write(punit,*) 'b0(1):',trim(myprint(rslt(1,0) ))
 
30216
    write(punit,*) 'b0(0):',trim(myprint(rslt(0,0) ))
 
30217
    if (rank.ge.1) then
 
30218
    write(punit,*) 'b1(2):',trim(myprint(rslt(2,1) ))
 
30219
    write(punit,*) 'b1(1):',trim(myprint(rslt(1,1) ))
 
30220
    write(punit,*) 'b1(0):',trim(myprint(rslt(0,1) ))
 
30221
    if (rank.ge.2) then
 
30222
    write(punit,*) 'b00(2):',trim(myprint(rslt(2,2)))
 
30223
    write(punit,*) 'b00(1):',trim(myprint(rslt(1,2)))
 
30224
    write(punit,*) 'b00(0):',trim(myprint(rslt(0,2)))
 
30225
    write(punit,*) 'b11(2):',trim(myprint(rslt(2,3)))
 
30226
    write(punit,*) 'b11(1):',trim(myprint(rslt(1,3)))
 
30227
    write(punit,*) 'b11(0):',trim(myprint(rslt(0,3)))
 
30228
    if (rank.ge.3) then
 
30229
    write(punit,*) 'b001(2):',trim(myprint(rslt(2,4)))
 
30230
    write(punit,*) 'b001(1):',trim(myprint(rslt(1,4)))
 
30231
    write(punit,*) 'b001(0):',trim(myprint(rslt(0,4)))
 
30232
    write(punit,*) 'b111(2):',trim(myprint(rslt(2,5)))
 
30233
    write(punit,*) 'b111(1):',trim(myprint(rslt(1,5)))
 
30234
    write(punit,*) 'b111(0):',trim(myprint(rslt(0,5)))
 
30235
    if (rank.ge.4) then
 
30236
    write(punit,*) 'b0000(2):',trim(myprint(rslt(2,6)))
 
30237
    write(punit,*) 'b0000(1):',trim(myprint(rslt(1,6)))
 
30238
    write(punit,*) 'b0000(0):',trim(myprint(rslt(0,6)))
 
30239
    write(punit,*) 'b0011(2):',trim(myprint(rslt(2,7)))
 
30240
    write(punit,*) 'b0011(1):',trim(myprint(rslt(1,7)))
 
30241
    write(punit,*) 'b0011(0):',trim(myprint(rslt(0,7)))
 
30242
    write(punit,*) 'b1111(2):',trim(myprint(rslt(2,8)))
 
30243
    write(punit,*) 'b1111(1):',trim(myprint(rslt(1,8)))
 
30244
    write(punit,*) 'b1111(0):',trim(myprint(rslt(0,8)))
 
30245
    endif;endif;endif;endif;endif
 
30246
  endif
 
30247
  end subroutine
 
30248
 
 
30249
 
16582
30250
!*******************************************************************
16583
30251
! calculates
16584
30252
!               C   /               d^(Dim)q
16602
30270
  use avh_olo_mp_tri
16603
30271
  use avh_olo_mp_auxfun ,only: kallen
16604
30272
!
16605
 
  include 'cts_mpc.h'
 
30273
  type(mp_complex) &  
16606
30274
    ,intent(out) :: rslt(0:2)
16607
 
  include 'cts_mpc.h'
 
30275
  type(mp_complex) &  
16608
30276
    ,intent(in)  :: p1,p2,p3
16609
 
  include 'cts_mpc.h'
 
30277
  type(mp_complex) &  
16610
30278
    ,intent(in)  :: m1,m2,m3
16611
30279
!
16612
 
  include 'cts_mpc.h'
 
30280
  type(mp_complex) &  
16613
30281
    :: pp(3)
16614
 
  include 'cts_mpc.h'
 
30282
  type(mp_complex) &  
16615
30283
    :: mm(3)
16616
 
  include 'cts_mpc.h'
 
30284
  type(mp_complex) &  
16617
30285
    :: ss(3),rr(3),lambda
16618
 
  include 'cts_mpr.h'
 
30286
  type(mp_real) & 
16619
30287
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
16620
 
  include 'cts_mpr.h'
 
30288
  type(mp_real) & 
16621
30289
    :: mulocal,mulocal2
16622
30290
  integer :: icase,ii
16623
30291
  character(25+99) ,parameter :: warning=&
16654
30322
    if (am(ii).gt.smax) smax = am(ii)
16655
30323
  enddo
16656
30324
!
16657
 
  mulocal = muscale
 
30325
  mulocal = muscale 
16658
30326
!
16659
30327
  mulocal2 = mulocal*mulocal
16660
30328
!
16764
30432
  use avh_olo_mp_tri
16765
30433
  use avh_olo_mp_auxfun ,only: kallen
16766
30434
!
16767
 
  include 'cts_mpc.h'
 
30435
  type(mp_complex) &  
16768
30436
    ,intent(out) :: rslt(0:2)
16769
 
  include 'cts_mpc.h'
 
30437
  type(mp_complex) &  
16770
30438
    ,intent(in)  :: p1,p2,p3
16771
 
  include 'cts_mpc.h'
 
30439
  type(mp_complex) &  
16772
30440
    ,intent(in)  :: m1,m2,m3
16773
 
  include 'cts_mpr.h'
16774
 
    ,intent(in)  :: rmu
 
30441
  type(mp_real) & 
 
30442
    ,intent(in)  :: rmu      
16775
30443
!
16776
 
  include 'cts_mpc.h'
 
30444
  type(mp_complex) &  
16777
30445
    :: pp(3)
16778
 
  include 'cts_mpc.h'
 
30446
  type(mp_complex) &  
16779
30447
    :: mm(3)
16780
 
  include 'cts_mpc.h'
 
30448
  type(mp_complex) &  
16781
30449
    :: ss(3),rr(3),lambda
16782
 
  include 'cts_mpr.h'
 
30450
  type(mp_real) & 
16783
30451
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
16784
 
  include 'cts_mpr.h'
 
30452
  type(mp_real) & 
16785
30453
    :: mulocal,mulocal2
16786
30454
  integer :: icase,ii
16787
30455
  character(25+99) ,parameter :: warning=&
16818
30486
    if (am(ii).gt.smax) smax = am(ii)
16819
30487
  enddo
16820
30488
!
16821
 
  mulocal = rmu
 
30489
  mulocal = rmu     
16822
30490
!
16823
30491
  mulocal2 = mulocal*mulocal
16824
30492
!
16928
30596
  use avh_olo_mp_tri
16929
30597
  use avh_olo_mp_auxfun ,only: kallen
16930
30598
!
16931
 
  include 'cts_mpc.h'
 
30599
  type(mp_complex) &  
16932
30600
    ,intent(out) :: rslt(0:2)
16933
 
  include 'cts_mpr.h'
 
30601
  type(mp_real) & 
16934
30602
    ,intent(in)  :: p1,p2,p3
16935
 
  include 'cts_mpc.h'
 
30603
  type(mp_complex) &  
16936
30604
    ,intent(in)  :: m1,m2,m3
16937
30605
!
16938
 
  include 'cts_mpr.h'
 
30606
  type(mp_real) & 
16939
30607
    :: pp(3)
16940
 
  include 'cts_mpc.h'
 
30608
  type(mp_complex) &  
16941
30609
    :: mm(3)
16942
 
  include 'cts_mpc.h'
 
30610
  type(mp_complex) &  
16943
30611
    :: ss(3),rr(3),lambda
16944
 
  include 'cts_mpr.h'
 
30612
  type(mp_real) & 
16945
30613
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
16946
 
  include 'cts_mpr.h'
 
30614
  type(mp_real) & 
16947
30615
    :: mulocal,mulocal2
16948
30616
  integer :: icase,ii
16949
30617
  character(25+99) ,parameter :: warning=&
16974
30642
    if (am(ii).gt.smax) smax = am(ii)
16975
30643
  enddo
16976
30644
!
16977
 
  mulocal = muscale
 
30645
  mulocal = muscale 
16978
30646
!
16979
30647
  mulocal2 = mulocal*mulocal
16980
30648
!
17084
30752
  use avh_olo_mp_tri
17085
30753
  use avh_olo_mp_auxfun ,only: kallen
17086
30754
!
17087
 
  include 'cts_mpc.h'
 
30755
  type(mp_complex) &  
17088
30756
    ,intent(out) :: rslt(0:2)
17089
 
  include 'cts_mpr.h'
 
30757
  type(mp_real) & 
17090
30758
    ,intent(in)  :: p1,p2,p3
17091
 
  include 'cts_mpc.h'
 
30759
  type(mp_complex) &  
17092
30760
    ,intent(in)  :: m1,m2,m3
17093
 
  include 'cts_mpr.h'
17094
 
    ,intent(in)  :: rmu
 
30761
  type(mp_real) & 
 
30762
    ,intent(in)  :: rmu      
17095
30763
!
17096
 
  include 'cts_mpr.h'
 
30764
  type(mp_real) & 
17097
30765
    :: pp(3)
17098
 
  include 'cts_mpc.h'
 
30766
  type(mp_complex) &  
17099
30767
    :: mm(3)
17100
 
  include 'cts_mpc.h'
 
30768
  type(mp_complex) &  
17101
30769
    :: ss(3),rr(3),lambda
17102
 
  include 'cts_mpr.h'
 
30770
  type(mp_real) & 
17103
30771
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
17104
 
  include 'cts_mpr.h'
 
30772
  type(mp_real) & 
17105
30773
    :: mulocal,mulocal2
17106
30774
  integer :: icase,ii
17107
30775
  character(25+99) ,parameter :: warning=&
17132
30800
    if (am(ii).gt.smax) smax = am(ii)
17133
30801
  enddo
17134
30802
!
17135
 
  mulocal = rmu
 
30803
  mulocal = rmu     
17136
30804
!
17137
30805
  mulocal2 = mulocal*mulocal
17138
30806
!
17242
30910
  use avh_olo_mp_tri
17243
30911
  use avh_olo_mp_auxfun ,only: kallen
17244
30912
!
17245
 
  include 'cts_mpc.h'
 
30913
  type(mp_complex) &  
17246
30914
    ,intent(out) :: rslt(0:2)
17247
 
  include 'cts_mpr.h'
 
30915
  type(mp_real) & 
17248
30916
    ,intent(in)  :: p1,p2,p3
17249
 
  include 'cts_mpr.h'
 
30917
  type(mp_real) & 
17250
30918
    ,intent(in)  :: m1,m2,m3
17251
30919
!
17252
 
  include 'cts_mpr.h'
 
30920
  type(mp_real) & 
17253
30921
    :: pp(3)
17254
 
  include 'cts_mpr.h'
 
30922
  type(mp_real) & 
17255
30923
    :: mm(3)
17256
 
  include 'cts_mpc.h'
 
30924
  type(mp_complex) &  
17257
30925
    :: ss(3),rr(3),lambda
17258
 
  include 'cts_mpr.h'
 
30926
  type(mp_real) & 
17259
30927
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
17260
 
  include 'cts_mpr.h'
 
30928
  type(mp_real) & 
17261
30929
    :: mulocal,mulocal2
17262
30930
  integer :: icase,ii
17263
30931
  character(25+99) ,parameter :: warning=&
17281
30949
    if (am(ii).gt.smax) smax = am(ii)
17282
30950
  enddo
17283
30951
!
17284
 
  mulocal = muscale
 
30952
  mulocal = muscale 
17285
30953
!
17286
30954
  mulocal2 = mulocal*mulocal
17287
30955
!
17391
31059
  use avh_olo_mp_tri
17392
31060
  use avh_olo_mp_auxfun ,only: kallen
17393
31061
!
17394
 
  include 'cts_mpc.h'
 
31062
  type(mp_complex) &  
17395
31063
    ,intent(out) :: rslt(0:2)
17396
 
  include 'cts_mpr.h'
 
31064
  type(mp_real) & 
17397
31065
    ,intent(in)  :: p1,p2,p3
17398
 
  include 'cts_mpr.h'
 
31066
  type(mp_real) & 
17399
31067
    ,intent(in)  :: m1,m2,m3
17400
 
  include 'cts_mpr.h'
17401
 
    ,intent(in)  :: rmu
 
31068
  type(mp_real) & 
 
31069
    ,intent(in)  :: rmu      
17402
31070
!
17403
 
  include 'cts_mpr.h'
 
31071
  type(mp_real) & 
17404
31072
    :: pp(3)
17405
 
  include 'cts_mpr.h'
 
31073
  type(mp_real) & 
17406
31074
    :: mm(3)
17407
 
  include 'cts_mpc.h'
 
31075
  type(mp_complex) &  
17408
31076
    :: ss(3),rr(3),lambda
17409
 
  include 'cts_mpr.h'
 
31077
  type(mp_real) & 
17410
31078
    :: smax,ap(3),am(3),as(3),ar(3),hh,s1r2,s2r3,s3r3
17411
 
  include 'cts_mpr.h'
 
31079
  type(mp_real) & 
17412
31080
    :: mulocal,mulocal2
17413
31081
  integer :: icase,ii
17414
31082
  character(25+99) ,parameter :: warning=&
17432
31100
    if (am(ii).gt.smax) smax = am(ii)
17433
31101
  enddo
17434
31102
!
17435
 
  mulocal = rmu
 
31103
  mulocal = rmu     
17436
31104
!
17437
31105
  mulocal2 = mulocal*mulocal
17438
31106
!
17565
31233
  use avh_olo_mp_box
17566
31234
  use avh_olo_mp_boxc
17567
31235
!
17568
 
  include 'cts_mpc.h'
 
31236
  type(mp_complex) &  
17569
31237
    ,intent(out) :: rslt(0:2)
17570
 
  include 'cts_mpc.h'
 
31238
  type(mp_complex) &  
17571
31239
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
17572
 
  include 'cts_mpc.h'
 
31240
  type(mp_complex) &  
17573
31241
    ,intent(in)  :: m1,m2,m3,m4
17574
31242
!
17575
 
  include 'cts_mpc.h'
 
31243
  type(mp_complex) &  
17576
31244
    :: pp(6)
17577
 
  include 'cts_mpc.h'
 
31245
  type(mp_complex) &  
17578
31246
    :: mm(4)
17579
 
  include 'cts_mpc.h'
 
31247
  type(mp_complex) &  
17580
31248
    :: ss(6),rr(4)
17581
 
  include 'cts_mpr.h'
 
31249
  type(mp_real) & 
17582
31250
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
17583
 
  include 'cts_mpr.h'
 
31251
  type(mp_real) & 
17584
31252
    :: mulocal,mulocal2,small,hh,min13,min24,min56
17585
31253
  integer :: icase,ii,jj
17586
31254
  logical :: useboxc
17633
31301
  enddo
17634
31302
  small = small*neglig(prcpar)
17635
31303
!
17636
 
  mulocal = muscale
 
31304
  mulocal = muscale 
17637
31305
!
17638
31306
  mulocal2 = mulocal*mulocal
17639
31307
!
17836
31504
  use avh_olo_mp_box
17837
31505
  use avh_olo_mp_boxc
17838
31506
!
17839
 
  include 'cts_mpc.h'
 
31507
  type(mp_complex) &  
17840
31508
    ,intent(out) :: rslt(0:2)
17841
 
  include 'cts_mpc.h'
 
31509
  type(mp_complex) &  
17842
31510
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
17843
 
  include 'cts_mpc.h'
 
31511
  type(mp_complex) &  
17844
31512
    ,intent(in)  :: m1,m2,m3,m4
17845
 
  include 'cts_mpr.h'
17846
 
    ,intent(in)  :: rmu
 
31513
  type(mp_real) & 
 
31514
    ,intent(in)  :: rmu      
17847
31515
!
17848
 
  include 'cts_mpc.h'
 
31516
  type(mp_complex) &  
17849
31517
    :: pp(6)
17850
 
  include 'cts_mpc.h'
 
31518
  type(mp_complex) &  
17851
31519
    :: mm(4)
17852
 
  include 'cts_mpc.h'
 
31520
  type(mp_complex) &  
17853
31521
    :: ss(6),rr(4)
17854
 
  include 'cts_mpr.h'
 
31522
  type(mp_real) & 
17855
31523
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
17856
 
  include 'cts_mpr.h'
 
31524
  type(mp_real) & 
17857
31525
    :: mulocal,mulocal2,small,hh,min13,min24,min56
17858
31526
  integer :: icase,ii,jj
17859
31527
  logical :: useboxc
17906
31574
  enddo
17907
31575
  small = small*neglig(prcpar)
17908
31576
!
17909
 
  mulocal = rmu
 
31577
  mulocal = rmu     
17910
31578
!
17911
31579
  mulocal2 = mulocal*mulocal
17912
31580
!
18109
31777
  use avh_olo_mp_box
18110
31778
  use avh_olo_mp_boxc
18111
31779
!
18112
 
  include 'cts_mpc.h'
 
31780
  type(mp_complex) &  
18113
31781
    ,intent(out) :: rslt(0:2)
18114
 
  include 'cts_mpr.h'
 
31782
  type(mp_real) & 
18115
31783
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
18116
 
  include 'cts_mpc.h'
 
31784
  type(mp_complex) &  
18117
31785
    ,intent(in)  :: m1,m2,m3,m4
18118
31786
!
18119
 
  include 'cts_mpr.h'
 
31787
  type(mp_real) & 
18120
31788
    :: pp(6)
18121
 
  include 'cts_mpc.h'
 
31789
  type(mp_complex) &  
18122
31790
    :: mm(4)
18123
 
  include 'cts_mpc.h'
 
31791
  type(mp_complex) &  
18124
31792
    :: ss(6),rr(4)
18125
 
  include 'cts_mpr.h'
 
31793
  type(mp_real) & 
18126
31794
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
18127
 
  include 'cts_mpr.h'
 
31795
  type(mp_real) & 
18128
31796
    :: mulocal,mulocal2,small,hh,min13,min24,min56
18129
31797
  integer :: icase,ii,jj
18130
31798
  logical :: useboxc
18171
31839
  enddo
18172
31840
  small = small*neglig(prcpar)
18173
31841
!
18174
 
  mulocal = muscale
 
31842
  mulocal = muscale 
18175
31843
!
18176
31844
  mulocal2 = mulocal*mulocal
18177
31845
!
18374
32042
  use avh_olo_mp_box
18375
32043
  use avh_olo_mp_boxc
18376
32044
!
18377
 
  include 'cts_mpc.h'
 
32045
  type(mp_complex) &  
18378
32046
    ,intent(out) :: rslt(0:2)
18379
 
  include 'cts_mpr.h'
 
32047
  type(mp_real) & 
18380
32048
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
18381
 
  include 'cts_mpc.h'
 
32049
  type(mp_complex) &  
18382
32050
    ,intent(in)  :: m1,m2,m3,m4
18383
 
  include 'cts_mpr.h'
18384
 
    ,intent(in)  :: rmu
 
32051
  type(mp_real) & 
 
32052
    ,intent(in)  :: rmu      
18385
32053
!
18386
 
  include 'cts_mpr.h'
 
32054
  type(mp_real) & 
18387
32055
    :: pp(6)
18388
 
  include 'cts_mpc.h'
 
32056
  type(mp_complex) &  
18389
32057
    :: mm(4)
18390
 
  include 'cts_mpc.h'
 
32058
  type(mp_complex) &  
18391
32059
    :: ss(6),rr(4)
18392
 
  include 'cts_mpr.h'
 
32060
  type(mp_real) & 
18393
32061
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
18394
 
  include 'cts_mpr.h'
 
32062
  type(mp_real) & 
18395
32063
    :: mulocal,mulocal2,small,hh,min13,min24,min56
18396
32064
  integer :: icase,ii,jj
18397
32065
  logical :: useboxc
18438
32106
  enddo
18439
32107
  small = small*neglig(prcpar)
18440
32108
!
18441
 
  mulocal = rmu
 
32109
  mulocal = rmu     
18442
32110
!
18443
32111
  mulocal2 = mulocal*mulocal
18444
32112
!
18641
32309
  use avh_olo_mp_box
18642
32310
  use avh_olo_mp_boxc
18643
32311
!
18644
 
  include 'cts_mpc.h'
 
32312
  type(mp_complex) &  
18645
32313
    ,intent(out) :: rslt(0:2)
18646
 
  include 'cts_mpr.h'
 
32314
  type(mp_real) & 
18647
32315
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
18648
 
  include 'cts_mpr.h'
 
32316
  type(mp_real) & 
18649
32317
    ,intent(in)  :: m1,m2,m3,m4
18650
32318
!
18651
 
  include 'cts_mpr.h'
 
32319
  type(mp_real) & 
18652
32320
    :: pp(6)
18653
 
  include 'cts_mpr.h'
 
32321
  type(mp_real) & 
18654
32322
    :: mm(4)
18655
 
  include 'cts_mpc.h'
 
32323
  type(mp_complex) &  
18656
32324
    :: ss(6),rr(4)
18657
 
  include 'cts_mpr.h'
 
32325
  type(mp_real) & 
18658
32326
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
18659
 
  include 'cts_mpr.h'
 
32327
  type(mp_real) & 
18660
32328
    :: mulocal,mulocal2,small,hh,min13,min24,min56
18661
32329
  integer :: icase,ii,jj
18662
32330
  logical :: useboxc
18696
32364
  enddo
18697
32365
  small = small*neglig(prcpar)
18698
32366
!
18699
 
  mulocal = muscale
 
32367
  mulocal = muscale 
18700
32368
!
18701
32369
  mulocal2 = mulocal*mulocal
18702
32370
!
18899
32567
  use avh_olo_mp_box
18900
32568
  use avh_olo_mp_boxc
18901
32569
!
18902
 
  include 'cts_mpc.h'
 
32570
  type(mp_complex) &  
18903
32571
    ,intent(out) :: rslt(0:2)
18904
 
  include 'cts_mpr.h'
 
32572
  type(mp_real) & 
18905
32573
    ,intent(in)  :: p1,p2,p3,p4,p12,p23
18906
 
  include 'cts_mpr.h'
 
32574
  type(mp_real) & 
18907
32575
    ,intent(in)  :: m1,m2,m3,m4
18908
 
  include 'cts_mpr.h'
18909
 
    ,intent(in)  :: rmu
 
32576
  type(mp_real) & 
 
32577
    ,intent(in)  :: rmu      
18910
32578
!
18911
 
  include 'cts_mpr.h'
 
32579
  type(mp_real) & 
18912
32580
    :: pp(6)
18913
 
  include 'cts_mpr.h'
 
32581
  type(mp_real) & 
18914
32582
    :: mm(4)
18915
 
  include 'cts_mpc.h'
 
32583
  type(mp_complex) &  
18916
32584
    :: ss(6),rr(4)
18917
 
  include 'cts_mpr.h'
 
32585
  type(mp_real) & 
18918
32586
    :: smax,ap(6),am(4),as(6),ar(4),s1r2,s2r2,s2r3,s3r4,s4r4
18919
 
  include 'cts_mpr.h'
 
32587
  type(mp_real) & 
18920
32588
    :: mulocal,mulocal2,small,hh,min13,min24,min56
18921
32589
  integer :: icase,ii,jj
18922
32590
  logical :: useboxc
18956
32624
  enddo
18957
32625
  small = small*neglig(prcpar)
18958
32626
!
18959
 
  mulocal = rmu
 
32627
  mulocal = rmu     
18960
32628
!
18961
32629
  mulocal2 = mulocal*mulocal
18962
32630
!
19165
32833
    ,olo_dp_scale=>olo_get_scale &
19166
32834
    ,olo_dp_onshell=>olo_get_onshell &
19167
32835
    ,olo_dp_precision=>olo_get_precision &
19168
 
    ,olo ,olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
 
32836
    ,olo,olo_a0,olo_an,olo_b0,olo_b11,olo_bn,olo_c0,olo_d0
 
32837
  use avh_olo_qp ,only: &
 
32838
     olo_qp_kind=>olo_kind &
 
32839
    ,olo_qp_scale=>olo_get_scale &
 
32840
    ,olo_qp_onshell=>olo_get_onshell &
 
32841
    ,olo_qp_precision=>olo_get_precision &
 
32842
    ,olo,olo_a0,olo_an,olo_b0,olo_b11,olo_bn,olo_c0,olo_d0
19169
32843
  use avh_olo_mp ,only: &
19170
32844
     olo_mp_kind=>olo_kind &
19171
32845
    ,olo_mp_scale=>olo_get_scale &
19172
32846
    ,olo_mp_onshell=>olo_get_onshell &
19173
32847
    ,olo_mp_precision=>olo_get_precision &
19174
 
    ,olo ,olo_a0 ,olo_b0 ,olo_b11 ,olo_c0 ,olo_d0
 
32848
    ,olo,olo_a0,olo_an,olo_b0,olo_b11,olo_bn,olo_c0,olo_d0
19175
32849
 
19176
32850
  implicit none
19177
32851
 
19189
32863
  end subroutine
19190
32864
 
19191
32865
  subroutine olo_precision( ndec )
19192
 
  use avh_olo_dp ,only: dp_sub=>olo_precision
19193
 
  use avh_olo_mp ,only: mp_sub=>olo_precision
 
32866
  use avh_olo_dp ,only: dp_sub=>olo_precision 
 
32867
  use avh_olo_qp ,only: qp_sub=>olo_precision 
 
32868
  use avh_olo_mp ,only: mp_sub=>olo_precision 
19194
32869
  integer ,intent(in) :: ndec
19195
 
  call dp_sub( ndec )
19196
 
  call mp_sub( ndec )
 
32870
  call dp_sub( ndec ) 
 
32871
  call qp_sub( ndec ) 
 
32872
  call mp_sub( ndec ) 
19197
32873
  end subroutine
19198
32874
 
19199
32875
  subroutine olo_scale( val )
19200
 
  use avh_olo_dp ,only: dp_sub=>olo_scale
19201
 
  use avh_olo_mp ,only: mp_sub=>olo_scale
 
32876
  use avh_olo_dp ,only: dp_sub=>olo_scale 
 
32877
  use avh_olo_qp ,only: qp_sub=>olo_scale 
 
32878
  use avh_olo_mp ,only: mp_sub=>olo_scale 
19202
32879
  real(kind(1d0)) ,intent(in) :: val
19203
 
  call dp_sub( val )
19204
 
  call mp_sub( val )
 
32880
  call dp_sub( val ) 
 
32881
  call qp_sub( val ) 
 
32882
  call mp_sub( val ) 
19205
32883
  end subroutine
19206
32884
 
19207
32885
  subroutine olo_onshell( val )
19208
 
  use avh_olo_dp ,only: dp_sub=>olo_onshell
19209
 
  use avh_olo_mp ,only: mp_sub=>olo_onshell
 
32886
  use avh_olo_dp ,only: dp_sub=>olo_onshell 
 
32887
  use avh_olo_qp ,only: qp_sub=>olo_onshell 
 
32888
  use avh_olo_mp ,only: mp_sub=>olo_onshell 
19210
32889
  real(kind(1d0)) ,intent(in) :: val
19211
 
  call dp_sub( val )
19212
 
  call mp_sub( val )
 
32890
  call dp_sub( val ) 
 
32891
  call qp_sub( val ) 
 
32892
  call mp_sub( val ) 
19213
32893
  end subroutine
19214
32894
 
19215
32895
  subroutine olo_setting( iunit )