      SUBROUTINE RNIJMLSJ(R,TYPE,VPOT,FI,DFI,DDFI)
************************************************************************
**    NIJMEGEN NUCLEON-NUCLEON POTENTIAL PROGRAM                      **
**    ------------------------------------------                      **
**    Version 1.0: June 1994                                          **
**    Version 1.1: March 1995                                         **
**    E-mail: info@nn-online.org
**    Reference: Stoks et al. Phys.Rev. C49 (1994) June               **
**                                                                    **
**    Refined and extended version of the 1978 Nijmegen NN potential  **
**    in coordinate space on LSJ basis.                               **
**    Basic references for formulas and set up of this program can be **
**    found in Phys.Rev.D17 (1978) 768 and Phys.Rev.C40 (1989) 2226.  **
**    Reference: V.G.J.Stoks et.al. Phys.Rev. C49 (1994) June         **
**                                                                    **
**    INPUT:  R       in fermi                                        **
**    -----   TYPE    'PP', 'NP', 'PN', or 'NN' (character*2)         **
**                                                                    **
**    OUTPUT: central VC, spin-spin VSS, tensor VT, spin-orbit VLS,   **
**    ------  asymmetric spin-orbit VLSA, quadratic spin-orbit VQ12   **
**            potentials in MeV.                                      **
**            Nonlocal term FI   (dimensionless)                      **
**                          DFI  (dimension MeV)     1st derivative   **
**                          DDFI (dimension MeV**2)  2nd derivative   **
**            All these terms are communicated via                    **
**                 COMMON/POTS/VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP **
**            This subroutine returns a 2x2 potential matrix VPOT     **
**            in MeV which is the partial-wave coordinate-space       **
**            potential for the partial wave PHNAME (see below)       **
**--------------------------------------------------------------------**
**    Potential decomposition in coordinate space plane-wave basis:   **
**    V(r) = VC                                                       **
**         + VSS   (SIG1.SIG2)                                        **
**         + VT    S12                                                **
**         + VLS   L.(SIG1+SIG2)/2                                    **
**         + VLSA  L.(SIG1-SIG2)/2                (NOT USED !!!)      **
**         + VQ12  [(SIG1.L)(SIG2.L)+(SIG2.L)(SIG1.L)]/2              **
**         - [Laplacian FI + FI Laplacian]/2Mred                      **
**                                                                    **
**    COMMON-blocks which have to be filled beforehand:               **
**    +  COMMON/EMANHP/PHNAME                                         **
**              PHNAME is character*3 and contains the name of the    **
**              phase shift in the spectral notation.                 **
**              - singlets:           1S0  1P1  1D2  1F3  1G4 ...     **
**              - triplets uncoupled: 3P0  3P1  3D2  3F3  3G4 ...     **
**              - triplets coupled:        3C1  3C2  3C3  3C4 ...     **
**                where 3C1 denotes 3S1 - epsilon1 - 3D1 channel      **
**                      3C2 denotes 3P2 - epsilon2 - 3F2 channel ...  **
**    +  COMMON/CHOICE/IDPAR                                          **
**              IDPAR is an integer and denotes the various different **
**              models that can be chosen.                            **
**              IDPAR=0: nijm93: potential for pp and np together.    **
**                               including a phenomenological         **
**                               parameter to give the 1S0 pp and np  **
**                               phase shift/scattering length        **
**                               difference                           **
**                    1: nijmI : Reidlike model, each partial wave has**
**                               its own parameterset                 **
**                    2: nijmII: like nijmI, but fully local          **
**    +  COMMON/RELKIN/NONREL                                         **
**              NONREL is a logical used in the IDPAR=1 and 2 options.**
**              NONREL=.TRUE.  gives the deuteron binding energy of   **
**                             B=2.224575 MeV using non-relativistic  **
**                             kinematics.                            **
**              NONREL=.FALSE. gives the deuteron binding energy of   **
**                             B=2.224575 MeV using relativistic      **
**                             kinematics.                            **
**              Model IDPAR=0 gives the deuteron only using           **
**              relativistic kinematics ==> NONREL=.FALSE.            **
**                                                                    **
**    NOTE: ALL potential models use a fixed fpi**2=0.075 for the     **
**    ----- pion-nucleon coupling constant at the pion pole, which    **
**          is represented by the DATA FPPPI0/0.075D0/ statement.     **
**                                                                    **
**          The PP potentials were fitted with the Coulomb given by   **
**          V_Coul(r) = alpha'/r  where                               **
**             alpha' = 2*k*eta'/M_p                                  **
**             eta'   = (T_lab+M_p)/sqrt[T_lab**2+2*M_p*T_lab]/fsc    **
**             fsc    = 137.0359895                                   **
**             Eqs.(25), (26), (10) from Phys.Rev.C38(1988)15.        **
************************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 VPOT(2,2)
      INTEGER SPIN
      CHARACTER PHNAME*3, PHNAM0*3, TYPE*2, CAPS*12, SMAL*12
      COMMON/EMANHP/PHNAME
      COMMON/CHOICE/IDPAR
      COMMON/POTS/  VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP
      DATA PHNAM0/'***'/
      DATA CAPS/'CSPDFGHIKLMN'/, SMAL/'cspdfghiklmn'/
      SAVE NCHAN,SPIN,L,J,ISO
 
      VC  =0D0
      VSS =0D0
      VT  =0D0
      VLS =0D0
      VLSA=0D0
      VQ12=0D0
      FIC  =0D0
      FICP =0D0
      FICPP=0D0

      IF(PHNAME.NE.PHNAM0) THEN
        DO 5 LL=1,12
          IF(PHNAME(2:2).EQ.SMAL(LL:LL)) THEN
            WRITE(PHNAME(2:2),'(A1)') CAPS(LL:LL)
          ENDIF
    5   CONTINUE
        PHNAM0=PHNAME
        NCHAN=1
        IF(PHNAME(2:2).EQ.'C') NCHAN=2
        IF(PHNAME(1:1).EQ.'1') SPIN=0
        IF(PHNAME(1:1).EQ.'3') SPIN=1
        READ(PHNAME,'(2X,I1)') J
        L=J
        IF(PHNAME.EQ.'3P0') L=1
        IF(NCHAN.EQ.2) L=J-1
        ISO=MOD(SPIN+L+1,2)
      ENDIF
 
      IF(TYPE.EQ.'pp') THEN
        TYPE='PP'
      ELSEIF(TYPE.EQ.'np') THEN
        TYPE='NP'
      ELSEIF(TYPE.EQ.'pn') THEN
        TYPE='PN'
      ELSEIF(TYPE.EQ.'nn') THEN
        TYPE='NN'
      ENDIF

      CALL NYMPOT(R,TYPE,ISO)
 
      IF(NCHAN.EQ.1)THEN
        IF(SPIN.EQ.0)THEN
          VPOT(1,1) = VC - 3D0*VSS - J*(J+1)*VQ12
        ELSEIF(L.EQ.J)THEN
          VPOT(1,1) = VC + VSS + 2D0*VT - VLS + (1D0-J*(J+1))*VQ12
        ELSEIF(L.EQ.(J+1))THEN
          VPOT(1,1) = VC + VSS - 2D0*(J+2)/(2*J+1)*VT
     .                - (J+2)*VLS + (J+2)*(J+2)*VQ12
        ENDIF
      ELSE
        VPOT(1,1) = VC + VSS - 2D0*(J-1)/(2*J+1)*VT +
     .                (J-1)*VLS + (J-1)*(J-1)*VQ12
        VPOT(2,2) = VC + VSS - 2D0*(J+2)/(2*J+1)*VT -
     .                (J+2)*VLS + (J+2)*(J+2)*VQ12
        VPOT(1,2) = 6D0*DSQRT(J*(J+1)*1D0)/(2*J+1)*VT
        VPOT(2,1) = VPOT(1,2)
      ENDIF
 
      IF(IDPAR.EQ.2) THEN
        FI  = 0D0
        DFI = 0D0
        DDFI= 0D0
      ELSE
        FI  = FIC
        DFI = FICP
        DDFI= FICPP
      ENDIF
 
      RETURN
      END
