JHUGen MELA  JHUGen v7.5.6, MELA v2.4.2
Matrix element calculations as used in JHUGen.
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
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
nf
@ nf
Definition: TMCFM.hh:17
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