C     This code was provided on 2016-04-13 by Silvano Simula and
C     reflects the parametrisation used in hep-ph/0301204 (CLAS) and
C     described in hep-ph/9901360.
C
C     The parameterization was developed for describing nucleon data at
C     Q^2 > 0.5 GeV^2 and x > 0.15.
C
C     Check with the author before making this public.
C----------------------------------------------------------------------      
CCCCCCC
CCCCCCC               USAGE: CALL F2SF(IN,QM2,XN,F2)
CCCCCCC
CCCCCCC               INPUTS:
CCCCCCC
CCCCCCC               IN = 0 NEUTRON
CCCCCCC               IN = 1 PROTON
CCCCCCC               IN = 2 DEUTERON
CCCCCCC
CCCCCCC               QM2 = SQUARED FOUR-MOMENTUM TRANSFER (GEV/C)**2
CCCCCCC               XN  = BJORKEN VARIABLE
CCCCCCC
CCCCCCC               OUTPUT: F2 = STRUCTURE FUNCTION F2               
CCCCCCC




      SUBROUTINE F2SF(IN,QM2,XN,F2)
CCCCCCC
CCCCCCC             EVALUATE NUCLEON STRUCTURE FUNCTION F2
CCCCCCC                  (SLAC PARAMETERIZATION)
CCCCCCC
CCCCCCC                      IN = 0 NEUTRON
CCCCCCC                      IN = 1 PROTON
CCCCCCC                      IN = 2 DEUTERON
CCCCCCC
CCCCCCC               QM2 = SQUARED FOUR-MOMENTUM TRANSFER (GEV/C)**2
CCCCCCC               XN  = BJORKEN VARIABLE
CCCCCCC
      IMPLICIT REAL*8 (A-H,O-Z)
      DATA DM/0.938256D0/,WPI/1.073232D0/
      SAVE
      F2=0.D0
      W=DSQRT(DM*DM+QM2*(1.D0-XN)/XN)
      IF(W.LE.WPI) RETURN
      F2=F2SLAC(IN,XN,QM2)    
      IF(IN.NE.2) THEN
       CALL RESBKG(QM2,W,F2BKG,F2RES)
      ELSE
       CALL RESBKGD(QM2,W,F2BKG,F2RES)
      ENDIF
      F2=F2*(F2BKG+F2RES)
      RETURN
      END
      



********************************************************************************
*
*                  SLAC PARAMETERIZATION (WITH RESONANCES)
*
********************************************************************************

      DOUBLE PRECISION FUNCTION F2SLAC(IN,XB,QM2)
CCCCCCC
CCCCCCC            DEEP INELASTIC STRUCTURE FUNCTION F2N
CCCCCCC                    (SLAC PARAMETERIZATION)
CCCCCCC
CCCCCCC                    IN = 0 NEUTRON
CCCCCCC                    IN = 1 PROTON
CCCCCCC                    IN = 2 DEUTERON
CCCCCCC
CCCCCCC              XB  = BJORKEN SCALING VARIABLE
CCCCCCC              QM2 = SQUARED FOUR-MOMENTUM TRANSFER (GEV/C)**2
CCCCCCC
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION CN(7),CP(7),CD(7)
      DATA CN/0.0640D0,0.2250D0,4.1060D0,-7.0790D0,3.0550D0,
     *        1.6421D0,0.37636D0/
      DATA CP/0.25615D0,2.1785D0,0.89784D0,-6.7162D0,3.7557D0,
     *        1.6421D0,0.37636D0/
      DATA CD/0.47709D0,2.1602D0,3.6274D0,-10.470D0,4.9272D0,
     *        1.5121D0,0.35115D0/
      SAVE
      F2SLAC=0.D0
      IF(XB.GE.1.D0) RETURN
      DS=1.D0
      IF(IN.EQ.0) THEN
       XSXB=(QM2+CN(7))/(QM2+CN(6)*XB)
       XS=XB*XSXB
       DO 300 I=1,5
       F2SLAC=F2SLAC+CN(I)*DS
  300  DS=DS*(1.D0-XS)
      ELSE IF(IN.EQ.1) THEN
       XSXB=(QM2+CP(7))/(QM2+CP(6)*XB)
       XS=XB*XSXB
       DO 500 I=1,5
       F2SLAC=F2SLAC+CP(I)*DS
  500  DS=DS*(1.D0-XS)
      ELSE
       XSXB=(QM2+CD(7))/(QM2+CD(6)*XB)
       XS=XB*XSXB
       DO 700 I=1,5
       F2SLAC=F2SLAC+CD(I)*DS
  700  DS=DS*(1.D0-XS)
       IF(XB.GT.0.D0) F2SLAC=F2SLAC/(1.D0-DEXP(-7.70D0*(1.D0/XB-1.D0+
     +                       0.938256D0*0.938256D0/QM2)))
      ENDIF
      F2SLAC=F2SLAC*(1.D0-XS)*(1.D0-XS)*(1.D0-XS)/XSXB
      RETURN
      END
      SUBROUTINE RESBKG(QM2,W,BKG,RESN)