************************************************************************
      SUBROUTINE NYMPOT(R,TYPE,ISO)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 NEUTM
      CHARACTER PHNAME*3,PHNAM0*3, TYPE*2, TYP0*2
      LOGICAL FIRST
      COMMON/EMANHP/PHNAME
      COMMON/CHOICE/IDPAR
      COMMON/POTS/  VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP
      COMMON/MESONM/AMPI,AMETA,AMETP, AMRO,AMOM,AMFI, AMA0,AMEP,AMF0,
     .              AMPIC,AMROC,AMA0C,AWPIC,AWROC,AWA0C, AVSC
      COMMON/PARAMS/PAR(6,5)
      COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2,
     .              ALVE,THV ,GV1, GRO,GOM,GFI,  GRO2,GOM2,GFI2,
     .              ALVM,     FV1, FRO,FOM,FFI,  FRO2,FOM2,FFI2,
     .              ALGS,THGS,GS1, GA0,GEP,GF0,  GA02,GEP2,GF02,
     .              GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI,
     .              FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2
      COMMON/YUKEFF/ARO,AMR1,AROC,AMRC1,AWRC1,BRO,AMR2,BROC,AMRC2,AWRC2,
     .              AVSC1,AVSC2, AEPS,AME1,BEPS,AME2
      COMMON/BROADM/GAMRO,THRRO,GAMRC,THRRC,GAMEP,THRE0,THREC,NRO,NEP
      COMMON/SCALIN/AMT,AMPV
      COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS
      COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4,
     .              GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4
      COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2,
     .              AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2,
     .              AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2
      DATA FPPPI0/0.075D0/, FIRST/.FALSE./
      DATA TYP0/'XX'/, PHNAM0/'***'/, IDPAR0/-1/
      DATA PI/3.14159265358979323846D0/, SRPI/1.7724538509055160273D0/
      SAVE ISIGN,CONV,PROTM,NEUTM,HBARC
 
      IF(FIRST) GOTO 10
      FIRST = .TRUE.
      CONV  = PI/180D0
**    Nucleon and meson masses (Particle Data Group 1990)
      HBARC = 197.327053D0
      PROTM = 938.27231D0
      NEUTM = 939.56563D0
      AMT   = 938.27231D0
      AMPV  = 139.5675D0
      AMPIC = 139.5675D0
      AMPI  = 134.9739D0
      AMETA = 548.8D0
      AMETP = 957.5D0
      AMROC = 768.3D0
      AMRO  = 768.7D0
      AMOM  = 781.95D0
      AMFI  =1019.412D0
      AMA0C = 983.3D0
      AMA0  = 983.3D0
      AMF0  = 975.6D0
      AVSC  = ((NEUTM-PROTM)/AMROC)**2
      FAC   = 2D0*DSQRT(PROTM*NEUTM)/(PROTM+NEUTM)
      AWPIC = FAC*DSQRT(AMPIC**2 - (NEUTM-PROTM)**2)
      AWROC = FAC*DSQRT(AMROC**2 - (NEUTM-PROTM)**2)
      AWA0C = FAC*DSQRT(AMA0C**2 - (NEUTM-PROTM)**2)
 
**    Broad rho-meson: spectral density to two effective Yukawa's
**    Yukawa's fitted to PHI0C 0.001 - 2 fm (steps 0.002, ALAMV=825 MeV)
      GAMRO = 152.4D0
      THRRO = AMPIC+AMPIC
      GAMRC = 149.1D0
      THRRC = AMPIC+AMPI
      NRO  = 1
      ARO  = 0.2655205D0
      BRO  = 0.5607493D0
      AMR1 = 645.3772D0
      AMR2 = 878.3667D0
      AROC = 0.3875515D0
      BROC = 0.4508341D0
      AMRC1= 674.1521D0
      AMRC2= 929.9742D0
      AWRC1 = FAC*DSQRT(AMRC1**2 - (NEUTM-PROTM)**2)
      AWRC2 = FAC*DSQRT(AMRC2**2 - (NEUTM-PROTM)**2)
      AVSC1 = ((NEUTM-PROTM)/AMRC1)**2
      AVSC2 = ((NEUTM-PROTM)/AMRC2)**2
 
   10 CONTINUE
      IF(TYPE.EQ.TYP0) THEN
        IF(IDPAR0.EQ.IDPAR) THEN
          IF((IDPAR.EQ.1 .OR. IDPAR.EQ.2) .AND. PHNAME.NE.PHNAM0) THEN
            GOTO 15
          ELSE
            GOTO 20
          ENDIF
        ENDIF
      ENDIF
      TYP0=TYPE
      IF(TYPE.EQ.'PP') THEN
        AMY = PROTM
        AMN = PROTM
        I3Y = 1
        I3N = 1
      ELSEIF(TYPE.EQ.'NP') THEN
        AMY = NEUTM
        AMN = PROTM
        I3Y =-1
        I3N = 1
      ELSEIF(TYPE.EQ.'PN') THEN
        AMY = PROTM
        AMN = NEUTM
        I3Y = 1
        I3N =-1
      ELSEIF(TYPE.EQ.'NN') THEN
        AMY = NEUTM
        AMN = NEUTM
        I3Y =-1
        I3N =-1
      ENDIF
      ISIGN = I3Y*I3N
      CALL AMFACS
 
   15 PHNAM0=PHNAME
      IDPAR0=IDPAR
      CALL NYMPAR(ISIGN)
C              pseudovec  vector    tensor   scalar    pomeron
C              FPI        GRO       FRO      GA0       GPOM
C              PV1        GV1       FOM      GEP       GPOMP
C              ALPV       ALVE      FFI      GF0       AMPOM
C              THPV       THV       RHOC%    THGS      AMPOMP
C     Cut-off  ALAMP      ALAMV     ALAM     ALAMS     AMEP
C     2 Yukawa AEPS       AME1      BEPS     AME2      GAMEP
 
