PDF/spdf/sfwhi3.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.1.1.2  1996/10/30 08:30:44  cernlib
   6 * Version 7.04
   7 *
   8 * Revision 1.1.1.1  1996/04/12 15:29:46  plothow
   9 * Version 7.01
  10 *
  11 *
  12 #include "pdf/pilot.h"
  13 c-------------------------------------------------------
  14       subroutine SFWHI3(ZX,ZQ,ZUV,ZDV,ZUB,ZDB,ZSB,ZCB,ZGL)
  15 c-------------------------------------------------------
  16 c     WHIT3 parton distribution in the photon
  17 c
  18 c     INPUT:  integer ic  : if ic=0 then qc=0
  19 c                           else qc is calculated
  20 c             DOUBLE PRECISION  Q2  : energy scale Q^2 (GeV^2)
  21 c             DOUBLE PRECISION  x   : energy fraction
  22 c
  23 c     OUTPUT: DOUBLE PRECISION  qu  : up-quark dist.
  24 c             DOUBLE PRECISION  qd  : down- or strange-quark dist.
  25 c             DOUBLE PRECISION  qc  : charm-quark dist.
  26 c             DOUBLE PRECISION  g   : gluon dist.
  27 c-------------------------------------------------------
  28 c     Modified by M.Tanaka on July 22, 1994.
  29 c     The bug pointed out by M.Drees is fixed.
  30 c-------------------------------------------------------
  31 c     Modified by I.Watanabe on July 22, 1994.
  32 c-------------------------------------------------------
  33       implicit none
  34       external whit3g
  35 #include "pdf/expdp.inc"
  36      +       ZX,ZQ,ZUV,ZDV,ZUB,ZDB,ZSB,ZCB,ZGL
  37 c arg
  38       integer ic
  39       DOUBLE PRECISION Q2,x
  40       DOUBLE PRECISION qu,qd,qc,g
  41 c const
  42       DOUBLE PRECISION q42it,q52it,lam42,lam52
  43       DOUBLE PRECISION alinv,mc,PI
  44 c local
  45       DOUBLE PRECISION qv,qsea,cv,cs,dcv,dcs
  46       DOUBLE PRECISION A0val,A1val,A2val,Bval,Cval,
  47      $       A0sea,B0sea,BB0sea,C0sea
  48       DOUBLE PRECISION A0dcv,A1dcv,A2dcv,A3dcv,Bdcv,Cdcv
  49       DOUBLE PRECISION Adcs, B0dcs, B1dcs, Cdcs
  50       DOUBLE PRECISION x1,x2,mc2q2
  51       DOUBLE PRECISION s,s2,s3,s4,prsccf,alstpi
  52       DOUBLE PRECISION WHIT3g
  53 c parameters
  54       parameter(lam42=0.16d0, lam52=0.091411319d0)
  55       parameter(Q42IT=4.0d0, Q52IT=100.0d0)
  56       parameter(alinv=137.036d0, mc=1.5d0)
  57       parameter(pi=3.14159265358979323846d0)
  58       common /scale/ s,s2,s3,s4,prsccf
  59 c
  60 c begin
  61       x=ZX
  62       Q2=ZQ*ZQ
  63       ic=1
  64 c
  65       x1=1.0d0-x
  66       x2=x**2
  67       mc2q2=mc**2/Q2
  68 c
  69       if(Q2.lt.100.0d0) then
  70 c  under 100 GeV^2
  71 c
  72 c  set  scale s
  73          if(Q2.lt.4.0d0) then
  74 cccc  for under 4GeV^2 prescription
  75             s=  0.0d0
  76             prsccf =  log(Q2/LAM42)/ log(Q42IT/LAM42)
  77             alstpi = 6.0d0/25.0d0/ log(Q42IT/LAM42)
  78          else
  79             s=   log(  log(Q2/LAM42)/ log(Q42IT/LAM42))
  80             prsccf = 1.0d0
  81             alstpi = 6.0d0/25.0d0/ log(Q2/LAM42)
  82          endif
  83             s2=s**2
  84             s3=s2*s
  85             s4=s2**2
  86 c
  87 cccccc   WHIT3 quark (U100)
  88 c
  89       A0val= 1.882000d+00+s*( 1.213000d+00)+s2*( 6.970000d-01)
  90       A1val=              s*(-2.361000d+00)+s2*(-1.136000d+00)
  91       A2val=              s*( 5.280000d-01)+s2*( 2.406000d+00)
  92       Bval = 5.000000d-01+s*( 2.107000d-02)+s2*( 4.130000d-03)
  93       Cval = 2.500000d-01+s*(-2.376000d-01)+s2*( 2.018000d-01)
  94      $           +s3*(-5.040000d-02)
  95       A0sea= 1.587000d+00+s*( 5.050000d+00)+s2*(-1.126000d+01)
  96      $           +s3*( 7.560000d+00)+s4*(-1.471000d+00)
  97       B0sea=-1.006000d-01+s*( 2.259000d-01)+s2*(-1.195000d+00)
  98      $           +s3*( 1.175000d+00)+s4*(-4.460000d-01)
  99       BB0sea=5.730000d+00+s*( 2.564000d+01)+s2*(-5.870000d+01)
 100      $           +s3*( 6.320000d+01)+s4*(-2.577000d+01)
 101       C0sea= 2.136000d+01+s*(-7.290000d+01)+s2*( 1.532000d+02)
 102      $           +s3*(-1.679000d+02)+s4*( 6.740000d+01)
 103 c
 104          qv  = prsccf/alinv/x*
 105      $         (A0val+A1val*x+A2val*x2) * x**Bval * x1**Cval
 106          qsea= prsccf/alinv/x*
 107      $         A0sea * x**(B0sea+BB0sea*x) * x1**C0sea
 108 c
 109          qu  = qv/3.0d0  + qsea/6.0d0
 110          qu  = qu*x
 111          ZUV=qu
 112          ZUB=qu
 113          qd  = qv/12.0d0 + qsea/6.0d0
 114          qd  = qd*x
 115          ZDV=qd
 116          ZDB=qd
 117          ZSB=qd
 118 c
 119          if((ic.ne.0) .and. (x*(1.0d0+4.0d0*mc2q2).lt.1.0d0)) then
 120             call WHIT3Q(x,mc2q2,cv,cs)
 121             qc = cv/alinv/2.0d0/PI + cs*alstpi
 122             qc  = qc*x
 123             ZCB=qc
 124          else
 125             qc = 0.0d0
 126             ZCB=qc
 127          endif
 128 c
 129          g   = WHIT3G(x,Q2)
 130          g   = g*x
 131          ZGL=g
 132 c
 133       else
 134 c over 100 GeV^2
 135 c
 136 c set scale s
 137          s=   log(  log(Q2/LAM52)/ log(Q52IT/LAM52))
 138          prsccf = 1.0d0
 139          alstpi = 6.0d0/23.0d0/ log(Q2/LAM52)
 140             s2=s**2
 141             s3=s2*s
 142             s4=s2**2
 143 c
 144 cccccc   WHIT3 quark (O100)
 145 c
 146       A0val= 3.058000d+00+s*( 2.474000d+00)+s2*( 1.002000d+00)
 147       A1val=-2.182000d+00+s*(-4.480000d+00)+s2*(-2.264000d-01)
 148       A2val= 1.522000d+00+s*( 4.300000d+00)+s2*( 1.315000d+00)
 149       Bval = 5.170000d-01+s*( 4.030000d-02)+s2*(-2.097000d-02)
 150       Cval = 1.655000d-01+s*(-2.064000d-02)+s2*( 5.370000d-02)
 151       A0sea= 1.850000d+00+s*(-3.670000d+00)+s2*( 2.714000d+01)
 152      $           +s3*(-1.066000d+02)+s4*( 1.309000d+02)
 153       B0sea=-2.299000d-01+s*(-4.970000d-01)+s2*( 2.464000d+00)
 154      $           +s3*(-9.950000d+00)+s4*( 1.232000d+01)
 155       BB0sea=1.042000d+01+s*(-1.074000d+01)+s2*( 1.327000d+02)
 156      $           +s3*(-5.390000d+02)+s4*( 6.560000d+02)
 157       C0sea= 4.070000d+00+s*( 4.110000d+00)+s2*(-1.719000d+02)
 158      $           +s3*( 7.070000d+02)+s4*(-8.590000d+02)
 159 c
 160          qv  = 1.0d0/alinv/x*
 161      $         (A0val+A1val*x+A2val*x2) * x**Bval * x1**Cval
 162          qsea= 1.0d0/alinv/x*
 163      $         A0sea * x**(B0sea+BB0sea*x) * x1**C0sea
 164 c
 165          qu  = qv/3.0d0  + qsea/6.0d0
 166          qu  = qu*x
 167          ZUV=qu
 168          ZUB=qu
 169          qd  = qv/12.0d0 + qsea/6.0d0
 170          qd  = qd*x
 171          ZDV=qd
 172          ZDB=qd
 173          ZSB=qd
 174          g   = WHIT3G(x,Q2)
 175          g   = g*x
 176          ZGL=g
 177 c
 178          if((ic.ne.0) .and. (x*(1.0d0+4.0d0*mc2q2).lt.1.0d0)) then
 179       A0dcv=              s*( 1.219000d-01)+s2*( 6.200000d+00)
 180      $           +s3*(-2.504000d+01)+s4*( 3.098000d+01)
 181       A1dcv=              s*( 1.913000d+00)+s2*(-7.690000d+01)
 182      $           +s3*( 3.180000d+02)+s4*(-3.920000d+02)
 183       A2dcv=              s*(-7.160000d+00)+s2*( 2.503000d+02)
 184      $           +s3*(-1.062000d+03)+s4*( 1.308000d+03)
 185       A3dcv=              s*( 3.190000d+00)+s2*(-2.301000d+02)
 186      $           +s3*( 1.012000d+03)+s4*(-1.250000d+03)
 187       Bdcv = 4.990000d-01+s*( 3.470000d+00)+s2*(-1.526000d+01)
 188      $           +s3*( 1.967000d+01)
 189       Cdcv = 3.290000d-01+s*( 8.240000d+00)+s2*(-3.800000d+01)
 190      $           +s3*( 4.630000d+01)
 191       Adcs =              s*(-1.948000d-02)+s2*( 2.861000d-02)
 192      $           +s3*(-2.036000d-02)
 193       B0dcs=-4.130000d-01+s*(-4.390000d-01)+s2*( 1.810000d-01)
 194       B1dcs= 5.190000d+00+s*(-7.400000d+00)+s2*( 3.400000d+00)
 195       Cdcs = 2.359000d+00+s*( 9.770000d-01)+s2*(-7.730000d+00)
 196      $           +s3*( 9.480000d+00)
 197 c
 198          dcv = 1.0d0/alinv/x*
 199      $         (A0dcv+x*A1dcv+x2*A2dcv+x2*x*A3dcv) * x**Bdcv * x1**Cdcv
 200          dcs = 1.0d0/alinv/x*
 201      $         Adcs * x**(B0dcs+B1dcs*x) * x1**Cdcs
 202 c
 203            call WHIT3Q(x,mc*mc/Q2,cv,cs)
 204            qc = cv/alinv/2.0d0/PI + cs*alstpi + dcs + dcv
 205            qc  = qc*x
 206            ZCB=qc
 207          else
 208            qc = 0.0d0
 209            ZCB=qc
 210          endif
 211       endif
 212 c
 213       return
 214       end