CCCCCCC
CCCCCCC       EVALUATE THE BACKGROUND AND RESONANCE TERMS OF THE
CCCCCCC   MODULATING FUNCTION (SLAC PARAMETRIZATION) FOR THE NUCLEON
CCCCCCC
CCCCCCC             QM2 = SQUARED FOUR-MOMENTUM TRANSFER (GEV/C)**2
CCCCCCC             W   = FINAL HADRON INVARIANT MASS (GEV)
CCCCCCC
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION LR(4),AR(4),DMR(4),DGR(4)
      DATA X0/-0.599937D0/,X1/4.76158D0/,X2/0.411676D0/
      DATA B1/0.755311D0/,B2/3.35065D0/,B3/3.51024D0/,B4/1.74470D0/
      DATA ALFA/-0.174985D0/,BETA/0.00967019D0/
      DATA DMU/-0.0352567D0/,DMUP/3.51852D0/
      DATA AR/1.04000D0,0.481327D0,0.655872D0,0.747338D0/
      DATA DMR/1.22991D0,1.51015D0,1.71762D0,1.95381D0/
      DATA DGR/0.106254D0,0.0816620D0,0.125520D0,0.198915D0/
      DATA LR/1,2,3,2/
      DATA INDEX/0/
      SAVE
      IF(INDEX.NE.0) GO TO 10
      DM=0.938256D0
      DMPAI=0.134976D0
      WTH=DM+DMPAI
      DM2=DM*DM
      DMPAI2=DMPAI*DMPAI
      PGRECO=3.141592654D0
      COEF=6.08974D0
      INDEX=1
   10 BKG=0.D0
      RESN=0.D0
      IF(W.LE.WTH) RETURN
      BKG=1.D0
      IF(W.GT.4.D0) RETURN
      W2=W*W
      QS=(W2+DM2-DMPAI2)**2-4.D0*DM2*W2
      IF(QS.LE.0.D0) RETURN
      QS=0.5D0*DSQRT(QS)/W
      OMEGA=0.5D0*(W2+QM2-DM2)/DM
      XN=0.5D0*QM2/(DM*OMEGA)
      BKG2=1.D0
      IF(W.GT.B4) BKG2=DEXP(-B3*(W2-B4*B4))
      ETAB=1.D0
      ETAD=1.D0
      IF((QM2.GT.2.D0).OR.(W.GT.2.5D0)) GO TO 300
      ETAB=1.D0-2.5D0*QM2*DEXP(-12.5D0*QM2*QM2-
     -     50.D0*(W-1.325D0)*(W-1.325D0))
      ETAD=1.D0+2.50D0*QM2*DEXP(-12.5D0*QM2*QM2)
  300 CONTINUE
      BKG=B1*(1.D0-DEXP(-B2*(W-WTH)))+(1.D0-B1)*(1.D0-BKG2)
      BKG=ETAB*BKG*(1.D0+(1.D0-BKG)*(X0+X1*(XN-X2)*(XN-X2)))
      DO 500 I=1,4
      AI=AR(I)
      IF(I.EQ.1) AI=ETAD*(AI+QM2*DMIN1(0.D0,ALFA+BETA*QM2))
      DMI=DMR(I)
      IF(I.EQ.3) DMI=DMI*(1.D0+DMU/(1.D0+DMUP*QM2))
      QS0=(DMI*DMI+DM2-DMPAI2)**2-4.D0*DM2*DMI*DMI
      IF(QS0.LE.0.D0) GO TO 500
      QS0=0.5D0*DSQRT(QS0)/DMI
      JI=2*LR(I)
      DG=0.5D0*DGR(I)*((QS/QS0)**(JI+1))*
     *   (1.D0+(COEF*QS0)**JI)/(1.D0+(COEF*QS)**JI)
      RESN=RESN+AI*DG/((W-DMI)*(W-DMI)+DG*DG)
  500 CONTINUE
      RESN=0.5D0*RESN*(1.D0-B1)*BKG2/(DM*PGRECO)
      RETURN
      END
      SUBROUTINE RESBKGD(QM2,W,BKG,RESN)