**    (joined) cutoffs for pseudoscalar, vector, scalar
      ALAMP = PAR(5,1)
      ALAMV = PAR(5,2)
      ALAMS = PAR(5,4)
      ALAM  = PAR(5,3)
      IF(ALAMP.EQ.0D0) ALAMP=ALAM
      IF(ALAMV.EQ.0D0) ALAMV=ALAM
      IF(ALAMS.EQ.0D0) ALAMS=ALAM
**    pseudovector couplings
      FPI   = DSQRT(FPPPI0*DEXP(-(AMPI/ALAMP)**2))
      PV1   = PAR(2,1)
      ALPV  = PAR(3,1)
      THPV  = PAR(4,1)*CONV
**    vector couplings
      GRO   = PAR(1,2)
      GV1   = PAR(2,2)
      ALVE  = PAR(3,2)
      THV   = PAR(4,2)*CONV
**    tensor couplings
      FRO   = PAR(1,3)
      FOM   = PAR(2,3)
      FFI   = PAR(3,3)
**    scalar couplings
      GA0   = PAR(1,4)
      GEP   = PAR(2,4)
      GF0   = PAR(3,4)
      THGS  = PAR(4,4)*CONV
**    diffractive contribution
      GPOM  = PAR(1,5)
      GPOMP = PAR(2,5)
      AMPOM = PAR(3,5)
      AMPOMP= PAR(4,5)
      IF(AMPOMP.EQ.0D0) AMPOMP=AMPOM
      AMPOM2= AMPOM*AMPOM
      AMPOM4= AMPOM2*AMPOM2
      APOMP2= AMPOMP*AMPOMP
      APOMP4= APOMP2*APOMP2
 
      CALL NYMCOP(ISIGN)
      GROGOM = GRO*GOM
      GROFOM = GRO*FOM/(2D0*AMT)
      FROGOM = FRO/(2D0*AMT)*GOM
      FROFOM = FRO*FOM/(4D0*AMT*AMT)
 
**    Broad epsilon-meson: spectral density to two effective Yukawa's
**    Yukawa's fitted to PHI0C from 0.001 to 2 fm (steps 0.005)
      AMEP  = PAR(5,5)
      GAMEP = PAR(6,5)
      THRE0 = AMPI+AMPI
      THREC = AMPIC+AMPIC
      NEP  = 0
      AEPS = PAR(6,1)
      AME1 = PAR(6,2)
      BEPS = PAR(6,3)
      AME2 = PAR(6,4)
 
**    isospin dependence
   20 FACISO= 4D0*ISO-2D0
      GA0C2 = FACISO*GA0*GA0
      FPIC2 = FACISO*FPI*FPI/(AMPV*AMPV)
      GROC2 = FACISO*GRO*GRO
      FROC2 = FACISO*FRO*FRO/(4D0*AMT*AMT)
      GFPROC= FACISO*(GRO*FRO+FRO*GRO)/(2D0*AMT)
      GFMROC= FACISO*(GRO*FRO-FRO*GRO)/(2D0*AMT)
      IF(PHNAME.EQ.'1S0' .AND. (TYPE.EQ.'NP'.OR.TYPE.EQ.'PN')) THEN
**      Phenomenological phase-shift difference in PP and NP 1S0
        GROC2=GROC2*(1D0+PAR(4,3))
        FROC2=FROC2*(1D0+PAR(4,3))
      ENDIF
 
      FPOM2 = (GPOM *AMPOM /AMT)**2 * 4D0*AMPOM /SRPI
      FPOMP2= (GPOMP*AMPOMP/AMT)**2 * 4D0*AMPOMP/SRPI
 
      RH = R/HBARC
      CALL RSPACE(RH,TYPE)
      CALL POTFUN(RH,TYPE,ISIGN,FACISO)
 
      RETURN
      END
************************************************************************
      SUBROUTINE AMFACS
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2,
     .              AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2,
     .              AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2
 
      AMY2  = AMY*AMY
      AMYI  = 1D0/AMY
      AMYI2 = AMYI*AMYI
      AMN2  = AMN*AMN
      AMNI  = 1D0/AMN
      AMNI2 = AMNI*AMNI
      AMYPN = AMY+AMN
      AMYMN = AMY-AMN
      AMYPN2= AMYPN*AMYPN
      AMYMN2= AMYMN*AMYMN
      AY2PN2= AMY2+AMN2
      AY2MN2= AMY2-AMN2
      AMYN  = AMY*AMN
      AMYNI = AMYI*AMNI
      AMYNI2= AMYNI*AMYNI
      AYPNI2= AMYI2+AMNI2
      AYMNI2= AMYI2-AMNI2
      REDM = AMYN/AMYPN
      ALF  = 4D0*REDM/AMYPN
      IF(AMY.EQ.AMN) ALF = 1D0
      RETURN
      END
************************************************************************
      SUBROUTINE NYMPAR(ISIGN)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/PARAMS/PAR(6,5)
      COMMON/CHOICE/IDPAR
      DIMENSION  PARTR1(5,6)
C              pseudovec  vector    tensor   scalar    pomeron
C              FPI        GRO       FRO      GA0       GPOM
C              PV1        GV1       FOM      GEP       GPOMP
C              ALPV       ALVE      FFI      GF0       AMPOM
C              THPV       THV       RHOC%    THGS      AMPOMP
C     Cut-off  ALAMP      ALAMV     ALAM     ALAMS     AMEP
C     2 Yukawa AEPS       AME1      BEPS     AME2      GAMEP
C----------------------------------------------------------------------
 
**    Parameter-set with separate cutoffs, and fitted to all data(Nijm93)
      DATA PARTR1/
     1 .2720668D+00,.9209319D+00,.3770582D+01,.1384689D+01,.5228672D+01
     2,.1595311D+00,.2594356D+01,.5816365D+00,.5310001D+01,.2204600D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.3484505D+01,.2081618D+03
     4,-.230000D+02,.3750000D+02,.4371144D-01,.3790000D+02,.0000000D+00
     5,.1177107D+04,.9045040D+03,.0000000D+00,.5544013D+03,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/

 
 
      IF(IDPAR.EQ.0) THEN
        DO 1 I=1,6
          DO 1 J=1,5
  1         PAR(I,J)=PARTR1(J,I)
      ELSEIF(IDPAR.EQ.1) THEN
        CALL PHSRDL(ISIGN)
      ELSEIF(IDPAR.EQ.2) THEN
        CALL PHSLOC(ISIGN)
      ENDIF
 
      WRITE(*,*) ' NIJMEGEN POTENTIAL PARAMETERS ARE:'
      DO 4 I=1,6
  4     WRITE(*,5) (PAR(I,J),J=1,5)
  5   FORMAT(5(1X,D15.7))
      RETURN
      END
