JHUGen MELA  v2.4.1
Matrix element calculations as used in JHUGen. MELA is an important tool that was used for the Higgs boson discovery and for precise measurements of its structure and interactions. Please see the website https://spin.pha.jhu.edu/ and papers cited there for more details, and kindly cite those papers when using this code.
CALLING_cpHTO.f
Go to the documentation of this file.
1 *-----------------------------------------------------------------------------------------*
2 * *
3 * cpHTO v 1.1 (May 2012) by Giampiero *
4 * *
5 * Not the program alone but a SUBROUTINE to call the program + the program *
6 * *
7 * *
8 * CALL CALL_HTO(mhiggs,mtop,mhb,ghb) *
9 * *
10 * REAL*8 mhiggs | I - your value for muH *
11 * REAL*8 mtop | I - your value for m_top *
12 * REAL*8 gh | O - gH *
13 * *
14 * History: *
15 * Version Date Comment *
16 * ------- ---- ------- *
17 * 1.0 December 2011 Original code. Giampiero *
18 * March 2012 bug fixed in ghb *
19 * 1.1 May 2012 Expanded solution for low muh *
20 * *
21 * Given the parametrization s_H = muh^2 - i*muh*gh for the Higgs-boson complex pole *
22 * computes gh at a given value of muh in the Standard Model *
23 * It also returns the OS width and mass and width in the bar-scheme *
24 * *
25 *-----------------------------------------------------------------------* *
26 * Comments to Giampiero Passarino <giampiero(at)to.infn.it> * *
27 *-----------------------------------------------------------------------* *
28 * *
29 * %\cite{Goria:2011wa} *
30 * \bibitem{Goria:2011wa} *
31 * S.~Goria, G.~Passarino and D.~Rosco, *
32 * %``The Higgs Boson Lineshape,'' *
33 * arXiv:1112.5517 [hep-ph]. *
34 * %%CITATION = ARXIV:1112.5517;%% *
35 * *
36 * %\cite{Passarino:2010qk} *
37 * \bibitem{Passarino:2010qk} *
38 * G.~Passarino, C.~Sturm and S.~Uccirati, *
39 * %``Higgs Pseudo-Observables, Second Riemann Sheet and All That,'' *
40 * Nucl.\ Phys.\ B {\bf 834} (2010) 77 *
41 * [arXiv:1001.3360 [hep-ph]]. *
42 * %%CITATION = ARXIV:1001.3360;%% *
43 * *
44 *-----------------------------------------------------------------------------------------*
45 *
46 ************************************************************************************
47 * * * *
48 * * def * *
49 * qcdc * 0 - 1 * QCD corrections to ferm self-energy *
50 * gtop * 0 - 1 - 2 * real - cmplx def - cmplx your choice *
51 * * * top quark mass *
52 * yimt * if(gtop.eq.2) * your choice for Gamma_top *
53 * mt [GeV] * I * top quark mass *
54 * muh [GeV] * I * s_H = muh^2 - i*muh*gh *
55 * * * *
56 ************************************************************************************
57 *
58 *-----------------------------------------------------------------------------------------
59 *
60  MODULE hto_aux_hcp
61  INTEGER qcdc,pcnt,gtop
62  real*8 cxe,cxmu,cxtau,cxu,cxd,cxc,cxs,cxt,cxb,
63  # cxes,cxmus,cxtaus,cxus,cxds,cxcs,cxss,cxts,cxbs,
64  # clxe,clxmu,clxtau,clxu,clxd,clxc,clxs,clxt,clxb,muhcp,
65  # scalec,cxqs,cxq,cxls,cxl,cxtmb,cxtmbs,cxbi,cxtmbi,xq,
66  # cxtc,cxbc,yimt
67  real*8, dimension(2) :: cxwi,clcts,clwtb,cpw,cpz
68  END MODULE hto_aux_hcp
69 *
70 *-----------------------------------------------------------------------------------------
71 *
72  MODULE hto_masses
73  real*8 mt
74  real*8, parameter :: m0= 0.d0
75  real*8, parameter :: mw= 80.398d0
76  real*8, parameter :: mz= 91.1876d0
77  real*8, parameter :: me= 0.51099907d-3
78  real*8, parameter :: mm= 0.105658389d0
79  real*8, parameter :: mtl= 1.77684d0
80  real*8, parameter :: muq= 0.190d0
81  real*8, parameter :: mdq= 0.190d0
82  real*8, parameter :: mcq= 1.55d0
83  real*8, parameter :: msq= 0.190d0
84  real*8, parameter :: mbq= 4.69d0
85  real*8, parameter :: mb= 4.69d0
86  real*8, parameter :: mtiny= 1.d-10
87  real*8, parameter :: imw= 2.08872d0
88  real*8, parameter :: imz= 2.4952d0
89  real*8, parameter :: swr= mw*mw-imw*imw
90  real*8, parameter :: swi= -mw*imw*(1.d0-0.5d0*(imw*imw)/(mw*mw))
91  real*8, parameter :: szr= mz*mz-imz*imz
92  real*8, parameter :: szi= -mz*imz*(1.d0-0.5d0*(imz*imz)/(mz*mz))
93  END MODULE hto_masses
94 *
95 *-----------------------------------------------------------------------------------------
96 *
97  MODULE hto_puttime
98  CONTAINS
99 *
100  SUBROUTINE hto_timestamp()
101 *
102 !**************************************************************************80
103 !
104 !! TIMESTAMP prints the current YMDHMS date as a time stamp.
105 !
106 ! Example:
107 !
108 ! 31 May 2001 9:45:54.872 AM
109 !
110 ! Modified:
111 !
112 ! 06 August 2005
113 !
114 ! Author:
115 !
116 ! John Burkardt
117 !
118 ! Parameters:
119 !
120 ! None
121 !
122  IMPLICIT NONE
123 
124  CHARACTER (len=8) ampm
125  INTEGER d
126  INTEGER h
127  INTEGER m
128  INTEGER mm
129  CHARACTER (len= 9), parameter, dimension(12) :: month= (/
130  # 'January ', 'February ', 'March ', 'April ',
131  # 'May ', 'June ', 'July ', 'August ',
132  # 'September', 'October ', 'November ', 'December ' /)
133  INTEGER n
134  INTEGER s
135  INTEGER values(8)
136  INTEGER y
137 
138  CALL date_and_time (values= values)
139 
140  y= values(1)
141  m= values(2)
142  d= values(3)
143  h= values(5)
144  n= values(6)
145  s= values(7)
146  mm= values(8)
147 
148  IF(h < 12) THEN
149  ampm= 'AM'
150  ELSE IF (h== 12) THEN
151  IF(n== 0 .and. s== 0) THEN
152  ampm= 'Noon'
153  ELSE
154  ampm= 'PM'
155  ENDIF
156  ELSE
157  h= h-12
158  IF(h < 12) THEN
159  ampm= 'PM'
160  ELSE IF (h== 12) THEN
161  IF(n== 0 .and. s== 0) THEN
162  ampm= 'Midnight'
163  ELSE
164  ampm= 'AM'
165  ENDIF
166  ENDIF
167  ENDIF
168 
169  WRITE (*,'(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)')
170  # d,trim(month(m)),y,h,':',n,':',s,'.',mm,trim(ampm)
171 
172  RETURN
173  END SUBROUTINE hto_timestamp
174 *
175  END MODULE hto_puttime
176 *
177 *---------------------------------------------------------------------------------------------
178 *
179  MODULE hto_units
180  INTEGER, parameter :: izer= 0
181  INTEGER, parameter :: ione= 1
182  INTEGER, parameter :: itwo= 2
183  real*8, parameter :: eps= -1.d0
184  real*8, parameter :: one= 1.d0
185  real*8, parameter :: zero= 0.d0
186  real*8, parameter :: qeps= 1.d-25
187  real*8, parameter :: ez= 1.d-15
188  real*8 :: co(1:2)=(/1.d0,0.d0/)
189  real*8 :: ci(1:2)=(/0.d0,1.d0/)
190  real*8 :: cz(1:2)=(/0.d0,0.d0/)
191  END MODULE hto_units
192 *
193 *-----------------------------------------------------------------------------------------
194 *
195  MODULE hto_riemann
196  real*8, parameter :: pi= 3.141592653589793238462643d0
197  real*8, parameter :: pis= pi*pi
198  real*8, parameter :: piq= pis*pis
199  real*8, parameter :: rz2= 1.64493406684823d0
200  real*8, parameter :: rz3= 1.20205690315959d0
201  real*8, parameter :: rz4= 1.08232323371114d0
202  real*8, parameter :: rz5= 1.03692775514337d0
203  real*8, parameter :: eg= 0.5772156649d0
204  real*8, parameter :: ln_pi= 0.114472988584940016d1
205  END MODULE hto_riemann
206 *
207 *-----------------------------------------------------------------------------------------
208 *
209  MODULE hto_bernoulli
210  real*8 :: b_num(0:18)=(/1.d0,-5.d-1,1.66666666666666d-1,
211  # 0.d0,-3.33333333333333d-2,0.d0,2.38095238095238d-2,
212  # 0.d0,-3.33333333333333d-2,0.d0,7.57575757575757d-2,
213  # 0.d0,-2.53113553113553d-1,0.d0,1.16666666666666d0,
214  # 0.d0,-7.09215686274509d0,0.d0,5.49711779448621d1/)
215  END MODULE hto_bernoulli
216 *
217 *-----------------------------------------------------------------------------------------
218 *
219  MODULE hto_ferbos
220  INTEGER ifb
221  END MODULE hto_ferbos
222 *
223 *-----------------------------------------------------------------------------------------
224 *
225  MODULE hto_aux_hbb
226  real*8 xb,xtop
227  real*8, dimension(2) :: cxw,clw,ccts,csts,cctq,cswt,cdwt,
228  # cdzt,cxws,cxwc,cxz,rcmw,cctvi
229  END MODULE hto_aux_hbb
230 *
231 *-----------------------------------------------------------------------------------------
232 *
233  MODULE hto_optcp
234  CHARACTER (len=3) ocp
235  END MODULE hto_optcp
236 *
237 *-----------------------------------------------------------------------------------------
238 *
239  MODULE hto_set_phys_const
240  real*8 alpha_0,g_f,g_w,als,alpha_s_mh,alpha_s_kmh,imt
241  END MODULE hto_set_phys_const
242 *
243 *-----------------------------------------------------------------------------------------
244 *
245  MODULE hto_rootw
246  INTEGER inc
247  END MODULE hto_rootw
248 *
249 *-----------------------------------------------------------------------------------------
250 *
251  MODULE hto_transfmh
252  real*8 tmuh
253  END MODULE hto_transfmh
254 *
255 *-----------------------------------------------------------------------------------------
256 *
257  MODULE hto_acmplx_pro
258  INTERFACE OPERATOR ( .cp. )
259  MODULE PROCEDURE cp
260  END INTERFACE
261  CONTAINS
262  FUNCTION cp(x,y)
263  USE hto_riemann
264  USE hto_units
265  IMPLICIT NONE
266  real*8, dimension(2) :: cp,z1,z2
267  real*8, INTENT(IN), dimension(2) :: x,y
268  IF(abs(x(2)).eq.1.d0.and.abs(y(2)).eq.1.d0) THEN
269  cp(1)= x(1)*y(1)
270  cp(2)= 0.d0
271  ELSE
272  IF(abs(x(2)).eq.1.d0) THEN
273  z1(1)= x(1)
274  z1(2)= 0.d0
275  ELSE
276  z1= x
277  ENDIF
278  IF(abs(y(2)).eq.1.d0) THEN
279  z2(1)= y(1)
280  z2(2)= 0.d0
281  ELSE
282  z2= y
283  ENDIF
284  cp(1)= z1(1)*z2(1)-z1(2)*z2(2)
285  cp(2)= z1(1)*z2(2)+z1(2)*z2(1)
286  ENDIF
287  END FUNCTION cp
288  END MODULE hto_acmplx_pro
289 *
290 *------------------------------------------------------------------
291 *
292  MODULE hto_acmplx_rat
293  INTERFACE OPERATOR ( .cq. )
294  MODULE PROCEDURE cq
295  END INTERFACE
296  CONTAINS
297  FUNCTION cq( x,y )
298  IMPLICIT NONE
299  real*8, dimension(2) :: cq,z1,z2
300  real*8, INTENT(IN), dimension(2) :: x,y
301  real*8 theta
302  IF(x(2).eq.0.d0.and.y(2).eq.0.d0) THEN
303  cq(1)= x(1)/y(1)
304  cq(2)= 0.d0
305  RETURN
306  ENDIF
307  IF(abs(x(2)).eq.1.d0.and.abs(y(2)).eq.1.d0) THEN
308  cq(1)= x(1)/y(1)
309  cq(2)= 0.d0
310  ELSE
311  IF(abs(x(2)).eq.1.d0) then
312  z1(1)= x(1)
313  z1(2)= 0.d0
314  z2(1)= y(1)
315  z2(2)= y(2)
316  ELSEIF(abs(y(2)).eq.1.d0) then
317  z1(1)= x(1)
318  z1(2)= x(2)
319  z2(1)= y(1)
320  z2(2)= 0.d0
321  ELSE
322  z1= x
323  z2= y
324  ENDIF
325  IF(abs(z2(1)) > abs(z2(2))) THEN
326  theta= z2(2)/z2(1)
327  cq(1)= (z1(1)+theta*z1(2))/(theta*z2(2)+z2(1))
328  cq(2)= (z1(2)-theta*z1(1))/(theta*z2(2)+z2(1))
329  ELSE
330  theta= z2(1)/z2(2)
331  cq(1)= (theta*z1(1)+z1(2))/(theta*z2(1)+z2(2))
332  cq(2)= (theta*z1(2)-z1(1))/(theta*z2(1)+z2(2))
333  ENDIF
334  ENDIF
335  END FUNCTION cq
336  END MODULE hto_acmplx_rat
337 *
338 *------------------------------------------------------------------
339 *
340  MODULE hto_linear_comb_c
341  INTERFACE OPERATOR ( .lcc. )
342  MODULE PROCEDURE lcc
343  END INTERFACE
344  CONTAINS
345  FUNCTION lcc(c,x)
346  USE hto_acmplx_pro
347  USE hto_units
348  IMPLICIT NONE
349  real*8, dimension(:) :: c
350  real*8, dimension(2) :: x,lcc,sum
351  INTENT(IN) c,x
352  INTEGER n,i
353  n= size(c)
354  sum= c(n)*co
355  DO i=n-1,1,-1
356  sum= (sum.cp.x)+c(i)*co
357  ENDDO
358  lcc= sum
359  END FUNCTION lcc
360  END MODULE hto_linear_comb_c
361 *
362 *-----------------------------------------------------------------------------------------
363 *
364  MODULE hto_real_lnz
365  INTERFACE OPERATOR ( .rlnz. )
366  MODULE PROCEDURE rlnz
367  END INTERFACE
368  CONTAINS
369  FUNCTION rlnz(x,y)
370  IMPLICIT NONE
371  real*8 rlnz
372  real*8, INTENT(IN) :: x,y
373  rlnz= 0.5d0*log(x*x+y*y)
374  END FUNCTION rlnz
375  END MODULE hto_real_lnz
376 *
377 *-----------------------------------------------------------------------------------------
378 *
379  MODULE hto_imag_lnz
380  INTERFACE OPERATOR ( .ilnz. )
381  MODULE PROCEDURE ilnz
382  END INTERFACE
383  CONTAINS
384  FUNCTION ilnz(x,y)
385  USE hto_riemann
386  IMPLICIT NONE
387  real*8, INTENT(IN) :: x,y
388  real*8 teta,tnteta,sr,si,ax,ay,ilnz
389  ax= abs(x)
390  ay= abs(y)
391  IF(x.eq.0.d0) THEN
392  IF(y > 0.d0) THEN
393  teta= pi/2.d0
394  ELSE
395  teta= -pi/2.d0
396  ENDIF
397  ilnz= teta
398  RETURN
399  ELSE IF(y.eq.0.d0) THEN
400  IF(x > 0.d0) THEN
401  teta= 0.d0
402  ELSE
403  teta= pi
404  ENDIF
405  ilnz= teta
406  RETURN
407  ELSE
408  tnteta= ay/ax
409  teta= atan(tnteta)
410  sr= x/ax
411  si= y/ay
412  IF(sr > 0.d0) THEN
413  ilnz= si*teta
414  ELSE
415  ilnz= si*(pi-teta)
416  ENDIF
417  RETURN
418  ENDIF
419  END FUNCTION ilnz
420  END MODULE hto_imag_lnz
421 *
422 *-----------------------------------------------------------------------------------------
423 *
424  MODULE hto_real_ln
425  INTERFACE OPERATOR ( .rln. )
426  MODULE PROCEDURE rln
427  END INTERFACE
428  CONTAINS
429  FUNCTION rln(x,ep)
430  IMPLICIT NONE
431  real*8 rln
432  real*8, INTENT(IN) :: x,ep
433  rln= log(abs(x))
434  END FUNCTION rln
435  END MODULE hto_real_ln
436 *
437 *-----------------------------------------------------------------------------------------
438 *
439  MODULE hto_cmplx_ln
440  INTERFACE OPERATOR ( .cln. )
441  MODULE PROCEDURE cln
442  END INTERFACE
443  CONTAINS
444  FUNCTION cln(x,ep)
445  USE hto_riemann
446  IMPLICIT NONE
447  real*8, dimension(2) :: cln
448  real*8, INTENT(IN) :: x,ep
449  IF(abs(ep).ne.1.d0) THEN
450  print*,' Wrong argument for CLN '
451  stop
452  ENDIF
453  cln(1)= log(abs(x))
454  IF(x > 0.d0) THEN
455  cln(2)= 0.d0
456  ELSE
457  cln(2)= ep*pi
458  ENDIF
459  END FUNCTION cln
460  END MODULE hto_cmplx_ln
461 *
462 *-----------------------------------------------------------------------------------------
463 *
464  MODULE hto_full_ln
465  INTERFACE OPERATOR ( .fln. )
466  MODULE PROCEDURE fln
467  END INTERFACE
468  CONTAINS
469  FUNCTION fln(x,y)
470  USE hto_riemann
471  IMPLICIT NONE
472  real*8 ax,ay,teta,tnteta,sr,si
473  real*8, INTENT(IN) :: x,y
474  real*8, dimension(2) :: fln
475  IF(abs(y).eq.1.d0) THEN
476  fln(1)= log(abs(x))
477  IF(x > 0.d0) THEN
478  fln(2)= 0.d0
479  ELSE
480  fln(2)= y*pi
481  ENDIF
482  ELSE
483  fln(1)= 0.5d0*log(x*x+y*y)
484  ax= abs(x)
485  ay= abs(y)
486  IF(x.eq.0.d0) THEN
487  IF(y > 0.d0) THEN
488  teta= pi/2.d0
489  ELSE
490  teta= -pi/2.d0
491  ENDIF
492  fln(2)= teta
493  ELSE IF(y.eq.0.d0) THEN
494  IF(x > 0.d0) THEN
495  teta= 0.d0
496  ELSE
497  teta= pi
498  ENDIF
499  fln(2)= teta
500  ELSE
501  tnteta= ay/ax
502  teta= atan(tnteta)
503  sr= x/ax
504  si= y/ay
505  IF(sr > 0.d0) THEN
506  fln(2)= si*teta
507  ELSE
508  fln(2)= si*(pi-teta)
509  ENDIF
510  ENDIF
511  ENDIF
512  END FUNCTION fln
513  END MODULE hto_full_ln
514 *
515 *------------------------------------------------------------------------
516 *
517  MODULE hto_ln_2_riemann
518  INTERFACE OPERATOR ( .lnsrs. )
519  MODULE PROCEDURE lnsrs
520  END INTERFACE
521  CONTAINS
522  FUNCTION lnsrs(x,y)
523  USE hto_riemann
524  USE hto_full_ln
525  USE hto_units
526  IMPLICIT NONE
527  real*8, dimension(2) :: lnsrs,x,y,olnsrs
528  real*8 ax,ay,teta,tnteta,ilnx,sr,si,sx,sy,xms
529  INTENT(IN) x,y
530 *
531  IF(abs(y(2)).ne.1.d0) THEN
532 *
533  xms= x(1)*x(1)+x(2)*x(2)
534  IF(abs(1.d0-sqrt(xms)).lt.1.d-12) THEN
535  teta= atan(abs(x(2)/x(1)))
536  sr= x(1)/abs(x(1))
537  si= x(2)/abs(x(2))
538  lnsrs(1)= 0.d0
539  IF(sr > 0.d0) THEN
540  lnsrs(2)= si*teta
541  ELSE
542  lnsrs(2)= si*(pi-teta)
543  ENDIF
544  RETURN
545  ELSE
546  lnsrs= x(1).fln.x(2)
547  olnsrs= y(1).fln.y(2)
548  RETURN
549  ENDIF
550  ENDIF
551 *
552  lnsrs(1)= 0.5d0*log(x(1)*x(1)+x(2)*x(2))
553  ax= abs(x(1))
554  ay= abs(x(2))
555  IF(x(1).eq.0.d0) THEN
556  IF(x(2) > 0.d0) THEN
557  teta= pi/2.d0
558  ELSE
559  teta= -pi/2.d0
560  ENDIF
561  ilnx= teta
562  ELSE IF(x(2).eq.0.d0) THEN
563  IF(x(1) > 0.d0) THEN
564  teta= 0.d0
565  ELSE
566  teta= pi
567  ENDIF
568  ilnx= teta
569  ELSE
570  tnteta= ay/ax
571  teta= atan(tnteta)
572  sr= x(1)/ax
573  si= x(2)/ay
574  IF(sr > 0.d0) THEN
575  ilnx= si*teta
576  ELSE
577  ilnx= si*(pi-teta)
578  ENDIF
579  ENDIF
580 *
581  IF(x(1) > 0.d0) THEN
582  IF(y(1) < 0.d0) THEN
583  IF((x(2) > 0.d0.and.y(2) > 0).or.
584  # (x(2) < 0.d0.and.y(2) < 0)) THEN
585  lnsrs(2)= ilnx
586  ELSEIF(x(2) > 0.d0.and.y(2) < 0) THEN
587  lnsrs(2)= ilnx-pi
588  ELSE
589  print*,'+++++++++++++++++++++++++++++++++++'
590  print*,' anomaly ln '
591  print*,x
592  print*,y
593  print*,'+++++++++++++++++++++++++++++++++++'
594  ENDIF
595  ELSE
596  lnsrs(2)= ilnx
597  ENDIF
598  ELSE
599  IF(abs(y(2)).ne.1.d0) THEN
600  print*,' Wrong argument for LNSRS '
601  stop
602  ELSE
603 *
604  IF((x(2)*y(2)) < 0.d0) THEN
605  lnsrs(2)= ilnx+2.d0*y(2)*pi
606  ELSE
607  lnsrs(2)= ilnx
608  ENDIF
609 *
610  ENDIF
611  ENDIF
612  RETURN
613  END FUNCTION lnsrs
614  END MODULE hto_ln_2_riemann
615 *
616 *-----------------------------------------------------------------------------------------
617 *
618  MODULE hto_cmplx_srs_root
619  INTERFACE OPERATOR ( .crsrs. )
620  MODULE PROCEDURE crsrs
621  END INTERFACE
622  CONTAINS
623  FUNCTION crsrs(x,y)
624  USE hto_units
625  USE hto_riemann
626  IMPLICIT NONE
627  real*8 r,rs,u,v
628  real*8, dimension(2) :: crsrs
629  real*8, INTENT(IN), dimension(2):: x,y
630 *
631  IF(x(1) > 0.d0) THEN
632  rs= x(1)*x(1)+x(2)*x(2)
633  r= sqrt(rs)
634  u= 0.5d0*(r+x(1))
635  crsrs(1)= sqrt(u)
636  r= sqrt(rs)
637  v= 0.5d0*(r-x(1))
638  crsrs(2)= sign(one,x(2))*sqrt(v)
639  ELSE
640  rs= x(1)*x(1)+x(2)*x(2)
641  r= sqrt(rs)
642  u= 0.5d0*(r+x(1))
643  v= 0.5d0*(r-x(1))
644 *
645  IF((x(2)*y(2)) > 0.d0) THEN
646  crsrs(1)= sqrt(u)
647  crsrs(2)= sign(one,x(2))*sqrt(v)
648  ELSEIF((x(2)*y(2)) < 0.d0) THEN
649  crsrs(1)= -sqrt(u)
650  crsrs(2)= sign(one,x(2))*sqrt(v)
651  ENDIF
652 *
653  ENDIF
654  END FUNCTION crsrs
655  END MODULE hto_cmplx_srs_root
656 *
657 *-----------------------------------------------------------------------------------------
658 *
659  MODULE hto_cmplx_root
660  INTERFACE OPERATOR ( .cr. )
661  MODULE PROCEDURE cr
662  END INTERFACE
663  CONTAINS
664  FUNCTION cr(x,ep)
665  IMPLICIT NONE
666  real*8, dimension(2) :: cr
667  real*8, INTENT(IN) :: x,ep
668  IF(x > 0.d0) THEN
669  cr(1)= sqrt(x)
670  cr(2)= 0.d0
671  ELSE
672  cr(1)= 0.d0
673  cr(2)= ep*sqrt(abs(x))
674  ENDIF
675  END FUNCTION cr
676  END MODULE hto_cmplx_root
677 *
678 *-----------------------------------------------------------------------------------------
679 *
680  MODULE hto_cmplx_rootz
681  INTERFACE OPERATOR ( .crz. )
682  MODULE PROCEDURE crz
683  END INTERFACE
684  CONTAINS
685  FUNCTION crz(x,y)
686  USE hto_units
687  IMPLICIT NONE
688  real*8, dimension(2) :: crz
689  real*8, INTENT(IN) :: x,y
690  real*8 rs,r,u,v,sax
691  IF(abs(y/x).lt.1.d-8) THEN
692  IF(x.gt.0.d0) THEN
693  crz(1)= sqrt(x)*(1.d0+0.5d0*y*y/(x*x))
694  crz(2)= 0.5d0*y/sqrt(x)
695  ELSEIF(x.lt.0.d0) THEN
696  sax= sqrt(abs(x))
697  crz(1)= 0.5d0*abs(y)/sax
698  crz(2)= sign(one,y)*sax*(1.d0+0.5d0*y*y/(x*x))
699  ENDIF
700  ELSE
701  rs= x*x+y*y
702  r= sqrt(rs)
703  u= 0.5d0*(r+x)
704  crz(1)= sqrt(u)
705  IF(x > 0.d0.and.y.eq.0.d0) THEN
706  crz(2)= 0.d0
707  ELSE
708  v= 0.5d0*(r-x)
709  crz(2)= sign(one,y)*sqrt(v)
710  ENDIF
711  ENDIF
712  END FUNCTION crz
713  END MODULE hto_cmplx_rootz
714 *
715 *-----------------------------------------------------------------------------------------
716 *
717  MODULE hto_common_niels
718  real*8, dimension(3,0:15) :: plr
719  real*8, dimension(3,0:15) :: plr_4
720  END MODULE hto_common_niels
721 *
722 *-----------------------------------------------------------------------------------------
723 *
724  MODULE hto_kountac
725  INTEGER kp,km
726  END MODULE hto_kountac
727 *
728 *-----------------------------------------------------------------------------------------
729 *
730  MODULE hto_linear_comb
731  INTERFACE OPERATOR ( .lc. )
732  MODULE PROCEDURE lc
733  END INTERFACE
734  CONTAINS
735  FUNCTION lc(c,x)
736  IMPLICIT NONE
737  real*8, dimension(:) :: c
738  real*8 x,lc
739  INTENT(IN) c,x
740  INTEGER n,i
741  real*8 sum
742  n= size(c)
743  sum= c(n)
744  DO i=n-1,1,-1
745  sum= sum*x+c(i)
746  ENDDO
747  lc= sum
748  END FUNCTION lc
749  END MODULE hto_linear_comb
750 *
751 *-----------------------------------------------------------------------------------------
752 *
753  MODULE hto_sp_fun
754  CONTAINS
755 *
756 * extension to n+p = 4
757 *
758 * 1 Li_2
759 * 2 Li_3
760 * 3 S_12
761 * 4 Li_4
762 * 5 S_22
763 * 6 S_13
764 *
765  RECURSIVE FUNCTION hto_s_niels_up4(x) RESULT(res)
766  USE hto_riemann
767  USE hto_acmplx_pro
768  USE hto_cmplx_ln
769  USE hto_real_ln
770  USE hto_common_niels
771  USE hto_linear_comb
772  USE hto_units
773 *
774  IMPLICIT NONE
775 *
776  real*8, dimension(6,2) :: res
777  real*8, dimension(2) :: x
778  INTENT(IN) x
779 *
780  INTEGER i,j,l
781  real*8 ym,ym2,ymod,s1,s2,s3,l2,xmo,z_exp,sum,s13m1,s22m1
782  real*8, dimension(6) :: sign
783  real*8, dimension(0:15) :: sumr
784  real*8, dimension(6,2) :: aniels,bniels,add
785  real*8, dimension(2) :: ln_omx,ln2_omx,ln3_omx,ln_omy,ln2_omy,
786  # ln3_omy,ln_y,ln2_y,ln3_y,ln_yi,ln_myi,ln2_myi,ln3_myi,ln4_y,
787  # y,omy,yi,yt,omx,myi,prod,li2,li3,s12,prod1,prod2,prodl,
788  # prodl1,prodl2,add1,add2,add3,add4,add5,add6,add7,add8,add9,
789  # add10,ln_my,ln2_my,ln3_my,ln4_my,add11,add12,add13,add14,
790  # add15,add16,add17,add18,add19,add20,add21,ln4_omx,ln_ymo,
791  # ln2_ymo,ln3_ymo,ln4_ymo
792  real*8, parameter :: li4h=6.72510831970049127d-2
793 *
794  IF(abs(x(2)).ne.1.d0) THEN
795  print 1,x
796  stop
797  ENDIF
798  1 format(' wrong input for niels ',2e20.5)
799 *
800  l2= log(2.d0)
801  s13m1= li4h+l2*(7.d0/8.d0*rz3-rz2*l2/4.d0+l2*l2*l2/24.d0)-rz4
802  s22m1= 2.d0*li4h+l2*(7.d0/4.d0*rz3-0.5d0*rz2*l2+l2*l2*l2/12.d0)-
803  # 15.d0/8.d0*rz4
804 *
805  IF(x(1).eq.1.d0) THEN
806  res(1,1)= rz2
807  res(2,1)= rz3
808  res(3,1)= rz3
809  res(4,1)= rz4
810  res(5,1)= -1/2*(rz2**2-3.d0*rz4)
811  res(6,1)= rz4
812  FORALL (i=1:6) res(i,2)= 0.d0
813  RETURN
814  ENDIF
815  IF(x(1).eq.0.5d0) THEN
816  res(1,1)= 0.5d0*(rz2-l2*l2)
817  res(2,1)= 7.d0/8.d0*rz3-l2*(0.5d0*rz2-l2*l2/6.d0)
818  res(3,1)= rz3/8.d0-l2*l2*l2/6.d0
819  res(4,1)= li4h
820  res(5,1)= -l2*res(3,1)-l2**4/8.d0-rz2*rz2/4.d0+3.d0/4.d0*rz4
821  res(6,1)= -res(4,1)+l2*res(3,1)+l2**2/4.d0*(1.d0/3.d0+rz2)-
822  # l2*rz3-rz4
823  FORALL (i=1:6) res(i,2)= 0.d0
824  RETURN
825  ENDIF
826 *
827 * gets rid of arguments with negative real part
828 *
829  IF(x(1) < 0.d0) THEN
830  xmo= x(1)-1.d0
831  ymod= xmo*xmo
832  y(1)= x(1)*xmo/ymod
833  y(2)= -x(2)
834  omx= co-x
835  ln_omx= omx(1).cln.omx(2)
836  ln2_omx= ln_omx.cp.ln_omx
837  ln3_omx= ln2_omx.cp.ln_omx
838  ln4_omx= ln3_omx.cp.ln_omx
839  aniels= hto_s_niels_up4(y)
840  li2(1:2)= aniels(1,1:2)
841  li3(1:2)= aniels(2,1:2)
842  s12(1:2)= aniels(3,1:2)
843  add1= ln2_omx.cp.li2
844  add2= ln_omx.cp.li3
845  add3= ln_omx.cp.s12
846  add(1,1:2)= -0.5d0*ln2_omx(1:2)
847  sign(1)= -1.d0
848  prod= ln_omx.cp.li2
849  add(2,1:2)= aniels(3,1:2)-ln3_omx(1:2)/6.d0-prod(1:2)
850  sign(2)= -1.d0
851  add(3,1:2)= ln3_omx(1:2)/6.d0
852  sign(3)= 1.d0
853  add(4,1:2)= -0.5d0*add1(1:2)-add2(1:2)+add3(1:2)
854  # -1.d0/24.d0*ln4_omx(1:2)-aniels(6,1:2)+aniels(5,1:2)
855  # +co(1:2)*(2.d0*s13m1-s22m1+1.d0/8.d0*rz4)
856  sign(4)= -1.d0
857  add(5,1:2)= add3(1:2)+1.d0/24.d0*ln4_omx(1:2)
858  # -2.d0*aniels(6,1:2)+aniels(5,1:2)+co(1:2)*(4.d0*s13m1
859  # -2.d0*s22m1+0.25d0*rz4)
860  sign(5)= 1.d0
861  add(6,1:2)= -1.d0/24.d0*ln4_omx(1:2)-aniels(6,1:2)+
862  # co(1:2)*(4.d0*s13m1-2.d0*s22m1+0.25d0*rz4)
863  sign(6)= -1.d0
864  ELSE
865  y= x
866  add= 0.d0
867  sign= 1.d0
868  ENDIF
869 *
870  ym2= y(1)*y(1)
871  ym= abs(y(1))
872 *
873 * |y| < 1 & Re(y) < 1/2
874 *
875  IF(ym < 1.d0.and.y(1) < 0.5d0) THEN
876  omy= co-y
877  z_exp= -(omy(1).rln.omy(2))
878  DO l=1,3
879  sumr(0:15)= plr(l,0:15)
880  sum= sumr.lc.z_exp
881  res(l,1)= sum
882  res(l,2)= 0.d0
883  ENDDO
884  DO l=4,6
885  sumr(0:15)= plr_4(l-3,0:15)
886  sum= sumr.lc.z_exp
887  res(l,1)= sum
888  res(l,2)= 0.d0
889  ENDDO
890  FORALL (i=1:6,j=1:2) res(i,j)= sign(i)*res(i,j)+add(i,j)
891  RETURN
892 *
893 * |y| < 1 & Re(y) > 1/2
894 *
895  ELSEIF(ym < 1.d0.and.y(1) > 0.5d0) THEN
896  omy= co-y
897  ln_omy= omy(1).cln.omy(2)
898  ln_y= y(1).cln.y(2)
899  ln2_omy= ln_omy.cp.ln_omy
900  ln2_y= ln_y.cp.ln_y
901  ln3_y= ln2_y.cp.ln_y
902  aniels= hto_s_niels_up4(omy)
903  s12(1:2)= aniels(3,1:2)
904  li3(1:2)= aniels(2,1:2)
905  li2(1:2)= aniels(1,1:2)
906  prodl= ln_y.cp.ln_omy
907  res(1,1:2)= -li2(1:2)-prodl(1:2)+rz2*co(1:2)
908  prodl= ln_omy.cp.ln2_y
909  prod= ln_y.cp.li2
910  res(2,1:2)= -s12(1:2)-prod(1:2)-0.5d0*prodl(1:2)+
911  # rz2*ln_y(1:2)+rz3*co(1:2)
912  prodl= ln_y.cp.ln2_omy
913  prod= ln_omy.cp.li2
914  res(3,1:2)= -li3(1:2)+prod(1:2)+0.5d0*prodl(1:2)+rz3*co(1:2)
915  add1= ln2_y.cp.li2
916  add2= ln_y.cp.s12
917  add3= ln_omy.cp.ln3_y
918  add4= ln_omy.cp.s12
919  add5= ln_y.cp.ln_omy
920  add5= add5.cp.li2
921  add6= ln_y.cp.li3
922  add7= ln2_y.cp.ln2_omy
923  add8= ln_omy.cp.li3
924  add9= ln_y.cp.ln3_omy
925  add10= ln2_omy.cp.li2
926  res(4,1:2)= -aniels(6,1:2)-0.5d0*add1(1:2)-add2(1:2)-
927  # add3(1:2)/6.d0+rz3*ln_y(1:2)+0.5d0*rz2*ln2_y+rz4*co(1:2)
928  res(5,1:2)= aniels(5,1:2)-add4(1:2)-add5(1:2)+add6(1:2)
929  # -add2(1:2)-0.25d0*add7(1:2)+0.5d0*co(1:2)*(rz2*rz2-3.d0*rz4)
930  res(6,1:2)= aniels(4,1:2)-add8(1:2)+add9(1:2)/6.d0+
931  # 0.5d0*add10(1:2)-co(1:2)*s13m1
932  FORALL (i=1:6,j=1:2) res(i,j)= sign(i)*res(i,j)+add(i,j)
933  RETURN
934 *
935 * |y| > 1 & Re(y^-1) < 1/2
936 *
937  ELSEIF(ym > 1.d0.and.y(1) >= 2.d0) THEN
938  yi(1)= y(1)/ym2
939  yi(2)= -y(2)
940  ln_yi= yi(1).cln.yi(2)
941  ln_my= (-y(1)).cln.(-y(2))
942  ln2_my= ln_my.cp.ln_my
943  ln3_my= ln3_my.cp.ln_my
944  ln4_my= ln3_my.cp.ln_my
945  myi(1)= -y(1)/ym2
946  myi(2)= y(2)
947  ln_myi= myi(1).cln.myi(2)
948  ln2_myi= ln_myi.cp.ln_myi
949  ln3_myi= ln2_myi.cp.ln_myi
950  aniels= hto_s_niels_up4(yi)
951  li2(1:2)= aniels(1,1:2)
952  li3(1:2)= aniels(2,1:2)
953  s12(1:2)= aniels(3,1:2)
954  res(1,1:2)= -aniels(1,1:2)-0.5d0*ln2_myi(1:2)-rz2*co(1:2)
955  res(2,1:2)= aniels(2,1:2)+ln3_myi(1:2)/6.d0+rz2*ln_myi(1:2)
956  li2(1:2)= aniels(1,1:2)
957  prod= ln_myi.cp.li2
958  res(3,1:2)= aniels(2,1:2)-aniels(3,1:2)-ln3_myi(1:2)/6.d0-
959  # prod(1:2)+rz3*co(1:2)
960  res(4,1:2)= aniels(4,1:2)+0.5d0*rz2*ln2_my(1:2)+
961  # 1.d0/24.d0*ln4_my+7.d0/4.d0*rz4*co(1:2)
962  add1= ln_my.cp.li3
963  add1= ln_my.cp.s12
964  add3= ln2_my.cp.li2
965  res(5,1:2)= -aniels(5,1:2)+2.d0*aniels(4,1:2)+add1(1:2)-
966  # rz3*ln_my-ln4_my/24.d0+7.d0/4.d0*rz4*co(1:2)
967  res(6,1:2)= aniels(4,1:2)+aniels(6,1:2)-aniels(5,1:2)+
968  # add1(1:2)-add2(1:2)+0.5d0*add3(1:2)+ln4_my/24.d0+
969  # co(1:2)*(-2.d0*s13m1+s22m1+7.d0/8.d0*rz4)
970  FORALL (i=1:6,j=1:2) res(i,j)= sign(i)*res(i,j)+add(i,j)
971  RETURN
972 *
973 * |y| > 1 & Re(y^-1) > 1/2
974 *
975  ELSEIF(ym > 1.d0.and.y(1) < 2.d0) THEN
976  yt(1)= (y(1)-1.d0)/y(1)
977  yt(2)= y(2)
978  omy= co-y
979  ln_y= y(1).cln.y(2)
980  ln_omy= omy(1).cln.omy(2)
981  ln2_y= ln_y.cp.ln_y
982  ln3_y= ln2_y.cp.ln_y
983  ln4_y= ln3_y.cp.ln_y
984  ln2_omy= ln_omy.cp.ln_omy
985  ln_my= (-y(1)).cln.(-y(2))
986  ln2_my= ln_my.cp.ln_my
987  ln3_my= ln2_my.cp.ln_my
988  ln4_my= ln3_my.cp.ln_my
989  aniels= hto_s_niels_up4(yt)
990  bniels= 0.d0
991  prod= ln_y.cp.ln_omy
992  bniels(1,1:2)= aniels(1,1:2)-prod(1:2)+0.5d0*ln2_y(1:2)+
993  # rz2*co(1:2)
994  res(1,1:2)= aniels(1,1:2)-prod(1:2)+0.5d0*ln2_y(1:2)+
995  # rz2*co(1:2)
996  prodl= ln2_y.cp.ln_omy
997  li2(1:2)= bniels(1,1:2)
998  prod= ln_y.cp.li2
999  res(2,1:2)= -aniels(3,1:2)+prod(1:2)+0.5d0*prodl(1:2)-
1000  # ln3_y(1:2)/6.d0+rz3*co(1:2)
1001  li2(1:2)= aniels(1,1:2)
1002  prodl1= ln_omy.cp.ln2_y
1003  prodl2= ln_y.cp.ln2_omy
1004  prod1= ln_omy.cp.li2
1005  prod2= ln_y.cp.li2
1006  res(3,1:2)= rz3*co(1:2)-0.5d0*prodl1(1:2)-prod1(1:2)+
1007  # 0.5d0*prodl2(1:2)+ln3_y(1:2)/6.d0+prod2(1:2)+
1008  # aniels(2,1:2)-aniels(3,1:2)
1009  add1= ln_ymo.cp.ln3_y
1010  add2= ln_y.cp.s12
1011  add3= ln2_y.cp.li2
1012  add4= ln_ymo.cp.s12
1013  add5= ln_my.cp.ln_ymo
1014  add5= add5.cp.ln2_y
1015  add6= ln_my.cp.s12
1016  add7= ln_y.cp.ln_ymo
1017  add7= add7.cp.li2
1018  add8= ln_my.cp.ln3_y
1019  add9= ln_y.cp.ln_my
1020  add9= add9.cp.li2
1021  add10= ln_y.cp.ln_my
1022  add11= ln_y.cp.li3
1023  add12= ln2_y.cp.ln2_ymo
1024  add13= ln_ymo.cp.li3
1025  add14= ln_my.cp.ln_ymo
1026  add14= add14.cp.li2
1027  add15= ln_my.cp.li3
1028  add16= ln_y.cp.ln_ymo
1029  add16= add16.cp.ln2_my
1030  add17= ln_y.cp.ln_my
1031  add17= add17.cp.ln2_ymo
1032  add18= ln_y.cp.ln3_ymo
1033  add19= ln2_ymo.cp.li2
1034  add20= ln2_my.cp.li2
1035  add21= ln2_y.cp.ln2_my
1036  res(4,1:2)= -1.d0/6.d0*add1(1:2)-add2(1:2)+ln_y(1:2)*rz3
1037  # -0.5d0*ln2_my*rz2+0.5d0*add3(1:2)-0.5d0*ln2_y(1:2)*rz2
1038  # -1.d0/24.d0*ln4_my(1:2)+1.d0/6.d0*ln4_y(1:2)+aniels(6,1:2)
1039  # -11.d0/4.d0*rz4*co(1:2)
1040  res(5,1:2)= -5.d0/6.d0*add1(1:2)+add4(1:2)+0.5d0*add5(1:2)
1041  # -0.5d0*add8(1:2)+add6(1:2)-add7(1:2)-add9(1:2)
1042  # +add10(1:2)*rz2+add11(1:2)-3.d0*add2(1:2)+ln_y(1:2)*rz3
1043  # +1.d0/4.d0*add12(1:2)+2.d0*add3(1:2)-ln2_y(1:2)*rz2
1044  # +1.d0/24.d0*ln4_my(1:2)+7.d0/12.d0*ln4_y(1:2)
1045  # +2.d0*aniels(6,1:2)-aniels(5,1:2)-7.d0/2.d0*rz4*co(1:2)
1046  res(6,1:2)= -7.d0/6.d0*add1(1:2)-add13(1:2)+add4(1:2)
1047  # +3.d0/2.d0*add5(1:2)+add14(1:2)-add8(1:2)-add15(1:2)
1048  # +add6(1:2)-0.5d0*add16(1:2)-2.d0*add7(1:2)-0.5d0*add17(1:2)
1049  # -2.d0*add9(1:2)+add10(1:2)*rz2-1.d0/6.d0*add18(1:2)
1050  # +2.d0*add11(1:2)-2.d0*add2(1:2)+0.5d0*add19(1:2)
1051  # +0.5d0*add20(1:2)-0.5d0*ln2_my*rz2+3.d0/4.d0*add12(1:2)
1052  # +0.5d0*add21(1:2)+2.d0*add3(1:2)-0.5d0*ln2_y(1:2)*rz2
1053  # -1.d0/24.d0*ln4_my(1:2)+ 7.d0/12.d0*ln4_y(1:2)+aniels(4,1:2)
1054  # +aniels(6,1:2)-aniels(5,1:2)+co(1:2)*(2.d0*s13m1-s22m1
1055  # -21.d0/8.d0*rz4)
1056  FORALL (i=1:6,j=1:2) res(i,j)= sign(i)*res(i,j)+add(i,j)
1057  RETURN
1058  ENDIF
1059 *
1060  END FUNCTION hto_s_niels_up4
1061 *
1062 *------------------------------------------------------------------
1063 *
1064  FUNCTION hto_li2_srsz(x,y,unit) RESULT(value)
1065  USE hto_acmplx_pro
1066  USE hto_full_ln
1067  USE hto_riemann
1068  USE hto_units
1069  USE hto_kountac
1070 *
1071  IMPLICIT NONE
1072 *
1073  INTEGER unit
1074  real*8 xms,atheta,theta,sr,si
1075  real*8, dimension (:) :: x,y
1076  real*8, dimension(3,2) :: aux
1077  real*8, dimension(2) :: lnc,add,value
1078  INTENT(IN) x,y
1079 *
1080  IF(abs(y(2)).ne.1.d0) THEN
1081  IF(unit.eq.1) THEN
1082  xms= x(1)*x(1)+x(2)*x(2)
1083  IF(abs(1.d0-sqrt(xms)).gt.1.d-12) THEN
1084  print*,' apparent inconsistency '
1085  ENDIF
1086  atheta= atan(abs(x(2)/x(1)))
1087  sr= x(1)/abs(x(1))
1088  si= x(2)/abs(x(2))
1089  IF(sr > 0.d0.and.si > 0.d0) THEN
1090  theta= atheta
1091  ELSEIF(sr > 0.d0.and.si < 0.d0) THEN
1092  theta= 2.d0*pi-atheta
1093  ELSEIF(sr < 0.d0.and.si > 0.d0) THEN
1094  theta= pi-atheta
1095  ELSEIF(sr < 0.d0.and.si < 0.d0) THEN
1096  theta= pi+atheta
1097  ENDIF
1098  aux= hto_poly_unit(theta)
1099  value(1:2)= aux(1,1:2)
1100  ELSE
1101  value= hto_li2(x)
1102  ENDIF
1103  RETURN
1104  ENDIF
1105 *
1106  IF(x(1) > 1.d0) THEN
1107  IF(y(1) < 1.d0) THEN
1108  value= hto_li2(x)
1109  print*,'+++++++++++++++++++++++++++++++++++'
1110  print*,' anomaly Li2 '
1111  print*,x
1112  print*,y
1113  print*,'+++++++++++++++++++++++++++++++++++'
1114  ENDIF
1115  lnc= x(1).fln.x(2)
1116  add(1)= -lnc(2)
1117  add(2)= lnc(1)
1118  IF(y(2) < 0.d0.and.x(2) > 0.d0) THEN
1119  value= hto_li2(x)-2.d0*pi*add
1120  km= km+1
1121  ELSEIF(y(2) > 0.d0.and.x(2) < 0.d0) THEN
1122  value= hto_li2(x)+2.d0*pi*add
1123  kp= kp+1
1124  ELSE
1125  value= hto_li2(x)
1126  ENDIF
1127  ELSE
1128  value= hto_li2(x)
1129  ENDIF
1130 *
1131  RETURN
1132 *
1133  END FUNCTION hto_li2_srsz
1134 *
1135 *------------------------------------------------------------------
1136 *
1137  FUNCTION hto_li3_srsz(x,y,unit) RESULT(value)
1138  USE hto_acmplx_pro
1139  USE hto_full_ln
1140  USE hto_riemann
1141  USE hto_units
1142 *
1143  IMPLICIT NONE
1144 *
1145  INTEGER unit
1146  real*8 xms,atheta,theta,sr,si
1147  real*8, dimension (:) :: x,y
1148  real*8, dimension(3,2) :: aux
1149  real*8, dimension(2) :: lnc,lncs,add,value
1150  INTENT(IN) x,y
1151 *
1152  IF(abs(y(2)).ne.1.d0) THEN
1153  IF(unit.eq.1) THEN
1154  xms= x(1)*x(1)+x(2)*x(2)
1155  IF(abs(1.d0-sqrt(xms)).gt.1.d-12) THEN
1156  print*,' apparent inconsistency '
1157  ENDIF
1158  atheta= atan(abs(x(2)/x(1)))
1159  sr= x(1)/abs(x(1))
1160  si= x(2)/abs(x(2))
1161  IF(sr > 0.d0.and.si > 0.d0) THEN
1162  theta= atheta
1163  ELSEIF(sr > 0.d0.and.si < 0.d0) THEN
1164  theta= 2.d0*pi-atheta
1165  ELSEIF(sr < 0.d0.and.si > 0.d0) THEN
1166  theta= pi-atheta
1167  ELSEIF(sr < 0.d0.and.si < 0.d0) THEN
1168  theta= pi+atheta
1169  ENDIF
1170  aux= hto_poly_unit(theta)
1171  value(1:2)= aux(2,1:2)
1172  ELSE
1173  value= hto_li3(x)
1174  ENDIF
1175  RETURN
1176  ENDIF
1177 *
1178  IF(x(1) > 1.d0) THEN
1179  IF(y(1) < 1.d0) THEN
1180  print*,' anomaly'
1181  print*,x
1182  print*,y
1183  stop
1184  ENDIF
1185  lnc= x(1).fln.x(2)
1186  lncs= lnc.cp.lnc
1187  add(1)= -lncs(2)
1188  add(2)= lncs(1)
1189  IF(y(2) < 0.d0.and.x(2) > 0.d0) THEN
1190  value= hto_li3(x)-pi*add
1191  ELSEIF(y(2) > 0.d0.and.x(2) < 0.d0) THEN
1192  value= hto_li3(x)+pi*add
1193  ELSE
1194  value= hto_li3(x)
1195  ENDIF
1196  ELSE
1197  value= hto_li3(x)
1198  ENDIF
1199 *
1200  RETURN
1201 *
1202  END FUNCTION hto_li3_srsz
1203 *
1204 *
1205 *------------------------------------------------------------------
1206 *
1207  FUNCTION hto_poly_unit(theta) RESULT(value)
1208  USE hto_riemann
1209  USE hto_full_ln
1210  USE hto_real_lnz
1211  USE hto_imag_lnz
1212  USE hto_linear_comb_c
1213  USE hto_acmplx_pro
1214  USE hto_bernoulli
1215  USE hto_units
1216 *
1217  IMPLICIT NONE
1218 *
1219  INTEGER n,i
1220  real*8 theta
1221  real*8, dimension(2) :: arg,ln,z,sum2,sum3,sum4,pw2,pw3,pw4,
1222  # cb2,cb3,cb4
1223  real*8, dimension(4) :: psi
1224  real*8, dimension(0:15) :: rzf
1225  real*8, dimension(3,2) :: value
1226  real*8, dimension(0:17) :: c2,c3,c4,fac
1227 *
1228  data rzf(0:15) /-0.5d0,0.d0,1.644934066848226d0,
1229  # 1.202056903159594d0,1.082323233711138d0,
1230  # 1.036927755143370d0,1.017343061984449d0,
1231  # 1.008349277381923d0,1.004077356197944d0,
1232  # 1.002008392826082d0,1.000994575127818d0,
1233  # 1.000494188604119d0,1.000246086553308d0,
1234  # 1.000122713346578d0,1.000061248135059d0,
1235  # 1.000030588236307d0/
1236 *
1237  psi(1)= eg
1238  psi(2)= psi(1)+1.d0
1239  psi(3)= psi(2)+0.5d0
1240  psi(4)= psi(3)+1.d0/3.d0
1241 *
1242  fac(0)= 1.d0
1243  DO n=1,17
1244  fac(n)= n*fac(n-1)
1245  ENDDO
1246 *
1247  arg(1)= 0.d0
1248  arg(2)= -theta
1249 *
1250  ln= arg(1).fln.arg(2)
1251 *
1252  DO n=0,17
1253  IF((2-n) >= 0) THEN
1254  c2(n)= rzf(2-n)/fac(n)
1255  ELSE
1256  c2(n)= -b_num(n-1)/(n-1)/fac(n)
1257  ENDIF
1258  IF((3-n) >= 0) THEN
1259  c3(n)= rzf(3-n)/fac(n)
1260  ELSE
1261  c3(n)= -b_num(n-2)/(n-2)/fac(n)
1262  ENDIF
1263  IF((4-n) >= 0) THEN
1264  c4(n)= rzf(4-n)/fac(n)
1265  ELSE
1266  c4(n)= -b_num(n-3)/(n-3)/fac(n)
1267  ENDIF
1268  ENDDO
1269 *
1270  z(1)= 0.d0
1271  z(2)= theta
1272 *
1273  sum2= c2.lcc.z
1274  sum3= c3.lcc.z
1275  sum4= c4.lcc.z
1276 *
1277  pw2= z
1278  pw3= z.cp.pw2
1279  pw4= z.cp.pw3
1280 *
1281  cb2(1:2)= co(1:2)*(psi(2)-psi(1))-ln(1:2)
1282  cb3(1:2)= co(1:2)*(psi(3)-psi(1))-ln(1:2)
1283  cb4(1:2)= co(1:2)*(psi(4)-psi(1))-ln(1:2)
1284 *
1285  cb2= pw2.cp.cb2
1286  cb3= pw3.cp.cb3
1287  cb4= pw4.cp.cb4
1288 *
1289  value(1,1:2)= sum2(1:2)+cb2(1:2)
1290 *
1291  value(2,1:2)= sum3(1:2)+0.5d0*cb3(1:2)
1292 *
1293  value(3,1:2)= 1.d0/6.d0*(sum4(1:2)+1.d0/6.d0*cb4(1:2))
1294 *
1295  RETURN
1296 *
1297  END FUNCTION hto_poly_unit
1298 *
1299 *-----------------------------------------------------------------
1300 *
1301  FUNCTION hto_li2(x) RESULT(value)
1302  USE hto_acmplx_pro
1303  USE hto_acmplx_rat
1304  USE hto_full_ln
1305  USE hto_bernoulli
1306  USE hto_riemann
1307  USE hto_units
1308 *
1309  IMPLICIT NONE
1310 *
1311  real*8, dimension(2) ::x,value
1312  INTENT(IN) x
1313 *
1314  INTEGER n
1315  real*8 ym,ym2,sign1,sign2,sign3,fact, parr,pari,parm,parm2,zr
1316  real*8, dimension(2) :: clnx,clnomx,clnoy,clnz,clnomz,
1317  # add1,add2,add3,par,res
1318  real*8, dimension(0:14) :: bf
1319  real*8, dimension(15) :: ct,sn
1320  real*8, dimension(2) :: omx,y,oy,omy,z,omz,t,omt
1321 *
1322  omx= co-x
1323  IF(x(1) < 0.d0) THEN
1324  y= omx
1325  sign1= -1.d0
1326  clnx= x(1).fln.x(2)
1327  clnomx= omx(1).fln.omx(2)
1328  add1= pis/6.d0*co-(clnx.cp.clnomx)
1329  ELSE
1330  y= x
1331  sign1= 1.d0
1332  add1= 0.d0
1333  ENDIF
1334  omy= co-y
1335  ym2= y(1)*y(1)+y(2)*y(2)
1336  ym= sqrt(ym2)
1337  IF(ym > 1.d0) THEN
1338  z(1)= y(1)/ym2
1339  z(2)= -y(2)/ym2
1340  sign2= -1.d0
1341  oy= -y
1342  clnoy= oy(1).fln.oy(2)
1343  add2= -pis/6.d0*co-0.5d0*(clnoy.cp.clnoy)
1344  ELSE
1345  z= y
1346  sign2= 1.d0
1347  add2= 0.d0
1348  ENDIF
1349  omz= co-z
1350  zr= z(1)
1351  IF(zr > 0.5d0) THEN
1352  t= co-z
1353  omt= co-t
1354  sign3= -1.d0
1355  clnz= z(1).fln.z(2)
1356  clnomz= omz(1).fln.omz(2)
1357  add3= pis/6.d0*co-(clnz.cp.clnomz)
1358  ELSE
1359  t= z
1360  omt= co-t
1361  sign3= 1.d0
1362  add3= 0.d0
1363  ENDIF
1364  par= omt(1).fln.omt(2)
1365  fact= 1.d0
1366  DO n=0,14
1367  bf(n)= b_num(n)/fact
1368  fact= fact*(n+2.d0)
1369  ENDDO
1370  parr= par(1)
1371  pari= par(2)
1372  parm2= parr*parr+pari*pari
1373  parm= sqrt(parm2)
1374  ct(1)= parr/parm
1375  sn(1)= pari/parm
1376  DO n=2,15
1377  ct(n)= ct(1)*ct(n-1)-sn(1)*sn(n-1)
1378  sn(n)= sn(1)*ct(n-1)+ct(1)*sn(n-1)
1379  ENDDO
1380 *
1381  res(1)= -((((((((bf(14)*ct(15)*parm2+bf(12)*ct(13))*parm2+
1382  # bf(10)*ct(11))*parm2+bf(8)*ct(9))*parm2+
1383  # bf(6)*ct(7))*parm2+bf(4)*ct(5))*parm2+
1384  # bf(2)*ct(3))*(-parm)+bf(1)*ct(2))*(-parm)+
1385  # bf(0)*ct(1))*parm
1386  res(2)= -((((((((bf(14)*sn(15)*parm2+bf(12)*sn(13))*parm2+
1387  # bf(10)*sn(11))*parm2+bf(8)*sn(9))*parm2+
1388  # bf(6)*sn(7))*parm2+bf(4)*sn(5))*parm2+
1389  # bf(2)*sn(3))*(-parm)+bf(1)*sn(2))*(-parm)+
1390  # bf(0)*sn(1))*parm
1391 *
1392  value= sign1*(sign2*(sign3*res+add3)+add2)+add1
1393 *
1394  RETURN
1395 *
1396  END FUNCTION hto_li2
1397 *
1398 *------------------------------------------------------------------
1399 *
1400  FUNCTION hto_li3(x)
1401  USE hto_riemann
1402  USE hto_units
1403 *
1404  IMPLICIT NONE
1405 *
1406  real*8, dimension (:) :: x
1407  real*8 hto_li3(size(x))
1408  INTENT(IN) x
1409  INTEGER n
1410  real*8 xm,xm2,xtst,pr,pj,p2,pm,pr1,pj1,pm1,p12,pr2,pj2,p22,pm2,
1411  # rln2_x,iln2_x,tm2,y2r,ym2,ytst
1412  real*8, dimension(0:14) :: bf
1413  real*8, dimension(15) :: ct,sn,ct1,sn1,ct2,sn2
1414  real*8, dimension(2) :: y,addx,ox,clnx,par,res,u1,u2,ln_y,omy,
1415  # ln_omy,addy,par1,par2,res1,res2,t,resa,resb,ln_t,res3,res4,
1416  # ln_omt,addt,addt2,omt,omu1,omu2
1417  real*8 :: b(0:14)=(/1.d0,-0.75d0,
1418  # 0.236111111111111111111111111111111d0,
1419  # -3.472222222222222222222222222222222d-2,
1420  # 6.481481481481481481481481481481482d-4,
1421  # 4.861111111111111111111111111111111d-4,
1422  # -2.393550012597631645250692869740488d-5,
1423  # -1.062925170068027210884353741496599d-5,
1424  # 7.794784580498866213151927437641723d-7,
1425  # 2.526087595532039976484420928865373d-7,
1426  # -2.359163915200471237027273583310139d-8,
1427  # -6.168132746415574698402981231264060d-9,
1428  # 6.824456748981078267312315451125495d-10,
1429  # 1.524285616929084572552216019859487d-10,
1430  # -1.916909414174054295837274763110831d-11/)
1431 *
1432  FORALL (n=0:14) bf(n)= b(n)/(n+1.d0)
1433 *
1434  xm2= x(1)*x(1)+x(2)*x(2)
1435  xm= sqrt(xm2)
1436 *
1437 *-----the modulus of x is checked
1438 *
1439  xtst= xm-1.d0
1440  IF(xtst <= 1.d-20) THEN
1441  y= x
1442  addx= 0.d0
1443  ELSE IF(xm > 1.d-20) THEN
1444  y(1)= x(1)/xm2
1445  y(2)= -x(2)/xm2
1446  ox= -x
1447  clnx= hto_cqlnx(ox)
1448  rln2_x= clnx(1)*clnx(1)
1449  iln2_x= clnx(2)*clnx(2)
1450  addx(1)= -clnx(1)*(rz2+1.d0/6.d0*(rln2_x-3.d0*iln2_x))
1451  addx(2)= -clnx(2)*(rz2+1.d0/6.d0*(3.d0*rln2_x-iln2_x))
1452  ENDIF
1453 *
1454 *-----once x --> y, |y|<1 the sign of re(y) is checked
1455 * if re(y)>0 a transformation is required for re(y)>1/2
1456 *
1457  y2r= y(1)*y(1)-y(2)*y(2)
1458  IF(y(1) >= 0.d0.or.y2r < 0.d0) THEN
1459  ytst= y(1)-0.5d0
1460  IF(ytst <= 1.d-20) THEN
1461 *
1462 *-----li_3(y) is computed
1463 *
1464  omy= co-y
1465  par= hto_cqlnomx(y,omy)
1466  pr= -par(1)
1467  pj= -par(2)
1468  p2= pr*pr+pj*pj
1469  pm= sqrt(p2)
1470  ct(1)= pr/pm
1471  sn(1)= pj/pm
1472  DO n=2,15
1473  ct(n)= ct(1)*ct(n-1)-sn(1)*sn(n-1)
1474  sn(n)= sn(1)*ct(n-1)+ct(1)*sn(n-1)
1475  ENDDO
1476  res(1)= pm*(bf(0)*ct(1)+pm*(bf(1)*ct(2)+pm*
1477  # (bf(2)*ct(3)+pm*(bf(3)*ct(4)+pm*
1478  # (bf(4)*ct(5)+pm*(bf(5)*ct(6)+pm*
1479  # (bf(6)*ct(7)+pm*(bf(7)*ct(8)+pm*
1480  # (bf(8)*ct(9)+pm*(bf(9)*ct(10)+pm*
1481  # (bf(10)*ct(11)+pm*(bf(11)*ct(12)+pm*
1482  # (bf(12)*ct(13)+pm*(bf(13)*ct(14)+pm*
1483  # (bf(14)*ct(15))))))))))))))))
1484  res(2)= pm*(bf(0)*sn(1)+pm*(bf(1)*sn(2)+pm*
1485  # (bf(2)*sn(3)+pm*(bf(3)*sn(4)+pm*
1486  # (bf(4)*sn(5)+pm*(bf(5)*sn(6)+pm*
1487  # (bf(6)*sn(7)+pm*(bf(7)*sn(8)+pm*
1488  # (bf(8)*sn(9)+pm*(bf(9)*sn(10)+pm*
1489  # (bf(10)*sn(11)+pm*(bf(11)*sn(12)+pm*
1490  # (bf(12)*sn(13)+pm*(bf(13)*sn(14)+pm*
1491  # (bf(14)*sn(15))))))))))))))))
1492  hto_li3= res+addx
1493  RETURN
1494  ELSE IF(ytst > 1.d-20) THEN
1495  ym2= y(1)*y(1)+y(2)*y(2)
1496  u1(1)= 1.d0-y(1)/ym2
1497  u1(2)= y(2)/ym2
1498  u2= co-y
1499  ln_y= hto_cqlnx(y)
1500  omy= co-y
1501  ln_omy= hto_cqlnomx(y,omy)
1502  addy(1)= rz3+rz2*ln_y(1)+1.d0/6.d0*ln_y(1)*
1503  # (ln_y(1)*ln_y(1)-3.d0*ln_y(2)*ln_y(2))-
1504  # 0.5d0*ln_omy(1)*(ln_y(1)*ln_y(1)-ln_y(2)*
1505  # ln_y(2))+ln_y(1)*ln_y(2)*ln_omy(2)
1506  addy(2)= rz2*ln_y(2)+1.d0/6.d0*ln_y(2)*(3.d0*
1507  # ln_y(1)*ln_y(1)-ln_y(2)*ln_y(2))-0.5d0*
1508  # ln_omy(2)*(ln_y(1)*ln_y(1)-ln_y(2)*ln_y(2))-
1509  # ln_y(1)*ln_omy(1)*ln_y(2)
1510 *
1511 *-----li_3(1-1/y) is computed
1512 *
1513  omu1= co-u1
1514  par1= hto_cqlnomx(u1,omu1)
1515  pr1= -par1(1)
1516  pj1= -par1(2)
1517  p12= pr1*pr1+pj1*pj1
1518  pm1= sqrt(p12)
1519  ct1(1)= pr1/pm1
1520  sn1(1)= pj1/pm1
1521  DO n=2,15
1522  ct1(n)= ct1(1)*ct1(n-1)-sn1(1)*sn1(n-1)
1523  sn1(n)= sn1(1)*ct1(n-1)+ct1(1)*sn1(n-1)
1524  ENDDO
1525  res1(1)= pm1*(bf(0)*ct1(1)+pm1*(bf(1)*ct1(2)+pm1*
1526  # (bf(2)*ct1(3)+pm1*(bf(3)*ct1(4)+pm1*
1527  # (bf(4)*ct1(5)+pm1*(bf(5)*ct1(6)+pm1*
1528  # (bf(6)*ct1(7)+pm1*(bf(7)*ct1(8)+pm1*
1529  # (bf(8)*ct1(9)+pm1*(bf(9)*ct1(10)+pm1*
1530  # (bf(10)*ct1(11)+pm1*(bf(11)*ct1(12)+pm1*
1531  # (bf(12)*ct1(13)+pm1*(bf(13)*ct1(14)+pm1*
1532  # (bf(14)*ct1(15))))))))))))))))
1533  res1(2)= pm1*(bf(0)*sn1(1)+pm1*(bf(1)*sn1(2)+pm1*
1534  # (bf(2)*sn1(3)+pm1*(bf(3)*sn1(4)+pm1*
1535  # (bf(4)*sn1(5)+pm1*(bf(5)*sn1(6)+pm1*
1536  # (bf(6)*sn1(7)+pm1*(bf(7)*sn1(8)+pm1*
1537  # (bf(8)*sn1(9)+pm1*(bf(9)*sn1(10)+pm1*
1538  # (bf(10)*sn1(11)+pm1*(bf(11)*sn1(12)+pm1*
1539  # (bf(12)*sn1(13)+pm1*(bf(13)*sn1(14)+pm1*
1540  # (bf(14)*sn1(15))))))))))))))))
1541 *
1542 *-----li_3(1-y) is computed
1543 *
1544  omu2= co-u2
1545  par2= hto_cqlnomx(u2,omu2)
1546  pr2= -par2(1)
1547  pj2= -par2(2)
1548  p22= pr2*pr2+pj2*pj2
1549  pm2= sqrt(p22)
1550  ct2(1)= pr2/pm2
1551  sn2(1)= pj2/pm2
1552  DO n=2,15
1553  ct2(n)= ct2(1)*ct2(n-1)-sn2(1)*sn2(n-1)
1554  sn2(n)= sn2(1)*ct2(n-1)+ct2(1)*sn2(n-1)
1555  ENDDO
1556  res2(1)= pm2*(bf(0)*ct2(1)+pm2*(bf(1)*ct2(2)+pm2*
1557  # (bf(2)*ct2(3)+pm2*(bf(3)*ct2(4)+pm2*
1558  # (bf(4)*ct2(5)+pm2*(bf(5)*ct2(6)+pm2*
1559  # (bf(6)*ct2(7)+pm2*(bf(7)*ct2(8)+pm2*
1560  # (bf(8)*ct2(9)+pm2*(bf(9)*ct2(10)+pm2*
1561  # (bf(10)*ct2(11)+pm2*(bf(11)*ct2(12)+pm2*
1562  # (bf(12)*ct2(13)+pm2*(bf(13)*ct2(14)+pm2*
1563  # (bf(14)*ct2(15))))))))))))))))
1564  res2(2)= pm2*(bf(0)*sn2(1)+pm2*(bf(1)*sn2(2)+pm2*
1565  # (bf(2)*sn2(3)+pm2*(bf(3)*sn2(4)+pm2*
1566  # (bf(4)*sn2(5)+pm2*(bf(5)*sn2(6)+pm2*
1567  # (bf(6)*sn2(7)+pm2*(bf(7)*sn2(8)+pm2*
1568  # (bf(8)*sn2(9)+pm2*(bf(9)*sn2(10)+pm2*
1569  # (bf(10)*sn2(11)+pm2*(bf(11)*sn2(12)+pm2*
1570  # (bf(12)*sn2(13)+pm2*(bf(13)*sn2(14)+pm2*
1571  # (bf(14)*sn2(15))))))))))))))))
1572  hto_li3= -res1-res2+addx+addy
1573  RETURN
1574  ENDIF
1575 *
1576 *-----if re(y)<0 a transformation is required in terms of t = -y
1577 * and of t^2
1578 *
1579  ELSE IF(y(1) < 0.d0) THEN
1580 *
1581 *-----first t
1582 *
1583  t= -y
1584  IF(t(1) <= 0.5d0) THEN
1585 *
1586 *-----li_3(t) is computed
1587 *
1588  omt= co-t
1589  par= hto_cqlnomx(t,omt)
1590  pr= -par(1)
1591  pj= -par(2)
1592  p2= pr*pr+pj*pj
1593  pm= sqrt(p2)
1594  ct(1)= pr/pm
1595  sn(1)= pj/pm
1596  DO n=2,15
1597  ct(n)= ct(1)*ct(n-1)-sn(1)*sn(n-1)
1598  sn(n)= sn(1)*ct(n-1)+ct(1)*sn(n-1)
1599  ENDDO
1600  resa(1)= pm*(bf(0)*ct(1)+pm*(bf(1)*ct(2)+pm*
1601  # (bf(2)*ct(3)+pm*(bf(3)*ct(4)+pm*
1602  # (bf(4)*ct(5)+pm*(bf(5)*ct(6)+pm*
1603  # (bf(6)*ct(7)+pm*(bf(7)*ct(8)+pm*
1604  # (bf(8)*ct(9)+pm*(bf(9)*ct(10)+pm*
1605  # (bf(10)*ct(11)+pm*(bf(11)*ct(12)+pm*
1606  # (bf(12)*ct(13)+pm*(bf(13)*ct(14)+pm*
1607  # (bf(14)*ct(15))))))))))))))))
1608  resa(2)= pm*(bf(0)*sn(1)+pm*(bf(1)*sn(2)+pm*
1609  # (bf(2)*sn(3)+pm*(bf(3)*sn(4)+pm*
1610  # (bf(4)*sn(5)+pm*(bf(5)*sn(6)+pm*
1611  # (bf(6)*sn(7)+pm*(bf(7)*sn(8)+pm*
1612  # (bf(8)*sn(9)+pm*(bf(9)*sn(10)+pm*
1613  # (bf(10)*sn(11)+pm*(bf(11)*sn(12)+pm*
1614  # (bf(12)*sn(13)+pm*(bf(13)*sn(14)+pm*
1615  # (bf(14)*sn(15))))))))))))))))
1616  ELSE IF(t(1) > 0.5d0) THEN
1617  tm2= t(1)*t(1)+t(2)*t(2)
1618  u1(1)= 1.d0-t(1)/tm2
1619  u1(2)= t(2)/tm2
1620  u2= co-t
1621  ln_t= hto_cqlnx(t)
1622  omt= co-t
1623  ln_omt= hto_cqlnomx(t,omt)
1624  addt(1)= rz3+rz2*ln_t(1)+1.d0/6.d0*ln_t(1)*
1625  # (ln_t(1)*ln_t(1)-3.d0*ln_t(2)*ln_t(2))-
1626  # 0.5d0*ln_omt(1)*(ln_t(1)*ln_t(1)-ln_t(2)*
1627  # ln_t(2))+ln_t(1)*ln_t(2)*ln_omt(2)
1628  addt(2)= rz2*ln_t(2)+1.d0/6.d0*ln_t(2)*(3.d0*
1629  # ln_t(1)*ln_t(1)-ln_t(2)*ln_t(2))-0.5d0*
1630  # ln_omt(2)*(ln_t(1)*ln_t(1)-ln_t(2)*ln_t(2))-
1631  # ln_t(1)*ln_omt(1)*ln_t(2)
1632 *
1633 *-----li3(1-1/t) is computed
1634 *
1635  omu1= co-u1
1636  par1= hto_cqlnomx(u1,omu1)
1637  pr1= -par1(1)
1638  pj1= -par1(2)
1639  p12= pr1*pr1+pj1*pj1
1640  pm1= sqrt(p12)
1641  ct1(1)= pr1/pm1
1642  sn1(1)= pj1/pm1
1643  DO n=2,15
1644  ct1(n)= ct1(1)*ct1(n-1)-sn1(1)*sn1(n-1)
1645  sn1(n)= sn1(1)*ct1(n-1)+ct1(1)*sn1(n-1)
1646  ENDDO
1647  res1(1)= pm1*(bf(0)*ct1(1)+pm1*(bf(1)*ct1(2)+pm1*
1648  # (bf(2)*ct1(3)+pm1*(bf(3)*ct1(4)+pm1*
1649  # (bf(4)*ct1(5)+pm1*(bf(5)*ct1(6)+pm1*
1650  # (bf(6)*ct1(7)+pm1*(bf(7)*ct1(8)+pm1*
1651  # (bf(8)*ct1(9)+pm1*(bf(9)*ct1(10)+pm1*
1652  # (bf(10)*ct1(11)+pm1*(bf(11)*ct1(12)+pm1*
1653  # (bf(12)*ct1(13)+pm1*(bf(13)*ct1(14)+pm1*
1654  # (bf(14)*ct1(15))))))))))))))))
1655  res1(2)= pm1*(bf(0)*sn1(1)+pm1*(bf(1)*sn1(2)+pm1*
1656  # (bf(2)*sn1(3)+pm1*(bf(3)*sn1(4)+pm1*
1657  # (bf(4)*sn1(5)+pm1*(bf(5)*sn1(6)+pm1*
1658  # (bf(6)*sn1(7)+pm1*(bf(7)*sn1(8)+pm1*
1659  # (bf(8)*sn1(9)+pm1*(bf(9)*sn1(10)+pm1*
1660  # (bf(10)*sn1(11)+pm1*(bf(11)*sn1(12)+pm1*
1661  # (bf(12)*sn1(13)+pm1*(bf(13)*sn1(14)+pm1*
1662  # (bf(14)*sn1(15))))))))))))))))
1663 *
1664 *-----li3(1-t) is computed
1665 *
1666  omu2= co-u2
1667  par2= hto_cqlnomx(u2,omu2)
1668  pr2= -par2(1)
1669  pj2= -par2(2)
1670  p22= pr2*pr2+pj2*pj2
1671  pm2= sqrt(p22)
1672  ct2(1)= pr2/pm2
1673  sn2(1)= pj2/pm2
1674  DO n=2,15
1675  ct2(n)= ct2(1)*ct2(n-1)-sn2(1)*sn2(n-1)
1676  sn2(n)= sn2(1)*ct2(n-1)+ct2(1)*sn2(n-1)
1677  ENDDO
1678  res2(1)= pm2*(bf(0)*ct2(1)+pm2*(bf(1)*ct2(2)+pm2*
1679  # (bf(2)*ct2(3)+pm2*(bf(3)*ct2(4)+pm2*
1680  # (bf(4)*ct2(5)+pm2*(bf(5)*ct2(6)+pm2*
1681  # (bf(6)*ct2(7)+pm2*(bf(7)*ct2(8)+pm2*
1682  # (bf(8)*ct2(9)+pm2*(bf(9)*ct2(10)+pm2*
1683  # (bf(10)*ct2(11)+pm2*(bf(11)*ct2(12)+pm2*
1684  # (bf(12)*ct2(13)+pm2*(bf(13)*ct2(14)+pm2*
1685  # (bf(14)*ct2(15))))))))))))))))
1686  res2(2)= pm2*(bf(0)*sn2(1)+pm2*(bf(1)*sn2(2)+pm2*
1687  # (bf(2)*sn2(3)+pm2*(bf(3)*sn2(4)+pm2*
1688  # (bf(4)*sn2(5)+pm2*(bf(5)*sn2(6)+pm2*
1689  # (bf(6)*sn2(7)+pm2*(bf(7)*sn2(8)+pm2*
1690  # (bf(8)*sn2(9)+pm2*(bf(9)*sn2(10)+pm2*
1691  # (bf(10)*sn2(11)+pm2*(bf(11)*sn2(12)+pm2*
1692  # (bf(12)*sn2(13)+pm2*(bf(13)*sn2(14)+pm2*
1693  # (bf(14)*sn2(15))))))))))))))))
1694  resa= -res1-res2+addt
1695  ENDIF
1696 *
1697 *-----THEN t^2
1698 *
1699  t(1)= y(1)*y(1)-y(2)*y(2)
1700  t(2)= 2.d0*y(1)*y(2)
1701  IF(t(1) <= 0.5d0) THEN
1702 *
1703 *-----li_3(t^2) is computed
1704 *
1705  omt= co-t
1706  par= hto_cqlnomx(t,omt)
1707  pr= -par(1)
1708  pj= -par(2)
1709  p2= pr*pr+pj*pj
1710  pm= sqrt(p2)
1711  ct(1)= pr/pm
1712  sn(1)= pj/pm
1713  DO n=2,15
1714  ct(n)= ct(1)*ct(n-1)-sn(1)*sn(n-1)
1715  sn(n)= sn(1)*ct(n-1)+ct(1)*sn(n-1)
1716  ENDDO
1717  resb(1)= pm*(bf(0)*ct(1)+pm*(bf(1)*ct(2)+pm*
1718  # (bf(2)*ct(3)+pm*(bf(3)*ct(4)+pm*
1719  # (bf(4)*ct(5)+pm*(bf(5)*ct(6)+pm*
1720  # (bf(6)*ct(7)+pm*(bf(7)*ct(8)+pm*
1721  # (bf(8)*ct(9)+pm*(bf(9)*ct(10)+pm*
1722  # (bf(10)*ct(11)+pm*(bf(11)*ct(12)+pm*
1723  # (bf(12)*ct(13)+pm*(bf(13)*ct(14)+pm*
1724  # (bf(14)*ct(15))))))))))))))))
1725  resb(2)= pm*(bf(0)*sn(1)+pm*(bf(1)*sn(2)+pm*
1726  # (bf(2)*sn(3)+pm*(bf(3)*sn(4)+pm*
1727  # (bf(4)*sn(5)+pm*(bf(5)*sn(6)+pm*
1728  # (bf(6)*sn(7)+pm*(bf(7)*sn(8)+pm*
1729  # (bf(8)*sn(9)+pm*(bf(9)*sn(10)+pm*
1730  # (bf(10)*sn(11)+pm*(bf(11)*sn(12)+pm*
1731  # (bf(12)*sn(13)+pm*(bf(13)*sn(14)+pm*
1732  # (bf(14)*sn(15))))))))))))))))
1733  ELSE IF(t(1) > 0.5d0) THEN
1734  tm2= t(1)*t(1)+t(2)*t(2)
1735  u1(1)= 1.d0-t(1)/tm2
1736  u1(2)= t(2)/tm2
1737  u2= co-t
1738  ln_t= hto_cqlnx(t)
1739  omt= co-t
1740  ln_omt= hto_cqlnomx(t,omt)
1741  addt2(1)= rz3+rz2*ln_t(1)+1.d0/6.d0*ln_t(1)*
1742  # (ln_t(1)*ln_t(1)-3.d0*ln_t(2)*ln_t(2))-
1743  # 0.5d0*ln_omt(1)*(ln_t(1)*ln_t(1)-ln_t(2)*
1744  # ln_t(2))+ln_t(1)*ln_t(2)*ln_omt(2)
1745  addt2(2)= rz2*ln_t(2)+1.d0/6.d0*ln_t(2)*(3.d0*
1746  # ln_t(1)*ln_t(1)-ln_t(2)*ln_t(2))-0.5d0*
1747  # ln_omt(2)*(ln_t(1)*ln_t(1)-ln_t(2)*ln_t(2))-
1748  # ln_t(1)*ln_omt(1)*ln_t(2)
1749 *
1750 *-----li_3(1-1/t^2) is computed
1751 *
1752  omu1= co-u1
1753  par1= hto_cqlnomx(u1,omu1)
1754  pr1= -par1(1)
1755  pj1= -par1(2)
1756  p12= pr1*pr1+pj1*pj1
1757  pm1= sqrt(p12)
1758  ct1(1)= pr1/pm1
1759  sn1(1)= pj1/pm1
1760  DO n=2,15
1761  ct1(n)= ct1(1)*ct1(n-1)-sn1(1)*sn1(n-1)
1762  sn1(n)= sn1(1)*ct1(n-1)+ct1(1)*sn1(n-1)
1763  ENDDO
1764  res3(1)= pm1*(bf(0)*ct1(1)+pm1*(bf(1)*ct1(2)+pm1*
1765  # (bf(2)*ct1(3)+pm1*(bf(3)*ct1(4)+pm1*
1766  # (bf(4)*ct1(5)+pm1*(bf(5)*ct1(6)+pm1*
1767  # (bf(6)*ct1(7)+pm1*(bf(7)*ct1(8)+pm1*
1768  # (bf(8)*ct1(9)+pm1*(bf(9)*ct1(10)+pm1*
1769  # (bf(10)*ct1(11)+pm1*(bf(11)*ct1(12)+pm1*
1770  # (bf(12)*ct1(13)+pm1*(bf(13)*ct1(14)+pm1*
1771  # (bf(14)*ct1(15))))))))))))))))
1772  res3(2)= pm1*(bf(0)*sn1(1)+pm1*(bf(1)*sn1(2)+pm1*
1773  # (bf(2)*sn1(3)+pm1*(bf(3)*sn1(4)+pm1*
1774  # (bf(4)*sn1(5)+pm1*(bf(5)*sn1(6)+pm1*
1775  # (bf(6)*sn1(7)+pm1*(bf(7)*sn1(8)+pm1*
1776  # (bf(8)*sn1(9)+pm1*(bf(9)*sn1(10)+pm1*
1777  # (bf(10)*sn1(11)+pm1*(bf(11)*sn1(12)+pm1*
1778  # (bf(12)*sn1(13)+pm1*(bf(13)*sn1(14)+pm1*
1779  # (bf(14)*sn1(15))))))))))))))))
1780 *
1781 *-----li_3(1-t^2) is computed
1782 *
1783  omu2= co-u2
1784  par2= hto_cqlnomx(u2,omu2)
1785  pr2= -par2(1)
1786  pj2= -par2(2)
1787  p22= pr2*pr2+pj2*pj2
1788  pm2= sqrt(p22)
1789  ct2(1)= pr2/pm2
1790  sn2(1)= pj2/pm2
1791  DO n=2,15
1792  ct2(n)= ct2(1)*ct2(n-1)-sn2(1)*sn2(n-1)
1793  sn2(n)= sn2(1)*ct2(n-1)+ct2(1)*sn2(n-1)
1794  ENDDO
1795  res4(1)= pm2*(bf(0)*ct2(1)+pm2*(bf(1)*ct2(2)+pm2*
1796  # (bf(2)*ct2(3)+pm2*(bf(3)*ct2(4)+pm2*
1797  # (bf(4)*ct2(5)+pm2*(bf(5)*ct2(6)+pm2*
1798  # (bf(6)*ct2(7)+pm2*(bf(7)*ct2(8)+pm2*
1799  # (bf(8)*ct2(9)+pm2*(bf(9)*ct2(10)+pm2*
1800  # (bf(10)*ct2(11)+pm2*(bf(11)*ct2(12)+pm2*
1801  # (bf(12)*ct2(13)+pm2*(bf(13)*ct2(14)+pm2*
1802  # (bf(14)*ct2(15))))))))))))))))
1803  res4(2)= pm2*(bf(0)*sn2(1)+pm2*(bf(1)*sn2(2)+pm2*
1804  # (bf(2)*sn2(3)+pm2*(bf(3)*sn2(4)+pm2*
1805  # (bf(4)*sn2(5)+pm2*(bf(5)*sn2(6)+pm2*
1806  # (bf(6)*sn2(7)+pm2*(bf(7)*sn2(8)+pm2*
1807  # (bf(8)*sn2(9)+pm2*(bf(9)*sn2(10)+pm2*
1808  # (bf(10)*sn2(11)+pm2*(bf(11)*sn2(12)+pm2*
1809  # (bf(12)*sn2(13)+pm2*(bf(13)*sn2(14)+pm2*
1810  # (bf(14)*sn2(15))))))))))))))))
1811  resb= -res3-res4+addt2
1812  ENDIF
1813  hto_li3= -resa+0.25d0*resb+addx
1814  RETURN
1815  ENDIF
1816 *
1817  END FUNCTION hto_li3
1818 *
1819 *-----------------------------------------------------------------------------------------
1820 *
1821  SUBROUTINE hto_init_niels
1822  USE hto_common_niels
1823 *
1824  plr= 0.d0
1825 *
1826  plr(1,1)= 1.d0
1827  plr(1,2)= -2.5d-1
1828  plr(1,3)= 2.77777777777777777d-2
1829  plr(1,5)= -2.77777777777777777d-4
1830  plr(1,7)= 4.72411186696900982d-6
1831  plr(1,9)= -9.18577307466196355d-8
1832  plr(1,11)= 1.89788699889709990d-9
1833  plr(1,13)= -4.06476164514422552d-11
1834  plr(1,15)= 8.92169102045645255d-13
1835 *
1836  plr(2,1)= 1.d0
1837  plr(2,2)= -3.75d-1
1838  plr(2,3)= 7.87037037037037037d-2
1839  plr(2,4)= -8.68055555555555555d-3
1840  plr(2,5)= 1.29629629629629629d-4
1841  plr(2,6)= 8.10185185185185185d-5
1842  plr(2,7)= -3.41935716085375949d-6
1843  plr(2,8)= -1.32865646258503401d-6
1844  plr(2,9)= 8.66087175610985134d-8
1845  plr(2,10)= 2.52608759553203997d-8
1846  plr(2,11)= -2.14469446836406476d-9
1847  plr(2,12)= -5.14011062201297891d-10
1848  plr(2,13)= 5.24958211460082943d-11
1849  plr(2,14)= 1.08877544066363183d-11
1850  plr(2,15)= -1.27793960944936953d-12
1851 *
1852  plr(3,2)= 2.5d-1
1853  plr(3,3)= -8.33333333333333333d-2
1854  plr(3,4)= 1.04166666666666666d-2
1855  plr(3,6)= -1.15740740740740740d-4
1856  plr(3,8)= 2.06679894179894179d-6
1857  plr(3,10)= -4.13359788359788359d-8
1858  plr(3,12)= 8.69864874494504124d-10
1859  plr(3,14)= -1.88721076381696185d-11
1860 *
1861  plr_4= 0.d0
1862 *
1863  plr_4(1,1)= 1.d0
1864  plr_4(1,2)= -4.375d-1
1865  plr_4(1,3)= 1.16512345679012345d-1
1866  plr_4(1,4)= -1.98206018518518518d-2
1867  plr_4(1,5)= 1.92793209876543209d-3
1868  plr_4(1,6)= -3.10570987654320987d-5
1869  plr_4(1,7)= -1.56240091148578352d-5
1870  plr_4(1,8)= 8.48512354677320663d-7
1871  plr_4(1,9)= 2.29096166031897114d-7
1872  plr_4(1,10)= -2.18326142185269169d-8
1873  plr_4(1,11)= -3.88282487917201557d-9
1874  plr_4(1,12)= 5.44629210322033211d-10
1875  plr_4(1,13)= 6.96080521068272540d-11
1876  plr_4(1,14)= -1.33757376864452151d-11
1877  plr_4(1,15)= -1.27848526852665716d-12
1878 *
1879  plr_4(2,2)= 2.5d-1
1880  plr_4(2,3)= -1.25d-1
1881  plr_4(2,4)= 2.95138888888888888d-2
1882  plr_4(2,5)= -3.47222222222222222d-3
1883  plr_4(2,6)= 5.40123456790123456d-5
1884  plr_4(2,7)= 3.47222222222222222d-5
1885  plr_4(2,8)= -1.49596875787351977d-6
1886  plr_4(2,9)= -5.90513983371126228d-7
1887  plr_4(2,10)= 3.89739229024943310d-8
1888  plr_4(2,11)= 1.14822163433274544d-8
1889  plr_4(2,12)= -9.82984964666863015d-10
1890  plr_4(2,13)= -2.37235874862137488d-10
1891  plr_4(2,14)= 2.43730598177895652d-11
1892  plr_4(2,15)= 5.08095205643028190d-12
1893 *
1894  plr_4(3,2)= 5.55555555555555555d-2
1895  plr_4(3,3)= -2.08333333333333333d-2
1896  plr_4(3,4)= 2.77777777777777777d-3
1897  plr_4(3,6)= -3.30687830687830687d-5
1898  plr_4(3,8)= 6.12384871644130903d-7
1899  plr_4(3,10)= -1.25260541927208593d-8
1900  plr_4(3,12)= 2.67650730613693576d-10
1901  plr_4(3,14)= -5.87132237631943687d-12
1902 *
1903  RETURN
1904 *
1905  END SUBROUTINE hto_init_niels
1906 *
1907 *-----CQLNX---------------------------------------------
1908 *
1909 *--- Computes ln(z)
1910 *
1911  FUNCTION hto_cqlnx(arg) RESULT(res)
1912  USE hto_riemann
1913  USE hto_units
1914  IMPLICIT NONE
1915 *
1916  real*8 teta,zm,zm2,tnteta,sr,si
1917  real*8, dimension(2) :: arg,aarg,res
1918  INTENT(IN) arg
1919 *
1920  IF((abs(arg(2))-eps).eq.0.d0) THEN
1921  res(1)= log(abs(arg(1)))
1922  IF(arg(1) > 0.d0) THEN
1923  res(2)= 0.d0
1924  ELSE
1925  res(2)= pi*sign(one,arg(2))
1926  ENDIF
1927  RETURN
1928  ENDIF
1929 *
1930  aarg= abs(arg)
1931  zm2= (arg(1))**2+(arg(2))**2
1932  zm= sqrt(zm2)
1933  res(1)= log(zm)
1934  IF(arg(1).eq.0.d0) THEN
1935  IF(arg(2) > 0.d0) THEN
1936  teta= pi/2.d0
1937  ELSE
1938  teta= -pi/2.d0
1939  ENDIF
1940  res(2)= teta
1941  RETURN
1942  ELSE IF(arg(2).eq.0.d0) THEN
1943  IF(arg(1) > 0.d0) THEN
1944  teta= 0.d0
1945  ELSE
1946  teta= pi
1947  ENDIF
1948  res(2)= teta
1949  RETURN
1950  ELSE
1951  tnteta= aarg(2)/aarg(1)
1952  teta= atan(tnteta)
1953  sr= arg(1)/aarg(1)
1954  si= arg(2)/aarg(2)
1955  IF(sr > 0.d0) THEN
1956  res(2)= si*teta
1957  ELSE
1958  res(2)= si*(pi-teta)
1959  ENDIF
1960  RETURN
1961  ENDIF
1962 *
1963  END FUNCTION hto_cqlnx
1964 *
1965 *-----HTO_cqlnomx---------------------------------------
1966 *
1967 *--- Computes ln(1-x), usually |x| << 1
1968 *
1969  FUNCTION hto_cqlnomx(arg,omarg) RESULT(res)
1970 *
1971  IMPLICIT NONE
1972 *
1973  INTEGER n,k
1974  real*8 zr,zi,zm2,zm
1975  real*8, dimension(2) :: arg,omarg,res,ares
1976  real*8, dimension(10) :: ct,sn
1977  INTENT(IN) arg,omarg
1978 *
1979  zr= arg(1)
1980  zi= arg(2)
1981  zm2= zr*zr+zi*zi
1982  zm= sqrt(zm2)
1983  IF(zm < 1.d-7) THEN
1984  ct(1)= zr/zm
1985  sn(1)= zi/zm
1986  DO n=2,10
1987  ct(n)= ct(1)*ct(n-1)-sn(1)*sn(n-1)
1988  sn(n)= sn(1)*ct(n-1)+ct(1)*sn(n-1)
1989  ENDDO
1990  ares(1)= ct(10)/10.d0
1991  ares(2)= sn(10)/10.d0
1992  DO k=9,1,-1
1993  ares(1)= ares(1)*zm+ct(k)/k
1994  ares(2)= ares(2)*zm+sn(k)/k
1995  ENDDO
1996  ares(1)= -ares(1)*zm
1997  ares(2)= -ares(2)*zm
1998  ELSE
1999  ares= hto_cqlnx(omarg)
2000  ENDIF
2001  res= ares
2002 *
2003  RETURN
2004 *
2005  END FUNCTION hto_cqlnomx
2006 *
2007  END MODULE hto_sp_fun
2008 *
2009 *-----------------------------------------------------------------------
2010 *-- Comments to Graeme Watt <watt(at)hep.ucl.ac.uk>
2011 *----------------------------------------------------------------------
2012 *-- from Andreas Vogt's QCD-PEGASUS package (hep-ph/0408244).
2013 *-- The running coupling alpha_s is obtained at N^mLO (m = 0,1,2,3)
2014 *-- by solving the renormalisation group equation in the MSbar scheme
2015 *-- by a fourth-order Runge-Kutta integration. Transitions from
2016 *-- n_f to n_f+1 flavours are made when the factorisation scale
2017 *-- mu_f equals the pole masses m_h (h = c,b,t). At exactly
2018 *-- the thresholds m_{c,b,t}, the number of flavours n_f = {3,4,5}.
2019 *-- The top quark mass should be set to be very large to evolve with
2020 *-- a maximum of five flavours. The factorisation scale mu_f may be
2021 *-- a constant multiple of the renormalisation scale mu_r. The input
2022 *-- factorisation scale mu_(f,0) should be less than or equal to
2023 *-- the charm quark mass. However, if it is greater than the
2024 *-- charm quark mass, the value of alpha_s at mu_(f,0) = 1 GeV will
2025 *-- be found using a root-finding algorithm.
2026 *--
2027 *-- Example of usage.
2028 *-- First call the initialisation routine (only needed once):
2029 *--
2030 *-- IORD = 2 ! perturbative order (N^mLO,m=0,1,2,3)
2031 *-- FR2 = 1.d0 ! ratio of mu_f^2 to mu_r^2
2032 *-- MUR = 1.d0 ! input mu_r in GeV
2033 *-- ASMUR = 0.5d0 ! input value of alpha_s at mu_r
2034 *-- MC = 1.4d0 ! charm quark mass
2035 *-- MB = 4.75d0 ! bottom quark mass
2036 *-- MT = 1.D10 ! top quark mass
2037 *-- CALL HTO_INITALPHAS(IORD, FR2, MUR, ASMUR, MC, MB, MT)
2038 *--
2039 *-- Then get alpha_s at a renormalisation scale mu_r with:
2040 *--
2041 *-- MUR = 100.d0 ! renormalisation scale in GeV
2042 *-- ALFAS = HTO_ALPHAS(MUR)
2043 *--
2044 *
2045  MODULE hto_dzpar
2046  INTEGER iordc
2047  real*8 fr2c,murc,asmurc,mcc,mbc,mtc,r0c
2048  END MODULE hto_dzpar
2049 *
2050 * MODULE HTO_DZEROX
2051 * INTEGER IORD
2052 * REAL*8 FR2,MUR,ASMUR,MC,MB,MT,R0
2053 * END MODULE HTO_DZEROX
2054 *
2055  MODULE hto_rzeta
2056  real*8, dimension(6) :: zeta
2057  END MODULE hto_rzeta
2058  MODULE hto_colour
2059  real*8 cf, ca, tr
2060  END MODULE hto_colour
2061  MODULE hto_asinp
2062  real*8 as0, m20
2063  END MODULE hto_asinp
2064  MODULE hto_aspar
2065  INTEGER naord, nastps
2066  END MODULE hto_aspar
2067  MODULE hto_varflv
2068  INTEGER ivfns
2069  END MODULE hto_varflv
2070  MODULE hto_nffix
2071  INTEGER nff
2072  END MODULE hto_nffix
2073  MODULE hto_frrat
2074  real*8 logfr
2075  END MODULE hto_frrat
2076  MODULE hto_asfthr
2077  real*8 asc,m2c,asb,m2b,ast,m2t
2078  END MODULE hto_asfthr
2079  MODULE hto_betacom
2080  real*8, dimension(3:6) :: beta0,beta1,beta2,beta3
2081  END MODULE hto_betacom
2082 *
2083 * MODULE HTO_nmlo_alphas
2084 * CONTAINS
2085 *
2086 *-----------------------------------------------------------------------
2087 *
2088  SUBROUTINE hto_initalphas(IORD, FR2, MUR, ASMUR, MC, MB, MT)
2089  USE hto_dzpar
2090 *
2091 
2092 *-- IORD = 0 (LO), 1 (NLO), 2 (NNLO), 3 (NNNLO).
2093 *-- FR2 = ratio of mu_f^2 to mu_r^2 (must be a fixed value).
2094 *-- MUR = input renormalisation scale (in GeV) for alpha_s.
2095 *-- ASMUR = input value of alpha_s at the renormalisation scale MUR.
2096 *-- MC,MB,MT = heavy quark masses in GeV.
2097 *
2098  IMPLICIT NONE
2099 *
2100  INTEGER IORD
2101  real*8 fr2,mur,asmur,mc,mb,mt,a,b,hto_dzero,
2102  # hto_findalphasr0,r0,asi
2103  real*8, parameter :: eps=1.d-10
2104  INTEGER, parameter :: MAXF=10000
2105  INTEGER, parameter :: MODE=1
2106  EXTERNAL hto_findalphasr0
2107 
2108  IF(mur*sqrt(fr2).LE.mc) THEN ! Check that MUF <= MC.
2109  r0 = mur
2110  asi = asmur
2111  ELSE ! Solve for alpha_s at R0 = 1 GeV.
2112 *
2113 *-- Copy variables to common block.
2114 *
2115  r0c = 1.d0/sqrt(fr2)
2116  iordc = iord
2117  fr2c = fr2
2118  murc = mur
2119  asmurc = asmur
2120  mcc = mc
2121  mbc = mb
2122  mtc = mt
2123 *
2124 *-- Now get alpha_s(R0) corresponding to alpha_s(MUR).
2125 *
2126  a = 0.02d0 ! lower bound for alpha_s(R0)
2127  b = 2.00d0 ! upper bound for alpha_s(R0)
2128  r0 = r0c
2129  asi = hto_dzero(a,b,eps,maxf,hto_findalphasr0,mode)
2130  ENDIF
2131 
2132  CALL hto_initalphasr0(iord,fr2,r0,asi,mc,mb,mt)
2133 
2134  RETURN
2135  END SUBROUTINE hto_initalphas
2136 *
2137 *----------------------------------------------------------------------
2138 *
2139 *-- Find the zero of this function using HTO_DZEROX.
2140 *
2141  FUNCTION hto_findalphasr0(ASI)
2142  USE hto_dzpar
2143 *
2144  IMPLICIT NONE
2145 *
2146  real*8 hto_alphas,hto_findalphasr0,asi
2147 *
2148  CALL hto_initalphasr0(iordc,fr2c,r0c,asi,mcc,mbc,mtc)
2149 *
2150  hto_findalphasr0 = hto_alphas(murc) - asmurc ! solve equal to zero
2151 
2152 
2153  RETURN
2154  END FUNCTION hto_findalphasr0
2155 *
2156 *----------------------------------------------------------------------
2157 *
2158  SUBROUTINE hto_initalphasr0(IORD,FR2,R0,ASI,MC,MB,MT)
2159  USE hto_rzeta
2160  USE hto_colour
2161  USE hto_asinp
2162  USE hto_aspar
2163  USE hto_varflv
2164  USE hto_nffix
2165  USE hto_frrat
2166 *
2167 *-- IORD = 0 (LO), 1 (NLO), 2 (NNLO), 3 (NNNLO).
2168 *-- FR2 = ratio of mu_f^2 to mu_r^2 (must be a fixed value).
2169 *-- R0 = input renormalisation scale (in GeV) for alphas_s.
2170 *-- ASI = input value of alpha_s at the renormalisation scale R0.
2171 *-- MC,MB,MT = heavy quark masses in GeV.
2172 *-- Must have R0*sqrt(FR2) <= MC to call this subroutine.
2173 *
2174  IMPLICIT NONE
2175 *
2176  INTEGER IORD
2177  real*8 fr2,r0,asi,mc,mb,mt,r20,mc2,mb2,mt2
2178  real*8, parameter :: pi= 3.14159265358979d0
2179 *
2180 * ..QCD colour factors
2181 *
2182  ca = 3.d0
2183  cf = 4.d0/3.d0
2184  tr = 0.5 d0
2185 *
2186 * ..The lowest integer values of the Zeta function
2187 *
2188  zeta(1) = 0.5772 15664 90153 d0
2189  zeta(2) = 1.64493 40668 48226 d0
2190  zeta(3) = 1.20205 69031 59594 d0
2191  zeta(4) = 1.08232 32337 11138 d0
2192  zeta(5) = 1.03692 77551 43370 d0
2193  zeta(6) = 1.01734 30619 84449 d0
2194 
2195  ivfns = 1 ! variable flavour-number scheme (VFNS)
2196 C IVFNS = 0 ! fixed flavour-number scheme (FFNS)
2197  nff = 4 ! number of flavours for FFNS
2198  naord = iord ! perturbative order of alpha_s
2199  nastps = 20 ! num. steps in Runge-Kutta integration
2200  r20 = r0**2 ! input renormalisation scale
2201  mc2 = mc**2 ! mu_f^2 for charm threshold
2202  mb2 = mb**2 ! mu_f^2 for bottom threshold
2203  mt2 = mt**2 ! mu_f^2 for top threshold
2204  logfr = log(fr2) ! log of ratio of mu_f^2 to mu_r^2
2205  m20 = r20 * fr2 ! input factorisation scale
2206 
2207 *
2208 * ..Stop some nonsense
2209 *
2210  IF( (ivfns .EQ. 0) .AND. (nff .LT. 3) ) THEN
2211  print*, 'Wrong flavour number for FFNS evolution. STOP'
2212  stop
2213  ENDIF
2214  IF( (ivfns .EQ. 0) .AND. (nff .GT. 5) ) THEN
2215  print*, 'Wrong flavour number for FFNS evolution. STOP'
2216  stop
2217  ENDIF
2218 *
2219  IF( naord .GT. 3 ) THEN
2220  print*, 'Specified order in a_s too high. STOP'
2221  stop
2222  ENDIF
2223 *
2224  IF( (ivfns .NE. 0) .AND. (fr2 .GT. 4.001d0) ) THEN
2225  print*, 'Too low mu_r for VFNS evolution. STOP'
2226  stop
2227  ENDIF
2228 *
2229  IF( (ivfns .EQ. 1) .AND. (m20 .GT. mc2) ) THEN
2230  print*, 'Too high mu_0 for VFNS evolution. STOP'
2231  stop
2232  ENDIF
2233 *
2234  IF( (asi .GT. 2.d0) .OR. (asi .LT. 2.d-2) ) THEN
2235  print*, 'alpha_s out of range. STOP'
2236  stop
2237  ENDIF
2238 *
2239  IF( (ivfns .EQ. 1) .AND. (mc2 .GT. mb2) ) THEN
2240  print*, 'Wrong charm-bottom mass hierarchy. STOP'
2241  stop
2242  ENDIF
2243  IF( (ivfns .EQ. 1) .AND. (mb2 .GT. mt2) ) THEN
2244  print*, 'Wrong bottom-top mass hierarchy. STOP'
2245  stop
2246  ENDIF
2247 *
2248 *
2249 *-- Store the beta function coefficients in a COMMON block.
2250 *
2251  CALL hto_betafct
2252 *
2253 *-- Store a_s = alpha_s(mu_r^2)/(4 pi) at the input scale R0.
2254 *
2255  as0 = asi / (4.d0* pi)
2256 *
2257 *-- Store alpha_s at the heavy flavour thresholds in a COMMON block.
2258 *
2259  IF(ivfns .NE. 0) THEN
2260  CALL hto_evnfthr(mc2,mb2,mt2)
2261  ENDIF
2262 
2263  RETURN
2264  END SUBROUTINE hto_initalphasr0
2265 *
2266 *----------------------------------------------------------------------
2267 *
2268  FUNCTION hto_alphas(MUR)
2269  USE hto_nffix
2270  USE hto_varflv
2271  USE hto_frrat
2272  USE hto_asinp
2273  USE hto_asfthr
2274 *
2275  IMPLICIT NONE
2276  INTEGER nf
2277 * REAL*8 M2,MUR,R2,ASI,ASF,R20,R2T,R2B,R2C,AS,HTO_ALPHAS
2278  real*8 m2,mur,r2,asi,asf,r20,r2t,r2b,r2c,hto_alphas
2279  real*8, parameter :: pi= 3.1415 9265358979d0
2280 *
2281  INTERFACE
2282  FUNCTION hto_as(R2,R20,AS0,NF)
2283  USE hto_aspar
2284  USE hto_betacom
2285  IMPLICIT NONE
2286  INTEGER nf
2287  real*8 r2,r20,as0,hto_as
2288  END FUNCTION hto_as
2289  END INTERFACE
2290 *
2291 * ..Input common blocks
2292 *
2293 
2294  r2 = mur**2
2295  m2 = r2 * exp(+logfr)
2296  IF(ivfns .EQ. 0) THEN
2297 *
2298 * Fixed number of flavours
2299 *
2300  nf = nff
2301  r20 = m20 * r2/m2
2302  asi = as0
2303  asf = hto_as(r2,r20,as0,nf)
2304 *
2305  ELSE
2306 *
2307 * ..Variable number of flavours
2308 *
2309  IF(m2 .GT. m2t) THEN
2310  nf = 6
2311  r2t = m2t * r2/m2
2312  asi = ast
2313  asf = hto_as(r2,r2t,ast,nf)
2314 *
2315  ELSE IF(m2 .GT. m2b) THEN
2316  nf = 5
2317  r2b = m2b * r2/m2
2318  asi = asb
2319  asf = hto_as(r2,r2b,asb,nf)
2320 *
2321  ELSE IF(m2 .GT. m2c) THEN
2322  nf = 4
2323  r2c = m2c * r2/m2
2324  asi = asc
2325  asf = hto_as(r2,r2c,asc,nf)
2326 *
2327  ELSE
2328  nf = 3
2329  r20 = m20 * r2/m2
2330  asi = as0
2331  asf = hto_as(r2,r20,as0,nf)
2332 *
2333  ENDIF
2334 *
2335  ENDIF
2336 *
2337 * ..Final value of alpha_s
2338 *
2339  hto_alphas = 4.d0*pi*asf
2340 *
2341  RETURN
2342  END FUNCTION hto_alphas
2343 *
2344 * =================================================================av==
2345 
2346 
2347 * =====================================================================
2348 *
2349 * ..The threshold matching of the QCD coupling in the MS(bar) scheme,
2350 * a_s = alpha_s(mu_r^2)/(4 pi), for NF -> NF + 1 active flavours
2351 * up to order a_s^4 (NNNLO).
2352 *
2353 * ..The value ASNF of a_s for NF flavours at the matching scale, the
2354 * logarithm LOGRH = ln (mu_r^2/m_H^2) -- where m_H is the pole mass
2355 * of the heavy quark -- and NF are passed as arguments to the
2356 * function HTO_ASNF1. The order of the expansion NAORD (defined as
2357 * the 'n' in N^nLO) is provided by the common-block ASPAR.
2358 *
2359 * ..The matching coefficients are inverted from Chetyrkin, Kniehl and
2360 * Steinhauser, Phys. Rev. Lett. 79 (1997) 2184. The QCD colour
2361 * factors have been hard-wired in these results. The lowest integer
2362 * values of the Zeta function are given by the common-block RZETA.
2363 *
2364 * =====================================================================
2365 *
2366 *
2367  FUNCTION hto_asnf1(ASNF,LOGRH,NF)
2368  USE hto_aspar
2369  USE hto_rzeta
2370 *
2371  IMPLICIT NONE
2372  INTEGER nf,prvcll,k1,k2
2373  real*8 asnf,logrh,cmci30,cmcf30,cmcf31,
2374  # cmci31,asp,lrhp,hto_asnf1
2375  real*8, dimension(3,0:3) :: cmc
2376 **
2377 * ---------------------------------------------------------------------
2378 *
2379 * ..Input common-blocks
2380 *
2381 * ..Variables to be saved for the next call
2382 *
2383  SAVE cmc,cmci30,cmcf30,cmcf31,cmci31,prvcll
2384 *
2385 * ---------------------------------------------------------------------
2386 *
2387 * ..The coupling-constant matching coefficients (CMC's) up to NNNLO
2388 * (calculated and saved in the first call of this routine)
2389 *
2390  IF(prvcll .NE. 1) THEN
2391 *
2392  cmc(1,0) = 0.d0
2393  cmc(1,1) = 2.d0/3.d0
2394 *
2395  cmc(2,0) = 14.d0/3.d0
2396  cmc(2,1) = 38.d0/3.d0
2397  cmc(2,2) = 4.d0/9.d0
2398 *
2399  cmci30 = + 80507.d0/432.d0 * zeta(3) + 58933.d0/1944.d0
2400  # + 128.d0/3.d0 * zeta(2) * (1.+ dlog(2.d0)/3.d0)
2401  cmcf30 = - 64.d0/9.d0 * (zeta(2) + 2479.d0/3456.d0)
2402  cmci31 = 8941.d0/27.d0
2403  cmcf31 = - 409.d0/27.d0
2404  cmc(3,2) = 511.d0/9.d0
2405  cmc(3,3) = 8.d0/27.d0
2406 *
2407  prvcll = 1
2408 *
2409  ENDIF
2410 *
2411 * ---------------------------------------------------------------------
2412 *
2413 * ..The N_f dependent CMC's, and the alpha_s matching at order NAORD
2414 *
2415  cmc(3,0) = cmci30 + nf * cmcf30
2416  cmc(3,1) = cmci31 + nf * cmcf31
2417 *
2418  hto_asnf1 = asnf
2419  IF(naord .EQ. 0) GO TO 1
2420  asp = asnf
2421 *
2422  DO k1 = 1,naord
2423  asp = asp * asnf
2424  lrhp = 1.d0
2425  DO k2 = 0,k1
2426  hto_asnf1 = hto_asnf1 + asp * cmc(k1,k2) * lrhp
2427  lrhp = lrhp * logrh
2428  ENDDO
2429  ENDDO
2430 *
2431  1 RETURN
2432 *
2433  END FUNCTION hto_asnf1
2434 *
2435 * =================================================================av==
2436 *
2437 * ..The subroutine EVNFTHR for the evolution of a_s = alpha_s/(4 pi)
2438 * from a three-flavour initial scale to the four- to six-flavour
2439 * thresholds (identified with the squares of the corresponding quark
2440 * masses). The results are written to the common-block ASFTHR.
2441 *
2442 * ..The input scale M20 = mu_(f,0)^2 and the corresponding value
2443 * AS0 of a_s are provided by ASINP. The fixed scale logarithm
2444 * LOGFR = ln (mu_f^2/mu_r^2) is specified in FRRAT. The alpha_s
2445 * matching is done by the function HTO_ASNF1.
2446 *
2447 * =====================================================================
2448 *
2449 *
2450  SUBROUTINE hto_evnfthr(MC2,MB2,MT2)
2451  USE hto_asinp
2452  USE hto_frrat
2453  USE hto_asfthr
2454 *
2455  IMPLICIT NONE
2456  real*8 mc2,mb2,mt2,r20,r2c,r2b,r2t,hto_as,hto_asnf1,
2457  # asc3,asb4,ast5,sc,sb,st
2458 *
2459 * ---------------------------------------------------------------------
2460 *
2461 * ..Input common blocks
2462 *
2463 *
2464 * ..Output common blocks
2465 *
2466 
2467 * ---------------------------------------------------------------------
2468 *
2469 * ..Coupling constants at and evolution distances to/between thresholds
2470 *
2471  r20 = m20 * exp(-logfr)
2472 *
2473 * ..Charm
2474 *
2475  m2c = mc2
2476  r2c = m2c * r20/m20
2477  asc3 = hto_as(r2c,r20,as0,3)
2478  sc = log(as0 / asc3)
2479  asc = hto_asnf1(asc3,-logfr,3)
2480 *
2481 * ..Bottom
2482 *
2483  m2b = mb2
2484  r2b = m2b * r20/m20
2485  asb4 = hto_as(r2b,r2c,asc,4)
2486  sb = log(asc / asb4)
2487  asb = hto_asnf1(asb4,-logfr,4)
2488 *
2489 * ..Top
2490 *
2491  m2t = mt2
2492  r2t = m2t * r20/m20
2493  ast5 = hto_as(r2t,r2b,asb,5)
2494  st = log(asb / ast5)
2495  ast = hto_asnf1(ast5,-logfr,5)
2496 
2497  RETURN
2498  END SUBROUTINE hto_evnfthr
2499 *
2500 * =================================================================av==
2501 *
2502 * ..The running coupling of QCD,
2503 *
2504 * AS = a_s = alpha_s(mu_r^2)/(4 pi),
2505 *
2506 * obtained by integrating the evolution equation for a fixed number
2507 * of massless flavours NF. Except at leading order (LO), AS is
2508 * obtained using a fourth-order Runge-Kutta integration.
2509 *
2510 * ..The initial and final scales R20 and R2, the value AS0 at
2511 * R20, and NF are passed as function arguments. The coefficients
2512 * of the beta function up to a_s^5 (N^3LO) are provided by the
2513 * common-block BETACOM. The order of the expansion NAORD (defined
2514 * as the 'n' in N^nLO) and the number of steps NASTPS for the
2515 * integration beyond LO are given by the common-block ASPAR.
2516 *
2517 * =====================================================================
2518 *
2519 *
2520  FUNCTION hto_as(R2, R20,AS0,NF)
2521  USE hto_aspar
2522  USE hto_betacom
2523 *
2524  IMPLICIT NONE
2525  INTEGER nf,k1
2526  real*8 r2,r20,as0,as1,as2,as3,as4,fbeta1,fbeta2,fbeta3,fbeta4,a,
2527  # lrrat,dlr,xk0,xk1,xk2,xk3,hto_as
2528  INTEGER, parameter :: nfmin =3
2529  INTEGER, parameter :: nfmax =6
2530  real*8, parameter :: sxth =0.166666666666666d0
2531 *
2532 * ---------------------------------------------------------------------
2533 *
2534 * ..Input common-blocks
2535 *
2536 *
2537 * ..The beta functions FBETAn at N^nLO for n = 1, 2, and 3
2538 *
2539 *
2540 * ---------------------------------------------------------------------
2541 *
2542 * ..Initial value, evolution distance and step size
2543 *
2544  hto_as = as0
2545  lrrat = log(r2/r20)
2546  dlr = lrrat / nastps
2547 *
2548 * ..Solution of the evolution equation depending on NAORD
2549 * (fourth-order Runge-Kutta beyond the leading order)
2550 *
2551  IF(naord .EQ. 0) THEN
2552 *
2553  hto_as = as0 / (1.+ beta0(nf) * as0 * lrrat)
2554 *
2555  ELSE IF(naord .EQ. 1) THEN
2556 *
2557  DO k1 = 1,nastps
2558  as1= hto_as
2559  fbeta1= - as1**2 * ( beta0(nf) + as1 * beta1(nf) )
2560  xk0 = dlr * fbeta1
2561  as2= hto_as + 0.5d0 * xk0
2562  fbeta2= - as2**2 * ( beta0(nf) + as2 * beta1(nf) )
2563  xk1 = dlr * fbeta2
2564  as3= hto_as + 0.5d0 * xk1
2565  fbeta3= - as3**2 * ( beta0(nf) + as3 * beta1(nf) )
2566  xk2 = dlr * fbeta3
2567  as4= hto_as + xk2
2568  fbeta4= - as4**2 * ( beta0(nf) + as4 * beta1(nf) )
2569  xk3 = dlr * fbeta4
2570  hto_as = hto_as + sxth * (xk0 + 2.d0* xk1 + 2.d0* xk2 + xk3)
2571  ENDDO
2572 *
2573  ELSE IF(naord .EQ. 2) THEN
2574 *
2575  DO k1 = 1,nastps
2576  as1= hto_as
2577  fbeta1= - as1**2 * ( beta0(nf) + as1 * ( beta1(nf)
2578  # + as1 * beta2(nf) ) )
2579  xk0 = dlr * fbeta1
2580  as2= hto_as + 0.5d0 * xk0
2581  fbeta2= - as2**2 * ( beta0(nf) + as2 * ( beta1(nf)
2582  # + as2 * beta2(nf) ) )
2583  xk1 = dlr * fbeta2
2584  as3= hto_as + 0.5d0 * xk1
2585  fbeta3= - as3**2 * ( beta0(nf) + as3 * ( beta1(nf)
2586  # + as3 * beta2(nf) ) )
2587  xk2 = dlr * fbeta3
2588  as4= hto_as + xk2
2589  fbeta4= - as4**2 * ( beta0(nf) + as4 * ( beta1(nf)
2590  # + as4 * beta2(nf) ) )
2591  xk3 = dlr * fbeta4
2592  hto_as = hto_as + sxth * (xk0 + 2.d0* xk1 + 2.d0* xk2 + xk3)
2593  ENDDO
2594 *
2595  ELSE IF(naord .EQ. 3) THEN
2596 *
2597  DO k1 = 1,nastps
2598  as1= hto_as
2599  fbeta1= - as1**2 * ( beta0(nf) + as1 * ( beta1(nf)
2600  # + as1 * (beta2(nf) + as1 * beta3(nf)) ) )
2601  xk0 = dlr * fbeta1
2602  as2= hto_as + 0.5d0 * xk0
2603  fbeta2= - as2**2 * ( beta0(nf) + as2 * ( beta1(nf)
2604  # + as2 * (beta2(nf) + as2 * beta3(nf)) ) )
2605  xk1 = dlr * fbeta2
2606  as3= hto_as + 0.5d0 * xk1
2607  fbeta3= - as3**2 * ( beta0(nf) + as3 * ( beta1(nf)
2608  # + as3 * (beta2(nf) + as3 * beta3(nf)) ) )
2609  xk2 = dlr * fbeta3
2610  as4= hto_as + xk2
2611  fbeta4= - as4**2 * ( beta0(nf) + as4 * ( beta1(nf)
2612  # + as4 * (beta2(nf) + as4 * beta3(nf)) ) )
2613  xk3 = dlr * fbeta4
2614  hto_as = hto_as + sxth * (xk0 + 2.d0* xk1 + 2.d0* xk2 + xk3)
2615  ENDDO
2616 *
2617  ENDIF
2618 *
2619 * ---------------------------------------------------------------------
2620 *
2621  RETURN
2622  END FUNCTION hto_as
2623 *
2624 * =================================================================av==
2625 *
2626 * ..The subroutine BETAFCT for the coefficients BETA0...BETA3 of the
2627 * beta function of QCD up to order alpha_s^5 (N^3LO), normalized by
2628 *
2629 * d a_s / d ln mu_r^2 = - BETA0 a_s^2 - BETA1 a_s^3 - ...
2630 *
2631 * with a_s = alpha_s/(4*pi).
2632 *
2633 * ..The MSbar coefficients are written to the common-block BETACOM for
2634 * NF = 3...6 (parameters NFMIN, NFMAX) quark flavours.
2635 *
2636 * ..The factors CF, CA and TF are taken from the common-block COLOUR.
2637 * Beyond NLO the QCD colour factors are hard-wired in this routine,
2638 * and the numerical coefficients are truncated to six digits.
2639 *
2640 * =====================================================================
2641 *
2642 *
2643  SUBROUTINE hto_betafct
2644  USE hto_colour
2645  USE hto_betacom
2646 *
2647  IMPLICIT NONE
2648  INTEGER NF
2649  real*8 b00,b01,b10,b11
2650  INTEGER, parameter :: NFMIN=3
2651  INTEGER, parameter :: NFMAX=6
2652 *
2653 * ---------------------------------------------------------------------
2654 *
2655 * ..The full LO and NLO coefficients
2656 *
2657  b00 = 11.d0/3.d0 * ca
2658  b01 = -4.d0/3.d0 * tr
2659  b10 = 34.d0/3.d0 * ca**2
2660  b11 = -20.d0/3.d0 * ca*tr - 4.* cf*tr
2661 *
2662 * ..Flavour-number loop and output to the array
2663 *
2664  DO nf = nfmin,nfmax
2665 *
2666  beta0(nf) = b00 + b01 * nf
2667  beta1(nf) = b10 + b11 * nf
2668 *
2669  beta2(nf) = 1428.50d0 - 279.611d0 * nf + 6.01852d0 * nf**2
2670  beta3(nf) = 29243.0d0 - 6946.30d0 * nf + 405.089d0 * nf**2
2671  # + 1.49931d0 * nf**3
2672  ENDDO
2673 
2674 *
2675  RETURN
2676  END SUBROUTINE hto_betafct
2677 *
2678 * =================================================================av==
2679 *
2680 *-- G.W. HTO_DZEROX taken from CERNLIB to find the zero of a function.
2681 *
2682  FUNCTION hto_dzero(A0,B0,EPS,MAXF,F,MODE)
2683  IMPLICIT REAL*8 (a-h,o-z)
2684 C Based on
2685 C
2686 C J.C.P. Bus and T.J. Dekker, Two Efficient Algorithms with
2687 C Guaranteed Convergence for Finding a Zero of a Function,
2688 C ACM Trans. Math. Software 1 (1975) 330-345.
2689 C
2690 C (MODE = 1: Algorithm M; MODE = 2: Algorithm R)
2691 *
2692 * CHARACTER*80 ERRTXT
2693  real*8 hto_dzero
2694  LOGICAL lmt
2695  dimension im1(2),im2(2),lmt(2)
2696  parameter(z1 = 1, half = z1/2)
2697  DATA im1 /2,3/, im2 /-1,3/
2698 *
2699  hto_dzero = 0.d0 ! G.W. to prevent compiler warning
2700  IF(mode .NE. 1 .AND. mode .NE. 2) THEN
2701  c=0
2702 * WRITE(ERRTXT,101) MODE
2703  print 101,mode
2704 * WRITE(6,*) ERRTXT
2705  GO TO 99
2706  ENDIF
2707  fa=f(b0)
2708  fb=f(a0)
2709  IF(fa*fb .GT. 0) THEN
2710  c=0
2711 * WRITE(ERRTXT,102) A0,B0
2712  print 102,a0,b0
2713 * WRITE(6,*) ERRTXT
2714  GO TO 99
2715  ENDIF
2716  atl=abs(eps)
2717  b=a0
2718  a=b0
2719  lmt(2)=.true.
2720  mf=2
2721  1 c=a
2722  fc=fa
2723  2 ie=0
2724  3 IF(abs(fc) .LT. abs(fb)) THEN
2725  IF(c .NE. a) THEN
2726  d=a
2727  fd=fa
2728  ENDIF
2729  a=b
2730  b=c
2731  c=a
2732  fa=fb
2733  fb=fc
2734  fc=fa
2735  ENDIF
2736  tol=atl*(1+abs(c))
2737  h=half*(c+b)
2738  hb=h-b
2739  IF(abs(hb) .GT. tol) THEN
2740  IF(ie .GT. im1(mode)) THEN
2741  w=hb
2742  ELSE
2743  tol=tol*sign(z1,hb)
2744  p=(b-a)*fb
2745  lmt(1)=ie .LE. 1
2746  IF(lmt(mode)) THEN
2747  q=fa-fb
2748  lmt(2)=.false.
2749  ELSE
2750  fdb=(fd-fb)/(d-b)
2751  fda=(fd-fa)/(d-a)
2752  p=fda*p
2753  q=fdb*fa-fda*fb
2754  ENDIF
2755  IF(p .LT. 0) THEN
2756  p=-p
2757  q=-q
2758  ENDIF
2759  IF(ie .EQ. im2(mode)) p=p+p
2760  IF(p .EQ. 0 .OR. p .LE. q*tol) THEN
2761  w=tol
2762  ELSEIF(p .LT. hb*q) THEN
2763  w=p/q
2764  ELSE
2765  w=hb
2766  ENDIF
2767  ENDIF
2768  d=a
2769  a=b
2770  fd=fa
2771  fa=fb
2772  b=b+w
2773  mf=mf+1
2774  IF(mf .GT. maxf) THEN
2775 * WRITE(6,*) "Error in HTO_DZERO: TOO MANY FUNCTION CALLS"
2776  print*,"Error in HTO_DZERO: TOO MANY FUNCTION CALLS"
2777  GO TO 99
2778  ENDIF
2779  fb=f(b)
2780  IF(fb .EQ. 0 .OR. sign(z1,fc) .EQ. sign(z1,fb)) GO TO 1
2781  IF(w .EQ. hb) GO TO 2
2782  ie=ie+1
2783  GO TO 3
2784  ENDIF
2785  hto_dzero=c
2786  99 CONTINUE
2787  RETURN
2788  101 FORMAT('Error in DZERO: MODE = ',i3,' ILLEGAL')
2789  102 FORMAT('Error in DZERO: F(A) AND F(B) HAVE THE SAME SIGN, A = ',
2790  1 1p,d15.8,', B = ',d15.8)
2791 *
2792  END FUNCTION hto_dzero
2793 *
2794 *------------------------------------------------------------------
2795 *
2796  MODULE hto_olas
2797  CONTAINS
2798 *
2799  FUNCTION hto_b0af_em(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
2800  USE hto_acmplx_pro
2801  USE hto_acmplx_rat
2802  USE hto_cmplx_root
2803  USE hto_cmplx_rootz
2804  USE hto_ln_2_riemann
2805  USE hto_full_ln
2806  USE hto_units
2807 *
2808  IMPLICIT NONE
2809 *
2810  real*8 scal,ps0i,xm0i,scals,ps0,xm0
2811  real*8, dimension(2) :: value,psi,ps,xmsi,xms,betasc,betas,
2812  # betac,beta,argc,arg,lbet
2813 *
2814  scals= scal*scal
2815  ps= psi/scals
2816  ps0= ps0i/scals
2817  xms= xmsi/scals
2818  xm0= xm0i/scal
2819 *
2820  betasc= co-4.d0*(xms.cq.ps)
2821  IF(betasc(2).eq.0.d0) THEN
2822  betasc(2)= -eps
2823  betac= (betasc(1)).cr.(betasc(2))
2824  ELSE
2825  betac= (betasc(1)).crz.(betasc(2))
2826  ENDIF
2827  argc= (betac+co).cq.(betac-co)
2828  IF(argc(2).eq.0.d0) THEN
2829  argc(2)= eps
2830  lbet= argc(1).fln.argc(2)
2831  ELSE
2832  betas(1)= 1.d0-4.d0*(xm0*xm0)/ps0
2833  betas(2)= -eps
2834  beta= (betas(1)).cr.(betas(2))
2835  arg= (beta+co).cq.(beta-co)
2836  IF(arg(2).eq.0.d0) arg(2)= eps
2837  lbet= argc.lnsrs.arg
2838  ENDIF
2839 *
2840  value= 2.d0*co-(betac.cp.lbet)
2841 *
2842  RETURN
2843 *
2844  END FUNCTION hto_b0af_em
2845 *
2846  END MODULE hto_olas
2847 *
2848 *--------------------------------------------------------------------------
2849 *
2850  FUNCTION hto_quarkqcd(scal,psi,ps0i,xmsi,xm0i,type) RESULT(value)
2851  USE hto_riemann
2852  USE hto_acmplx_pro
2853  USE hto_acmplx_rat
2854  USE hto_cmplx_root
2855  USE hto_cmplx_rootz
2856  USE hto_cmplx_srs_root
2857  USE hto_ln_2_riemann
2858  USE hto_full_ln
2859  USE hto_sp_fun
2860  USE hto_units
2861 *
2862  IMPLICIT NONE
2863 *
2864  INTEGER it,type,unit
2865  real*8 scal,ps0i,xm0i,scals,ps0,xm0,sgn
2866  real*8, dimension(2) :: value,psi,ps,xmsi,xms,betasc,betas,
2867  # betac,beta,argc,arg,lq,lm,cx,comx,cxs,x,omx,xs,clx,clomx,
2868  # clxs,li2cx,li3cx,li2cxs,li3cxs,copx,clopx,lqs,qcd,lms,
2869  # opx,tau,taus,clxx,clxxs
2870  real*8, dimension(6,2) :: aux,auxs
2871 *
2872  scals= scal*scal
2873  ps= psi/scals
2874  ps0= ps0i/scals
2875  xms= xmsi/scals
2876  xm0= xm0i/scal
2877 *
2878  IF(psi(2).eq.0.d0.and.xmsi(2).eq.0.d0.
2879  # and.psi(1).le.4.d0*xmsi(1)) THEN
2880  unit= 1
2881  ELSE
2882  unit= 0
2883  ENDIF
2884 *
2885  IF(abs(ps(2)/ps(1)).lt.1.d-10.and.xms(2).eq.0.d0) THEN
2886  betasc(1)= 1.d0-4.d0*xms(1)/ps(1)
2887  betasc(2)= 4.d0/(ps(1)*ps(1))*xms(1)*ps(2)
2888  ELSE
2889  betasc= co-4.d0*(xms.cq.ps)
2890  ENDIF
2891  IF(betasc(2).eq.0.d0) THEN
2892  betasc(2)= -eps
2893  betac= (betasc(1)).cr.(betasc(2))
2894  ELSE
2895  betac= (betasc(1)).crz.(betasc(2))
2896  ENDIF
2897  argc= (betac+co).cq.(betac-co)
2898 *
2899  betas(1)= 1.d0-4.d0*xm0*xm0/ps0
2900  betas(2)= -eps
2901  beta= (betas(1)).cr.(betas(2))
2902  arg= (beta+co).cq.(beta-co)
2903 *
2904  IF(arg(2).eq.0.d0) THEN
2905  x(1)= 1.d0/arg(1)
2906  x(2)= -eps
2907  sgn= sign(one,x(1))
2908  xs(1)= x(1)*x(1)
2909  xs(2)= -sgn*eps
2910  ELSE
2911  x= (beta-co).cq.(beta+co)
2912  xs= x.cp.x
2913  ENDIF
2914  omx= co-x
2915  opx= co+x
2916 *
2917  IF(arg(2).eq.0.d0) arg(2)= eps
2918  IF(argc(2).eq.0.d0) THEN
2919  it= 0
2920  argc(2)= eps
2921  lq= argc(1).fln.argc(2)
2922  ELSE
2923  it= 1
2924  lq= argc.lnsrs.arg
2925  ENDIF
2926  lqs= lq.cp.lq
2927 *
2928  IF(it.eq.0.d0) THEN
2929  cx(1)= 1.d0/argc(1)
2930  cx(2)= -eps
2931  comx= co-cx
2932  copx= co+cx
2933  sgn= sign(one,cx(1))
2934  cxs(1)= cx(1)*cx(1)
2935  cxs(2)= -sgn*eps
2936  clx= cx(1).fln.cx(2)
2937  clxs= clx.cp.clx
2938  clxx= cxs(1).fln.cxs(2)
2939  clxxs= clxx.cp.clxx
2940  clomx= comx(1).fln.comx(2)
2941  clopx= copx(1).fln.copx(2)
2942  aux= hto_s_niels_up4(cx)
2943  li2cx(1:2)= aux(1,1:2)
2944  li3cx(1:2)= aux(2,1:2)
2945  auxs= hto_s_niels_up4(cxs)
2946  li2cxs(1:2)= auxs(1,1:2)
2947  li3cxs(1:2)= auxs(2,1:2)
2948  ELSEIF(it.eq.1.d0) THEN
2949  cx= (betac-co).cq.(betac+co)
2950  comx= co-cx
2951  copx= co+cx
2952  cxs= cx.cp.cx
2953  clx= cx.lnsrs.x
2954  clxs= clx.cp.clx
2955  clxx= cxs.lnsrs.xs
2956  clxxs= clxx.cp.clxx
2957  clomx= comx.lnsrs.omx
2958  clopx= copx.lnsrs.opx
2959  li2cx= hto_li2_srsz(cx,x,unit)
2960  li3cx= hto_li3_srsz(cx,x,unit)
2961  li2cxs= hto_li2_srsz(cxs,xs,unit)
2962  li3cxs= hto_li3_srsz(cxs,xs,unit)
2963  ENDIF
2964 *
2965  IF(xms(2).eq.0.d0) THEN
2966  lm(1)= log(xms(1))
2967  lm(2)= 0.d0
2968  ELSE
2969  lm= xms(1).fln.xms(2)
2970  ENDIF
2971  lms= lm.cp.lm
2972 *
2973  tau= xms.cq.ps
2974  taus= tau.cp.tau
2975 *
2976  IF(type.eq.0) THEN
2977 *
2978  qcd= -3.d0/4.d0*(co-12.d0*tau)*rz2
2979  # +1.d0/16.d0*(3.d0*co+344.d0*tau)
2980  # -3.d0/2.d0*((co-6.d0*tau).cp.lms)
2981  # +3.d0/4.d0*((3.d0*co-14.d0*tau).cp.(betac.cp.clx))
2982  # -3.d0*((li3cxs-2.d0*li3cx+4.d0/3.d0*(li2cx.cp.clx)
2983  # +1.d0/3.d0*(clxs.cp.clomx)+rz3*co
2984  # -2.d0/3.d0*(clxx.cp.li2cxs)-1.d0/6.d0*(clxxs.cp.clomx)
2985  # -1.d0/6.d0*
2986  # (clxxs.cp.clopx)).cp.((co-4.d0*tau).cp.(co-2.d0*tau)))
2987  # -1.d0/2.d0*((4.d0*li2cxs-4.d0*li2cx-4.d0*(clomx.cp.clx)
2988  # -2.d0*(cx.cp.(clxs.cq.comx))+4.d0*(clxx.cp.clomx)
2989  # +4.d0*(clxx.cp.clopx)+(clxxs.cp.(cxs.cq.comx))
2990  # +(clxxs.cp.(cxs.cq.copx))).cp.(betac.cp.(co-4.d0*tau)))
2991  # +1.d0/4.d0*(lm.cp.(11.d0*co-108.d0*tau))
2992  # +1.d0/4.d0*(clxs.cp.(3.d0*co+58.d0*taus-28.d0*tau))
2993 *
2994  ELSEIF(type.eq.1) THEN
2995 *
2996  qcd= -3.d0/4.d0*(co-12.d0*tau)*rz2
2997  # +1.d0/16.d0*(67.d0*co-40.d0*tau)
2998  # +3.d0/4.d0*((3.d0*co-14.d0*tau).cp.(betac.cp.clx))
2999  # -3.d0*((li3cxs-2.d0*li3cx+4.d0/3.d0*(li2cx.cp.clx)
3000  # +1.d0/3.d0*(clxs.cp.clomx)+rz3*co
3001  # -2.d0/3.d0*(clxx.cp.li2cxs)-1.d0/6.d0*(clxxs.cp.clomx)
3002  # -1.d0/6.d0*
3003  # (clxxs.cp.clopx)).cp.((co-4.d0*tau).cp.(co-2.d0*tau)))
3004  # -1.d0/2.d0*((4.d0*li2cxs-4.d0*li2cx-4.d0*(clomx.cp.clx)
3005  # -2.d0*(cx.cp.(clxs.cq.comx))+4.d0*(clxx.cp.clomx)
3006  # +4.d0*(clxx.cp.clopx)+(clxxs.cp.(cxs.cq.comx))
3007  # +(clxxs.cp.(cxs.cq.copx))).cp.(betac.cp.(co-4.d0*tau)))
3008  # -2.d0*
3009  # (((co-8.d0*tau).cp.(betac.cp.lq)).cp.(co-3.d0/4.d0*lm))
3010  # -3.d0*((betac.cp.lq).cp.(lm.cp.tau))
3011  # +4.d0*((co.cp.betac).cp.(lq.cp.tau))
3012  # -9.d0/4.d0*(lm.cp.(co+4.d0*tau))
3013  # +9.d0*(lms.cp.tau)
3014  # +1.d0/4.d0*(clxs.cp.(3.d0*co+58.d0*taus-28.d0*tau))
3015 *
3016  ENDIF
3017 *
3018  value= qcd
3019 *
3020  RETURN
3021 *
3022  END FUNCTION hto_quarkqcd
3023 *
3024 *------------------------------------------------------------------
3025 *
3026 *-----------------------------------------------------------------------------------------
3027 *
3028 *-----------------------------------------------------------------------------------------
3029 *
3030 *
3031  MODULE hto_qcd
3032  CONTAINS
3033 *
3034  FUNCTION hto_ralphas(rs0,rs,als)
3035  USE hto_riemann
3036  USE hto_masses
3037  IMPLICIT NONE
3038  INTEGER i,nfe
3039  real*8 hto_ralphas,rs0,rs,als,x1,x2,xacc,qcdl,rat,rl,rll,rb,fac,
3040  # facp,rhs,ratl2,pqcdl4,qcdb0,qcdb1,qcdb2,qcda,pqcdl3,
3041  # fac2,pqcdl5
3042  real*8, dimension(5) :: b0,b1,b2
3043  INTEGER, parameter :: nf=5
3044 *
3045 *-----limits for lambda_5 are 1 mev < lambda_5 < 10 gev
3046 *
3047  IF(als.eq.0.d0) THEN
3048  hto_ralphas= 0.d0
3049  ELSE
3050  x1= 0.001d0
3051  x2= 10.0d0
3052  xacc= 1.d-12
3053  qcdl= hto_qcdlam(nf,als,rs0,x1,x2,xacc)
3054  pqcdl5= qcdl
3055  DO i=1,5
3056  b0(i)= (11.d0-2.d0/3.d0*i)/4.d0
3057  b1(i)= (102.d0-38.d0/3.d0*i)/16.d0
3058  b2(i)= 0.5d0*(2857.d0-i*(5033.d0/9.d0-325.d0/27.d0*i))/64.d0
3059  ENDDO
3060 *
3061  IF(rs < mbq) THEN
3062  rat= mbq/qcdl
3063  rl= 2.d0*log(rat)
3064  rll= log(rl)
3065  rb= log(b0(5)/b0(4))
3066  fac= b1(5)/b0(5)-b1(4)/b0(4)
3067  facp= b2(5)/b0(5)-b2(4)/b0(4)
3068  fac2= b1(5)*b1(5)/b0(5)/b0(5)-b1(4)*b1(4)/b0(4)/b0(4)
3069  rhs= (b0(5)-b0(4))*rl+fac*rll-b1(4)/b0(4)*rb+
3070  # b1(5)/b0(5)/b0(5)*fac*rll/rl+1.d0/b0(5)/rl*(
3071  # fac2-facp-7.d0/72.d0)
3072  rhs= rhs/b0(4)
3073  ratl2= exp(rhs)
3074  qcdl= qcdl/sqrt(ratl2)
3075  pqcdl4= qcdl
3076  nfe= nf-1
3077  IF(rs < mcq) THEN
3078  rat= mcq/qcdl
3079  rl= 2.d0*log(rat)
3080  rll= log(rl)
3081  rb= log(b0(4)/b0(3))
3082  fac= b1(4)/b0(4)-b1(3)/b0(3)
3083  facp= b2(4)/b0(4)-b2(3)/b0(3)
3084  fac2= b1(4)*b1(4)/b0(4)/b0(4)-b1(3)*b1(3)/b0(3)/b0(3)
3085  rhs= (b0(4)-b0(3))*rl+fac*rll-b1(3)/b0(3)*rb+
3086  # b1(4)/b0(4)/b0(4)*fac*rll/rl+1.d0/b0(4)/rl*(
3087  # fac2-facp-7.d0/72.d0)
3088  rhs= rhs/b0(3)
3089  ratl2= exp(rhs)
3090  qcdl= qcdl/sqrt(ratl2)
3091  pqcdl3= qcdl
3092  nfe= nf-2
3093  ENDIF
3094  ELSE
3095  nfe= nf
3096  ENDIF
3097 *
3098  qcdb0= 11.d0-2.d0/3.d0*nfe
3099  qcdb1= 102.d0-38.d0/3.d0*nfe
3100  qcdb2= 0.5d0*(2857.d0-5033.d0/9.d0*nfe+325.d0/27.d0*nfe*nfe)
3101  qcda= 2.d0*log(rs/qcdl)
3102 *
3103  hto_ralphas= 4.d0*pi/qcdb0/qcda*(1.d0-qcdb1/qcdb0**2/qcda*
3104  # log(qcda)+(qcdb1/qcdb0**2/qcda)**2*((log(qcda)-
3105  # 0.5d0)**2+qcdb2*qcdb0/qcdb1**2-5.d0/4.d0))
3106 *
3107  ENDIF
3108  RETURN
3109  END FUNCTION hto_ralphas
3110 *
3111 *---------------------------------------------------------------------------
3112 *
3113  FUNCTION hto_qcdlam(nf,als,rs,x1,x2,xacc)
3114  IMPLICIT NONE
3115  INTEGER nf,j
3116  real*8 hto_qcdlam,als,rs,x1,x2,xacc,fmid,f,dx,xmid
3117  INTEGER, parameter :: jmax=50
3118 *
3119  fmid= hto_qcdscale(nf,als,rs,x2)
3120  f= hto_qcdscale(nf,als,rs,x1)
3121  IF(f*fmid >= 0.d0) stop
3122  IF(f < 0.d0) THEN
3123  hto_qcdlam= x1
3124  dx= x2-x1
3125  ELSE
3126  hto_qcdlam= x2
3127  dx= x1-x2
3128  ENDIF
3129  DO j=1,jmax
3130  dx= dx*0.5d0
3131  xmid= hto_qcdlam+dx
3132  fmid= hto_qcdscale(nf,als,rs,xmid)
3133  IF(fmid <= 0.d0) hto_qcdlam= xmid
3134  IF(abs(dx) < xacc.or.fmid.eq.0.d0) RETURN
3135  ENDDO
3136  END FUNCTION hto_qcdlam
3137 *
3138  FUNCTION hto_qcdscale(nf,als,rs,x)
3139  USE hto_riemann
3140  IMPLICIT NONE
3141  INTEGER nf
3142  real*8 als,rs,x,qcdb0,qcdb1,qcdb2,qcda,hto_qcdscale
3143 *
3144  qcdb0= 11.d0-2.d0/3.d0*nf
3145  qcdb1= 102.d0-38.d0/3.d0*nf
3146  qcdb2= 0.5d0*(2857.d0-5033.d0/9.d0*nf+325.d0/27.d0*nf*nf)
3147  qcda= 2.d0*log(rs/x)
3148  hto_qcdscale= als-(4.d0*pi/qcdb0/qcda*(1.d0-qcdb1/qcdb0**2/qcda*
3149  # log(qcda)+(qcdb1/qcdb0**2/qcda)**2*((log(qcda)-
3150  # 0.5d0)**2+qcdb2*qcdb0/qcdb1**2-5.d0/4.d0)))
3151  RETURN
3152  END FUNCTION hto_qcdscale
3153 *
3154 *--------------------------------------------------------------------
3155 *
3156  FUNCTION hto_run_bc(scal) RESULT(value)
3157  USE hto_riemann
3158  USE hto_masses
3159  USE hto_set_phys_const
3160 *
3161  IMPLICIT NONE
3162 *
3163  real*8 scal,scal2,alsr,aexps,scaling1g,als1g,alsc4,alsc42,
3164  # als1g2,alsb,alsb2,alsz,alsz2,fn,b03,b13,b23,g03,g13,
3165  # g23,rex3,b03s,b03c,b13s,sm1g,cfm13,cfm23,rmsc,
3166  # b04,b04c,b14,b24,g04,g14,g24,rex4,b04s,b14s,asldf,cfm14,
3167  # cfm24,rsmb,zero,x1,x2,xacc,cmm4,cmb,b05,b15,b25,g05,g15,
3168  # g25,rex5,b05s,b05c,b15s,cfm15,cfm25,rcqm,bmm5,rbqm,scal1g,
3169  # rsmc
3170  real*8, dimension(2) :: value
3171 *
3172  scal2= scal*scal
3173  alsr= hto_ralphas(mz,scal,als)
3174  aexps= alsr/pi
3175 *
3176 *-----COMPUTES THE RUNNING CHARM MASS
3177 *
3178  scal1g= 1.d0
3179  als1g= hto_ralphas(mz,scal1g,als)/pi
3180  alsc4= hto_ralphas(mz,mcq,als)/pi
3181  alsc42= alsc4*alsc4
3182  als1g2= als1g*als1g
3183  alsb= hto_ralphas(mz,mbq,als)/pi
3184  alsb2= alsb*alsb
3185  alsz= hto_ralphas(mz,scal,als)/pi
3186  alsz2= alsz*alsz
3187 *
3188 *-----FIRST THE RUNNING OF THE S-QUARK MASS
3189 * UP TO C/B-THRESHOLD
3190 *
3191  fn= 3.d0
3192  b03= (11.d0-2.d0/3.d0*fn)/4.d0
3193  b13= (102.d0-38.d0/3.d0*fn)/16.d0
3194  b23= (2857.d0/2.d0-5033.d0/18.d0*fn+325.d0/54.d0*fn*fn)/64.d0
3195  g03= 1.d0
3196  g13= (202.d0/3.d0-20.d0/9.d0*fn)/16.d0
3197  g23= (1249.d0-(2216.d0/27.d0+160.d0/3.d0*rz3)*fn-
3198  # 140.d0/81.d0*fn*fn)/64.d0
3199  rex3= g03/b03
3200  b03s= b03*b03
3201  b03c= b03s*b03
3202  b13s= b13*b13
3203  sm1g= 0.189d0
3204  asldf= alsc4-als1g
3205  cfm13= g13/b03-b13*g03/b03s
3206  cfm23= g23/b03-b13*g13/b03s-b23*g03/b03s+b13s*g03/b03c
3207  rsmc= sm1g*(alsc4/als1g)**rex3*(1.d0+cfm13*
3208  # asldf+0.5d0*cfm13*cfm13*asldf*asldf+0.5d0*cfm23*
3209  # (alsc42-als1g2))
3210 *
3211  fn= 4.d0
3212  b04= (11.d0-2.d0/3.d0*fn)/4.d0
3213  b14= (102.d0-38.d0/3.d0*fn)/16.d0
3214  b24= (2857.d0/2.d0-5033.d0/18.d0*fn+325.d0/54.d0*fn*fn)/64.d0
3215  g04= 1.d0
3216  g14= (202.d0/3.d0-20.d0/9.d0*fn)/16.d0
3217  g24= (1249.d0-(2216.d0/27.d0+160.d0/3.d0*rz3)*fn-
3218  # 140.d0/81.d0*fn*fn)/64.d0
3219  rex4= g04/b04
3220  b04s= b04*b04
3221  b04c= b04s*b04
3222  b14s= b14*b14
3223  asldf= alsb-alsc4
3224  cfm14= g14/b04-b14*g04/b04s
3225  cfm24= g24/b04-b14*g14/b04s-b24*g04/b04s+
3226  # b14s*g04/b04c
3227  rsmb= rsmc*(alsb/alsc4)**rex4*(1.d0+cfm14*
3228  # asldf+0.5d0*cfm14*cfm14*asldf*asldf+0.5d0*cfm24*
3229  # (alsb2-alsc42))
3230 *
3231 *-----C QUARK mASS AT C-THRESHOLD
3232 *
3233  zero= 0.d0
3234  x1= 0.5d0
3235  x2= 2.0d0
3236  xacc= 1.d-12
3237  fn= 4.d0
3238  cmm4= hto_rrunm(x1,x2,xacc,mcq,alsc4,rsmc,zero,fn)
3239 *
3240 *-----C QUARK MASS AT B-THRESHOLD
3241 *
3242  cmb= cmm4*(alsb/alsc4)**rex4*(1.d0+cfm14*
3243  # (alsb-alsc4)+0.5d0*cfm14*cfm14*
3244  # (alsb-alsc4)**2+0.5d0*cfm24*(alsb2-alsc42))
3245 *
3246 *-----RUNNING CHARM MASS
3247 *
3248  fn= 5.d0
3249  b05= (11.d0-2.d0/3.d0*fn)/4.d0
3250  b15= (102.d0-38.d0/3.d0*fn)/16.d0
3251  b25= (2857.d0/2.d0-5033.d0/18.d0*fn+325.d0/54.d0*fn*fn)/64.d0
3252  g05= 1.d0
3253  g15= (202.d0/3.d0-20.d0/9.d0*fn)/16.d0
3254  g25= (1249.d0-(2216.d0/27.d0+160.d0/3.d0*rz3)*fn-
3255  # 140.d0/81.d0*fn*fn)/64.d0
3256  rex5= g05/b05
3257  b05s= b05*b05
3258  b05c= b05s*b05
3259  b15s= b15*b15
3260  cfm15= g15/b05-b15*g05/b05s
3261  cfm25= g25/b05-b15*g15/b05s-b25*g05/b05s+b15s*g05/b05c
3262  rcqm= cmb*(alsz/alsb)**rex5*(1.d0+cfm15*
3263  # (alsz-alsb)+0.5d0*cfm15*cfm15*
3264  # (alsz-alsb)**2+0.5d0*cfm25*(alsz2-alsb2))
3265 *
3266 *-----B QUARK MASS AT B-THRESHOLD
3267 *
3268  x1= 0.5d0
3269  x2= 6.0d0
3270  xacc= 1.d-12
3271  fn= 5.d0
3272  bmm5= hto_rrunm(x1,x2,xacc,mbq,alsb,cmb,rsmb,fn)
3273 *
3274 *-----RUNNINg B MASS
3275 *
3276  asldf= alsz-alsb
3277  rbqm= bmm5*(alsz/alsb)**rex5*(1.d0+cfm15*
3278  # asldf+0.5d0*cfm15*cfm15*asldf*asldf+0.5d0*cfm25*
3279  # (alsz2-alsb2))
3280 *
3281  value(1)= rcqm
3282  value(2)= rbqm
3283 *
3284  RETURN
3285  END FUNCTION hto_run_bc
3286 *
3287 *
3288 *-----RRUNM--------------------------------------------------------
3289 * COMPUTES THE RUNNING QUARK MASS AT THE POLE MASS
3290 *
3291  FUNCTION hto_rrunm(x1,x2,xacc,qm,als,rm1,rm2,fn)
3292  IMPLICIT NONE
3293 *
3294  INTEGER, parameter :: jmax=50
3295  INTEGER j
3296  real*8 hto_rrunm,x1,x2,xacc,qm,als,rm1,rm2,fn,fmid,f,dx,xmid
3297 *
3298  fmid= hto_qcdmass(qm,als,rm1,rm2,fn,x2)
3299  f= hto_qcdmass(qm,als,rm1,rm2,fn,x1)
3300  IF(f*fmid.ge.0.d0) then
3301  print*,'root must be bracketed for bisection'
3302  print 1,qm
3303  1 format(/' error detected by HTO_rrunm ',/
3304  # ' current value of quark mass = ',e20.5)
3305 * STOP ! MARKUS NOTE: Removed this stop. Hence, the program keeps running even if there are errors!
3306  ENDIF
3307  IF(f < 0.d0) then
3308  hto_rrunm= x1
3309  dx= x2-x1
3310  ELSE
3311  hto_rrunm= x2
3312  dx= x1-x2
3313  ENDIF
3314  DO j=1,jmax
3315  dx= dx*0.5d0
3316  xmid= hto_rrunm+dx
3317  fmid= hto_qcdmass(qm,als,rm1,rm2,fn,xmid)
3318  IF(fmid.le.0.d0) hto_rrunm= xmid
3319  IF(abs(dx) < xacc.or.fmid.eq.0.d0) RETURN
3320  ENDDO
3321 *
3322  END FUNCTION hto_rrunm
3323 *
3324 *---------------------------------------------------------------------
3325 *
3326  FUNCTION hto_qcdmass(qm,als,rm1,rm2,fn,x)
3327  USE hto_riemann
3328 *
3329  IMPLICIT NONE
3330 *
3331  real*8 hto_qcdmass,qm,als,rm1,rm2,fn,x,rln,rlns,r1,r2,delta0,
3332  # delta1,delta2,rhs
3333 *
3334  rln= 2.d0*log(qm/x)
3335  rlns= rln*rln
3336  r1= rm1/x
3337  r2= rm2/x
3338  delta0= 3.d0/4.d0*rz2-3.d0/8.d0
3339  delta1= r1*(pis/8.d0+r1*(-0.597d0+0.230d0*r1))
3340  delta2= r2*(pis/8.d0+r2*(-0.597d0+0.230d0*r2))
3341 *
3342  rhs= 1.d0+als*(4.d0/3.d0+rln+als*(3817.d0/288.d0-8.d0/3.d0+
3343  # 2.d0/3.d0*(2.d0+log(2.d0))*rz2-rz3/6.d0-fn/3.d0*(rz2+
3344  # 71.d0/48.d0)+4.d0/3.d0*(delta0+delta1+delta2)+(173.d0/
3345  # 24.d0-13.d0/36.d0*fn)*rln+(15.d0/8.d0-fn/12.d0)*rlns))
3346  hto_qcdmass= qm-x*rhs
3347 *
3348  RETURN
3349 *
3350  END FUNCTION hto_qcdmass
3351 *
3352  END MODULE hto_qcd
3353 *
3354 *-----------------------------------------------------------------------------
3355 *
3356  MODULE hto_a_cmplx
3357  CONTAINS
3358 *
3359  FUNCTION hto_b021_dm_cp(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
3360  USE hto_cmplx_root
3361  USE hto_cmplx_rootz
3362  USE hto_cmplx_srs_root
3363  USE hto_ln_2_riemann
3364  USE hto_acmplx_pro
3365  USE hto_acmplx_rat
3366  USE hto_full_ln
3367  USE hto_units
3368 *
3369  IMPLICIT NONE
3370 *
3371  INTEGER i,nci,nc
3372  real*8 scal,scals,ps0i,ps0,xm1,xm2
3373  real*8, intent(in), dimension(2) :: xm0i
3374  real*8, intent(in), dimension(2,2) :: xmsi
3375  real*8, dimension(2) :: value,xm1c,xm2c
3376  real*8, dimension(2,2) :: xms
3377  real*8, dimension(2) :: xm0
3378  real*8, dimension(2) :: psi,ps,aroot,root,lambdasc,lambdas,
3379  # lambdac,lambda,argc,arg,llam,l1,l2
3380 *
3381  ps= psi
3382  ps0= ps0i
3383  xms= xmsi
3384  xm0= xm0i
3385 *
3386  xm1c(1:2)= xms(1,1:2)
3387  xm2c(1:2)= xms(2,1:2)
3388  xm1c= xm1c.cq.ps
3389  xm2c= xm2c.cq.ps
3390  xm1= xm0(1)*xm0(1)/ps0
3391  xm2= xm0(2)*xm0(2)/ps0
3392 *
3393  aroot= xm1c.cp.xm2c
3394  root= (aroot(1).crz.aroot(2))
3395 *
3396  lambdasc= co+(xm1c.cp.xm1c)+(xm2c.cp.xm2c)-2.d0*(
3397  # xm1c+xm2c+(xm1c.cp.xm2c))
3398  lambdas(1)= 1.d0+xm1*xm1+xm2*xm2-2.d0*(
3399  # xm1+xm2+xm1*xm2)
3400  lambdas(2)= -eps
3401  lambdac= (lambdasc(1)).crz.(lambdasc(2))
3402  lambda= (lambdas(1)).cr.(lambdas(2))
3403  IF(lambda(2).eq.0.d0) lambda(2)= -eps
3404 *
3405  argc= 0.5d0*((-co+xm1c+xm2c-lambdac).cq.root)
3406 *
3407  arg(1)= 0.5d0*(-1.d0+xm1+xm2-lambda(1))/sqrt(xm1*xm2)
3408  arg(2)= eps
3409 *
3410  llam= argc.lnsrs.arg
3411 *
3412  l1= xm1c(1).fln.xm1c(2)
3413  l2= xm2c(1).fln.xm2c(2)
3414 *
3415  value= (((xm1c-xm2c-co).cq.lambdac).cp.llam)+0.5d0*(l1-l2)
3416 *
3417  RETURN
3418  END FUNCTION hto_b021_dm_cp
3419 *
3420  END MODULE hto_a_cmplx
3421 *
3422 *-----------------------------------------------------------------------------------------
3423 *
3424  MODULE hto_root_find2
3425  CONTAINS
3426 *
3427  FUNCTION hto_zeroin(f, ax, bx, aerr, rerr) RESULT(fn_val)
3428 *
3429  USE hto_rootw
3430 *
3431 ! Code converted using TO_F90 by Alan Miller
3432 ! Date: 2003-07-14 Time: 12:32:54
3433 
3434 !-----------------------------------------------------------------------
3435 
3436 ! FINDING A ZERO OF THE FUNCTION F(X) IN THE INTERVAL (AX,BX)
3437 
3438 ! ------------------------
3439 
3440 ! INPUT...
3441 
3442 ! F FUNCTION SUBPROGRAM WHICH EVALUATES F(X) FOR ANY X IN THE
3443 ! CLOSED INTERVAL (AX,BX). IT IS ASSUMED THAT F IS CONTINUOUS,
3444 ! AND THAT F(AX) AND F(BX) HAVE DIFFERENT SIGNS.
3445 ! AX LEFT ENDPOINT OF THE INTERVAL
3446 ! BX RIGHT ENDPOINT OF THE INTERVAL
3447 ! AERR THE ABSOLUTE ERROR TOLERANCE TO BE SATISFIED
3448 ! RERR THE RELATIVE ERROR TOLERANCE TO BE SATISFIED
3449 
3450 ! OUTPUT...
3451 
3452 ! ABCISSA APPROXIMATING A ZERO OF F IN THE INTERVAL (AX,BX)
3453 
3454 !-----------------------------------------------------------------------
3455 ! ZEROIN IS A SLIGHTLY MODIFIED TRANSLATION OF THE ALGOL PROCEDURE
3456 ! ZERO GIVEN BY RICHARD BRENT IN ALGORITHMS FOR MINIMIZATION WITHOUT
3457 ! DERIVATIVES, PRENTICE-HALL, INC. (1973).
3458 !-----------------------------------------------------------------------
3459 
3460  IMPLICIT NONE
3461  real*8, INTENT(IN) :: ax
3462  real*8, INTENT(IN) :: bx
3463  real*8, INTENT(IN) :: aerr
3464  real*8, INTENT(IN) :: rerr
3465  real*8 :: fn_val
3466 *
3467 * EXTERNAL f
3468 *
3469  INTERFACE
3470  FUNCTION f(x) RESULT(fn_val)
3471  IMPLICIT NONE
3472  real*8, INTENT(IN) :: x
3473  real*8 :: fn_val
3474  END FUNCTION f
3475  END INTERFACE
3476 *
3477  real*8 :: a,b,c,d,e,eps,fa,fb,fc,tol,xm,p,q,r,s,atol,rtol
3478 
3479 ! COMPUTE EPS, THE RELATIVE MACHINE PRECISION
3480 
3481  eps= epsilon(0.0d0)
3482 
3483 ! INITIALIZATION
3484 
3485  a= ax
3486  b= bx
3487  fa= f(a)
3488  fb= f(b)
3489  IF(fa*fb.gt.0.d0) THEN
3490  inc= 1
3491  ENDIF
3492  atol= 0.5d0*aerr
3493  rtol= max(0.5d0*rerr, 2.0d0*eps)
3494 
3495 ! BEGIN STEP
3496 
3497  10 c= a
3498  fc= fa
3499  d= b-a
3500  e= d
3501  20 IF(abs(fc) < abs(fb)) THEN
3502  a= b
3503  b= c
3504  c= a
3505  fa= fb
3506  fb= fc
3507  fc= fa
3508  END IF
3509 
3510 ! CONVERGENCE TEST
3511 
3512  tol= rtol*max(abs(b),abs(c))+atol
3513  xm= 0.5d0*(c-b)
3514  IF(abs(xm) > tol) THEN
3515  IF(fb /= 0.0d0) THEN
3516 
3517 ! IS BISECTION NECESSARY
3518 
3519  IF(abs(e) >= tol) THEN
3520  IF(abs(fa) > abs(fb)) THEN
3521 
3522 ! IS QUADRATIC INTERPOLATION POSSIBLE
3523 
3524  IF(a == c) THEN
3525 
3526 ! LINEAR INTERPOLATION
3527 
3528  s= fb/fc
3529  p= (c-b)*s
3530  q= 1.0d0-s
3531  ELSE
3532 
3533 ! INVERSE QUADRATIC INTERPOLATION
3534 
3535  q= fa/fc
3536  r= fb/fc
3537  s= fb/fa
3538  p= s*((c-b)*q*(q-r)-(b-a)*(r-1.0d0))
3539  q= (q-1.0d0)*(r-1.0d0)*(s-1.0d0)
3540  ENDIF
3541 
3542 ! ADJUST SIGNS
3543 
3544  IF(p > 0.0d0) q= -q
3545  p= abs(p)
3546 
3547 ! IS INTERPOLATION ACCEPTABLE
3548 
3549  IF(2.0*p < (3.0*xm*q-abs(tol*q))) THEN
3550  IF(p < abs(0.5d0*e*q)) THEN
3551  e= d
3552  d= p/q
3553  GO TO 30
3554  ENDIF
3555  ENDIF
3556  ENDIF
3557  ENDIF
3558 
3559 ! BISECTION
3560 
3561  d= xm
3562  e= d
3563 
3564 ! COMPLETE STEP
3565 
3566  30 a= b
3567  fa= fb
3568  IF(abs(d) > tol) b= b+d
3569  IF(abs(d) <= tol) b= b+sign(tol,xm)
3570  fb= f(b)
3571  IF(fb*(fc/abs(fc)) > 0.0d0) GO TO 10
3572  GO TO 20
3573  ENDIF
3574  ENDIF
3575 
3576 ! DONE
3577 
3578  fn_val= b
3579  RETURN
3580  END FUNCTION hto_zeroin
3581 *
3582  END MODULE hto_root_find2
3583 *
3584 *--------------------------------------------------------------------------
3585 *
3586  MODULE hto_hbb_cp
3587  CONTAINS
3588 *
3589  FUNCTION hto_sshh(x)
3590  USE hto_aux_hcp
3591 *
3592  IMPLICIT NONE
3593 *
3594 c I've commented the following line and added the other twos (Carlo Oleari)
3595 c REAL*8 HTO_SSHH,rgh,muc,scalc,x
3596  real*8 hto_sshh,rgh,muc,scalc
3597  real*8, INTENT(IN) :: x
3598 *
3599  muc= muhcp
3600  scalc= scalec
3601  rgh= x*muc
3602 *
3603  hto_sshh= hto_shh(muc,scalc,rgh)
3604 *
3605  RETURN
3606  END FUNCTION hto_sshh
3607 *
3608 *---------------------------------------------------------------------------------------
3609 *
3610  FUNCTION hto_shh(muhr,scal,rgh)
3611  USE hto_ferbos
3612  USE hto_a_cmplx
3613  USE hto_aux_hcp
3614  USE hto_aux_hbb
3615  USE hto_units
3616  USE hto_acmplx_pro
3617  USE hto_acmplx_rat
3618  USE hto_full_ln
3619  USE hto_ln_2_riemann
3620  USE hto_masses
3621  USE hto_set_phys_const
3622  USE hto_riemann
3623  USE hto_optcp
3624  USE hto_olas
3625  USE hto_common_niels
3626  USE hto_qcd
3627  USE hto_cmplx_rootz
3628 *
3629  IMPLICIT NONE
3630 *
3631  INTEGER nc,iz
3632  real*8 hto_shh,muhr,rgh,muhs,scal,scals,p2,xm0,str,sti,ewc,
3633  # sconv,asmur,emc,emb,emt,as_nlo,rmbs,rmcs,rmss,
3634  # crmbs,crmcs,lcxb,lcxc,lcxbs,lcxcs,lclxb,lclxc,qcdtop,neg
3635  real*8, dimension(2) :: axm0
3636  real*8, dimension(2,2) :: axms
3637  real*8, dimension(3,2,2) :: bmcb
3638  real*8, dimension(8,2,2) :: bmcf
3639  real*8, dimension(1,2,2) :: bmct
3640  real*8, dimension(3,2) :: bm0b,coefbb
3641  real*8, dimension(8,2) :: bm0f,coefbf
3642  real*8, dimension(1,2) :: bm0t,coefbt
3643  real*8, dimension(2) :: sh,shs,clh,b0sumb,b0sumf,cxp,ksumb,
3644  # ksumf,coefb1,coefb2,coefb3,coefb4,coefb5,coefb6,coefb7,
3645  # coefb8,coefb9,coefb10,coefb11,coefb12,ab2,ab3,
3646  # totalf,totalt,totalb,total,b0sumt,ksumt,xms,
3647  # b0part,cpt,ccxt,deltag,sww0,coefw1,coefw2,
3648  # ksumw,ccxts,cctsi,shi,clt,cxhw,cstsi,csmcts,cltmw,
3649  # b0sumw,sww,dw,b0sumw1,b0sumw2,cmxw,clmw,cxtw,
3650  # kfmsb,ktmsb,kbmsb,nloqcd,runbc,ttqcd,wccxt,wclt,wccxts,
3651  # wcxtw,wcltmw,ascal
3652 *
3653  INTERFACE
3654  SUBROUTINE hto_initalphas(asord,FR2,MUR,asmur,emc,emb,emt)
3655  USE hto_dzpar
3656  IMPLICIT NONE
3657  INTEGER asord
3658  real*8 fr2,mur,asmur,emc,emb,emt,hto_findalphasr0
3659  EXTERNAL hto_findalphasr0
3660  END SUBROUTINE hto_initalphas
3661  END INTERFACE
3662 *
3663  INTERFACE
3664  FUNCTION hto_alphas(MUR)
3665  USE hto_nffix
3666  USE hto_varflv
3667  USE hto_frrat
3668  USE hto_asinp
3669  USE hto_asfthr
3670  IMPLICIT NONE
3671  real*8 mur,hto_alphas
3672  END FUNCTION hto_alphas
3673  END INTERFACE
3674 *
3675  INTERFACE
3676  FUNCTION hto_quarkqcd(scal,psi,ps0i,xmsi,xm0i,type)
3677  # result(value)
3678  USE hto_riemann
3679  USE hto_acmplx_pro
3680  USE hto_acmplx_rat
3681  USE hto_cmplx_root
3682  USE hto_cmplx_rootz
3683  USE hto_cmplx_srs_root
3684  USE hto_ln_2_riemann
3685  USE hto_full_ln
3686  USE hto_sp_fun
3687  USE hto_units
3688  IMPLICIT NONE
3689  INTEGER type
3690  real*8 scal,ps0i,xm0i
3691  real*8, dimension(2) :: value,psi,xmsi
3692  END FUNCTION hto_quarkqcd
3693  END INTERFACE
3694 *
3695  muhs= muhr*muhr
3696  scals= scal*scal
3697 *
3698  asmur= 0.12018d0
3699  emc= 1.4d0
3700  emb= 4.75d0
3701  emt= mt
3702  iz= 1
3703  CALL hto_initalphas(iz,one,mz,asmur,emc,emb,emt)
3704  als= hto_alphas(scal)
3705  as_nlo= als/pi
3706 *
3707  runbc= hto_run_bc(scal)
3708  crmbs= runbc(2)*runbc(2)
3709  crmcs= runbc(1)*runbc(1)
3710 *
3711  lcxb= crmbs/scals
3712  lcxc= crmcs/scals
3713 *
3714  lcxbs= lcxb*lcxb
3715  lcxcs= lcxc*lcxc
3716  lclxb= log(lcxb)
3717  lclxc= log(lcxc)
3718 *
3719  IF(gtop == 1) THEN
3720  imt= g_f/(8.d0*sqrt(2.d0)*pi)*(mt*mt-mw*mw)**2*
3721  # (mt*mt+2.d0*mw*mw)/mt**3
3722  ELSEIF(gtop == 0) THEN
3723  imt= 0.d0
3724  ELSE
3725  imt= yimt
3726  ENDIF
3727 *
3728  str= mt*mt-0.25d0*imt*imt
3729  sti= -mt*imt
3730  cpt(1)= str
3731  cpt(2)= sti
3732  wccxt= cpt/scals
3733  wccxts= wccxt.cp.wccxt
3734  ccxt= cpt/scals
3735  ccxts= ccxt.cp.ccxt
3736 *
3737  cctsi= co.cq.ccts
3738  cstsi= co.cq.csts
3739  csmcts= csts-ccts
3740  cmxw= -cxw
3741 *
3742  clmw= cmxw(1).fln.cmxw(2)
3743  clmw(2)= clmw(2)-2.d0*pi
3744 *
3745  sh(1)= muhs/scals
3746  sh(2)= -muhr*rgh/scals
3747 *
3748  cxhw= sh-cxw
3749  shs= sh.cp.sh
3750  shi= co.cq.sh
3751 *
3752  clh= sh(1).fln.sh(2)
3753  clt= ccxt(1).fln.ccxt(2)
3754  wclt= wccxt(1).fln.wccxt(2)
3755  cxtw= ccxt-cxw
3756  wcxtw= wccxt-cxw
3757  cltmw= cxtw(1).fln.cxtw(2)
3758  wcltmw= wcxtw(1).fln.wcxtw(2)
3759 *
3760 * W
3761  coefb1= (12.d0*cxw-4.d0*sh+(shs.cq.cxw))/64.d0
3762 *
3763 * Z
3764  coefb2= (-4.d0*(sh.cq.ccts)+(shs.cq.cxw)+
3765  # 12.d0*(cxw.cq.cctq))/128.d0
3766 *
3767 * H
3768  coefb3= 9.d0/128.d0*(shs.cq.cxw)
3769 *
3770 * top
3771  coefb4= -3.d0/32.d0*((4.d0*ccxt-sh).cp.(ccxt.cq.cxw))
3772 *
3773 * light fermions
3774 *
3775  coefb5= -3.d0/32.d0*((4.d0*co*lcxb-sh).cq.cxw)*lcxb
3776 *
3777  coefb6= -1.d0/32.d0*((4.d0*co*cxtau-sh).cq.cxw)*cxtau
3778 *
3779  coefb7= -3.d0/32.d0*((4.d0*co*lcxc-sh).cq.cxw)*lcxc
3780 *
3781  coefb8= -1.d0/32.d0*((4.d0*co*cxmu-sh).cq.cxw)*cxmu
3782 *
3783  coefb9= -3.d0/32.d0*((4.d0*co*cxs-sh).cq.cxw)*cxs
3784 *
3785  coefb10= -3.d0/32.d0*((4.d0*co*cxd-sh).cq.cxw)*cxd
3786 *
3787  coefb11= -3.d0/32.d0*((4.d0*co*cxu-sh).cq.cxw)*cxu
3788 *
3789  coefb12= -1.d0/32.d0*((4.d0*co*cxe-sh).cq.cxw)*cxe
3790 *
3791  cxp(1)= muhs
3792  cxp(2)= -muhr*rgh
3793  p2= muhs
3794 *
3795  IF(ifb.eq.0) THEN
3796 *
3797  xms(1)= swr
3798  xms(2)= swi
3799  xm0= mw
3800  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3801  b0sumb= (coefb1.cp.b0part)
3802  xms(1)= szr
3803  xms(2)= szi
3804  xm0= mz
3805  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3806  b0sumb= b0sumb+(coefb2.cp.b0part)
3807  xms(1)= muhs
3808  xms(2)= -muhr*rgh
3809  xm0= muhr
3810  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3811  b0sumb= b0sumb+(coefb3.cp.b0part)
3812 *
3813  xms(1:2)= crmbs*co(1:2)
3814  xm0= sqrt(crmbs)
3815  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3816  b0sumf= (coefb5.cp.b0part)
3817  xms(1:2)= mtl*mtl*co(1:2)
3818  xm0= mtl
3819  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3820  b0sumf= b0sumf+(coefb6.cp.b0part)
3821  xms(1:2)= crmcs*co(1:2)
3822  xm0= sqrt(crmcs)
3823  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3824  b0sumf= b0sumf+(coefb7.cp.b0part)
3825  xms(1:2)= mm*mm*co(1:2)
3826  xm0= mm
3827  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3828  b0sumf= b0sumf+(coefb8.cp.b0part)
3829  xms(1:2)= msq*msq*co(1:2)
3830  xm0= msq
3831  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3832  b0sumf= b0sumf+(coefb9.cp.b0part)
3833  xms(1:2)= mdq*mdq*co(1:2)
3834  xm0= mdq
3835  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3836  b0sumf= b0sumf+(coefb10.cp.b0part)
3837  xms(1:2)= muq*muq*co(1:2)
3838  xm0= muq
3839  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3840  b0sumf= b0sumf+(coefb11.cp.b0part)
3841  xms(1:2)= me*me*co(1:2)
3842  xm0= me
3843  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3844  b0sumf= b0sumf+(coefb12.cp.b0part)
3845 *
3846  xms(1:2)= cpt(1:2)
3847  xm0= mt
3848  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3849  b0sumt= (coefb4.cp.b0part)
3850 *
3851  iz= 0
3852  xms(1:2)= crmbs*co(1:2)
3853  xm0= sqrt(crmbs)
3854  nloqcd= crmbs*hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3855  xms(1:2)= crmcs*co(1:2)
3856  xm0= sqrt(crmcs)
3857  nloqcd= nloqcd+crmcs*hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3858  IF(qcdc==0) nloqcd= 0.d0
3859 *
3860  xms(1:2)= cpt(1:2)
3861  xm0= mt
3862  iz= 1
3863  ttqcd= hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3864  ttqcd= cpt.cp.ttqcd
3865  IF(qcdc==0) ttqcd= 0.d0
3866 *
3867  ELSEIF(ifb.eq.1) THEN
3868 *
3869  xms(1:2)= crmbs*co(1:2)
3870  xm0= sqrt(crmbs)
3871  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3872  b0sumf= (coefb5.cp.b0part)
3873  xms(1:2)= mtl*mtl*co(1:2)
3874  xm0= mtl
3875  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3876  b0sumf= b0sumf+(coefb6.cp.b0part)
3877  xms(1:2)= crmcs*co(1:2)
3878  xm0= sqrt(crmcs)
3879  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3880  b0sumf= b0sumf+(coefb7.cp.b0part)
3881  xms(1:2)= mm*mm*co(1:2)
3882  xm0= mm
3883  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3884  b0sumf= b0sumf+(coefb8.cp.b0part)
3885  xms(1:2)= msq*msq*co(1:2)
3886  xm0= msq
3887  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3888  b0sumf= b0sumf+(coefb9.cp.b0part)
3889  xms(1:2)= mdq*mdq*co(1:2)
3890  xm0= mdq
3891  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3892  b0sumf= b0sumf+(coefb10.cp.b0part)
3893  xms(1:2)= muq*muq*co(1:2)
3894  xm0= muq
3895  b0part=hto_b0af_em(scal,cxp,p2,xms,xm0)
3896  b0sumf= b0sumf+(coefb11.cp.b0part)
3897  xms(1:2)= me*me*co(1:2)
3898  xm0= me
3899  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3900  b0sumf= b0sumf+(coefb12.cp.b0part)
3901 *
3902  iz= 0
3903  xms(1:2)= crmbs*co(1:2)
3904  xm0= sqrt(crmbs)
3905  nloqcd= crmbs*hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3906  xms(1:2)= crmcs*co(1:2)
3907  xm0= sqrt(crmcs)
3908  nloqcd= nloqcd+crmcs*hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3909  IF(qcdc==0) nloqcd= 0.d0
3910 *
3911  ELSEIF(ifb.eq.2) THEN
3912 *
3913  xms(1:2)= cpt(1:2)
3914  xm0= mt
3915  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3916  b0sumt= (coefb4.cp.b0part)
3917 *
3918  xms(1:2)= cpt(1:2)
3919  xm0= mt
3920  iz= 1
3921  ttqcd= hto_quarkqcd(scal,cxp,p2,xms,xm0,iz)
3922  ttqcd= cpt.cp.ttqcd
3923  IF(qcdc==0) ttqcd= 0.d0
3924 *
3925  ELSEIF(ifb.eq.3) THEN
3926 *
3927  xms(1)= swr
3928  xms(2)= swi
3929  xm0= mw
3930  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3931  b0sumb= (coefb1.cp.b0part)
3932  xms(1)= szr
3933  xms(2)= szi
3934  xm0= mz
3935  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3936  b0sumb= b0sumb+(coefb2.cp.b0part)
3937  xms(1)= muhs
3938  xms(2)= -muhr*rgh
3939  xm0= muhr
3940  b0part= hto_b0af_em(scal,cxp,p2,xms,xm0)
3941  b0sumb= b0sumb+(coefb3.cp.b0part)
3942 *
3943  ENDIF
3944 *
3945  IF(ifb.eq.0.or.ifb.eq.1) THEN
3946  ksumf= -(sh.cq.cxw)*(cxe*clxe+cxmu*clxmu+
3947  # cxtau*clxtau+3.d0*(cxd*clxd+cxs*clxs+lcxb*lclxb+
3948  # cxu*clxu+lcxc*lclxc))/32.d0+
3949  # cxwi*(cxes+cxmus+cxtaus+3.d0*(
3950  # cxds+cxss+lcxbs+cxus+lcxcs))/8.d0
3951  ENDIF
3952  IF(ifb.eq.0.or.ifb.eq.2) THEN
3953  ksumt= 3.d0/32.d0*(4.d0*((ccxt.cq.cxw).cp.ccxt)
3954  # -(clt.cp.((sh.cq.cxw).cp.ccxt)))
3955  ENDIF
3956 *
3957  IF(ifb.eq.0.or.ifb.eq.3) THEN
3958 *
3959  ksumb= (-2.d0*((2.d0*co+cctsi+3.d0*(sh.cq.cxw)).cp.sh)
3960  # -(clcts.cp.((6.d0*cctsi-(sh.cq.cxw)).cp.sh))
3961  # +3.d0*(clw.cp.((4.d0*co+2.d0*cctsi-(sh.cq.cxw)).cp.sh))
3962  # -3.d0*(clh.cp.(shs.cq.cxw)))/128.d0
3963 *
3964  ENDIF
3965 *
3966  ewc= 4.d0*sqrt(2.d0)*g_f/pis
3967  sconv= muhs/scals
3968 *
3969  IF(ifb.eq.0.or.ifb.eq.1) THEN
3970  totalf= b0sumf+ksumf
3971  ENDIF
3972 *
3973  IF(ifb.eq.0.or.ifb.eq.2) THEN
3974  totalt= b0sumt+ksumt
3975 *
3976  neg= ewc*(swr*totalt(2)+swi*totalt(1))/sconv
3977  # -as_nlo*g_f/(sqrt(2.d0)*pis)*
3978  # (sh(1)*ttqcd(2)+sh(2)*ttqcd(1))/sconv
3979 *
3980  IF(neg < 0.d0) THEN
3981  totalt= 0.d0
3982  qcdtop= 0.d0
3983  pcnt= -1
3984  ELSE
3985  qcdtop= as_nlo*g_f/(sqrt(2.d0)*pis)*
3986  # (sh(1)*ttqcd(2)+sh(2)*ttqcd(1))/sconv
3987  pcnt= 1
3988  ENDIF
3989 *
3990  ENDIF
3991 *
3992  IF(ifb.eq.0.or.ifb.eq.3) THEN
3993  totalb= b0sumb+ksumb
3994  IF((swr*totalb(2)+swi*totalb(1)) < 0.d0) THEN
3995  totalb= 0.d0
3996  pcnt= -1
3997  ELSE
3998  pcnt= 1
3999  ENDIF
4000  ENDIF
4001 *
4002  total= totalf+totalt+totalb
4003 *
4004 *--- W self energies
4005 *
4006  deltag= 6.d0*co+0.5d0*(((7.d0*co-4.d0*csts).cq.csts).cp.clcts)
4007 *
4008  sww0= -(38.d0*cxw+6.d0*wccxt+7.d0*sh
4009  # -48.d0*(((wccxt.cq.sh).cq.cxw).cp.wccxt)+8.d0*(cxw.cq.sh))/128.d0
4010  # -3.d0/64.d0*((cxw-sh+(cxws.cq.cxhw)).cp.clh)
4011  # +3.d0/32.d0*(((co-4.d0*((wccxt.cq.sh).cq.cxw).cp.wccxt)).cp.wclt)
4012  # +((((8.d0*co-17.d0*cstsi+3.d0*cctsi).cp.cxw)
4013  # -6.d0*((cxw.cq.sh).cq.cctq)).cp.clcts)/64.d0
4014  # -((cxw.cq.sh).cq.cctq)/32.d0+5.d0/128.d0*(cxw.cq.ccts)
4015 *
4016  coefw1= -(((8.d0*co-(sh.cq.cxw)).cp.sh)*sh
4017  # -4.d0*((-12.d0*cxw+7.d0*sh).cp.cxw))/192.d0
4018 *
4019  coefw2= -((cxws.cq.csmcts).cp.(416.d0*co-192.d0*csts
4020  # -((132.d0*co-((12.d0*co+cctsi).cq.ccts)).cq.ccts)))/192.d0
4021 *
4022  cxp(1)= swr
4023  cxp(2)= swi
4024  p2= mw*mw
4025 *
4026  axms(1,1)= swr
4027  axms(1,2)= swi
4028  axm0(1)= mw
4029  axms(2,1)= muhs
4030  axms(2,2)= -muhr*rgh
4031  axm0(2)= muhr
4032  b0part= hto_b021_dm_cp(scal,cxp,p2,axms,axm0)
4033  b0sumw1= (coefw1.cp.b0part)
4034  b0sumw= (coefw1.cp.b0part)
4035 *
4036  axms(1,1)= szr
4037  axms(1,2)= szi
4038  axm0(1)= mz
4039  axms(2,1)= swr
4040  axms(2,2)= swi
4041  axm0(2)= mw
4042  b0part= hto_b021_dm_cp(scal,cxp,p2,axms,axm0)
4043  b0sumw2= (coefw2.cp.b0part)
4044  b0sumw= b0sumw+(coefw2.cp.b0part)
4045 *
4046  ksumw= -12.d0*((cxw
4047  # -0.5d0*((3.d0*co-(wccxts.cq.cxws)).cp.wccxt)).cp.wcltmw)
4048  # -((24.d0*cxw-((14.d0*co-(sh.cq.cxw)).cp.sh)).cp.clh)
4049  # +((36.d0*cxw-14.d0*sh-18.d0*((co-4.d0*(wccxt.cq.sh)).cp.wccxt)
4050  # +(shs.cq.cxw)).cp.clw)
4051  # -6.d0*(((2.d0*co+((cxwi-12.d0*shi).cp.wccxt)).cp.wccxt)
4052  # +1.d0/6.d0*((15.d0*co-(sh.cq.cxw)).cp.sh)
4053  # +2.d0/9.d0*((97.d0*co+9.d0*(cxw.cq.sh)).cp.cxw))
4054  # +(((cxw.cq.ccts).cp.(co-6.d0*(cxw.cq.sh))).cq.ccts)
4055  # -2.d0*(((cxw.cq.csmcts).cp.clcts).cp.(62.d0*co
4056  # -48.d0*csts-5.d0*cctsi))
4057  # -18.d0*(((cxws.cq.sh).cq.cctq).cp.clcts)
4058  # -72.d0*((wclt.cp.wccxts).cp.(shi-1.d0/12.d0*(wccxt.cq.cxws)))
4059  # +23.d0*(cxw.cq.ccts)
4060 *
4061  ksumw= ksumw/192.d0+3.d0/16.d0*(cxw.cp.(clw-clmw))
4062 *
4063  sww= b0sumw+ksumw
4064 *
4065  dw= (-sww+sww0)/sconv+deltag/16.d0
4066 * DW= 0.d0
4067 *
4068  IF(ifb.eq.0) THEN
4069  hto_shh= rgh/muhr*
4070  # (1.d0+ewc*(swr*dw(1)-swi*dw(2)))
4071  # -ewc*(swr*total(2)+swi*total(1))/sconv
4072  # +as_nlo*g_f/(sqrt(2.d0)*pis)*
4073  # (sh(1)*nloqcd(2)+sh(2)*nloqcd(1))/sconv
4074  # +qcdtop
4075 *
4076  ELSEIF(ifb.eq.1) THEN
4077  hto_shh= rgh/muhr*
4078  # (1.d0+ewc*(swr*dw(1)-swi*dw(2)))
4079  # -ewc*(swr*totalf(2)+swi*totalf(1))/sconv
4080  # +as_nlo*g_f/(sqrt(2.d0)*pis)*
4081  # (sh(1)*nloqcd(2)+sh(2)*nloqcd(1))/sconv
4082  ELSEIF(ifb.eq.2) THEN
4083  hto_shh= rgh/muhr*
4084  # (1.d0+ewc*(swr*dw(1)-swi*dw(2)))
4085  # -ewc*(swr*totalt(2)+swi*totalt(1))/sconv
4086  # +qcdtop
4087  ELSEIF(ifb.eq.3) THEN
4088  hto_shh= rgh/muhr*
4089  # (1.d0+ewc*(swr*dw(1)-swi*dw(2)))
4090  # -ewc*(swr*totalb(2)+swi*totalb(1))/sconv
4091  ENDIF
4092 *
4093  RETURN
4094 *
4095  END FUNCTION hto_shh
4096 *
4097  END MODULE hto_hbb_cp
4098 *
4099 *--------------------------------------------------------------------------
4100 *
4101 *----------------------------------------------------------------
4102 * H total grids ``Handbook of LHC Higgs Cross Sections: 1. Inclusive Observables,''
4103 *----------------------------------------------------------------
4104 *
4105  SUBROUTINE hto_gridht(mass,evalue)
4106 *
4107  IMPLICIT NONE
4108 *
4109  INTEGER i,top,gdim
4110  real*8 u,value,evalue,mass
4111  real*8, dimension(103) :: bc,cc,dc
4112 *
4113 * u value of M_H at which the spline is to be evaluated
4114 *
4115  gdim= 103
4116 *
4117  CALL hto_fmmsplinesingleht(bc,cc,dc,top,gdim)
4118 *
4119  u= mass
4120  CALL hto_seval3singleht(u,bc,cc,dc,top,gdim,value)
4121 *
4122  evalue= value
4123 *
4124  RETURN
4125 *
4126 *-----------------------------------------------------------------------
4127 *
4128  CONTAINS
4129 *
4130  SUBROUTINE hto_fmmsplinesingleht(b,c,d,top,gdim)
4131 *
4132 *---------------------------------------------------------------------------
4133 *
4134  INTEGER k,n,i,top,gdim,l
4135 *
4136  real*8, dimension(103) :: xc,yc
4137  real*8, dimension(103) :: x,y
4138 *
4139  real*8, DIMENSION(gdim) :: b
4140 * linear coeff
4141 *
4142  real*8, DIMENSION(gdim) :: c
4143 * quadratic coeff.
4144 *
4145  real*8, DIMENSION(gdim) :: d
4146 * cubic coeff.
4147 *
4148  real*8 :: t
4149  real*8,PARAMETER:: zero=0.0, two=2.0, three=3.0
4150 *
4151 * The grid
4152 *
4153 *
4154  DATA (xc(i),i=1,103)/
4155  # 90.d0,95.d0,100.d0,105.d0,110.d0,115.d0,120.d0,
4156  # 125.d0,130.d0,135.d0,140.d0,145.d0,150.d0,155.d0,160.d0,165.d0,
4157  # 170.d0,175.d0,180.d0,185.d0,190.d0,195.d0,200.d0,210.d0,220.d0,
4158  # 230.d0,240.d0,250.d0,260.d0,270.d0,280.d0,290.d0,300.d0,310.d0,
4159  # 320.d0,330.d0,340.d0,350.d0,360.d0,370.d0,380.d0,390.d0,400.d0,
4160  # 410.d0,420.d0,430.d0,440.d0,450.d0,460.d0,470.d0,480.d0,490.d0,
4161  # 500.d0,510.d0,520.d0,530.d0,540.d0,550.d0,560.d0,570.d0,580.d0,
4162  # 590.d0,600.d0,610.d0,620.d0,630.d0,640.d0,650.d0,660.d0,670.d0,
4163  # 680.d0,690.d0,700.d0,710.d0,720.d0,730.d0,740.d0,750.d0,760.d0,
4164  # 770.d0,780.d0,790.d0,800.d0,810.d0,820.d0,830.d0,840.d0,850.d0,
4165  # 860.d0,870.d0,880.d0,890.d0,900.d0,910.d0,920.d0,930.d0,940.d0,
4166  # 950.d0,960.d0,970.d0,980.d0,990.d0,1000.d0/
4167 *
4168  DATA (yc(i),i=1,103)/
4169  # 2.20d-3,2.32d-3,2.46d-3,2.62d-3,2.82d-3,3.09d-3,3.47d-3,4.03d-3,
4170  # 4.87d-3,6.14d-3,8.12d-3,1.14d-2,1.73d-2,3.02d-2,8.29d-2,2.46d-1,
4171  # 3.80d-1,5.00d-1,6.31d-1,8.32d-1,1.04d0,1.24d0,1.43d0,1.85d0,
4172  # 2.31d0,2.82d0,3.40d0,4.04d0,4.76d0,5.55d0,6.43d0,7.39d0,8.43d0,
4173  # 9.57d0,10.8d0,12.1d0,13.5d0,15.2d0,17.6d0,20.2d0,23.1d0,26.1d0,
4174  # 29.2d0,32.5d0,35.9d0,39.4d0,43.1d0,46.9d0,50.8d0,54.9d0,59.1d0,
4175  # 63.5d0,68.0d0,72.7d0,77.6d0,82.6d0,87.7d0,93.1d0,98.7d0,104.d0,
4176  # 110.d0,116.d0,123.d0,129.d0,136.d0,143.d0,150.d0,158.d0,166.d0,
4177  # 174.d0,182.d0,190.d0,199.d0,208.d0,218.d0,227.d0,237.d0,248.d0,
4178  # 258.d0,269.d0,281.d0,292.d0,304.d0,317.d0,330.d0,343.d0,357.d0,
4179  # 371.d0,386.d0,401.d0,416.d0,432.d0,449.d0,466.d0,484.d0,502.d0,
4180  # 521.d0,540.d0,560.d0,581.d0,602.d0,624.d0,647.d0/
4181 *
4182  n= 103
4183  FORALL(l=1:103)
4184  x(l)= xc(l)
4185  y(l)= yc(l)
4186  ENDFORALL
4187 
4188 *.....Set up tridiagonal system.........................................
4189 * b=diagonal, d=offdiagonal, c=right-hand side
4190 *
4191  d(1)= x(2)-x(1)
4192  c(2)= (y(2)-y(1))/d(1)
4193  DO k= 2,n-1
4194  d(k)= x(k+1)-x(k)
4195  b(k)= two*(d(k-1)+d(k))
4196  c(k+1)= (y(k+1)-y(k))/d(k)
4197  c(k)= c(k+1)-c(k)
4198  END DO
4199 *
4200 *.....End conditions. third derivatives at x(1) and x(n) obtained
4201 * from divided differences.......................................
4202 *
4203  b(1)= -d(1)
4204  b(n)= -d(n-1)
4205  c(1)= zero
4206  c(n)= zero
4207  IF (n > 3) THEN
4208  c(1)= c(3)/(x(4)-x(2))-c(2)/(x(3)-x(1))
4209  c(n)= c(n-1)/(x(n)-x(n-2))-c(n-2)/(x(n-1)-x(n-3))
4210  c(1)= c(1)*d(1)*d(1)/(x(4)-x(1))
4211  c(n)= -c(n)*d(n-1)*d(n-1)/(x(n)-x(n-3))
4212  END IF
4213 *
4214  DO k=2,n ! forward elimination
4215  t= d(k-1)/b(k-1)
4216  b(k)= b(k)-t*d(k-1)
4217  c(k)= c(k)-t*c(k-1)
4218  END DO
4219 *
4220  c(n)= c(n)/b(n)
4221 *
4222 * back substitution ( makes c the sigma of text)
4223 *
4224  DO k=n-1,1,-1
4225  c(k)= (c(k)-d(k)*c(k+1))/b(k)
4226  END DO
4227 *
4228 *.....Compute polynomial coefficients...................................
4229 *
4230  b(n)= (y(n)-y(n-1))/d(n-1)+d(n-1)*(c(n-1)+c(n)+c(n))
4231  DO k=1,n-1
4232  b(k)= (y(k+1)-y(k))/d(k)-d(k)*(c(k+1)+c(k)+c(k))
4233  d(k)= (c(k+1)-c(k))/d(k)
4234  c(k)= three*c(k)
4235  END DO
4236  c(n)= three*c(n)
4237  d(n)= d(n-1)
4238 *
4239  RETURN
4240 *
4241  END SUBROUTINE hto_fmmsplinesingleht
4242 *
4243 *------------------------------------------------------------------------
4244 *
4245  SUBROUTINE hto_seval3singleht(u,b,c,d,top,gdim,f,fp,fpp,fppp)
4246 *
4247 * ---------------------------------------------------------------------------
4248 *
4249  real*8,INTENT(IN) :: u
4250 * abscissa at which the spline is to be evaluated
4251 *
4252  INTEGER j,k,n,l,top,gdim
4253 *
4254  real*8, dimension(103) :: xc,yc
4255  real*8, dimension(103) :: x,y
4256  real*8, DIMENSION(gdim) :: b,c,d
4257 * linear,quadratic,cubic coeff
4258 *
4259  real*8,INTENT(OUT),OPTIONAL:: f,fp,fpp,fppp
4260 * function, 1st,2nd,3rd deriv
4261 *
4262  INTEGER, SAVE :: i=1
4263  real*8 :: dx
4264  real*8,PARAMETER:: two=2.0, three=3.0, six=6.0
4265 *
4266 * The grid
4267 *
4268  DATA (xc(l),l=1,103)/
4269  # 90.d0,95.d0,100.d0,105.d0,110.d0,115.d0,120.d0,
4270  # 125.d0,130.d0,135.d0,140.d0,145.d0,150.d0,155.d0,160.d0,165.d0,
4271  # 170.d0,175.d0,180.d0,185.d0,190.d0,195.d0,200.d0,210.d0,220.d0,
4272  # 230.d0,240.d0,250.d0,260.d0,270.d0,280.d0,290.d0,300.d0,310.d0,
4273  # 320.d0,330.d0,340.d0,350.d0,360.d0,370.d0,380.d0,390.d0,400.d0,
4274  # 410.d0,420.d0,430.d0,440.d0,450.d0,460.d0,470.d0,480.d0,490.d0,
4275  # 500.d0,510.d0,520.d0,530.d0,540.d0,550.d0,560.d0,570.d0,580.d0,
4276  # 590.d0,600.d0,610.d0,620.d0,630.d0,640.d0,650.d0,660.d0,670.d0,
4277  # 680.d0,690.d0,700.d0,710.d0,720.d0,730.d0,740.d0,750.d0,760.d0,
4278  # 770.d0,780.d0,790.d0,800.d0,810.d0,820.d0,830.d0,840.d0,850.d0,
4279  # 860.d0,870.d0,880.d0,890.d0,900.d0,910.d0,920.d0,930.d0,940.d0,
4280  # 950.d0,960.d0,970.d0,980.d0,990.d0,1000.d0/
4281 *
4282  DATA (yc(l),l=1,103)/
4283  # 2.20d-3,2.32d-3,2.46d-3,2.62d-3,2.82d-3,3.09d-3,3.47d-3,4.03d-3,
4284  # 4.87d-3,6.14d-3,8.12d-3,1.14d-2,1.73d-2,3.02d-2,8.29d-2,2.46d-1,
4285  # 3.80d-1,5.00d-1,6.31d-1,8.32d-1,1.04d0,1.24d0,1.43d0,1.85d0,
4286  # 2.31d0,2.82d0,3.40d0,4.04d0,4.76d0,5.55d0,6.43d0,7.39d0,8.43d0,
4287  # 9.57d0,10.8d0,12.1d0,13.5d0,15.2d0,17.6d0,20.2d0,23.1d0,26.1d0,
4288  # 29.2d0,32.5d0,35.9d0,39.4d0,43.1d0,46.9d0,50.8d0,54.9d0,59.1d0,
4289  # 63.5d0,68.0d0,72.7d0,77.6d0,82.6d0,87.7d0,93.1d0,98.7d0,104.d0,
4290  # 110.d0,116.d0,123.d0,129.d0,136.d0,143.d0,150.d0,158.d0,166.d0,
4291  # 174.d0,182.d0,190.d0,199.d0,208.d0,218.d0,227.d0,237.d0,248.d0,
4292  # 258.d0,269.d0,281.d0,292.d0,304.d0,317.d0,330.d0,343.d0,357.d0,
4293  # 371.d0,386.d0,401.d0,416.d0,432.d0,449.d0,466.d0,484.d0,502.d0,
4294  # 521.d0,540.d0,560.d0,581.d0,602.d0,624.d0,647.d0/
4295 *
4296  n= 103
4297  FORALL(l=1:103)
4298  x(l)= xc(l)
4299  y(l)= yc(l)
4300  ENDFORALL
4301 *
4302 *.....First check if u is in the same interval found on the
4303 * last call to Seval.............................................
4304 *
4305  IF ( (i<1) .OR. (i >= n) ) i=1
4306  IF ( (u < x(i)) .OR. (u >= x(i+1)) ) THEN
4307  i=1
4308 *
4309 * binary search
4310 *
4311  j= n+1
4312  DO
4313  k= (i+j)/2
4314  IF (u < x(k)) THEN
4315  j= k
4316  ELSE
4317  i= k
4318  ENDIF
4319  IF (j <= i+1) EXIT
4320  ENDDO
4321  ENDIF
4322 *
4323  dx= u-x(i)
4324 *
4325 * evaluate the spline
4326 *
4327  IF (Present(f)) f= y(i)+dx*(b(i)+dx*(c(i)+dx*d(i)))
4328  IF (Present(fp)) fp= b(i)+dx*(two*c(i) + dx*three*d(i))
4329  IF (Present(fpp)) fpp= two*c(i) + dx*six*d(i)
4330  IF (Present(fppp)) fppp= six*d(i)
4331 *
4332  RETURN
4333 *
4334  END SUBROUTINE hto_seval3singleht
4335 *
4336  END SUBROUTINE hto_gridht
4337 *
4338 *----------------------------------------------------------------
4339 * gH grids
4340 *----------------------------------------------------------------
4341 *
4342  SUBROUTINE hto_gridlow(mass,evalue)
4343 *
4344  IMPLICIT NONE
4345 *
4346  INTEGER i,top,gdim
4347  real*8 u,value,evalue,mass
4348  real*8, dimension(22) :: bc,cc,dc
4349 *
4350 * u value of M_H at which the spline is to be evaluated
4351 * top= -1,0,1 lower, central, upper value for m_top
4352 *
4353  gdim= 22
4354 *
4355  CALL hto_fmmsplinesinglel(bc,cc,dc,top,gdim)
4356 *
4357  u= mass
4358  CALL hto_seval3singlel(u,bc,cc,dc,top,gdim,value)
4359 *
4360  evalue= value
4361 *
4362  RETURN
4363 *
4364 *-----------------------------------------------------------------------
4365 *
4366  CONTAINS
4367 *
4368  SUBROUTINE hto_fmmsplinesinglel(b,c,d,top,gdim)
4369 *
4370 *---------------------------------------------------------------------------
4371 *
4372  INTEGER k,n,i,top,gdim,l
4373 *
4374  real*8, dimension(22) :: xc,yc
4375  real*8, dimension(22) :: x,y
4376 *
4377  real*8, DIMENSION(gdim) :: b
4378 * linear coeff
4379 *
4380  real*8, DIMENSION(gdim) :: c
4381 * quadratic coeff.
4382 *
4383  real*8, DIMENSION(gdim) :: d
4384 * cubic coeff.
4385 *
4386  real*8 :: t
4387  real*8,PARAMETER:: zero=0.0, two=2.0, three=3.0
4388 *
4389 * The grid
4390 *
4391 *
4392  DATA (xc(i),i=1,22)/
4393  # 190.d0,191.d0,192.d0,193.d0,194.d0,195.d0,196.d0,197.d0,198.d0,
4394  # 199.d0,200.d0,240.d0,241.d0,242.d0,243.d0,244.d0,245.d0,246.d0,
4395  # 247.d0,248.d0,249.d0,250.d0/
4396 *
4397  DATA (yc(i),i=1,22)/
4398  # 0.10346d1,0.10750d1,0.11151d1,0.11549d1,0.11942d1,0.12329d1,
4399  # 0.12708d1,0.13083d1,0.13456d1,0.13832d1,0.14212d1,
4400  # 0.32401d1,0.32994d1,0.33593d1,0.34200d1,0.34813d1,0.35433d1,
4401  # 0.36061d1,0.36695d1,0.37336d1,0.37984d1,0.38640d1/
4402 *
4403  n= 22
4404  FORALL(l=1:22)
4405  x(l)= xc(l)
4406  y(l)= yc(l)
4407  ENDFORALL
4408 
4409 *.....Set up tridiagonal system.........................................
4410 * b=diagonal, d=offdiagonal, c=right-hand side
4411 *
4412  d(1)= x(2)-x(1)
4413  c(2)= (y(2)-y(1))/d(1)
4414  DO k= 2,n-1
4415  d(k)= x(k+1)-x(k)
4416  b(k)= two*(d(k-1)+d(k))
4417  c(k+1)= (y(k+1)-y(k))/d(k)
4418  c(k)= c(k+1)-c(k)
4419  END DO
4420 *
4421 *.....End conditions. third derivatives at x(1) and x(n) obtained
4422 * from divided differences.......................................
4423 *
4424  b(1)= -d(1)
4425  b(n)= -d(n-1)
4426  c(1)= zero
4427  c(n)= zero
4428  IF (n > 3) THEN
4429  c(1)= c(3)/(x(4)-x(2))-c(2)/(x(3)-x(1))
4430  c(n)= c(n-1)/(x(n)-x(n-2))-c(n-2)/(x(n-1)-x(n-3))
4431  c(1)= c(1)*d(1)*d(1)/(x(4)-x(1))
4432  c(n)= -c(n)*d(n-1)*d(n-1)/(x(n)-x(n-3))
4433  END IF
4434 *
4435  DO k=2,n ! forward elimination
4436  t= d(k-1)/b(k-1)
4437  b(k)= b(k)-t*d(k-1)
4438  c(k)= c(k)-t*c(k-1)
4439  END DO
4440 *
4441  c(n)= c(n)/b(n)
4442 *
4443 * back substitution ( makes c the sigma of text)
4444 *
4445  DO k=n-1,1,-1
4446  c(k)= (c(k)-d(k)*c(k+1))/b(k)
4447  END DO
4448 *
4449 *.....Compute polynnomial coefficients...................................
4450 *
4451  b(n)= (y(n)-y(n-1))/d(n-1)+d(n-1)*(c(n-1)+c(n)+c(n))
4452  DO k=1,n-1
4453  b(k)= (y(k+1)-y(k))/d(k)-d(k)*(c(k+1)+c(k)+c(k))
4454  d(k)= (c(k+1)-c(k))/d(k)
4455  c(k)= three*c(k)
4456  END DO
4457  c(n)= three*c(n)
4458  d(n)= d(n-1)
4459 *
4460  RETURN
4461 *
4462  END SUBROUTINE hto_fmmsplinesinglel
4463 *
4464 *------------------------------------------------------------------------
4465 *
4466  SUBROUTINE hto_seval3singlel(u,b,c,d,top,gdim,f,fp,fpp,fppp)
4467 *
4468 * ---------------------------------------------------------------------------
4469 *
4470  real*8,INTENT(IN) :: u
4471 * abscissa at which the spline is to be evaluated
4472 *
4473  INTEGER j,k,n,l,top,gdim
4474 *
4475  real*8, dimension(22) :: xc,yc
4476  real*8, dimension(22) :: x,y
4477  real*8, DIMENSION(gdim) :: b,c,d
4478 * linear,quadratic,cubic coeff
4479 *
4480  real*8,INTENT(OUT),OPTIONAL:: f,fp,fpp,fppp
4481 * function, 1st,2nd,3rd deriv
4482 *
4483  INTEGER, SAVE :: i=1
4484  real*8 :: dx
4485  real*8,PARAMETER:: two=2.0, three=3.0, six=6.0
4486 *
4487 * The grid
4488 *
4489  DATA (xc(l),l=1,22)/
4490  # 190.d0,191.d0,192.d0,193.d0,194.d0,195.d0,196.d0,197.d0,198.d0,
4491  # 199.d0,200.d0,240.d0,241.d0,242.d0,243.d0,244.d0,245.d0,246.d0,
4492  # 247.d0,248.d0,249.d0,250.d0/
4493 *
4494  DATA (yc(l),l=1,22)/
4495  # 0.10346d1,0.10750d1,0.11151d1,0.11549d1,0.11942d1,0.12329d1,
4496  # 0.12708d1,0.13083d1,0.13456d1,0.13832d1,0.14212d1,
4497  # 0.32401d1,0.32994d1,0.33593d1,0.34200d1,0.34813d1,0.35433d1,
4498  # 0.36061d1,0.36695d1,0.37336d1,0.37984d1,0.38640d1/
4499 *
4500  n= 22
4501  FORALL(l=1:22)
4502  x(l)= xc(l)
4503  y(l)= yc(l)
4504  ENDFORALL
4505 *
4506 *.....First check if u is in the same interval found on the
4507 * last call to Seval.............................................
4508 *
4509  IF ( (i<1) .OR. (i >= n) ) i=1
4510  IF ( (u < x(i)) .OR. (u >= x(i+1)) ) THEN
4511  i=1
4512 *
4513 * binary search
4514 *
4515  j= n+1
4516  DO
4517  k= (i+j)/2
4518  IF (u < x(k)) THEN
4519  j= k
4520  ELSE
4521  i= k
4522  ENDIF
4523  IF (j <= i+1) EXIT
4524  ENDDO
4525  ENDIF
4526 *
4527  dx= u-x(i)
4528 *
4529 * evaluate the spline
4530 *
4531  IF (Present(f)) f= y(i)+dx*(b(i)+dx*(c(i)+dx*d(i)))
4532  IF (Present(fp)) fp= b(i)+dx*(two*c(i) + dx*three*d(i))
4533  IF (Present(fpp)) fpp= two*c(i) + dx*six*d(i)
4534  IF (Present(fppp)) fppp= six*d(i)
4535 *
4536  RETURN
4537 *
4538  END SUBROUTINE hto_seval3singlel
4539 *
4540  END SUBROUTINE hto_gridlow
4541 *
4542 *---------------------------------------------------------------------------------
4543 *
4544  FUNCTION hto_deriv(scal,rhm) RESULT(value)
4545  USE hto_masses
4546  USE hto_acmplx_pro
4547  USE hto_acmplx_rat
4548  USE hto_cmplx_root
4549  USE hto_full_ln
4550  USE hto_qcd
4551  USE hto_set_phys_const
4552  USE hto_units
4553 *
4554  IMPLICIT NONE
4555 *
4556  INTEGER iz
4557  real*8 scal,scals,rhm,ps,xw,xz,lw,lz,ls,xe,lxe,xmu,lxmu,xtau,
4558  # lxtau,xu,lxu,xd,lxd,xc,lxc,xs,lxs,xt,lxt,xb,lxb,rmbs,rmcs,
4559  # xes,xmus,xtaus,xus,xds,xcs,xss,xts,xbs,
4560  # xec,xmuc,xtauc,xuc,xdc,xcc,xsc,xtc,xbc,
4561  # bwis,bzis,fw,fz,
4562  # bxeis,bxmuis,bxtauis,bxuis,bxdis,bxcis,bxsis,bxtis,bxbis,
4563  # bxes,bxmus,bxtaus,bxus,bxds,bxcs,bxss,bxts,bxbs,
4564  # asmur,emc,emb,emt
4565  real*8, dimension(2) :: bs,bw,bz,arg,lbw,lbz,dmz,bzi,bh,lbh,bwi,
4566  # dmw,dmh,sh,bxe,lbxe,bxmu,lbxmu,bxtau,lbxtau,bxu,lbxu,bxd,
4567  # lbxd,bxc,lbxc,bxs,lbxs,bxt,lbxt,bxb,lbxb,runbc,bwic,bzic,
4568  # d2mh,dmwh,dmzh,dmzw,dmww,dmzz,
4569  # bxei,bxmui,bxtaui,bxui,bxdi,bxci,bxsi,bxti,bxbi
4570  real*8, dimension(10,2) :: value
4571 *
4572  INTERFACE
4573  SUBROUTINE hto_initalphas(asord,FR2,MUR,asmur,emc,emb,emt)
4574  USE hto_dzpar
4575  IMPLICIT NONE
4576  INTEGER asord
4577  real*8 fr2,mur,asmur,emc,emb,emt,hto_findalphasr0
4578  EXTERNAL hto_findalphasr0
4579  END SUBROUTINE hto_initalphas
4580  END INTERFACE
4581 *
4582  INTERFACE
4583  FUNCTION hto_alphas(MUR)
4584  USE hto_nffix
4585  USE hto_varflv
4586  USE hto_frrat
4587  USE hto_asinp
4588  USE hto_asfthr
4589  IMPLICIT NONE
4590  real*8 mur,hto_alphas
4591  END FUNCTION hto_alphas
4592  END INTERFACE
4593 *
4594  scals= scal*scal
4595  ps= rhm*rhm
4596 *
4597  xw= (mw*mw)/ps
4598  xz= (mz*mz)/ps
4599  lw= log(xw)
4600  lz= log(xz)
4601  ls= log(ps/scals)
4602  fw= 1.d0-4.d0*xw*(1.d0-3.d0*xw)
4603  fz= 1.d0-4.d0*xz*(1.d0-3.d0*xz)
4604 *
4605  asmur= 0.12018d0
4606  emc= 1.4d0
4607  emb= 4.75d0
4608  emt= mt
4609  iz= 1
4610  CALL hto_initalphas(iz,one,mz,asmur,emc,emb,emt)
4611  als= hto_alphas(scal)
4612  runbc= hto_run_bc(scal)
4613  rmbs= runbc(2)*runbc(2)
4614  rmcs= runbc(1)*runbc(1)
4615 *
4616  xe= (me*me)/ps
4617  lxe= log(xe)
4618  xmu= (mm*mm)/ps
4619  lxmu= log(xmu)
4620  xtau= (mtl*mtl)/ps
4621  lxtau= log(xtau)
4622  xu= (muq*muq)/ps
4623  lxu= log(xu)
4624  xd= (mdq*mdq)/ps
4625  lxd= log(xd)
4626  xc= rmcs/ps
4627  lxc= log(xc)
4628  xs= (msq*msq)/ps
4629  lxs= log(xs)
4630  xt= (mt*mt)/ps
4631  lxt= log(xt)
4632  xb= rmbs/ps
4633  lxb= log(xb)
4634  xes= xe*xe
4635  xmus= xmu*xmu
4636  xtaus= xtau*xtau
4637  xus= xu*xu
4638  xds= xd*xd
4639  xcs= xc*xc
4640  xss= xs*xs
4641  xts= xt*xt
4642  xbs= xb*xb
4643  xec= xes*xe
4644  xmuc= xmus*xmu
4645  xtauc= xtaus*xtau
4646  xuc= xus*xu
4647  xdc= xds*xd
4648  xcc= xcs*xc
4649  xsc= xss*xs
4650  xtc= xts*xt
4651  xbc= xbs*xb
4652 *
4653 * H
4654 *
4655  bs(1)= -3.d0
4656  bs(2)= -eps
4657  bh= (bs(1)).cr.(bs(2))
4658  arg= (bh+co).cq.(bh-co)
4659  IF(arg(2).eq.0.d0) arg(2)= eps
4660  lbh= arg(1).fln.arg(2)
4661 *
4662 *
4663 * W
4664 *
4665  bs(1)= 1.d0-4.d0*(mw*mw)/ps
4666  bs(2)= -eps
4667  bw= (bs(1)).cr.(bs(2))
4668  IF(bw(2).eq.0.d0) bw(2)= -eps
4669  bwi= co.cq.bw
4670  IF(bwi(2).eq.0.d0) bwi(2)= eps
4671  bwis= 1.d0/(1.d0-4.d0*(mw*mw)/ps)
4672  bwic= bwis*bwi
4673  arg= (bw+co).cq.(bw-co)
4674  IF(arg(2).eq.0.d0) arg(2)= eps
4675  lbw= arg(1).fln.arg(2)
4676 *
4677 * Z
4678 *
4679  bs(1)= 1.d0-4.d0*(mz*mz)/ps
4680  bs(2)= -eps
4681  bz= (bs(1)).cr.(bs(2))
4682  IF(bz(2).eq.0.d0) bz(2)= -eps
4683  bzi= co.cq.bz
4684  IF(bzi(2).eq.0.d0) bzi(2)= eps
4685  bzis= 1.d0/(1.d0-4.d0*(mz*mz)/ps)
4686  bzic= bzis*bzi
4687  arg= (bz+co).cq.(bz-co)
4688  IF(arg(2).eq.0.d0) arg(2)= eps
4689  lbz= arg(1).fln.arg(2)
4690 *
4691 * f
4692 *
4693  bs(1)= 1.d0-4.d0*(me*me)/ps
4694  bs(2)= -eps
4695  bxe= (bs(1)).cr.(bs(2))
4696  arg= (bxe+co).cq.(bxe-co)
4697  IF(arg(2).eq.0.d0) arg(2)= eps
4698  lbxe= arg(1).fln.arg(2)
4699 *
4700  bs(1)= 1.d0-4.d0*(mm*mm)/ps
4701  bs(2)= -eps
4702  bxmu= (bs(1)).cr.(bs(2))
4703  arg= (bxmu+co).cq.(bxmu-co)
4704  IF(arg(2).eq.0.d0) arg(2)= eps
4705  lbxmu= arg(1).fln.arg(2)
4706 *
4707  bs(1)= 1.d0-4.d0*(mtl*mtl)/ps
4708  bs(2)= -eps
4709  bxtau= (bs(1)).cr.(bs(2))
4710  arg= (bxtau+co).cq.(bxtau-co)
4711  IF(arg(2).eq.0.d0) arg(2)= eps
4712  lbxtau= arg(1).fln.arg(2)
4713 *
4714  bs(1)= 1.d0-4.d0*(muq*muq)/ps
4715  bs(2)= -eps
4716  bxu= (bs(1)).cr.(bs(2))
4717  arg= (bxu+co).cq.(bxu-co)
4718  IF(arg(2).eq.0.d0) arg(2)= eps
4719  lbxu= arg(1).fln.arg(2)
4720 *
4721  bs(1)= 1.d0-4.d0*(mdq*mdq)/ps
4722  bs(2)= -eps
4723  bxd= (bs(1)).cr.(bs(2))
4724  arg= (bxd+co).cq.(bxd-co)
4725  IF(arg(2).eq.0.d0) arg(2)= eps
4726  lbxd= arg(1).fln.arg(2)
4727 *
4728  bs(1)= 1.d0-4.d0*rmcs/ps
4729  bs(2)= -eps
4730  bxc= (bs(1)).cr.(bs(2))
4731  arg= (bxc+co).cq.(bxc-co)
4732  IF(arg(2).eq.0.d0) arg(2)= eps
4733  lbxc= arg(1).fln.arg(2)
4734 *
4735  bs(1)= 1.d0-4.d0*(msq*msq)/ps
4736  bs(2)= -eps
4737  bxs= (bs(1)).cr.(bs(2))
4738  arg= (bxs+co).cq.(bxs-co)
4739  IF(arg(2).eq.0.d0) arg(2)= eps
4740  lbxs= arg(1).fln.arg(2)
4741 *
4742  bs(1)= 1.d0-4.d0*(mt*mt)/ps
4743  bs(2)= -eps
4744  bxt= (bs(1)).cr.(bs(2))
4745  arg= (bxt+co).cq.(bxt-co)
4746  IF(arg(2).eq.0.d0) arg(2)= eps
4747  lbxt= arg(1).fln.arg(2)
4748 *
4749  bs(1)= 1.d0-4.d0*rmbs/ps
4750  bs(2)= -eps
4751  bxb= (bs(1)).cr.(bs(2))
4752  arg= (bxb+co).cq.(bxb-co)
4753  IF(arg(2).eq.0.d0) arg(2)= eps
4754  lbxb= arg(1).fln.arg(2)
4755 *
4756  bxei= co.cq.bxe
4757  bxmui= co.cq.bxmu
4758  bxtaui= co.cq.bxtau
4759  bxui= co.cq.bxu
4760  bxdi= co.cq.bxd
4761  bxci= co.cq.bxc
4762  bxsi= co.cq.bxs
4763  bxti= co.cq.bxt
4764  bxbi= co.cq.bxb
4765  bxeis= 1.d0/(1.d0-4.d0*(me*me)/ps)
4766  bxmuis= 1.d0/(1.d0-4.d0*(mm*mm)/ps)
4767  bxtauis= 1.d0/(1.d0-4.d0*(mtl*mtl)/ps)
4768  bxuis= 1.d0/(1.d0-4.d0*(muq*muq)/ps)
4769  bxdis= 1.d0/(1.d0-4.d0*(mdq*mdq)/ps)
4770  bxcis= 1.d0/(1.d0-4.d0*rmcs/ps)
4771  bxsis= 1.d0/(1.d0-4.d0*(msq*msq)/ps)
4772  bxtis= 1.d0/(1.d0-4.d0*(mt*mt)/ps)
4773  bxbis= 1.d0/(1.d0-4.d0*rmbs/ps)
4774 *
4775  bxes= 1.d0-4.d0*(me*me)/ps
4776  bxmus= 1.d0-4.d0*(mm*mm)/ps
4777  bxtaus= 1.d0-4.d0*(mtl*mtl)/ps
4778  bxus= 1.d0-4.d0*(muq*muq)/ps
4779  bxds= 1.d0-4.d0*(mdq*mdq)/ps
4780  bxcs= 1.d0-4.d0*rmcs/ps
4781  bxss= 1.d0-4.d0*(msq*msq)/ps
4782  bxts= 1.d0-4.d0*(mt*mt)/ps
4783  bxbs= 1.d0-4.d0*rmbs/ps
4784 *
4785  sh= - 9.d0*(lbh.cp.bh)
4786  # - fz*(lbz.cp.bz)
4787  # - 2.d0*fw*(lbw.cp.bw)
4788  # +co*(
4789  # - (1.d0-6.d0*xz)*lz
4790  # - 2.d0*(1.d0-6.d0*xw)*lw
4791  # - 6.d0*(1.d0-2.d0*xw)*ls
4792  # +2.d0*(9.d0+xw*(-10.d0+24.d0*xw))
4793  # - 2.d0*xz*(5.d0-12.d0*xz)
4794  # +6.d0*xz*ls)
4795 *
4796  sh= sh/(128.d0*xw)*ps+ps/(32.d0*xw)*(
4797  # - 3.d0*xt*bxts*(bxt.cp.lbxt)-3.d0*xt*lxt*co
4798  # - 3.d0*xb*bxbs*(bxb.cp.lbxb)-3.d0*xb*lxb*co
4799  # - 3.d0*xs*bxss*(bxs.cp.lbxs)-3.d0*xs*lxs*co
4800  # - 3.d0*xc*bxcs*(bxc.cp.lbxc)-3.d0*xc*lxc*co
4801  # - 3.d0*xd*bxds*(bxd.cp.lbxd)-3.d0*xd*lxd*co
4802  # - 3.d0*xu*bxus*(bxu.cp.lbxu)-3.d0*xd*lxu*co
4803  # - xtau*bxtaus*(bxtau.cp.lbxtau)-xtau*lxtau*co
4804  # - xmu*bxmus*(bxmu.cp.lbxmu)-xmu*lxmu*co
4805  # - xe*bxes*(bxe.cp.lbxe)-xe*lxe*co+co*(
4806  # - ls*(3.d0*(xt+xb+xs+xc+xd+xu)+xtau+xmu+xe)
4807  # +6.d0*xt*(1.d0-2.d0*xt)
4808  # +6.d0*xb*(1.d0-2.d0*xb)
4809  # +6.d0*xs*(1.d0-2.d0*xs)
4810  # +6.d0*xc*(1.d0-2.d0*xc)
4811  # +6.d0*xd*(1.d0-2.d0*xd)
4812  # +6.d0*xu*(1.d0-2.d0*xu)
4813  # +2.d0*xtau*(1.d0-2.d0*xtau)
4814  # +2.d0*xmu*(1.d0-2.d0*xmu)
4815  # +2.d0*xe*(1.d0-2.d0*xe)))
4816 *
4817  dmh= - 18.d0*(bh.cp.lbh)
4818  # - 2.d0*xz*fz*(lbz.cq.bz)
4819  # - 2.d0*(1.d0-2.d0*xz)*(lbz.cp.bz)
4820  # - 4.d0*xw*fw*(lbw.cq.bw)
4821  # - 4.d0*(1.d0-2.d0*xw)*(lbw.cp.bw)
4822  # +co*(
4823  # - 2.d0*(1.d0-3.d0*xz)*lz
4824  # - 4.d0*(1.d0-3.d0*xw)*lw
4825  # - 12.d0*(1.d0-xw)*ls
4826  # +6.d0*(5.d0-2.d0*xw*(1.d0+2.d0*xw))
4827  # - 6.d0*xz*(1.d0+2.d0*xz)
4828  # +6.d0*xz*ls)
4829 *
4830  dmh= dmh/(128.d0*xw)
4831  # +1.d0/(32.d0*xw)*(
4832  # - 2.d0*xes*bxes*(lbxe.cq.bxe)
4833  # - 2.d0*xmus*bxmus*(lbxmu.cq.bxmu)
4834  # - 2.d0*xtaus*bxtaus*(lbxtau.cq.bxtau)
4835  # - 6.d0*xus*bxus*(lbxu.cq.bxu)
4836  # - 6.d0*xds*bxds*(lbxd.cq.bxd)
4837  # - 6.d0*xcs*bxcs*(lbxc.cq.bxc)
4838  # - 6.d0*xss*bxss*(lbxs.cq.bxs)
4839  # - 6.d0*xts*bxts*(lbxt.cq.bxt)
4840  # - 6.d0*xbs*bxbs*(lbxb.cq.bxb)
4841  # - 3.d0*xt*((lbxt.cp.bxt)+lxt*co)
4842  # - 3.d0*xb*((lbxb.cp.bxb)+lxb*co)
4843  # - 3.d0*xc*((lbxc.cp.bxc)+lxc*co)
4844  # - 3.d0*xs*((lbxs.cp.bxs)+lxs*co)
4845  # - 3.d0*xu*((lbxu.cp.bxu)+lxu*co)
4846  # - 3.d0*xd*((lbxd.cp.bxd)+lxd*co)
4847  # - xtau*((lbxtau.cp.bxtau)+lxtau*co)
4848  # - xmu*((lbxmu.cp.bxmu)+lxmu*co)
4849  # - xe*((lbxe.cp.bxe)+lxe*co)+co*(
4850  # - ls*(3.d0*(xt+xb+xs+xc+xd+xu)+xtau+xmu+xe)
4851  # +3.d0*xt*(2.d0+xts*bxts)
4852  # +3.d0*xb*(2.d0+xbs*bxbs)
4853  # +3.d0*xc*(2.d0+xcs*bxcs)
4854  # +3.d0*xs*(2.d0+xss*bxss)
4855  # +3.d0*xu*(2.d0+xus*bxus)
4856  # +3.d0*xd*(2.d0+xds*bxds)
4857  # +xtau*(2.d0+xtaus*bxtaus)
4858  # +xmu*(2.d0+xmus*bxmus)
4859  # +xe*(2.d0+xes*bxes)))
4860 *
4861  dmw= (9.d0*(bh.cp.lbh)
4862  # +fz*(bz.cp.lbz)
4863  # - xw*fw*(lbw.cq.bw)
4864  # +2.d0*(1.d0-12.d0*xw*xw)*(bw.cp.lbw)
4865  # +co*(
4866  # 2.d0*lw+(1.d0-6.d0*xz)*lz+6.d0*(1.d0-xz)*ls
4867  # - 2.d0*(9.d0-xw*(2.d0+36.d0*xw))
4868  # +2.d0*xz*(5.d0-12.d0*xz)))/(128.d0*xw*xw)
4869  dmw= dmw-1.d0/(32.d0*xw*xw)*(
4870  # - 3.d0*xt*bxts*(bxt.cp.lbxt)-3.d0*xt*lxt*co
4871  # - 3.d0*xb*bxbs*(bxb.cp.lbxb)-3.d0*xb*lxb*co
4872  # - 3.d0*xs*bxss*(bxs.cp.lbxs)-3.d0*xs*lxs*co
4873  # - 3.d0*xc*bxcs*(bxc.cp.lbxc)-3.d0*xc*lxc*co
4874  # - 3.d0*xd*bxds*(bxd.cp.lbxd)-3.d0*xd*lxd*co
4875  # - 3.d0*xu*bxus*(bxu.cp.lbxu)-3.d0*xd*lxu*co
4876  # - xtau*bxtaus*(bxtau.cp.lbxtau)-xtau*lxtau*co
4877  # - xmu*bxmus*(bxmu.cp.lbxmu)-xmu*lxmu*co
4878  # - xe*bxes*(bxe.cp.lbxe)-xe*lxe*co
4879  # +co*(
4880  # - ls*(3.d0*(xt+xb+xs+xc+xd+xu)+xtau+xmu+xe)
4881  # +6.d0*xt*(1.d0-2.d0*xt)
4882  # +6.d0*xb*(1.d0-2.d0*xb)
4883  # +6.d0*xs*(1.d0-2.d0*xs)
4884  # +6.d0*xc*(1.d0-2.d0*xc)
4885  # +6.d0*xd*(1.d0-2.d0*xd)
4886  # +6.d0*xu*(1.d0-2.d0*xu)
4887  # +2.d0*xtau*(1.d0-2.d0*xtau)
4888  # +2.d0*xmu*(1.d0-2.d0*xmu)
4889  # +2.d0*xe*(1.d0-2.d0*xe)))
4890 *
4891  dmz= (-0.25d0+(xz-3.d0*xz))*(lbz.cq.bz)
4892  # +2.d0*(1-6.d0*xz)*(bz.cp.lbz)+
4893  # co*(-4.d0+30.d0*xz+3.d0*(lz+ls))
4894 *
4895  dmz= dmz/(64.d0*xw)
4896 *
4897  d2mh= (2.d0*fw*bwis*co
4898  # +fz*bzis*co
4899  # -9.d0*(lbh.cp.bh)
4900  # +2.d0*xz*xz*fz*(lbz.cp.bzic)
4901  # -2.d0*xz*(1.d0-12.d0*xz)*(lbz.cp.bzi)
4902  # -(lbz.cp.bz)
4903  # +4.d0*xw*xw*fz*(lbw.cp.bwic)
4904  # -4.d0*xw*(1.d0-12.d0*xw)*(lbw.cp.bwi)
4905  # -2.d0*(lbw.cp.bw)
4906  # +co*(
4907  # -6.d0*ls-lz-2.d0*lw+9.d0+4.d0*xw*(1+3.d0*xw)+
4908  # 2.d0*xz*(1.d0+3.d0*xz)))/(64.d0*xw*ps)
4909 *
4910  d2mh= d2mh+1.d0/(32.d0*xw*ps)*(
4911  # 4.d0*xec*(lbxe*bxeis)
4912  # +2.d0*bxei
4913  # -16.d0*xec*(lbxe.cp.bxei)
4914  # +4.d0*xmuc*(lbxmu*bxmuis)
4915  # +2.d0*bxmui
4916  # -16.d0*xmuc*(lbxmu.cp.bxmui)
4917  # +4.d0*xtauc*(lbxtau*bxtauis)
4918  # +2.d0*bxtaui
4919  # -16.d0*xtauc*(lbxtau.cp.bxtaui)
4920  # +12.d0*xuc*(lbxu*bxuis)
4921  # +6.d0*bxui
4922  # -48.d0*xuc*(lbxu.cp.bxui)
4923  # +12.d0*xdc*(lbxd*bxdis)
4924  # +6.d0*bxdi
4925  # -48.d0*xdc*(lbxd.cp.bxdi)
4926  # +12.d0*xcc*(lbxc*bxcis)
4927  # +6.d0*bxci
4928  # -48.d0*xcc*(lbxc.cp.bxci)
4929  # +12.d0*xsc*(lbxs*bxsis)
4930  # +6.d0*bxsi
4931  # -48.d0*xsc*(lbxs.cp.bxsi)
4932  # +12.d0*xtc*(lbxt*bxtis)
4933  # +6.d0*bxti
4934  # -48.d0*xtc*(lbxu.cp.bxti)
4935  # +12.d0*xbc*(lbxb*bxbis)
4936  # +6.d0*bxbi
4937  # -48.d0*xbc*(lbxb.cp.bxbi)+
4938  # co*(
4939  # xec*bxes
4940  # +xmuc*bxmus
4941  # +xtauc*bxtaus
4942  # +xuc*bxus
4943  # +xdc*bxds
4944  # +xcc*bxcs
4945  # +xsc*bxss
4946  # +xtc*bxts
4947  # +xbc*bxbs))
4948 *
4949  dmwh= (2.d0*xw*fw*bwis*co
4950  # +9.d0*(lbh.cp.bh)
4951  # +xz*fz*(lbz.cq.bz)
4952  # +(1.d0-2.d0*xz)*(lbz.cp.bz)
4953  # - 4.d0*xw*xw*fw*(lbw.cp.bwic)
4954  # - xw*(1.d0+xw*xw*(-10.d0+48.d0*xw))*(lbw.cq.bw)
4955  # +2.d0*(lbw.cp.bw)
4956  # +co*(
4957  # +2.d0*lw
4958  # +(1.d0-3.d0*xz)*lz
4959  # +3.d0*(2.d0-xz)*ls
4960  # - (15.d0+xw*(-2.d0+12.d0*xw))
4961  # +3.d0*xz*(1.d0+2.d0*xz)))/(64.d0*xw*xw*ps)
4962 *
4963  dmzh= (2.d0*fz*bzis*co
4964  # - 4.d0*xs*fz*(lbz.cp.bzic)
4965  # - 3.d0*(1.d0+xz*(-6.d0+24.d0*xz))*(lbz.cq.bz)
4966  # +4.d0*(lbz.cp.bz)
4967  # +co*(
4968  # +6.d0*ls
4969  # +6.d0*lz
4970  # - 4.d0*(1.d0+6.d0*xz)))/(128.d0*xw*ps)
4971 *
4972  dmzw= (fz*(lbz.cq.bz)
4973  # - 8.d0*(1.d0-6.d0*xz)*(lbz.cp.bz)
4974  # +co*(
4975  # - 12.d0*ls
4976  # - 12.d0*lz
4977  # +8.d0*(2.d0-15.d0*xz)))/(256.d0*xw*xw*ps)
4978 *
4979  dmww= (xw*(1.d0-4.d0*xw*(1.d0-2.d0*xw))*bwis*co
4980  # - 18.d0*(lbh.cp.bh)
4981  # - 2.d0*fz*(lbz.cp.bz)
4982  # - 2.d0*xw*xw*fw*(lbw.cp.bwic)
4983  # +2.d0*xw*(1.d0-12.d0*xw*xw)*(lbw.cq.bw)
4984  # - 4.d0*(lbw.cp.bw)
4985  # +co*(
4986  # - 4.d0*lw
4987  # - 2.d0*(1.d0-6.d0*xz)*lz
4988  # - 12.d0*(1.d0-xz)*ls
4989  # +4.d0*(9.d0-xw*(1.d0-6.d0*xw))
4990  # - 4.d0*xz*(5.d0-12.d0*xz)))/(128.d0*xw*xw*xw*ps)
4991  dmww= dmww+1.d0/(162.d0*xw*xw*xw*ps)*(
4992  # - 3.d0*xt*bxts*(bxt.cp.lbxt)-3.d0*xt*lxt*co
4993  # - 3.d0*xb*bxbs*(bxb.cp.lbxb)-3.d0*xb*lxb*co
4994  # - 3.d0*xs*bxss*(bxs.cp.lbxs)-3.d0*xs*lxs*co
4995  # - 3.d0*xc*bxcs*(bxc.cp.lbxc)-3.d0*xc*lxc*co
4996  # - 3.d0*xd*bxds*(bxd.cp.lbxd)-3.d0*xd*lxd*co
4997  # - 3.d0*xu*bxus*(bxu.cp.lbxu)-3.d0*xd*lxu*co
4998  # - xtau*bxtaus*(bxtau.cp.lbxtau)-xtau*lxtau*co
4999  # - xmu*bxmus*(bxmu.cp.lbxmu)-xmu*lxmu*co
5000  # - xe*bxes*(bxe.cp.lbxe)-xe*lxe*co+co*(
5001  # - ls*(3.d0*(xt+xb+xs+xc+xd+xu)+xtau+xmu+xe)
5002  # +6.d0*xt*(1.d0-2.d0*xt)
5003  # +6.d0*xb*(1.d0-2.d0*xb)
5004  # +6.d0*xs*(1.d0-2.d0*xs)
5005  # +6.d0*xc*(1.d0-2.d0*xc)
5006  # +6.d0*xd*(1.d0-2.d0*xd)
5007  # +6.d0*xu*(1.d0-2.d0*xu)
5008  # +2.d0*xtau*(1.d0-2.d0*xtau)
5009  # +2.d0*xmu*(1.d0-2.d0*xmu)
5010  # +2.d0*xe*(1.d0-2.d0*xe)))
5011 *
5012  dmzz= (fz*bzis*co
5013  # - 2.d0*xz*fz*(lbz.cp.bzic)
5014  # +8.d0*xz*(1.d0-6.d0*xz)*(lbz.cq.bz)
5015  # - 48.d0*xz*(lbz.cp.bz)
5016  # +4.d0*(1.d0+42.d0*xz)*co)/(256.d0*xw*xz*ps)
5017 *
5018  value(1,1:2)= sh(1:2)
5019  value(2,1:2)= dmh(1:2)
5020  value(3,1:2)= dmw(1:2)
5021  value(4,1:2)= dmz(1:2)
5022  value(5,1:2)= d2mh(1:2)
5023  value(6,1:2)= dmwh(1:2)
5024  value(7,1:2)= dmzh(1:2)
5025  value(8,1:2)= dmzw(1:2)
5026  value(9,1:2)= dmww(1:2)
5027  value(10,1:2)= dmzz(1:2)
5028 *
5029  RETURN
5030 *
5031  END FUNCTION hto_deriv
5032 *
5033 *--------------------------------------------------------------------------
5034 *----- Main ---------------------------------------------------------------
5035 *--------------------------------------------------------------------------
5036 *
5037  SUBROUTINE hto_pole(m,mhb,ghb)
5038  USE hto_masses
5039  USE hto_riemann
5040  USE hto_sp_fun
5041  USE hto_aux_hcp
5042 *
5043  IMPLICIT NONE
5044 *
5045  INTEGER i
5046  real*8 muh,cpgh,gos,mhb,ghb,m,sclaec,expghi,ewc,ghi
5047  real*8, dimension(10,2) :: expc
5048 *
5049  INTERFACE
5050  FUNCTION hto_deriv(scal,rhm) RESULT(value)
5051  USE hto_masses
5052  USE hto_acmplx_pro
5053  USE hto_acmplx_rat
5054  USE hto_cmplx_root
5055  USE hto_full_ln
5056  USE hto_qcd
5057  USE hto_units
5058  IMPLICIT NONE
5059  real*8 scal,rhm
5060  real*8, dimension(10,2) :: value
5061  END FUNCTION hto_deriv
5062  END INTERFACE
5063 *
5064  CALL hto_init_niels
5065 *
5066  muh= m
5067 *
5068  CALL hto_gridht(muh,gos)
5069 *
5070  IF(muh.le.200.d0) THEN
5071  expc= hto_deriv(muh,muh)
5072  ewc= 4.d0*sqrt(2.d0)*1.16637d-5*(mw*mw)/pis
5073  expghi= gos
5074  # -ewc*ewc*expc(2,2)*expc(2,2)*gos
5075  # +0.5d0*ewc*(expc(2,2)/muh-expc(5,2)*muh)*gos*gos
5076  cpgh= expghi
5077  ELSEIF((muh > 200.d0).and.(muh < 240.d0)) THEN
5078  CALL hto_gridlow(muh,ghi)
5079  cpgh= ghi
5080  ELSE
5081  CALL hto_gh(muh,cpgh)
5082  ENDIF
5083 *
5084  mhb= sqrt(muh*muh+cpgh*cpgh)
5085  ghb= mhb/muh*cpgh
5086 *
5087  RETURN
5088 *
5089  END SUBROUTINE hto_pole
5090 *
5091 *---------------------------------------------------------------------------------------
5092 *
5093  SUBROUTINE hto_gh(muh,cpgh)
5094  USE hto_masses
5095  USE hto_aux_hcp
5096  USE hto_aux_hbb
5097  USE hto_cmplx_rootz
5098  USE hto_acmplx_pro
5099  USE hto_acmplx_rat
5100  USE hto_full_ln
5101  USE hto_units
5102  USE hto_ferbos
5103  USE hto_rootw
5104  USE hto_hbb_cp
5105  USE hto_set_phys_const
5106  USE hto_root_find2
5107 *
5108  IMPLICIT NONE
5109 *
5110  INTEGER i
5111  real*8 muh,scals,x1,x2,xacc,tgh,itgh,ghf,ghb,ght,cpgh
5112  real*8, dimension(2) :: cmw,cmz
5113 *
5114  scalec= muh
5115  scals= scalec*scalec
5116 *
5117  xtop= mt*mt/(muh*muh)
5118  xb= mb*mb/(muh*muh)
5119 *
5120  cxe= (me*me)/scals
5121  cxmu= (mm*mm)/scals
5122  cxtau= (mtl*mtl)/scals
5123  cxu= (muq*muq)/scals
5124  cxd= (mdq*mdq)/scals
5125  cxc= (mcq*mcq)/scals
5126  cxs= (msq*msq)/scals
5127  cxt= (mt*mt)/scals
5128  cxb= (mb*mb)/scals
5129 *
5130  cxes= cxe*cxe
5131  cxmus= cxmu*cxmu
5132  cxtaus= cxtau*cxtau
5133  cxus= cxu*cxu
5134  cxds= cxd*cxd
5135  cxcs= cxc*cxc
5136  cxss= cxs*cxs
5137  cxts= cxt*cxt
5138  cxbs= cxb*cxb
5139  cxtmb= cxt-cxb
5140  cxtmbs= cxtmb*cxtmb
5141  cxtmbi= 1.d0/cxtmb
5142 *
5143  cxtc= cxts*cxt
5144  cxbc= cxbs*cxb
5145 *
5146  clxe= log(cxe)
5147  clxmu= log(cxmu)
5148  clxtau= log(cxtau)
5149  clxu= log(cxu)
5150  clxd= log(cxd)
5151  clxc= log(cxc)
5152  clxs= log(cxs)
5153  clxt= log(cxt)
5154  clxb= log(cxb)
5155 *
5156  cmw(1)= swr
5157  cmw(2)= swi
5158  cmz(1)= szr
5159  cmz(2)= szi
5160 *
5161  rcmw= cmw(1).crz.cmw(2)
5162 *
5163  cxw(1)= swr/scals
5164  cxw(2)= swi/scals
5165  cxz(1)= szr/scals
5166  cxz(2)= szi/scals
5167  cxws= cxw.cp.cxw
5168  cxwc= cxws.cp.cxw
5169  cxwi= co.cq.cxw
5170 *
5171  clw= cxw(1).fln.cxw(2)
5172 *
5173  ccts= cmw.cq.cmz
5174  csts= co-ccts
5175  cctq= ccts.cp.ccts
5176  cctvi= cctq.cp.ccts
5177  clcts= ccts(1).fln.ccts(2)
5178 *
5179  xq= cxt+cxb
5180  cxq= cxb+cxc+cxs+cxu+cxd
5181  cxqs= cxbs+cxcs+cxss+cxus+cxds
5182  cxl= cxtau+cxmu+cxe
5183  cxls= cxtaus+cxmus+cxes
5184 *
5185  clwtb= cxtmbs*co+cxws-2.d0*xq*cxw
5186 *
5187  cpw= swr*co+swi*ci
5188  cpz= szr*co+szi*ci
5189 *
5190  g_f= 1.16637d-5
5191 *
5192  muhcp= muh
5193 *
5194  IF(muhcp.ge.900.d0) THEN
5195  x2= 1.d3/muh
5196  ELSEIF((muhcp.gt.600.d0).and.(muhcp.lt.900.d0)) THEN
5197  x2= 4.d2/muh
5198  ELSEIF(muhcp.lt.160.d0) THEN
5199  x2= 1.d0/muh
5200  ELSE
5201  x2= 2.d2/muh
5202  ENDIF
5203  xacc= 1.d-10
5204  DO i=3,0,-1
5205  ifb= i
5206  x1= -1.d0/muh
5207 *
5208  inc= 0
5209  tgh= muh*hto_zeroin(hto_sshh,x1,x2,zero,xacc)
5210 *
5211 * T
5212 *
5213  IF(i==0) THEN
5214 *
5215 * LF
5216 *
5217  ELSEIF(i==1) THEN
5218  ghf= tgh
5219 *
5220 * top
5221 *
5222  ELSEIF(i==2) THEN
5223  ght= tgh
5224 *
5225 * bos
5226 *
5227  ELSEIF(i==3) THEN
5228  ghb= tgh
5229 *
5230  ENDIF
5231 
5232  IF(inc==1) THEN
5233  print*,'---- Warning ------------------------ '
5234  IF(i==0) THEN
5235  print*,' inconsistent interval for tot '
5236  ELSEIF(i==1) THEN
5237  print*,' inconsistent interval for lf '
5238  ELSEIF(i==2) THEN
5239  print*,' inconsistent interval for top '
5240  ELSEIF(i==3) THEN
5241  print*,' inconsistent interval for bos '
5242  ENDIF
5243  print*,'------------------------------------ '
5244  ENDIF
5245  ENDDO
5246 *
5247  xacc= 1.d-20
5248  DO i=3,0,-1
5249  ifb= i
5250  IF(i==0) THEN
5251  x1= 0.9d0*tgh/muh
5252  x2= 1.1d0*tgh/muh
5253  ELSE IF(i==1) THEN
5254  x1= 0.9d0*ghf/muh
5255  x2= 1.1d0*ghf/muh
5256  ELSE IF(i==2) THEN
5257  x1= 0.9d0*ght/muh
5258  x2= 1.1d0*ght/muh
5259  ELSE IF(i==3) THEN
5260  x1= 0.9d0*ghb/muh
5261  x2= 1.1d0*ghb/muh
5262  ENDIF
5263  inc= 0
5264  itgh= muh*hto_zeroin(hto_sshh,x1,x2,zero,xacc)
5265  IF(i==0) THEN
5266 * print 116,itgH
5267  cpgh= itgh
5268  ELSEIF(i==1) THEN
5269 * print 117,itgH
5270  ELSEIF(i==2) THEN
5271 * print 1118,itgH
5272  ELSEIF(i==3) THEN
5273 * print 118,itgH
5274  ENDIF
5275  IF(inc==1) THEN
5276  print*,'---- Warning ------------------------ '
5277  IF(i==0) THEN
5278  print*,' inconsistent interval for tot '
5279  ELSEIF(i==1) THEN
5280  print*,' inconsistent interval for lf '
5281  ELSEIF(i==2) THEN
5282  print*,' inconsistent interval for top '
5283  ELSEIF(i==3) THEN
5284  print*,' inconsistent interval for bos '
5285  ENDIF
5286 * print*,'------------------------------------ '
5287  ENDIF
5288  ENDDO
5289 * print*,' '
5290 * print*,'+++++++++++++++++++++++++++++++++++++++++++++++++++++'
5291 *
5292  116 format(' gH Total [GeV] =',e20.7)
5293  117 format(' gH LightF [GeV] =',e20.5)
5294  1118 format(' gH top [GeV] =',e20.5)
5295  118 format(' gH Bos [GeV] =',e20.5)
5296 *
5297  RETURN
5298 *
5299  END SUBROUTINE hto_gh
5300 *
5301 *---------------------------------------------------------------------------------------
5302 *
5303  MODULE hto_solve_nonlin
5304 
5305 ! Corrections to FUNCTION Enorm - 28 November 2003
5306 
5307  IMPLICIT NONE
5308  PUBLIC :: hto_hbrd,hto_hybrd
5309  CONTAINS
5310  SUBROUTINE hto_hbrd(HTO_FCN,n,x,fvec,epsfcn,tol,info,diag)
5311 *
5312 ! Code converted using TO_F90 by Alan Miller
5313 ! Date: 2003-07-15 Time: 13:27:42
5314 *
5315  INTEGER, INTENT(IN) :: n
5316  real*8, INTENT(IN OUT) :: x(n)
5317  real*8, INTENT(IN OUT) :: fvec(n)
5318  real*8, INTENT(IN) :: epsfcn
5319  real*8, INTENT(IN) :: tol
5320  INTEGER, INTENT(OUT) :: info
5321  real*8, INTENT(OUT) :: diag(n)
5322 *
5323 ! EXTERNAL fcn
5324 *
5325  INTERFACE
5326  SUBROUTINE hto_fcn(N,X,FVEC,IFLAG)
5327  IMPLICIT NONE
5328  INTEGER, INTENT(IN) :: n
5329  real*8, INTENT(IN) :: x(n)
5330  real*8, INTENT(OUT) :: fvec(n)
5331  INTEGER, INTENT(IN OUT) :: iflag
5332  END SUBROUTINE hto_fcn
5333  END INTERFACE
5334 
5335 ! **********
5336 
5337 ! SUBROUTINE HTO_HBRD
5338 
5339 ! THE PURPOSE OF HBRD IS TO FIND A ZERO OF A SYSTEM OF N NONLINEAR
5340 ! FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE POWELL HYBRID METHOD.
5341 ! THIS IS DONE BY USING THE MORE GENERAL NONLINEAR EQUATION SOLVER HYBRD.
5342 ! THE USER MUST PROVIDE A SUBROUTINE HTO_WHICH CALCULATES THE FUNCTIONS.
5343 ! THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
5344 
5345 ! THE SUBROUTINE HTO_STATEMENT IS
5346 
5347 ! SUBROUTINE HTO_HBRD(N,X,FVEC,EPSFCN,TOL,INFO,WA,LWA)
5348 
5349 ! WHERE
5350 
5351 ! FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE HTO_WHICH CALCULATES
5352 ! THE FUNCTIONS. FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT
5353 ! IN THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
5354 
5355 ! SUBROUTINE HTO_FCN(N,X,FVEC,IFLAG)
5356 ! INTEGER N,IFLAG
5357 ! REAL X(N),FVEC(N)
5358 ! ----------
5359 ! CALCULATE THE FUNCTIONS AT X AND RETURN THIS VECTOR IN FVEC.
5360 ! ---------
5361 ! RETURN
5362 ! END
5363 
5364 ! THE VALUE OF IFLAG NOT BE CHANGED BY FCN UNLESS
5365 ! THE USER WANTS TO TERMINATE THE EXECUTION OF HBRD.
5366 ! IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
5367 
5368 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
5369 ! OF FUNCTIONS AND VARIABLES.
5370 
5371 ! X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN AN INITIAL
5372 ! ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X CONTAINS THE
5373 ! FINAL ESTIMATE OF THE SOLUTION VECTOR.
5374 
5375 ! FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
5376 ! THE FUNCTIONS EVALUATED AT THE OUTPUT X.
5377 
5378 ! EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE STEP LENGTH
5379 ! FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS APPROXIMATION ASSUMES
5380 ! THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF EPSFCN.
5381 ! IF EPSFCN IS LESS THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE
5382 ! RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE
5383 ! PRECISION.
5384 
5385 ! TOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS WHEN THE
5386 ! ALGORITHM ESTIMATES THAT THE RELATIVE ERROR BETWEEN X AND THE SOLUTION
5387 ! IS AT MOST TOL.
5388 
5389 ! INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS TERMINATED
5390 ! EXECUTION, INFO IS SET TO THE (NEGATIVE) VALUE OF IFLAG.
5391 ! SEE DESCRIPTION OF FCN. OTHERWISE, INFO IS SET AS FOLLOWS.
5392 
5393 ! INFO= 0 IMPROPER INPUT PARAMETERS.
5394 
5395 ! INFO= 1 ALGORITHM ESTIMATES THAT THE RELATIVE ERROR
5396 ! BETWEEN X AND THE SOLUTION IS AT MOST TOL.
5397 
5398 ! INFO= 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED 200*(N+1).
5399 
5400 ! INFO= 3 TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
5401 ! THE APPROXIMATE SOLUTION X IS POSSIBLE.
5402 
5403 ! INFO= 4 ITERATION IS NOT MAKING GOOD PROGRESS.
5404 
5405 ! SUBPROGRAMS CALLED
5406 
5407 ! USER-SUPPLIED ...... FCN
5408 
5409 ! MINPACK-SUPPLIED ... HYBRD
5410 
5411 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
5412 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
5413 
5414 ! Reference:
5415 ! Powell, M.J.D. 'A hybrid method for nonlinear equations' in Numerical Methods
5416 ! for Nonlinear Algebraic Equations', P.Rabinowitz (editor), Gordon and
5417 ! Breach, London 1970.
5418 ! **********
5419  INTEGER :: maxfev, ml,mode,mu,nfev,nprint
5420  real*8 :: xtol
5421  real*8, PARAMETER :: factor= 100.0d0,zero= 0.0d0
5422 
5423  info= 0
5424 
5425 ! CHECK THE INPUT PARAMETERS FOR ERRORS.
5426 
5427  IF(n <= 0.or.epsfcn < zero.or.tol < zero) GO TO 20
5428 
5429 ! CALL HTO_HYBRD.
5430 
5431  maxfev= 200*(n+1)
5432  xtol= tol
5433  ml= n-1
5434  mu= n-1
5435  mode= 2
5436  nprint= 0
5437  CALL hto_hybrd(hto_fcn,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,diag,
5438  # mode,factor,nprint,info,nfev)
5439  IF(info == 5) info= 4
5440  20 RETURN
5441 
5442 ! LAST CARD OF SUBROUTINE HTO_HBRD.
5443 
5444  END SUBROUTINE hto_hbrd
5445 *
5446 *------------------------------------------------------------------------
5447 *
5448  SUBROUTINE hto_hybrd(HTO_FCN,n,x,fvec,xtol,maxfev,ml,mu,epsfcn,
5449  # diag,mode,factor,nprint,info,nfev)
5450 
5451  INTEGER, INTENT(IN) :: n
5452  real*8, INTENT(IN OUT) :: x(n)
5453  real*8, INTENT(IN OUT) :: fvec(n)
5454  real*8, INTENT(IN) :: xtol
5455  INTEGER, INTENT(IN OUT) :: maxfev
5456  INTEGER, INTENT(IN OUT) :: ml
5457  INTEGER, INTENT(IN) :: mu
5458  real*8, INTENT(IN) :: epsfcn
5459  real*8, INTENT(OUT) :: diag(n)
5460  INTEGER, INTENT(IN) :: mode
5461  real*8, INTENT(IN) :: factor
5462  INTEGER, INTENT(IN OUT) :: nprint
5463  INTEGER, INTENT(OUT) :: info
5464  INTEGER, INTENT(OUT) :: nfev
5465 
5466 ! EXTERNAL fcn
5467 
5468  INTERFACE
5469  SUBROUTINE hto_fcn(N,X,FVEC,IFLAG)
5470  IMPLICIT NONE
5471  INTEGER, INTENT(IN) :: n
5472  real*8, INTENT(IN) :: x(n)
5473  real*8, INTENT(OUT) :: fvec(n)
5474  INTEGER, INTENT(IN OUT) :: iflag
5475  END SUBROUTINE hto_fcn
5476  END INTERFACE
5477 
5478 ! **********
5479 
5480 ! SUBROUTINE HTO_HYBRD
5481 
5482 ! THE PURPOSE OF HYBRD IS TO FIND A ZERO OF A SYSTEM OF N NONLINEAR
5483 ! FUNCTIONS IN N VARIABLES BY A MODIFICATION OF THE POWELL HYBRID METHOD.
5484 ! THE USER MUST PROVIDE A SUBROUTINE HTO_WHICH CALCULATES THE FUNCTIONS.
5485 ! THE JACOBIAN IS THEN CALCULATED BY A FORWARD-DIFFERENCE APPROXIMATION.
5486 
5487 ! THE SUBROUTINE HTO_STATEMENT IS
5488 
5489 ! SUBROUTINE HTO_HYBRD(FCN,N,X,FVEC,XTOL,MAXFEV,ML,MU,EPSFCN,
5490 ! DIAG,MODE,FACTOR,NPRINT,INFO,NFEV,FJAC,
5491 ! LDFJAC,R,LR,QTF,WA1,WA2,WA3,WA4)
5492 
5493 ! WHERE
5494 
5495 ! FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE HTO_WHICH CALCULATES
5496 ! THE FUNCTIONS. FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN
5497 ! THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
5498 
5499 ! SUBROUTINE HTO_FCN(N, X, FVEC, IFLAG)
5500 ! INTEGER N, IFLAG
5501 ! REAL X(N), FVEC(N)
5502 ! ----------
5503 ! CALCULATE THE FUNCTIONS AT X AND
5504 ! RETURN THIS VECTOR IN FVEC.
5505 ! ---------
5506 ! RETURN
5507 ! END
5508 
5509 ! THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
5510 ! THE USER WANTS TO TERMINATE EXECUTION OF HYBRD.
5511 ! IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
5512 
5513 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
5514 ! OF FUNCTIONS AND VARIABLES.
5515 
5516 ! X IS AN ARRAY OF LENGTH N. ON INPUT X MUST CONTAIN AN INITIAL
5517 ! ESTIMATE OF THE SOLUTION VECTOR. ON OUTPUT X CONTAINS THE FINAL
5518 ! ESTIMATE OF THE SOLUTION VECTOR.
5519 
5520 ! FVEC IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
5521 ! THE FUNCTIONS EVALUATED AT THE OUTPUT X.
5522 
5523 ! XTOL IS A NONNEGATIVE INPUT VARIABLE. TERMINATION OCCURS WHEN THE
5524 ! RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES IS AT MOST XTOL.
5525 
5526 ! MAXFEV IS A POSITIVE INTEGER INPUT VARIABLE. TERMINATION OCCURS WHEN
5527 ! THE NUMBER OF CALLS TO FCN IS AT LEAST MAXFEV BY THE END OF AN
5528 ! ITERATION.
5529 
5530 ! ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES THE
5531 ! NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE JACOBIAN MATRIX.
5532 ! IF THE JACOBIAN IS NOT BANDED, SET ML TO AT LEAST N - 1.
5533 
5534 ! MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES THE NUMBER
5535 ! OF SUPERDIAGONALS WITHIN THE BAND OF THE JACOBIAN MATRIX.
5536 ! IF THE JACOBIAN IS NOT BANDED, SET MU TO AT LEAST N - 1.
5537 
5538 ! EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE STEP LENGTH
5539 ! FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS APPROXIMATION
5540 ! ASSUMES THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE ORDER
5541 ! OF EPSFCN. IF EPSFCN IS LESS THAN THE MACHINE PRECISION,
5542 ! IT IS ASSUMED THAT THE RELATIVE ERRORS IN THE FUNCTIONS ARE OF THE
5543 ! ORDER OF THE MACHINE PRECISION.
5544 
5545 ! DIAG IS AN ARRAY OF LENGTH N. IF MODE= 1 (SEE BELOW),
5546 ! DIAG IS INTERNALLY SET. IF MODE= 2, DIAG MUST CONTAIN POSITIVE
5547 ! ENTRIES THAT SERVE AS MULTIPLICATIVE SCALE FACTORS FOR THE
5548 ! VARIABLES.
5549 
5550 ! MODE IS AN INTEGER INPUT VARIABLE. IF MODE= 1, THE VARIABLES WILL BE
5551 ! SCALED INTERNALLY. IF MODE= 2, THE SCALING IS SPECIFIED BY THE
5552 ! INPUT DIAG. OTHER VALUES OF MODE ARE EQUIVALENT TO MODE= 1.
5553 
5554 ! FACTOR IS A POSITIVE INPUT VARIABLE USED IN DETERMINING THE
5555 ! INITIAL STEP BOUND. THIS BOUND IS SET TO THE PRODUCT OF
5556 ! FACTOR AND THE EUCLIDEAN NORM OF DIAG*X IF NONZERO, OR ELSE
5557 ! TO FACTOR ITSELF. IN MOST CASES FACTOR SHOULD LIE IN THE
5558 ! INTERVAL (.1,100.). 100. IS A GENERALLY RECOMMENDED VALUE.
5559 
5560 ! NPRINT IS AN INTEGER INPUT VARIABLE THAT ENABLES CONTROLLED
5561 ! PRINTING OF ITERATES IF IT IS POSITIVE. IN THIS CASE,
5562 ! FCN IS CALLED WITH IFLAG= 0 AT THE BEGINNING OF THE FIRST
5563 ! ITERATION AND EVERY NPRINT ITERATIONS THEREAFTER AND
5564 ! IMMEDIATELY PRIOR TO RETURN, WITH X AND FVEC AVAILABLE
5565 ! FOR PRINTING. IF NPRINT IS NOT POSITIVE, NO SPECIAL CALLS
5566 ! OF FCN WITH IFLAG= 0 ARE MADE.
5567 
5568 ! INFO IS AN INTEGER OUTPUT VARIABLE. IF THE USER HAS
5569 ! TERMINATED EXECUTION, INFO IS SET TO THE (NEGATIVE)
5570 ! VALUE OF IFLAG. SEE DESCRIPTION OF FCN. OTHERWISE,
5571 ! INFO IS SET AS FOLLOWS.
5572 
5573 ! INFO= 0 IMPROPER INPUT PARAMETERS.
5574 
5575 ! INFO= 1 RELATIVE ERROR BETWEEN TWO CONSECUTIVE ITERATES
5576 ! IS AT MOST XTOL.
5577 
5578 ! INFO= 2 NUMBER OF CALLS TO FCN HAS REACHED OR EXCEEDED MAXFEV.
5579 
5580 ! INFO= 3 XTOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN
5581 ! THE APPROXIMATE SOLUTION X IS POSSIBLE.
5582 
5583 ! INFO= 4 ITERATION IS NOT MAKING GOOD PROGRESS, AS
5584 ! MEASURED BY THE IMPROVEMENT FROM THE LAST
5585 ! FIVE JACOBIAN EVALUATIONS.
5586 
5587 ! INFO= 5 ITERATION IS NOT MAKING GOOD PROGRESS, AS MEASURED BY
5588 ! THE IMPROVEMENT FROM THE LAST TEN ITERATIONS.
5589 
5590 ! NFEV IS AN INTEGER OUTPUT VARIABLE SET TO THE NUMBER OF CALLS TO FCN.
5591 
5592 ! FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE ORTHOGONAL MATRIX Q
5593 ! PRODUCED BY THE QR FACTORIZATION OF THE FINAL APPROXIMATE JACOBIAN.
5594 
5595 ! LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
5596 ! WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
5597 
5598 ! R IS AN OUTPUT ARRAY OF LENGTH LR WHICH CONTAINS THE
5599 ! UPPER TRIANGULAR MATRIX PRODUCED BY THE QR FACTORIZATION
5600 ! OF THE FINAL APPROXIMATE JACOBIAN, STORED ROWWISE.
5601 
5602 ! LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN (N*(N+1))/2.
5603 
5604 ! QTF IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS
5605 ! THE VECTOR (Q TRANSPOSE)*FVEC.
5606 
5607 ! WA1, WA2, WA3, AND WA4 ARE WORK ARRAYS OF LENGTH N.
5608 
5609 ! SUBPROGRAMS CALLED
5610 
5611 ! USER-SUPPLIED ...... FCN
5612 
5613 ! MINPACK-SUPPLIED ... DOGLEG,SPMPAR,ENORM,FDJAC1,
5614 ! QFORM,QRFAC,R1MPYQ,R1UPDT
5615 
5616 ! FORTRAN-SUPPLIED ... ABS,MAX,MIN,MIN,MOD
5617 
5618 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
5619 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
5620 
5621 ! **********
5622 
5623  INTEGER :: i,iflag,iter,j,jm1,l,lr,msum,ncfail,ncsuc,
5624  # nslow1,nslow2
5625  INTEGER :: iwa(1)
5626  LOGICAL :: jeval,sing
5627  real*8 :: actred,delta,epsmch,fnorm,fnorm1,pnorm,prered,
5628  # ratio,sum,temp,xnorm
5629  real*8, PARAMETER :: one= 1.0d0,p1= 0.1d0,p5= 0.5d0,
5630  # p001= 0.001d0,p0001= 0.0001d0,zero= 0.0d0
5631  real*8 :: fjac(n,n),r(n*(n+1)/2),qtf(n),wa1(n),wa2(n),
5632  # wa3(n),wa4(n)
5633 *
5634  epsmch= epsilon(1.0d0)
5635  info= 0
5636  iflag= 0
5637  nfev= 0
5638  lr= n*(n+1)/2
5639  IF(n > 0.and.xtol >= zero.and.maxfev > 0.and.ml >= 0
5640  # .and.mu >= 0.and.factor > zero ) THEN
5641  IF(mode == 2) THEN
5642  diag(1:n)= one
5643  ENDIF
5644  iflag= 1
5645  CALL hto_fcn(n,x,fvec,iflag)
5646  nfev= 1
5647  IF(iflag >= 0) THEN
5648  fnorm= hto_enorm(n,fvec)
5649  msum= min(ml+mu+1,n)
5650  iter= 1
5651  ncsuc= 0
5652  ncfail= 0
5653  nslow1= 0
5654  nslow2= 0
5655  20 jeval= .true.
5656  iflag= 2
5657  CALL hto_fdjac1(hto_fcn,n,x,fvec,fjac,n,iflag,ml,mu,epsfcn,
5658  # wa1,wa2)
5659  nfev= nfev+msum
5660  IF(iflag >= 0) THEN
5661  CALL hto_qrfac(n,n,fjac,n,.false.,iwa,1,wa1,wa2,wa3)
5662  IF(iter == 1) THEN
5663  IF(mode /= 2) THEN
5664  DO j= 1,n
5665  diag(j)= wa2(j)
5666  IF(wa2(j) == zero) diag(j)= one
5667  ENDDO
5668  ENDIF
5669  wa3(1:n)= diag(1:n)*x(1:n)
5670  xnorm= hto_enorm(n,wa3)
5671  delta= factor*xnorm
5672  IF(delta == zero) delta= factor
5673  ENDIF
5674  qtf(1:n)= fvec(1:n)
5675  DO j= 1,n
5676  IF(fjac(j,j) /= zero) THEN
5677  sum= zero
5678  DO i= j,n
5679  sum= sum+fjac(i,j)*qtf(i)
5680  ENDDO
5681  temp= -sum/fjac(j,j)
5682  DO i= j,n
5683  qtf(i)= qtf(i)+fjac(i,j)*temp
5684  ENDDO
5685  ENDIF
5686  ENDDO
5687  sing= .false.
5688  DO j= 1,n
5689  l= j
5690  jm1= j-1
5691  IF(jm1 >= 1) THEN
5692  DO i= 1,jm1
5693  r(l)= fjac(i,j)
5694  l= l+n-i
5695  ENDDO
5696  ENDIF
5697  r(l)= wa1(j)
5698  IF(wa1(j) == zero) sing= .true.
5699  ENDDO
5700  CALL hto_qform(n,n,fjac,n,wa1)
5701  IF(mode /= 2) THEN
5702  DO j= 1,n
5703  diag(j)= max(diag(j),wa2(j))
5704  ENDDO
5705  ENDIF
5706  120 IF(nprint > 0) THEN
5707  iflag= 0
5708  IF(mod(iter-1,nprint) == 0) CALL hto_fcn(n,x,fvec,iflag)
5709  IF(iflag < 0) GO TO 190
5710  ENDIF
5711  CALL hto_dogleg(n,r,lr,diag,qtf,delta,wa1,wa2,wa3)
5712  DO j= 1,n
5713  wa1(j)= -wa1(j)
5714  wa2(j)= x(j)+wa1(j)
5715  wa3(j)= diag(j)*wa1(j)
5716  ENDDO
5717  pnorm= hto_enorm(n,wa3)
5718  IF(iter == 1) delta= min(delta,pnorm)
5719  iflag= 1
5720  CALL hto_fcn(n,wa2,wa4,iflag)
5721  nfev= nfev+1
5722  IF(iflag >= 0) THEN
5723  fnorm1= hto_enorm(n,wa4)
5724  actred= -one
5725  IF(fnorm1 < fnorm) actred= one-(fnorm1/fnorm)**2
5726  l= 1
5727  DO i= 1,n
5728  sum= zero
5729  DO j= i,n
5730  sum= sum+r(l)*wa1(j)
5731  l= l+1
5732  ENDDO
5733  wa3(i)= qtf(i)+sum
5734  ENDDO
5735  temp= hto_enorm(n,wa3)
5736  prered= zero
5737  IF(temp < fnorm) prered= one-(temp/fnorm)**2
5738  ratio= zero
5739  IF(prered > zero) ratio= actred/prered
5740  IF(ratio < p1) THEN
5741  ncsuc= 0
5742  ncfail= ncfail+1
5743  delta= p5*delta
5744  ELSE
5745  ncfail= 0
5746  ncsuc= ncsuc+1
5747  IF(ratio >= p5.or.ncsuc > 1) delta= max(delta,pnorm/p5)
5748  IF(abs(ratio-one) <= p1) delta= pnorm/p5
5749  ENDIF
5750  IF(ratio >= p0001) THEN
5751  DO j= 1,n
5752  x(j)= wa2(j)
5753  wa2(j)= diag(j)*x(j)
5754  fvec(j)= wa4(j)
5755  ENDDO
5756  xnorm= hto_enorm(n,wa2)
5757  fnorm= fnorm1
5758  iter= iter+1
5759  ENDIF
5760  nslow1= nslow1+1
5761  IF(actred >= p001) nslow1= 0
5762  IF(jeval) nslow2= nslow2+1
5763  IF(actred >= p1) nslow2= 0
5764  IF(delta <= xtol*xnorm.or.fnorm == zero) info= 1
5765  IF(info == 0) THEN
5766  IF(nfev >= maxfev) info= 2
5767  IF(p1*max(p1*delta,pnorm) <= epsmch*xnorm) info= 3
5768  IF(nslow2 == 5) info= 4
5769  IF(nslow1 == 10) info= 5
5770  IF(info == 0) THEN
5771  IF(ncfail /= 2) THEN
5772  DO j= 1,n
5773  sum= zero
5774  DO i= 1,n
5775  sum= sum+fjac(i,j)*wa4(i)
5776  ENDDO
5777  wa2(j)= (sum-wa3(j))/pnorm
5778  wa1(j)= diag(j)*((diag(j)*wa1(j))/pnorm)
5779  IF(ratio >= p0001) qtf(j)= sum
5780  ENDDO
5781  CALL hto_r1updt(n,n,r,lr,wa1,wa2,wa3,sing)
5782  CALL hto_r1mpyq(n,n,fjac,n,wa2,wa3)
5783  CALL hto_r1mpyq(1,n,qtf,1,wa2,wa3)
5784  jeval= .false.
5785  GO TO 120
5786  ENDIF
5787  GO TO 20
5788  ENDIF
5789  ENDIF
5790  ENDIF
5791  ENDIF
5792  ENDIF
5793  ENDIF
5794 *
5795  190 IF(iflag < 0) info= iflag
5796  iflag= 0
5797  IF(nprint > 0) CALL hto_fcn(n,x,fvec,iflag)
5798  RETURN
5799 *
5800  END SUBROUTINE hto_hybrd
5801 *
5802 *--------------------------------------------------------------------
5803 *
5804  SUBROUTINE hto_dogleg(n,r,lr,diag,qtb,delta,x,wa1,wa2)
5805 *
5806  INTEGER, INTENT(IN) :: n
5807  INTEGER, INTENT(IN) :: lr
5808  real*8, INTENT(IN) :: r(lr)
5809  real*8, INTENT(IN) :: diag(n)
5810  real*8, INTENT(IN) :: qtb(n)
5811  real*8, INTENT(IN) :: delta
5812  real*8, INTENT(IN OUT) :: x(n)
5813  real*8, INTENT(OUT) :: wa1(n)
5814  real*8, INTENT(OUT) :: wa2(n)
5815 
5816 ! **********
5817 
5818 ! SUBROUTINE HTO_DOGLEG
5819 
5820 ! GIVEN AN M BY N MATRIX A, AN N BY N NONSINGULAR DIAGONAL
5821 ! MATRIX D, AN M-VECTOR B, AND A POSITIVE NUMBER DELTA, THE
5822 ! PROBLEM IS TO DETERMINE THE CONVEX COMBINATION X OF THE
5823 ! GAUSS-NEWTON AND SCALED GRADIENT DIRECTIONS THAT MINIMIZES
5824 ! (A*X - B) IN THE LEAST SQUARES SENSE, SUBJECT TO THE
5825 ! RESTRICTION THAT THE EUCLIDEAN NORM OF D*X BE AT MOST DELTA.
5826 
5827 ! THIS SUBROUTINE HTO_COMPLETES THE SOLUTION OF THE PROBLEM
5828 ! IF IT IS PROVIDED WITH THE NECESSARY INFORMATION FROM THE
5829 ! QR FACTORIZATION OF A. THAT IS, IF A= Q*R, WHERE Q HAS
5830 ! ORTHOGONAL COLUMNS AND R IS AN UPPER TRIANGULAR MATRIX,
5831 ! THEN DOGLEG EXPECTS THE FULL UPPER TRIANGLE OF R AND
5832 ! THE FIRST N COMPONENTS OF (Q TRANSPOSE)*B.
5833 
5834 ! THE SUBROUTINE HTO_STATEMENT IS
5835 
5836 ! SUBROUTINE HTO_DOGLEG(N,R,LR,DIAG,QTB,DELTA,X,WA1,WA2)
5837 
5838 ! WHERE
5839 
5840 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE ORDER OF R.
5841 
5842 ! R IS AN INPUT ARRAY OF LENGTH LR WHICH MUST CONTAIN THE UPPER
5843 ! TRIANGULAR MATRIX R STORED BY ROWS.
5844 
5845 ! LR IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
5846 ! (N*(N+1))/2.
5847 
5848 ! DIAG IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
5849 ! DIAGONAL ELEMENTS OF THE MATRIX D.
5850 
5851 ! QTB IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE FIRST
5852 ! N ELEMENTS OF THE VECTOR (Q TRANSPOSE)*B.
5853 
5854 ! DELTA IS A POSITIVE INPUT VARIABLE WHICH SPECIFIES AN UPPER
5855 ! BOUND ON THE EUCLIDEAN NORM OF D*X.
5856 
5857 ! X IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE DESIRED
5858 ! CONVEX COMBINATION OF THE GAUSS-NEWTON DIRECTION AND THE
5859 ! SCALED GRADIENT DIRECTION.
5860 
5861 ! WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N.
5862 
5863 ! SUBPROGRAMS CALLED
5864 
5865 ! MINPACK-SUPPLIED ... SPMPAR,ENORM
5866 
5867 ! FORTRAN-SUPPLIED ... ABS,MAX,MIN,SQRT
5868 
5869 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
5870 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
5871 
5872 ! **********
5873 
5874  INTEGER :: i,j,jj,jp1,k,l
5875  real*8 :: alpha,bnorm,epsmch,gnorm,qnorm,sgnorm,sum,temp
5876 *
5877  epsmch= epsilon(1.0d0)
5878  jj= (n*(n+1))/2+1
5879  DO k= 1,n
5880  j= n-k+1
5881  jp1= j+1
5882  jj= jj-k
5883  l= jj+1
5884  sum= 0.0
5885  IF(n >= jp1) THEN
5886  DO i= jp1,n
5887  sum= sum+r(l)*x(i)
5888  l= l+1
5889  ENDDO
5890  ENDIF
5891  temp= r(jj)
5892  IF(temp == 0.0) THEN
5893  l= j
5894  DO i= 1,j
5895  temp= max(temp,abs(r(l)))
5896  l= l+n-i
5897  ENDDO
5898  temp= epsmch*temp
5899  IF(temp == 0.0) temp= epsmch
5900  ENDIF
5901  x(j)= (qtb(j)-sum)/temp
5902  ENDDO
5903 *
5904  DO j= 1,n
5905  wa1(j)= 0.0
5906  wa2(j)= diag(j)*x(j)
5907  ENDDO
5908  qnorm= hto_enorm(n,wa2)
5909 *
5910  IF(qnorm > delta) THEN
5911  l= 1
5912  DO j= 1,n
5913  temp= qtb(j)
5914  DO i= j,n
5915  wa1(i)= wa1(i)+r(l)*temp
5916  l= l+1
5917  ENDDO
5918  wa1(j)= wa1(j)/diag(j)
5919  ENDDO
5920  gnorm= hto_enorm(n,wa1)
5921  sgnorm= 0.0
5922  alpha= delta/qnorm
5923  IF(gnorm /= 0.0) THEN
5924  DO j= 1,n
5925  wa1(j)= (wa1(j)/gnorm)/diag(j)
5926  ENDDO
5927  l= 1
5928  DO j= 1,n
5929  sum= 0.0
5930  DO i= j,n
5931  sum= sum+r(l)*wa1(i)
5932  l= l+1
5933  ENDDO
5934  wa2(j)= sum
5935  ENDDO
5936  temp= hto_enorm(n,wa2)
5937  sgnorm= (gnorm/temp)/temp
5938  alpha= 0.0
5939  IF(sgnorm < delta) THEN
5940  bnorm= hto_enorm(n,qtb)
5941  temp= (bnorm/gnorm)*(bnorm/qnorm)*(sgnorm/delta)
5942  temp= temp-(delta/qnorm)*(sgnorm/delta)**2+
5943  # sqrt((temp-(delta/qnorm))**2+(1.0d0-(delta/qnorm)**2)*
5944  # (1.0d0-( sgnorm/delta)**2))
5945  alpha= ((delta/qnorm)*(1.0d0-(sgnorm/delta)**2))/temp
5946  ENDIF
5947  ENDIF
5948  temp= (1.0d0-alpha)*min(sgnorm,delta)
5949  DO j= 1,n
5950  x(j)= temp*wa1(j)+alpha*x(j)
5951  ENDDO
5952  ENDIF
5953 *
5954  RETURN
5955 *
5956  END SUBROUTINE hto_dogleg
5957 *
5958 *-------------------------------------------------------------------
5959 *
5960  SUBROUTINE hto_fdjac1(HTO_FCN,n,x,fvec,fjac,ldfjac,iflag,ml,mu,
5961  # epsfcn,wa1,wa2)
5962 *
5963  INTEGER, INTENT(IN) :: n
5964  REAL*8, INTENT(IN OUT) :: x(n)
5965  real*8, INTENT(IN) :: fvec(n)
5966  INTEGER, INTENT(IN) :: ldfjac
5967  real*8, INTENT(OUT) :: fjac(ldfjac,n)
5968  INTEGER, INTENT(IN OUT) :: iflag
5969  INTEGER, INTENT(IN) :: ml
5970  INTEGER, INTENT(IN) :: mu
5971  real*8, INTENT(IN) :: epsfcn
5972  real*8, INTENT(IN OUT) :: wa1(n)
5973  real*8, INTENT(OUT) :: wa2(n)
5974 
5975 ! EXTERNAL fcn
5976 
5977  INTERFACE
5978  SUBROUTINE hto_fcn(N,X,FVEC,IFLAG)
5979  IMPLICIT NONE
5980  INTEGER, PARAMETER :: dp= selected_real_kind(14,60)
5981  INTEGER,INTENT(IN) :: n
5982  real*8,INTENT(IN) :: x(n)
5983  real*8, INTENT(OUT) :: fvec(n)
5984  INTEGER, INTENT(IN OUT) :: iflag
5985  END SUBROUTINE hto_fcn
5986  END INTERFACE
5987 
5988 ! **********
5989 
5990 ! SUBROUTINE HTO_FDJAC1
5991 
5992 ! THIS SUBROUTINE HTO_COMPUTES A FORWARD-DIFFERENCE APPROXIMATION TO THE N BY N
5993 ! JACOBIAN MATRIX ASSOCIATED WITH A SPECIFIED PROBLEM OF N FUNCTIONS IN N
5994 ! VARIABLES. IF THE JACOBIAN HAS A BANDED FORM, THEN FUNCTION EVALUATIONS
5995 ! ARE SAVED BY ONLY APPROXIMATING THE NONZERO TERMS.
5996 
5997 ! THE SUBROUTINE HTO_STATEMENT IS
5998 
5999 ! SUBROUTINE HTO_FDJAC1(FCN,N,X,FVEC,FJAC,LDFJAC,IFLAG,ML,MU,EPSFCN,
6000 ! WA1,WA2)
6001 
6002 ! WHERE
6003 
6004 ! FCN IS THE NAME OF THE USER-SUPPLIED SUBROUTINE HTO_WHICH CALCULATES
6005 ! THE FUNCTIONS. FCN MUST BE DECLARED IN AN EXTERNAL STATEMENT IN
6006 ! THE USER CALLING PROGRAM, AND SHOULD BE WRITTEN AS FOLLOWS.
6007 
6008 ! SUBROUTINE HTO_FCN(N,X,FVEC,IFLAG)
6009 ! INTEGER N,IFLAG
6010 ! REAL X(N),FVEC(N)
6011 ! ----------
6012 ! CALCULATE THE FUNCTIONS AT X AND
6013 ! RETURN THIS VECTOR IN FVEC.
6014 ! ----------
6015 ! RETURN
6016 ! END
6017 
6018 ! THE VALUE OF IFLAG SHOULD NOT BE CHANGED BY FCN UNLESS
6019 ! THE USER WANTS TO TERMINATE EXECUTION OF FDJAC1.
6020 ! IN THIS CASE SET IFLAG TO A NEGATIVE INTEGER.
6021 
6022 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
6023 ! OF FUNCTIONS AND VARIABLES.
6024 
6025 ! X IS AN INPUT ARRAY OF LENGTH N.
6026 
6027 ! FVEC IS AN INPUT ARRAY OF LENGTH N WHICH MUST CONTAIN THE
6028 ! FUNCTIONS EVALUATED AT X.
6029 
6030 ! FJAC IS AN OUTPUT N BY N ARRAY WHICH CONTAINS THE
6031 ! APPROXIMATION TO THE JACOBIAN MATRIX EVALUATED AT X.
6032 
6033 ! LDFJAC IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN N
6034 ! WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY FJAC.
6035 
6036 ! IFLAG IS AN INTEGER VARIABLE WHICH CAN BE USED TO TERMINATE
6037 ! THE EXECUTION OF FDJAC1. SEE DESCRIPTION OF FCN.
6038 
6039 ! ML IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
6040 ! THE NUMBER OF SUBDIAGONALS WITHIN THE BAND OF THE
6041 ! JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
6042 ! ML TO AT LEAST N - 1.
6043 
6044 ! EPSFCN IS AN INPUT VARIABLE USED IN DETERMINING A SUITABLE
6045 ! STEP LENGTH FOR THE FORWARD-DIFFERENCE APPROXIMATION. THIS
6046 ! APPROXIMATION ASSUMES THAT THE RELATIVE ERRORS IN THE
6047 ! FUNCTIONS ARE OF THE ORDER OF EPSFCN. IF EPSFCN IS LESS
6048 ! THAN THE MACHINE PRECISION, IT IS ASSUMED THAT THE RELATIVE
6049 ! ERRORS IN THE FUNCTIONS ARE OF THE ORDER OF THE MACHINE PRECISION.
6050 
6051 ! MU IS A NONNEGATIVE INTEGER INPUT VARIABLE WHICH SPECIFIES
6052 ! THE NUMBER OF SUPERDIAGONALS WITHIN THE BAND OF THE
6053 ! JACOBIAN MATRIX. IF THE JACOBIAN IS NOT BANDED, SET
6054 ! MU TO AT LEAST N - 1.
6055 
6056 ! WA1 AND WA2 ARE WORK ARRAYS OF LENGTH N. IF ML + MU + 1 IS AT
6057 ! LEAST N, THEN THE JACOBIAN IS CONSIDERED DENSE, AND WA2 IS
6058 ! NOT REFERENCED.
6059 
6060 ! SUBPROGRAMS CALLED
6061 
6062 ! MINPACK-SUPPLIED ... SPMPAR
6063 
6064 ! FORTRAN-SUPPLIED ... ABS,MAX,SQRT
6065 
6066 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6067 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
6068 
6069 ! **********
6070 *
6071 
6072  INTEGER :: i,j,k,msum
6073  REAL*8 :: eps,epsmch,h,temp
6074  real*8, PARAMETER :: zero= 0.0d0
6075 *
6076  epsmch= epsilon(1.0d0)
6077  eps= sqrt(max(epsfcn,epsmch))
6078  msum= ml+mu+1
6079  IF(msum >= n) THEN
6080  DO j= 1,n
6081  temp= x(j)
6082  h= eps*abs(temp)
6083  IF(h == zero) h= eps
6084  x(j)= temp+h
6085  CALL hto_fcn(n,x,wa1,iflag)
6086  IF(iflag < 0) EXIT
6087  x(j)= temp
6088  DO i= 1,n
6089  fjac(i,j)= (wa1(i)-fvec(i))/h
6090  ENDDO
6091  ENDDO
6092  ELSE
6093  DO k= 1,msum
6094  DO j= k,n,msum
6095  wa2(j)= x(j)
6096  h= eps*abs(wa2(j))
6097  IF(h == zero) h= eps
6098  x(j)= wa2(j)+h
6099  ENDDO
6100  CALL hto_fcn(n,x,wa1,iflag)
6101  IF(iflag < 0) EXIT
6102  DO j= k,n,msum
6103  x(j)= wa2(j)
6104  h= eps*abs(wa2(j))
6105  IF(h == zero) h= eps
6106  DO i= 1,n
6107  fjac(i,j)= zero
6108  IF(i >= j-mu.and.i <= j+ml) fjac(i,j)= (wa1(i)-fvec(i))/h
6109  ENDDO
6110  ENDDO
6111  ENDDO
6112  ENDIF
6113 *
6114  RETURN
6115 *
6116  END SUBROUTINE hto_fdjac1
6117 *
6118 *-------------------------------------------------------------------
6119 *
6120  SUBROUTINE hto_qform(m,n,q,ldq,wa)
6121 *
6122  INTEGER, INTENT(IN) :: m
6123  INTEGER, INTENT(IN) :: n
6124  INTEGER, INTENT(IN) :: ldq
6125  real*8, INTENT(OUT) :: q(ldq,m)
6126  real*8, INTENT(OUT) :: wa(m)
6127 
6128 ! **********
6129 
6130 ! SUBROUTINE HTO_QFORM
6131 
6132 ! THIS SUBROUTINE HTO_PROCEEDS FROM THE COMPUTED QR FACTORIZATION OF AN M BY N
6133 ! MATRIX A TO ACCUMULATE THE M BY M ORTHOGONAL MATRIX Q FROM ITS FACTORED FORM.
6134 
6135 ! THE SUBROUTINE HTO_STATEMENT IS
6136 
6137 ! SUBROUTINE HTO_QFORM(M,N,Q,LDQ,WA)
6138 
6139 ! WHERE
6140 
6141 ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
6142 ! OF ROWS OF A AND THE ORDER OF Q.
6143 
6144 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF COLUMNS OF A.
6145 
6146 ! Q IS AN M BY M ARRAY. ON INPUT THE FULL LOWER TRAPEZOID IN
6147 ! THE FIRST MIN(M,N) COLUMNS OF Q CONTAINS THE FACTORED FORM.
6148 ! ON OUTPUT Q HAS BEEN ACCUMULATED INTO A SQUARE MATRIX.
6149 
6150 ! LDQ IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
6151 ! WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY Q.
6152 
6153 ! WA IS A WORK ARRAY OF LENGTH M.
6154 
6155 ! SUBPROGRAMS CALLED
6156 
6157 ! FORTRAN-SUPPLIED ... MIN
6158 
6159 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6160 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
6161 
6162 ! **********
6163 *
6164  INTEGER :: i,j,jm1,k,l,minmn,np1
6165  REAL*8 :: sum,temp
6166  real*8, PARAMETER :: one= 1.0d0,zero= 0.0d0
6167 *
6168  minmn= min(m,n)
6169  IF(minmn >= 2) THEN
6170  DO j= 2,minmn
6171  jm1= j-1
6172  DO i= 1,jm1
6173  q(i,j)= zero
6174  ENDDO
6175  ENDDO
6176  ENDIF
6177  np1= n+1
6178  IF(m >= np1) THEN
6179  DO j= np1,m
6180  DO i= 1,m
6181  q(i,j)= zero
6182  ENDDO
6183  q(j,j)= one
6184  ENDDO
6185  ENDIF
6186  DO l= 1,minmn
6187  k= minmn-l+1
6188  DO i= k,m
6189  wa(i)= q(i,k)
6190  q(i,k)= zero
6191  ENDDO
6192  q(k,k)= one
6193  IF(wa(k) /= zero) THEN
6194  DO j= k,m
6195  sum= zero
6196  DO i= k,m
6197  sum= sum+q(i,j)*wa(i)
6198  ENDDO
6199  temp= sum/wa(k)
6200  DO i= k,m
6201  q(i,j)= q(i,j)-temp*wa(i)
6202  ENDDO
6203  ENDDO
6204  ENDIF
6205  ENDDO
6206 *
6207  RETURN
6208 *
6209  END SUBROUTINE hto_qform
6210 *
6211 *----------------------------------------------------------------
6212 *
6213  SUBROUTINE hto_qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa)
6214 *
6215  INTEGER, INTENT(IN) :: m
6216  INTEGER, INTENT(IN) :: n
6217  INTEGER, INTENT(IN) :: lda
6218  real*8, INTENT(IN OUT) :: a(lda,n)
6219  LOGICAL, INTENT(IN) :: pivot
6220  INTEGER, INTENT(IN) :: lipvt
6221  INTEGER, INTENT(OUT) :: ipvt(lipvt)
6222  real*8, INTENT(OUT) :: rdiag(n)
6223  real*8, INTENT(OUT) :: acnorm(n)
6224  real*8, INTENT(OUT) :: wa(n)
6225 
6226 ! **********
6227 
6228 ! SUBROUTINE HTO_QRFAC
6229 
6230 ! THIS SUBROUTINE HTO_USES HOUSEHOLDER TRANSFORMATIONS WITH COLUMN PIVOTING
6231 ! (OPTIONAL) TO COMPUTE A QR FACTORIZATION OF THE M BY N MATRIX A.
6232 ! THAT IS, QRFAC DETERMINES AN ORTHOGONAL MATRIX Q, A PERMUTATION MATRIX P,
6233 ! AND AN UPPER TRAPEZOIDAL MATRIX R WITH DIAGONAL ELEMENTS OF NONINCREASING
6234 ! MAGNITUDE, SUCH THAT A*P= Q*R. THE HOUSEHOLDER TRANSFORMATION FOR
6235 ! COLUMN K, K= 1,2,...,MIN(M,N), IS OF THE FORM
6236 
6237 ! T
6238 ! I - (1/U(K))*U*U
6239 
6240 ! WHERE U HAS ZEROS IN THE FIRST K-1 POSITIONS. THE FORM OF THIS
6241 ! TRANSFORMATION AND THE METHOD OF PIVOTING FIRST APPEARED IN THE
6242 ! CORRESPONDING LINPACK SUBROUTINE.
6243 
6244 ! THE SUBROUTINE HTO_STATEMENT IS
6245 
6246 ! SUBROUTINE HTO_QRFAC(M,N,A,LDA,PIVOT,IPVT,LIPVT,RDIAG,ACNORM,WA)
6247 
6248 ! WHERE
6249 
6250 ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF A.
6251 
6252 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
6253 ! OF COLUMNS OF A.
6254 
6255 ! A IS AN M BY N ARRAY. ON INPUT A CONTAINS THE MATRIX FOR WHICH THE
6256 ! QR FACTORIZATION IS TO BE COMPUTED. ON OUTPUT THE STRICT UPPER
6257 ! TRAPEZOIDAL PART OF A CONTAINS THE STRICT UPPER TRAPEZOIDAL PART OF R,
6258 ! AND THE LOWER TRAPEZOIDAL PART OF A CONTAINS A FACTORED FORM OF Q
6259 ! (THE NON-TRIVIAL ELEMENTS OF THE U VECTORS DESCRIBED ABOVE).
6260 
6261 ! LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
6262 ! WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
6263 
6264 ! PIVOT IS A LOGICAL INPUT VARIABLE. IF PIVOT IS SET TRUE,
6265 ! THEN COLUMN PIVOTING IS ENFORCED. IF PIVOT IS SET FALSE,
6266 ! THEN NO COLUMN PIVOTING IS DONE.
6267 
6268 ! IPVT IS AN INTEGER OUTPUT ARRAY OF LENGTH LIPVT. IPVT DEFINES THE
6269 ! PERMUTATION MATRIX P SUCH THAT A*P= Q*R.
6270 ! COLUMN J OF P IS COLUMN IPVT(J) OF THE IDENTITY MATRIX.
6271 ! IF PIVOT IS FALSE, IPVT IS NOT REFERENCED.
6272 
6273 ! LIPVT IS A POSITIVE INTEGER INPUT VARIABLE. IF PIVOT IS FALSE,
6274 ! THEN LIPVT MAY BE AS SMALL AS 1. IF PIVOT IS TRUE, THEN
6275 ! LIPVT MUST BE AT LEAST N.
6276 
6277 ! RDIAG IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE
6278 ! DIAGONAL ELEMENTS OF R.
6279 
6280 ! ACNORM IS AN OUTPUT ARRAY OF LENGTH N WHICH CONTAINS THE NORMS OF
6281 ! THE CORRESPONDING COLUMNS OF THE INPUT MATRIX A.
6282 ! IF THIS INFORMATION IS NOT NEEDED, THEN ACNORM CAN COINCIDE WITH RDIAG.
6283 
6284 ! WA IS A WORK ARRAY OF LENGTH N. IF PIVOT IS FALSE, THEN WA
6285 ! CAN COINCIDE WITH RDIAG.
6286 
6287 ! SUBPROGRAMS CALLED
6288 
6289 ! MINPACK-SUPPLIED ... SPMPAR,ENORM
6290 
6291 ! FORTRAN-SUPPLIED ... MAX,SQRT,MIN
6292 
6293 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6294 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
6295 
6296 ! **********
6297  INTEGER :: i,j,jp1,k,kmax,minmn
6298  REAL*8 :: ajnorm,epsmch,sum,temp
6299  real*8, PARAMETER :: one= 1.0d0,p05= 0.05d0,zero= 0.0d0
6300 *
6301  epsmch= epsilon(1.0d0)
6302  DO j= 1,n
6303  acnorm(j)= hto_enorm(m,a(1:,j))
6304  rdiag(j)= acnorm(j)
6305  wa(j)= rdiag(j)
6306  IF(pivot) ipvt(j)= j
6307  ENDDO
6308  minmn= min(m,n)
6309  DO j= 1,minmn
6310  IF(pivot) THEN
6311  kmax= j
6312  DO k= j,n
6313  IF(rdiag(k) > rdiag(kmax)) kmax= k
6314  ENDDO
6315  IF(kmax /= j) THEN
6316  DO i= 1,m
6317  temp= a(i,j)
6318  a(i,j)= a(i,kmax)
6319  a(i,kmax)= temp
6320  ENDDO
6321  rdiag(kmax)= rdiag(j)
6322  wa(kmax)= wa(j)
6323  k= ipvt(j)
6324  ipvt(j)= ipvt(kmax)
6325  ipvt(kmax)= k
6326  ENDIF
6327  ENDIF
6328  ajnorm= hto_enorm(m-j+1,a(j:,j))
6329  IF(ajnorm /= zero) THEN
6330  IF(a(j,j) < zero) ajnorm= -ajnorm
6331  DO i= j,m
6332  a(i,j)= a(i,j)/ajnorm
6333  ENDDO
6334  a(j,j)= a(j,j)+one
6335  jp1= j+1
6336  IF(n >= jp1) THEN
6337  DO k= jp1,n
6338  sum= zero
6339  DO i= j,m
6340  sum= sum+a(i,j)*a(i,k)
6341  ENDDO
6342  temp= sum/a(j,j)
6343  DO i= j,m
6344  a(i,k)= a(i,k)-temp*a(i,j)
6345  ENDDO
6346  IF(.NOT.(.NOT.pivot.OR.rdiag(k) == zero)) THEN
6347  temp= a(j,k)/rdiag(k)
6348  rdiag(k)= rdiag(k)*sqrt(max(zero,one-temp**2))
6349  IF(p05*(rdiag(k)/wa(k))**2 <= epsmch) THEN
6350  rdiag(k)= hto_enorm(m-j,a(jp1:,k))
6351  wa(k)= rdiag(k)
6352  ENDIF
6353  ENDIF
6354  ENDDO
6355  ENDIF
6356  ENDIF
6357  rdiag(j)= -ajnorm
6358  ENDDO
6359 *
6360  RETURN
6361 *
6362  END SUBROUTINE hto_qrfac
6363 *
6364 *-------------------------------------------------------------
6365 *
6366  SUBROUTINE hto_r1mpyq(m,n,a,lda,v,w)
6367 *
6368  INTEGER, INTENT(IN) :: m
6369  INTEGER, INTENT(IN) :: n
6370  INTEGER, INTENT(IN) :: lda
6371  real*8, INTENT(IN OUT) :: a(lda,n)
6372  real*8, INTENT(IN) :: v(n)
6373  real*8, INTENT(IN) :: w(n)
6374 
6375 ! **********
6376 
6377 ! SUBROUTINE HTO_R1MPYQ
6378 
6379 ! GIVEN AN M BY N MATRIX A, THIS SUBROUTINE HTO_COMPUTES A*Q WHERE
6380 ! Q IS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
6381 
6382 ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
6383 
6384 ! AND GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE WHICH
6385 ! ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
6386 ! Q ITSELF IS NOT GIVEN, RATHER THE INFORMATION TO RECOVER THE
6387 ! GV, GW ROTATIONS IS SUPPLIED.
6388 
6389 ! THE SUBROUTINE HTO_STATEMENT IS
6390 
6391 ! SUBROUTINE HTO_R1MPYQ(M, N, A, LDA, V, W)
6392 
6393 ! WHERE
6394 
6395 ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF A.
6396 
6397 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF COLUMNS OF A.
6398 
6399 ! A IS AN M BY N ARRAY. ON INPUT A MUST CONTAIN THE MATRIX TO BE
6400 ! POSTMULTIPLIED BY THE ORTHOGONAL MATRIX Q DESCRIBED ABOVE.
6401 ! ON OUTPUT A*Q HAS REPLACED A.
6402 
6403 ! LDA IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN M
6404 ! WHICH SPECIFIES THE LEADING DIMENSION OF THE ARRAY A.
6405 
6406 ! V IS AN INPUT ARRAY OF LENGTH N. V(I) MUST CONTAIN THE INFORMATION
6407 ! NECESSARY TO RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
6408 
6409 ! W IS AN INPUT ARRAY OF LENGTH N. W(I) MUST CONTAIN THE INFORMATION
6410 ! NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED ABOVE.
6411 
6412 ! SUBROUTINES CALLED
6413 
6414 ! FORTRAN-SUPPLIED ... ABS, SQRT
6415 
6416 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6417 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
6418 
6419 ! **********
6420 
6421  INTEGER :: i,j,nmj,nm1
6422  REAL*8 :: COS,SIN,temp
6423  real*8, PARAMETER :: one= 1.0d0
6424 *
6425  nm1= n-1
6426  IF(nm1 >= 1) THEN
6427  DO nmj= 1,nm1
6428  j= n-nmj
6429  IF(abs(v(j)) > one) cos= one/v(j)
6430  IF(abs(v(j)) > one) sin= sqrt(one-cos**2)
6431  IF(abs(v(j)) <= one) sin= v(j)
6432  IF(abs(v(j)) <= one) cos= sqrt(one-sin**2)
6433  DO i= 1,m
6434  temp= cos*a(i,j)-sin*a(i,n)
6435  a(i,n)= sin*a(i,j)+cos*a(i,n)
6436  a(i,j)= temp
6437  ENDDO
6438  ENDDO
6439  DO j= 1,nm1
6440  IF(abs(w(j)) > one) cos= one/w(j)
6441  IF(abs(w(j)) > one) sin= sqrt(one-cos**2)
6442  IF(abs(w(j)) <= one) sin= w(j)
6443  IF(abs(w(j)) <= one) cos= sqrt(one-sin**2)
6444  DO i= 1,m
6445  temp= cos*a(i,j)+sin*a(i,n)
6446  a(i,n)= -sin*a(i,j)+cos*a(i,n)
6447  a(i,j)= temp
6448  ENDDO
6449  ENDDO
6450  ENDIF
6451 *
6452  RETURN
6453 *
6454  END SUBROUTINE hto_r1mpyq
6455 *
6456 *--------------------------------------------------------------
6457 *
6458  SUBROUTINE hto_r1updt(m,n,s,ls,u,v,w,sing)
6459 *
6460  INTEGER, INTENT(IN) :: m
6461  INTEGER, INTENT(IN) :: n
6462  INTEGER, INTENT(IN) :: ls
6463  real*8, INTENT(IN OUT) :: s(ls)
6464  real*8, INTENT(IN) :: u(m)
6465  real*8, INTENT(IN OUT) :: v(n)
6466  real*8, INTENT(OUT) :: w(m)
6467  LOGICAL, INTENT(OUT) :: sing
6468 
6469 ! **********
6470 
6471 ! SUBROUTINE HTO_R1UPDT
6472 
6473 ! GIVEN AN M BY N LOWER TRAPEZOIDAL MATRIX S, AN M-VECTOR U,
6474 ! AND AN N-VECTOR V, THE PROBLEM IS TO DETERMINE AN
6475 ! ORTHOGONAL MATRIX Q SUCH THAT
6476 
6477 ! T
6478 ! (S + U*V )*Q
6479 
6480 ! IS AGAIN LOWER TRAPEZOIDAL.
6481 
6482 ! THIS SUBROUTINE HTO_DETERMINES Q AS THE PRODUCT OF 2*(N - 1) TRANSFORMATIONS
6483 
6484 ! GV(N-1)*...*GV(1)*GW(1)*...*GW(N-1)
6485 
6486 ! WHERE GV(I), GW(I) ARE GIVENS ROTATIONS IN THE (I,N) PLANE
6487 ! WHICH ELIMINATE ELEMENTS IN THE I-TH AND N-TH PLANES, RESPECTIVELY.
6488 ! Q ITSELF IS NOT ACCUMULATED, RATHER THE INFORMATION TO RECOVER THE GV,
6489 ! GW ROTATIONS IS RETURNED.
6490 
6491 ! THE SUBROUTINE HTO_STATEMENT IS
6492 
6493 ! SUBROUTINE HTO_R1UPDT(M,N,S,LS,U,V,W,SING)
6494 
6495 ! WHERE
6496 
6497 ! M IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER OF ROWS OF S.
6498 
6499 ! N IS A POSITIVE INTEGER INPUT VARIABLE SET TO THE NUMBER
6500 ! OF COLUMNS OF S. N MUST NOT EXCEED M.
6501 
6502 ! S IS AN ARRAY OF LENGTH LS. ON INPUT S MUST CONTAIN THE LOWER
6503 ! TRAPEZOIDAL MATRIX S STORED BY COLUMNS. ON OUTPUT S CONTAINS
6504 ! THE LOWER TRAPEZOIDAL MATRIX PRODUCED AS DESCRIBED ABOVE.
6505 
6506 ! LS IS A POSITIVE INTEGER INPUT VARIABLE NOT LESS THAN
6507 ! (N*(2*M-N+1))/2.
6508 
6509 ! U IS AN INPUT ARRAY OF LENGTH M WHICH MUST CONTAIN THE VECTOR U.
6510 
6511 ! V IS AN ARRAY OF LENGTH N. ON INPUT V MUST CONTAIN THE VECTOR V.
6512 ! ON OUTPUT V(I) CONTAINS THE INFORMATION NECESSARY TO
6513 ! RECOVER THE GIVENS ROTATION GV(I) DESCRIBED ABOVE.
6514 
6515 ! W IS AN OUTPUT ARRAY OF LENGTH M. W(I) CONTAINS INFORMATION
6516 ! NECESSARY TO RECOVER THE GIVENS ROTATION GW(I) DESCRIBED ABOVE.
6517 
6518 ! SING IS A LOGICAL OUTPUT VARIABLE. SING IS SET TRUE IF ANY OF THE
6519 ! DIAGONAL ELEMENTS OF THE OUTPUT S ARE ZERO. OTHERWISE SING IS
6520 ! SET FALSE.
6521 
6522 ! SUBPROGRAMS CALLED
6523 
6524 ! MINPACK-SUPPLIED ... SPMPAR
6525 
6526 ! FORTRAN-SUPPLIED ... ABS,SQRT
6527 
6528 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6529 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE, JOHN L. NAZARETH
6530 
6531 ! **********
6532 
6533  INTEGER :: i,j,jj,l,nmj,nm1
6534  REAL*8 :: COS,cotan,giant,SIN,TAN,tau,temp
6535  real*8, PARAMETER :: one= 1.0d0,p5= 0.5d0,p25= 0.25d0,zero= 0.0d0
6536 *
6537  giant= huge(1.0d0)
6538  jj= (n*(2*m-n+1))/2-(m-n)
6539  l= jj
6540  DO i= n,m
6541  w(i)= s(l)
6542  l= l+1
6543  ENDDO
6544  nm1= n-1
6545  IF(nm1 >= 1) THEN
6546  DO nmj= 1,nm1
6547  j= n-nmj
6548  jj= jj-(m-j+1)
6549  w(j)= zero
6550  IF(v(j) /= zero) THEN
6551  IF(abs(v(n)) < abs(v(j))) THEN
6552  cotan= v(n)/v(j)
6553  sin= p5/sqrt(p25+p25*cotan**2)
6554  cos= sin*cotan
6555  tau= one
6556  IF(abs(cos)*giant > one) tau= one/cos
6557  ELSE
6558  tan= v(j)/v(n)
6559  cos= p5/sqrt(p25+p25*tan**2)
6560  sin= cos*tan
6561  tau= sin
6562  ENDIF
6563  v(n)= sin*v(j)+cos*v(n)
6564  v(j)= tau
6565  l= jj
6566  DO i= j,m
6567  temp= cos*s(l)-sin*w(i)
6568  w(i)= sin*s(l)+cos*w(i)
6569  s(l)= temp
6570  l= l+1
6571  ENDDO
6572  ENDIF
6573  ENDDO
6574  ENDIF
6575  DO i= 1,m
6576  w(i)= w(i)+v(n)*u(i)
6577  ENDDO
6578  sing= .false.
6579  IF(nm1 >= 1) THEN
6580  DO j= 1,nm1
6581  IF(w(j) /= zero) THEN
6582  IF(abs(s(jj)) < abs(w(j))) THEN
6583  cotan= s(jj)/w(j)
6584  sin= p5/sqrt(p25+p25*cotan**2)
6585  cos= sin*cotan
6586  tau= one
6587  IF(abs(cos)*giant > one) tau= one/cos
6588  ELSE
6589  tan= w(j)/s(jj)
6590  cos= p5/sqrt(p25+p25*tan**2)
6591  sin= cos*tan
6592  tau= sin
6593  ENDIF
6594  l= jj
6595  DO i= j,m
6596  temp= cos*s(l)+sin*w(i)
6597  w(i)= -sin*s(l)+cos*w(i)
6598  s(l)= temp
6599  l= l+1
6600  ENDDO
6601  w(j)= tau
6602  ENDIF
6603  IF(s(jj) == zero) sing= .true.
6604  jj= jj+(m-j+1)
6605  ENDDO
6606  ENDIF
6607  l= jj
6608  DO i= n,m
6609  s(l)= w(i)
6610  l= l+1
6611  ENDDO
6612  IF(s(jj) == zero) sing= .true.
6613 *
6614  RETURN
6615 *
6616  END SUBROUTINE hto_r1updt
6617 *
6618 *-----------------------------------------------------------------
6619 *
6620  FUNCTION hto_enorm(n,x) RESULT(fn_val)
6621 *
6622  INTEGER, INTENT(IN) :: n
6623  REAL*8, INTENT(IN) :: x(n)
6624  real*8 :: fn_val
6625 
6626 ! **********
6627 
6628 ! FUNCTION ENORM
6629 
6630 ! GIVEN AN N-VECTOR X, THIS FUNCTION CALCULATES THE EUCLIDEAN NORM OF X.
6631 
6632 ! THE EUCLIDEAN NORM IS COMPUTED BY ACCUMULATING THE SUM OF SQUARES IN THREE
6633 ! DIFFERENT SUMS. THE SUMS OF SQUARES FOR THE SMALL AND LARGE COMPONENTS
6634 ! ARE SCALED SO THAT NO OVERFLOWS OCCUR. NON-DESTRUCTIVE UNDERFLOWS ARE
6635 ! PERMITTED. UNDERFLOWS AND OVERFLOWS DO NOT OCCUR IN THE COMPUTATION OF THE UNSCALED
6636 ! SUM OF SQUARES FOR THE INTERMEDIATE COMPONENTS.
6637 ! THE DEFINITIONS OF SMALL, INTERMEDIATE AND LARGE COMPONENTS DEPEND ON
6638 ! TWO CONSTANTS, RDWARF AND RGIANT. THE MAIN RESTRICTIONS ON THESE CONSTANTS
6639 ! ARE THAT RDWARF**2 NOT UNDERFLOW AND RGIANT**2 NOT OVERFLOW.
6640 ! THE CONSTANTS GIVEN HERE ARE SUITABLE FOR EVERY KNOWN COMPUTER.
6641 
6642 ! THE FUNCTION STATEMENT IS
6643 
6644 ! REAL FUNCTION ENORM(N, X)
6645 
6646 ! WHERE
6647 
6648 ! N IS A POSITIVE INTEGER INPUT VARIABLE.
6649 
6650 ! X IS AN INPUT ARRAY OF LENGTH N.
6651 
6652 ! SUBPROGRAMS CALLED
6653 
6654 ! FORTRAN-SUPPLIED ... ABS,SQRT
6655 
6656 ! ARGONNE NATIONAL LABORATORY. MINPACK PROJECT. MARCH 1980.
6657 ! BURTON S. GARBOW, KENNETH E. HILLSTROM, JORGE J. MORE
6658 
6659 ! **********
6660 
6661  INTEGER :: i
6662  REAL*8 :: agiant,floatn,s1,s2,s3,xabs,x1max,x3max
6663  real*8, PARAMETER :: rdwarf= 1.0d-100,rgiant= 1.0d+100
6664 *
6665  s1= 0.0d0
6666  s2= 0.0d0
6667  s3= 0.0d0
6668  x1max= 0.0d0
6669  x3max= 0.0d0
6670  floatn= n
6671  agiant= rgiant/floatn
6672  DO i= 1,n
6673  xabs= abs(x(i))
6674  IF(xabs <= rdwarf.or.xabs >= agiant) THEN
6675  IF(xabs > rdwarf) THEN
6676  IF(xabs > x1max) THEN
6677  s1= 1.0d0+s1*(x1max/xabs)**2
6678  x1max= xabs
6679  ELSE
6680  s1= s1+(xabs/x1max)**2
6681  ENDIF
6682  ELSE
6683  IF(xabs > x3max) THEN
6684  s3= 1.0d0+s3*(x3max/xabs)**2
6685  x3max= xabs
6686  ELSE
6687  IF(xabs /= 0.0d0) s3= s3+(xabs/x3max)**2
6688  ENDIF
6689  ENDIF
6690  ELSE
6691  s2= s2+xabs**2
6692  ENDIF
6693  ENDDO
6694  IF(s1 /= 0.0d0) THEN
6695  fn_val= x1max*sqrt(s1+(s2/x1max)/x1max)
6696  ELSE
6697  IF(s2 /= 0.0d0) THEN
6698  IF(s2 >= x3max) fn_val= sqrt(s2*(1.0d0+(x3max/s2)*(x3max*s3)))
6699  IF(s2 < x3max) fn_val= sqrt(x3max*((s2/x3max)+(x3max*s3)))
6700  ELSE
6701  fn_val= x3max*sqrt(s3)
6702  ENDIF
6703  ENDIF
6704 *
6705  RETURN
6706 *
6707  END FUNCTION hto_enorm
6708 *
6709  END MODULE hto_solve_nonlin
6710 *
6711 *------------------------------------------------------------------------------
6712 *
6713  SUBROUTINE hto_poles(m,nv)
6714  USE hto_transfmh
6715  USE hto_masses
6716  USE hto_set_phys_const
6717  USE hto_solve_nonlin
6718 *
6719  IMPLICIT NONE
6720 *
6721  INTEGER nv,n,info
6722  REAL*8 m,tol
6723  real*8, dimension(3) :: xcp,fvcp,diag
6724  EXTERNAL hto_cpoles
6725 *
6726  n= nv
6727  tol= 1.d-8
6728  tmuh= m
6729  xcp(1)= sqrt(20.d0/mw)
6730  xcp(2)= 1.d0
6731  xcp(3)= 1.d0
6732  CALL hto_hbrd(hto_cpoles,n,xcp,fvcp,tol,tol,info,diag)
6733  print 2003,info
6734  print*,' '
6735  IF(info == 1) THEN
6736  print*,'ALGORITHM ESTIMATES THAT THE RELATIVE ERROR'
6737  print*,'BETWEEN X AND THE SOLUTION IS AT MOST TOL'
6738  ELSEIF(info == 2) THEN
6739  print*,'NUMBER OF CALLS TO FCN HAS REACHED'
6740  print*,'OR EXCEEDED 200*(N+1)'
6741  ELSEIF(info == 3) THEN
6742  print*,'TOL IS TOO SMALL. NO FURTHER IMPROVEMENT IN'
6743  print*,'THE APPROXIMATE SOLUTION X IS POSSIBLE'
6744  ELSEIF(info == 4) THEN
6745  print*,'ITERATION IS NOT MAKING GOOD PROGRESS'
6746  ENDIF
6747  print*,' '
6748  print 2005,1.d-2*xcp(2)*xcp(2)*m
6749  print 2004,1.d-1*xcp(1)*xcp(1)*mw,
6750  # imw*(1.d0-0.5d0*(imw*imw)/(mw*mw))
6751  IF(n == 3) THEN
6752  print 2006,1.d-2*xcp(3)*xcp(3)*mt,imt
6753  ENDIF
6754 *
6755  2003 format(' info =',i2)
6756 *
6757  2004 format(' gammaW = ',2e20.5)
6758  2005 format(' gammaH = ',e20.5)
6759  2006 format(' gammat = ',2e20.5)
6760 *
6761  RETURN
6762 *
6763  END SUBROUTINE hto_poles
6764 *
6765 *------------------------------------------------------------------------------
6766 *
6767  SUBROUTINE hto_cpoles(n,xcp,fvcp,iflag)
6768  USE hto_ferbos
6769  USE hto_aux_hcp
6770  USE hto_units
6771  USE hto_acmplx_pro
6772  USE hto_acmplx_rat
6773  USE hto_full_ln
6774  USE hto_ln_2_riemann
6775  USE hto_masses
6776  USE hto_set_phys_const
6777  USE hto_riemann
6778  USE hto_optcp
6779  USE hto_transfmh
6780  USE hto_qcd
6781 *
6782  IMPLICIT NONE
6783 *
6784  INTEGER nc,n,iflag,iz
6785  REAL*8 muh,rgh,muhs,scal,scals,p2,xm0,str,sti,rgw,
6786  # lswr,lswi,lmw,bxm0,emc,emb,emt,asmur,rgt,as_nlo,ewc,
6787  # crmbs,crmcs,lcxb,lcxc,lcxbs,lcxcs,lclxb,lclxc,as_lo
6788  real*8, dimension(n) :: xcp,fvcp
6789  real*8, dimension(2,2) :: axms
6790  real*8, dimension(2) :: axm0,bxms,runbc
6791  real*8, dimension(2) :: sh,shs,clh,b0sumb,b0sumf,cxp,ksumb,
6792  # ksumf,coefb1,coefb2,coefb3,coefb4,coefb5,coefb6,coefb7,
6793  # coefb8,coefb9,coefb10,coefb11,coefb12,
6794  # shhf,shht,shhb,shh,b0sumt,ksumt,xms,
6795  # b0part,cpt,cpts,ccxt,deltag,sww0,coefw1,
6796  # coefw2,ksumw,ccxts,cctsi,shi,clt,cxhw,cstsi,csmcts,cltmw,
6797  # b0sumw,sww,dw,b0sumw1,b0sumw2,cxw,cxz,ccts,clw,csts,
6798  # cctq,cxws,cmxw,clmw,cxtw,kfmsb,ktmsb,kbmsb,kwmsb,
6799  # coeft1,coeft2,coeft3,coeft4,b0sumtop,ksumtop,stt,
6800  # coeft1s,b0sumtops,ksumtops,stts,cctqi,ucpt,nloqcd,ttqcd,
6801  # dww,sww0w,swww,ksumww,lcxwi,lclcts
6802 *
6803  INTERFACE
6804  SUBROUTINE hto_initalphas(asord,FR2,MUR,asmur,emc,emb,emt)
6805  USE hto_dzpar
6806  IMPLICIT NONE
6807  INTEGER asord
6808  real*8 fr2,mur,asmur,emc,emb,emt,hto_findalphasr0
6809  EXTERNAL hto_findalphasr0
6810  END SUBROUTINE hto_initalphas
6811  END INTERFACE
6812 *
6813  INTERFACE
6814  FUNCTION hto_alphas(MUR)
6815  USE hto_nffix
6816  USE hto_varflv
6817  USE hto_frrat
6818  USE hto_asinp
6819  USE hto_asfthr
6820  IMPLICIT NONE
6821  real*8 mur,hto_alphas
6822  END FUNCTION hto_alphas
6823  END INTERFACE
6824 *
6825  INTERFACE
6826  FUNCTION hto_lquarkqcd(scal,psi,ps0i,xmsi,xm0i,type)
6827  # result(value)
6828  USE hto_riemann
6829  USE hto_acmplx_pro
6830  USE hto_acmplx_rat
6831  USE hto_cmplx_root
6832  USE hto_cmplx_rootz
6833  USE hto_cmplx_srs_root
6834  USE hto_ln_2_riemann
6835  USE hto_full_ln
6836  USE hto_sp_fun
6837  USE hto_units
6838  IMPLICIT NONE
6839  INTEGER type
6840  real*8 scal,ps0i,xm0i
6841  real*8, dimension(2) :: value,psi,xmsi
6842  END FUNCTION hto_lquarkqcd
6843  END INTERFACE
6844 *
6845  INTERFACE
6846  FUNCTION hto_lb0af_em(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
6847  USE hto_acmplx_pro
6848  USE hto_acmplx_rat
6849  USE hto_cmplx_root
6850  USE hto_cmplx_rootz
6851  USE hto_cmplx_srs_root
6852  USE hto_ln_2_riemann
6853  USE hto_full_ln
6854  USE hto_units
6855  IMPLICIT NONE
6856  real*8 scal,ps0i,xm0i
6857  real*8, dimension(2) :: value,psi,xmsi
6858  END FUNCTION hto_lb0af_em
6859  END INTERFACE
6860 *
6861  INTERFACE
6862  FUNCTION hto_lb0af_dm(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
6863  USE hto_acmplx_pro
6864  USE hto_acmplx_rat
6865  USE hto_cmplx_root
6866  USE hto_cmplx_rootz
6867  USE hto_cmplx_srs_root
6868  USE hto_ln_2_riemann
6869  USE hto_full_ln
6870  USE hto_units
6871  IMPLICIT NONE
6872  real*8 scal,ps0i
6873  real*8, dimension(2,2) :: xmsi
6874  real*8, dimension(2) :: value,psi,xm0i
6875  END FUNCTION hto_lb0af_dm
6876  END INTERFACE
6877 *
6878  INTERFACE
6879  FUNCTION hto_lb021_dm_cp(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
6880  USE hto_cmplx_root
6881  USE hto_cmplx_rootz
6882  USE hto_cmplx_srs_root
6883  USE hto_ln_2_riemann
6884  USE hto_acmplx_pro
6885  USE hto_acmplx_rat
6886  USE hto_full_ln
6887  USE hto_units
6888  IMPLICIT NONE
6889  real*8 scal,ps0i
6890  real*8, intent(in), dimension(2) :: xm0i
6891  real*8, intent(in), dimension(2,2) :: xmsi
6892  real*8, dimension(2) :: value
6893  real*8, dimension(2) :: psi
6894  END FUNCTION hto_lb021_dm_cp
6895  END INTERFACE
6896 *
6897  muh= tmuh
6898  scal= muh
6899  muhs= muh*muh
6900  scals= scal*scal
6901 *
6902  cxw(1)= mw*mw/scals*(1.d0-0.5d-2*(xcp(1)*xcp(1))**2)
6903  cxw(2)= -1.d-1*mw*mw/scals*xcp(1)*xcp(1)
6904 *
6905  cmxw= -cxw
6906  cxws= cxw.cp.cxw
6907  lcxwi= co.cq.cxw
6908 *
6909  rgw= 1.d-1*xcp(1)*xcp(1)*mw
6910  rgh= 1.d-2*xcp(2)*xcp(2)*muh
6911  IF(n == 3) THEN
6912  rgt= 1.d-2*xcp(3)*xcp(3)*mt
6913  ELSEIF(n == 2) THEN
6914  rgt= imt
6915  ENDIF
6916 *
6917  lswr= mw*mw*(1.d0-0.5d-2*(xcp(1)*xcp(1))**2)
6918  lswi= -mw*rgw
6919 *
6920  clw= cxw(1).fln.cxw(2)
6921  clmw= cmxw(1).fln.cmxw(2)
6922  clmw(2)= clmw(2)-2.d0*pi
6923 *
6924  cxz(1)= szr/scals
6925  cxz(2)= szi/scals
6926  ccts= cxw.cq.cxz
6927  csts= co-ccts
6928  cctq= ccts.cp.ccts
6929  cctqi= co.cq.cctq
6930  lclcts= ccts(1).fln.ccts(2)
6931 *
6932  asmur= 0.12018d0
6933  emc= 1.4d0
6934  emb= 4.75d0
6935  emt= mt
6936  iz= 1
6937  CALL hto_initalphas(iz,one,mz,asmur,emc,emb,emt)
6938  as_nlo= hto_alphas(scal)/pi
6939  runbc= hto_run_bc(scal)
6940  crmbs= runbc(2)*runbc(2)
6941  crmcs= runbc(1)*runbc(1)
6942 *
6943  lcxb= crmbs/scals
6944  lcxc= crmcs/scals
6945 *
6946  lcxbs= lcxb*lcxb
6947  lcxcs= lcxc*lcxc
6948  lclxb= log(lcxb)
6949  lclxc= log(lcxc)
6950 *
6951  ucpt(1)= mt*mt
6952  ucpt(2)= 0.d0
6953  cpt(1)= mt*mt/scals
6954  cpt(2)= 0.d0
6955  cpts= cpt.cp.cpt
6956 *
6957  ccxt= cpt
6958  ccxts= ccxt.cp.ccxt
6959  cctsi= co.cq.ccts
6960  cstsi= co.cq.csts
6961  csmcts= csts-ccts
6962 *
6963  sh(1)= muhs/scals
6964  sh(2)= -muh*rgh/scals
6965 *
6966  cxhw= sh-cxw
6967  shs= sh.cp.sh
6968  shi= co.cq.sh
6969 *
6970  cxtw= ccxt-cxw
6971  clh= sh(1).fln.sh(2)
6972  clt= ccxt(1).fln.ccxt(2)
6973  cltmw= cxtw(1).fln.cxtw(2)
6974 *
6975 * W
6976  coefb1= (12.d0*cxw-4.d0*sh+(shs.cq.cxw))/64.d0
6977 *
6978 * Z
6979  coefb2= (-4.d0*(sh.cq.ccts)+(shs.cq.cxw)+
6980  # 12.d0*(cxw.cq.cctq))/128.d0
6981 *
6982 * H
6983  coefb3= 9.d0/128.d0*(shs.cq.cxw)
6984 *
6985 * top
6986  coefb4= -3.d0/32.d0*((4.d0*ccxt-sh).cp.(ccxt.cq.cxw))
6987 *
6988 * light fermions
6989 *
6990  coefb5= -3.d0/32.d0*((4.d0*co*lcxb-sh).cq.cxw)*lcxb
6991 *
6992  coefb6= -1.d0/32.d0*((4.d0*co*cxtau-sh).cq.cxw)*cxtau
6993 *
6994  coefb7= -3.d0/32.d0*((4.d0*co*lcxc-sh).cq.cxw)*lcxc
6995 *
6996  coefb8= -1.d0/32.d0*((4.d0*co*cxmu-sh).cq.cxw)*cxmu
6997 *
6998  coefb9= -3.d0/32.d0*((4.d0*co*cxs-sh).cq.cxw)*cxs
6999 *
7000  coefb10= -3.d0/32.d0*((4.d0*co*cxd-sh).cq.cxw)*cxd
7001 *
7002  coefb11= -3.d0/32.d0*((4.d0*co*cxu-sh).cq.cxw)*cxu
7003 *
7004  coefb12= -1.d0/32.d0*((4.d0*co*cxe-sh).cq.cxw)*cxe
7005 *
7006  cxp(1)= muhs
7007  cxp(2)= -muh*rgh
7008  p2= muhs
7009 *
7010  xms(1)= lswr
7011  xms(2)= lswi
7012  xm0= mw
7013  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7014  b0sumb= coefb1.cp.b0part
7015 *
7016  xms(1)= szr
7017  xms(2)= szi
7018  xm0= mz
7019  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7020  b0sumb= b0sumb+(coefb2.cp.b0part)
7021 *
7022  xms(1)= muhs
7023  xms(2)= -muh*rgh
7024  xm0= muh
7025  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7026  b0sumb= b0sumb+(coefb3.cp.b0part)
7027 *
7028  xms(1:2)= crmbs*co(1:2)
7029  xm0= sqrt(crmbs)
7030  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7031  b0sumf= coefb5.cp.b0part
7032 *
7033  xms(1:2)= mtl*mtl*co(1:2)
7034  xm0= mtl
7035  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7036  b0sumf= b0sumf+(coefb6.cp.b0part)
7037 *
7038  xms(1:2)= crmcs*co(1:2)
7039  xm0= sqrt(crmcs)
7040  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7041  b0sumf= b0sumf+(coefb7.cp.b0part)
7042 *
7043  xms(1:2)= mm*mm*co(1:2)
7044  xm0= mm
7045  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7046  b0sumf= b0sumf+(coefb8.cp.b0part)
7047 *
7048  xms(1:2)= msq*msq*co(1:2)
7049  xm0= msq
7050  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7051  b0sumf= b0sumf+(coefb9.cp.b0part)
7052 *
7053  xms(1:2)= mdq*mdq*co(1:2)
7054  xm0= mdq
7055  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7056  b0sumf= b0sumf+(coefb10.cp.b0part)
7057 *
7058  xms(1:2)= muq*muq*co(1:2)
7059  xm0= muq
7060  b0part=hto_lb0af_em(scal,cxp,p2,xms,xm0)
7061  b0sumf= b0sumf+(coefb11.cp.b0part)
7062 *
7063  xms(1:2)= me*me*co(1:2)
7064  xm0= me
7065  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7066  b0sumf= b0sumf+(coefb12.cp.b0part)
7067 *
7068  xms(1:2)= ucpt(1:2)
7069  xm0= mt
7070  b0part= hto_lb0af_em(scal,cxp,p2,xms,xm0)
7071  b0sumt= coefb4.cp.b0part
7072 *
7073  iz= 0
7074  xms(1:2)= crmbs*co(1:2)
7075  xm0= sqrt(crmbs)
7076  nloqcd= crmbs*hto_lquarkqcd(scal,cxp,p2,xms,xm0,iz)
7077  xms(1:2)= crmcs*co(1:2)
7078  xm0= sqrt(crmcs)
7079  nloqcd= nloqcd+crmcs*hto_lquarkqcd(scal,cxp,p2,xms,xm0,iz)
7080  IF(qcdc==0) nloqcd= 0.d0
7081 *
7082  xms= ucpt
7083  xm0= mt
7084  iz= 1
7085  ttqcd= hto_lquarkqcd(scal,cxp,p2,xms,xm0,iz)
7086  ttqcd= cpt.cp.ttqcd
7087  IF(qcdc==0) ttqcd= 0.d0
7088 *
7089  ksumf= -1.d0/32.d0*(sh.cq.cxw)*(cxe*clxe+cxmu*clxmu+
7090  # cxtau*clxtau+3.d0*(cxd*clxd+cxs*clxs+lcxb*lclxb+
7091  # cxu*clxu+lcxc*lclxc))+
7092  # 1.d0/8.d0*lcxwi*(cxes+cxmus+cxtaus+3.d0*(
7093  # cxds+cxss+lcxbs+cxus+lcxcs))
7094  ksumt= 3.d0/8.d0*((ccxt.cq.cxw).cp.ccxt)
7095  # -3.d0/32.d0*(clt.cp.((sh.cq.cxw).cp.ccxt))
7096 *
7097  ksumb= -1.d0/64.d0*((2.d0*co+cctsi+3.d0*(sh.cq.cxw)).cp.sh)
7098  # -1.d0/128.d0*(lclcts.cp.((6.d0*cctsi-(sh.cq.cxw)).cp.sh))
7099  # +3.d0/128.d0*(clw.cp.((4.d0*co+2.d0*cctsi-(sh.cq.cxw)).cp.sh))
7100  # -3.d0/128.d0*(clh.cp.(shs.cq.cxw))
7101 *
7102  shhf= b0sumf+ksumf
7103  shht= b0sumt+ksumt
7104  IF((lswr*shht(2)+lswi*shht(1)) < 0.d0) shht= 0.d0
7105  shhf= shhf+shht
7106  shhb= b0sumb+ksumb
7107  IF((lswr*shhb(2)+lswi*shhb(1)) < 0.d0) shhb= 0.d0
7108  shh= shhf+shhb
7109 *
7110 *--- W self energies
7111 *
7112  deltag= 6.d0*co+0.5d0*(((7.d0*co-4.d0*csts).cq.csts).cp.lclcts)
7113 *
7114  sww0= -(38.d0*cxw+6.d0*ccxt+7.d0*sh
7115  # -48.d0*(((ccxt.cq.sh).cq.cxw).cp.ccxt)+8.d0*(cxw.cq.sh))/128.d0
7116  # -3.d0/64.d0*((cxw-sh+(cxws.cq.cxhw)).cp.clh)
7117  # +3.d0/32.d0*(((co-4.d0*((ccxt.cq.sh).cq.cxw).cp.ccxt)).cp.clt)
7118  # +((((8.d0*co-17.d0*cstsi+3.d0*cctsi).cp.cxw)
7119  # -6.d0*((cxw.cq.sh).cq.cctq)).cp.lclcts)/64.d0
7120  # -((cxw.cq.sh).cq.cctq)/32.d0+5.d0/128.d0*(cxw.cq.ccts)
7121 *
7122  sww0w= -(38.d0*cxw+6.d0*ccxt+7.d0*sh
7123  # -48.d0*(((ccxt.cq.sh).cq.cxw).cp.ccxt)+8.d0*(cxw.cq.sh))/128.d0
7124  # -3.d0/64.d0*((cxw-sh+(cxws.cq.cxhw)).cp.(clh-clw))
7125  # +3.d0/32.d0*
7126  # (((co-4.d0*((ccxt.cq.sh).cq.cxw).cp.ccxt)).cp.(clt-clw))
7127  # +((((8.d0*co-17.d0*cstsi+3.d0*cctsi).cp.cxw)
7128  # -6.d0*((cxw.cq.sh).cq.cctq)).cp.lclcts)/64.d0
7129  # -((cxw.cq.sh).cq.cctq)/32.d0+5.d0/128.d0*(cxw.cq.ccts)
7130 *
7131  coefw1= -(((8.d0*co-(sh.cq.cxw)).cp.sh)*sh
7132  # -4.d0*((-12.d0*cxw+7.d0*sh).cp.cxw))/192.d0
7133 *
7134  coefw2= -((cxws.cq.csmcts).cp.(416.d0*co-192.d0*csts
7135  # -((132.d0*co-((12.d0*co+cctsi).cq.ccts)).cq.ccts)))/192.d0
7136 *
7137  cxp(1)= lswr
7138  cxp(2)= lswi
7139  p2= mw*mw
7140 *
7141  axms(1,1)= lswr
7142  axms(1,2)= lswi
7143  axm0(1)= mw
7144  axms(2,1)= muhs
7145  axms(2,2)= -muh*rgh
7146  axm0(2)= muh
7147  b0part= hto_lb021_dm_cp(scal,cxp,p2,axms,axm0)
7148  b0sumw1= (coefw1.cp.b0part)
7149  b0sumw= (coefw1.cp.b0part)
7150 *
7151  axms(1,1)= szr
7152  axms(1,2)= szi
7153  axm0(1)= mz
7154  axms(2,1)= lswr
7155  axms(2,2)= lswi
7156  axm0(2)= mw
7157  b0part= hto_lb021_dm_cp(scal,cxp,p2,axms,axm0)
7158  b0sumw2= (coefw2.cp.b0part)
7159  b0sumw= b0sumw+(coefw2.cp.b0part)
7160 *
7161  ksumw= -12.d0*((cxw
7162  # -0.5d0*((3.d0*co-(ccxts.cq.cxws)).cp.ccxt)).cp.cltmw)
7163  # -((24.d0*cxw-((14.d0*co-(sh.cq.cxw)).cp.sh)).cp.clh)
7164  # +((36.d0*cxw-14.d0*sh-18.d0*((co-4.d0*(ccxt.cq.sh)).cp.ccxt)
7165  # +(shs.cq.cxw)).cp.clw)
7166  # -6.d0*(((2.d0*co+((lcxwi-12.d0*shi).cp.ccxt)).cp.ccxt)
7167  # +1.d0/6.d0*((15.d0*co-(sh.cq.cxw)).cp.sh)
7168  # +2.d0/9.d0*((97.d0*co+9.d0*(cxw.cq.sh)).cp.cxw))
7169  # +(((cxw.cq.ccts).cp.(co-6.d0*(cxw.cq.sh))).cq.ccts)
7170  # -2.d0*(((cxw.cq.csmcts).cp.lclcts).cp.(62.d0*co
7171  # -48.d0*csts-5.d0*cctsi))
7172  # -18.d0*(((cxws.cq.sh).cq.cctq).cp.lclcts)
7173  # -72.d0*((clt.cp.ccxts).cp.(shi-1.d0/12.d0*(ccxt.cq.cxws)))
7174  # +23.d0*(cxw.cq.ccts)
7175  ksumw= ksumw/192.d0+3.d0/16.d0*(cxw.cp.(clw-clmw))
7176 *
7177  ksumww= -12.d0*((cxw
7178  # -0.5d0*((3.d0*co-(ccxts.cq.cxws)).cp.ccxt)).cp.(cltmw-clw))
7179  # -((24.d0*cxw-((14.d0*co-(sh.cq.cxw)).cp.sh)).cp.(clh-clw))
7180  # -6.d0*(((2.d0*co+((lcxwi-12.d0*shi).cp.ccxt)).cp.ccxt)
7181  # +1.d0/6.d0*((15.d0*co-(sh.cq.cxw)).cp.sh)
7182  # +2.d0/9.d0*((97.d0*co+9.d0*(cxw.cq.sh)).cp.cxw))
7183  # +(((cxw.cq.ccts).cp.(co-6.d0*(cxw.cq.sh))).cq.ccts)
7184  # -2.d0*(((cxw.cq.csmcts).cp.lclcts).cp.(62.d0*co
7185  # -48.d0*csts-5.d0*cctsi))
7186  # -18.d0*(((cxws.cq.sh).cq.cctq).cp.lclcts)
7187  # -72.d0*
7188  # (((clt-clw).cp.ccxts).cp.(shi-1.d0/12.d0*(ccxt.cq.cxws)))
7189  # +23.d0*(cxw.cq.ccts)
7190  ksumww= ksumww/192.d0+3.d0/16.d0*(cxw.cp.(clw-clmw))
7191 *
7192  sww= b0sumw+ksumw
7193  swww= b0sumw+ksumww
7194 *
7195  dw= -sww+sww0+deltag/16.d0
7196  dww= -swww+sww0w+deltag/16.d0
7197 * DW= 0.d0
7198 *
7199  ksumtop= 1.d0/128.d0*(-(2.d0*cxw+3.d0*cxb*co+cxbs*lcxwi)+48.d0*
7200  # ((cpt.cq.sh).cq.cxw)*cxbs+(cpts.cq.cxw)+(cpt.cp.(co
7201  # -4.d0*cxb*lcxwi)))*clxb
7202  # +1.d0/576.d0*(-(50.d0*cxw-9.d0*cxb*co-9.d0*cxbs*lcxwi
7203  # +17.d0*(cxw.cq.cctq)-40.d0*(cxw.cq.ccts))+18.d0*(cpts.cq.cxw)
7204  # +(cpt.cp.(co+17.d0*cctsi+9.d0*cxb*lcxwi-216.d0*((
7205  # cpts.cq.cxw).cq.sh)+54.d0*((cxw.cq.sh).cq.cctq)
7206  # +18.d0*(sh.cq.cxw)-216.d0*(shi.cp.cxw)*cxbs+108.d0*(cxw.cq.sh))))
7207  # +1.d0/1152.d0*(clt.cp.(432.d0*((cpts.cq.cxw).cp.(cpt.cq.sh))
7208  # -(cxw.cp.(32.d0*co-40.d0*cctsi+17.d0*cctqi))
7209  # +(cpt.cp.(32.d0-64.d0*csts-41.d0*cctsi-9.d0*(sh.cq.cxw)))))
7210  # -1.d0/128.d0*(clh.cp.((-4.d0*cpt+5.d0*sh).cp.(cpt.cq.cxw)))
7211  # +1.d0/1152.d0*(clw.cp.((50.d0*cxw+27.d0*cxb*co+9.d0*cxbs*
7212  # lcxwi+17.d0*(cxw.cq.cctq)-40.d0*(cxw.cq.ccts))
7213  # +9.d0*(cpts.cq.cxw)+(cpt.cp.(7.d0*co+64.d0*csts-7.d0*cctsi
7214  # -18.d0*cxb*lcxwi-108.d0*((cxw.cq.sh).cq.cctq)
7215  # -216.d0*(cxw.cq.sh)))))
7216  # -1.d0/1152.d0*(lclcts.cp.((cxw.cp.(32.d0*co-40.d0*
7217  # cctsi+17.d0*cctqi))+(cpt.cp.(16.d0*co+64.d0*csts-7.d0*
7218  # cctsi-108.d0*((cxw.cq.sh).cq.cctq)))))
7219 *
7220  coeft1= -1.d0/576.d0*(-(cxw.cp.(32.d0*co-40.d0*cctsi+17.d0*
7221  # cctqi))+(cpt.cp.(16.d0*co+64.d0*csts-7.d0*cctsi)))
7222 *
7223  coeft2= 1.d0/64.d0*((-4.d0*cpt+sh).cp.(cpt.cq.cxw))
7224 *
7225  coeft3= 1.d0/9.d0*(csts.cp.cpt)
7226 *
7227  coeft4= 1.d0/64.d0*((-2.d0*cxw+cxb*co+cxbs*lcxwi)
7228  # +(cpts.cq.cxw)+(cpt.cp.(co-2.d0*cxb*lcxwi)))
7229 *
7230  cxp(1)= mt*mt
7231  cxp(2)= -mt*rgt
7232  p2= mt*mt
7233 *
7234  axms(1,1)= mt*mt
7235  axms(1,2)= -mt*rgt
7236  axm0(1)= mt
7237  axms(2,1)= szr
7238  axms(2,2)= szi
7239  axm0(2)= mz
7240  b0part= hto_lb0af_dm(scal,cxp,p2,axms,axm0)
7241  b0sumtop= (coeft1.cp.b0part)
7242 *
7243  axms(1,1)= mt*mt
7244  axms(1,2)= -mt*rgt
7245  axm0(1)= mt
7246  axms(2,1)= muhs
7247  axms(2,2)= -muh*rgh
7248  axm0(2)= muh
7249  b0part= hto_lb0af_dm(scal,cxp,p2,axms,axm0)
7250  b0sumtop= b0sumtop+(coeft2.cp.b0part)
7251 *
7252  b0part= 2.d0*co
7253  b0sumtop= b0sumtop+(coeft3.cp.b0part)
7254 *
7255  axms(1,1)= mb*mb
7256  axms(1,2)= 0.d0
7257  axm0(1)= mb
7258  axms(2,1)= lswr
7259  axms(2,2)= lswi
7260  axm0(2)= mw
7261  b0part= hto_lb0af_dm(scal,cxp,p2,axms,axm0)
7262  b0sumtop= b0sumtop+(coeft4.cp.b0part)
7263 *
7264  ksumtops= cpt/6.d0-(clt.cp.cpt)/2.d0
7265 *
7266  coeft1s= 1.d0/3.d0*cpt
7267 *
7268  b0part= 2.d0*co
7269  b0sumtops= coeft1s.cp.b0part
7270 *
7271  stt= b0sumtop+ksumtop
7272  stts= b0sumtops+ksumtops
7273 *
7274  ewc= 4.d0*sqrt(2.d0)*g_f/pis
7275 *
7276  asmur= 0.13939d0
7277  emc= 1.4d0
7278  emb= 4.75d0
7279  emt= mt
7280  iz= 0
7281  CALL hto_initalphas(iz,one,mz,asmur,emc,emb,emt)
7282  as_lo= hto_alphas(scal)/pi
7283 *
7284  fvcp(1)= rgw/mw*(1.d0+ewc*(lswr*dww(1)-lswi*dww(2)))
7285  # -ewc*(scal/mw)**2*(lswr*swww(2)+lswi*swww(1))
7286 *
7287  fvcp(2)= rgh/muh*(1.d0+ewc*(lswr*dw(1)-lswi*dw(2)))
7288  # -ewc*(lswr*shh(2)+lswi*shh(1))*scals/muhs
7289  # +as_nlo*g_f/(sqrt(2.d0)*pis)*
7290  # (sh(1)*nloqcd(2)+sh(2)*nloqcd(1))*scals/muhs
7291  # +as_nlo*g_f/(sqrt(2.d0)*pis)*
7292  # (sh(1)*ttqcd(2)+sh(2)*ttqcd(1))*scals/muhs
7293 *
7294  IF(n == 3) THEN
7295  fvcp(3)= rgt/mt*(1.d0+2.d0*ewc*(lswr*dw(1)-lswi*dw(2)))
7296  # -scals/(mt*mt)*(ewc*(lswr*stt(2)+lswi*stt(1))+
7297  # 4.d0*(scals/(mt*mt))*as_lo*stts(2))
7298  ENDIF
7299 *
7300  RETURN
7301 *
7302  END SUBROUTINE hto_cpoles
7303 *
7304 *------------------------------------------------------------------
7305 *
7306  FUNCTION hto_lquarkqcd(scal,psi,ps0i,xmsi,xm0i,type) RESULT(value)
7307  USE hto_riemann
7308  USE hto_acmplx_pro
7309  USE hto_acmplx_rat
7310  USE hto_cmplx_root
7311  USE hto_cmplx_rootz
7312  USE hto_cmplx_srs_root
7313  USE hto_ln_2_riemann
7314  USE hto_full_ln
7315  USE hto_sp_fun
7316  USE hto_units
7317 *
7318  IMPLICIT NONE
7319 *
7320  INTEGER it,type,unit
7321  REAL*8 scal,ps0i,xm0i,scals,ps0,xm0,sgn
7322  real*8, dimension(2) :: value,psi,ps,xmsi,xms,betasc,betas,
7323  # betac,beta,argc,arg,lq,lm,cx,comx,cxs,x,omx,xs,clx,clomx,
7324  # clxs,li2cx,li3cx,li2cxs,li3cxs,copx,clopx,lqs,qcd,lms,
7325  # opx,tau,taus,clxx,clxxs
7326  real*8, dimension(6,2) :: aux,auxs
7327 *
7328  scals= scal*scal
7329  ps= psi/scals
7330  ps0= ps0i/scals
7331  xms= xmsi/scals
7332  xm0= xm0i/scal
7333 *
7334  IF(psi(2).eq.0.d0.and.xmsi(2).eq.0.d0.
7335  # and.psi(1).le.4.d0*xmsi(1)) THEN
7336  unit= 1
7337  ELSE
7338  unit= 0
7339  ENDIF
7340 *
7341  IF(abs(ps(2)/ps(1)).lt.1.d-10.and.xms(2).eq.0.d0) THEN
7342  betasc(1)= 1.d0-4.d0*xms(1)/ps(1)
7343  betasc(2)= 4.d0/(ps(1)*ps(1))*xms(1)*ps(2)
7344  ELSE
7345  betasc= co-4.d0*(xms.cq.ps)
7346  ENDIF
7347  IF(betasc(2).eq.0.d0) THEN
7348  betasc(2)= -eps
7349  betac= (betasc(1)).cr.(betasc(2))
7350  ELSE
7351  betac= (betasc(1)).crz.(betasc(2))
7352  ENDIF
7353  argc= (betac+co).cq.(betac-co)
7354 *
7355  betas(1)= 1.d0-4.d0*xm0*xm0/ps0
7356  betas(2)= -eps
7357  beta= (betas(1)).cr.(betas(2))
7358  arg= (beta+co).cq.(beta-co)
7359 *
7360  IF(arg(2).eq.0.d0) THEN
7361  x(1)= 1.d0/arg(1)
7362  x(2)= -eps
7363  sgn= sign(one,x(1))
7364  xs(1)= x(1)*x(1)
7365  xs(2)= -sgn*eps
7366  ELSE
7367  x= (beta-co).cq.(beta+co)
7368  xs= x.cp.x
7369  ENDIF
7370  omx= co-x
7371  opx= co+x
7372 *
7373  IF(arg(2).eq.0.d0) arg(2)= eps
7374  IF(argc(2).eq.0.d0) THEN
7375  it= 0
7376  argc(2)= eps
7377  lq= argc(1).fln.argc(2)
7378  ELSE
7379  it= 1
7380  lq= argc.lnsrs.arg
7381  ENDIF
7382  lqs= lq.cp.lq
7383 *
7384  IF(it.eq.0.d0) THEN
7385  cx(1)= 1.d0/argc(1)
7386  cx(2)= -eps
7387  comx= co-cx
7388  copx= co+cx
7389  sgn= sign(one,cx(1))
7390  cxs(1)= cx(1)*cx(1)
7391  cxs(2)= -sgn*eps
7392  clx= cx(1).fln.cx(2)
7393  clxs= clx.cp.clx
7394  clxx= cxs(1).fln.cxs(2)
7395  clxxs= clxx.cp.clxx
7396  clomx= comx(1).fln.comx(2)
7397  clopx= copx(1).fln.copx(2)
7398  aux= hto_s_niels_up4(cx)
7399  li2cx(1:2)= aux(1,1:2)
7400  li3cx(1:2)= aux(2,1:2)
7401  auxs= hto_s_niels_up4(cxs)
7402  li2cxs(1:2)= auxs(1,1:2)
7403  li3cxs(1:2)= auxs(2,1:2)
7404  ELSEIF(it.eq.1.d0) THEN
7405  cx= (betac-co).cq.(betac+co)
7406  comx= co-cx
7407  copx= co+cx
7408  cxs= cx.cp.cx
7409  clx= cx.lnsrs.x
7410  clxs= clx.cp.clx
7411  clxx= cxs.lnsrs.xs
7412  clxxs= clxx.cp.clxx
7413  clomx= comx.lnsrs.omx
7414  clopx= copx.lnsrs.opx
7415  li2cx= hto_li2_srsz(cx,x,unit)
7416  li3cx= hto_li3_srsz(cx,x,unit)
7417  li2cxs= hto_li2_srsz(cxs,xs,unit)
7418  li3cxs= hto_li3_srsz(cxs,xs,unit)
7419  ENDIF
7420 *
7421  IF(xms(2).eq.0.d0) THEN
7422  lm(1)= log(xms(1))
7423  lm(2)= 0.d0
7424  ELSE
7425  lm= xms(1).fln.xms(2)
7426  ENDIF
7427  lms= lm.cp.lm
7428 *
7429  tau= xms.cq.ps
7430  taus= tau.cp.tau
7431 *
7432  IF(type.eq.0) THEN
7433 *
7434  qcd= -3.d0/4.d0*(co-12.d0*tau)*rz2
7435  # +1.d0/16.d0*(3.d0*co+344.d0*tau)
7436  # -3.d0/2.d0*((co-6.d0*tau).cp.lms)
7437  # +3.d0/4.d0*((3.d0*co-14.d0*tau).cp.(betac.cp.clx))
7438  # -3.d0*((li3cxs-2.d0*li3cx+4.d0/3.d0*(li2cx.cp.clx)
7439  # +1.d0/3.d0*(clxs.cp.clomx)+rz3*co
7440  # -2.d0/3.d0*(clxx.cp.li2cxs)-1.d0/6.d0*(clxxs.cp.clomx)
7441  # -1.d0/6.d0*
7442  # (clxxs.cp.clopx)).cp.((co-4.d0*tau).cp.(co-2.d0*tau)))
7443  # -1.d0/2.d0*((4.d0*li2cxs-4.d0*li2cx-4.d0*(clomx.cp.clx)
7444  # -2.d0*(cx.cp.(clxs.cq.comx))+4.d0*(clxx.cp.clomx)
7445  # +4.d0*(clxx.cp.clopx)+(clxxs.cp.(cxs.cq.comx))
7446  # +(clxxs.cp.(cxs.cq.copx))).cp.(betac.cp.(co-4.d0*tau)))
7447  # +1.d0/4.d0*(lm.cp.(11.d0*co-108.d0*tau))
7448  # +1.d0/4.d0*(clxs.cp.(3.d0*co+58.d0*taus-28.d0*tau))
7449 *
7450  ELSEIF(type.eq.1) THEN
7451 *
7452  qcd= -3.d0/4.d0*(co-12.d0*tau)*rz2
7453  # +1.d0/16.d0*(67.d0*co-40.d0*tau)
7454  # +3.d0/4.d0*((3.d0*co-14.d0*tau).cp.(betac.cp.clx))
7455  # -3.d0*((li3cxs-2.d0*li3cx+4.d0/3.d0*(li2cx.cp.clx)
7456  # +1.d0/3.d0*(clxs.cp.clomx)+rz3*co
7457  # -2.d0/3.d0*(clxx.cp.li2cxs)-1.d0/6.d0*(clxxs.cp.clomx)
7458  # -1.d0/6.d0*
7459  # (clxxs.cp.clopx)).cp.((co-4.d0*tau).cp.(co-2.d0*tau)))
7460  # -1.d0/2.d0*((4.d0*li2cxs-4.d0*li2cx-4.d0*(clomx.cp.clx)
7461  # -2.d0*(cx.cp.(clxs.cq.comx))+4.d0*(clxx.cp.clomx)
7462  # +4.d0*(clxx.cp.clopx)+(clxxs.cp.(cxs.cq.comx))
7463  # +(clxxs.cp.(cxs.cq.copx))).cp.(betac.cp.(co-4.d0*tau)))
7464  # -2.d0*
7465  # (((co-8.d0*tau).cp.(betac.cp.lq)).cp.(co-3.d0/4.d0*lm))
7466  # -3.d0*((betac.cp.lq).cp.(lm.cp.tau))
7467  # +4.d0*((co.cp.betac).cp.(lq.cp.tau))
7468  # -9.d0/4.d0*(lm.cp.(co+4.d0*tau))
7469  # +9.d0*(lms.cp.tau)
7470  # +1.d0/4.d0*(clxs.cp.(3.d0*co+58.d0*taus-28.d0*tau))
7471 *
7472  ENDIF
7473 *
7474  value= qcd
7475 *
7476  RETURN
7477 *
7478  END FUNCTION hto_lquarkqcd
7479 *
7480 *------------------------------------------------------------------
7481 *
7482  FUNCTION hto_lb0af_dm(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
7483  USE hto_acmplx_pro
7484  USE hto_acmplx_rat
7485  USE hto_cmplx_root
7486  USE hto_cmplx_rootz
7487  USE hto_cmplx_srs_root
7488  USE hto_ln_2_riemann
7489  USE hto_full_ln
7490  USE hto_units
7491 *
7492  IMPLICIT NONE
7493 *
7494  real*8 scal,ps0i,scals,ps0,xm1,xm2
7495  real*8, dimension(2,2) :: xmsi,xms
7496  real*8, dimension(2) :: value,psi,ps,lambdasc,lambdas,
7497  # lambdac,lambda,argc,arg,llam,lm,xm0,xm0i,aroot,
7498  # root,rat,lnr,xm1c,xm2c
7499 *
7500  scals= scal*scal
7501  ps= psi/scals
7502  ps0= ps0i/scals
7503  xms= xmsi/scals
7504  xm0= xm0i/scal
7505  xm1c(1:2)= xms(1,1:2)
7506  xm2c(1:2)= xms(2,1:2)
7507  xm1= xm0(1)*xm0(1)
7508  xm2= xm0(2)*xm0(2)
7509  aroot= xm1c.cp.xm2c
7510  root= (aroot(1).crz.aroot(2))
7511 *
7512  lambdasc= (ps.cp.ps)+(xm1c.cp.xm1c)+(xm2c.cp.xm2c)-2.d0*(
7513  # (ps.cp.xm1c)+(ps.cp.xm2c)+(xm1c.cp.xm2c))
7514  lambdas(1)= ps0*ps0+xm1*xm1+xm2*xm2-2.d0*(
7515  # ps0*xm1+ps0*xm2+xm1*xm2)
7516  lambdas(2)= -eps
7517  lambdac= (lambdasc(1)).crz.(lambdasc(2))
7518  lambda= (lambdas(1)).cr.(lambdas(2))
7519  IF(lambda(2).eq.0.d0) lambda(2)= -eps
7520 *
7521  argc= 0.5d0*((-ps+xm1c+xm2c-lambdac).cq.root)
7522 *
7523  arg(1)= 0.5d0*(-ps0+xm1+xm2-lambda(1))/sqrt(xm1*xm2)
7524  arg(2)= eps
7525 *
7526  llam= argc.lnsrs.arg
7527 *
7528  rat= xm1c.cq.xm2c
7529  lnr= rat(1).fln.rat(2)
7530 *
7531  value= 2.d0*co-0.5d0*(((xm1c-xm2c).cq.ps).cp.lnr)-
7532  # ((lambdac.cq.ps).cp.llam)
7533 *
7534  RETURN
7535 *
7536  END FUNCTION hto_lb0af_dm
7537 *
7538 *-------------------------------------------------------------------
7539 *
7540  FUNCTION hto_lb0af_em(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
7541  USE hto_acmplx_pro
7542  USE hto_acmplx_rat
7543  USE hto_cmplx_root
7544  USE hto_cmplx_rootz
7545  USE hto_cmplx_srs_root
7546  USE hto_ln_2_riemann
7547  USE hto_full_ln
7548  USE hto_units
7549 *
7550  IMPLICIT NONE
7551 *
7552  real*8 scal,ps0i,xm0i,scals,ps0,xm0
7553  real*8, dimension(2) :: value,psi,ps,xmsi,xms,betasc,betas,
7554  # betac,beta,argc,arg,lbet
7555 *
7556  scals= scal*scal
7557  ps= psi/scals
7558  ps0= ps0i/scals
7559  xms= xmsi/scals
7560  xm0= xm0i/scal
7561 *
7562  betasc= co-4.d0*(xms.cq.ps)
7563  IF(betasc(2).eq.0.d0) THEN
7564  betasc(2)= -eps
7565  betac= (betasc(1)).cr.(betasc(2))
7566  ELSE
7567  betac= (betasc(1)).crz.(betasc(2))
7568  ENDIF
7569  argc= (betac+co).cq.(betac-co)
7570  IF(argc(2).eq.0.d0) THEN
7571  argc(2)= eps
7572  lbet= argc(1).fln.argc(2)
7573  ELSE
7574  betas(1)= 1.d0-4.d0*(xm0*xm0)/ps0
7575  betas(2)= -eps
7576  beta= (betas(1)).cr.(betas(2))
7577  arg= (beta+co).cq.(beta-co)
7578  IF(arg(2).eq.0.d0) arg(2)= eps
7579  lbet= argc.lnsrs.arg
7580  ENDIF
7581 *
7582  value= 2.d0*co-(betac.cp.lbet)
7583 *
7584  RETURN
7585 *
7586  END FUNCTION hto_lb0af_em
7587 *
7588 *-----------------------------------------------------------------------
7589 *
7590  FUNCTION hto_lb021_dm_cp(scal,psi,ps0i,xmsi,xm0i) RESULT(value)
7591  USE hto_cmplx_root
7592  USE hto_cmplx_rootz
7593  USE hto_cmplx_srs_root
7594  USE hto_ln_2_riemann
7595  USE hto_acmplx_pro
7596  USE hto_acmplx_rat
7597  USE hto_full_ln
7598  USE hto_units
7599 *
7600  IMPLICIT NONE
7601 *
7602  INTEGER i,nci,nc
7603  REAL*8 scal,scals,ps0i,ps0,xm1,xm2
7604  real*8, intent(in), dimension(2) :: xm0i
7605  real*8, intent(in), dimension(2,2) :: xmsi
7606  real*8, dimension(2) :: value,xm1c,xm2c
7607  real*8, dimension(2,2) :: xms
7608  real*8, dimension(2) :: xm0
7609  real*8, dimension(2) :: psi,ps,aroot,root,lambdasc,lambdas,
7610  # lambdac,lambda,argc,arg,llam,l1,l2
7611 *
7612  ps= psi
7613  ps0= ps0i
7614  xms= xmsi
7615  xm0= xm0i
7616 *
7617  xm1c(1:2)= xms(1,1:2)
7618  xm2c(1:2)= xms(2,1:2)
7619  xm1c= xm1c.cq.ps
7620  xm2c= xm2c.cq.ps
7621  xm1= xm0(1)*xm0(1)/ps0
7622  xm2= xm0(2)*xm0(2)/ps0
7623 *
7624  aroot= xm1c.cp.xm2c
7625  root= (aroot(1).crz.aroot(2))
7626 *
7627  lambdasc= co+(xm1c.cp.xm1c)+(xm2c.cp.xm2c)-2.d0*(
7628  # xm1c+xm2c+(xm1c.cp.xm2c))
7629  lambdas(1)= 1.d0+xm1*xm1+xm2*xm2-2.d0*(
7630  # xm1+xm2+xm1*xm2)
7631  lambdas(2)= -eps
7632  lambdac= (lambdasc(1)).crz.(lambdasc(2))
7633  lambda= (lambdas(1)).cr.(lambdas(2))
7634  IF(lambda(2).eq.0.d0) lambda(2)= -eps
7635 *
7636  argc= 0.5d0*((-co+xm1c+xm2c-lambdac).cq.root)
7637 *
7638  arg(1)= 0.5d0*(-1.d0+xm1+xm2-lambda(1))/sqrt(xm1*xm2)
7639  arg(2)= eps
7640 *
7641  llam= argc.lnsrs.arg
7642 *
7643  l1= xm1c(1).fln.xm1c(2)
7644  l2= xm2c(1).fln.xm2c(2)
7645 *
7646  value= (((xm1c-xm2c-co).cq.lambdac).cp.llam)+0.5d0*(l1-l2)
7647 *
7648  RETURN
7649 *
7650  END FUNCTION hto_lb021_dm_cp
7651 *
7652 *----------------------------------------------------------------------
7653 *
7654 !Heshy note: I added mhb, copied from POWHEG
7655  SUBROUTINE call_hto(mhiggs,mtop,mhb,ghb)
7656  USE hto_masses
7657  USE hto_aux_hcp
7658  USE hto_puttime
7659  IMPLICIT NONE
7660  real*8 mhiggs,mtop,mhb,ghb
7661 *
7662  qcdc= 1
7663  gtop= 1
7664 *
7665 * your choice for G_top [GeV] (requires gtop = 2)
7666 *
7667  yimt= 0.d0
7668 *
7669 * top-quark mass
7670 *
7671  mt= mtop
7672  CALL hto_pole(mhiggs,mhb,ghb)
7673 *
7674  RETURN
7675 *
7676  END SUBROUTINE call_hto
7677 
7678 
hto_rzeta
Definition: CALLING_cpHTO.f:2055
hto_cmplx_ln
Definition: CALLING_cpHTO.f:439
hto_bernoulli::b_num
real *8, dimension(0:18) b_num
Definition: CALLING_cpHTO.f:210
hto_sp_fun::hto_li3
real *8 function, dimension(size(x)) hto_li3(x)
Definition: CALLING_cpHTO.f:1401
hto_masses::mm
real *8, parameter mm
Definition: CALLING_cpHTO.f:78
hto_aux_hcp::cxtmbs
real *8 cxtmbs
Definition: CALLING_cpHTO.f:62
hto_cmplx_root::cr
real *8 function, dimension(2) cr(x, ep)
Definition: CALLING_cpHTO.f:665
value
pymela::gHIGGS_KAPPA value("gHIGGS_KAPPA_TILDE", pymela::gHIGGS_KAPPA_TILDE) .value("SIZE_HQQ"
hto_qcd::hto_qcdlam
real *8 function hto_qcdlam(nf, als, rs, x1, x2, xacc)
Definition: CALLING_cpHTO.f:3114
hto_asinp::m20
real *8 m20
Definition: CALLING_cpHTO.f:2062
hto_acmplx_pro
Definition: CALLING_cpHTO.f:257
hto_aux_hcp::xq
real *8 xq
Definition: CALLING_cpHTO.f:62
hto_aux_hbb::cctvi
real *8, dimension(2) cctvi
Definition: CALLING_cpHTO.f:227
hto_pole
subroutine hto_pole(m, mhb, ghb)
Definition: CALLING_cpHTO.f:5038
hto_units::ione
integer, parameter ione
Definition: CALLING_cpHTO.f:181
hto_masses::swr
real *8, parameter swr
Definition: CALLING_cpHTO.f:89
hto_deriv
real *8 function, dimension(10, 2) hto_deriv(scal, rhm)
Definition: CALLING_cpHTO.f:4545
hto_gh
subroutine hto_gh(muh, cpgh)
Definition: CALLING_cpHTO.f:5094
hto_linear_comb_c::lcc
real *8 function, dimension(2) lcc(c, x)
Definition: CALLING_cpHTO.f:346
hto_aux_hbb::cxw
real *8, dimension(2) cxw
Definition: CALLING_cpHTO.f:227
hto_aux_hcp::pcnt
integer pcnt
Definition: CALLING_cpHTO.f:61
hto_aux_hcp::cpw
real *8, dimension(2) cpw
Definition: CALLING_cpHTO.f:67
hto_aux_hcp::qcdc
integer qcdc
Definition: CALLING_cpHTO.f:61
hto_aux_hcp::clwtb
real *8, dimension(2) clwtb
Definition: CALLING_cpHTO.f:67
hto_masses::mcq
real *8, parameter mcq
Definition: CALLING_cpHTO.f:82
hto_real_ln
Definition: CALLING_cpHTO.f:424
hto_units::one
real *8, parameter one
Definition: CALLING_cpHTO.f:184
hto_rootw
Definition: CALLING_cpHTO.f:245
hto_sp_fun::hto_init_niels
subroutine hto_init_niels
Definition: CALLING_cpHTO.f:1822
hto_dzpar::fr2c
real *8 fr2c
Definition: CALLING_cpHTO.f:2047
hto_riemann::rz3
real *8, parameter rz3
Definition: CALLING_cpHTO.f:200
hto_hbb_cp
Definition: CALLING_cpHTO.f:3586
hto_masses::mz
real *8, parameter mz
Definition: CALLING_cpHTO.f:76
hto_cmplx_rootz
Definition: CALLING_cpHTO.f:680
hto_aux_hcp::cxt
real *8 cxt
Definition: CALLING_cpHTO.f:62
hto_nffix
Definition: CALLING_cpHTO.f:2070
hto_solve_nonlin::hto_fdjac1
subroutine hto_fdjac1(HTO_FCN, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn, wa1, wa2)
Definition: CALLING_cpHTO.f:5962
hto_set_phys_const::alpha_s_kmh
real *8 alpha_s_kmh
Definition: CALLING_cpHTO.f:240
hto_masses::mdq
real *8, parameter mdq
Definition: CALLING_cpHTO.f:81
hto_colour::ca
real *8 ca
Definition: CALLING_cpHTO.f:2059
hto_asfthr::m2b
real *8 m2b
Definition: CALLING_cpHTO.f:2077
hto_units::cz
real *8, dimension(1:2) cz
Definition: CALLING_cpHTO.f:190
hto_units::qeps
real *8, parameter qeps
Definition: CALLING_cpHTO.f:186
hto_units::ci
real *8, dimension(1:2) ci
Definition: CALLING_cpHTO.f:189
hto_set_phys_const
Definition: CALLING_cpHTO.f:239
hto_asfthr::m2t
real *8 m2t
Definition: CALLING_cpHTO.f:2077
hto_qcd
Definition: CALLING_cpHTO.f:3031
hto_aux_hcp::yimt
real *8 yimt
Definition: CALLING_cpHTO.f:62
hto_dzero
real *8 function hto_dzero(A0, B0, EPS, MAXF, F, MODE)
Definition: CALLING_cpHTO.f:2683
hto_cpoles
subroutine hto_cpoles(n, xcp, fvcp, iflag)
Definition: CALLING_cpHTO.f:6768
hto_riemann
Definition: CALLING_cpHTO.f:195
hto_betacom::beta2
real *8, dimension(3:6) beta2
Definition: CALLING_cpHTO.f:2080
hto_qcd::hto_rrunm
real *8 function hto_rrunm(x1, x2, xacc, qm, als, rm1, rm2, fn)
Definition: CALLING_cpHTO.f:3292
hto_real_lnz::rlnz
real *8 function rlnz(x, y)
Definition: CALLING_cpHTO.f:370
hto_betacom::beta3
real *8, dimension(3:6) beta3
Definition: CALLING_cpHTO.f:2080
hto_a_cmplx
Definition: CALLING_cpHTO.f:3356
hto_initalphasr0
subroutine hto_initalphasr0(IORD, FR2, R0, ASI, MC, MB, MT)
Definition: CALLING_cpHTO.f:2159
hto_lquarkqcd
real *8 function, dimension(2) hto_lquarkqcd(scal, psi, ps0i, xmsi, xm0i, type)
Definition: CALLING_cpHTO.f:7307
hto_aux_hcp::cxtmb
real *8 cxtmb
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxq
real *8 cxq
Definition: CALLING_cpHTO.f:62
hto_ln_2_riemann::lnsrs
real *8 function, dimension(2) lnsrs(x, y)
Definition: CALLING_cpHTO.f:523
hto_solve_nonlin
Definition: CALLING_cpHTO.f:5303
hto_acmplx_rat::cq
real *8 function, dimension(2) cq(x, y)
Definition: CALLING_cpHTO.f:298
hto_masses::mtiny
real *8, parameter mtiny
Definition: CALLING_cpHTO.f:86
hto_linear_comb_c
Definition: CALLING_cpHTO.f:340
hto_aux_hbb::cxwc
real *8, dimension(2) cxwc
Definition: CALLING_cpHTO.f:227
hto_aux_hcp::clxs
real *8 clxs
Definition: CALLING_cpHTO.f:62
hto_dzpar::mbc
real *8 mbc
Definition: CALLING_cpHTO.f:2047
hto_aux_hbb::cctq
real *8, dimension(2) cctq
Definition: CALLING_cpHTO.f:227
hto_qcd::hto_qcdscale
real *8 function hto_qcdscale(nf, als, rs, x)
Definition: CALLING_cpHTO.f:3139
hto_units::co
real *8, dimension(1:2) co
Definition: CALLING_cpHTO.f:188
hto_riemann::piq
real *8, parameter piq
Definition: CALLING_cpHTO.f:198
hto_solve_nonlin::hto_hybrd
subroutine, public hto_hybrd(HTO_FCN, n, x, fvec, xtol, maxfev, ml, mu, epsfcn, diag, mode, factor, nprint, info, nfev)
Definition: CALLING_cpHTO.f:5450
hto_kountac::kp
integer kp
Definition: CALLING_cpHTO.f:725
hto_aux_hcp::cxtmbi
real *8 cxtmbi
Definition: CALLING_cpHTO.f:62
hto_units::izer
integer, parameter izer
Definition: CALLING_cpHTO.f:180
hto_set_phys_const::g_f
real *8 g_f
Definition: CALLING_cpHTO.f:240
hto_hbb_cp::hto_sshh
real *8 function hto_sshh(x)
Definition: CALLING_cpHTO.f:3590
hto_asfthr::ast
real *8 ast
Definition: CALLING_cpHTO.f:2077
hto_rzeta::zeta
real *8, dimension(6) zeta
Definition: CALLING_cpHTO.f:2056
hto_dzpar::asmurc
real *8 asmurc
Definition: CALLING_cpHTO.f:2047
hto_aux_hcp::cxmu
real *8 cxmu
Definition: CALLING_cpHTO.f:62
hto_aspar::naord
integer naord
Definition: CALLING_cpHTO.f:2065
hto_aux_hcp::clxu
real *8 clxu
Definition: CALLING_cpHTO.f:62
hto_acmplx_rat
Definition: CALLING_cpHTO.f:292
hto_betafct
subroutine hto_betafct
Definition: CALLING_cpHTO.f:2644
hto_masses::msq
real *8, parameter msq
Definition: CALLING_cpHTO.f:83
hto_aux_hcp::cxu
real *8 cxu
Definition: CALLING_cpHTO.f:62
hto_optcp
Definition: CALLING_cpHTO.f:233
hto_asinp::as0
real *8 as0
Definition: CALLING_cpHTO.f:2062
hto_solve_nonlin::hto_r1mpyq
subroutine hto_r1mpyq(m, n, a, lda, v, w)
Definition: CALLING_cpHTO.f:6367
hto_rootw::inc
integer inc
Definition: CALLING_cpHTO.f:246
nf
@ nf
Definition: TMCFM.hh:17
hto_aux_hcp::cxtaus
real *8 cxtaus
Definition: CALLING_cpHTO.f:62
hto_olas::hto_b0af_em
real *8 function, dimension(2) hto_b0af_em(scal, psi, ps0i, xmsi, xm0i)
Definition: CALLING_cpHTO.f:2800
hto_aux_hbb::cxz
real *8, dimension(2) cxz
Definition: CALLING_cpHTO.f:227
hto_ln_2_riemann
Definition: CALLING_cpHTO.f:517
hto_asinp
Definition: CALLING_cpHTO.f:2061
hto_cmplx_ln::cln
real *8 function, dimension(2) cln(x, ep)
Definition: CALLING_cpHTO.f:445
hto_aux_hcp::cxb
real *8 cxb
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxs
real *8 cxs
Definition: CALLING_cpHTO.f:62
hto_hbb_cp::hto_shh
real *8 function hto_shh(muhr, scal, rgh)
Definition: CALLING_cpHTO.f:3611
hto_evnfthr
subroutine hto_evnfthr(MC2, MB2, MT2)
Definition: CALLING_cpHTO.f:2451
hto_masses::swi
real *8, parameter swi
Definition: CALLING_cpHTO.f:90
hto_sp_fun::hto_cqlnomx
real *8 function, dimension(2) hto_cqlnomx(arg, omarg)
Definition: CALLING_cpHTO.f:1970
hto_masses::muq
real *8, parameter muq
Definition: CALLING_cpHTO.f:80
hto_kountac
Definition: CALLING_cpHTO.f:724
hto_aux_hbb::cswt
real *8, dimension(2) cswt
Definition: CALLING_cpHTO.f:227
hto_aux_hcp
Definition: CALLING_cpHTO.f:60
hto_fmmsplinesinglel
subroutine hto_fmmsplinesinglel(b, c, d, top, gdim)
Definition: CALLING_cpHTO.f:4369
hto_masses::mbq
real *8, parameter mbq
Definition: CALLING_cpHTO.f:84
hto_aux_hcp::cxbi
real *8 cxbi
Definition: CALLING_cpHTO.f:62
hto_transfmh
Definition: CALLING_cpHTO.f:251
hto_sp_fun::hto_li2_srsz
real *8 function, dimension(2) hto_li2_srsz(x, y, unit)
Definition: CALLING_cpHTO.f:1065
hto_solve_nonlin::hto_dogleg
subroutine hto_dogleg(n, r, lr, diag, qtb, delta, x, wa1, wa2)
Definition: CALLING_cpHTO.f:5805
hto_sp_fun
Definition: CALLING_cpHTO.f:753
hto_masses::mtl
real *8, parameter mtl
Definition: CALLING_cpHTO.f:79
hto_aux_hbb::rcmw
real *8, dimension(2) rcmw
Definition: CALLING_cpHTO.f:227
hto_dzpar::murc
real *8 murc
Definition: CALLING_cpHTO.f:2047
hto_as
real *8 function hto_as(R2, R20, AS0, NF)
Definition: CALLING_cpHTO.f:2521
hto_aux_hbb::xtop
real *8 xtop
Definition: CALLING_cpHTO.f:226
hto_aux_hcp::clxe
real *8 clxe
Definition: CALLING_cpHTO.f:62
hto_findalphasr0
real *8 function hto_findalphasr0(ASI)
Definition: CALLING_cpHTO.f:2142
hto_units
Definition: CALLING_cpHTO.f:179
hto_root_find2::hto_zeroin
real *8 function hto_zeroin(f, ax, bx, aerr, rerr)
Definition: CALLING_cpHTO.f:3428
hto_frrat::logfr
real *8 logfr
Definition: CALLING_cpHTO.f:2074
hto_dzpar
Definition: CALLING_cpHTO.f:2045
hto_riemann::ln_pi
real *8, parameter ln_pi
Definition: CALLING_cpHTO.f:204
hto_aux_hcp::clxtau
real *8 clxtau
Definition: CALLING_cpHTO.f:62
hto_imag_lnz
Definition: CALLING_cpHTO.f:379
hto_sp_fun::hto_li2
real *8 function, dimension(2) hto_li2(x)
Definition: CALLING_cpHTO.f:1302
hto_full_ln
Definition: CALLING_cpHTO.f:464
hto_set_phys_const::alpha_0
real *8 alpha_0
Definition: CALLING_cpHTO.f:240
hto_fmmsplinesingleht
subroutine hto_fmmsplinesingleht(b, c, d, top, gdim)
Definition: CALLING_cpHTO.f:4131
hto_aux_hcp::cxts
real *8 cxts
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::clxc
real *8 clxc
Definition: CALLING_cpHTO.f:62
hto_solve_nonlin::hto_enorm
real *8 function hto_enorm(n, x)
Definition: CALLING_cpHTO.f:6621
hto_aux_hcp::cxe
real *8 cxe
Definition: CALLING_cpHTO.f:62
hto_transfmh::tmuh
real *8 tmuh
Definition: CALLING_cpHTO.f:252
hto_aux_hcp::cxls
real *8 cxls
Definition: CALLING_cpHTO.f:62
hto_qcd::hto_ralphas
real *8 function hto_ralphas(rs0, rs, als)
Definition: CALLING_cpHTO.f:3035
hto_a_cmplx::hto_b021_dm_cp
real *8 function, dimension(2) hto_b021_dm_cp(scal, psi, ps0i, xmsi, xm0i)
Definition: CALLING_cpHTO.f:3360
hto_solve_nonlin::hto_qrfac
subroutine hto_qrfac(m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm, wa)
Definition: CALLING_cpHTO.f:6214
hto_linear_comb::lc
real *8 function lc(c, x)
Definition: CALLING_cpHTO.f:736
hto_aspar::nastps
integer nastps
Definition: CALLING_cpHTO.f:2065
hto_units::eps
real *8, parameter eps
Definition: CALLING_cpHTO.f:183
call_hto
subroutine call_hto(mhiggs, mtop, mhb, ghb)
Definition: CALLING_cpHTO.f:7656
hto_aux_hcp::gtop
integer gtop
Definition: CALLING_cpHTO.f:61
hto_varflv
Definition: CALLING_cpHTO.f:2067
hto_ferbos
Definition: CALLING_cpHTO.f:219
hto_solve_nonlin::hto_r1updt
subroutine hto_r1updt(m, n, s, ls, u, v, w, sing)
Definition: CALLING_cpHTO.f:6459
hto_asnf1
real *8 function hto_asnf1(ASNF, LOGRH, NF)
Definition: CALLING_cpHTO.f:2368
hto_root_find2
Definition: CALLING_cpHTO.f:3424
hto_aux_hcp::clxb
real *8 clxb
Definition: CALLING_cpHTO.f:62
hto_seval3singlel
subroutine hto_seval3singlel(u, b, c, d, top, gdim, f, fp, fpp, fppp)
Definition: CALLING_cpHTO.f:4467
hto_dzpar::mtc
real *8 mtc
Definition: CALLING_cpHTO.f:2047
hto_nffix::nff
integer nff
Definition: CALLING_cpHTO.f:2071
hto_aux_hbb::xb
real *8 xb
Definition: CALLING_cpHTO.f:226
hto_imag_lnz::ilnz
real *8 function ilnz(x, y)
Definition: CALLING_cpHTO.f:385
hto_aux_hcp::cxc
real *8 cxc
Definition: CALLING_cpHTO.f:62
hto_units::ez
real *8, parameter ez
Definition: CALLING_cpHTO.f:187
hto_aux_hcp::cxcs
real *8 cxcs
Definition: CALLING_cpHTO.f:62
hto_masses::m0
real *8, parameter m0
Definition: CALLING_cpHTO.f:74
hto_lb0af_em
real *8 function, dimension(2) hto_lb0af_em(scal, psi, ps0i, xmsi, xm0i)
Definition: CALLING_cpHTO.f:7541
hto_aux_hcp::cxes
real *8 cxes
Definition: CALLING_cpHTO.f:62
hto_common_niels::plr
real *8, dimension(3, 0:15) plr
Definition: CALLING_cpHTO.f:718
hto_aux_hcp::cpz
real *8, dimension(2) cpz
Definition: CALLING_cpHTO.f:67
hto_aux_hbb::cxws
real *8, dimension(2) cxws
Definition: CALLING_cpHTO.f:227
hto_real_lnz
Definition: CALLING_cpHTO.f:364
hto_sp_fun::hto_li3_srsz
real *8 function, dimension(2) hto_li3_srsz(x, y, unit)
Definition: CALLING_cpHTO.f:1138
hto_full_ln::fln
real *8 function, dimension(2) fln(x, y)
Definition: CALLING_cpHTO.f:470
hto_sp_fun::hto_poly_unit
real *8 function, dimension(3, 2) hto_poly_unit(theta)
Definition: CALLING_cpHTO.f:1208
hto_asfthr::asb
real *8 asb
Definition: CALLING_cpHTO.f:2077
hto_sp_fun::hto_s_niels_up4
recursive real *8 function, dimension(6, 2) hto_s_niels_up4(x)
Definition: CALLING_cpHTO.f:766
hto_aux_hcp::clcts
real *8, dimension(2) clcts
Definition: CALLING_cpHTO.f:67
hto_cmplx_rootz::crz
real *8 function, dimension(2) crz(x, y)
Definition: CALLING_cpHTO.f:686
hto_asfthr::m2c
real *8 m2c
Definition: CALLING_cpHTO.f:2077
hto_varflv::ivfns
integer ivfns
Definition: CALLING_cpHTO.f:2068
hto_aux_hcp::clxd
real *8 clxd
Definition: CALLING_cpHTO.f:62
hto_bernoulli
Definition: CALLING_cpHTO.f:209
hto_set_phys_const::alpha_s_mh
real *8 alpha_s_mh
Definition: CALLING_cpHTO.f:240
hto_qcd::hto_qcdmass
real *8 function hto_qcdmass(qm, als, rm1, rm2, fn, x)
Definition: CALLING_cpHTO.f:3327
hto_masses::mt
real *8 mt
Definition: CALLING_cpHTO.f:73
hto_riemann::rz4
real *8, parameter rz4
Definition: CALLING_cpHTO.f:201
hto_gridlow
subroutine hto_gridlow(mass, evalue)
Definition: CALLING_cpHTO.f:4343
hto_aux_hcp::cxtau
real *8 cxtau
Definition: CALLING_cpHTO.f:62
hto_initalphas
subroutine hto_initalphas(IORD, FR2, MUR, ASMUR, MC, MB, MT)
Definition: CALLING_cpHTO.f:2089
hto_masses
Definition: CALLING_cpHTO.f:72
hto_common_niels::plr_4
real *8, dimension(3, 0:15) plr_4
Definition: CALLING_cpHTO.f:719
hto_masses::imz
real *8, parameter imz
Definition: CALLING_cpHTO.f:88
hto_dzpar::iordc
integer iordc
Definition: CALLING_cpHTO.f:2046
hto_aux_hbb::cdzt
real *8, dimension(2) cdzt
Definition: CALLING_cpHTO.f:227
hto_masses::mw
real *8, parameter mw
Definition: CALLING_cpHTO.f:75
hto_ferbos::ifb
integer ifb
Definition: CALLING_cpHTO.f:220
hto_aux_hcp::scalec
real *8 scalec
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxqs
real *8 cxqs
Definition: CALLING_cpHTO.f:62
hto_olas
Definition: CALLING_cpHTO.f:2796
hto_lb0af_dm
real *8 function, dimension(2) hto_lb0af_dm(scal, psi, ps0i, xmsi, xm0i)
Definition: CALLING_cpHTO.f:7483
hto_masses::imw
real *8, parameter imw
Definition: CALLING_cpHTO.f:87
hto_aux_hbb
Definition: CALLING_cpHTO.f:225
hto_poles
subroutine hto_poles(m, nv)
Definition: CALLING_cpHTO.f:6714
hto_solve_nonlin::hto_qform
subroutine hto_qform(m, n, q, ldq, wa)
Definition: CALLING_cpHTO.f:6121
hto_quarkqcd
real *8 function, dimension(2) hto_quarkqcd(scal, psi, ps0i, xmsi, xm0i, type)
Definition: CALLING_cpHTO.f:2851
hto_riemann::pis
real *8, parameter pis
Definition: CALLING_cpHTO.f:197
hto_masses::mb
real *8, parameter mb
Definition: CALLING_cpHTO.f:85
hto_lb021_dm_cp
real *8 function, dimension(2) hto_lb021_dm_cp(scal, psi, ps0i, xmsi, xm0i)
Definition: CALLING_cpHTO.f:7591
hto_aux_hcp::clxmu
real *8 clxmu
Definition: CALLING_cpHTO.f:62
hto_riemann::eg
real *8, parameter eg
Definition: CALLING_cpHTO.f:203
hto_aux_hbb::clw
real *8, dimension(2) clw
Definition: CALLING_cpHTO.f:227
hto_dzpar::mcc
real *8 mcc
Definition: CALLING_cpHTO.f:2047
hto_cmplx_srs_root::crsrs
real *8 function, dimension(2) crsrs(x, y)
Definition: CALLING_cpHTO.f:624
hto_aux_hcp::cxus
real *8 cxus
Definition: CALLING_cpHTO.f:62
hto_seval3singleht
subroutine hto_seval3singleht(u, b, c, d, top, gdim, f, fp, fpp, fppp)
Definition: CALLING_cpHTO.f:4246
hto_asfthr
Definition: CALLING_cpHTO.f:2076
hto_masses::szi
real *8, parameter szi
Definition: CALLING_cpHTO.f:92
hto_aux_hbb::cdwt
real *8, dimension(2) cdwt
Definition: CALLING_cpHTO.f:227
hto_colour
Definition: CALLING_cpHTO.f:2058
hto_real_ln::rln
real *8 function rln(x, ep)
Definition: CALLING_cpHTO.f:430
hto_cmplx_root
Definition: CALLING_cpHTO.f:659
hto_qcd::hto_run_bc
real *8 function, dimension(2) hto_run_bc(scal)
Definition: CALLING_cpHTO.f:3157
hto_aux_hcp::cxbs
real *8 cxbs
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxd
real *8 cxd
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxmus
real *8 cxmus
Definition: CALLING_cpHTO.f:62
hto_aux_hbb::ccts
real *8, dimension(2) ccts
Definition: CALLING_cpHTO.f:227
hto_aux_hcp::muhcp
real *8 muhcp
Definition: CALLING_cpHTO.f:62
hto_riemann::rz5
real *8, parameter rz5
Definition: CALLING_cpHTO.f:202
hto_units::itwo
integer, parameter itwo
Definition: CALLING_cpHTO.f:182
hto_aux_hcp::cxwi
real *8, dimension(2) cxwi
Definition: CALLING_cpHTO.f:67
hto_aux_hcp::cxtc
real *8 cxtc
Definition: CALLING_cpHTO.f:62
hto_colour::cf
real *8 cf
Definition: CALLING_cpHTO.f:2059
hto_masses::szr
real *8, parameter szr
Definition: CALLING_cpHTO.f:91
hto_set_phys_const::g_w
real *8 g_w
Definition: CALLING_cpHTO.f:240
hto_set_phys_const::imt
real *8 imt
Definition: CALLING_cpHTO.f:240
hto_aux_hbb::csts
real *8, dimension(2) csts
Definition: CALLING_cpHTO.f:227
hto_frrat
Definition: CALLING_cpHTO.f:2073
hto_dzpar::r0c
real *8 r0c
Definition: CALLING_cpHTO.f:2047
hto_aux_hcp::clxt
real *8 clxt
Definition: CALLING_cpHTO.f:62
hto_aux_hcp::cxbc
real *8 cxbc
Definition: CALLING_cpHTO.f:62
hto_set_phys_const::als
real *8 als
Definition: CALLING_cpHTO.f:240
hto_acmplx_pro::cp
real *8 function, dimension(2) cp(x, y)
Definition: CALLING_cpHTO.f:263
hto_asfthr::asc
real *8 asc
Definition: CALLING_cpHTO.f:2077
hto_aux_hcp::cxds
real *8 cxds
Definition: CALLING_cpHTO.f:62
hto_masses::me
real *8, parameter me
Definition: CALLING_cpHTO.f:77
hto_betacom::beta0
real *8, dimension(3:6) beta0
Definition: CALLING_cpHTO.f:2080
hto_kountac::km
integer km
Definition: CALLING_cpHTO.f:725
hto_betacom
Definition: CALLING_cpHTO.f:2079
hto_puttime
Definition: CALLING_cpHTO.f:97
hto_common_niels
Definition: CALLING_cpHTO.f:717
hto_sp_fun::hto_cqlnx
real *8 function, dimension(2) hto_cqlnx(arg)
Definition: CALLING_cpHTO.f:1912
hto_alphas
real *8 function hto_alphas(MUR)
Definition: CALLING_cpHTO.f:2269
hto_optcp::ocp
character(len=3) ocp
Definition: CALLING_cpHTO.f:234
hto_units::zero
real *8, parameter zero
Definition: CALLING_cpHTO.f:185
hto_colour::tr
real *8 tr
Definition: CALLING_cpHTO.f:2059
hto_aux_hcp::cxss
real *8 cxss
Definition: CALLING_cpHTO.f:62
hto_solve_nonlin::hto_hbrd
subroutine, public hto_hbrd(HTO_FCN, n, x, fvec, epsfcn, tol, info, diag)
Definition: CALLING_cpHTO.f:5311
hto_cmplx_srs_root
Definition: CALLING_cpHTO.f:618
hto_gridht
subroutine hto_gridht(mass, evalue)
Definition: CALLING_cpHTO.f:4106
hto_linear_comb
Definition: CALLING_cpHTO.f:730
hto_betacom::beta1
real *8, dimension(3:6) beta1
Definition: CALLING_cpHTO.f:2080
hto_riemann::rz2
real *8, parameter rz2
Definition: CALLING_cpHTO.f:199
hto_aspar
Definition: CALLING_cpHTO.f:2064
hto_puttime::hto_timestamp
subroutine hto_timestamp()
Definition: CALLING_cpHTO.f:101
hto_aux_hcp::cxl
real *8 cxl
Definition: CALLING_cpHTO.f:62
Generated by   doxygen 1.8.17