CCCCCCC
CCCCCCC       EVALUATE THE BACKGROUND AND RESONANCE TERMS OF THE
CCCCCCC   MODULATING FUNCTION (SLAC PARAMETRIZATION) FOR THE DEUTERON
CCCCCCC
CCCCCCC             QM2 = SQUARED FOUR-MOMENTUM TRANSFER (GEV/C)**2
CCCCCCC             W   = FINAL HADRON INVARIANT MASS (GEV)
CCCCCCC
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION LR(4),AR(4),DMR(4),DGR(4)
      DATA X0/-0.21262D0/,X1/6.9690D0/,X2/0.40314D0/
      DATA B1/0.76111D0/,B2/4.1470D0/,B3/3.7119D0/,B4/1.4218D0/
      DATA ALFA/-0.24480D0/,BETA/0.014503D0/
      DATA DMU/-0.0352567D0/,DMUP/3.51852D0/
      DATA AR/0.74847D0,0.011500D0,0.12662D0,0.747338D0/
      DATA DMR/1.2400D0,1.4772D0,1.5233D0,1.95381D0/
      DATA DGR/0.12115D0,0.0069580D0,0.084095D0,0.198915D0/
      DATA LR/1,2,3,2/
      DATA INDEX/0/
      SAVE
      IF(INDEX.NE.0) GO TO 10
      DM=0.938256D0
      DMPAI=0.134976D0
      WTH=DM+DMPAI
      DM2=DM*DM
      DMPAI2=DMPAI*DMPAI
      PGRECO=3.141592654D0
      COEF=6.08974D0
      INDEX=1
   10 BKG=0.D0
      RESN=0.D0
      IF(W.LE.WTH) RETURN
      BKG=1.D0
      IF(W.GT.4.D0) RETURN
      W2=W*W
      QS=(W2+DM2-DMPAI2)**2-4.D0*DM2*W2
      IF(QS.LE.0.D0) RETURN
      QS=0.5D0*DSQRT(QS)/W
      OMEGA=0.5D0*(W2+QM2-DM2)/DM
      XN=0.5D0*QM2/(DM*OMEGA)
      BKG2=1.D0
      IF(W.GT.B4) BKG2=DEXP(-B3*(W2-B4*B4))
      BKG=B1*(1.D0-DEXP(-B2*(W-WTH)))+(1.D0-B1)*(1.D0-BKG2)
      BKG=BKG*(1.D0+(1.D0-BKG)*(X0+X1*(XN-X2)*(XN-X2)))
      DO 500 I=1,4
      AI=AR(I)
      IF(I.EQ.1) AI=AI+QM2*DMIN1(0.D0,ALFA+BETA*QM2)
      DMI=DMR(I)
      IF(I.EQ.3) DMI=DMI*(1.D0+DMU/(1.D0+DMUP*QM2))
      QS0=(DMI*DMI+DM2-DMPAI2)**2-4.D0*DM2*DMI*DMI
      IF(QS0.LE.0.D0) GO TO 500
      QS0=0.5D0*DSQRT(QS0)/DMI
      JI=2*LR(I)
      DG=0.5D0*DGR(I)*((QS/QS0)**(JI+1))*
     *   (1.D0+(COEF*QS0)**JI)/(1.D0+(COEF*QS)**JI)
      RESN=RESN+AI*DG/((W-DMI)*(W-DMI)+DG*DG)
  500 CONTINUE
      RESN=0.5D0*RESN*(1.D0-B1)*BKG2/(DM*PGRECO)
      RETURN
      END
      