************************************************************************
C     This subroutine reads the parameters of the 0-350 MeV fitted
C     Reidlike potential, Jan 1993, chi**2/data=1.03
C-----------------------------------------------------------------------
      SUBROUTINE PHSRDL(ISIGN)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER PHNAME*3
      LOGICAL NONREL
      COMMON/PARAMS/PAR(6,5)
      COMMON/EMANHP/PHNAME
      COMMON/RELKIN/NONREL
      DIMENSION APP1S0(5,6),ANP1S0(5,6),PAR1P1(5,6),PAR1D2(5,6),
     .          PAR1F3(5,6),PAR1G4(5,6),PAR3P1(5,6),PAR3D2(5,6),
     .          PAR3F3(5,6),PAR3G4(5,6),PAR3P0(5,6),PAR3C1(5,6),
     .          PAR3C2(5,6),PAR3C3(5,6),PAR3C4(5,6),PARRST(5,6),
     .          PNR3C1(5,6)
      DATA APP1S0/
     1 .2702427D+00,.6723103D+00,.3697581D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4846532D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4744299D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA ANP1S0/
     1 .2702427D+00,.6723103D+00,.3423514D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4942984D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1P1/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.3290519D+01,.5473693D-01,.4784616D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1D2/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.0000000D+00,.5473693D-01,.2348432D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.3639503D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1F3/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.4812761D+01,.5473693D-01,.6316315D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1G4/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.4142482D+01,.5473693D-01,.4859055D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3P1/
     1 .2702427D+00,.6723103D+00,.0000000D+00,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4980991D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4923498D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3D2/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5880449D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.1693534D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3F3/
     1 .2702427D+00,.6723103D+00,.8961465D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5458122D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3G4/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.3201615D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3P0/
     1 .2702427D+00,.6723103D+00,.3160965D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.3726932D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C1/
     1 .2706937D+00,.2598577D+01,.2125742D+01,.8334762D+00,.2751792D+01
     2,.0000000D+00,.2536422D+01,.5473693D-01,.4906761D+01,.44371888D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8848614D+03,.6465221D+03,.0000000D+00,.6990612D+03,.7600000D+03
     6,.1690008D+00,.5831763D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C2/
     1 .2702427D+00,.6723103D+00,.5188648D+01,.8334762D+00,.3668014D+01
     2,.1341669D+00,.0000000D+00,.5473693D-01,.3995761D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8275346D+03,.0000000D+00,.5831699D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C3/
     1 .2702427D+00,.6723103D+00,.3877361D+01,.8334762D+00,.4723766D+01
     2,.2811080D+00,.0000000D+00,.5473693D-01,.4818122D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C4/
     1 .2702427D+00,.6723103D+00,.7551377D+01,.8334762D+00,.2360920D+01
     2,.2871299D+00,.0000000D+00,.5473693D-01,.4855317D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PARRST/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
C     Parameters for a nonlocal potential with non-relativistic deuteron
      DATA PNR3C1/
     1 .2707126D+00,.2588931D+01,.2120162D+01,.8334762D+00,.2751792D+01
     2,.0000000D+00,.2521404D+01,.5473693D-01,.4889314D+01,.44371806D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8848614D+03,.6465221D+03,.0000000D+00,.6990612D+03,.7600000D+03
     6,.1690008D+00,.5831292D+03,.6130152D+00,.1021139D+04,.6400000D+03/
 
      DO 1 I=1,6
        DO 1 J=1,5
          IF(PHNAME.EQ.'1S0') THEN
            IF(ISIGN.EQ. 1) PAR(I,J)=APP1S0(J,I)
            IF(ISIGN.EQ.-1) PAR(I,J)=ANP1S0(J,I)
          ELSEIF(PHNAME.EQ.'1P1') THEN
            PAR(I,J)=PAR1P1(J,I)
          ELSEIF(PHNAME.EQ.'1D2') THEN
            PAR(I,J)=PAR1D2(J,I)
          ELSEIF(PHNAME.EQ.'1F3') THEN
            PAR(I,J)=PAR1F3(J,I)
          ELSEIF(PHNAME.EQ.'1G4') THEN
            PAR(I,J)=PAR1G4(J,I)
          ELSEIF(PHNAME.EQ.'3P0') THEN
            PAR(I,J)=PAR3P0(J,I)
          ELSEIF(PHNAME.EQ.'3P1') THEN
            PAR(I,J)=PAR3P1(J,I)
          ELSEIF(PHNAME.EQ.'3D2') THEN
            PAR(I,J)=PAR3D2(J,I)
          ELSEIF(PHNAME.EQ.'3F3') THEN
            PAR(I,J)=PAR3F3(J,I)
          ELSEIF(PHNAME.EQ.'3G4') THEN
            PAR(I,J)=PAR3G4(J,I)
          ELSEIF(PHNAME.EQ.'3C1') THEN
            IF(.NOT.NONREL) PAR(I,J)=PAR3C1(J,I)
            IF(NONREL) PAR(I,J)=PNR3C1(J,I)
          ELSEIF(PHNAME.EQ.'3C2') THEN
            PAR(I,J)=PAR3C2(J,I)
          ELSEIF(PHNAME.EQ.'3C3') THEN
            PAR(I,J)=PAR3C3(J,I)
          ELSEIF(PHNAME.EQ.'3C4') THEN
            PAR(I,J)=PAR3C4(J,I)
          ELSE
            PAR(I,J)=PARRST(J,I)
          ENDIF
    1 CONTINUE
      RETURN
      END
************************************************************************
C     This subroutine reads the parameters of the 0-350 MeV fitted
C     local potential (without Q**2), Jan 1993, chi**2/data=1.03
C-----------------------------------------------------------------------
      SUBROUTINE PHSLOC(ISIGN)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER PHNAME*3
      LOGICAL NONREL
      COMMON/PARAMS/PAR(6,5)
      COMMON/EMANHP/PHNAME
      COMMON/RELKIN/NONREL
      DIMENSION APP1S0(5,6),ANP1S0(5,6),PAR1P1(5,6),PAR1D2(5,6),
     .          PAR1F3(5,6),PAR1G4(5,6),PAR3P1(5,6),PAR3D2(5,6),
     .          PAR3F3(5,6),PAR3G4(5,6),PAR3P0(5,6),PAR3C1(5,6),
     .          PAR3C2(5,6),PAR3C3(5,6),PAR3C4(5,6),PARRST(5,6),
     .          PNR3C1(5,6)
      DATA APP1S0/
     1 .2702427D+00,.6723103D+00,.4006116D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4669822D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.3909783D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4692497D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA ANP1S0/
     1 .2702427D+00,.6723103D+00,.7407998D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4626459D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2196159D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4722381D+03,.6130152D+00,.1021139D+04,.6400000D+03/
C     DATA PAR1P1/
C    1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
C    2,.2871299D+00,.2849628D+01,.5473693D-01,.5411714D+01,.4437220D+00
C    3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
C    4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
C    5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
C    6,.1690008D+00,.5217623D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1P1/
     . .2702427D+00,.6723103D+00,.0000000D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.3430827D+01,.5473693D-01,.2825877D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+03,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1D2/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4138573D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2243917D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4367031D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1F3/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.3983000D+01,.5473693D-01,.5627977D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR1G4/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2037620D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3P1/
     1 .2702427D+00,.6723103D+00,.0000000D+00,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4171550D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.3368384D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4530824D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3D2/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5469270D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.1847244D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3F3/
     1 .2702427D+00,.6723103D+00,.6012926D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5530460D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3G4/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.3663270D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3P0/
     1 .2702427D+00,.6723103D+00,.2761025D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.3041218D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8275346D+03,.0000000D+00,.1134832D+04,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C1/
     1 .2702427D+00,.1607944D+01,.1841778D+01,.5469244D+00,.3469472D+01
     2,.2871299D+00,.2240543D+01,.5473693D-01,.4035077D+01,.4437213D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.5151821D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8275346D+03,.0000000D+00,.8044237D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C2/
     1 .2702427D+00,.6723103D+00,.5816373D+01,.8334762D+00,.3957678D+01
     2,.2353573D+00,.0000000D+00,.5473693D-01,.4143714D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2781205D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8275346D+03,.0000000D+00,.6121468D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C3/
     1 .2702427D+00,.6723103D+00,.4050335D+01,.8334762D+00,.4316501D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5048592D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PAR3C4/
     1 .2702427D+00,.6723103D+00,.7347855D+01,.8334762D+00,.2579081D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.5157279D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
      DATA PARRST/
     1 .2702427D+00,.6723103D+00,.4728635D+01,.8334762D+00,.2751792D+01
     2,.2871299D+00,.2849628D+01,.5473693D-01,.4859055D+01,.4437220D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.2579522D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.0000000D+00,.0000000D+00,.8275346D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
C     Parameters for a local potential with non-relativistic deuteron
      DATA PNR3C1/
     1 .2702427D+00,.1710842D+01,.1781765D+01,.5362515D+00,.3461562D+01
     2,.2871299D+00,.2247159D+01,.5473693D-01,.4028595D+01,.44387996D+00
     3,.3550000D+00,.1000000D+01,.0000000D+00,.8389363D+00,.5184792D+03
     4,-.230000D+02,.3750000D+02,.0000000D+00,.3790000D+02,.0000000D+00
     5,.8275346D+03,.0000000D+00,.8044237D+03,.0000000D+00,.7600000D+03
     6,.1690008D+00,.4878179D+03,.6130152D+00,.1021139D+04,.6400000D+03/
 
      DO 1 I=1,6
        DO 1 J=1,5
          IF(PHNAME.EQ.'1S0') THEN
            IF(ISIGN.EQ. 1) PAR(I,J)=APP1S0(J,I)
            IF(ISIGN.EQ.-1) PAR(I,J)=ANP1S0(J,I)
          ELSEIF(PHNAME.EQ.'1P1') THEN
            PAR(I,J)=PAR1P1(J,I)
          ELSEIF(PHNAME.EQ.'1D2') THEN
            PAR(I,J)=PAR1D2(J,I)
          ELSEIF(PHNAME.EQ.'1F3') THEN
            PAR(I,J)=PAR1F3(J,I)
          ELSEIF(PHNAME.EQ.'1G4') THEN
            PAR(I,J)=PAR1G4(J,I)
          ELSEIF(PHNAME.EQ.'3P0') THEN
            PAR(I,J)=PAR3P0(J,I)
          ELSEIF(PHNAME.EQ.'3P1') THEN
            PAR(I,J)=PAR3P1(J,I)
          ELSEIF(PHNAME.EQ.'3D2') THEN
            PAR(I,J)=PAR3D2(J,I)
          ELSEIF(PHNAME.EQ.'3F3') THEN
            PAR(I,J)=PAR3F3(J,I)
          ELSEIF(PHNAME.EQ.'3G4') THEN
            PAR(I,J)=PAR3G4(J,I)
          ELSEIF(PHNAME.EQ.'3C1') THEN
            IF(.NOT.NONREL) PAR(I,J)=PAR3C1(J,I)
            IF(NONREL) PAR(I,J)=PNR3C1(J,I)
          ELSEIF(PHNAME.EQ.'3C2') THEN
            PAR(I,J)=PAR3C2(J,I)
          ELSEIF(PHNAME.EQ.'3C3') THEN
            PAR(I,J)=PAR3C3(J,I)
          ELSEIF(PHNAME.EQ.'3C4') THEN
            PAR(I,J)=PAR3C4(J,I)
          ELSE
            PAR(I,J)=PARRST(J,I)
          ENDIF
    1 CONTINUE
      RETURN
      END
************************************************************************
      SUBROUTINE NYMCOP(ISIGN)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2,
     .              ALVE,THV ,GV1, GRO,GOM,GFI,  GRO2,GOM2,GFI2,
     .              ALVM,     FV1, FRO,FOM,FFI,  FRO2,FOM2,FFI2,
     .              ALGS,THGS,GS1, GA0,GEP,GF0,  GA02,GEP2,GF02,
     .              GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI,
     .              FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2
      COMMON/SCALIN/AMT,AMPV
      DATA SR3/1.7320508075688772935D0/
 
**    pseudovector coupling constants
      PV8  = FPI * (4D0*ALPV-1D0)/SR3
      COST = DCOS(THPV)
      SINT = DSIN(THPV)
      FETA = COST*PV8 - SINT*PV1
      FETP = SINT*PV8 + COST*PV1
      FPI2 = FPI*FPI/(AMPV*AMPV) * ISIGN
      FETA2= FETA*FETA/(AMPV*AMPV)
      FETP2= FETP*FETP/(AMPV*AMPV)
 
**    vector coupling constants
      GV8  = GRO * (4D0*ALVE-1D0)/SR3
      COST = DCOS(THV)
      SINT = DSIN(THV)
      GFI  = COST*GV8 - SINT*GV1
      GOM  = SINT*GV8 + COST*GV1
      GRO2 = GRO*GRO * ISIGN
      GOM2 = GOM*GOM
      GFI2 = GFI*GFI
 
**    tensor coupling constants
      COST = DCOS(THV)
      SINT = DSIN(THV)
      FV8  = COST*(GFI+FFI) + SINT*(GOM+FOM) - GV8
      FV1  =-SINT*(GFI+FFI) + COST*(GOM+FOM) - GV1
      ALVM = (SR3*(GV8+FV8)+(GRO+FRO))/(4D0*(GRO+FRO))
      FRO2 = FRO*FRO/(4D0*AMT*AMT) * ISIGN
      FOM2 = FOM*FOM/(4D0*AMT*AMT)
      FFI2 = FFI*FFI/(4D0*AMT*AMT)
 
      GFPRO = (GRO*FRO+FRO*GRO)/(2D0*AMT) * ISIGN
      GFPOM = (GOM*FOM+FOM*GOM)/(2D0*AMT)
      GFPFI = (GFI*FFI+FFI*GFI)/(2D0*AMT)
      GFMRO = (GRO*FRO-FRO*GRO)/(2D0*AMT) * ISIGN
      GFMOM = (GOM*FOM-FOM*GOM)/(2D0*AMT)
      GFMFI = (GFI*FFI-FFI*GFI)/(2D0*AMT)
 
**    scalar coupling constants
      COST = DCOS(THGS)
      SINT = DSIN(THGS)
      GS8  = COST*GEP + SINT*GF0
      GS1  =-SINT*GEP + COST*GF0
      ALGS = (SR3*GS8+GA0)/(4D0*GA0)
      GA02 = GA0*GA0 * ISIGN
      GEP2 = GEP*GEP
      GF02 = GF0*GF0
 
      RETURN
      END
************************************************************************
      SUBROUTINE RSPACE(RH,TYPE)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER TYPE*2
      DIMENSION RES1(7), RES2(7)
      COMMON/MESONM/AMPI,AMETA,AMETP, AMRO,AMOM,AMFI, AMA0,AMEP,AMF0,
     .              AMPIC,AMROC,AMA0C,AWPIC,AWROC,AWA0C, AVSC
      COMMON/YUKEFF/ARO,AMR1,AROC,AMRC1,AWRC1,BRO,AMR2,BROC,AMRC2,AWRC2,
     .              AVSC1,AVSC2, AEPS,AME1,BEPS,AME2
      COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS
      COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4,
     .              GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4
      COMMON/RMAT/  A(7,13),B(7)
 
C**   Pseudoscalar mesons pi, eta, eta'
      CALL REGGE(RH,AMPI,ALAMP,A(1,2))
      CALL REGGE(RH,AMETA,ALAMP,A(1,3))
      CALL REGGE(RH,AMETP,ALAMP,A(1,4))
 
C**   Vector mesons rho, omega, phi
      CALL REGGE(RH,AMR1,ALAMV,RES1)
      CALL REGGE(RH,AMR2,ALAMV,RES2)
      DO 11 I=1,7
        A(I,6) = ARO*RES1(I) + BRO*RES2(I)
   11 CONTINUE
      CALL REGGE(RH,AMOM,ALAMV,A(1,7))
      CALL REGGE(RH,AMFI,ALAMV,A(1,8))
      DO 12 I=1,7
        B(I)=A(I,6)-A(I,7)
   12 CONTINUE
 
c**   Scalar mesons a0(980), epsilon, f0(975)
      CALL REGGE(RH,AMA0,ALAMS,A(1,10))
      CALL REGGE(RH,AME1,ALAMS,RES1)
      CALL REGGE(RH,AME2,ALAMS,RES2)
      DO 13 I=1,7
        A(I,11) = AEPS*RES1(I) + BEPS*RES2(I)
   13 CONTINUE
      CALL REGGE(RH,AMF0,ALAMS,A(1,12))
 
C**   Isospin-1 mesons (pi+, rho+, a0+)
      IF(TYPE.EQ.'NP' .OR. TYPE.EQ.'PN') THEN
        CALL REGGE(RH,AWPIC,ALAMP,A(1,1))
        CALL REGGE(RH,AWRC1,ALAMV,RES1)
        CALL REGGE(RH,AWRC2,ALAMV,RES2)
        DO 14 I=1,7
          A(I,5) = AROC*RES1(I) + BROC*RES2(I)
C*        Second part vector-vector potential (same as scalar potential)
          A(I,13)= AVSC1*AROC*RES1(I) + AVSC2*BROC*RES2(I)
   14   CONTINUE
        CALL REGGE(RH,AWA0C,ALAMS,A(1,9))
      ENDIF
 
      RETURN
      END
************************************************************************
      SUBROUTINE REGGE(RH,AM,ALAM,FIFUNS)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION FIFUNS(7)
      DATA ZMATCH/1D-02/, SQPI/1.7724538509055160273D0/
 
      RATM=AM/ALAM
      RATM2=RATM*RATM
      RATM3=RATM*RATM2
      EXPM=FDEXP(RATM2)
      AM3=AM*AM*AM
      AM5=AM*AM*AM3
      Z=RH*ALAM
 
      IF(Z.GT.ZMATCH) THEN
        XLAM=0.5D0*RH*ALAM
        XLAM2=XLAM*XLAM
        ELAM=FDEXP(-XLAM2)
        X=AM*RH
        ERFCM=FDERFC(RATM-XLAM)
        ERFCP=FDERFC(RATM+XLAM)
        EPX=0D0
        IF(ERFCP.NE.0) EPX=FDEXP(X)
        EMX=FDEXP(-X)
 
        PHI0C = EXPM*(EMX*ERFCM-EPX*ERFCP)/(2D0*X)
        PHI0L =(EXPM*(EMX*ERFCM*(1D0+X)-EPX*ERFCP*(1D0-X))-
     .          4D0/SQPI*XLAM*ELAM ) / (2D0*X*X*X)
        PHI0T =(EXPM*(EMX*ERFCM*(1D0+X+X*X/3D0)
     .               -EPX*ERFCP*(1D0-X+X*X/3D0))
     .         -8D0/SQPI*XLAM*(0.5D0+XLAM2/3D0)*ELAM) / (2D0*X*X*X)
        DEL1C =-ELAM/(RATM3*2D0*SQPI)
        DEL1L =-ELAM/(RATM2*RATM3*4D0*SQPI)
        DEL1T =-ELAM*XLAM2/(RATM2*RATM3*6D0*SQPI)
        DEL2C = 3D0*(DEL1T-DEL1L)
      ELSE
        A=RATM
        B=-FDERFC(A)*A*EXPM*SQPI
        A2=A*A
        A4=A2*A2
        A6=A4*A2
        A8=A6*A2
        A10=A8*A2
        Z2=Z*Z
        Z4=Z2*Z2
        Z6=Z4*Z2
        Z8=Z6*Z2
        PHI0C = (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z8/5806080D0+
     .          (8*A6*B+8*A6-4*A4+6*A2-15)*Z6/40320D0+
     .          (4*A4*B+4*A4-2*A2+3)*Z4/480D0+
     .          (2*A2*B+2*A2-1)*Z2/12D0+B+1D0
        PHI0C = PHI0C/(SQPI*A)
        PHI0T = (32*A10*B+32*A10-16*A8+24*A6-60*A4+210*A2-945)
     .           *Z8/47900160D0+
     .          (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z6/362880D0+
     .          (8*A6*B+8*A6-4*A4+6*A2-15)*Z4/5040D0+
     .          (4*A4*B+4*A4-2*A2+3)*Z2/180D0
        PHI0T = PHI0T/(SQPI*A**3)
        PHI0L =-(32*A10*B+32*A10-16*A8+24*A6-60*A4+210*A2-945)
     .           *Z8/127733760D0-
     .          (16*A8*B+16*A8-8*A6+12*A4-30*A2+105)*Z6/725760D0-
     .          (8*A6*B+8*A6-4*A4+6*A2-15)*Z4/6720D0-
     .          (4*A4*B+4*A4-2*A2+3)*Z2/120D0-(2*A2*B+2*A2-1D0)/6D0
        PHI0L = PHI0L/(SQPI*A**3)
        DEL1C =-Z8/12288D0+Z6/768D0-Z4/64D0+Z2/8D0-0.5D0
        DEL1C = DEL1C/(SQPI*A**3)
        DEL1T = Z8/9216D0-Z6/768D0+Z4/96D0-Z2/24D0
        DEL1T = DEL1T/(SQPI*A**5)
        DEL1L =-Z8/24576D0+Z6/1536D0-Z4/128D0+Z2/16D0-0.25D0
        DEL1L = DEL1L/(SQPI*A**5)
        DEL2C = 3D0*(DEL1T-DEL1L)
      ENDIF
 
      FIFUNS(1) = AM*PHI0C
      FIFUNS(2) = AM3*(PHI0C+DEL1C)
      FIFUNS(3) = AM5*(PHI0C+DEL1C+DEL2C)
      FIFUNS(4) = AM3*PHI0L
      FIFUNS(5) = AM5*(PHI0L+DEL1L)
      FIFUNS(6) = AM3*PHI0T
      FIFUNS(7) = AM5*(PHI0T+DEL1T)
 
      RETURN
      END
************************************************************************
      FUNCTION FDEXP(X)
      IMPLICIT REAL*8(A-Z)
      IF(X.LE.-100D0) THEN
        FDEXP=0D0
      ELSE
        FDEXP=DEXP(X)
      ENDIF
      RETURN
      END
************************************************************************
      FUNCTION FDERFC(X)
      IMPLICIT REAL*8(A-Z)
      IF(X.GE. 10D0) THEN
        FDERFC=0D0
      ELSEIF(X.LE.-10D0) THEN
        FDERFC=2D0
      ELSE
        FDERFC=DERFC(X)
      ENDIF
      RETURN
      END
************************************************************************
      SUBROUTINE POTFUN(RH,TYPE,ISIGN,FACISO)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER TYPE*2
      COMMON/POTS/  VC,VSS,VT,VLS,VLSA,VQ12,FIC,FICP,FICPP
      COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2,
     .              ALVE,THV ,GV1, GRO,GOM,GFI,  GRO2,GOM2,GFI2,
     .              ALVM,     FV1, FRO,FOM,FFI,  FRO2,FOM2,FFI2,
     .              ALGS,THGS,GS1, GA0,GEP,GF0,  GA02,GEP2,GF02,
     .              GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI,
     .              FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2
      COMMON/SCALIN/AMT,AMPV
      COMMON/CUTOFF/ALAM,ALAMP,ALAMV,ALAMS
      COMMON/CHOICE/IDPAR
      COMMON/POMRON/GPOM, FPOM2, AMPOM, AMPOM2,AMPOM4,
     .              GPOMP,FPOMP2,AMPOMP,APOMP2,APOMP4
      COMMON/AMCOEF/ALF,REDM, AMY,AMY2,AMYI,AMYI2, AMN,AMN2,AMNI,AMNI2,
     .              AMYPN,AMYMN, AMYPN2,AMYMN2, AY2PN2,AY2MN2,
     .              AMYN,AMYNI,AMYNI2, AYPNI2,AYMNI2
      COMMON/RMAT/  A(7,13),B(7)
 
      RH2= RH*RH
 
C*    Pseudoscalar-meson potential
      VPVS = (FPI2*A(2,2)+FETA2*A(2,3)+FETP2*A(2,4)) / 3D0
      VPVT = (FPI2*A(6,2)+FETA2*A(6,3)+FETP2*A(6,4))
 
C*    Vector-meson potential
      VVC   = (GRO2*A(1,6)+GOM2*A(1,7)+GFI2*A(1,8)) +
     .        (GRO2*A(2,6)+GOM2*A(2,7)+GFI2*A(2,8)) * AMYNI/(2D0*ALF) +
     .        (GFPRO*A(2,6)+GFPOM*A(2,7)+GFPFI*A(2,8)) / (4D0*REDM) +
     .        (FRO2*A(3,6)+FOM2*A(3,7)+FFI2*A(3,8)) * AMYNI/4D0
      VVS   = ((GRO2+AMYPN*GFPRO+4D0*AMYN*FRO2)*A(2,6) +
     .         (GOM2+AMYPN*GFPOM+4D0*AMYN*FOM2)*A(2,7) +
     .         (GFI2+AMYPN*GFPFI+4D0*AMYN*FFI2)*A(2,8)) * AMYNI/6D0 +
     .        (FRO2*A(3,6)+FOM2*A(3,7)+FFI2*A(3,8)) * AMYNI/12D0
      VVT   =-((GRO2+AMYPN*GFPRO+4D0*AMYN*FRO2)*A(6,6) +
     .         (GOM2+AMYPN*GFPOM+4D0*AMYN*FOM2)*A(6,7) +
     .         (GFI2+AMYPN*GFPFI+4D0*AMYN*FFI2)*A(6,8)) * AMYNI/4D0 -
     .        (FRO2*A(7,6)+FOM2*A(7,7)+FFI2*A(7,8)) * AMYNI/8D0
      VVLS  =-((GRO2*(0.5D0+1D0/ALF)+AMYPN*GFPRO)*A(4,6) +
     .         (GOM2*(0.5D0+1D0/ALF)+AMYPN*GFPOM)*A(4,7) +
     .         (GFI2*(0.5D0+1D0/ALF)+AMYPN*GFPFI)*A(4,8)) * AMYNI -
     .        (FRO2*A(5,6)+FOM2*A(5,7)+FFI2*A(5,8))*AMYNI*(.5D0+1D0/ALF)
      VVQ12 = ((GRO2+4D0*AMYPN*GFPRO+8D0*AMYPN2*FRO2)*A(6,6) +
     .         (GOM2+4D0*AMYPN*GFPOM+8D0*AMYPN2*FOM2)*A(6,7) +
     .         (GFI2+4D0*AMYPN*GFPFI+8D0*AMYPN2*FFI2)*A(6,8)) *
     .        AMYNI2/16D0 * 3D0/RH2
      FICV  = REDM*(GRO2*A(1,6)+GOM2*A(1,7)+GFI2*A(1,8)) *
     .             (AYPNI2+AMYNI)/2D0
      FICVP =-REDM*(GRO2*A(4,6)+GOM2*A(4,7)+GFI2*A(4,8)) *
     .             (AYPNI2+AMYNI)/2D0 * RH
      FICV2 = REDM*(GRO2*A(2,6)+GOM2*A(2,7)+GFI2*A(2,8)) *
     .             (AYPNI2+AMYNI)/2D0
     .      + REDM*(GRO2*A(4,6)+GOM2*A(4,7)+GFI2*A(4,8)) *(AYPNI2+AMYNI)
 
C*    Scalar-meson potential
      VSC  =-(GA02*A(1,10)+GEP2*A(1,11)+GF02*A(1,12)) +
     .       (GA02*A(2,10)+GEP2*A(2,11)+GF02*A(2,12)) * AYPNI2/8D0
      VSLS =-(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12)) * AYPNI2/4D0
      VSQ12=-(GA02*A(6,10)+GEP2*A(6,11)+GF02*A(6,12)) * AMYNI2/16D0
     .       *3D0/RH2
      FICS = REDM*(GA02*A(1,10)+GEP2*A(1,11)+GF02*A(1,12))*AMYNI/2D0
      FICSP=-REDM*(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12))*AMYNI/2D0*RH
      FICS2= REDM*(GA02*A(2,10)+GEP2*A(2,11)+GF02*A(2,12))*AMYNI/2D0
     .     + REDM*(GA02*A(4,10)+GEP2*A(4,11)+GF02*A(4,12))*AMYNI
 
C*    Diffractive contribution
      XI0 = AMPOM*RH
      XI02 = XI0*XI0
      EXI0 = 0D0
      IF(XI02.LT.170.) EXI0 = FDEXP(-XI02)
      XI1 = AMPOMP*RH
      XI12 = XI1*XI1
      EXI1 = 0D0
      IF(XI12.LT.170.) EXI1 = FDEXP(-XI12)
      VDC  = FPOM2 * (1D0+AMPOM2*(1.5D0-XI02)*AYPNI2/2D0) * EXI0 +
     .       FPOMP2* (1D0+APOMP2*(1.5D0-XI12)*AYPNI2/2D0)*ISIGN * EXI1
      VDLS = (FPOM2 * AMPOM2 * EXI0 +
     .        FPOMP2* APOMP2 * EXI1*ISIGN) * AYPNI2/2D0
      VDQ12= (FPOM2 * AMPOM4 * EXI0 +
     .        FPOMP2* APOMP4 * EXI1*ISIGN) * AMYNI2/4D0
      FICD  =-REDM*(FPOM2*EXI0 + ISIGN*FPOMP2*EXI1) * AMYNI/2D0
      FICDP = REDM*(FPOM2*EXI0*XI02 + ISIGN*FPOMP2*EXI1*XI12) * AMYNI/RH
      FICD2 = REDM*(FPOM2*EXI0*(1D0-2D0*XI02)*AMPOM2 +
     .              ISIGN*FPOMP2*EXI1*(1D0-2D0*XI12)*APOMP2) * AMYNI
 
      IF(TYPE.EQ.'NP' .OR. TYPE.EQ.'PN') THEN
**      Pseudoscalar: pi+
        VPVS = VPVS + FPIC2/ALF*A(2,1)/3D0
        VPVT = VPVT + FPIC2/ALF*A(6,1)
 
**      Vector: rho+
        VVC   = VVC   + GROC2*ALF*A(1,5)+GROC2*AMYNI/2D0*A(2,5)+
     .          ALF*(GFPROC*AMYPN+FROC2*AMYMN2)*AYPNI2/8D0*A(2,5) +
     .          FROC2*AMYNI/4D0*A(3,5) *
     .                (1D0+(AY2MN2**2+2D0*AMYN*AMYMN2)*AMYNI2/16D0)
        VVS   = VVS   + (GROC2+AMYPN*GFPROC+AMYPN2*FROC2)*
     .          (AMYNI/6D0+ALF*AMYMN2*AMYNI2/16D0) * A(2,5) +
     .          FROC2/ALF*AYPNI2/24D0*A(3,5)
        VVT   = VVT   - FROC2/ALF*AYPNI2/16D0*A(7,5) -
     .          (GROC2+AMYPN*GFPROC+AMYPN2*FROC2)*AMYNI/4D0*A(6,5)
        VVLS  = VVLS  -((2D0-ALF/2D0)*GROC2+2D0*AY2PN2/AMYPN*GFPROC
     .                  + 2D0*AMYMN2*FROC2)*AMYNI*A(4,5)  -  A(5,5)*
     .          FROC2*((2D0/ALF-0.5D0)/ALF-AMYMN2*AMYNI/8D0)*AMYNI
        VVQ12 = VVQ12 + ALF*(GROC2+4D0*AMYPN*GFPROC+8D0*AMYPN2*FROC2)*
     .          A(6,5) * AMYNI2/16D0 * 3D0/RH2
        FICV  = FICV  + REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 +
     .                  GFPROC*AMYMN2/AMYPN*AMYNI +
     .                  FROC2*(4D0/ALF-2D0*ALF*AY2PN2*AMYNI)) * A(1,5)
        FICVP = FICVP - REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 +
     .                  GFPROC*AMYMN2/AMYPN*AMYNI +
     .                  FROC2*(4D0/ALF-2D0*ALF*AY2PN2*AMYNI))*A(4,5)*RH
        FICV2 = FICV2 + REDM*(ALF*GROC2*(AYPNI2+AMYNI)/2D0 +
     .                  GFPROC*AMYMN2/AMYPN*AMYNI + FROC2*
     .          (4D0/ALF-2D0*ALF*AY2PN2*AMYNI)) * (A(2,5)+2D0*A(4,5))
C       Second part of vector-vector potential (same as scalar)
        VVC  = VVC  + ALF*GROC2*(A(1,13)-AMYNI/4D0*A(2,13))
        VVLS = VVLS + ALF*GROC2*AMYNI/2D0*A(4,13)
        VVQ12= VVQ12+ ALF*GROC2*AMYNI2/16D0*A(6,13) * 3D0/RH2
        FICV = FICV + ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)*A(1,13)
        FICVP= FICVP- ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)*A(4,13)*RH
        FICV2= FICV2+ ALF*REDM*GROC2*(AYPNI2/4D0-AMYNI)*
     .                (A(2,13)+2D0*A(4,13))
 
**      Scalar: a0+
        VSC  = VSC  - ALF*(GA0C2*A(1,9) - GA0C2*A(2,9)*AMYNI/4D0)
        VSLS = VSLS - ALF*GA0C2*A(4,9)*AMYNI/2D0
        VSQ12= VSQ12- ALF*GA0C2*A(6,9)*AMYNI2/16D0 * 3D0/RH2
        FICS = FICS - REDM*ALF*GA0C2*A(1,9) * (AYPNI2/4D0-AMYNI)
        FICSP= FICSP+ REDM*ALF*GA0C2*A(4,9) * (AYPNI2/4D0-AMYNI)*RH
        FICS2= FICS2- REDM*ALF*GA0C2*(AYPNI2/4D0-AMYNI)*
     .                (A(2,9)+2D0*A(4,9))
 
**      Diffractive: pomeron (A2)
        VDC  = VDC  + FACISO*FPOMP2*
     .                (1D0+APOMP2*(1.5D0-XI12)*AMYNI) * EXI1
        VDLS = VDLS + FACISO*FPOMP2 * APOMP2*AMYNI * EXI1
        VDQ12= VDQ12+ FACISO*FPOMP2 * APOMP4*AMYNI2/4D0 * EXI1
        FICD = FICD + REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1
        FICDP= FICDP- REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1
     .                     * 2D0*XI12/RH
        FICD2= FICD2- REDM * FACISO*FPOMP2*(AYPNI2/4D0-AMYNI)*EXI1 *
     .                APOMP2*(2D0-4D0*XI12)
      ENDIF
 
      VC   = VSC         + VVC   + VDC
      VSS  =        VPVS + VVS
      VT   =        VPVT + VVT
      VLS  = VSLS        + VVLS  + VDLS
      VLSA = 0D0
      VQ12 = VSQ12       + VVQ12 + VDQ12
 
      FIC  = FICS        + FICV + FICD
      FICP = FICSP       + FICVP+ FICDP
      FICPP= FICS2       + FICV2+ FICD2
 
      RETURN
      END
