!---------------------------------------------------------------------

! simple calling routine, just to check meson parameters etc:

!      call HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS)

!      SP: NCHAN=1, LN NCHAN=2, LP: NCHAN=3

!      NBASE=1: SU(2) BASIS, NBASE=2: PARTICLE BASIS

!---------------------------------------------------------------------

c      subroutine dummy   ! example of calling program

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL,

     .           FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL,

     .           VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS,

     .           FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS,

     .           VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS,

     .           FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS,

     .           VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR,

     .           FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR

c*   .          ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN

      COMMON/POTPRT/VPRT(12,3,3)      ! PRT=PARTICLE



      do 1 i=1,10

      xfm = 0.1d0*i

      call HNPOT16(xfm,0,0,3,1,0) ! Lp 1s0, isospin basis, noprint

c     call HNPOT16(xfm,0,0,3,1,1) ! Lp 1s0, isospin basis, print

c     call HNPOT16(xfm,0,0,3,2,1) ! Lp 1s0, particle basis

c     call HNPOT16(xfm,0,1,3,1,1) ! Lp 3s1

    1 write(6,11) xfm,vcll,vsigll,vtenll,vsoll,vso2ll

   11 format(' xfm=',f8.3,' vcll=',d12.5,' vsigll=',d12.5,

     .' vtenll=',d12.5,' vsoll=',d12.5,' vso2ll=',d12.5)

      write(*,*)

      do 2 i=1,10

      xfm = 0.1d0*i

      call HNPOT16(xfm,0,0,3,1,1) ! Lp 1s0, isospin basis

    2 write(6,21) xfm,fill,dfill,fisll,dfisll         

   21 format(' xfm=',f8.3,' fill=',d12.5,' dfill =',d12.5,

     .' fisll =',d12.5,' dfisll=',d12.5)

       

       stop

       end

C *******************************************************************

C *******************************************************************

C     SUBROUTINE HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS) ! this version

C *******************************************************************

C     2011, AUGUST: A LA BBPROGS.MARIUS11.CSB

C            AXIAL MESONS, D1 <-> OMEGA(783), E1 <-> PHI(1020)  

C -------------------------------------------------------------------

C     2009, AUGUST: REFINED TREATMENT QUARK-CORE EFFECTS IN DIFRAC

C -------------------------------------------------------------------

C     2008: POSIBILITY: NSU3F = 0 (SU3F-BREAKING), = 1 (SU3F-SYMMETRY) !!

C           SETTING: VIA DATA STATEMENT IN THIS ROUTINE!

C *******************************************************************

C     NOTICE: ORGANIZATION COMMON/POT/ SIMILAR AS FOR NSC89 PROGRAM !

C *******************************************************************

c     2009: csb: nchan=1-> icsb=0, nchan=2-> icsb=-1, nchan=3-> icsb=+1

c     version: nchan=1 -> Sigma(+)-proton

c              nchan=2 -> Lambda  -neutron

c              nchan=3 -> Lambda  -proton  

 

c     note: sigma(-)-proton, not proper threshold treatment!!!

c--------------------------------------------------------------------

c     version with green transformation facility!!



c     IGREEN = 0: output the model-potentials, unmodified !                   

c   

c     IGREEN = 1: green transformation -> modified potentials  



C *******************************************************************

C

C     HYPERON - NUCLEON POTENTIAL PROGRAM :

C

C     Model-options:

C     *********************************************************************

C     *  ESC04: OSAKA-VERSION DECEMBER 2004                               *

C     *                                                                   *

C     *  IMODEL = 1 : Hard-Core MODEL PRD15 = YN-model D                  *

C     *  IMODEL = 2 : Hard-Core MODEL PRD20 = YN-model F                  *

C     *                                                                   *

C     *  IMODEL = 3 : Soft-Core MODEL NSC97f= YN-model                    *

C     *  IMODEL = 4 : Soft-Core MODEL NSC97e= YN-model                    *

C     *                                                                   *

C     *  IMODEL = 6 : Soft-Core MODEL ESC04A= NN+YN-model, paper II       *

C     *  IMODEL = 7 : Soft-Core MODEL ESC04B= NN+YN-model, paper II       *

C     *  IMODEL = 8 : Soft-Core MODEL ESC04C= NN+YN-model, paper II       *

C     *  IMODEL = 9 : Soft-Core MODEL ESC04D= NN+YN-model, paper II       *

C     *  IMODEL =10-13 : Soft-Core MODEL ESC06D= NN+YN-model              *

C     *  IMODEL =14,15 : Soft-Core MODEL ESC07D= NN+YN-model              *



C     *  IMODEL =16-17 : Soft-Core MODEL ESC08 = NN+YN-model              *

C                                                                         *

C     *  IMODEL =18 : Soft-Core MODEL ESC08 = definite version 2 nov. 2010*

C     *********************************************************************

C

C     IN THIS VERSION ZERO'S IN FORM FACTORS ARE OPTIONAL !

C

C -------------------------------------------------------------------------

CC

CC    THE POTENTIALS ARE TO BE USED IN THE MULTICHANNEL SCHRODINGER

CC                                _    1

CC  [ 1/(2 mu )*d(i,j)*LAPL - V  (r) + -(LAPL*phi  (r) + phi  (r)*LAPL)

CC           i                 ij      2         ij         ij

CC       2                        _

CC   + (k /2*mu )*d(i,j) ] * psi (r) = 0 .

CC             i                j

CC

CC    here phi = FI/(MRED) in program.   LAPL = laplacian operator.

CC

CC    EQUATION LIKE NR.36 IN PR.D17,1978,

CC !! except for definition phi !! The adaption is made

C -------------------------------------------------------------------

CC IN COMMON/POT/: FI, FIS are defined as the phi(r) in 

CC EQUATION NR.35 in PRD17, 1978, which differs from the phi(r)

cc above in the Schrodinger eq.!!!

C *******************************************************************

C

C  !! POTENTIALS FROM INDIVIDUAL MESONS CAN BE OBTAINED BY

C     CHANGING DATA OF COMMON/INMES/ IN BLOCKDATA SUBPROGRAM !!

C

C INPUT :

C     X     = YN-DISTANCE IN PION-COMPTON WAVELENGTH

C     NCHAN = 1 : SIGMA(+)-PROTON

C           = 2 : LAMBDA-NEUTRON

C           = 3 : LAMBDA-PROTON

C

C     NBASE = 1 : POTENTIALS ONLY CALCULATED ON THE ISOSPIN-BASIS

C           = 2 : POTENTIALS ALSO CALCULATED ON THE PARTICLE-BASIS

C

C     NS    = 0 : NOPRINT

C           = 1 : RESTRICTED PRINTING

C           = 2 : EXTENSIVE PRINTING. THE PROGRAM PRINTS X,

C                 AND THE TOTAL POTENTIALS ON THE ISOSPIN-BASIS

C               [  VCLL,VSIGLL,VTENLL,VSOLL,VSO2LL,FILL,DFILL,DDFILL ]

C     ISPIN=1/2 [  VCSS,VSIGSS,VTENSS,VSOSS,VSO2SS,FISS,DFISS,DDFISS ]

C               [  VCLS,VSIGLS,VTENLS,VSOLS,VSO2LS,FILS,DFILS,DDFILS ]

C

C     ISPIN=3/2 [  VCDR,VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR ]

C

C                 AND FOR NBASE=2 ALSO THE POTENTIALS ON THE

C                 PARTICLE BASIS

C

C     NS    = 3 : EXTRA PRINTING : THE PROGRAM PRINTS ALSO

C                 THE POTENTIALS ON THE ISOSPIN-BASIS PER MESON-TYPE

C

C     LINT = ORBITAL ANGULAR MOMENTUM YN-CHANNEL

C

C     JSPIN= TOTAL SPIN YN-CHANNEL

C

C     HERE: AKS(I) ARE PUT TO ZERO, RELEVANT IN CASE OF NADIA=1

C

C

C END INPUT DESCRIPTION. ********************************************

C

C OUTPUT: NIJMEGEN-SOFTCORE HYPERON-NUCLEON POTENTIALS

C

C     LITERATURE NIJMEGEN OBE-MODEL :  PHYS.REV. D17,P.768,1978 (NN)

C                                   :  FONTEFRAUD CONF.   ,1987 (YN)

C                                   :  PHYS.REV.,TO BE SUBMITTED(YN)

C

C AD NBASE=1 :

C     THE POTENTIALS ON THE ISOSPIN-BASIS ARE COMMUNICATED TO THE

C     CALLING PROGRAM VIA

c     COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL,

c    .           FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL,

c    .           VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS,

c    .           FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS,

c    .           VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS,

c    .           FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS,

c    .           VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR,

c    .           FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR

c*   .          ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN

C

C     HERE NOMENCLATURE :

C

C     VC   = CENTRAL POTENTIAL   , VSIG = SPIN-SPIN POTENTIAL ,

C     VTEN = TENSOR     ,,       , VSO  = SPIN-ORBIT   ,,     ,

C     VASO = ASYMM. LS  ,,       , VSO2 = QUADRATIC SPIN-ORBIT.

C     FI   = MRED*PHI, DFI  = MRED*PHI', DDFI = MRED*PHI'',

C     FIS  = MRED*PHIS, MRED*DFIS  = MRED*PHIS', DDFIS = MRED*PHIS'',

C

C     PHI , PHI', PHI'', AND PHIS , PHIS', PHIS'' 

C     APPEAR IN THE SCHRODINGER EQUATION DUE

C     TO THE Q**2-DEPENDENCE OF THE POTENTIALS (SEE PR.D17,EQ.36),

C     NOTE HOWEVER THAT WE ADAPTED THE DEFINITION OF FI TO THE

C     MULTI-CHANNEL CASE (SEE BELOW FOR THE DESCRIPTION) !!!!

C

C     NOTE THAT WE DID INCLUDE THE ASO-POTENTIALS. THEY ARE,

C     IN THE PRESENT MODEL, UNIMPORTANT TO FIT THE LOW ENERGY YN-DATA,

C     HOWEVER THEY ARE IMPORTANT IN HYPERNUCLEI AND NUCLEAR MATTER.     

C

C     LL = LAMBDA-LAMBDA MATRIX ELEMENT  )

C     LS = LAMBDA-SIGMA    ,,     ,,     )  I=1/2

C     SS = SIGMA -SIGMA    ,,     ,,     )

C     DR = SIGMA -SIGMA    ,,     ,,        I=3/2

C

C AD NBASE=2 :

C     THE POTENTIALS ON THE PARTICLE-BASIS ARE COMMUNICATED TO THE

C     CALLING PROGRAM

C  I) FOR NCHAN=2 AND 3 VIA :

C     COMMON/POTPRT/VPRT(12,3,3)        PRT=PARTICLE

C

C     HERE NOMENCLATURE :

C     VPRT(1,*,*) = CENTRAL POTENTIAL , VPRT(2,*,*) = SPIN-SPIN POTENTIAL

C     VPRT(3,*,*) = TENSOR     ,,     , VPRT(4,*,*) = SPIN-ORBIT   ,,

C     VPRT(5,*,*) = ASYMM. LS  ,,     , VPRT(6,*,*) = QUADRATIC SPIN-ORBIT

C     VPRT(7,*,*) = PHI               , VPRT(8,*,*) = PHI' ,

C     VPRT(9,*,*) = PHI'',

C     VPRT(10,*,*)= PHIS              , VPRT(11,*,*)= PHIS' ,

C     VPRT(12,*,*)= PHIS''.

C

C     NCHAN=2  LABELS CHANNELS :

C     LAMBDA-NEUTRON=1, SIGMA(0)-NEUTRON=2, SIGMA(-)-PROTON=3

C     NCHAN=3  LABELS CHANNELS :

C     LAMBDA-PROTON =1, SIGMA(+)-NEUTRON=2, SIGMA(0)-PROTON=3

C

C II) FOR NCHAN=1 (SIGMA(+)-PROTON CHANNEL) VIA

C     COMMON/POT/, NAMELY THROUGH THE POTENTIALS

C     VCDR,VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR .

C

C

C

C     NOTE THAT IN THE NSC/ESC-MODEL

C          1) FOR YN WE DO THE GREEN TRANSF. ON THE ISOSPIN BASIS

C          2) FOR YN AND ISPIN=1/2 THE GREEN TRANSFORMATION HAS

C             TO BE DONE NUMERICALLY (2-CHANNEL PROBLEM)

C

C

C END OUTPUT DESCRIPTION. *******************************************

C

C     UNITS :  XFM IN FM, X IN PIM**-1, USED PIM=138.041 MEV

C              VC,VSIG,VTEN,VSO,VSO2 IN MEV**+1

C              FI IN MEV**-1 , DFI IN MEV**0 , DDFI IN MEV**+1

C

C ******************************************************************

C  Parameters: Organization DEC.2007

C ******************************************************************

C

C   PAR( 1,I)= XS     G1     FD1    FV1   GS1    GA2    FA1    GSPAIR

C   PAR( 2,I)= XT     ALP    ALVD   ALVV  GS*    PSID   ALPA   GVPAIR

C   PAR( 3,I)= X1P    GETAP  GOM    FOM   GEPS   GPOM   FE1    FVPAIR

C   PAR( 4,I)= X3P27  PIONC  AM1RO  ARO   AMD    1.0    THA    GAPAIR

C   PAR( 5,I)= XHIGL  PION0  AM2RO  BRO   AM1SI  ASI    GT1    HAPAIR

C   PAR( 6,I)= PROTON ETA    AMOM   ELPHI AM2SI  BSI    GEFF   GPPAIR

C   PAR( 7,I)= NEUTRN AMX0   AMFI   PSIS1 AM1ST  1.0    FT1    HOPAIR

C   PAR( 8,I)= ALM27  ALMP1  ALMV1  PSIS8 ALMS1  AMA2   FEFF   GEPAIR

C   PAR( 9,I)= ALM8S  ALMP0  ALMV0  THS1  ALMS0  AMPOM  ALMAX  GPIET     

C   PAR(10,I)= ALM10  THPS   THV    THS2  AMEPS  THD    SONV   GPIETP

C   PAR(11,I)= ALM8A  THPE   THRO   THDE  GAMEP  AHYPC  SONPV  ALPAPR

C   PAR(12,I)= ALM10S APV    FDNP1  FDNN1 GEPS2  FPOMH  SONSC  ALSCPR

C   PAR(13,I)= ALM1   HFPI   HFD1   HFV1  ALS2   GPOMH  SONVPR ALVDPR

C   PAR(14,I)= ---    FCHPI  HALVD  HALVV GDEL2  AMPOMH SONPPR ALVVPR 

C   PAR(15,I)= RSCAL  HFETP  HGOM   HFOM  ALS    GPOPP  SONSPR GPIPOM



C   PAR(16,I)= FACYN  ALMKA  ALMKS  ALMKP AMSCK  AMKSS  FB1    GTENPR

C   PAR(17,I)= FACYY  FNNPI  ---    ---   AMFI51 FALS   ALFBX  FTENPR

C   PAR(18,I)= ---    FFA1   ---    ---   GPPS2  FDEL   FB9    GPSPR

C   PAR(19,I)= ---    ALFFX  GONP1  GONN1 FI51   FS*    SONVA  GPIROV

C   PAR(20,I)= ---    FFE1   GSNP1  GSNN1 UPOM   FEPS   ALTV   GPIOMV



C     HERE : PHYSICAL COUPLINGS, EXCEPT FOR

C            THE SU3-SINGLET COUPLINGS GPS1 AND FD1

C

C ******************************************************************

C

C     ALM27 = ALAM IRREP 27      , ALAM10 = ALM IRREP 10

C     ALM8S = ALAM IRREP 27+8S   , ALM8A = ALAM IRREP 10*+8A

C

C     PAR(7,1)= ALAM IS CURRENT FORM FACTOR MASS SET IN OBEPOT

C               EQUAL TO ALAM** OF THE PARTICULAR CHANNEL

C

C     PARAMETERS FOR MODEL D AND F :

C     PAR(1-3,1)=XS,XT,XP : HARDCORE PARAMETERS ( 0 IN NSC-MODEL )

C     PAR(4-6,1)=X3P27,X3P8,XHIGHL: HARDCORE PARAMETERS ( 0 IN NSC-MODEL

C

C     G1,G6,G9 : PION-,ETA-,ETA'-COUPLING CONSTANT

C     FD1,ALVD,FD9 : VECTOR MESON G-TYPE COUPLING PARAMETERS

C     FV1,FV6,FV9 : VECTOR MESON F-TYPE COUPLING CONSTANTS

C     GS1,GS6,GS9 : SCALAR MESON COUPLING CONSTANTS

C     GPOM,GA2 : (POMERON+F+F')-,A2-COUPLING CONSTANT

C     THPS,THV,THS : PSEUDOSCALAR-,VECTOR-,SCALAR-MESON MIXING ANGLES

C     ARO,AM1RO,BRO,AM2RO : BROAD RHO-MESON PARAMETERS (SEE P.R.D17)

C     ASI,AM1SI,BSI,AM2SI :  ,,   EPS- ,,      ,,,            ,,

C     AMD,AMSST : DELTA-,S(975)-MESON MASS

C     ALAM : FORMFACTOR MASS

C

C     ALMNN ALMLL ALMSS ALMLS ALMLK  AMKSS   ALMSK : F.F. PER VERTEX

C     IN NSC SET IN OBEPOT TO APPROPRIATE VALUES.

C

C     PIM = PION MASS

C

c *******************************************************************

C BEGIN MAIN PROGRAM ************************************************

C *******************************************************************

      SUBROUTINE HNPOT16(XFM,LINT,JSPIN,NCHAN,NBASE,NS)

C** § SUBROUTINE HNPOT16(X,LINT,JSPIN,NCHAN,NBASE,NS)

C *******************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      REAL*8 MPROT,MNEUT,MLAMB,MSIGP,MSIGN,MSIGM

      COMMON/PRMTRS/ PAR(20,8)

      COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2

      COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA    

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4)

      COMMON/FRMFAC/ALM(7)

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALAMK,ALMKS,ALMKAP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/ALLAX/ FA(11),FFA(11),FB(11),ALMAX                            

      COMMON/COUPL/F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .  G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .  FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .  FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .  GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .  GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB

     .             ,CORTPS,CORTV,CORTA,CORTB



      COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL,

     .           FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL,

     .           VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS,

     .           FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS,

     .           VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS,

     .           FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS,

     .           VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR,

     .           FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR

c*   .          ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN

      COMMON/POTPRT/VPRT(12,3,3)      ! PRT=PARTICLE

      COMMON/PIMAS/PIM0

C----------------------------------------------------------------------

      common/pmed/facmv,facms,facmvh,facmsh

C----------------------------------------------------------------------

      DIMENSION VI(12,4),BM(3,3),BMP(3,3)

      EQUIVALENCE (VI(1,1),VCLL)

      DIMENSION TRANS(3,3),TRAND(3,3)

      CHARACTER AMODEL(18)*9,SYS(3)*16,TYPV(12)*16              

      DATA SYS/'SIGMA(+)-PROTON','LAMBDA-NEUTRON','LAMBDA-PROTON'/

      DATA TYPV/'CENTRAL','SPIN-SPIN','TENSOR','SPIN-ORBIT',

     .          'ASYMM SPIN-ORBIT','QUADR SPIN-ORBIT',

     .          'PHIC-FUNCTION','DPHIC-FUNCTION','DDPHIC-FUNCTION',

     .          'PHIS-FUNCTION','DPHIS-FUNCTION','DDPHIS-FUNCTION'/



      DATA N2/6/,ICALL/0/,NCHNH/-10/,LINTH/-10/,JSPINH/-10/,BM/9*0.D0/

      DATA MPROT/938.27231D0/,MNEUT/939.56563D0/,MLAMB/1115.63D0/,

     .     MSIGP/1189.37D0/ ,MSIGN/1192.47D0/ ,MSIGM/1197.35D0/

c     CHARACTER * 4 INPS(4),INVCT(5),INSC(5),INDIF(4)

      DATA AMODEL/' MODEL-D ',' MODEL-F ',' NSC89   ',

     .            ' NSC97f  ',' NSC97e  ',

     .            ' ESC04A  ',' ESC04B  ',' ESC04C  ',' ESC04D  ',

     .            ' ESC06D  ',' ESC06Dp ',

     .            ' NILS06D1',' NILS06D3',

     .            ' NILS07D ',' NILS07Dp',

     .            ' ESC08a  ',' ESC08b  ',

     .            ' ESC08c  '/

C----------------------------------------------------------------------

      DATA XS/0.D0/,XT/0.D0/,X1P/0.D0/,X3P27/0.D0/,X3P8S/0.D0/,

     .     XHIGHL/0.D0/

C----------------------------------------------------------------------

C     EXACT FLAVOR-SYMMETRY NO=0/YES=1:

      DATA NSU3F/0/

c     DATA NSU3F/1/

C----------------------------------------------------------------------

C     INCLUSION NON-LOCAL TENSOR/SPIN-SPIN POTENTIALS:

      DATA CORSPS/1D0/,CORSV/0D0/,CORSA/0D0/,CORSB/1D0/,

     .     CORTPS/0D0/,CORTV/0D0/,CORTA/0D0/,CORTB/0D0/

C----------------------------------------------------------------------

      SAVE ICALL,NLOC,ICSB

C----------------------------------------------------------------------

      X = XFM*138.041D0/197.327053D0     ! FM -> PIM^{-1}

C----------------------------------------------------------------------

C     FIXED: 

      IMODEL=18

      IGREEN=0

C----------------------------------------------------------------------

      IF(NCHAN.EQ.1) ICSB= 0

      IF(NCHAN.EQ.2) ICSB=-1

      IF(NCHAN.EQ.3) ICSB=+1

      IF(NSU3F.EQ.1) ICSB= 0

C----------------------------------------------------------------------

C----------------------------------------------------------------------

C     NOTE: in YNOOM: CORRECTION TO PI-OM-PAIR only for imodel.gt.13!!

C----------------------------------------------------------------------

      IF(ICALL.GT.0.and.IMODEL.EQ.IMODL) GOTO 100



      IF(NS.NE.0) 

     .WRITE(*,333) IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS

  333 FORMAT(' HNPOT16:IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS=',

     .8(I2,2X))

C----------------------------------------------------------------------

c     write(*,*) 

c    .'HNPOT16:IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS=',

c    .IMODEL,NSU3F,LINT,JSPIN,NCHAN,NBASE,IGREEN,NS



      IMODL = IMODEL



C     Defining model parameters:

      CALL MODPARS(IMODEL)

C     SPECIAL SETTINGS:

      IF(IGRTST.EQ.0) IGREEN=0

      IF(NCHAN.EQ.1) IDAM=0

      IF(IMODEL.LE.4.OR.IMODEL.GE.10) IDAM=0      ! check this 



      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      WRITE(*,*) '======================================================

     .========'

      WRITE(N2,334) IMODEL,AMODEL(IMODEL),INRS,IRET,IDAM,IGERST,NSU3F,

     .IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,

     .ITPS,IPAIR,IPIBE,IPSBE,

     .IZPS,IZVC,IZSC,IZAX,IZTEN,

     .IPV,IGM,INA,IOFF,NADIA,IRET,IGREEN

  334 FORMAT(/,' ***** MODEL INFORMATION: IMODEL=',I2,

     .' MODEL=',A9,' *****',//,

     .' ***** VERSION: BBPROGS.MARIUS11.CSB *****',//,

     .' INRS =',I2,' IRET =',I2,' IDAM =',I2,

     .' IGERST=',I2,' NSU3F=',I2,//,

     .' IPSC =',I2,' IVCT =',I2,' ISCL =',I2,' IDIF  =',I2,

     .' IAXI =',I2,' ITEN =',I2,/,

     .' ITPS =',I2,' IPAIR=',I2,' IPIBE=',I2,' IPSBE =',I2,/,

     .' IZPS =',I2,' IZVC =',I2,' IZSC =',I2,' IZAX  =',I2,

     .' IZTEN=',I2,//,

     .' IPV  =',I2,' IGM  =',I2,' INA  =',I2,' IOFF  =',I2,

     .' NADIA=',I2,//,' *** IRET=',I2,' IGREEN=',I2,' ***',/)

      WRITE(*,*) '======================================================

     .========'

C ******************************************************************

      WRITE(N2,*)

      WRITE(N2,*) ' NON-LOCAL TENSOR-SPINSPIN PARAMETERS:'

      WRITE(N2,91) CORSPS,CORSV,CORSA,CORSB,COTPS,CORV,CORTA,CORTV

  91  FORMAT(' CORSPS=',F4.1,' CORSV=',F4.1, 

     .' CORSA=',F4.1,' CORSB=',F4.1,/,  

     .' CORTPS=',F4.1,' CORTV=',F4.1,' CORTA=',F4.1,' CORTB=',F4.1,

     .//,72('*'),//)                                                  

C ******************************************************************

      ENDIF

c-----------------------------------------------------------------------

C     SETTING THE MESON-PARAMETERS

c-----------------------------------------------------------------------

c     esc08-models:

c     if(imodel.eq.18) open(9,file='parbbsc.15dec2012')  ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.nophil.marius')  ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.ESC08c.best13')  ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.ESC08c.best13p3') ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.30nov2013')  ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.best14june') ! ESC08c 

c     if(imodel.eq.18) open(9,file='parbbsc.best14june.b') ! ESC08c 

cr    if(imodel.eq.18) open(9,file='parbbsc.best16')   ! ESC08c, april16

cr    see call escpar16 below



cy    WRITE(*,*) '------------------------------------------------------

cy   .--------'

cy    write(*,*) ' HNPOT16: PARAMETERS imod=18: parbbsc.best16'     

cy    WRITE(*,*) '------------------------------------------------------

cy   .--------'

c-----------------------------------------------------------------------



      IF(IGREEN.NE.0) THEN

      WRITE(*,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++

     .++++++++'

      WRITE(*,*) ' !!! WARNING: IGREEN=',IGREEN,

     .           ' GREEN TRANSFORMATION, OKAY???? '

      WRITE(*,*) '++++++++++++++++++++++++++++++++++++++++++++++++++++++

     .++++++++'

      ENDIF



      IMODL = IMODEL

      IF(IMODEL.LE.2) NLOC=0

      IF(IMODEL.GE.3) NLOC=1

      AKS(1) = 0.D0

      AKS(2) = 0.D0

      AKS(3) = 0.D0

      AM(1) = 938.2592D0

      PIM   = 138.041D0

      AMPI  = 138.041D0

      AME   = 548.8D0

      AMK   = 495.8D0

      BMK   = 453.4D0

      AMX   = 957.5D0

      AMFI  = 1019.5D0

      AMOM  = 783.9D0

      AMKS  = 892.6D0

      BMKS  = 869.1D0

      PIM0  = PIM

C-------------------------------------------------------------

      IF(NSU3F.EQ.1) THEN

      AGMO=DSQRT((2*AMK**2+PIM**2)/3D0)  ! GM-O M0 = 410 MeV

      AGMO= 400D0

      AMPI = AGMO

      AMK  = AGMO

      BMK  = AGMO

      AME  = AGMO

      AMX  = AGMO

      AGMOV=DSQRT((2*AMKS**2+AMRO**2)/3D0)  ! GM-O M0 = 885 MeV

      AGMOV= 800D0

      AMKS = AGMOV

      BMKS = AGMOV

      AMFI = AGMOV

      AMOM = AGMOV

      ENDIF

C-------------------------------------------------------------

c*    IF(NS.EQ.1) THEN

cy    WRITE(6,99)

cy    WRITE(6,599)

cy    WRITE(N2,10) AMODEL(IMODEL)

   10 FORMAT('0 THE PARAMETERS MODEL=',A9,/)

c*    ENDIF

C-------------------------------------------------------------

cr    THIS VERSION: PARAMETERS ARE INTERNAL VIA CALL ESCPAR16:

      CALL ESCPAR16(NS)

C-------------------------------------------------------------

cr    DO 21 I=1,20

cr    READ(9,*) (PAR(I,J),J=1,8)

cr    WRITE(6,22) I,(PAR(I,J),J=1,4)

cr    WRITE(6,22) I,(PAR(I,J),J=5,8)

cr 21 WRITE(6,*)

   21 continue

      REWIND 9

   22 FORMAT(' I=',I2,4(D15.7,2X))

cr    WRITE(6,99)

   99 FORMAT(72('-'))

C-------------------------------------------------------------

C

      IF(IMODEL.LE.2) THEN

      XS  =PAR(1,1)

      XT  =PAR(2,1)

      X1P =PAR(3,1)

      X3P27=PAR(4,1)

      X3P8S=PAR(5,1)

      XHIGHL=X3P27    

      ENDIF

C-------------------------------------------------------------

C

C     TWO POLE APPROXIMATION UNSTABLE MESONS

C

      ARO  =PAR(4,4)

      AM1RO=PAR(4,3)

      BRO  =PAR(5,4)

      AM2RO=PAR(5,3)



      IF(IGERST.EQ.0) THEN

      ASI  =PAR(5,6)

      AM1SI=PAR(5,5)

      BSI  =PAR(6,6)

      AM2SI=PAR(6,5)

      ENDIF

C     BRYAN AND GERSTEN TWO-POLE PARAMETRIZATION BROAD EPSILON:

      IF(IGERST.EQ.1) THEN

      CALL GERSTPAR

      PAR(5,6) = ASI

      PAR(5,5) = AM1SI

      PAR(6,6) = BSI

      PAR(6,5) = AM2SI

      ENDIF

      AMD  =PAR(4,5)

      AMSST=PAR(7,5)

c*    AMSCK=PAR(12,5)

      AMSCK=PAR(16,5)

C-------------------------------------------------------------

C     EXACT SU3-FLAVOR SYMMETRY:

      IF(NSU3F.EQ.1) THEN

      ARO = 1.D0

      BRO = 0.D0

      AM1RO = 800.D0

      AM2RO = 800.D0

      AMOM  = 800.D0

      AMFI  = 800.D0

      AMKS  = 800.D0

      BMKS  = 800.D0

      ASI = 1.D0

      BSI = 0.D0

      AM1SI = 800.D0

      AM2SI = 800.D0

      AMD   = 800.D0

      AMSST = 800.D0

      AMSCK = 800.D0

      ENDIF

C

C     DIFFRACTIVE MASSES

C

      AMA2 =PAR(8,6)

      AMPOM=PAR(9,6)

      AMF2 =AMPOM

c*    AMKSS=PAR(8,6)

      AMKSS=PAR(16,6)

      AHYPC = PAR(11,6)          

C ------------------------------------------------------------------*

C     NUCLEAR MEDIUM EFFECTS ON MESON MASSES: SE BELOW

C ------------------------------------------------------------------*

c     write(*,*) 'program at 1'



c     ICALL=1

100   IF(NCHNH.EQ.NCHAN.AND.LINTH.EQ.LINT.AND.JSPINH.EQ.JSPIN) GOTO 200

      NCHNH=NCHAN

      LINTH=LINT

      JSPINH=JSPIN

C *******************************************************************

C

C     FORM FACTOR MASSES :

C

C *******************************************************************

C     MODELS HC-D, HC-F:                     

      IF(IMODEL.LE.2) THEN

      ALAM = 10000.D0

c*    ALAM = 2000.D0

      ALM(1) = ALAM

      ALM1  = ALAM

      ALM27 = ALAM

      ALM8S = ALAM

      ALM8A = ALAM

      ALM10 = ALAM

      ALM10S= ALAM

      ALAMK = ALAM

      ALMKAP= ALAM

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,201) 

     .ALM1,ALM27,ALM8S,ALM10,ALM8A,ALM10S,ALMKAP

  201 FORMAT(/,' ALM1  =',F9.3,' ALM27 =',F9.3,' ALM8S =',F9.3,

     .       /,' ALM10 =',F9.3,' ALM8A =',F9.3,' ALM10S=',F9.3,

     .       /,' ALMKAP=',F9.1,//)

      ENDIF

C *******************************************************************

C     MODELS PRC40:                     

      IF(IMODEL.EQ.3) THEN

      ALM1 =PAR(8,1)

      ALM27=PAR(8,1)

      ALM8S=PAR(9,1)

      ALM10=PAR(10,1)

      ALM8A=PAR(11,1)

      ALM10S=PAR(12,1)

      IF(NCHAN.NE.1 .AND. NCHAN.NE.4) ALM10=ALM10S

      IUSPIN=JSPIN+LINT+1

      IF(MOD(IUSPIN,2).EQ.0) THEN

      ALAM1=ALM8A

      ALAM3=ALM10

      ENDIF

      IF(MOD(IUSPIN,2).EQ.1) THEN

      ALAM1=ALM8S

      ALAM3=ALM27

      ENDIF

      IF(ALAMK.EQ.0.D0) ALAMK=ALM27

      IF(ALMKS.EQ.0.D0) ALMKS=ALM27

      IF(ALMKAP.EQ.0.D0) ALMKAP=ALM27

C     THE FOLLOWING GOOD FOR ALL LINT'S :

C     IF(NCHAN.EQ.1.AND.MOD(IUSPIN,2).EQ.0) ALAM=ALM10

C     IF(NCHAN.EQ.1.AND.MOD(IUSPIN,2).EQ.1) ALAM=ALM27

C     THE FOLLOWING ONLY GOOD FOR LINT=0 :

C     IF(NCHAN.EQ.1.AND.JSPIN.EQ.1) ALAM=ALM10

C     IF(NCHAN.EQ.1.AND.JSPIN.EQ.0) ALAM=ALM27

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,202) 

     .ALM1,ALM27,ALM8S,ALM10,ALM8A,ALM10S

  202 FORMAT(/,' ALM1  =',F9.3,' ALM27 =',F9.3,' ALM8S =',F9.3,

     .       /,' ALM10 =',F9.3,' ALM8A =',F9.3,' ALM10S=',F9.3,//)

C

C     FOR THIS VERSION OF THE SOFTCORE OBE-MODEL:

C

      DO 5 I=1,5

      ALM(I)=ALAM1

      IF(I.GT.2) GOTO 5

      ALM(I+6)=ALAM3

   5  CONTINUE

      ENDIF

C *******************************************************************

C     SOFT-CORE 97-OBE-MODELs, and ESC-MODEL:

      IF(IMODEL.GE.4) THEN

      ALMP8 = PAR(8,2)

      ALMV8 = PAR(8,3)

      ALMS8 = PAR(8,5)

      ALMP1 = PAR(9,2)

      ALMV1 = PAR(9,3)

      ALMS1 = PAR(9,5)

      ALAMK = PAR(16,2)

      ALMKS = PAR(16,3)

      ALMKAP= PAR(16,4)

      ALMAX = PAR(9,7)

      IF(ALAMK.EQ.0.D0) ALAMK=ALMP8

      IF(ALMKS.EQ.0.D0) ALMKS=ALMV8

      IF(ALMKAP.EQ.0.D0) ALMKAP=ALMS8

      IF(ALMAX.EQ.0.D0) ALMAX=ALMP8

      ENDIF

C -------------------------------------------------------------------

C     MEDIUM EFFECTS FORM FACTORS:

C     not yet implemented in this program!!

C -------------------------------------------------------------------

C     EXACT SU3-FLAVOR SYMMETRY:

      IF(NSU3F.EQ.1) THEN

      ALMP1 = ALMP8

      ALMV1 = ALMV8

      ALMS1 = ALMS8

      ALMKA = ALMP8

      ALMKS = ALMV8

      ALMKP = ALMS8

      ENDIF

C-------------------------------------------------------------

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,204) ALMP8,ALMV8,ALMS8,ALMP1,

     .       ALMV1,ALMS1,ALAMK,ALMKS,ALMKAP,ALMAX

  204 FORMAT(/,' ALMP8 =',F9.3,' ALMV8 =',F9.3,' ALMS8 =',F9.3,

     .       /,' ALMP1 =',F9.3,' ALMV1 =',F9.3,' ALMS1 =',F9.3,

     .       /,' ALAMK =',F9.3,' ALMKS =',F9.3,' ALMKAP=',F9.1,

     .       /,' ALMAX =',F9.3,//)

cc    ENDIF

C *******************************************************************

      IF(NSU3F.EQ.1) THEN

      MPROT = MLAMB

      MNEUT = MLAMB

      MSIGP = MLAMB

      MSIGM = MLAMB

      MSIGN = MLAMB

      ENDIF

C -------------------------------------------------------------------

c*    ICALL=1

      GOTO(1,2,3),NCHAN

   1  AMY(1)=MSIGP

      AMY(2)=MSIGP

      AMY(3)=MSIGP

      AM(1) =MPROT

      AM(2) =MPROT

      AM(3) =MPROT

      GOTO 4

   2  AMY(1)=MLAMB

      AMY(2)=MSIGN

      AMY(3)=MSIGM

      AM(1) =MNEUT

      AM(2) =MNEUT

      AM(3) =MPROT

      GOTO 4

   3  AMY(1)=MLAMB

      AMY(2)=MSIGP

      AMY(3)=MSIGN

      AM(1) =MPROT

      AM(2) =MNEUT

      AM(3) =MPROT

   4  CONTINUE



C     MEDIUM EFFECTS ON THE BARYON MASSES:

C     Yamamoto: M*(Lambda) < M(Lambda), M*(Sigma) > M(Sigma) !??

      FSTAR = 1D0  

      IF(FSTAR.NE.1D0) THEN

c*    FSTAR = 0.6D0     ! Ter Haar

      DO 13 KK=1,3

      AM(KK) = FSTAR * AM(KK)

  13  AMY(KK) = FSTAR * AMY(KK)

      WRITE(6,*) ' HNPOT16: MEDIUM EFFECT MASSES FSTAR=',FSTAR

      ENDIF



      DO 12 I=1,3

      REDM(I)=AM(I)*AMY(I)/(AM(I)+AMY(I))

  12  TEM(I) =2*REDM(I)/(PIM**2)

      REDMM = (REDM(1)+REDM(2)+REDM(3))/3.D0

CC

CC    adaption to multi-channel S.E. as described in comments above :

CC

      AMLN=DSQRT(AMY(1)*AM(1))

      AMSN=DSQRT(AMY(2)*AM(1))

      AMH =0.5D0*(AMY(1)+AMY(2))

      AMSS=0.5D0*(AMY(2)+AMY(3))

c**   AMLS=DSQRT(AMH*AM(1))

      AMNN=(AM(1)+AM(2)+AM(3))/3.D0

      AMLS=DSQRT(AMH*AMNN) 

C

 200  CALL WRLDCOP2(NCHAN,LINT,JSPIN,ICSB,NS)

c     write(*,*) 'program at 2'



      MAN = MOD(LINT+JSPIN+1,2)

      IF(MAN.EQ.1) P=+1.D0

      IF(MAN.EQ.0) P=-1.D0

c**   P = (-1.D0)**(LINT+JSPIN)

C

C     NUCLEAR MEDIUM EFFECTS ON MESON MASSES: SEE ABOVE

c*    FACMV = 1D0

c*    FACMS = 1D0

c*    facmv = 0.85d0

c**   CALL PMEDIUM(FACMV,FACMS)

C

      IF(IGREEN.EQ.0) 

     .CALL VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)

      IF(IGREEN.EQ.1) 

     .CALL POTGR(X,PIM,P,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)

C

C     RESTORATION MESON MASSES:                

c*    FACMVI= 1d0/FACMV

c*    FACMSI= 1d0/FACMS

c*    CALL PMEDIUM(FACMVI,FACMSI)

C

c     write(*,*) 'program at 3'

      IF(NBASE.EQ.1) GOTO 1000

C

      IF(NS.GE.1.AND.ICALL.EQ.0)  PRINT 14,SYS(NCHAN),JSPIN,LINT

  14  FORMAT(//,1X,A13,'-POTENTIALS ON THE PARTICLE-BASIS : JSPIN=',I2,

     .            ' LINT=',I2,//)

      IF(NCHAN.EQ.1) THEN

      IF(ICALL.EQ.0.and.NS.NE.0) PRINT 15

  15  FORMAT(1X,' : SEE POTENTIALS ON THE ISOSPIN BASIS')

      GOTO 1000

      ENDIF



C ---------------------------------------------------------------------

C     WRITING THE POTENTIALS:

C     NOMENCLATURE :

C     VPRT(1,*,*) = CENTRAL POTENTIAL , VPRT(2,*,*) = SPIN-SPIN POTENTIAL

C     VPRT(3,*,*) = TENSOR     ,,     , VPRT(4,*,*) = SPIN-ORBIT   ,,

C     VPRT(5,*,*) = ASYMM. LS  ,,     , VPRT(6,*,*) = QUADRATIC SPIN-ORBIT,

C     VPRT(7,*,*) = PHI               , VPRT(8,*,*) = PHI' ,

C     VPRT(9,*,*) = PHI''             , VPRT(10,*,*)= PHIS    

C     VPRT(11,*,*)= PHIS'             , VPRT(12,*,*)= PHIS''.

C

      DO 301 I=1,12

      BM(1,1)=VI(I,1)

      BM(2,2)=VI(I,2)

      BM(1,2)=VI(I,3)

      BM(3,3)=VI(I,4)

      BM(2,1)=BM(1,2)

      bm(2,3)=0D0

      bm(3,2)=0D0

      IF(NCHAN.EQ.2) CALL TRANLN(TRANS,TRAND)

      IF(NCHAN.EQ.3) CALL TRANLP(TRANS,TRAND)

C     TRANSFORMATION FROM ISOSPIN-BASE TO PARTICLE-BASE:

      DO 302 I1=1,3

      DO 302 J1=1,3

      II=I1

      JJ=J1

      IF(I1.EQ.3) II=2

      IF(J1.EQ.3) JJ=2

  302 BMP (I1,J1)=TRANS(I1,J1)*BM(II,JJ) + TRAND(I1,J1)*BM(3,3)

      DO 303 II=1,3

      DO 303 JJ=1,3

 303  VPRT(I,II,JJ)=BMP(II,JJ)

C

      IF(NS.GE.3) THEN

       IF(I.EQ.1) THEN

      WRITE(N2,98)

      WRITE(N2,*) ' POTENTIALS ON THE PARTICLE BASIS:'

       ENDIF

      WRITE(N2,332) X,TYPV(I),(VPRT(I,1,JJ),JJ=1,3),

     .             (VPRT(I,2,JJ),JJ=1,3),(VPRT(I,3,JJ),JJ=1,3)

      IF(I.EQ.12) WRITE(N2,98)

      ENDIF

 301  CONTINUE

 332  FORMAT(/,1X,' X=',F10.4,' PIM-1 ',2X,A16,2X,3(D12.5,3X),/,

     .      41X,3(D12.5,3X),/,41X,3(D12.5,3X))

  98  FORMAT(85('='))

C ---------------------------------------------------------------------

C

1000  ICALL=1

c     write(*,*) 'program at 4'

C

C ------------------------------------------------------------------

  599 FORMAT(72('*')/,'C'/,

     a'C     ESC-PARAMETERS :  PARAMETER-MATRIX'/,'C'/,

     b'C   PAR( 1,I)= XS     G1     FD1    FV1    GS1    GA2    FA1    

     .GSPAIR',/,

     c'C   PAR( 2,I)= XT     ALP    ALVD   ALVV   GS*    PSID   ALPA   

     .GVPAIR',/,

     d'C   PAR( 3,I)= X1P    GETAP  GOM    FOM    GEPS   GPOM   FE1    

     .FVPAIR',/,

     e'C   PAR( 4,I)= X3P27  PIONC  AM1RO  ARO    AMD    1.0    THA    

     .GPIRO1',/,

     f'C   PAR( 5,I)= XHIGL  PION0  AM2RO  BRO    AM1SI  ASI    GT1    

     .GPIRO0',/,

     g'C   PAR( 6,I)= PROTON ETA    AMOM   ELPHI  AM2SI  BSI    GEFF   

     .GPISI ',/,

     h'C   PAR( 7,I)= NEUTRN AMX0   AMFI   PSIS1  AM1ST  1.0    FT1    

     .HOPAIR',/,

     i'C   PAR( 8,I)= ALM27  ALMP1  ALMV1  PSIS8  ALMS1  AMA2   FEFF   

     .GSISI ',/,

     j'C   PAR( 9,I)= ALM8S  ALMP0  ALMV0  THS1   ALMS0  AMPOM  ALMAX  

     .GPIET',/,  

     k'C   PAR(10,I)= ALM10  THPS   THV    THS2   AMEPS  THD    SONV   

     .GPIETP',/,

     l'C   PAR(11,I)= ALM8A  THPE   THRO   THDE   GAMEP  AHYPC  SONPV  

     .ALPAPR',/,     

     m'C   PAR(12,I)= FACNA  APV    FDNP1  FDNN1  GEPS2  FPOMH  SONSC  

     .ALSCPR',/,

     n'C   PAR(13,I)= ANG51  HFPS1  HFD1   HFV1   ALS2   GPOMH  SONVPR 

     .ALVDPR',/,

     o'C   PAR(14,I)= SON{1} FCHPI  HALVD  HALVV  GDEL2  AMPOMH SONPPR 

     .ALVVPR',/, 

     p'C   PAR(15,I)= RSCAL  HFETP  HGOM   HFOM   ALS    GPOPP  SONSPR 

     .GPIPOM',/,                   

     q'C   PAR(16,I)= FACYN  ALMKA  ALMKS  ALMKP  AMSCK  AMKSS  FB1    

     .GTENPR',/,

     r'C   PAR(17,I)= GAMSCK FNNPI  ASCK   BSCK   AMFI51 FALS   ALFBX  

     .FTENPR',/,

     s'C   PAR(18,I)= AM1SCK FFA1   ---    AM2SCK GPPS2  FDEL   FB9    

     .GPSPR ',/,

     t'C   PAR(19,I)= ALPBPR ALFFX  GONP1  GONN1  FI51   FS*    SONVA  

     .GPIROV',/,

     u'C   PAR(20,I)= AKMAX  FFE1   GSNP1  GSNN1  UPOM   FEPS   ---    

     .GPIOMV',/,'C',/,72('-'),/ )

C-----------------------------------------------------------------

      RETURN

      END

C ***************************************************************

      SUBROUTINE MODPARS(IMODEL)        

C ***************************************************************

C     iopt   = 4:   onebos and twomes parameters set in ynmain

C     imodel = 1:   Hard-core OBE-model-D (PRD15)     ! YN-model

C     imodel = 2:   Hard-core OBE-model-F (PRD20)     ! YN-model



C     imodel = 3:   Soft-core OBE-model   (PRC40)     ! YN-model

C     imodel = 4:   Soft-core OBE-model   NSC97f      ! YN-model

C     imodel = 5:   Soft-core OBE-model   NSC97e      ! YN-model



C     imodel = 6:   Soft-core ESC-model   ESC04A      !TRUE NN+YN-model

C     imodel = 7:   Soft-core ESC-model   ESC04B      !TRUE NN+YN-model

C     imodel = 8:   Soft-core ESC-model   ESC04C      !TRUE NN+YN-model

C     imodel = 9:   Soft-core ESC-model   ESC04D      !TRUE NN+YN-model



C     imodel =10:   Soft-core ESC-model   ESC06D      !TRUE NN+YN-model

C     imodel =11:   Soft-core ESC-model   ESC06D      !TRUE NN+YN-model

C     imodel =12:   Soft-core ESC-model   NILS06D1    !TRUE NN+YN-model

C     imodel =13:   Soft-core ESC-model   NILS06D3    !TRUE NN+YN-model



C     imodel =14:   Soft-core ESC-model   NILS07D     !TRUE NN+YN-model

C     imodel =15:   Soft-core ESC-model   NILS07Dp    !TRUE NN+YN-model



C     imodel =16:   Soft-core ESC-model   ESC04D.07odd!TRUE NN+YN-model



C     imodel =17:   Soft-core ESC-model   ESC08A      !TRUE NN+YN-model

C     imodel =18:   Soft-core ESC-model   ESC08B      !TRUE NN+YN-model



C     imodel =18:   Soft-core ESC-model   ESC08C      !TRUE NN+YN-model

C ***************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ONEBOS/IOBE(7)   

      COMMON/TWOMES/ITME(4)                  

      COMMON/ZEROS/IZERO(5)

      COMMON/PAROOM/APV,ISPEC(5)                

      DIMENSION INFO(24,18)    

C     in row 'imodel' INFO contains the model-parameters:

C     INFO: ipsc,ivct,iscl,idif,iaxi,iten,

C           ipair,itps,ipibe,ipsbe,

C           ipv,igm,ina,ioff,nadia, inrs,idam,igerst,igrtst

C           izps,izvc,izsc,izax,izten 

      DATA INFO/1,1,1,0,0,0, 0,0,0,0, 0,0,0,0,0, 1,0,0,0, 0,0,0,0,0,  ! 1

     .          1,1,1,0,0,0, 0,0,0,0, 1,1,0,0,0, 1,0,0,0, 0,0,0,0,0,  ! 2

     .          1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0,  ! 3

     .          1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0,  ! 4

     .          1,1,1,1,0,0, 0,0,0,0, 1,0,0,0,0, 1,0,0,1, 0,0,0,0,0,  ! 5

     .          1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0,  ! 6

     .          1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0,  ! 7

     .          1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0,  ! 8

     .          1,1,1,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,0,  ! 9

     .          2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0,  !10

     .          2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0,  !11

     .          2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1,  !12

     .          2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1,  !13

     .          2,2,2,1,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1,  !14

     .          2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1,  !15

     .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1,  !16

     .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1,  !17

     .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !18



cc   .          0,0,0,3,0,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !18

c    .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !18



c**  .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !18

ccc  .          1,1,1,3,2,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !17

ccc  .          0,0,2,0,0,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/  !15test

c**  .          2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1,  !14 



cccc .          2,2,2,1,1,0, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,1,1,1/  !15

c**  .          0,0,0,0,0,1, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/  !12



c**  .          0,0,0,0,2,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/  !12

c**  .          2,2,2,1,1,0, 0,0,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,0,  !10

c**  .          2,2,2,1,1,1, 1,1,0,0, 1,0,1,1,0, 1,0,1,1, 0,0,2,1,1/  !12



c*    IF(IOPT.NE.4.AND.IOPT.NE.5.AND.IOPT.NE.6) THEN

      DO 1 KK=1,6

    1 IOBE (KK) = INFO(KK   ,IMODEL)

      DO 2 KK=1,4

    2 ITME (KK) = INFO(KK+6 ,IMODEL)

c*    ENDIF

      DO 3 KK=1,5

    3 ISPEC(KK) = INFO(KK+10,IMODEL)

      INRS      = INFO(16   ,IMODEL)

      IDAM      = INFO(17   ,IMODEL)

      IGERST    = INFO(18   ,IMODEL)

      IGRTST    = INFO(19   ,IMODEL)

C     ZEROS IN FORM FACTOR:

      DO 4 KK=1,5

    4 IZERO(KK) = INFO(KK+19,IMODEL)

      RETURN

      END

C *******************************************************************

      SUBROUTINE PMEDIUM(FACMV,FACMS)                             

C *******************************************************************

C     POSSIBILITY INCLUSION NUCLEAR-MEDIUM EFFECTS ON MESON MASSES

C     LITERATURE: A.DF. JACKSON, Ann.Rev.Nucl.Sci. 33: 105-141 (1983)

C     MSIGMA(RHO_N) = MEPS*[ 1 - ALF*RHO_N + BET*RHO_N^5/3]

C -------------------------------------------------------------------

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4)

      DATA RHON/0.18D0/, ALFN/0.5D0/

c*    DATA FACMV/1D0/,FACMS/1D0/

      DATA MEDCALL/0/



      IF(MEDCALL.GT.0) RETURN 

cc    IF(MEDIUM.EQ.1) THEN



C  MEDIUM FACTORS:

c*    facmv = 0.85d0

c*    facms = 0.85d0

cc    FACMV = 1.D0-ALFN*RHON

cc    FACMS = 1.D0-ALFN*RHON



C     CHANGE IN VECTOR MESON MASSES:

      AM1RO = AM1RO*FACMV

      AM2RO = AM2RO*FACMV

      AMKS  = AMKS *FACMV

      BMKS  = BMKS *FACMV

      AMOM  = AMOM *FACMV

      AMFI  = AMFI *FACMV

C     HEAVY VECTOR MASSES:

      DO 11 KK=1,4

   11 HAMVC(KK) = HAMVC(KK)*FACMV

C     CHANGE IN SCALAR MESON MASSES:

      AMD   = AMD  *FACMS

      AMSCK = AMSCK*FACMS

      AM1SI = AM1SI*FACMS

      AM2SI = AM2SI*FACMS

      AMSST = AMSST*FACMS

      AM2ST = AM2ST*FACMS

C     HEAVY SCALAR MASSES:

      DO 12 KK=1,4

   12 HAMSC(KK) = HAMSC(KK)*FACMS

cc    ENDIF

c*    MEDCALL = MEDCALL + 1

cc    WRITE(6,*) ' IN PMEDIUM: FACMV=',FACMV,

cc   .' FACMS=',FACMS,' ** MEDCALL=',MEDCALL



      RETURN

      END

C **********************************************************************

      subroutine escpar16(ns)

C **********************************************************************

      implicit real*8(a-h,o-z)

      common/prmtrs/par(20,8)

      dimension paresc16(8,20)

      character potname(1)*8

      data potname/'ESC08c16'/

C **********************************************************************

C     ESC-parameters :

C **********************************************************************

C   PAR( 1,I)= XS     F1     FD1    FV1    GDEL   GA2    FA1    GSPAIR

C   PAR( 2,I)= XT     ALP    ALVD   ALVV   GS*    PSID   ALPA   GVPAIR

C   PAR( 3,I)= X1P    FX0    GOM    FOM    GEPS   GPOM   FE1    FVPAIR

C   PAR( 4,I)= X3P27  PIONC  AM1RO  ARO    AMD    1.0    THA    GPIRO1 

C   PAR( 5,I)= CSLE   PION0  AM2RO  BRO    AM1SI  ASI    GT1    GPIRO0



C   PAR( 6,I)= PROTON ETA    AMOM   ELPHI  AM2SI  BSI    GEFF   GPISI 

C   PAR( 7,I)= NEUTRN AMX0   AMFI   PSIS1  AM1ST  1.0    FT1    HOPAIR

C   PAR( 8,I)= ALM27  ALMP8  ALMV8  PSIS8  ALMS8  AMA2   FEFF   GSISI  

C   PAR( 9,I)= ALM8S  ALMP1  ALMV1  THS2   ALMS1  AMPOM  ALMAX  GPIET

C   PAR(10,I)= ALM10  THPS   THV    THS1   AMEPS  THD    SONV   GPIETP



C   PAR(11,I)= ALM8A  THPE   THRO   THDE   GAMEP  AHYPC  SONPV  ALPAPR

C   PAR(12,I)= FACNA  APV    FDNP1  FDPP1  GEPS2  FHPOM  SONSC  ALSCPR

C   PAR(13,I)=  ---   HFPS1  HFD1   HFV1   ALS2   GHPOM  SONVPR ALVDPR

C   PAR(14,I)= SON(1) FCHPI  HALVD  HALVV  ---    AMPOMH SONPPR ALVVPR

C   PAR(15,I)= RSCAL  HFETP  HGOMD  HFOMV  ALS    GPOPPH SONSPR GPIPOM



C   PAR(16,I)= FACYN  ALMKA  ALMKS  ALMKP  AMSCK  AMKSSH FB1    GTENPR

C   PAR(17,I)= GAMSCK FNNPI  ASCK   BSCK   AMFI51 FALS   ALFBX  FTENPR

C   PAR(18,I)= AM1SCK FFA1   GOMETA AM2SCK GPPS2  FDEL   FB9    GPSPR 

C   PAR(19,I)=  ---   ALFFX  GONP1  GONN1  FI51   FS*    SONVA  GPIROV

C   PAR(20,I)= AKMAX  FFE1   GSNP1  GSNN1  UPOM   FEPS   ---    GPIOMV

C **********************************************************************

C     Soft-core model ESC08c, parbbsc.best16                      

      DATA PARESC16/

     A .000000000000000D+00, .268739630566707D+00, .634276647640713D+00,

     2 .383071425426434D+01,

     3 .635117390573632D+00,-.294576790000000D-10,-.816770798498021D+00,

     4-.380908010000000D-10,

     B .000000000000000D+00, .365000000000000D+00, .100000000000000D+01,

     2 .472498073766573D+00,

     3-.838936300000000D+00, .000000000000000D+00, .329581455726579D+00,

     4 .341310362965063D-01,

     C .000000000000000D+00, .251888683720332D+00, .336914849996356D+01,

     2-.768271131972376D+00,

     3 .440499499151728D+01, .332674289587370D+01,-.768739327855443D+00,

     4-.249337865026942D+00,

     D .000000000000000D+00, .139570000000000D+03, .647435800000000D+03,

     2 .190675900000000D+00,

     3 .962000000000000D+03, .100000000000000D+01, .500000000000000D+02,

     4 .743829264708528D+00,

     E .500000000000000D-01, .134960000000000D+03, .898174100000000D+03,

     2 .796489500000000D+00,

     3 .496397963027437D+03, .217807195795809D+00, .000000000000000D+00,

     4 .000000000000000D+00,

     F .938259300000000D+03, .548800050000000D+03, .783899900000000D+03,

     2-.279545880000000D+02,

     3 .136559411299000D+04, .782192804204191D+00, .000000000000000D+00,

     4-.438383378828360D-01,

     G .939552700000000D+03, .957500000000000D+03, .101950000000000D+04,

     2 .000000000000000D+00,

     3 .993000000000000D+03, .100000000000000D+01, .000000000000000D+00,

     4-.817710798346652D-02,

     H .964524200000000D+03, .102941770301647D+04, .688404457838911D+03,

     2 .000000000000000D+00,

     3 .893525915831090D+03, .307809600000000D+03, .000000000000000D+00,

     4 .482785590000000D-10,

     I .100000000000000D+01, .102941770301647D+04, .771322309873320D+03,

     2 .352600000000000D+02,

     3 .113609933385847D+04, .223122299428729D+03, .107656083400411D+04,

     4-.173520396031822D+00,

     J .300000000000000D+01,-.130000000000000D+02, .387000000000000D+02,

     2 .352600000000000D+02,

     3 .760000000000000D+03, .000000000000000D+00, .100000000000000D+01,

     4 .000000000000000D+00,

     K .000000000000000D+00, .570000000000000D+00,-.285000000000000D+01,

     2 .171000000000000D+01,

     3 .640000000000000D+03, .000000000000000D+00, .100000000000000D+01,

     4 .400000000000000D+00,

     L .000000000000000D+00, .100000000000000D+01, .584139959279144D+00,

     2 .632954838029737D+00,

     3 .000000000000000D+00,-.415563334435476D+01, .100000000000000D+01,

     4 .100000000000000D+01,

     M .000000000000000D+00, .000000000000000D+00, .000000000000000D+00,

     2 .000000000000000D+00,

     3 .000000000000000D+00, .435747052275295D+01, .100000000000000D+01,

     4 .100000000000000D+01,

     N .000000000000000D+00, .000000000000000D+00, .000000000000000D+00,

     a .000000000000000D+00,

     b .000000000000000D+00, .270480960439385D+03, .100000000000000D+01,

     c .400000000000000D+00,

     O .100000000000000D+01, .000000000000000D+00, .000000000000000D+00,

     a .000000000000000D+00,

     b .100000000000000D+01, .460450260000000D+01, .100000000000000D+01,

     c .456285030000000D-10,

     P .100000000000000D+01, .000000000000000D+00, .000000000000000D+00,

     a .000000000000000D+00,

     b .816000000000000D+03, .000000000000000D+00,-.197451123564073D+00,

     c .000000000000000D+00,

     Q .000000000000000D+00, .000000000000000D+00, .100000000000000D+01,

     a .000000000000000D+00,

     b .000000000000000D+00, .100000000000000D+01, .400000000000000D+00,

     c .000000000000000D+00,

     R .816000000000000D+03, .258491030080958D+01, .000000000000000D+00,

     2 .145373457988075D+04,

     3 .000000000000000D+00, .000000000000000D+00,-.758754557938523D-01,

     4 .000000000000000D+00,

     S .400000000000000D+00, .000000000000000D+00, .000000000000000D+00,

     2 .000000000000000D+00,

     3 .297000000000000D+00, .000000000000000D+00, .100000000000000D+01,

     4 .000000000000000D+00,

     T .000000000000000D+00,-.544806138335060D+00, .000000000000000D+00,

     2 .000000000000000D+00,

     3 .939000000000000D+03, .000000000000000D+00, .000000000000000D+00,

     4 .000000000000000D+00/

C **********************************************************************

      save



      do 1 i=1,20

      do 1 j=1,8

        par(i,j) = paresc16(j,i)

    1 continue

      if(ns.ge.1) then

        write(6,599)

        write(6,2) potname(1)    

    2   format(/,' ESCPAR16 -> PARAMETERS: ',A8,/)

        do 3 i=1,20

          write(6,4) i,(par(i,j),j=1,4),(par(i,j),j=5,8)

    3   continue

    4   format(1x,'i=',i2,4(d15.7,2x),/,5x,4(d15.7,2x))

      endif

C ------------------------------------------------------------------

  599 FORMAT(72('*')/,'C'/,

     a'C     ESC-PARAMETERS :  PARAMETER-MATRIX'/,'C'/,

     b'C   PAR( 1,I)= XS     G1     FD1    FV1    GS1    GA2    FA1    

     .GSPAIR',/,

     c'C   PAR( 2,I)= XT     ALP    ALVD   ALVV   GS*    PSID   ALPA   

     .GVPAIR',/,

     d'C   PAR( 3,I)= X1P    GETAP  GOM    FOM    GEPS   GPOM   FE1    

     .FVPAIR',/,

     e'C   PAR( 4,I)= X3P27  PIONC  AM1RO  ARO    AMD    1.0    THA    

     .GPIRO1',/,

     f'C   PAR( 5,I)= XHIGL  PION0  AM2RO  BRO    AM1SI  ASI    GT1    

     .GPIRO0',/,

     g'C   PAR( 6,I)= PROTON ETA    AMOM   ELPHI  AM2SI  BSI    GEFF   

     .GPISI ',/,

     h'C   PAR( 7,I)= NEUTRN AMX0   AMFI   PSIS1  AM1ST  1.0    FT1    

     .HOPAIR',/,

     i'C   PAR( 8,I)= ALM27  ALMP1  ALMV1  PSIS8  ALMS1  AMA2   FEFF   

     .GSISI ',/,

     j'C   PAR( 9,I)= ALM8S  ALMP0  ALMV0  THS1   ALMS0  AMPOM  ALMAX  

     .GPIET',/,  

     k'C   PAR(10,I)= ALM10  THPS   THV    THS2   AMEPS  THD    SONV   

     .GPIETP',/,

     l'C   PAR(11,I)= ALM8A  THPE   THRO   THDE   GAMEP  AHYPC  SONPV  

     .ALPAPR',/,     

     m'C   PAR(12,I)= FACNA  APV    FDNP1  FDNN1  GEPS2  FPOMH  SONSC  

     .ALSCPR',/,

     n'C   PAR(13,I)= ANG51  HFPS1  HFD1   HFV1   ALS2   GPOMH  SONVPR 

     .ALVDPR',/,

     o'C   PAR(14,I)= SON{1} FCHPI  HALVD  HALVV  GDEL2  AMPOMH SONPPR 

     .ALVVPR',/, 

     p'C   PAR(15,I)= RSCAL  HFETP  HGOM   HFOM   ALS    GPOPP  SONSPR 

     .GPIPOM',/,                   

     q'C   PAR(16,I)= FACYN  ALMKA  ALMKS  ALMKP  AMSCK  AMKSS  FB1    

     .GTENPR',/,

     r'C   PAR(17,I)= GAMSCK FNNPI  ASCK   BSCK   AMFI51 FALS   ALFBX  

     .FTENPR',/,

     s'C   PAR(18,I)= AM1SCK FFA1   ---    AM2SCK GPPS2  FDEL   FB9    

     .GPSPR ',/,

     t'C   PAR(19,I)= ALPBPR ALFFX  GONP1  GONN1  FI51   FS*    SONVA  

     .GPIROV',/,

     u'C   PAR(20,I)= AKMAX  FFE1   GSNP1  GSNN1  UPOM   FEPS   ---    

     .GPIOMV',/,'C',/,72('-'),/ )

C-----------------------------------------------------------------

      return

      end

C ***************************************************************

C ***************************************************************

*     BLOCK DATA YNBLK

C ***************************************************************

c     COMMON/INMES/INPS,INVCT,INSC,INDIF,INAX,INTEN

c     CHARACTER*4 INPS(4) /'YES','YES','YES','YES'/

c     CHARACTER*4 INVCT(4)/'YES','YES','YES','YES'/

c     CHARACTER*4 INSC(4) /'YES','YES','YES','YES'/

c     CHARACTER*4 INDIF(4)/'YES','YES','YES','YES'/

c     CHARACTER*4 INAX(4) /'NO ','NO ','NO ','NO '/

C     CHARACTER*4 INPS(4) /'NO ','NO ','NO ','NO '/

C     CHARACTER*4 INVCT(4)/'NO ','NO ','NO ','NO '/

C     CHARACTER*4 INSC(4) /'NO ','NO ','NO ','NO '/

C     CHARACTER*4 INDIF(4)/'NO ','NO ','NO ','NO '/

C     CHARACTER*4 INTEN(4)/'NO ','NO ','NO ','NO '/

c     END



C ***************************************************************

      SUBROUTINE WRLDCOP2(NCHAN,LINT,JSPIN,ICSB,NS)

C ******************************************************

C     version september 2000:   version with 2 scalar nonets

C     

C     ioptsc = 2:

C     1) su3-nonet : eps(760), del(962), S*(993), kappa(900)

C     2) su3-nonet : f0(1370), a0(1450), f0(1580), k**(1430)



C     note: modern notation: eps9760)=f0(760), del(962)=a0(9800, S*(993)=f0(975)



C     used notations: f0(1370)=eps2, a0(1450)=del2, f091580)=S2, K**(1430)=kappa2

C ******************************************************************

C  Parameters: Organization DEC.2004

C ******************************************************************

C

C     OBE-PARAMETERS ETC.:

C

C   PAR( 1,I)= XS     G1     FD1    FV1   GS1    GA2    FA1    GSPAIR

C   PAR( 2,I)= XT     ALP    ALVD   ALVV  GS*    PSID   ALPA   GVPAIR

C   PAR( 3,I)= X1P    GETAP  GOM    FOM   GEPS   GPOM   FE1    FVPAIR

C   PAR( 4,I)= X3P27  PIONC  AM1RO  ARO   AMD    1.0    THA    GAPAIR

C   PAR( 5,I)= XHIGL  PION0  AM2RO  BRO   AM1SI  ASI    GT1    HAPAIR

C   PAR( 6,I)= PROTON ETA    AMOM   ELPHI AM2SI  BSI    GEFF   GPPAIR

C   PAR( 7,I)= NEUTRN AMX0   AMFI   PSIS1 AM1ST  1.0    FT1    HOPAIR

C   PAR( 8,I)= ALM27  ALMP1  ALMV1  PSIS8 ALMS1  AMA2   FEFF   GEPAIR

C   PAR( 9,I)= ALM8S  ALMP0  ALMV0  THS1  ALMS0  AMPOM  ALMAX  GPIET     

C   PAR(10,I)= ALM10  THPS   THV    THS2  AMEPS  THD    SONV   GPIETP

C   PAR(11,I)= ALM8A  THPE   THRO   THDE  GAMEP  AHYPC  SONPV  ALPAPR

C   PAR(12,I)= ALM10S APV    FDNP1  FDNN1 GEPS2  FPOMH  SONSC  ALSCPR

C   PAR(13,I)= ALM1   HFPI   HFD1   HFV1  ALS2   GPOMH  SONVPR ALVDPR

C   PAR(14,I)= ---    FCHPI  HALVD  HALVV GDEL2  AMPOMH SONPPR ALVVPR 

C   PAR(15,I)= RSCAL  HFETP  HGOM   HFOM  ALS    GPOPP  SONSPR GPIPOM



C   PAR(16,I)= FACYN  ALMKA  ALMKS  ALMKP AMSCK  AMKSS  FB1    GTENPR

C   PAR(17,I)= FACYY  ---    ---    ---   ---    FALS   ALFBX  FTENPR

C   PAR(18,I)= ---    FFA1   ---    ---   GPPS2  FDEL   FB9    GPSPR

C   PAR(19,I)= ---    ALFFX  ---    ---   FI51   FS*    SONVA  GPIROV

C   PAR(20,I)= AKMAX  FFE1   ---    ---   UPOM   FEPS   ---    GPIOMV



C     HERE : PHYSICAL COUPLINGS, EXCEPT FOR

C            THE SU3-SINGLET COUPLINGS GPS1 AND FD1

C

C ******************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2

      COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE

      COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA     

      COMMON/INMES/INPS,INVCT,INSC,INDIF,INAX,INTEN

      CHARACTER*4 INPS(4),INVCT(4),INSC(4),INDIF(4),INAX(4),INTEN(4)

      COMMON/PRMTRS/PAR(20,8)

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALAMK,ALMKS,ALMKAP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/ALLAX/ FA(11),FFA(11),FB(11),ALMAX                            

c     COMMON/MIXING/THPS,THV,THS,THD

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPAX

      COMMON/ALLSC2/ELPHI,PSIS1,PSIS8,THSD1,THSD2,

     .              GSA(11),GSB(11),IOPTSC

      COMMON/ALLSC3/FS

      COMMON/HVY/HFPS(11),GT(11),FT(11),HFD(11),HFV(11)



      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GAPAIR,HAPAIR,GPPAIR,HOPAIR

     .            ,GEPAIR,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR



      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .  G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .  FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .  FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .  GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .  GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),FS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1)),

     .(GS1,GS(1)),(FS1,FS(1)),(GD1,GD(1))                  

C

      DATA SR2/1.4142136D0/,SR3/1.732051D0/,                   

     ,     AMPRO/938.2796D0/,N2/6/,IEXDB/0/,IEXD/0/,

     .     ALVVH/0.D0/,INIT/0/,ICALL/0/,I3P0/1/

C

C

C  F AND G  PSEUDOSCALAR

C  FD       VECTOR  DIRECT        = ELECTRIC

C  FV       VECTOR  DERIVATIVE    = MAGNETIC

C  USED INDEXING OF THE COUPLINGS :

C   1 =NNP       NNRO       NNDEL       NNA2

C   2 =SSP       SSRO       SSDEL       SSA2

C   3 =LSP       LSRO       LSDEL       LSA2

C   4 =LNK       LNKS       LNKAP       LNK**

C   5 =SNK       SNKS       SNKAP       SNK**

C   6 =NNE       NNOM       NNEPS       NNPOM

C   7 =LLE       LLOM       LLEPS       LLPOM

C   8 =SSE       SSOM       SSEPS       SSPOM

C   9 =NNX       NNFI       NNS*        NNF2

C   10=LLX       LLFI       LLS*        LLF2

C   11=SSX       SSFI       SSS*        SSF2

C

C  NNX STANDS FOR NNETA' ETC.

C  F AND G  PSEUDOSCALAR

C  FD       VECTOR  DIRECT COUPLING

C  FV       VECTOR  DERIVATIVE COUPLING

C

c     fstar = 0.6d0

c     if(icall.eq.0) ampro = ampro*fstar

c*    APV   = PAR(15,2)

      APV   = PAR(12,2)

c     write(*,*) 'WARNING: APV = 0 !!!!!!!!!!!!!'

c     apv   = 0d0

      SONV  = PAR(10,7)

      SONPV = PAR(11,7)

      SONSC = PAR(12,7)

      IF(SONPV.EQ.0.D0) SONPV=1.D0  

      IF(SONV.EQ.0.D0) SONV=SONPV

      IF(SONSC.EQ.0.D0) SONSC=SONPV

      IF(I3P0.EQ.1) THEN

c*    SONPV= SONV

      SONSC= SONV

      SONVA= SONV

      ENDIF

      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      WRITE(*,*) ' NOTICE: *************************************'

      WRITE(*,*) ' I3P0=',I3P0,' SONVP.NE.SONV=SONSC=SONVA'

c**   WRITE(*,*) ' I3P0=',I3P0,' SONVP.EQ.SONV=SONSC=SONVA'

      WRITE(*,*) ' NOTICE: *************************************'

      ENDIF

C

C     SETTING VALUE EXCHANGE-OPERATOR P

C

      MAN=MOD(LINT+JSPIN+1,2)

      P=1.D0

      IF(MAN.EQ.0) P=-P    

C

  12  PI=DACOS(-1.D0)

      CONV=PI/180.D0

      RSCAL=DSQRT(PAR(15,1))

      IF(IMODEL.LE.2) THEN

      G1  =PAR(1,2)*RSCAL

      G9  =PAR(3,2)*RSCAL

      ENDIF

      IF(IMODEL.GE.3) THEN

      F1  =PAR(1,2)*RSCAL

      F9  =PAR(3,2)*RSCAL

      ENDIF

      ALP =PAR(2,2)

      THPS=PAR(10,2)

      FD1 =PAR(1,3)*RSCAL

      ALVD=PAR(2,3)

      GOM =PAR(3,3)*RSCAL

      THV =PAR(10,3)

      FV1 =PAR(1,4)*RSCAL

      ALVV=PAR(2,4)

      FOM =PAR(3,4)*RSCAL

      GDEL=PAR(1,5)*RSCAL

      GSST=PAR(2,5)*RSCAL

      GEPS=PAR(3,5)*RSCAL

      THS =PAR(10,4)

C

*     in this version only the 1-nonet model implemented:

C     two-nonet model parameters:

      ELPHI = PAR(6,4)

      PSIS1 = PAR(7,4)

      PSIS8 = PAR(8,4)

      THS1  = PAR(9,4)

      THS2  = PAR(10,4)



      GA2  =PAR(1,6)*RSCAL

      GPOM =PAR(3,6)*RSCAL

      PSID =PAR(2,6)

      THD  =PAR(10,6)

      AHYPC= PAR(11,6)



      FA1  = PAR(1,7)*RSCAL

      FE1  = PAR(3,7)*RSCAL

      THA  = PAR(4,7)

      ALPAX= PAR(2,7)

      IF(ALPAX.EQ.0.D0) ALPAX =ALP



      SON  = PAR(11,7)

C     EXACT FLAVOR-SYMMETRY:

      IF(NSU3F.EQ.1) THEN

      AHYPC= 0.D0

      THPS = 0.D0

      THV  = 0.D0

      THS  = 0.D0

      THD  = 0.D0

      THA  = 0.D0

      ENDIF          

C

      THPSD=THPS

      THVD =THV

      THSD =THS

      THDD =THD

      THAD =THA

      PSIDD=PSID

      THPS=THPS*CONV

      THV =THV *CONV

      THS =THS *CONV

      THD =THD *CONV

      THA =THA *CONV

      PSID=PSID*CONV

      ELPHI = ELPHI*CONV

      PSIS1 = PSIS1*CONV

      PSIS8 = PSIS8*CONV

      THS1  = THS1 *CONV

      THS2  = THS2 *CONV

C

C     SU3 FOR 1) PV-COUPLINGS PS-SCALAR MESONS

C             2) PAULI-COUPLINGS VECTOR MESONS

C*********************************************************************

C

C  PSEUDOSCALAR COUPLING CONSTANTS

C

C*********************************************************************

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

      IF(IMODEL.LE.2) THEN

      F1 =PIM*G1/(2.*AM(1))

      GX0= G9

      FX0=PIM*G9/(2.*AM(1))

      ENDIF

      IF(IMODEL.GT.2) THEN

      G1=2*AM(1)*F1/PIM

      FX0 = F9

      GX0=2*AM(1)*F9/PIM

      ENDIF

      COST=DCOS(THPS)

      SINT=DSIN(THPS)

      F9 = (FX0-SINT*(4*ALP-1.D0)*F1/SR3)/COST

      G9 = (GX0-SINT*(4*ALP-1.D0)*G1/SR3)/COST

      IF(IPV.EQ.0) CALL SU3(G,ALP)

      IF(IPV.EQ.1) CALL SU3(F,ALP)



c     IF(NS.GE.1) WRITE(N2,450) G9,F9,ALP,THPSD,IPV,APV,SONPV

      IF(ICALL.EQ.0.and.NS.NE.0) 

     .WRITE(N2,450) G9,F9,ALP,THPSD,IPV,APV,SONPV

 450  FORMAT(' PS-SCALAR SINGLET COUPLING G9= ',F12.6,' F9=',

     .F12.6,/,24X,' ALP=',F7.3,' THETA =',F12.6,'  IPV=',I2,

     ./,24X,' APV=',F7.3,' SONPV= ',F7.2,/)



C     SU(3)-SYMMETRY BREAKING:

c     IF(SONPV.NE.1.D0) THEN              

c     IF(IPV.EQ.0) CALL SU3SB(G,SONPV,1)

c     IF(IPV.EQ.1) CALL SU3SB(F,SONPV,1)

c     ENDIF

      IF(SONPV.NE.1D0) CALL SU3SB03(G,ALP,SONPV)

      IF(SONPV.NE.1D0) CALL SU3SB03(F,ALP,SONPV)

C

C     ETA - X0 MIXING

C

C     MIND DIFFERENCE IN POSITION WITH VECTOR AND SCALAR MESONS

C

 700  IF(IPV.EQ.1) THEN      

      DO 701 JO=6,8

      JS=JO+3

      WOV=F(JO)

      WSV=F(JS)

      F(JS)= COST*WSV+SINT*WOV

  701 F(JO)=-SINT*WSV+COST*WOV

      G1 =2*AM(1)*F1/PIM

      G2 =2*AMY(2)*F2/PIM

      G3 =2*AMH*F3/PIM

      G4 =2*AMLN*F4/PIM

      G5 =2*AMSN*F5/PIM

      G6 =2*AM(1)*F6/PIM

      G7 =2*AMY(1)*F7/PIM

      G8 =2*AMY(2)*F8/PIM

      G9 =2*AM(1)*F9/PIM

      G10=2*AMY(1)*F10/PIM

      G11=2*AMY(3)*F11/PIM

      ENDIF

      IF(IPV.EQ.0) THEN      

      DO 702 JO=6,8

      JS=JO+3

      WOV=G(JO)

      WSV=G(JS)

      G(JS)= COST*WSV+SINT*WOV

  702 G(JO)=-SINT*WSV+COST*WOV

      F1 =G1*PIM/(2*AM(1))       

      F2 =G2*PIM/(2*AMY(2))       

      F3 =G3*PIM/(2*AMH)       

      F4 =G4*PIM/(2*AMLN)       

      F5 =G5*PIM/(2*AMSN)       

      F6 =G6*PIM/(2*AM(1))        

      F7 =G7*PIM/(2*AMY(1))       

      F8 =G8*PIM/(2*AMY(2))       

      F9 =G9*PIM/(2*AM(1))       

      F10=G10*PIM/(2*AMY(1))        

      F11=G11*PIM/(2*AMY(3))        

      ENDIF

C

C     USED IN OBE-PROGRAMS (SCSP ETC.) TO INCLUDE MASS FACTORS IN

C     POTS: (OLD WAY OF HELDER!, HAS GIVEN CONFUSION IN THE PAST!)

c     F2=PIM*G2/(2.*AMY(2))

c     F3=PIM*G3/(2.*AMH)

c     F4=AMK*G4/(2.*AMLN)

c     F5=AMK*G5/(2.*AMSN)

c     F6=AME*G6/(2.0*AM(1))

c     F7=AME*G7/(2.*AMY(1))

c     F8=AME*G8/(2.*AMY(2))

c     F9=AMX*G9/(2.0*AM(1))

c     F10=AMX*G10/(2.0*AMY(1))

c     F11=AMX*G11/(2.0*AMY(3))

C

C  !! IN THIS VERSION: WE INCLUDE THESE IN ROUTINE PSSCAL!!



C  SELECTION PSEUDO-SCALAR CONTRIBUTIONS

      CALL SELECT(F,INPS)

      CALL SELECT(G,INPS)

C*********************************************************************

C

C  COUPLING CONSTANTS FOR  VECTOR MESON POTENTIALS

C

C*********************************************************************

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

      IF(NCHAN.EQ.1.AND.PAR(20,7).NE.0D0) FD1=PAR(20,7)

      FD(9)=GOM

      FV(9)=FOM

      COST=DCOS(THV)

      SINT=DSIN(THV)

      IF(IGM.EQ.0) THEN

      FD9 = (GOM-SINT*(4*ALVD-1.D0)*FD1/SR3)/COST

      FV9 = (FOM-SINT*(4*ALVV-1.D0)*FV1/SR3)/COST

      ENDIF

      IF(IGM.EQ.1) THEN

      FD9 = (GOM-SINT*(4*ALVD-1.D0)*FD1/SR3)/COST

      FV9 = (GOM+FOM-SINT*(4*ALVV-1.D0)*(FD1+FV1)/SR3)/COST

      ENDIF

      CALL SU3(FD,ALVD)

      CALL SU3(FV,ALVV)

c     IF(NS.GE.1) WRITE(N2,550) FD9,FV9,ALVD,ALVV,THVD,IGM

      IF(ICALL.EQ.0.and.NS.NE.0) 

     .WRITE(N2,550) FD9,FV9,ALVD,ALVV,THVD,IGM,INRS,SONV

 550  FORMAT(' VECTOR SINGLET COUPLINGS FD9= ',F12.6,' FV9=',

     .F12.6,/,24X,' ALVD=',F12.6,' ALVV=',F12.6,' THETA=',F12.6,

     ./,24X,' IGM=',I2,' INRS=',I2,' SONV=',F7.2,//)



C     SU(3)-SYMMETRY BREAKING:

c     IF(SONV.NE.1.D0) CALL SU3SB(FD,SONV,2)

c     IF(SONV.NE.1.D0) CALL SU3SB(FV,SONV,2)

      IF(SONPV.NE.1D0) CALL SU3SB03(FD,ALVD,SONV)

      IF(SONPV.NE.1D0) CALL SU3SB03(FV,ALVV,SONV)

      ALVVH=ALVV

      INIT=1

      DO 5 JO=6,8

      JS=JO+3

      WOV=FV(JO)

      WOD=FD(JO)

      WSV=FV(JS)

      WSD=FD(JS)

      FV(JO)= COST*WSV+SINT*WOV

      FD(JO)= COST*WSD+SINT*WOD

      FV(JS)=-SINT*WSV+COST*WOV

      FD(JS)=-SINT*WSD+COST*WOD

    5 CONTINUE

      IF (IGM.EQ.0) GO TO 711

      DO 712 I=1,11

  712 FV(I)=FV(I)-FD(I)

  711 CONTINUE



C  SELECTION VECTOR MESON CONTRIBUTIONS

      CALL SELECT(FD,INVCT)

      CALL SELECT(FV,INVCT)

C*********************************************************************

C

C     SCALAR COUPLING CONSTANTS

C

C*********************************************************************

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

  501 FORMAT(72('-'))

C     PRESERVATION INPUT NN-COUPLINGS:

      GDELLD = GDEL

      GEPSLD = GEPS

      GSSTLD = GSST

      IF(ISCL.EQ.1) IOPTSC=1

      IF(ISCL.EQ.2) IOPTSC=2



      GDEL2 = PAR(14,5)*RSCAL

      GEPS2 = PAR(12,5)*RSCAL

      GSST2 = 0.D0



C     SEPARATION TWO NONETS: DEL(962) AND DEL2(1450) NN-COUPLINGS:

c     GDELI = GDEL

c     GDELI2= 0.D0

c     PSIS8D= PSIS8/CONV

c     CALL CNSTR97(PSIS8D,GDELI,GDELI2,GDEL,GDEL2,2)        



C     REDEFINITION EPS(760) AND GEPS(1370) NN-COUPLINGS:

c     GEPSI = GEPS 

c     GEPS2I= GEPS2

c     ELPHI2= PSIS1/CONV

c     CALL CNSTR97(ELPHI2,GEPSI,GEPS2I,GEPS,GEPS2,5)



C     REDEFINITION EPS(760) AND S(993) NN-COUPLINGS:

      GEPSI = GEPS

      GSSTI = GSST

      ELPHID= ELPHI/CONV

      CALL CNSTR97(ELPHID,GEPSI,GSSTI,GEPS,GSST,1)



C     REDEFINITION EPS(1370) AND S(1580) NN-COUPLINGS:

c     GEPSI = GEPS2

c     GSSTI = GSST2

c     ELPHI2= PSIS1/CONV

c     CALL CNSTR97(ELPHI2,GEPSI,GSSTI,GEPS2,GSST2,3)

C---------------------------------------------------------------------

C     FIRST SCALAR NONET:

      GS1=GDEL

      COST=DCOS(THS)

      SINT=DSIN(THS)

C**   SU3-assignments 'bare' mesons:

C     warning: check consistency with SCALAR !!

C**   S* similar to PHI(1020):

      GS9 = COST*GEPS-SINT*GSST

      GS6 = SINT*GEPS+COST*GSST



      ALS = PAR(15,5)

C     ABANDOING CONSTRAINT: ALS=ALS(THS1):

      IF(PAR(15,5).NE.0.D0) THEN

      GS(9)= (GEPS-SINT*(4*ALS-1.D0)*GS(1)/SR3)/COST

      GSST = -SINT*GS(9)+COST*(4*ALS-1.D0)*GS(1)/SR3

      ENDIF

      IF(ALS.EQ.0.D0.AND.GS1.NE.0.D0) 

     .ALS = 0.25D0*(SR3*GS6/GS1+1.D0)

      IF(ALS.EQ.0.AND.DABS(GS1).LT.1.D-06) ALS = 0.25D0



      CALL SU3(GS,ALS)



C     SU(3)-SYMMETRY BREAKING:

c     IF(SONSC.NE.1.D0) CALL SU3SB(GS,SONSC,3)

      IF(SONSC.NE.1D0) CALL SU3SB03(GS,ALS,SONSC)



C----------------------------------------------------------------

C     DERIVATIVE COUPLINGS:

      FALS = PAR(17,6)

      IF(FALS.EQ.0D0) FALS=ALS

      FS(1)= PAR(18,6)*RSCAL

      FSST = PAR(19,6)*RSCAL

      FEPS = PAR(20,6)*RSCAL

      FS9 =COST*FEPS-SINT*FSST                 

      FS6 =SINT*FEPS+COST*FSST                 

      CALL SU3(FS,FALS)

      IF(SONSC.NE.1.D0) CALL SU3SB03(FS,FALS,SONSC)

C----------------------------------------------------------------



      THSD =THS/CONV     



      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      WRITE(N2,500) IOPTSC,GS9,GS6,GDEL,GEPS,GSST,ALS,THSD,SONSC

     .             ,FS9,FS6,FS1,FEPS,FSST,FALS

 500  FORMAT(' 1rst SCALAR NONET SU3{1}:  IOPTSC=',I2,' GS9 =',F9.5,

     .' GS6 =',F9.5,/,22X,' GDEL=',F9.5, 

     .' GEPS=',F9.5,' GSST=',F9.5,/,22X,' ALS =',F9.3,' THS =',F9.3,

     .' SONSC=',F6.2,//,

     .' 1rst DERIVATIVE COUPLING :',11X,' FS9 =',F9.5,

     .' FS6 =',F9.5,/,22X,' GDEL=',F9.5, 

     .' FEPS=',F9.5,' FSST=',F9.5,' FALS=',F9.3,/)               

c      WRITE(N2,511) GEPS,GEPLL,GEPSS   

c511  FORMAT(' SCALAR SINGLET SU3{1}: GEPS =',F9.5,

c    .' GEPLL=',F9.5,' GEPSS=',F9.5,/)

      IF(PAR(13,1).NE.0.D0) WRITE(N2,521)

 521  FORMAT(25X,' ALS-THS CONSTRAINT ABANDNED',/)

      ENDIF

      DO 55 JO=6,8

      JS=JO+3

      WOS=GS(JO)

      WSS=GS(JO+3)

      GS(JO)= COST*WSS+SINT*WOS

      GS(JS)=-SINT*WSS+COST*WOS

      WOS=FS(JO)

      WSS=FS(JO+3)

      FS(JO)= COST*WSS+SINT*WOS

   55 FS(JS)=-SINT*WSS+COST*WOS



C     SU3-NONET COUPLINGS STORED IN GSB(KK):

      DO 56 KK=1,11

   56 GSB(KK) = GS(KK)

C     RESTORATION INPUT NN-COUPLINGS:

      GDEL = GDELLD

      GEPS = GEPSLD

      GSST = GSSTLD

C ------------------------------------------------------------------

C     PPNP, Vol.12: DOVER AND GAL NUMBERS:

c     IF(ICALL.EQ.0.and.NS.NE.0) THEN

c     WRITE(6,531) 

c 531 FORMAT(/,72('-'),/,

c    .' DOVER AND GAL NUMBERS (PPNP, VOL.12), EQN.(2.40):')

c     RLNLS = (2D0/3d0)*(GS(7)/GS(6))*(1D0+(FD(7)/GS(7))*(FD(6)/GS(6))*

c    .(3D0+4*FV(7)/FD(7)))/(1D0+(FD(6)/GS(6))**2*(3D0+4*FV(6)/FD(6)))

c     RSNLS = (2D0/3d0)*(GS(8)/GS(6))*(1D0+(FD(8)/GS(8))*(FD(6)/GS(6))*

c    .(3D0+4*FV(8)/FD(8)))/(1D0+(FD(6)/GS(6))**2*(3D0+4*FV(6)/FD(6)))

c     WRITE(6,532) RLNLS,RSNLS                        

c 532 FORMAT(' LN: V_SO(LN)/V_SO(NN)=',F4.2,' SN: V_SO(SN)/V_SO(NN)=',

c    .F6.2)

c     WRITE(6,501)

c     ENDIF

C ------------------------------------------------------------------

C     SECOND SCALAR NONET:

      GSA(1)=GDEL2 

      ALS2 = PAR(13,5)

      IF(ALS2.EQ.0.D0) ALS2 = ALS

      THS2 = PAR(9,4)*CONV

      IF(THS2.EQ.0.D0) THS2 = THS

      THSD2 = THS2/CONV



      COST=DCOS(THS2)

      SINT=DSIN(THS2)



C**   SU3-assignments 'bare' mesons:

C     warning: check consistency with SCALAR !!

C**   S* similar to PHI(1020):

c     new july 2006:

      GSA(9) = (GEPS2-SINT*(4*ALS2-1.D0)*GSA(1)/SR3)/COST

      GSST2  = -SINT*GSA(9)+COST*(4*ALS2-1.D0)*GSA(1)/SR3 



      GSA(9) = COST*GEPS2-SINT*GSST2

      GSA(6) = SINT*GEPS2+COST*GSST2



      CALL SU3(GSA,ALS2)



      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      THSD1 = THS1/CONV

      WRITE(N2,511) IOPTSC,GSA(9),GEPS2,ALS2,THSD1          

 511  FORMAT(' 2nd SCALAR NONET SU3{1}: IOPTSC=',I2,' GS9= ',F9.5,

     .' GEPS2=',F9.5,/,22X,' ALS2=',F9.3,' THS1=',F9.3)                   

      ENDIF                 



      DO 57 JO=6,8

      JS=JO+3

      WOS=GSA(JO)

      WSS=GSA(JS)

      GSA(JO)= COST*WSS+SINT*WOS

   57 GSA(JS)=-SINT*WSS+COST*WOS



C  SELECTION SCALAR MESON CONTRIBUTIONS

      CALL SELECT(GSA,INSC)

C---------------------------------------------------------------------

      IF(ICALL.EQ.0.and.NS.NE.0)

     .WRITE(N2,512) IGERST,PAR(10,5),PAR(11,5),ASI,AM1SI,BSI,AM2SI

 512  FORMAT(/,72('-'),/,' TREATMENT BROAD EPSILON: IGERST=',I2,

     .' AMEPS=',F9.3,' GAMEP=',F9.3,//,2X,' ASI=',F9.5,' AM1SI=',F12.5,

     .' BSI=',F9.5,' AM2SI=',F12.5,/)



C*********************************************************************

C

C     POMERON-TYPE OF COUPLINGS

C

C*********************************************************************

C     VERSION SEPTEMBER 2004

C*********************************************************************

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

      IF(GA2.EQ.0D0) THEN

      PSID = 0D0

      DO 113 KK=1,11

  113 GDA(KK) = 0D0

      ENDIF

      GPOM1 = GPOM*DCOS(PSID)

      GPOMP = GPOM*DSIN(PSID)



      GD(1) = 0D0

      GD(9) = GPOM1

      CALL SU3(GD,ALVD)

      PSIDD=PSID/CONV

C-------------------------------------------------------------------

C     ODDERON PARAMETERS:

      GPOMH = PAR(13,6)

      FPOMH = PAR(12,6)

      AMPOMH= PAR(14,6)

C-------------------------------------------------------------------

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,400) GPOM,GPOM1,PSIDD          

     .,GPOMH,FPOMH,AMPOMH

 400  FORMAT(' POMERON SINGLET COUPLING GPOM = ',F9.5,

     ,' GPOM1 =',F9.5,' PSID=',F9.3,/,

     .' NOTICE: FLAVOR DEPENDENCE!! ',

     .' GPOMH=',F9.5,' FPOMH=',F9.5,' AMPOMH=',F9.3,/)

C-------------------------------------------------------------------

c     flavor dependent couplings:

      if(ahypc.ne.0d0) then

c     gd(10) = gd(10)*amy(1)/am(1)

c     gd(11) = gd(11)*amy(2)/am(1)

cc    gd(10) = gd(10)*am(1)/amy(1)

cc    gd(11) = gd(11)*am(2)/amy(1)

      gd(10) = gd(10)*(1d0+ahypc*(amy(1)/am(1)-1d0))

      gd(11) = gd(11)*(1d0+ahypc*(amy(2)/am(1)-1d0))

      endif



      IF(GA2.NE.0D0) THEN

      GDA(1) = GA2

      ALD=ALVD

      SOND = SONV

      THD =THV

      THDD=THD/CONV

      SINT=DSIN(THD)

      COST=DCOS(THD)

      GDA(9) = (GPOMP-SINT*(4*ALD-1D0)*GDA(1)/SR3)/COST 

      IF(ICALL.EQ.0.and.NS.NE.0) 

     .WRITE(N2,401) GDA(1),GDA(9),ALD,THDD,PSIDD,AHYPC

 401  FORMAT(' DIFFRACTIVE NONET GDA1 = ',F9.5,' GDA9=',F9.5,

     .' ALPHA =',F9.3,/,24X,' THETA =',F12.6,' PSID=',F10.4,

     .' AHYPC=',F10.4,/)

      CALL SU3(GDA,ALD)

      IF(SOND.NE.1D0) CALL SU3SB03(GDA,ALD,SOND)



      DO 65 JO=6,8

      JS=JO+3

      WOD=GDA(JO)

      WSD=GDA(JS)

      GDA(JO)= COST*WSD+SINT*WOD

   65 GDA(JS)=-SINT*WSD+COST*WOD

      ENDIF

C     FLAVOR INDEPENDENCE : MASS-FACTORS

c     IF(AHYPC.EQ.0.D0) GOTO 64

c     GD2=GD2*AMPRO/AMSS

c     GD3=GD3*AMPRO/DSQRT(AMSS*AMY(1))

c     GD4=GD4*AMPRO/DSQRT(AMLN*AM(1) )

c     GD5=GD5*AMPRO/AMLS

c     GD7=GD7*AMPRO/AMY(1)

c     GD8=GD8*AMPRO/AMSS

c     GD10=GD10*AMPRO/AMY(1)

c     GD11=GD11*AMPRO/AMSS

c  64 CONTINUE

C---------------------------------------------------------------------

C     VERSION JULY 2007:     

C---------------------------------------------------------------------

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,403) PAR(14,6),PAR(13,6)      

 403  FORMAT(' HARD-POMERON SINGLET AMPOMH = ',F9.5,' GPOMH=',F9.5,/)

C---------------------------------------------------------------------



C  SELECTION DIFFRACTIVE CONTRIBUTIONS

      CALL SELECT(GD,INDIF)

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

C*********************************************************************

C

C     AXIAL COUPLING CONSTANTS

C

C*********************************************************************

      IF(IAXI.EQ.0) THEN

      FA1   = 0D0

      FE1   = 0D0

      ENDIF

      FA(1) = FA1     

      ALMAX = PAR(9,7)

      COST  = DCOS(THA)

      SINT  = DSIN(THA)

      FA(9) = (FE1-SINT*(4*ALPAX-1.D0)*FA1/SR3)/COST

      CALL SU3(FA,ALPAX)

      IF(SONVA.NE.1D0) CALL SU3SB03(FA,ALPAX,SONVA)

      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      THAD  = THA/CONV

      WRITE(N2,514) FA(1),FA(9),ALPAX,THAD,ALMAX     

 514  FORMAT(' AXIAL NONET SU3{1}: FA1  =',F9.5,' FA9=',F9.5,

     ./,20X,' ALPAX=',F9.3,' THA=',F9.3,' ALMAX=',F10.3)                   

      ENDIF                 

      DO 75 JO=6,8

      JS=JO+3

      WOS=FA(JO)

      WSS=FA(JS)

      FA(JO)= COST*WSS+SINT*WOS

   75 FA(JS)=-SINT*WSS+COST*WOS



C  SELECTION AXIAL MESON CONTRIBUTIONS

      CALL SELECT(FA,INAX)

C*********************************************************************

C     AXIAL DERIVATIVE COUPLING CONSTANTS

C

      FFA(1)= PAR(18,2)

      FFE1  = PAR(20,2)

      ALFFX = PAR(19,2)

      IF(ALFFX.EQ.0D0) ALFFX=ALPAX

      COST  = DCOS(THA)

      SINT  = DSIN(THA)

      FFA(9) = (FFE1-SINT*(4*ALFFX-1.D0)*FFA(1)/SR3)/COST

      CALL SU3(FFA,ALFFX)

      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      THAD  = THA/CONV

      WRITE(N2,803) FFA(1),FFA(9),ALFFX,THAD     

 803  FORMAT(' AXIAL NONET SU3{1}: FFA1  =',F9.5,' FFA9=',F9.5,

     ./,22X,' ALFFX=',F9.3,' THA=',F9.3)                   

      ENDIF                 

      DO 89 JO=6,8

      JS=JO+3

      WOS=FFA(JO)

      WSS=FFA(JS)

      FFA(JO)= COST*WSS+SINT*WOS

   89 FFA(JS)=-SINT*WSS+COST*WOS

C  SELECTION AXIAL MESON CONTRIBUTIONS

      CALL SELECT(FFA,INAX)

C*********************************************************************

      IF(IAXI.EQ.0.OR.IAXI.EQ.1) THEN

      FB(1) = 0D0

      FB9   = 0D0

      ENDIF

      IF(IAXI.NE.0.AND.IEXDB.EQ.0) THEN

      FB(1) = PAR(16,7)

      FB9   = PAR(18,7)

      ENDIF

      IF(IAXI.NE.0.AND.IEXDB.EQ.1) THEN

      SRB = 10D0*AMPRO**2

      FEXD = 1D0/DSQRT(SRB/AMPRO**2)

      FB(1) = FEXD* F1*2*AMPRO/PIM  *RSCAL

      FB9   = FEXD* FX0*2*AMPRO/PIM  *RSCAL

      ENDIF

      ALFBX = PAR(17,7)

      IF(ALFBX.EQ.0D0) ALFBX = ALP

c     THB = THPS

      THB = PAR(4,7)*CONV

      THB = 35.260D0*CONV

      COST  = DCOS(THB)

      SINT  = DSIN(THB)

      FB(9) = (FB9-SINT*(4*ALFBX-1.D0)*FB(1)/SR3)/COST

      CALL SU3(FB,ALFBX)

      IF(SONPV.NE.1D0) CALL SU3SB03(FB,ALFBX,SONVP)

      THBD  = THB/CONV

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,516) FB(1),FB(9),ALFBX,THBD  

 516  FORMAT(' B-AXIAL NONET SU3{1}: FB1  =',F9.5,' FB9=',F9.5,

     ./,20X,' ALFBX=',F9.3,' THB=',F9.3,/)                             

      DO 85 JO=6,8

      JS=JO+3

      WOS=FB(JO)

      WSS=FB(JS)

      FB(JO)= COST*WSS+SINT*WOS

   85 FB(JS)=-SINT*WSS+COST*WOS



C  SELECTION AXIAL MESON CONTRIBUTIONS

      CALL SELECT(FB,INAX)

C*********************************************************************

C*********************************************************************

C

C     TENSOR MESON COUPLINGS 

C

C*********************************************************************

      IF(ITEN.EQ.0) THEN

      GT(1) = 0D0

      FT(1) = 0D0

      GEFF  = 0D0

      FEFF  = 0D0

      ENDIF       



      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,501)

      THT  = THV

c*    ALTD = ALVD

c*    ALTV = ALVV

      ALTD = 0.D0 

      ALTV = PAR(20,7)

      IF(ALTV.EQ.0D0) ALTV = ALVV 

      IF(ITEN.NE.0) THEN

      GT(1)= PAR(5,7)

      GEFF = PAR(6,7)

      FT(1)= PAR(7,7)

      FEFF = PAR(8,7)

c     vector-meson values:

c     gt(1)= par(1,3)

c     ft(1)= par(1,4)

c     geff = gom

c     feff = fom

c*    altd = 0d0

      ENDIF

      COST=DCOS(THT)

      SINT=DSIN(THT)

      GT(9) = (GEFF-SINT*(4*ALTD-1.D0)*GT(1)/SR3)/COST

      FT(9) = (FEFF-SINT*(4*ALTV-1.D0)*FT(1)/SR3)/COST

      CALL SU3(GT,ALTD)

      CALL SU3(FT,ALTV)

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,900) GT(9),FT(9),ALTD,ALTV,

     .THT/CONV

 900  FORMAT(' TENSOR SINGLET COUPLINGS GT9= ',F12.6,' FT9=',

     .F12.6,/,24X,' ALTD=',F12.6,' ALTV=',F12.6,' THETA=',F12.6,//)



C     SU(3)-SYMMETRY BREAKING:

c     IF(SONV.NE.1.D0) CALL SU3SB(GT,SONV,2)

c     IF(SONV.NE.1.D0) CALL SU3SB(FT,SONV,2)

      DO 95 JO=6,8

      JS=JO+3

      WOV=FT(JO)

      WOD=GT(JO)

      WSV=FT(JS)

      WSD=GT(JS)

      FT(JO)= COST*WSV+SINT*WOV

      GT(JO)= COST*WSD+SINT*WOD

      FT(JS)=-SINT*WSV+COST*WOV

      GT(JS)=-SINT*WSD+COST*WOD

   95 CONTINUE



C  SELECTION TENSOR MESON CONTRIBUTIONS

      CALL SELECT(GT,INTEN)

      CALL SELECT(FT,INTEN)

C ******************************************************************

C

C     HEAVY PSEUDO-SCALARS

C

C ******************************************************************

c     IF(IEXD.EQ.0) THEN

      HFPS(1) = PAR(13,2)*RSCAL

      HFETP   = PAR(15,2)*RSCAL

c     ENDIF

      ALPH = ALP

      THPH = THPS

      SINT=DSIN(THPH)

      COST=DCOS(THPH)

      THPHD = THPH/CONV

      HFPS(9)=(HFETP-SINT*(4*ALPH-1.D0)*HFPS(1)/SR3)/COST

      CALL SU3(HFPS,ALPH)

cc    IF(SONPV.NE.1.D0) CALL SU3SB(HFPS,SONPV,1)

      IF(SONPV.NE.1.D0) CALL SU3SB03(HFPS,ALPH,SONPV)

      IF(ICALL.EQ.0.and.NS.NE.0) 

     .WRITE(N2,821) HFPS(9),FEXD,IEXD,ALPH,THPHD

  821 FORMAT(72('*'),/,' H-PS  MESONS SU3{1}: HFPS9=',F9.5,' FEXD=',

     .F9.3,' IEXD=',I3,/,22X,' ALPH=',F9.3,' THPH=',F9.3,/)

C

      DO 87 JO=6,8                

      JS=JO+3

      WOP=HFPS(JO)

      WSP=HFPS(JS)

      HFPS(JS)= COST*WSP+SINT*WOP

   87 HFPS(JO)=-SINT*WSP+COST*WOP



C  SELECTION H-PSEUDOSCALAR MESON CONTRIBUTIONS

      CALL SELECT(HFPS,INPS) 

C ******************************************************************

C

C  HEAVY VECTOR COUPLING CONSTANTS

C

C ******************************************************************

c     IF(IEXD.EQ.0) THEN

      HFD(1)=PAR(13,3)*RSCAL

      HALVD =PAR(14,3)*RSCAL

      HGOM  =PAR(15,3)*RSCAL

      HFV(1)=PAR(13,4)*RSCAL

      HALVV =PAR(14,4)*RSCAL

      HFOM  =PAR(15,4)*RSCAL

      RTOV  =0.D0        

c     ENDIF



      THHV = THV

      COST =COS(THHV)

      SINT =SIN(THHV)

      HFD(9) =(HGOM-SINT*(4*ALVD-1.D0)*HFD(1)/SR3)/COST

      HFV(9) =(HFOM-SINT*(4*ALVV-1.D0)*HFV(1)/SR3)/COST

      CALL SU3(HFD,ALVD)

      CALL SU3(HFV,ALVV)

cc    IF(SONV.NE.1.D0) CALL SU3SB(HFD,SONV,2)

cc    IF(SONV.NE.1.D0) CALL SU3SB(HFV,SONV,2)

      IF(SONV.NE.1.D0) CALL SU3SB03(HFD,ALVD,SONV)

      IF(SONV.NE.1.D0) CALL SU3SB03(HFV,ALVV,SONV)

      IF(ICALL.EQ.0.and.NS.NE.0) 

     .WRITE(N2,850) HFD(9),HFV(9),INRS,ALVD,ALVV,THVD,RTOV,IEXD

  850 FORMAT(72('*'),/,' HEAVY VMESONS SU3{1}: HFD9=',F9.5,' HFV9='

     .,F9.5,' INRS=',I3,/,22X,' ALVD=',F9.3,' ALVV=',F9.3,

     .' THHV=',F9.3,/,22X,' RTOV=',F9.3,' IEXD=',I3,/)                 

C

      DO 861 JO=6,8                

      JS=JO+3

      WOD=HFD(JO)

      WSD=HFD(JS)

      WOV=HFV(JO)

      WSV=HFV(JS)

      HFD(JO)= COST*WSD+SINT*WOD

      HFD(JS)=-SINT*WSD+COST*WOD

      HFV(JO)= COST*WSV+SINT*WOV

  861 HFV(JS)=-SINT*WSV+COST*WOV



C  SELECTION H-VECTOR MESON CONTRIBUTIONS

      CALL SELECT(HFD,INVCT) 

      CALL SELECT(HFV,INVCT) 

C

C*********************************************************************

C

C*********************************************************************

      IF(ICALL.EQ.0.and.NS.NE.0) THEN

      WRITE(N2,501)

      WRITE(N2,93) G,F,FD,FV,GSB,GSA,FS,GD,GDA,FA,FFA,FB,

     .             GT,FT,HFPS,HFD,HFV

      ENDIF

   93 FORMAT(/,'  COUPLING CONSTANTS : ',//,

     . 7x,'   nnp  ','   ssp  ','   slp  ','   lnk  ','   snk  ',/,

     . 7x,'   nne  ','   lle  ','   sse  ','   nnx  ','   llx  ',

     .    '   ssx  ',//,

     1 '  gps =',5f8.4,/,7x,6f8.4,//,'  fps =',5f8.4,/,7x,6f8.4,//,     

     2 '   fd =',5f8.4,/,7x,6f8.4,//,'   fv =',5f8.4,/,7x,6f8.4,//,     

     3 '  gsb =',5f8.4,/,7x,6f8.4,//,'  gsa =',5f8.4,/,7x,6f8.4,//,     

     4 '   fs =',5f8.4,/,7x,6f8.4,//,     

     5 '   gd =',5f8.4,/,7x,6f8.4,//,'  gda =',5f8.4,/,7x,6f8.4,//,     

     6 '   fa =',5f8.4,/,7x,6f8.4,//,'  ffa =',5f8.4,/,7x,6f8.4,//,     

     7 '   fb =',5f8.4,/,7x,6f8.4,//,     

     8 '   gt =',5f8.4,/,7x,6f8.4,//,'   ft =',5f8.4,/,7x,6f8.4,//,     

     9 ' hfps =',5f8.4,/,7x,6f8.4,//,

     x '  hfd =',5f8.4,/,7x,6f8.4,//,'  hfv =',5f8.4,/,7x,6f8.4,//)

C*********************************************************************

C

C     PAIR COUPLINGS

C

C*********************************************************************

      IF(IPAIR.NE.0) THEN

      GSPAIR = PAR(1,8)*RSCAL

      GVPAIR = PAR(2,8)*RSCAL

      FVPAIR = PAR(3,8)*RSCAL

      GAPAIR = PAR(4,8)*RSCAL

      HAPAIR = PAR(5,8)*RSCAL

      GPPAIR = PAR(6,8)*RSCAL

      HOPAIR = PAR(7,8)*RSCAL

      GEPAIR = PAR(8,8)*RSCAL

      GPIET  = PAR(9,8)*RSCAL

      GPIETP = PAR(10,8)*RSCAL

      GPIPOM = PAR(15,8)*RSCAL

C     GSPAIR = 0.D0

C     GVPAIR = 0.D0

C     FVPAIR = 0.D0

C     GAPAIR = 0.D0

C     HAPAIR = 0.D0

C     GPPAIR = 0.D0

C     HOPAIR = 0.D0

C     GEPAIR = 0.D0

C     GPIET  = 0.D0

C     GPIETP = 0.D0

      ALPVPR = ALP

c     ALVDPR = ALVD

c     ALVVPR = ALVV

c     ALSCPR = ALS

      ALVDPR = PAR(13,8)

      ALVVPR = PAR(14,8)

      ALSCPR = PAR(12,8)

      ALPAPR = PAR(11,8)

c*    ALPAPR = ALPAX



      CALL YNPRCOP(ICSB,NSU3F)

      ENDIF



      ICALL = 1

      RETURN

      END

C ***************************************************************

      SUBROUTINE SELECT(F,INMES)         

C ***************************************************************

C     CHECKING CONTRIBUTIONS INDIVIDUAL MESONS

C***********************************************************************

C  USED INDEXING OF THE COUPLINGS :

C   1 =NNP       NNRO       NNDEL       NNA2

C   2 =SSP       SSRO       SSDEL       SSA2

C   3 =LSP       LSRO       LSDEL       LSA2

C   4 =LNK       LNKS       LNKAP       LNK**

C   5 =SNK       SNKS       SNKAP       SNK**

C   6 =NNE       NNOM       NNEPS       NNPOM

C   7 =LLE       LLOM       LLEPS       LLPOM

C   8 =SSE       SSOM       SSEPS       SSPOM

C   9 =NNX       NNFI       NNS*        NNF2

C   10=LLX       LLFI       LLS*        LLF2

C   11=SSX       SSFI       SSS*        SSF2

C

C ***************************************************************

C  NNX STANDS FOR NNETA' ETC.

C ***************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      CHARACTER * 4 INMES(4)

      DIMENSION F(11)

      IF(INMES(1).EQ.'NO ') THEN 

      F(1) = 0.D0

      F(2) = 0.D0

      F(3) = 0.D0

      ENDIF

      IF(INMES(2).EQ.'NO ') THEN 

      F(6) = 0.D0

      F(7) = 0.D0

      F(8) = 0.D0

      ENDIF

      IF(INMES(3).EQ.'NO ') THEN 

      F(9) = 0.D0

      F(10) = 0.D0

      F(11) = 0.D0

      ENDIF

      IF(INMES(4).EQ.'NO ') THEN 

      F(4) = 0.D0

      F(5) = 0.D0

      ENDIF

      RETURN

      END

C ***************************************************************

      SUBROUTINE SU3(F,ALP)

C ***************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION F(11)

      DATA SR3/1.732051D0/

      FF   =  F(1)

      F(2) =2*FF*ALP

      F(3) =2*FF*(1.D0-ALP)/SR3

      F(4) = -FF*(1.D0+2*ALP)/SR3

      F(5) =  FF*(1.D0-2*ALP)

      F(6) =  FF*(4*ALP-1.D0)/SR3

      F(7) = -F(3)

      F(8) =  F(3)

      F(10)=  F(9)

      F(11)=  F(9)

      RETURN

      END

C **********************************************************************

      SUBROUTINE SU3SB(F,SONA,MTYP)

C **********************************************************************

C     MTYP=1: PSEUDO-SCALAR, MTYP=2: VECTOR, MTYP=3: SCALAR,DIFRAC

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION F(11),MEX(3)

      DATA MEX/1,1,0/,ICALL/0/

      IW = MEX(MTYP)

c**   SON = SONA*SONA

      SON = DABS(SONA)     

      F(4) = F(4) - F(4)*(1.D0-SON)

      F(5) = F(5) - F(5)*(1.D0-SON)

      IF(IW.EQ.1) THEN

      F(7) = F(7) 

      F(8) = F(8) - F(8)*(1.D0-SON*SON)/3.D0

      F(10)= F(10)- F(9)*(1.D0-SON*SON)

      F(11)= F(11)+ F(9)*(1.D0-SON*SON)/3.D0

      ENDIF

      IF(IW.EQ.0) THEN

      F(7) = F(7) + F(1)*(1.D0-SON*SON)*2/DSQRT(3.D0)

      F(8) = F(8) + F(1)*(1.D0-SON*SON)*2/DSQRT(3.D0)

      F(10)= F(10)- F(9)*(1.D0-SON*SON)/3.D0

      F(11)= F(11)- F(9)*(1.D0-SON*SON)/3.D0

      ENDIF

      IF(ICALL.EQ.0) THEN

      WRITE(*,99)

      WRITE(*,*) ' SU3SB: IW(PV)=',MEX(1),' IW(VCT)=',MEX(2),

     .' IW(SCL)=',MEX(3)

      WRITE(*,99)

   99 FORMAT(/,72('-'),/)

      ICALL=1

      ENDIF

      RETURN

      END



C **********************************************************************

cc    SUBROUTINE SU3SB(F,SON)

C **********************************************************************

cc    IMPLICIT REAL*8(A-H,O-Z)

cc    DIMENSION F(11)

cc    F(4) = F(4) - F(4)*(1.D0-SON)

cc    F(5) = F(5) - F(5)*(1.D0-SON)

cc    F(7) = F(7) 

cc    F(8) = F(8) - F(8)*(1.D0-SON*SON)/3.D0

cc    F(10)= F(10)- F(9)*(1.D0-SON*SON)

cc    F(11)= F(11)+ F(9)*(1.D0-SON*SON)/3.D0

cc    RETURN

cc    END

C ***************************************************************

c     SUBROUTINE SU3SB(F,SON)

C ***************************************************************

c     IMPLICIT REAL*8(A-H,O-Z)

c     DIMENSION F(11)

c     DATA SR2/1.414213562D0/,SR3/1.732051D0/

c     F(4) =  F(4)-F(4)*(1.D0-SON)

c     F(5) =  F(5)-F(5)*(1.D0-SON)

c     DELSB=  F(1) * (1.D0-SON*SON)*SR2/SR3

c     F(7) =  F(7) + SR2*DELSB

c     F(8) =  F(8) + SR2*DELSB

c     F(10)=  F(10)- DELSB

c     F(11)=  F(11)- DELSB

c     RETURN

c     END

C *****************************************************************

      SUBROUTINE VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)

C *****************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/MODEL/IMODL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2

      COMMON/TWOMES/IPAIR,ITPS,IPIBE,IPSBE

      COMMON/PAROOM/APV,IPV,IGM,INA,IOFF,NADIA     

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALAMK,ALMKS,ALMKAP



      COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL,

     .           FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL,

     .           VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS,

     .           FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS,

     .           VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS,

     .           FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS,

     .           VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR,

     .           FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR

c*   .          ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN

      COMMON/POTF/VCAA(4),VSIGAA(4),VTENAA(4),VSOAA(4),

     .            VSO2AA(4),VASOAA(4),VNNAA(4),

     .            FIAA(4),DFIAA(4),              

     .            FISAA(4),DFISAA(4),             

     .            FITAA(4),DFITAA(4)             

      COMMON/DDPOTF/DDFIAA(4),DDFSAA(4)

      COMMON/POTESC/VCESC(4),VSESC(4),VTESC(4),VOESC(4),VAESC(4)

      COMMON/PNNESC/ESCCNN,ESCSNN,ESCTNN,ESCONN

      CHARACTER * 16 SYS(3)

      CHARACTER *4 TYPM(10),TYPV(8),CHAN(4),TYPV2(8)

      DATA SYS/'SIGMA(+)-PROTON','LAMBDA-NEUTRON','LAMBDA-PROTON'/

      DATA TYPM/'PSSC','VCTR','SCAL','DIFR','AXIA','TENS',

     .'PSPS','PAIR','PIBE','PSBE'/, CHAN/'LL','SS','LS','DR'/,

     .  TYPV/' VC ','VSIG','VTEN',' VSO','VASO',' FI ',' FIS','DDFI'/,

     .  TYPV2/' VC ','VSIG','VTEN',' FI ',' FIS','DFI ','DFIS','DDFI'/

      DATA ZERO/0.D0/,N2/6/,ICALL/0/,ICALLS/0/,ICALLT/0/,I51/0/

C

      ICALL=ICALL+1

      IF(JSPIN.EQ.0) ICALLS=ICALLS+1

      IF(JSPIN.EQ.1) ICALLT=ICALLT+1

      IF(ICALL.EQ.1.AND.NS.GE.1)  PRINT 13,SYS(NCHAN),JSPIN,LINT

  13  FORMAT(//,1X,A13,'-POTENTIALS ON THE ISOSPIN-BASIS : JSPIN=',I2,

     .            ' LINT=',I2,//)



      NIPI=1

      IF(NCHAN.EQ.1) NIPI=4

      IF(NCHAN.NE.1) LC=1

      IF(NCHAN.EQ.1) LC=3

      PX = (-1D0)**LINT

C     PX = -1D0           ! for comparison with ynrmp10.f

      ICSB2 = 0

C

C     INITIALIZATION POTENTIALS

C

      CALL VSET

C

C-----BEGIN 25-LOOP ----------------------------- 

      DO 25 II=1,10

*     DO 25 II=1,4

C

      DO 24 IP=1,4

      VCAA(IP)  =ZERO

      VSIGAA(IP)=ZERO

      VTENAA(IP)=ZERO

      VSOAA(IP) =ZERO

      VSO2AA(IP)=ZERO

      VASOAA(IP)=ZERO

      FIAA(IP)  =ZERO

      DFIAA(IP) =ZERO

      DDFIAA(IP)=ZERO

      FISAA(IP) =ZERO

      DFISAA(IP)=ZERO

      DDFSAA(IP)=ZERO

      FITAA(IP) =ZERO

      DFITAA(IP)=ZERO

c*    DDFITA(IP)=ZERO

      VCESC(IP) = ZERO

      VSESC(IP) = ZERO

      VTESC(IP) = ZERO

      VOESC(IP) = ZERO

      VAESC(IP) = ZERO

  24  VNNAA(IP) = ZERO

      esccnn = zero

      escsnn = zero

      esctnn = zero

      esconn = zero

      escann = zero



C

      GOTO(26,27,28,29,291,292,15,16,17,18),II

c     GOTO(26,27,28,29),II

  26  IF(IPSC.NE.0) CALL PSSCAL(X,ICSB,NLOC,LC)       

      IF(IPSC.EQ.2) CALL PSSCA2(X,ICSB,NLOC,P,PX)        

c 26  IF(IPSC.EQ.1) CALL PSSCAL3(X,NADIA,ICSB,NLOC,NCHAN)

      GOTO 30

  27  IF(IVCT.NE.0) CALL VECTOR(X,ICSB,NLOC,LC)        

      IF(IVCT.EQ.2) CALL VECTOR2(X,ICSB,NLOC,P,PX)        

c 27  IF(IVCT.EQ.1) CALL VECTOR3(X,NADIA,ICSB,NLOC,NCHAN)

      GOTO 30

  28  IF(ISCL.NE.0) CALL SCALAR(X,ICSB,NLOC,LC)        

      IF(ISCL.EQ.2) CALL SCALAR2(X,ICSB,NLOC,LC)    

c 28  IF(ISCL.EQ.1) CALL SCALAR3(X,NADIA,ICSB,NLOC,NCHAN)

      GOTO 30

  29  IF(IDIF.NE.0) THEN

      IF(P.EQ.+1D0) I51 =1      ! A LA YNRMP10.F

      IF(P.EQ.-1D0) I51 =0      ! A LA YNRMP10.F

      CALL DIFRAC(X,ICSB,NLOC,LC,I51)       

      ENDIF

      GOTO 30

  291 IF(IAXI.GE.1) CALL AXIAL(X,ICSB,NLOC,LC,P,PX)       

      IF(IAXI.EQ.2) CALL AXIALU(X,ICSB,NLOC,P,PX)       

      GOTO 30

  292 IF(ITEN.EQ.1) CALL TENSOR(X,ICSB,NLOC,P,PX)       

      GOTO 30

  15  IF(ITPS.EQ.1) CALL YNPSPS(X,INA,IPV,IOFF,ICSB2,APV)               

      GOTO 40

  16  IF(IPAIR.EQ.1) CALL YNPAIR(X,INA,IPV,ICSB2,APV)                

      GOTO 40

  17  IF(IPIBE.EQ.1) CALL YNPIBE(X,INA,IPV,IOFF,APV)               

      GOTO 40

  18  IF(IPSBE.EQ.1) CALL YNPSBE(X,INA,IPV,IOFF,APV)                

      GOTO 40



  30  IF(MOD(ICALL,5).EQ.1) THEN

      IF(NS.EQ.3) THEN

      IF(II.LE.6) THEN

c     IF(ICALL.EQ.1) WRITE(N2,311) TYPM(II),X,(TYPV(KK),KK=1,7)

      WRITE(N2,311) TYPM(II),X,(TYPV(KK),KK=1,7)

 311  FORMAT(/,A4,' X=',F7.4,' PIM-1',' POTENTIALS:',/,

     .         /,6X,7(3X,A4,3X),/)

      DO 31 IP=NIPI,4

  31  WRITE(N2,32) CHAN(IP),VCAA(IP), VSIGAA(IP),VTENAA(IP),

     .             VSOAA(IP),VASOAA(IP),FIAA(IP),FISAA(IP)

c    .             VSOAA(IP),VSO2AA(IP),FIAA(IP),DFIAA(IP),DDFIAA(IP)

  32  FORMAT(1X,A4,2X,7(D9.3,1X),/)

      ENDIF

      ENDIF

      ENDIF



  40  IF(MOD(ICALL,5).EQ.1) THEN

      IF(NS.EQ.3) THEN

      IF(II.GE.7) THEN

c     IF(ICALL.EQ.1) WRITE(N2,411) TYPM(II),X,(TYPV(KK),KK=1,4)

      WRITE(N2,411) TYPM(II),X,(TYPV(KK),KK=1,5)

 411  FORMAT(/,A4,' X=',F7.4,' PIM-1',' POTENTIALS:',/,

     .         /,6X,5(3X,A4,3X),/)

      DO 41 IP=NIPI,4

  41  IF(MOD(ICALL,5).EQ.1)

     .WRITE(N2,42) CHAN(IP),VCESC(IP), VSESC(IP),VTESC(IP),

     .             VOESC(IP),VAESC(IP)

  42  FORMAT(1X,A4,2X,5(D9.3,1X),/)

      ENDIF

      ENDIF

      ENDIF

C

      VCNN    = VCNN   + VNNAA(1)

      VSIGNN  = VSIGNN + VNNAA(2)

      VTENNN  = VTENNN + VNNAA(3)

      VSONN   = VSONN  + VNNAA(4)

      IF(IPAIR.EQ.1) THEN

      VCNN    = VCNN   + ESCCNN   

      VSIGNN  = VSIGNN + ESCSNN   

      VTENNN  = VTENNN + ESCTNN  

      VSONN   = VSONN  + ESCONN  

      ENDIF

      IF(NCHAN.EQ.1) GOTO 33

      VCLL  =VCLL   + VCAA(1) + VCESC(1)

      VSIGLL=VSIGLL + VSIGAA(1) + VSESC(1)

      VTENLL=VTENLL + VTENAA(1) + VTESC(1)

      VSOLL =VSOLL  + VSOAA(1)  + VOESC(1)

      VSO2LL=VSO2LL + VSO2AA(1)

      VASOLL=VASOLL + VASOAA(1) + VAESC(1)



      VCLS  =VCLS   + VCAA(3)   + VCESC(3)

      VSIGLS=VSIGLS + VSIGAA(3) + VSESC(3)

      VTENLS=VTENLS + VTENAA(3) + VTESC(3)

      VSOLS =VSOLS  + VSOAA(3)  + VOESC(3)

      VSO2LS=VSO2LS + VSO2AA(3)

      VASOLS=VASOLS + VASOAA(3)



      VCSS  =VCSS   + VCAA(2)   + VCESC(2)

      VSIGSS=VSIGSS + VSIGAA(2) + VSESC(2)

      VTENSS=VTENSS + VTENAA(2) + VTESC(2)

      VSOSS =VSOSS  + VSOAA(2)  + VOESC(2)

      VSO2SS=VSO2SS + VSO2AA(2)

      VASOSS=VASOSS + VASOAA(2) + VAESC(2)



      FILL  =FILL   + FIAA(1)

      FILS  =FILS   + FIAA(3)

      FISS  =FISS   + FIAA(2)

      DFILL =DFILL  + DFIAA(1)

      DFILS =DFILS  + DFIAA(3)

      DFISS =DFISS  + DFIAA(2)

      DDFILL=DDFILL + DDFIAA(1)

      DDFILS=DDFILS + DDFIAA(3)

      DDFISS=DDFISS + DDFIAA(2)

      FISLL  =FISLL   + FISAA(1)

      FISLS  =FISLS   + FISAA(3)

      FISSS  =FISSS   + FISAA(2)

      DFISLL =DFISLL  + DFISAA(1)

      DFISLS =DFISLS  + DFISAA(3)

      DFISSS =DFISSS  + DFISAA(2)

      DDFSLL=DDFSLL + DDFSAA(1)

      DDFSLS=DDFSLS + DDFSAA(3)

      DDFSSS=DDFSSS + DDFSAA(2)

  33  VCDR  =VCDR   + VCAA(4) + VCESC(4)

      VSIGDR=VSIGDR + VSIGAA(4) + VSESC(4)

      VTENDR=VTENDR + VTENAA(4) + VTESC(4)

      VSODR =VSODR  + VSOAA(4)  + VOESC(4)

      VSO2DR=VSO2DR + VSO2AA(4)

      VASODR=VASODR + VASOAA(4) + VAESC(4)

      FIDR  =FIDR   + FIAA(4)

      DFIDR =DFIDR  + DFIAA(4)

      DDFIDR=DDFIDR + DDFIAA(4)

      FISDR  =FISDR   + FISAA(4)

      DFISDR =DFISDR  + DFISAA(4)

20    DDFSDR=DDFSDR + DDFSAA(4)

  25  CONTINUE

C-----END 25-LOOP --------------------------------------------



        IF(NS.EQ.3) THEN     ! BEGIN NS.EQ.3

      IF((JSPIN.EQ.0.AND.MOD(ICALLS,5).EQ.1).or.                           

     .(JSPIN.EQ.1.AND.MOD(ICALLT,5).EQ.1)) THEN                        

      IF(JSPIN.EQ.0) WRITE(*,99)

  99  FORMAT(72('-'))

c*    IF(MOD(ICALL,2).EQ.1) THEN

      IF(NS.GE.2) THEN

      XFM = X*197.327053D0/PIM

      WRITE(N2,312) XFM,JSPIN,LINT,(TYPV(KK),KK=1,7)

c*    WRITE(N2,312) XFM,JSPIN,LINT,(TYPV2(KK),KK=1,7)

 312  FORMAT(/,' XFM=',F7.4,' FM',' JSPIN=',I2,' LINT=',I2,

     .' TOTAL POTENTIALS:',/, /,6X,7(4X,A4,5X),/)

      IF(NCHAN.NE.1) THEN

      WRITE(N2,51)  VCLL, VSIGLL,VTENLL,VSOLL,VASOLL,FILL,FISLL

      WRITE(N2,52)  VCSS, VSIGSS,VTENSS,VSOSS,VASOSS,FISS,FISSS

      WRITE(N2,53)  VCLS, VSIGLS,VTENLS,VSOLS,VASOLS,FILS,FISLS

      WRITE(N2,54)  VCDR, VSIGDR,VTENDR,VSODR,VASODR,FIDR,FISDR



cc    WRITE(N2,51)  VCLL, VSIGLL,VTENLL,FILL,FISLL,DFILL,DFISLL

cc    WRITE(N2,52)  VCSS, VSIGSS,VTENSS,FISS,FISSS,DFISS,DFISSS

cc    WRITE(N2,53)  VCLS, VSIGLS,VTENLS,FILS,FISLS,DFILS,DFISLS

cc    WRITE(N2,54)  VCDR, VSIGDR,VTENDR,FIDR,FISDR,DFIDR,DFISDR

      ELSE

c     WRITE(N2,55)  VCDR, VSIGDR,VTENDR,VSODR,VSO2DR,FIDR,DFIDR,DDFIDR

      WRITE(N2,55)  VCDR, VSIGDR,VTENDR,VSODR,VASODR,FIDR,FISDR

cc    WRITE(N2,55)  VCDR, VSIGDR,VTENDR,FIDR,FISDR,DFIDR,DFISDR

      ENDIF

      ENDIF

      ENDIF

        ENDIF     ! END NS.EQ.3

  51  FORMAT(1X,' LL :',7(D12.5,1X),/)

  52  FORMAT(1X,' SS :',7(D12.5,1X),/)

  53  FORMAT(1X,' LS :',7(D12.5,1X),/)

  54  FORMAT(1X,' DR :',7(D12.5,1X),/)

  55  FORMAT(1X,' DR :',7(D12.5,1X),/)

C

      RETURN

      END

C**********************************************************************

C

      SUBROUTINE VSET

C

C**********************************************************************

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/POT/V(48)

c*    COMMON/POT/V(53)

      DATA ZERO/0.D0/

C

      DO 24 IP=1,48

c*    DO 24 IP=1,53

  24  V(IP) = ZERO

      RETURN

      END

C *************************************************************

      SUBROUTINE CNSTR97(ELPHID,GEPS,GSST,GEPSNW,GSSTNW,NCASE)

C *************************************************************

C     ADAPTED FOR THE VERSION WITH 2 SCALAR NONETS !! (SEPT. 2000)

C -------------------------------------------------------------

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      DATA SR2/1.4142136D0/,SR3/1.732051D0/,PIM/138.041D0/                

      DATA NS/0/,AMEPS2/1370.D0/,AMD2/1450.D0/,AMSST2/1580.D0/

CC

C     COMPUTATION ALTERNATIVE GEPS,GSST FROM THE ELLIPTIC CONSTRAINT:

C     VOLUME INTEGRAL VNN CONSTANT:

C     PRINT 200

C 200 FORMAT(/,' ELLIPTIC CONSTRAINT= PRESERVING VOL.INT NN:',/)

      PI   =DACOS(-1.D0)

      ELPHI=PI*ELPHID/180.D0

      COSFI=DCOS(ELPHI)

      SINFI=DSIN(ELPHI)

      IF(NCASE.EQ.1) THEN

      BMSI =ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2

      BMSST=(PIM/AMSST)**2

      CF   = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2)

      ENDIF

      IF(NCASE.EQ.2) THEN

      BMSI =(PIM/AMD)**2 

      BMSST=(PIM/AMD2)**2

      CF   = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2)

      ENDIF

      IF(NCASE.EQ.3) THEN

      BMSI =(PIM/AMEPS2)**2 

      BMSST=(PIM/AMSST2)**2

      CF   = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2)

      ENDIF

      IF(NCASE.EQ.5) THEN

      BMSI =ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2

      BMSST=(PIM/AMEPS2)**2

      CF   = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2)

      ENDIF



C     STANDARD ELLIPSE PARAMETERS, X^2/A^2 + Y^2/B^2 = :

      AA = 1.D0/DSQRT(BMSI)

      BB = 1.D0/DSQRT(BMSST)

      XX = GEPS/CF

      YY = GSST/CF

      

C     POLAR COORDINATES, (ELPHI,RR):

      EPSI2 = 1.D0-(BB/AA)**2

      RR    = BB/DSQRT(1.D0-EPSI2*COSFI**2)



      GEPSNW= CF*RR*COSFI

      GSSTNW= CF*RR*SINFI



      IF(NS.EQ.1) THEN

C     COMPUTATION ELPHI0: CORRESPONDS TO INPUT GEPS,GSST:

      ARG = GSST/GEPS

      IF(ARG.GE.0) ELPHI0=DATAN(ARG)*180.D0/PI

C     IF(ARG.LT.0) ELPHI0=360.D0+DATAN(ARG)*180.D0/PI

      IF(ARG.LT.0) ELPHI0=DATAN(ARG)*180.D0/PI



      IF(GSST.LT.0.D0.AND.GEPS.LT.0.D0) 

     .ELPHI0=ELPHI0 - 180.D0

      

      IF(NCASE.EQ.1)        

     .PRINT 111, ELPHID,GEPSNW,GSSTNW,ELPHI0

  111 FORMAT(' IN CNSTR97: ELPHID=',F8.3,' GEPSNW=',D12.5,

     .' GSSTNW=',D12.5,/,12X,' ELPHI0=',D12.5,/)

      IF(NCASE.EQ.2)        

     .PRINT 112, ELPHID,GEPSNW,GSSTNW,ELPHI0

  112 FORMAT(' IN CNSTR97: PSIS8D=',F8.3,' GDELNW=',D12.5,

     .' GDEL2NW=',D12.5,/,12X,' PSIS80=',D12.5,/)

      IF(NCASE.EQ.3)        

     .PRINT 113, ELPHID,GEPSNW,GSSTNW,ELPHI0

  113 FORMAT(' IN CNSTR97: PSIS1D=',F8.3,' GEPS2NW=',D12.5,

     .' GSST2NW=',D12.5,/,12X,' PSIS10=',D12.5,/)

      IF(NCASE.EQ.5)        

     .PRINT 115, ELPHID,GEPSNW,GSSTNW,ELPHI0

  115 FORMAT(' IN CNSTR97: PSIS1D=',F8.3,' GEPSNW=',D12.5,

     .' GEPS2NW=',D12.5,/,12X,' PSIS10=',D12.5,/)



      ENDIF

      RETURN

      END

C **************************************************************

      SUBROUTINE TRANLP(TRANS,TRAND)

C **************************************************************

C     LAMBDA-PROTON SYSTEM VERSION

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION TRANS(3,3),TRAND(3,3)

      DATA SR2/1.4142136D0/,SR3/1.732051D0/

      SR2 = DSQRT(2.D0)

      SR3 = DSQRT(3.D0)

      TRANS(1,1)=1.0D0

      TRANS(1,2)=SR2/SR3

      TRANS(2,1)=SR2/SR3

      TRANS(1,3)=-1.D0/SR3

      TRANS(3,1)=-1.D0/SR3

      TRANS(2,2)=2.D0/3

      TRANS(2,3)=-SR2/3

      TRANS(3,2)=-SR2/3

      TRANS(3,3)=1.D0/3

C

      TRAND(1,1)=0.D0

      TRAND(1,2)=0.D0

      TRAND(2,1)=0.D0

      TRAND(1,3)=0.D0

      TRAND(3,1)=0.D0

      TRAND(2,2)=1.D0/3

      TRAND(2,3)=SR2/3

      TRAND(3,2)=SR2/3

      TRAND(3,3)=2.D0/3

      RETURN

      END

C **************************************************************

      SUBROUTINE TRANLN(TRANS,TRAND)

C **************************************************************

C     LAMBDA-NEUTRON SYSTEM VERSION

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION TRANS(3,3),TRAND(3,3)

      DATA SR2/1.4142136D0/,SR3/1.732051D0/

      SR2 = DSQRT(2.D0)

      SR3 = DSQRT(3.D0)

      TRANS(1,1)=1.0D0

      TRANS(1,2)=1.D0/SR3

      TRANS(2,1)=1.D0/SR3

      TRANS(1,3)=-SR2/SR3

      TRANS(3,1)=-SR2/SR3

      TRANS(2,2)=1.D0/3

      TRANS(2,3)=-SR2/3

      TRANS(3,2)=-SR2/3

      TRANS(3,3)=2.D0/3

C

      TRAND(1,1)=0.D0

      TRAND(1,2)=0.D0

      TRAND(2,1)=0.D0

      TRAND(1,3)=0.D0

      TRAND(3,1)=0.D0

      TRAND(2,2)=2.D0/3

      TRAND(2,3)=SR2/3

      TRAND(3,2)=SR2/3

      TRAND(3,3)=1.D0/3

      RETURN

      END



C **********************************************************************

      SUBROUTINE GERSTPAR           

C **********************************************************************

C     COMPUTES TWO-POLE APPRXIMATION PARAMETERS FOR EPSILON-MESON,

C     USING THE Bryan-Gersten FORMULAS, PHYS.REV. D6 (1972) 341

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/PRMTRS/PAR(20,8)



      AME  = PAR(10,5)

      GAME = PAR(11,5)

      PIM2 = PIM*PIM

      AME2 = AME*AME

      AM32 = AME2*(DSQRT(AME2+4*PIM2)-2*PIM)

      AM32 = 4*PIM*AM32/(AME2+8*PIM2-4*PIM*DSQRT(AME2+4*PIM2))

      GAM  = GAME*AME/DSQRT(AME2-4*PIM2)



      X = (AME2+2*PIM*GAM)*AM32

      Y = AME2+AM32*(1.D0+0.25D0*GAM/PIM)+2*PIM*GAM

      Y = 0.5D0*Y

      AM12 = Y-DSQRT(Y*Y-X)

      AM22 = Y+DSQRT(Y*Y-X)



      ASI  = (AM12-AM32)/(AM12-AM22)

      BSI  = 1.D0-ASI

      AM1SI= DSQRT(AM12)

      AM2SI= DSQRT(AM22)



      RETURN

      END



C **********************************************************************

      SUBROUTINE FRMINIT            

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,             

     .             ALMKA,ALMKS,ALMKP

      COMMON/PRMTRS/ PAR(20,8)



C     COMMON FORM FACTOR FOR PS, VECT, AND SCALA RESPECTIVELY:

      ALMP0 = ALMP1

      ALMV0 = ALMV1

      ALMS0 = ALMS1



C     PUTTING THINGS IN PARAMETER MATRIX:

      PAR(9,2)=ALMP0

      PAR(9,3)=ALMV0

      PAR(9,5)=ALMS0

      RETURN

      END

      

C*****                   ***********************************************

      SUBROUTINE DCOFUN(XA,AMES,ALAM,CK,F,DF,DDF,D3F)

C*****                   ***********************************************

C     COMPUTATION FOURIER TRANSFORM WITH FINITE CK        

C     USING SERIES EXPANSION

C     XA: UNITS PION WAVE-LENGTH

C----------------------------------------------------------------------

C     DF0 = DPHI_C^0(R) = INT_K^INFTY ( PHI_C^0-INTEGRAND)

C

C     DF1 = (D/DXA) DF0, DF2 = (D/DXA)^2 DF0, DF3 = (D/DXA)^3 DF0

C----------------------------------------------------------------------

C     OPTIONS COMPUTATION: 

C     IASYMP=0: VIA RECURRENCE RELATIONS + PADE      ! VERY SUCCESFUL!

C     IASYMP=1: VIA ESTIMATION INTEGRALS             ! REASONABLE    

C----------------------------------------------------------------------

      IMPLICIT REAL*8 (A-H,O-Z)

      PARAMETER( EPS=1.D-04, MAXIT=20)

      DATA ICALL/0/,PIM/138.041D0/,AMF/197.32D0/,IASYMP/0/

      SAVE PI,SRPI,SR2

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      IF(ICALL.EQ.0) THEN

      PI = DACOS(-1.D0)

      SRPI=DSQRT(PI)

      SR2 =DSQRT(2.D0)

      ULAM = 10*ALAM

      ENDIF

      RATK = CK/ALAM

      RATM = AMES/ALAM

      RATP = ALAM/PIM

      X= (AMES/PIM)*XA

      XLAM=XA*ALAM/PIM

      XLAM2=XLAM*XLAM

      EX = FDEXP(X)

      EXPM = FDEXP(RATM*RATM) 

      DERFCM = FDERFC(-0.5D0*XLAM+RATM)

      DERFCP = FDERFC(+0.5D0*XLAM+RATM)

      ELAM0  = 0.25D0*SRPI*FDEXP(-0.25D0*XLAM2)



c--------------------------------------------------------------

c     I1(n) and I2(n) recursion-method

c--------------------------------------------------------------

c     write(*,*) ' recursion I1(n) and I2(n): xa=',xa,' xfm=',xa*amf/pim

c     scaling:

      scale=1.d0 

      fack = 1.d0

      funck0 =0.d0

      funck1 =0.d0

      funck2 =0.d0

      funck3 =0.d0



      if(iasymp.eq.0) then

      ai1mn=0.d0

      ai1n = 0.25d0*pi*expm*fderfc(-0.5d0*xlam+ratm)

      ai2mn=0.d0

      ai2n = 0.25d0*pi*expm*fderfc(+0.5d0*xlam+ratm)



      elam1= -0.5d0*dsqrt(pi)*fdexp(-0.25D0*xlam*xlam+x)/xlam

      elam2= +0.5d0*dsqrt(pi)*fdexp(-0.25D0*xlam*xlam-x)/xlam

      endif



      if(iasymp.eq.0) then

      NSTART=1

      NSTEP =1

      endif

      if(iasymp.ge.1) then

      NSTART=2

      NSTEP =2

      endif

c**   DO 100 n=1,2*MAXIT           ! IF: IASYMP=0

c**   DO 100 n=2,2*MAXIT,2         ! IF: IASYMP=1

      DO 100 n=NSTART,2*MAXIT,NSTEP     

c--------------------------------------------------------------

c     recurrence relation method:        ! VERY SUCCESFUL !!

c--------------------------------------------------------------

      if(iasymp.eq.0) then

      elam1 = elam1*xlam

      elam2 = elam2*xlam

      ai1pl = elam1 + 2*ratm*ai1n + 2*(n-1)*ai1mn

      ai2pl = elam2 - 2*ratm*ai2n + 2*(n-1)*ai2mn

      cfn = fdexp(-x)*ai1pl - fdexp(+x)*ai2pl

      ai1mn = ai1n

      ai1n  = ai1pl

      ai2mn = ai2n

      ai2n  = ai2pl



      as1n  = ai1pl

      as2n  = ai2pl

      endif

c--------------------------------------------------------------

c     asymptotic function:              ! LESS SUCCESFUL !!

c--------------------------------------------------------------

      if(iasymp.eq.1) then

      expmh= fdexp(0.5d0*ratm*ratm)

      psi1 = (0.25d0*pi/dsqrt(2.d0))*expmh*                    

     .fderfc(-xlam/sr2+ratm/sr2-dsqrt(1d0*n)) ! I_1: -infty - x0

      psi2 = (0.25d0*pi/dsqrt(2.d0))*expmh*                    

     .fderfc(+xlam/sr2+ratm/sr2-dsqrt(1d0*n)) ! I_2: x0 - infty

c     computation integrals:                                 

      expn = dexp(-0.5d0*n-ratm*dsqrt(2d0*n))*(2*n)**(0.5d0*n)

      as1n = (-1d0)**n*psi1*expn                                  

      as2n = psi2*expn                                  

      cfn= fdexp(-x)*as1n-fdexp(+x)*as2n

      endif     

c--------------------------------------------------------------

c     das1n = +ratp*elam0*xlam**n

c     das2n = -das1n              

c     d2as1n = +ratp**2*elam0*xlam**(n-1)*

c    .         ( (ratm-0.5d0*xlam)*xlam+n)

c     d2as2n = +ratp**2*elam0*xlam**(n-1)*

c    .         ( (ratm+0.5d0*xlam)*xlam-n)



      dcfn= -(ames/pim)*(fdexp(-x)*as1n+fdexp(+x)*as2n)

     .      +2*ratp*elam0*xlam**n

      d2cfn= +(ames/pim)**2*cfn +2*xlam**(n-1)*

     .       ratp**2*elam0*(-0.5d0*xlam**2+n)

      d3cfn= -(ames/pim)**3*(fdexp(-x)*as1n+fdexp(+x)*as2n)

     .       +2*xlam**(n-2)*ratp**3*elam0*(0.25d0*xlam**4

     .       -0.5d0*(2*n+1)*xlam**2+n*(n-1))

c---------------------------------------------------------------





c     if(icall.le.2.or.icall.eq.50.or.icall.eq.99) then

c     if(k.eq.1) write(*,*) ' xa=',xa,' xlam=',xlam 

c     write(*,700) as1n,das1n,d2as1n      

c 700 format(' as1n =',d9.2,' das1n=',d9.2,' d2as1n=',d9.2,

c    .       ' as2n =',d9.2,' das2n=',d9.2,' d2as2n=',d9.2)

c     endif



c--------------------------------------------------------------

      if(mod(n,2).eq.0) then

      k=n/2

      fack = 4*k*fack

      fct1F1 = HYP1F1(DFLOAT(-K+1),1.5D0,RATK**2)



      dfunck = fct1F1*cfn/fack   

      d1funck = fct1F1*dcfn/fack   

      d2funck = fct1F1*d2cfn/fack   

      d3funck = fct1F1*d3cfn/fack   



      funck0 = funck0 + dfunck

      funck1 = funck1 + d1funck

      funck2 = funck2 + d2funck

      funck3 = funck3 + d3funck



c     if(icall.le.2.or.icall.eq.50.or.icall.eq.99) then

c     if(k.eq.1) write(*,*) 'xfm=',x*amf/pim,' xlam=',xlam

c     write(*,20) k,dfunck,d1funck,d2funck, fct1F1

c  20 format(' k=',i3,' dfunck=',d10.3,' d1funck=',d10.3,

c    .' d2funck=',d10.3 ,' fct1F1=',d10.3)

c     endif

      endif

c--------------------------------------------------------------



  100 IF(DABS(DFUNCK/FUNCK0).LT.EPS) GOTO 200

c**   WRITE(*,*) ' COFUN: XA=',XA,' ACCURACY NOT REACHED !!'

  200 FUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK0

      DFUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK1

      DDFUNCO = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK2

      D3FUNCO  = (2/SRPI)*RATK*DEXP(-RATK*RATK)*FUNCK3

      

C     A LA SUBROUTINE FFUN2:

      X1 = 1D0/XA

      X2 = X1*X1

      X3 = X1*X2

      X4 = X2*X2

      VKUA = (ALAM/PIM)*FDEXP(-0.25D0*XLAM2)/(2*SRPI)

      DVKUA = -0.5D0*(ALAM/PIM)**2*XA*VKUA                     

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)

      FIA  = F0(EXPM,EX,DERFCM,DERFCP,XA)

      HIA  = H0(EXPM,EX,DERFCM,DERFCP,XA)

      DFIA  = -(FIA-2*VKUA)*X1 - (AMES/PIM)*HIA 

      DHIA  = -(AMES/PIM)*FIA - HIA*X1

      DDFIA = -(DFIA-2*DVKUA)*X1 +(FIA-2*VKUA)*X2 -(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

      

      F = (0.D0-FDERFC(RATK))*FIA + (2/PI)*FUNCO*X1

      DF = (0.D0-FDERFC(RATK))*DFIA + (2/PI)*DFUNCO*X1

     .       -(2/PI)*FUNCO*X2

      DDF = (0.D0-FDERFC(RATK))*DDFIA + (2/PI)*DDFUNCO*X1

     .       -(4/PI)*DFUNCO*X2 + (4/PI)*FUNCO*X3

      D3F  = (0.D0-FDERFC(RATK))*D3FIA + (2/PI)*D3FUNCO*X1

     .        -(6/PI)*DDFUNCO*X2 + (12/PI)*DFUNCO*X3

     .         -(12/PI)*FUNCO*X4

      GOTO 400

c--------------------------------------------------------------

C     PADE prediction/correction:

C     not inplemented.

c--------------------------------------------------------------

  400 ICALL = ICALL + 1

      RETURN

      END

C**************************************************************

      FUNCTION HYP1F1(A,C,Z)

C**************************************************************

C     COMPUTATION HYPERGEOMETRICAL SERIES 1F1(A,C;Z)

C**************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      FAC=1.D0

      TEMP=FAC

      AA=A

      CC=C

      DO 11 N=1,1000

           FAC=FAC*AA/CC

           FAC=FAC*Z/N

           SERIES=TEMP+FAC

           IF(SERIES.EQ.TEMP) GOTO 12

           TEMP=SERIES

           AA=AA+1.D0

           CC=CC+1.D0

   11 CONTINUE

      STOP 'CONVERGENCE FAILURE IN HYP1F1'

   12 HYP1F1 = SERIES

      RETURN

      END



C **********************************************************************

      SUBROUTINE DKBFUN(KIND,X,AM1,AM2,ALM1,ALM2,DAM,FUN)

C **********************************************************************

C

C     FOR DOUBLE STRANGENESS-EXCHANGE IN NUCLEON-NUCLEON

C     (KAON-KAON, KAON-KSTAR, KAON-KAPPA, KAON-K**)

C  ?? IT IS UNDERSTOOD THAT AM1=AMK, SO INDEX 1 REFERS TO THE KAON.

C

C     COMPUTES THE FOURIER TRANSFORMS FOR THE ADIABATIC DENOMINATOR:

C

C                     1     D  [        A            1

C      D_{//} = - --------- -- [ --------------- ---------

C                 2 OM1 OM2 DA [ (OM1+A) (OM2+A) OM1 + OM2

C

C                                         1         1     ]

C                                   + --------- --------- ] = -D_{X}

C                                     (OM1 + A) (OM2 + A) ]

C

C    ,WHICH COINCIDES WITH D_{//} FOR A=0 -> COMPATIBLE WITH PHBFUN!,

C     FOR VARIOUS COMBINATIONS OF DERIVATIVES.

C

C     KIND = 1: KAON-VECTOR-,   KIND = 2: KAON-SCALAR-,

C     KIND = 3: KAON-PSSCALAR-, KIND = 4: KAON-POMERON-EXCHANGE,

C     KIND = 5: NOT ALLOWED   , KIND = 6: KAON-AXIAL  -EXCHANGE.

C

C     SCHEMATICALLY:

C     KAON-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT1

C     FUN(4) = OPAEMO1 FUN(5) = OPAMMC  FUN(6) = OPAMMS

C     FUN(7) = OPAMMT  FUN(8) = OPAEMS2 FUN(9) = OPAEMT2

C     FUN(10)= OPAEMO2 FUN(11)= OCREES  FUN(12)= OCREET

C     KAON-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO

C     KAON-PSSCALAR EXCHANGE:

C     FUN(1) = OPSC    FUN(2) = OPSS    FUN(3) = OPST

C     DIFRAC-DIFRAC EXCHANGE:

C     FUN(1) = ODFC    FUN(2) = ODFO

C     KAON-AXIAL EXCHANGE:

C     FUN(1) = OAXC    FUN(2) = OAXS    FUN(3) = OAXT

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM



      DIMENSION XX(20),WW(20),YB(3),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA IPV/1/,YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      DATA AMPRO/938.2796D0/

      SAVE XX,WW

C

C     ACCORDING TO THE PAPER I, TABLE II AND APPENDIX A,B,

C     DEFINITION STATEMENT OPERATORS:

C !!  (NOTICE: G-FUNTIONS REFER TO KAON, F-FUNCTIONS TO MESONS.)

C

C 1)  KAON-VECTOR EXCHANGE:

      OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)=

     .  2*FF*(2*D1G/XH+D2G)/3.D0



c    .+( 4*D1F*(D3G+2*D2G/XH-2*D1G/XH/XH)

c    .+(2*D1F/XH+D2F)*(2*D1G/XH+D2G) )*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0



      OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)=

     . -2*FF*(D1G/XH-D2G)/3.D0



c    .+( 4*D1F*(D3G-  D2G/XH+  D1G/XH/XH)

c    .+(2*D1F/XH+D2F)*(D2G-D1G/XH) )*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(D2F*D2G-D1F*D1G/XH/XH)*(PIM/AMPRO)**2/6.D0



      OCREES(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)=

     .OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)



c    .+FF*(D4G+4*D3G/XH)*(PIM/AMPRO)**2/3.D0



      OCREET(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)=

     .OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)



c    .+FF*(D4G+D3G/XH-6*D2G/XH**2+6*D1G/XH**3)*(PIM/AMPRO)**2/3.D0



      OPAEMT(D1F,D1G,D2G,XH)=  2*D1F*(D1G/XH-D2G)/XH

      OPAEMO(D1F,D1G,XH)=  4*D1F*D1G/XH/XH

      OPEMS2(D1F,D2F,D1G,D2G,XH)= (2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0

      OPEMT2(D1F,D2F,D1G,D2G,XH)=  (D1F/XH-D2F)*(D1G/XH-D2G)/3.D0

      OPEMO2(D1F,D1G,XH)=  2*D1F*D1G/XH/XH



      OPAMMC(D1F,D2F,D1G,D2G,XH)=

     .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH

      OPAMMS(D1F,D2F,D1G,D2G,XH)=

     .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0

      OPAMMT(D1F,D2F,D1G,D2G,XH)=

     .+(D2F+D1F/XH)*(D2G-D1G/XH)/3.D0-1*(D2F-D1F/XH)*D1G/XH/3.D0

     .-1*(D2G-D1G/XH)*D1F/XH/3.D0



C2,4) KAON-SCALAR EXCHANGE:

      OSCS(FF,D1F,D2F,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0



c    .  +(2*D1F/XH+D2F)*(2*D1G/XH+D2G)*(PIM/AMPRO)**2/6.D0

c    .  -(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0

      OSCT(FF,D1F,D2F,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0



c    .      +(D1F/XH-D2F)*(D1G/XH-D2G)*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(D1F*D1G/XH/XH-D2F*D2G)*(PIM/AMPRO)**2/6.D0

      OSCO(D1F,D1G,XH)= 0.D0

c    .                 +(D1F*D1G/XH/XH)*(PIM/AMPRO)**2



C 3)  KAON-PSEUDO-SCALAR EXCHANGE:

      OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G)

      OPSS(D1F,D2F,D1G,D2G,XH)=+4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0

      OPST(D1F,D2F,D1G,D2G,XH)=-2*( (D2F-D1F/XH)*D1G/XH +

     . (D2G-D1G/XH)*D1F/XH )/3.D0



C 4)  DIFRAC-DIFRAC EXCHANGE:

      ODFC(FF,D1F,D2F,GG,D1G,D2G,XH)= 2*FF*GG



c    . -0.5D0*(PIM/AMPRO)**2

c    . *((D2F+2*D1F/XH)*GG+FF*(D2G+2*D1G/XH)-2*D1F*D1G)

      ODFO(FF,D1F,GG,D1G,XH)= 0.D0

c    .                        -(D1F*GG+FF*D1G)/XH*(PIM/AMPRO)**2



C 5)  KAON-AXIAL EXCHANGE:

      OAXC(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)

      OAXS(FF,D1G,D2G,XH)= +2*FF*(2*D1G/XH+D2G)*2/3.D0

      OAXT(FF,D1G,D2G,XH)= -2*FF*( -D1G/XH+D2G)/3.D0

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      AA   = DAM/PIM

      AA2  = AA*AA

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

      X4   = X1*X3

CC

      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1

      DDVKU1=-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1)

      D3VKU1=-0.5D0*(ALM1/PIM)**2*(2*DVKU1+X*DDVKU1)



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,12

  105 FUN(IFUN) = 0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*1.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110 

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

      FDISP = FDISP1*FDISP2

C

      IF(KIND.NE.5) THEN

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM

      DDHIM  =-(AM/PIM)*DFIM -DHIM*X1 +HIM*X2

      D3FIM  =-(DDFIM-2*DDVKU1)*X1+2*(DFIM-2*DVKU1)*X2

     .        -2*(FIM-2*VKU1)*X3-(AM/PIM)*DDHIM

      D3HIM  =-(AM/PIM)*DDFIM -DDHIM*X1 +2*DHIM*X2-2*HIM*X3

      D4FIM  =-(D3FIM-2*D3VKU1)*X1+3*(DDFIM-2*DDVKU1)*X2

     .        -6*(DFIM-2*DVKU1)*X3+6*(FIM-2*VKU1)*X4-(AM/PIM)*D3HIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

      D3FIM1  = D3FIM

      D4FIM1  = D4FIM

      ENDIF

C

      IF(KIND.LT.4.OR.KIND.GE.6) THEN

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM

      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

      ENDIF

      IF(KIND.EQ.4.OR.KIND.EQ.5) THEN

      XA   =X*AM2/PIM

      FIA  =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA)

      DFIA  = -2*(AM2/PIM)*XA*FIA

      DDFIA  = -2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM)

      FIM2= FIA

      DFIM2= DFIA

      DDFIM2= DDFIA

      ENDIF



C

      WGHT= GEW*(AA2-Y*Y)/(AA2+Y*Y)**2

C

      IF(KIND.EQ.1) THEN

      FUN(1)  = FUN(1)  + WGHT*FDISP*

     .  OPAEES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X)

      FUN(2)  = FUN(2)  + WGHT*FDISP*

     .  OPAEET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X)

      FUN(11) = FUN(11) + WGHT*FDISP*

     .   OCREES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X)

      FUN(12) = FUN(12) + WGHT*FDISP*

     .   OCREET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X)

      FUN(3)  = FUN(3)  + WGHT*FDISP*

     .   OPAEMT(DFIM2,DFIM1,DDFIM1,X)

      FUN(4)  = FUN(4)  + WGHT*FDISP*

     .   OPAEMO(DFIM2,DFIM1,X)

      FUN(5)  = FUN(5)  + WGHT*FDISP*

     .   OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(6)  = FUN(6)  + WGHT*FDISP*

     .   OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(7)  = FUN(7)  + WGHT*FDISP*

     .   OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(8)  = FUN(8)  + WGHT*FDISP*

     .   OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(9)  = FUN(9)  + WGHT*FDISP*

     .   OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(10) = FUN(10)  + WGHT*FDISP*

     .   OPEMO2(DFIM2,DFIM1,X)

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1)  = FUN(1)  + WGHT*

     .          FDISP*OSCS(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(2)  = FUN(2)  + WGHT*

     .          FDISP*OSCT(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(3)  = FUN(3)  + WGHT*

     .          FDISP*OSCO(DFIM2,DFIM1,X)

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1)  = FUN(1)  + WGHT*

     .          FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(2)  = FUN(2)  + WGHT*

     .          FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      FUN(3)  = FUN(3)  + WGHT*

     .          FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

      ENDIF

C

C     IF(KIND.EQ.5) THEN: NOT ALLOWED!

C

      IF(KIND.EQ.6) THEN

      FUN(1)  = FUN(1)  + WGHT*

     .          FDISP*OAXC(FIM2,DFIM1,DDFIM1,X)

      FUN(2)  = FUN(2)  + WGHT*

     .          FDISP*OAXS(FIM2,DFIM1,DDFIM1,X)

      FUN(3)  = FUN(3)  + WGHT*

     .          FDISP*OAXT(FIM2,DFIM1,DDFIM1,X)

      ENDIF

C

110   CONTINUE

100   CONTINUE



CC

C     PRINT 99, KIND,X,AM1,AM2,ALM1,ALM2,(FUN(II),II=1,12)

C99   FORMAT(/,' IN DKBFUN: KIND=',I2,' X=',F10.3,/,

C    .'  AM1,AM2=',2(F10.3,3X),'  ALM1,ALM2=',2(F10.3,3X),/,

C    .       /,' IN DKBFUN: FUN(II)=',/,5(D10.3,3X),/)

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE DKBOOM(ITYP,X,AM1,AM2,ALM1,ALM2,DAM)

C **********************************************************************

C

C     FOR DOUBLE STRANGENESS EXCHANGE (KK, K-KSTAR, K-KAPPA, K-K**)

C     COMPUTATION 1/M-CONTRIBUTIONS FOR TWO-MESON EXCHANGE

C     NOTE: PARTICLE 1 IS THE KAON!

C

C     ITYP=1: PS-PS, ITYP=2: PS-VCT, ITYP=3: PS-SCA, ITYP=4: PS-DIF

C     WARNING: ITYP=5 NOT YET IMPLEMENTED!

C *********************************************************************

C

C     NON-ADIABATIC DENOMINATOR (A LA EQ. (5.1)):

C                         1    D^2  [        A            1

C       D(//)^(1)=   --------- ---- [ --------------- ---------

C                    4 OM1 OM2 DA^2 [ (OM1+A) (OM2+A) OM1 + OM2

C

C                                 1         1     ]

C                           + --------- --------- ] = - D(X)^(1)/2

C                             (OM1 + A) (OM2 + A) ]

C ---------------------------------------------------------------------

C

C     PV-VERTEX CORRECTION DENOMINATOR (A LA EQ. (5.6)):

C                              1          [        2A     ]

C       D(PV)^(1)=  -------------------   [ 1 + --------- ]

C                   2 (OM1+A)^2 (OM2+A)^2 [     OM1 + OM2 ]

C

C     WHICH COINCIDE WITH FUNCTIONS COMPUTED BY FOOM FOR A-> 0!

C

C     A = DAM/PIM = HYPERON-NUCLEON MASS DIFFERENCE

C

C     WE COMPUTE IN THIS ROUTINE:

C

C  1) ITYPE=1 (PS-PS):

C  1A FNONC: -F.T. (K1.K2)^3 D//^(1)

C     FNONS: -F.T. (K1.K2) SIG1.(K1XK2) SIG2.(K1XK2) D(//)^(1)

C     FNONT: -F.T. (K1.K2) SIG1.(K1XK2) SIG2.(K1XK2) D(//)^(1)

C     FNONO: +F.T. (K1.K2) i*(SIG1+SIG2).(K1XK2) Q.(K1-K2) D(//)^(1)

C  1B FPVC : +F.T. (K1.K2) (K1^2+K2^2) D(PV)^(1)

C     FPVO : +F.T. i*(SIG1+SIG2).[QX ......] D(PV)^(1)

C

C  2) ITYPE=2,3,4 (PS-VCT,PS-SCAL,PS-DIFF):

C  2A FNONS,FNONT: +F.T. (K1.K2) SIG1.K1 SIG2.K1 D(//)^(1)

C  2B FPVS ,FPVT : -F.T. (SIG1.K1 SIG2.K2+SIG1.K2 SIG2.K1) D(PV)^(1)

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      DIMENSION XX(20),WW(20),YB(3)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/

      SAVE XX,WW,AA,AA2



C

C     CONSTRUCTION BASE FUNCTIONS FOR PS-PS-EXCHANGE:

C

C     ITYP=1:

      FNONC1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = +0.5D0*(

     .  6*(D2F-D1F/XH)*(D2G-D1G/XH)/XH/XH+D3F*D3G)

      FNONS1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = -(1.D0/3.D0)*(

     .  (D2F-D1F/XH-XH*D3F)*(D2G-D1G/XH-XH*D3G)/XH/XH-D3F*D3G)

      FNONT1(D1F,D2F,D3F,D1G,D2G,D3G,XH) = +(2.D0/3.D0)*(

     .  (D2F-D1F/XH-XH*D3F/4)*(D2G-D1G/XH-XH*D3G/4)/XH/XH

     .  -D3F*D3G/16.D0)

      FNONO1(D1F,D2F,D1G,D2G,XH) = -2*

     .  (D2F-D1F/XH)*(D2G-D1G/XH)/XH/XH

      FPVC1(D1F,D2F,D3F,D1G,XH) =

     .  (-2*D1F/XH/XH+2*D2F/XH+D3F)*D1G

      FPVO1(D1F,D2F,D1G,D2G,XH) =

     .  2*(D1F*D2G+D2F*D1G)/XH+4*D1F*D1G/XH/XH



C     ITYP=2,3,4:

      FNONS2(D1F,D2F,D3F,D1G,XH) = +(1.D0/6.D0)*

     .  (D3F+2*D2F/XH-2*D1F/XH/XH)*D1G

      FNONT2(D1F,D2F,D3F,D1G,XH) = +(1.D0/6.D0)*

     .  (D3F-  D2F/XH+  D1F/XH/XH)*D1G

      FPVS2(D1F,D1G,XH) = +D1F*D1G/3.D0

      FPVT2(D1F,D1G,XH) = +D1F*D1G/3.D0

C     ITYP=5:

      FNONC5(D1F,D1G,XH) = +0.5D0*D1F*D1G

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

        AA   =DAM/PIM

      IF(ICALL.EQ.0) THEN

        AA2  =AA*AA

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

CC

      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1

      DDVKU1=-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1)



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2

      DDVKU2=-0.5D0*(ALM2/PIM)**2*(VKU2+X*DVKU2)

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      FNONC=0.D0

      FNONS=0.D0

      FNONT=0.D0

      FNONO=0.D0

      FPVC =0.D0

      FPVS =0.D0

      FPVT =0.D0

      FPVO =0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

      FDISP = FDISP1*FDISP2

      GEW = GEW*FDISP

C

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM



      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2

      D3FIM =+(DFIM-2* DVKU1)*X2-2*(FIM-2* VKU1)*X3-(AM/PIM)*DDHIM

     .       -(DDFIM-2*DDVKU1)*X1+  (DFIM-2*DVKU1)*X2



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

      D3FIM1   = D3FIM

C

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM



      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2

      D3FIM =+(DFIM-2* DVKU2)*X2-2*(FIM-2* VKU2)*X3-(AM/PIM)*DDHIM

     .       -(DDFIM-2*DDVKU2)*X1+  (DFIM-2*DVKU2)*X2



      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

      D3FIM2   = D3FIM

C

C     NON-ADIABATIC INTEGRALS:

      WGHT= GEW*AA*(AA2-3*Y**2)/(Y*Y+AA2)**3

      IF(ITYP.EQ.1) THEN

      FNONC = FNONC + WGHT*

     .        FNONC1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X)

      FNONS = FNONS + WGHT*

     .        FNONS1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X)

      FNONT = FNONT + WGHT*

     .        FNONT1(DFIM1,DDFIM1,D3FIM1,DFIM2,DDFIM2,D3FIM2,X)

      FNONO = FNONO + WGHT*

     .        FNONO1(DFIM1,DDFIM1,DFIM2,DDFIM2,X)

      ENDIF

      IF(ITYP.GE.2 .AND. ITYP.LE.4) THEN

      FNONS = FNONS + WGHT*

     .        FNONS2(DFIM1,DDFIM1,D3FIM1,DFIM2,X)

      FNONT = FNONT + WGHT*

     .        FNONT2(DFIM1,DDFIM1,D3FIM1,DFIM2,X)

      ENDIF

      IF(ITYP.EQ.5) THEN

      FNONC = FNONC + WGHT*FNONC5(DFIM1,DFIM2,X)

      ENDIF



C     PV-VERTEX CORRECTION INTEGRALS:

      WGHT= GEW*2*AA*Y**2/(Y*Y+AA2)**2

      IF(ITYP.EQ.1) THEN

      FPVC  = FPVC  + WGHT*(

     .        FPVC1(DFIM1,DDFIM1,D3FIM1,DFIM2,X) +

     .        FPVC1(DFIM2,DDFIM2,D3FIM2,DFIM1,X) )

      FPVO  = FPVO  + WGHT*

     .        FPVO1(DFIM1,DDFIM1,DFIM2,DDFIM2,X)

      ENDIF

      IF(ITYP.GE.2 .AND. ITYP.LE.4) THEN

      FPVS  = FPVS  + WGHT*FPVS2(DFIM1,DFIM2,X)

      FPVT  = FPVT  + WGHT*FPVT2(DFIM1,DFIM2,X)

      ENDIF

C

110   CONTINUE

100   CONTINUE



CC

10000 CALL ERRSET(208,256,1,1)

      RETURN

      END





C **********************************************************************

      SUBROUTINE YNFUN2(KIND,X,AM1,AM2,ALM1,ALM2,DAMB,IYEX,FUN)

C

C   THIS ROUTINE IS FOR THE CASE OF ONE(!) MESON CARRYING STRANGENESS,

C   THIS IS EITHER MESON1(IYEX=1) OR MESON2(IYEX=2).

C   VERSION: 23 FEBRUARI, 1996

C **********************************************************************

C

C     THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN ; YNPSBE.FORTRAN

C     IT IS UNDERSTOOD THAT INDEX 1 REFERS TO THE PS-EXCHANGE (PION ETC.

C

C     COMPUTES THE FOURIER TRANSFORMS OF D, WHERE

C

C               1     |      1           1     |    1

C   2*D =  ---------- |  --------- + --------- |. -----

C          2 OM1.OM2  |  OM1+OM2-A   OM1+OM2+A |  OM1^2

C

C            1   (OM2^2 + A^2)      1

C        + ----- ---------------. -----  , D_{//}=-D_{X} = D

C           OM2  (OM2^2 + A^2)^2  OM1^2

C

C     FOR VARIOUS COMBINATIONS OF DERIVATIVES.

C

C     NOTICE: THIS CORRESPONDS TO YNFUN(....) FOR THE LIMIT DAM=0.D0!

C

C     KIND = 1: PION-VECTOR-,   KIND = 2: PION-SCALAR-,

C     KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE.

C

C     SCHEMATICALLY:

C     PION-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT1

C     FUN(4) = OPAEMO  FUN(5) = OPAMMC  FUN(6) = OPAMMS

C     FUN(7) = OPAMMT  FUN(8) = OPAEMS2 FUN(9) = OPAEMT2

C     FUN(10)= OPAEMO2 FUN(11)= OCREES  FUN(12)= OCREET 

C     PION-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C     PION-PSSCALAR EXCHANGE:

C     FUN(1) = OPSC    FUN(2) = OPSS    FUN(3) = OPST

C  !! NOTE: simplest def. of functions here, no k^2/M^2-terms!

C           in OPAEES etc.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Y)

      IMPLICIT COMPLEX*16 (Z)

***   COMPLEX*16 CDSQRT,DREAL,DIMAG

***   COMMON/MASSES/PIM,AMNC(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      DIMENSION XX(20),WW(20),YB(3),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/

      DATA PIM/138.041D0/,AMPRO/938.2796D0/

      DATA ZI/(0.D0,1.D0)/

      SAVE XX,WW,DAM

C

C     ACCORDING TO THE PAPER APPENDIX B,

C     DEFINITION STATEMENT OPERATORS:

C

C 1)  PION-VECTOR EXCHANGE:

      OPAEES(FF,D1G,D2G,XH)=  2*FF*(2*D1G/XH+D2G)/3.D0

      OPAEET(FF,D1G,D2G,XH)= -2*FF*(D1G/XH-D2G)/3.D0

      OCREES(FF,D1G,D2G,XH)=

     .OPAEES(FF,D1G,D2G,XH)

      OCREET(FF,D1G,D2G,XH)=

     .OPAEET(FF,D1G,D2G,XH)



      OPAEMT(D1F,D1G,D2G,XH)=  2*D1F*(D1G/XH-D2G)/XH

      OPAEMO(D1F,D1G,XH)=  4*D1F*D1G/XH/XH

      OPEMS2(D1F,D2F,D1G,D2G,XH)=(2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0

      OPEMT2(D1F,D2F,D1G,D2G,XH)=(D1F/XH-D2F)*(D1G/XH-D2G)/3.D0

      OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH               



      OPAMMC(D1F,D2F,D1G,D2G,XH)=

     .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH

      OPAMMS(D1F,D2F,D1G,D2G,XH)=

     .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0

      OPAMMT(D1F,D2F,D1G,D2G,XH)=

     .-(D1F/XH+D2F)*(D1G/XH-D2G)/3.D0+2*(D1F/XH-D2F)*D1G/XH/3.D0



C 2)  PION-SCALAR EXCHANGE:

      OSCS(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0

      OSCT(FF,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0

      OSCO(D1F,D1G,XH)= 0.D0



C 3)  PION-PSEUDO-SCALAR EXCHANGE:

      OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G)

      OPSS(D1F,D2F,D1G,D2G,XH)= 4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0

      OPST(D1F,D2F,D1G,D2G,XH)= 2*( (D1F/XH-D2F)*D1G/XH +

     . (D1G/XH-D2G)*D1F/XH )/3.D0

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

      ZF0(ZERATH,ZEXH,ZEMH,ZEPH,XH)=ZERATH*(ZEMH/ZEXH-ZEPH*ZEXH)/(2*XH)

      ZH0(ZERATH,ZEXH,ZEMH,ZEPH,XH)=ZERATH*(ZEMH/ZEXH+ZEPH*ZEXH)/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        DAM = DAMB/PIM

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

CC

      DAMB1 = DAM*(2-IYEX)

      DAMB2 = DAM*(IYEX-1)

      IF(IYEX.EQ.1) FDISA=FDEXP(DAMB**2/ALM1**2)

      IF(IYEX.EQ.2) FDISA=FDEXP(DAMB**2/ALM2**2)



      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2



      BM1 = DSQRT(AM1**2-DAMB1**2)

      XA   =X*BM1/PIM

      RATA =BM1/ALM1

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM1 +RATA)

      EPA  =FDERFC( XLM1 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU1)*X1-(BM1/PIM)*HIA

      DHIA  =-(BM1/PIM)*FIA -HIA *X1

      DDFIA  =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(BM1/PIM)*DHIA

      FI1= FIA

      DFI1= DFIA

      DDFI1= DDFIA



      IF(KIND.NE.4) THEN

      BM2 = DSQRT(AM2**2-DAMB2**2)

      XA   =X*BM2/PIM

      RATA =BM2/ALM2

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM2 +RATA)

      EPA  =FDERFC( XLM2 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU2)*X1-(BM2/PIM)*HIA

      DHIA  =-(BM2/PIM)*FIA -HIA *X1

      DDFIA  =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(BM2/PIM)*DHIA

      DDHIA =-(BM2/PIM)*DFIA-DHIA*X1+HIA*X2

C     D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(BM2/PIM)*DDHIA

C    .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

C     D3HIA =-(BM2/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3



      F4A   = 0.5D0*(PIM/BM2)*X*HIA

      DF4A  = 0.5D0*(PIM/BM2)*(HIA+X*DHIA)

      DDF4A = 0.5D0*(PIM/BM2)*(2*DHIA+X*DDHIA)

C     D3F4A  = 0.5D0*(PIM/BM2)*(3*DDHIA+X*D3HIA)

      ENDIF

      IF(KIND.EQ.4) THEN

      XA   =X*AM2/PIM

      FIA  =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA)

      DFIA  = -2*(AM2/PIM)*XA*FIA

      DDFIA = -2*(AM2/PIM)*(XA*DFIA + DFIA*AM2/PIM)

C     D3FIA = -2*(AM2/PIM)*(XA*DDFIA + 2*DFIA*AM2/PIM)

      RATD  = 0.5D0*PIM/AM2

      F4A  = FIA*RATD**2

      DF4A = DFIA*RATD**2

      DDF4A= DDFIA*RATD**2

C     D3F4A= D3FIA*RATD**2

      ENDIF

      FI2= FIA

      DFI2= DFIA

      DDFI2= DDFIA

      FI42= F4A

      DFI42= DF4A

      DDFI42= DDF4A

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,12

  105 FUN(IFUN) = 0.D0

      IF(KIND.EQ.1) THEN

      FUN(1) = 2*DAM*OPAEES(FI42,DFI1,DDFI1,X)*FDISA

      FUN(11)= 2*DAM*OCREES(FI42,DFI1,DDFI1,X)*FDISA

      FUN(2) = 2*DAM*OPAEET(FI42,DFI1,DDFI1,X)*FDISA

      FUN(12)= 2*DAM*OCREET(FI42,DFI1,DDFI1,X)*FDISA

      FUN(3) = 2*DAM*OPAEMT(DFI42,DFI1,DDFI1,X)*FDISA

      FUN(4) = 2*DAM*OPAEMO(DFI42,DFI1,X)*FDISA

      FUN(5) = 2*DAM*OPAMMC(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(6) = 2*DAM*OPAMMS(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(7) = 2*DAM*OPAMMT(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(8) = 2*DAM*OPEMS2(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(9) = 2*DAM*OPEMT2(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(10)= 2*DAM*OPEMO2(DFI42,DFI1,X)*FDISA

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1) = 2*DAM*OSCS(FI42,DFI1,DDFI1,X)*FDISA

      FUN(2) = 2*DAM*OSCT(FI42,DFI1,DDFI1,X)*FDISA

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1) = 2*DAM*OPSC(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(2) = 2*DAM*OPSS(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      FUN(3) = 2*DAM*OPST(DFI42,DDFI42,DFI1,DDFI1,X)*FDISA

      ENDIF

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*1.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110 

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

      FDISP = FDISP1*FDISP2

      ZDISP1= CDEXP(2*ZI*Y*DAM*RATP1**2)*FDISP1*FDEXP((DAM*RATP1)**2)

      ZDISP2= CDEXP(2*ZI*Y*DAM*RATP2**2)*FDISP2*FDEXP((DAM*RATP2)**2)

C

C     FIRST MESON:

C     REAL MESON MASS:

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM



C     COMPLEX MESON MASS:

       IF(IYEX.EQ.1) THEN

      ZAM=PIM*CDSQRT((BM1/PIM)**2+Y*Y+2*ZI*DAM*Y)

      ZXM=ZAM*X/PIM

      ZRATM =ZAM/ALM1

      ZERATM=ZDEXP(ZRATM*ZRATM)

      ZEXM  =ZDEXP(ZXM)

      ZEMM  =ZDERFC(-XLM1+ZRATM)

      ZEPM  =ZDERFC( XLM1+ZRATM)



      ZFIM   = ZF0(ZERATM,ZEXM,ZEMM,ZEPM,X )

      ZHIM   = ZH0(ZERATM,ZEXM,ZEMM,ZEPM,X )

      ZDFIM  =-(ZFIM-2*VKU1)*X1-(ZAM/PIM)*ZHIM

      ZDHIM  =-(ZAM/PIM)*ZFIM-ZHIM*X1

      ZDDFIM =-(ZDFIM-2*DVKU1)*X1+(ZFIM-2*VKU1)*X2-(ZAM/PIM)*ZDHIM

       ENDIF

C     END FIRST MESON

C

C     SECOND MESON:

      IF(KIND.NE.4) THEN

C     REAL MESON MASS:

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM



C     COMPLEX MESON MASS:

       IF(IYEX.EQ.2) THEN

      ZAM=PIM*CDSQRT((BM2/PIM)**2+Y*Y+2*ZI*DAM*Y)

      ZXM=ZAM*X/PIM

      ZRATM =ZAM/ALM2

      ZERATM=ZDEXP(ZRATM*ZRATM)

      ZEXM  =ZDEXP(ZXM)

      ZEMM  =ZDERFC(-XLM2+ZRATM)

      ZEPM  =ZDERFC( XLM2+ZRATM)



      ZFIM   = ZF0(ZERATM,ZEXM,ZEMM,ZEPM,X )

      ZHIM   = ZH0(ZERATM,ZEXM,ZEMM,ZEPM,X )

      ZDFIM  =-(ZFIM-2*VKU2)*X1-(ZAM/PIM)*ZHIM

      ZDHIM  =-(ZAM/PIM)*ZFIM-ZHIM*X1

      ZDDFIM =-(ZDFIM-2*DVKU2)*X1+(ZFIM-2*VKU2)*X2-(ZAM/PIM)*ZDHIM

       ENDIF

      ENDIF

      IF(KIND.EQ.4) THEN

      FIM = FI2

      DFIM = DFI2

      DDFIM = DDFI2

       IF(IYEX.EQ.2) THEN

      ZFIM = FI2

      ZDFIM = DFI2

      ZDDFIM = DDFI2

       ENDIF

      ENDIF

      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

C     END SECOND MESON



       IF(IYEX.EQ.2) THEN

C     FOR THE FIRST CONTRIBUTION:

      GEW1 = 0.5D0*GEW/Y**2

      GIM1 = (FI1-FDISP1*FIM1)

      DGIM1 = (DFI1-FDISP1*DFIM1)

      DDGIM1 = (DDFI1-FDISP1*DDFIM1)

      GIM2 = 2*DREAL(ZDISP2*ZFIM)

      DGIM2 = 2*DREAL(ZDISP2*ZDFIM)

      DDGIM2 = 2*DREAL(ZDISP2*ZDDFIM)

C     FOR THE SECOND CONTRIBUTION:

      GEW2 = ((Y*Y-DAM*DAM)/(Y*Y+DAM*DAM)**2)*GEW

      DFIM1 = DFI1

      DDFIM1 = DDFI1

      FIM2 = (FDISA*FI2-FDISP2*FIM2)

      DFIM2 = (FDISA*DFI2-FDISP2*DFIM2)

      DDFIM2 = (FDISA*DDFI2-FDISP2*DDFIM2)

       ENDIF

       IF(IYEX.EQ.1) THEN

C     FOR THE FIRST CONTRIBUTION:

      GEW1 = 0.5D0*GEW/Y**2

      GIM2 = (FI2-FDISP2*FIM2)

      DGIM2 = (DFI2-FDISP2*DFIM2)

      DDGIM2 = (DDFI2-FDISP2*DDFIM2)

      GIM1 = 2*DREAL(ZDISP1*ZFIM)

      DGIM1 = 2*DREAL(ZDISP1*ZDFIM)

      DDGIM1 = 2*DREAL(ZDISP1*ZDDFIM)

C     FOR THE SECOND CONTRIBUTION:

      GEW2 = ((Y*Y-DAM*DAM)/(Y*Y+DAM*DAM)**2)*GEW

      DFIM1 = (FDISA*DFI1-FDISP1*DFIM1)

      DDFIM1 = (FDISA*DDFI1-FDISP1*DDFIM1)

      FIM2 = FI2

      DFIM2 = DFI2

      DDFIM2 = DDFI2

       ENDIF

C

      IF(KIND.EQ.1) THEN

      FUN(1)  = FUN(1)  + GEW2*OPAEES(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAEES(GIM2,DGIM1,DDGIM1,X)

      FUN(11) = FUN(11) + GEW2*OCREES(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OCREES(GIM2,DGIM1,DDGIM1,X)

      FUN(2)  = FUN(2)  + GEW2*OPAEET(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAEET(GIM2,DGIM1,DDGIM1,X)

      FUN(12) = FUN(12) + GEW2*OCREET(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OCREET(GIM2,DGIM1,DDGIM1,X)

      FUN(3)  = FUN(3)  + GEW2*OPAEMT(DFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAEMT(DGIM2,DGIM1,DDGIM1,X)

      FUN(4)  = FUN(4)  + GEW2*OPAEMO(DFIM2,DFIM1,X)

     .                  + GEW1*OPAEMO(DGIM2,DGIM1,X)

      FUN(5)  = FUN(5)  + GEW2*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAMMC(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(6)  = FUN(6)  + GEW2*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAMMS(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(7)  = FUN(7)  + GEW2*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPAMMT(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(8)  = FUN(8)  + GEW2*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPEMS2(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(9)  = FUN(9)  + GEW2*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPEMT2(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(10) = FUN(10) + GEW2*OPEMO2(DFIM2,DFIM1,X)

     .                  + GEW1*OPEMO2(DGIM2,DGIM1,X)

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1)  = FUN(1)  + GEW2*OSCS(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OSCS(GIM2,DGIM1,DDGIM1,X)

      FUN(2)  = FUN(2)  + GEW2*OSCT(FIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OSCT(GIM2,DGIM1,DDGIM1,X)

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1)  = FUN(1)  + GEW2*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPSC(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(2)  = FUN(2)  + GEW2*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPSS(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      FUN(3)  = FUN(3)  + GEW2*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X)

     .                  + GEW1*OPST(DGIM2,DDGIM2,DGIM1,DDGIM1,X)

      ENDIF

C

110   CONTINUE

100   CONTINUE

C

C     CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1)

C

      IF(IMETH.EQ.0) THEN

      YMAX = YB(NINT+1)

      YFAC2 = YMAX/(YMAX**2+DAM**2)*FDISA

      IF(KIND.EQ.1) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OPAEES(FI2,DFI1,DDFI1,X)*YFAC2

      FUN(11)= FUN(11)+(1.D0/PI)*OCREES(FI2,DFI1,DDFI1,X)*YFAC2

      FUN(2) = FUN(2)+(1.D0/PI)*OPAEET(FI2,DFI1,DDFI1,X)*YFAC2

      FUN(12)= FUN(2)+(1.D0/PI)*OCREET(FI2,DFI1,DDFI1,X)*YFAC2

      FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)*YFAC2

      FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)*YFAC2

      FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)*YFAC2

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OSCS(FI2,DFI1,DDFI1,X)*YFAC2

      FUN(2) = FUN(2)+(1.D0/PI)*OSCT(FI2,DFI1,DDFI1,X)*YFAC2

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)*YFAC2

      ENDIF

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END



C **********************************************************************

      SUBROUTINE YNFUN3(ITYPE,KIND,X,AM1,AM2,ALM1,ALM2,DAMB,FUN)

C

C   THIS ROUTINE IS FOR THE CASE OF TWO(!) MESONS CARRYING STRANGENESS,

C   FUNCTIONS FOR KAON-KAON EXCHANGE ETC. , AM1=AM2= AMK= KAON MASS

C   VERSION: 23 FEBRUARI, 1996

C **********************************************************************

C

C     THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN.C

C     IT IS UNDERSTOOD THAT AM1=PIM, SO INDEX 1 REFERS TO THE PION.

C     NOTICE: IN THIS ROUTINE ITYPE=1 (PLANAR) AND ITYPE=2(CROSSED)

C

C     COMPUTES THE FOURIER TRANSFORMS OF D_{X} AND D_{//}, WHERE

C

C     1) ITYPE=2: KAON-KAON EXCHANGE (CROSSED):

C

C                   1                1

C   -2* D_{X} = + --------  ---------------------- .

C                OM1.OM2  (OM1^2-A^2)(OM2^2-A^2)

C

C                 |                              1     |

C               X |(OM1+OM2) - (OM1.OM2+A^2) --------- |

C                 |                          OM1 + OM2 |

C

C     2) ITYPE=1: KAON-KAON EXCHANGE (PLANAR):

C

C                    2 A^2             |      1

C  2* D_{//}= ---------------------- . | --------------

C             (OM1^2-A^2)(OM2^2-A^2)   | OM2(OM2^2-A^2)

C

C                   1                   1        |

C           + -------------- + ------------------| - 2* D_{X}

C             OM1(OM1^2-A^2)   OM1.OM2(OM1 + OM2)|

C

C     FOR VARIOUS COMBINATIONS OF DERIVATIVES.

C

C     NOTICE: THE SAME AS YNFUN IN THE LIMIT DAM=0.D0 !

C

C     KIND = 1: PION-VECTOR-,   KIND = 2: PION-SCALAR-,

C     KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE.

C

C     SCHEMATICALLY:

C     PION-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT1

C     FUN(4) = OPAEMO  FUN(5) = OPAMMC  FUN(6) = OPAMMS

C     FUN(7) = OPAMMT  FUN(8) = OPAEMS2 FUN(9) = OPAEMT2

C     FUN(10)= OPAEMO2 FUN(11)= OCREES  FUN(12)= OCREET 

C     PION-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C     PION-PSSCALAR EXCHANGE:

C     FUN(1) = OPSC    FUN(2) = OPSS    FUN(3) = OPST

C  !! NOTE: simplest def. of functions here, no k^2/M^2-terms!

C           in OPAEES etc.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

***   COMMON/MASSES/PIM,AMNC(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      DIMENSION XX(20),WW(20),YB(3),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/

      DATA PIM/138.041D0/,AMPRO/938.2796D0/

      SAVE XX,WW,DAM

C

C     ACCORDING TO THE PAPER APPENDIX B,

C     DEFINITION STATEMENT OPERATORS:

C

C 1)  PION-VECTOR EXCHANGE:

      OPAEES(FF,D1G,D2G,XH)=  2*FF*(2*D1G/XH+D2G)/3.D0

      OPAEET(FF,D1G,D2G,XH)= -2*FF*(D1G/XH-D2G)/3.D0

      OCREES(FF,D1G,D2G,XH)=

     .OPAEES(FF,D1G,D2G,XH)

      OCREET(FF,D1G,D2G,XH)=

     .OPAEET(FF,D1G,D2G,XH)



      OPAEMT(D1F,D1G,D2G,XH)=  2*D1F*(D1G/XH-D2G)/XH

      OPAEMO(D1F,D1G,XH)=  4*D1F*D1G/XH/XH

      OPEMS2(D1F,D2F,D1G,D2G,XH)=(2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0

      OPEMT2(D1F,D2F,D1G,D2G,XH)=(D1F/XH-D2F)*(D1G/XH-D2G)/3.D0

      OPEMO2(D1F,D1G,XH)= 2*D1F*D1G/XH/XH               



      OPAMMC(D1F,D2F,D1G,D2G,XH)=

     .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH

      OPAMMS(D1F,D2F,D1G,D2G,XH)=

     .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0

      OPAMMT(D1F,D2F,D1G,D2G,XH)=

     .-(D1F/XH+D2F)*(D1G/XH-D2G)/3.D0+2*(D1F/XH-D2F)*D1G/XH/3.D0



C 2)  PION-SCALAR EXCHANGE:

      OSCS(FF,D1G,D2G,XH)= +FF*(2*D1G/XH+D2G)/3.D0

      OSCT(FF,D1G,D2G,XH)= -FF*(D1G/XH-D2G)/3.D0

      OSCO(D1F,D1G,XH)= 0.D0



C 3)  PION-PSEUDO-SCALAR EXCHANGE:

      OPSC(D1F,D2F,D1G,D2G,XH)= (2*D1F*D1G/XH/XH+D2F*D2G)

      OPSS(D1F,D2F,D1G,D2G,XH)= 2*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0

      OPST(D1F,D2F,D1G,D2G,XH)= 1*( (D1F/XH-D2F)*D1G/XH +

     . (D1G/XH-D2G)*D1F/XH )/3.D0

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        DAM = DAMB/PIM

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

CC

      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2



      BM1 = DSQRT(AM1**2-DAMB**2)

      XA   =X*BM1/PIM

      RATA =BM1/ALM1

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM1 +RATA)

      EPA  =FDERFC( XLM1 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU1)*X1-(BM1/PIM)*HIA

      DHIA  =-(BM1/PIM)*FIA -HIA *X1

      DDFIA  =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(BM1/PIM)*DHIA

      DDHIA =-(BM1/PIM)*DFIA-DHIA*X1+HIA*X2

C     D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(BM1/PIM)*DDHIA

C    .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

C     D3HIA =-(BM1/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3

      F4A   = 0.5D0*(PIM/BM1)*X*HIA

      DF4A  = 0.5D0*(PIM/BM1)*(HIA+X*DHIA)

      DDF4A = 0.5D0*(PIM/BM1)*(2*DHIA+X*DDHIA)

C     D3F4A  = 0.5D0*(PIM/BM1)*(3*DDHIA+X*D3HIA)



      FI1= FIA

      DFI1= DFIA

      DDFI1= DDFIA

      FI41= F4A

      DFI41= DF4A

      DDFI41= DDF4A



      IF(KIND.NE.4) THEN

      BM2 = DSQRT(AM2**2-DAMB**2)

      XA   =X*BM2/PIM

      RATA =BM2/ALM2

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM2 +RATA)

      EPA  =FDERFC( XLM2 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU2)*X1-(BM2/PIM)*HIA

      DHIA  =-(BM2/PIM)*FIA -HIA *X1

      DDFIA  =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(BM2/PIM)*DHIA

      DDHIA =-(BM2/PIM)*DFIA-DHIA*X1+HIA*X2



      F4A   = 0.5D0*(PIM/BM2)*X*HIA

      DF4A  = 0.5D0*(PIM/BM2)*(HIA+X*DHIA)

      DDF4A = 0.5D0*(PIM/BM2)*(2*DHIA+X*DDHIA)

      ENDIF

      IF(KIND.EQ.4) THEN

      XA   =X*AM2/PIM

      FIA  =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA)

      DFIA  = -2*(AM2/PIM)*XA*FIA

      DDFIA = -2*(AM2/PIM)*(XA*DFIA + DFIA*AM2/PIM)

C     D3FIA = -2*(AM2/PIM)*(XA*DDFIA + 2*DFIA*AM2/PIM)

      RATD  = 0.5D0*PIM/AM2

      F4A  = FIA*RATD**2

      DF4A = DFIA*RATD**2

      DDF4A= DDFIA*RATD**2

C     D3F4A= D3FIA*RATD**2

      ENDIF

      FI2= FIA

      DFI2= DFIA

      DDFI2= DDFIA

      FI42= F4A

      DFI42= DF4A

      DDFI42= DDF4A

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,12

  105 FUN(IFUN) = 0.D0

      FDISA=FDEXP(+DAM**2*RATP1**2)*FDEXP(+DAM**2*RATP2**2)

      IF(ITYPE.EQ.1) THEN

      IF(KIND.EQ.1) THEN

      FUN(1)  =  1*DAM*(OPAEES(FI42,DFI1,DDFI1,X)

     .               +OPAEES(FI2,DFI41,DDFI41,X))*FDISA

      FUN(11) =  1*DAM*(OCREES(FI42,DFI1,DDFI1,X)

     .               +OCREES(FI2,DFI41,DDFI41,X))*FDISA

      FUN(2)  =  1*DAM*(OPAEET(FI42,DFI1,DDFI1,X)

     .               +OPAEET(FI2,DFI41,DDFI41,X))*FDISA

      FUN(12) =  1*DAM*(OCREET(FI42,DFI1,DDFI1,X)

     .               +OCREET(FI2,DFI41,DDFI41,X))*FDISA

      FUN(3)  =  1*DAM*(OPAEMT(DFI42,DFI1,DDFI1,X)

     .               +OPAEMT(DFI2,DFI41,DDFI41,X))*FDISA

      FUN(4)  =  1*DAM*(OPAEMO(DFI42,DFI1,X)

     .               +OPAEMO(DFI2,DFI41,X))*FDISA

      FUN(5)  =  1*DAM*(OPAMMC(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPAMMC(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(6)  =  1*DAM*(OPAMMS(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPAMMS(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(7)  =  1*DAM*(OPAMMT(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPAMMT(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(8)  =  1*DAM*(OPEMS2(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPEMS2(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(9)  =  1*DAM*(OPEMT2(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPEMT2(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(10) =  1*DAM*(OPEMO2(DFI42,DFI1,X)

     .               +OPEMO2(DFI2,DFI41,X))*FDISA

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1)  =  1*DAM*(OSCS(FI42,DFI1,DDFI1,X)

     .               +OSCS(FI2,DFI41,DDFI41,X))*FDISA

      FUN(2)  =  1*DAM*(OSCT(FI42,DFI1,DDFI1,X)

     .               +OSCT(FI2,DFI41,DDFI41,X))*FDISA

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1)  =  1*DAM*(OPSC(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPSC(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(2)  =  1*DAM*(OPSS(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPSS(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      FUN(3)  =  1*DAM*(OPST(DFI42,DDFI42,DFI1,DDFI1,X)

     .               +OPST(DFI2,DDFI2,DFI41,DDFI41,X))*FDISA

      ENDIF

      ENDIF

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*1.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110 

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

      FDISP = FDISP1*FDISP2

C

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

C

      IF(KIND.NE.4) THEN

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM



      ENDIF

      IF(KIND.EQ.4) THEN

      FIM = FI2

      DFIM = DFI2

      DDFIM = DDFI2

      ENDIF

      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM



      IF(ITYPE.EQ.1) GEWH = GEW*(Y**2+3*DAM**2)/(Y**2+DAM**2)**2

      IF(ITYPE.EQ.2) GEWH = +GEW/(Y**2+DAM**2)

C

      IF(KIND.EQ.1) THEN

      FUN(1)  = FUN(1)  + GEWH*(FDISA*OPAEES(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAEES(FIM2,DFIM1,DDFIM1,X))

      FUN(11) = FUN(11) + GEWH*(FDISA*OCREES(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OCREES(FIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEWH*(FDISA*OPAEET(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAEET(FIM2,DFIM1,DDFIM1,X))

      FUN(12) = FUN(12) + GEWH*(FDISA*OCREET(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OCREET(FIM2,DFIM1,DDFIM1,X))

      FUN(3)  = FUN(3)  + GEWH*(FDISA*OPAEMT(DFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAEMT(DFIM2,DFIM1,DDFIM1,X))

      FUN(4)  = FUN(4)  + GEWH*(FDISA*OPAEMO(DFI2,DFI1,X)

     .                  -FDISP*OPAEMO(DFIM2,DFIM1,X))

      FUN(5)  = FUN(5)  + GEWH*(FDISA*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(6)  = FUN(6)  + GEWH*(FDISA*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(7)  = FUN(7)  + GEWH*(FDISA*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(8)  = FUN(8)  + GEWH*(FDISA*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(9)  = FUN(9)  + GEWH*(FDISA*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(10) = FUN(10) + GEWH*(FDISA*OPEMO2(DFI2,DFI1,X)

     .                  -FDISP*OPEMO2(DFIM2,DFIM1,X))

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1)  = FUN(1)  + GEWH*(FDISA*OSCS(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OSCS(FIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEWH*(FDISA*OSCT(FI2,DFI1,DDFI1,X)

     .                  -FDISP*OSCT(FIM2,DFIM1,DDFIM1,X))

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1)  = FUN(1)  + GEWH*(FDISA*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEWH*(FDISA*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(3)  = FUN(3)  + GEWH*(FDISA*OPST(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      ENDIF

C

110   CONTINUE

100   CONTINUE

C

C     CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1)

C

      IF(IMETH.EQ.0) THEN

      YMAX = YB(NINT+1)

      IF(DAM.EQ.0.D0) YFACH = 1.D0/YMAX

      IF(DAM.NE.0.D0) THEN

      IF(ITYPE.EQ.1) YFACH=+(PI-2*DATAN(YMAX/DAM))/DAM

     .                     -YMAX/(YMAX**2+DAM**2)

      IF(ITYPE.EQ.2) YFACH=+(PI/2.D0-DATAN(YMAX/DAM))/DAM

      ENDIF

      YFACH = FDISA*YFACH

      IF(KIND.EQ.1) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OPAEES(FI2,DFI1,DDFI1,X)*YFACH

      FUN(11)= FUN(11)+(1.D0/PI)*OCREES(FI2,DFI1,DDFI1,X)*YFACH

      FUN(2) = FUN(2)+(1.D0/PI)*OPAEET(FI2,DFI1,DDFI1,X)*YFACH

      FUN(12)= FUN(12)+(1.D0/PI)*OCREET(FI2,DFI1,DDFI1,X)*YFACH

      FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)*YFACH

      FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)*YFACH

      FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)*YFACH

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OSCS(FI2,DFI1,DDFI1,X)*YFACH

      FUN(2) = FUN(2)+(1.D0/PI)*OSCT(FI2,DFI1,DDFI1,X)*YFACH

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)*YFACH

      ENDIF

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END



C**************************************************************

      FUNCTION ZDERFC(ZP)

C**************************************************************



      IMPLICIT REAL*8 (A-H,O-Y)

      COMPLEX*16 ZP,Z,IMA,ZDERFC,ZDEXP,Z2,WIZ

      INTEGER CAPN,NU,N,NP1

      REAL*8 H,H2,LAMBDA,R1,R2,S,S1,S2,T1,T2,C,REZ,IMZ,X,Y

      LOGICAL B

      DATA IMA/(0D0,1D0)/



      X =DREAL(IMA*ZP)

      Y =DIMAG(IMA*ZP)



C  FIRST QUADRANT:

      IF(X .GE.0.D0 .AND. Y .GE.0.D0) THEN

      ICASE = 1

      ENDIF

C  SECOND QUADRANT:

      IF(X .LT.0.D0 .AND. Y .GE.0.D0) THEN

      ICASE = 2

      X = -X

      ENDIF

C  THIRD QUADRANT:

      IF(X .LT.0.D0 .AND. Y .LT.0.D0) THEN

      ICASE = 3

      X = -X

      Y = -Y

      ENDIF

C  FOURTH QUADRANT:

      IF(X .GE.0.D0 .AND. Y .LT.0.D0) THEN

      ICASE = 4

      Y = -Y

      ENDIF



      Z = X + IMA*Y



C  SO: Z= X + IY ALWAYS IN FIRST QUADRANT -> APPLICATION

C  GAUTSCHI ALGORITHM

**

**    Ref. W. Gautschi, Algorithm 363, Communications of the

**    ACM Vol. 12 (1969) 635.

**

      B =.FALSE.

      COEF = 1.12837916709551D0



C     IF (X.LE.-4D0) GOTO 2



      IF ((Y.LT.4.29D0).AND.(X.LT.5.33D0)) THEN

        S = (1D0-Y/4.29D0)*DSQRT(1D0-X*X/28.41D0)

        H = 1.6 * S

        H2 = 2*H

        CAPN = 6 + 23*S

        LAMBDA = H2**CAPN

        NU = 9 + 21*S

      ELSE

        H = 0

        CAPN = 0

        NU = 8

      ENDIF

** lambda = 0 covers the underflow case when h > 0 is very small

      B = (H.EQ.0.OR.LAMBDA.EQ.0)

      R1 = 0D0

      R2 = 0D0

      S1 = 0D0

      S2 = 0D0

      DO 100 N =NU,0,-1

        NP1 = N + 1

        T1 = Y + H +NP1*R1

        T2 = X - NP1*R2

        C = 0.5D0/(T1*T1+T2*T2)

        R1=C*T1

        R2=C*T2

        IF (H.GT.0.AND.N.LE.CAPN) THEN

          T1 = LAMBDA+S1

          S1 = R1*T1-R2*S2

          S2=R2*T1+R1*S2

          LAMBDA=LAMBDA/H2

        ENDIF

 100  CONTINUE

      IF (Y.EQ.0) THEN

        XX = -X*X

        REZ = FDEXP(XX)

      ELSE

        IF (B) REZ = COEF *R1

        IF (.NOT.B) REZ = COEF*S1

      ENDIF

      IF (B) IMZ = COEF*R2

      IF (.NOT.B) IMZ = COEF*S2



      IF(ICASE.EQ.1) THEN

      WIZ  = REZ + IMA*IMZ

      ZDERFC = ZDEXP(-ZP*ZP)*WIZ

      ENDIF

      IF(ICASE.EQ.2) THEN

      WIZ  = REZ - IMA*IMZ

      ZDERFC = ZDEXP(-ZP*ZP)*WIZ

      ENDIF

      IF(ICASE.EQ.3) THEN

      ZDERFC = 2.D0 - (REZ + IMA*IMZ) * ZDEXP(-ZP*ZP)

      ENDIF

      IF(ICASE.EQ.4) THEN

      ZDERFC = 2.D0 - (REZ - IMA*IMZ) * ZDEXP(-ZP*ZP)

      ENDIF



      RETURN



C 1   ZDERFC=DCMPLX(0D0)

C     RETURN

C 2   ZDERFC=DCMPLX(2D0)

C     RETURN

      END



C**************************************************************

      FUNCTION ZDEXP(Z)

C**************************************************************

      IMPLICIT REAL*8(A-Y)

      COMPLEX*16  ZDEXP,IMA,Z

      IMA=(0D0,1D0)

      X =DREAL(Z)

      Y =DIMAG(Z)

      ZDEXP = FDEXP(X)*(DCOS(Y)+IMA*DSIN(Y))

      RETURN

      END





C **********************************************************************

C     ESCROMP2.F: ESCROMP1.F UPDATED TO INCLUDE ANTI-SYMMETRIC

C                 SPIN-ORBIT FOR PS-VECTOR

C **********************************************************************

      SUBROUTINE YNPSPS(X,INA,IPV,IOFF,NCSB,APV)

C **********************************************************************

C *

C *   DATE: JANUARY, 1995, UPDATED DECEMBER 1996 (REORGANIZED VECTORS)

C

C     version: january 1997, used in latest TOKYO version!

C

C *   YN-POTENTIALS FROM DOUBLE PSEUDO-SCALAR EXCHANGE

C *

C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION

C *               NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET

C *

C **********************************************************************

C     CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN):

C

C     IKIND=3, PSSCALAR-PSSCALAR EXCHANGE:

C     FUN(1) = OPSC    FUN(2) = OPSS    FUN(3) = OPST

C **********************************************************************

C

C     INCLUDED IN ENERGY DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT.

C     INCLUDED IN COUPLING-COMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/MODEL/IXXX(8),NSU3F

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD,

     .ALPA

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

C     COMMON/OOM/ INA,IPV,IOFF

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/PSBE/ 

     .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4)

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))



      CHARACTER *4 NTYPM(4)

      DATA NTYPM/'PI  ','KA  ','ETA ','ETAP'/

C

      DIMENSION FUN(12),FUNX(12)

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA IPIPI/1/,IPIET/1/,IPIETP/1/,IPIKA/1/,IKAKA/1/,

     .     IETA2/1/,IETKA/1/,IETETP/1/,IETPKA/1/,IETAP2/1/

      DATA N3/27/,FACT/70.D0/,DAM/230.D0/,ICALL/0/,ISFAC/1/,NSCHR/0/

     .,POLD/-12345.D0/,ISU3/0/,ICSB/0/

      SAVE FACT,DAM



      pim=pim0

      if(nsu3f.eq.1) then

      call su3sym(pim,amn,ampro,amro,ameps)

      dam = 0d0

      isu3= 1

      endif

C

      CALL ERRSET(208,256,-1,1)

C

  12  IF(ICALL.EQ.0) THEN

        FACT = PIM0/2.D0

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

*       ICSB = NCSB

        IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,ICSB

 52     FORMAT(//,'  IN YNPSPS: INA, IPV, IOFF=',3I3,' ICSB=',I2,//)

        IF(NSCHR.NE.0) PRINT 53, ALMP1,ALMP8,PIM,AMK,AME,AMX,DAM,APV

 53     FORMAT(/,' IN YNPSPS: ALMP1=',D10.3,' ALMP8=',D10.3,/,

     .  11X,' PIM, AMK, AME, AMX =',4(F10.3,2X),/,

     .  11X,'  DAM =',F10.3,' APV=',F12.5,/)

*       ICALL=1

      ENDIF



      if(pold.ne.p) then

      icall=0

      pold=p    

      nschr=1

      endif

C

C     XI-COUPLINGS:

      F12 = F1*(4*ALP-1.D0)/SR3

      F13 = -F1

C

C     CONSTRUCTION OF THE POTENTIALS

C

C     DO 1 I=2,NMAX

C     X = XA(I)

      VCNN =0.D0

      VSNN =0.D0

      VTNN =0.D0

      VCLL =0.D0

      VCLS =0.D0

      VCSS =0.D0

      VCDR =0.D0

      VSLL =0.D0

      VSLS =0.D0

      VSSS =0.D0

      VSDR =0.D0

      VTLL =0.D0

      VTLS =0.D0

      VTSS =0.D0

      VTDR =0.D0



      VOLL =0.D0

      VOLS =0.D0

      VOSS =0.D0

      VODR =0.D0



      DO 25 NCHAN=1,5

      DO 25 IPTYP=1,5

      DO 25 IPSI=1,4

      DO 25 IPSJ=1,4

   25 VPSPS(NCHAN,IPTYP,IPSI,IPSJ)=0.D0



      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)

     .CALL OMPSPS(X,INA,IPV,IOFF,ALP,APV)

      if(icall.eq.20.and.nschr.eq.1) then

c**   for check su3-symmetry:

**    write(N3,*) 'from YNPSPS: CALL OMPSPS TURNED OFF!!'

      write(N3,*) 'from OMPSPS: x=',x

      write(N3,*) 'vcll,vsll=',vcll,vsll

      write(N3,*) 'vcls,vsls=',vcls,vsls

      write(N3,*) 'vcss,vsss=',vcss,vsss

      write(N3,*) 'vcdr,vsdr=',vcdr,vsdr

      endif



C PION-PION EXCHANGE POTENTIALS:

      IF(IPIPI.EQ.1) THEN

C     PARALLEL:

      CPANN  =  1*(3-2*ISFAC)*F1**2*F1**2

      CPALL  =  1*3*F1*F1*F3*F3

      CPALS  =  1*2*SR3*F1*F1*F3*F2

      CPASS  =  1*F1*F1*(3*F3*F3+4*F2*F2)

      CPADR  =  +1*F1*F1*F2*F2

C     CROSSED:

      CCRNN  =  1*(3+2*ISFAC)*F1**2*F1**2

      CCRLL  =  1*3*F1*F1*F3*F3

      CCRLS  = -1*2*SR3*F1*F1*F3*F2

      CCRSS  =  -1*F1*F1*F3*F3

      CCRDR  =  1*F1*F1*(2*F3*F3+3*F2*F2)



*     CALL YNFUN(3,X,PIM,PIM,ALMP8,ALMP8,FUN)

      CALL YNFUN(3,X,AMPI,AMPI,ALMP8,ALMP8,FUN)



      VPSPS(1,1,1,1) = VPSPS(1,1,1,1) + FACT*( CPANN-CCRNN )*FUN(1)

      VPSPS(2,1,1,1) = VPSPS(2,1,1,1) + FACT*( CPALL-CCRLL )*FUN(1)

      VPSPS(3,1,1,1) = VPSPS(3,1,1,1) + FACT*( CPALS-CCRLS )*FUN(1)

      VPSPS(4,1,1,1) = VPSPS(4,1,1,1) + FACT*( CPASS-CCRSS )*FUN(1)

      VPSPS(5,1,1,1) = VPSPS(5,1,1,1) + FACT*( CPADR-CCRDR )*FUN(1)



      VPSPS(1,2,1,1) = VPSPS(1,2,1,1) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(2,2,1,1) = VPSPS(2,2,1,1) - FACT*( CPALL+CCRLL )*FUN(2)

      VPSPS(3,2,1,1) = VPSPS(3,2,1,1) - FACT*( CPALS+CCRLS )*FUN(2)

      VPSPS(4,2,1,1) = VPSPS(4,2,1,1) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,1,1) = VPSPS(5,2,1,1) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,1,1) = VPSPS(1,3,1,1) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(2,3,1,1) = VPSPS(2,3,1,1) - FACT*( CPALL+CCRLL )*FUN(3)

      VPSPS(3,3,1,1) = VPSPS(3,3,1,1) - FACT*( CPALS+CCRLS )*FUN(3)

      VPSPS(4,3,1,1) = VPSPS(4,3,1,1) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,1,1) = VPSPS(5,3,1,1) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END PION-PION



C PION-ETA EXCHANGE POTENTIALS:

      IF(IPIET.EQ.1) THEN

C     PARALLEL:

      CPANN  =  +2*F1**2*F6**2*ISFAC

*     CPALL  =  -0.0271D0*ICSB*2*F1*F3*F6*F7

      CPALL  = 0D0

      CPALS  =  -SR3*F1*F6*F3*(F8+F7)

      CPASS  =  -4*F1*F6*F2*F8

      CPADR  =  +2*F1*F6*F2*F8

C     CROSSED:

      CCRNN  =  +2*F1**2*F6**2*ISFAC

*     CCRLL  =  -0.0271D0*ICSB*2*F1*F3*F6*F7

      CCRLL  = 0D0

      CCRLS  =  -SR3*F1*F6*F3*(F8+F7)

      CCRSS  =  -4*F1*F6*F2*F8

      CCRDR  =  +2*F1*F6*F2*F8



*     CALL YNFUN(3,X,PIM,AME,ALMP8,ALMP8,FUN)

      CALL YNFUN(3,X,AMPI,AME,ALMP8,ALMP8,FUN)



      VPSPS(1,2,1,3) = VPSPS(1,2,1,3) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(3,2,1,3) = VPSPS(3,2,1,3) - FACT*( CPALS+CCRLS )*FUN(2)

      VPSPS(4,2,1,3) = VPSPS(4,2,1,3) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,1,3) = VPSPS(5,2,1,3) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,1,3) = VPSPS(1,3,1,3) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(3,3,1,3) = VPSPS(3,3,1,3) - FACT*( CPALS+CCRLS )*FUN(3)

      VPSPS(4,3,1,3) = VPSPS(4,3,1,3) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,1,3) = VPSPS(5,3,1,3) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END PION-ETA



C PION-ETA' EXCHANGE POTENTIALS:

      IF(IPIETP.EQ.1) THEN

C     PARALLEL:

      CPANN  =  +2*F1**2*F9**2*ISFAC

*     CPALL  =  -0.0271D0*ICSB*2*F1*F3*F9*F10

      CPALL  = 0D0

      CPALS  =  -SR3*F1*F9*F3*(F11+F10)

      CPASS  =  -4*F1*F9*F2*F11

      CPADR  =  +2*F1*F9*F2*F11

C     CROSSED:

      CCRNN  =  +2*F1**2*F9**2*ISFAC

*     CCRLL  =  -0.0271D0*ICSB*2*F1*F3*F9*F10

      CCRLL  = 0D0

      CCRLS  =  -SR3*F1*F9*F3*(F11+F10)

      CCRSS  =  -4*F1*F9*F2*F11

      CCRDR  =  +2*F1*F9*F2*F11



*     CALL YNFUN(3,X,PIM,AMX,ALMP8,ALMP1,FUN)

      CALL YNFUN(3,X,AMPI,AMX,ALMP8,ALMP1,FUN)



      VPSPS(1,2,1,4) = VPSPS(1,2,1,4) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(3,2,1,4) = VPSPS(3,2,1,4) - FACT*( CPALS+CCRLS )*FUN(2)

      VPSPS(4,2,1,4) = VPSPS(4,2,1,4) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,1,4) = VPSPS(5,2,1,4) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,1,4) = VPSPS(1,3,1,4) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(3,3,1,4) = VPSPS(3,3,1,4) - FACT*( CPALS+CCRLS )*FUN(3)

      VPSPS(4,3,1,4) = VPSPS(4,3,1,4) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,1,4) = VPSPS(5,3,1,4) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END PION-ETA'



C PION-KAON EXCHANGE POTENTIALS:

      IF(IPIKA.EQ.1) THEN

C     PARALLEL:

      CPALL  =  6*F1*F4*F3*F5

*               -0.0271D0*ICSB*F1*F3*F4**2*6

      CPALS  =  -SR3*F1*F3*(F4**2-F5**2)

     .          +2*SR3*F1*F2*F4*F5

      CPASS  =  F1*F5*(6*F3*F4+4*F2*F5)

      CPADR  =  +4*F1*F2*F5**2

C     CROSSED:

      CCRLL  =  3*(F1*F1*F4**2+F3*F3*F5**2)

*               -0.0271D0*ICSB*F1*F3*F4**2*3

      CCRLS  =  SR3*F4*F5*(F1**2-F3**2)

     .         +2*SR3*F2*F3*F5**2

      CCRSS  =  5*F1**2*F5**2+F3**2*F4**2

     .         +4*F2*F3*F4*F5

      CCRDR  =  2*F1**2*F5**2+F3**2*F4**2

     .         +3*F2**2*F5**2-2*F2*F3*F4*F5



*     CALL YNFUN(3,X,PIM,AMK,ALMP8,ALMKA,FUN)

      CALL YNFUN(3,X,AMPI,AMK,ALMP8,ALMKA,FUN)

c     CALL YNFUN2(3,X,PIM,AMK,ALMP8,ALMKA,DAM,2,FUN)



      VPSPS(2,1,1,2) = VPSPS(2,1,1,2) + FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSPS(3,1,1,2) = VPSPS(3,1,1,2) + FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSPS(4,1,1,2) = VPSPS(4,1,1,2) + FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSPS(5,1,1,2) = VPSPS(5,1,1,2) + FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSPS(2,2,1,2) = VPSPS(2,2,1,2) - FACT*(CPALL+CCRLL)*FUN(2)*P

      VPSPS(3,2,1,2) = VPSPS(3,2,1,2) - FACT*(CPALS+CCRLS)*FUN(2)*P

      VPSPS(4,2,1,2) = VPSPS(4,2,1,2) - FACT*(CPASS+CCRSS)*FUN(2)*P

      VPSPS(5,2,1,2) = VPSPS(5,2,1,2) - FACT*(CPADR+CCRDR)*FUN(2)*P



      VPSPS(2,3,1,2) = VPSPS(2,3,1,2) - FACT*(CPALL+CCRLL)*FUN(3)*P

      VPSPS(3,3,1,2) = VPSPS(3,3,1,2) - FACT*(CPALS+CCRLS)*FUN(3)*P

      VPSPS(4,3,1,2) = VPSPS(4,3,1,2) - FACT*(CPASS+CCRSS)*FUN(3)*P

      VPSPS(5,3,1,2) = VPSPS(5,3,1,2) - FACT*(CPADR+CCRDR)*FUN(3)*P

      ENDIF

C END PION-KAON



C KAON-KAON EXCHANGE POTENTIALS:

      IF(IKAKA.EQ.1) THEN

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  1*(F4**2+3*F5**2)*F4**2

      CPALS  =  1*SR3*(F5**2-F4**2)*F4*F5

      CPASS  =  1*(3*F4**2+F5**2)*F5**2

      CPADR  =  1*4*F5**4

C     CROSSED:

      CCRNN  =  1*((F4**2+3*F5**2)**2+ISFAC*(F4**2-F5**2)**2)/2.D0

      CCRLL  =  +1*(F4**2*F12**2+3*F5**2*F12**2)

      CCRLS  =  1*SR3*(F4*F4-F5*F5)*F13*F12

      CCRSS  =  +1*(-F4**2+5*F5**2)*F13**2

      CCRDR  =  +1*2*(F4**2+1*F5**2)*F13**2



      CALL YNFUN(3,X,AMK,AMK,ALMKA,ALMKA,FUN)

      CALL YNFUN(3,X,AMK,AMK,ALMKA,ALMKA,FUNX)

cc    CALL DKBFUN(3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

cc    CALL DKBFUN(3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUNX)

*     CALL YNFUN3(1,3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

*     CALL YNFUN3(2,3,X,AMK,AMK,ALMKA,ALMKA,DAM,FUNX)



      VPSPS(1,1,2,2)=VPSPS(1,1,2,2)+FACT*(CPANN*FUN(1)-CCRNN*FUNX(1))

      VPSPS(2,1,2,2)=VPSPS(2,1,2,2)+FACT*(CPALL*FUN(1)-CCRLL*FUNX(1))

      VPSPS(3,1,2,2)=VPSPS(3,1,2,2)+FACT*(CPALS*FUN(1)-CCRLS*FUNX(1))

      VPSPS(4,1,2,2)=VPSPS(4,1,2,2)+FACT*(CPASS*FUN(1)-CCRSS*FUNX(1))

      VPSPS(5,1,2,2)=VPSPS(5,1,2,2)+FACT*(CPADR*FUN(1)-CCRDR*FUNX(1))



      VPSPS(1,2,2,2)=VPSPS(1,2,2,2)-FACT*(CPANN*FUN(2)+CCRNN*FUNX(2))

      VPSPS(2,2,2,2)=VPSPS(2,2,2,2)-FACT*(CPALL*FUN(2)+CCRLL*FUNX(2))

      VPSPS(3,2,2,2)=VPSPS(3,2,2,2)-FACT*(CPALS*FUN(2)+CCRLS*FUNX(2))

      VPSPS(4,2,2,2)=VPSPS(4,2,2,2)-FACT*(CPASS*FUN(2)+CCRSS*FUNX(2))

      VPSPS(5,2,2,2)=VPSPS(5,2,2,2)-FACT*(CPADR*FUN(2)+CCRDR*FUNX(2))



      VPSPS(1,3,2,2)=VPSPS(1,3,2,2)-FACT*(CPANN*FUN(3)+CCRNN*FUNX(3))

      VPSPS(2,3,2,2)=VPSPS(2,3,2,2)-FACT*(CPALL*FUN(3)+CCRLL*FUNX(3))

      VPSPS(3,3,2,2)=VPSPS(3,3,2,2)-FACT*(CPALS*FUN(3)+CCRLS*FUNX(3))

      VPSPS(4,3,2,2)=VPSPS(4,3,2,2)-FACT*(CPASS*FUN(3)+CCRSS*FUNX(3))

      VPSPS(5,3,2,2)=VPSPS(5,3,2,2)-FACT*(CPADR*FUN(3)+CCRDR*FUNX(3))

      ENDIF

C END KAON-KAON



C ETA-ETA EXCHANGE POTENTIALS:

      IF(IETA2.EQ.1) THEN

C     PARALLEL:

      CPANN  =  1*F6**2*F6**2

      CPALL  =  1*F6**2*F7**2

      CPASS  =  1*F6**2*F8**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  1*F6**2*F7**2

      CCRSS  =  1*F6**2*F8**2

      CCRDR  =  CCRSS



      CALL YNFUN(3,X,AME,AME,ALMP8,ALMP8,FUN)



      VPSPS(1,2,3,3) = VPSPS(1,2,3,3) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(2,2,3,3) = VPSPS(2,2,3,3) - FACT*( CPALL+CCRLL )*FUN(2)

      VPSPS(4,2,3,3) = VPSPS(4,2,3,3) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,3,3) = VPSPS(5,2,3,3) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,3,3) = VPSPS(1,3,3,3) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(2,3,3,3) = VPSPS(2,3,3,3) - FACT*( CPALL+CCRLL )*FUN(3)

      VPSPS(4,3,3,3) = VPSPS(4,3,3,3) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,3,3) = VPSPS(5,3,3,3) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END ETA-ETA



C ETA-KAON EXCHANGE POTENTIALS:

      IF(IETKA.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*F6*F7*F4**2

      CPALS  =  -SR3*F6*(F7+F8)*F4*F5

      CPASS  =  -2*F6*F8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (F6**2+F7**2)*F4**2

      CCRLS  =  -SR3*(F6**2+F7*F8)*F4*F5

      CCRSS  =  -1*(F6**2+F8**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL YNFUN(3,X,AME,AMK,ALMP8,ALMKA,FUN)

**    CALL YNFUN2(3,X,AME,AMK,ALMP8,ALMKA,DAM,2,FUN)



      VPSPS(2,1,2,3) = VPSPS(2,1,2,3) + FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSPS(3,1,2,3) = VPSPS(3,1,2,3) + FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSPS(4,1,2,3) = VPSPS(4,1,2,3) + FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSPS(5,1,2,3) = VPSPS(5,1,2,3) + FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSPS(2,2,2,3) = VPSPS(2,2,2,3) - FACT*(CPALL+CCRLL)*FUN(2)*P

      VPSPS(3,2,2,3) = VPSPS(3,2,2,3) - FACT*(CPALS+CCRLS)*FUN(2)*P

      VPSPS(4,2,2,3) = VPSPS(4,2,2,3) - FACT*(CPASS+CCRSS)*FUN(2)*P

      VPSPS(5,2,2,3) = VPSPS(5,2,2,3) - FACT*(CPADR+CCRDR)*FUN(2)*P



      VPSPS(2,3,2,3) = VPSPS(2,3,2,3) - FACT*(CPALL+CCRLL)*FUN(3)*P

      VPSPS(3,3,2,3) = VPSPS(3,3,2,3) - FACT*(CPALS+CCRLS)*FUN(3)*P

      VPSPS(4,3,2,3) = VPSPS(4,3,2,3) - FACT*(CPASS+CCRSS)*FUN(3)*P

      VPSPS(5,3,2,3) = VPSPS(5,3,2,3) - FACT*(CPADR+CCRDR)*FUN(3)*P

      ENDIF

C END ETA-KAON



C ETA-ETA' EXCHANGE POTENTIALS:

      IF(IETETP.EQ.1) THEN

C     PARALLEL:

      CPANN  =  2*F6**2*F9**2

      CPALL  =  2*F6*F9*F7*F10

      CPASS  =  2*F6*F9*F8*F11

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  2*F6*F9*F7*F10

      CCRSS  =  2*F6*F9*F8*F11

      CCRDR  =  CCRSS



      CALL YNFUN(3,X,AME,AMX,ALMP8,ALMP1,FUN)



      VPSPS(1,2,3,4) = VPSPS(1,2,3,4) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(2,2,3,4) = VPSPS(2,2,3,4) - FACT*( CPALL+CCRLL )*FUN(2)

      VPSPS(4,2,3,4) = VPSPS(4,2,3,4) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,3,4) = VPSPS(5,2,3,4) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,3,4) = VPSPS(1,3,3,4) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(2,3,3,4) = VPSPS(2,3,3,4) - FACT*( CPALL+CCRLL )*FUN(3)

      VPSPS(4,3,3,4) = VPSPS(4,3,3,4) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,3,4) = VPSPS(5,3,3,4) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END ETA-ETA'



C ETA'-KAON EXCHANGE POTENTIALS:

      IF(IETPKA.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*F9*F10*F4**2

      CPALS  =  -SR3*F9*(F10+F11)*F4*F5

      CPASS  =  -2*F9*F11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (F9**2+F10**2)*F4**2

      CCRLS  =  -SR3*(F9**2+F10*F11)*F4*F5

      CCRSS  =  -1*(F9**2+F11**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL YNFUN(3,X,AMX,AMK,ALMP1,ALMKA,FUN)

**    CALL YNFUN2(3,X,AMX,AMK,ALMP1,ALMKA,DAM,2,FUN)



      VPSPS(2,1,2,4) = VPSPS(2,1,2,4) + FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSPS(3,1,2,4) = VPSPS(3,1,2,4) + FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSPS(4,1,2,4) = VPSPS(4,1,2,4) + FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSPS(5,1,2,4) = VPSPS(5,1,2,4) + FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSPS(2,2,2,4) = VPSPS(2,2,2,4) - FACT*(CPALL+CCRLL)*FUN(2)*P

      VPSPS(3,2,2,4) = VPSPS(3,2,2,4) - FACT*(CPALS+CCRLS)*FUN(2)*P

      VPSPS(4,2,2,4) = VPSPS(4,2,2,4) - FACT*(CPASS+CCRSS)*FUN(2)*P

      VPSPS(5,2,2,4) = VPSPS(5,2,2,4) - FACT*(CPADR+CCRDR)*FUN(2)*P



      VPSPS(2,3,2,4) = VPSPS(2,3,2,4) - FACT*(CPALL+CCRLL)*FUN(3)*P

      VPSPS(3,3,2,4) = VPSPS(3,3,2,4) - FACT*(CPALS+CCRLS)*FUN(3)*P

      VPSPS(4,3,2,4) = VPSPS(4,3,2,4) - FACT*(CPASS+CCRSS)*FUN(3)*P

      VPSPS(5,3,2,4) = VPSPS(5,3,2,4) - FACT*(CPADR+CCRDR)*FUN(3)*P

      ENDIF

C END ETAP-KAON



C ETA'-ETA' EXCHANGE POTENTIALS:

      IF(IETAP2.EQ.1) THEN

C     PARALLEL:

      CPANN  =  1*F9**2*F9**2

      CPALL  =  1*F9**2*F10**2

      CPASS  =  1*F9**2*F11**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  1*F9**2*F10**2

      CCRSS  =  1*F9**2*F11**2

      CCRDR  =  CCRSS



      CALL YNFUN(3,X,AMX,AMX,ALMP1,ALMP1,FUN)



      VPSPS(1,2,4,4) = VPSPS(1,2,4,4) - FACT*( CPANN+CCRNN )*FUN(2)

      VPSPS(2,2,4,4) = VPSPS(2,2,4,4) - FACT*( CPALL+CCRLL )*FUN(2)

      VPSPS(4,2,4,4) = VPSPS(4,2,4,4) - FACT*( CPASS+CCRSS )*FUN(2)

      VPSPS(5,2,4,4) = VPSPS(5,2,4,4) - FACT*( CPADR+CCRDR )*FUN(2)



      VPSPS(1,3,4,4) = VPSPS(1,3,4,4) - FACT*( CPANN+CCRNN )*FUN(3)

      VPSPS(2,3,4,4) = VPSPS(2,3,4,4) - FACT*( CPALL+CCRLL )*FUN(3)

      VPSPS(4,3,4,4) = VPSPS(4,3,4,4) - FACT*( CPASS+CCRSS )*FUN(3)

      VPSPS(5,3,4,4) = VPSPS(5,3,4,4) - FACT*( CPADR+CCRDR )*FUN(3)

      ENDIF

C END ETA'-ETA'



C     TOTAL CONTRIBUTION:

      DO 30 IMES=1,4

      DO 30 IPS=1,IMES



      VCNN = VCNN + VPSPS(1,1,IPS,IMES)

      VCLL = VCLL + VPSPS(2,1,IPS,IMES)

      VCLS = VCLS + VPSPS(3,1,IPS,IMES)

      VCSS = VCSS + VPSPS(4,1,IPS,IMES)

      VCDR = VCDR + VPSPS(5,1,IPS,IMES)



      VSNN = VSNN + VPSPS(1,2,IPS,IMES)

      VSLL = VSLL + VPSPS(2,2,IPS,IMES)

      VSLS = VSLS + VPSPS(3,2,IPS,IMES)

      VSSS = VSSS + VPSPS(4,2,IPS,IMES)

      VSDR = VSDR + VPSPS(5,2,IPS,IMES)



      VTNN = VTNN + VPSPS(1,3,IPS,IMES)

      VTLL = VTLL + VPSPS(2,3,IPS,IMES)

      VTLS = VTLS + VPSPS(3,3,IPS,IMES)

      VTSS = VTSS + VPSPS(4,3,IPS,IMES)

      VTDR = VTDR + VPSPS(5,3,IPS,IMES)

  30  CONTINUE



*     if(icall.eq.0.and.nschr.eq.1) then                   

      if(icall.eq.20.and.nschr.eq.1) then                   

      call writetm(1,x,p)

      write(N3,*)'*****************************************************'

      write(N3,*) 'YNPSPS total contributions: x=',x

      write(N3,*) 'vcll,vsll=',vcll,vsll

      write(N3,*) 'vcls,vsls=',vcls,vsls

      write(N3,*) 'vcss,vsss=',vcss,vsss

      write(N3,*) 'vcdr,vsdr=',vcdr,vsdr

      write(N3,*)'*****************************************************'

      endif

C END PSEUDO-SCALAR MESONS

C  1  CONTINUE

      ICALL=ICALL+1



1000  CALL ERRSET(208,256,1,1)

      RETURN

C END YNPSPS ROUTINE ***************************************************

      END

C

C FOR ROUTINE PIHBE:  ***********************************************

      BLOCK DATA XX

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS

      COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC

      COMMON/TREATD/IPIA2,IPIPOM,IPIKSS

      DATA IPIRO/1/,IPIOM/1/,IPIPH/1/,IPIKS/1/

      DATA IPIDE/1/,IPIEP/1/,IPIST/1/,IPIKSC/1/

      DATA IPIA2/1/,IPIPOM/1/,IPIKSS/1/

      END



C **********************************************************************

      SUBROUTINE YNPIBE(X,INA,IPV,IOFF,APV)

C **********************************************************************

C *

C *   DATE: JANUARY, 1995

C

C *   PION-MESON EXCHANGE YN-POTENTIALS (MESON= VECTOR, SCALAR, DIFFR.)

C *

C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION

C *               NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS

C * FROM: PI-EPSILON, PI-POMERON

C

C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET

C     VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET

C     SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET

C

C   STORAGE INDIDUAL CONTRIBUTIONS TO THE POTENTIALS:

C   VPSVC(NCHAN,TYPE,IPS,IVC): PS-VECTOR POTENTIALS,

C   NCHAN=1,2,3,4,5: NN,LL,LS,SS,DR;  TYPE=1,2,3,4,5: VC,VSIG,VTEN,VSO,VASO

C   IPS  =1,2,3,4: PI,K,ETA,ETAP;  IVC=1,2,3,4: RHO,K*,OMEGA,PHI

C   ISC  =1,2,3,4: DE,KAP,EPS,S*;  IDF=1,2,3,4: A2,K**,POM,POMP

C   VPSSC and VPSDF ANALOGOUSLY

C   VPSSC and VPSDF ANALOGOUSLY

C *

C **********************************************************************

C     CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN):

C

C     IKIND=1, PION-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT  FUN(4) = OPAEMO

C     FUN(5) = OPAMMC  FUN(6) = OPAMMS  FUN(7) = OPAMMT

C     IKIND=2, PION-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C     IKIND=4, PION-DIFFRACTIVE EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C **********************************************************************

C

C     INCLUDED IN ENERGY-DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT,FACT2

C     INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/POTNN /VCNN,VSNN,VTNN,VONN

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

*     COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

*     COMMON/ALLAX/FA1,FA9,ALPA

c     COMMON/OOM/ INA,IPV,IOFF

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))

C

      DIMENSION FUN(12),FUNH(12),AMSIG(2),ASIG(2)

      COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS

      COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC

      COMMON/TREATD/IPIA2,IPIPOM,IPIKSS

      COMMON/PSBE/ 

     .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4)

      common/cpsbe/papssc(5,4,4,4),crpssc(5,4,4,4)

      CHARACTER *4 NTYPM(4,4)

      DATA NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','OM  ','PHI ',

     .'DE  ','KAP ','EPS ','S*  ','A2  ','K** ','POM ','POMP'/

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,DAM/230.D0/

*     DATA AMPRO/1138.2796D0/,AMRO/760.D0/,AMEPS/760.D0/

      DATA N3/27/,ICALL/0/,FACT/70.D0/,FACT2/0.D0/,ISFAC/1/,NSCHR/0/

      SAVE FACT,FACT2,FACT3

      pim=pim0

*     pim=500.d0

C

      CALL ERRSET(208,256,-1,1)

C

  12  IF(ICALL.EQ.0) THEN

        FACT = PIM0/2.D0

*       FACT2= 0.25D0*FACT*(PIM0/AMPRO)**2

*       FACT3= 0.5D0*FACT2

        FACT2= 0.5D0*FACT*(PIM0/AMPRO)**2

        FACT3= 0.5D0*FACT2 

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3



        PRINT 52, INA,IPV,IOFF,IPIRO,IPIOM,IPIPH,IPIKS,

     .  IPIDE,IPIEP,IPIST,IPIKSC,IPIA2,IPIPOM,IPIKSS

 52     FORMAT(//,'  IN YNPIBE: INA,IPV,IOFF=',3I3,//,

     .  11X,'  IPIRO,IPIOM,IPIPH,IPIKS=',4I2,//,

     .  11X,'  IPIDE,IPIEP,IPIST,IPIKSC=',4I2,//,

     .  11X,'  IPIA2,IPIPOM,IPIKSS=',3I2,//)

        PRINT 53, ALMP1,ALMV1,ALMS1,ALMP8,ALMV8,ALMS8,PIM,DAM

 53     FORMAT(/,' IN YNPIBE: ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=',

     .  D10.3,/,11X,' ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',D10.3,/,

     .  11X,'  PIM =',F10.3,'  DAM =',F10.3,/)

*       ICALL=1

      ENDIF

C

C     CONSTRUCTION OF THE POTENTIALS

C

C     DO 1 I=2,NMAX

C     X = XA(I)

      VCNN =0.D0

      VSNN =0.D0

      VCLL =0.D0

      VCLS =0.D0

      VCSS =0.D0

      VCDR =0.D0

      VSLL =0.D0

      VSLS =0.D0

      VSSS =0.D0

      VSDR =0.D0

      VTLL =0.D0

      VTLS =0.D0

      VTSS =0.D0

      VTDR =0.D0

      VOLL =0.D0

      VOLS =0.D0

      VOSS =0.D0

      VODR =0.D0

      VALL =0.D0

      VALS =0.D0

      VASS =0.D0

      VADR =0.D0

      DO 25 NCHAN=1,5

      DO 25 IVTYP=1,5

      DO 25 IPSI=1,4

      DO 25 IMES=1,4

      if(ivtyp.le.4) then

      papssc(nchan,ivtyp,ipsi,imes)=0.d0

      crpssc(nchan,ivtyp,ipsi,imes)=0.d0

      endif

      VPSVC(NCHAN,IVTYP,IPSI,IMES)=0.D0

      VPSSC(NCHAN,IVTYP,IPSI,IMES)=0.D0

   25 VPSDF(NCHAN,IVTYP,IPSI,IMES)=0.D0



C     1/M-CORRECTIONS:

      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)

     .CALL OMPIBE(X,INA,IPV,IOFF,APV)

c     if(icall.eq.0.and.nschr.eq.1) then

c     write(N3,*) 'in OMPIBE: x=',x

c     write(N3,*) 'vcll,vsll=',vcll,vsll

c     write(N3,*) 'vcls,vsls=',vcls,vsls

c     write(N3,*) 'vcss,vsss=',vcss,vsss

c     write(N3,*) 'vcdr,vsdr=',vcdr,vsdr

c     endif



C A)  PION-VECTOR-MESON POTENTIALS: ******************************

C

C     PI-RHO:

      IF(IPIRO.EQ.1) THEN

C     EE-CONTRIBUTIONS:

C     PARALLEL:

      CPANN  =  2*(3.D0-2.D0*ISFAC)*F1**2*FD1**2

      CPALL  =  6*F1*FD1*F3*FD3

      CPALS  =  +2*SR3*F1*FD1*(F3*FD2+F2*FD3)

      CPASS  =  2*F1*FD1*(3*F3*FD3+4*F2*FD2)

      CPADR  =  2*F1*FD1*F2*FD2

C     CROSSED:

      CCRNN  =  2*(3.D0+2.D0*ISFAC)*F1**2*FD1**2

      CCRLL  =  6*F1*FD1*F3*FD3

      CCRLS  =  -2*SR3*F1*FD1*(F3*FD2+F2*FD3)

      CCRSS  =  -2*F1*FD1*F3*FD3

      CCRDR  =  2*F1*FD1*(2*F3*FD3+3*F2*FD2)



      DO 710 LL=1,12

  710 FUN(LL)=0.D0

      DO 711 KK=1,2

*     CALL YNFUN(1,X,PIM,AMVEC(KK),ALMP8,ALMV8,FUNH)

      CALL YNFUN(1,X,AMPI,AMVEC(KK),ALMP8,ALMV8,FUNH)

      DO 711 LL=1,12

  711 FUN(LL)=FUN(LL)+AVEC(KK)*FUNH(LL)

*     CALL YNFUN(1,X,PIM,AMRO,ALMP8,ALMV8,FUN)

*     CALL YNFUN(1,X,AMPI,AMRO,ALMP8,ALMV8,FUN)



      VPSVC(1,2,1,1)=

     .VPSVC(1,2,1,1) + FACT*( CPANN*FUN(1) - CCRNN*FUN(11) )

      VPSVC(2,2,1,1)=

     .VPSVC(2,2,1,1) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11) )

      VPSVC(3,2,1,1)=

     .VPSVC(3,2,1,1) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11) )

      VPSVC(4,2,1,1)=

     .VPSVC(4,2,1,1) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11) )

      VPSVC(5,2,1,1)=

     .VPSVC(5,2,1,1) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11) )



      VPSVC(1,3,1,1)=

     .VPSVC(1,3,1,1) + FACT*( CPANN*FUN(2) - CCRNN*FUN(12) )

      VPSVC(2,3,1,1)=

     .VPSVC(2,3,1,1) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12) )

      VPSVC(3,3,1,1)=

     .VPSVC(3,3,1,1) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12) )

      VPSVC(4,3,1,1)=

     .VPSVC(4,3,1,1) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12) )

      VPSVC(5,3,1,1)=

     .VPSVC(5,3,1,1) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12) )



C     1/M^2-TERMS:

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*(3.D0-2.D0*ISFAC)*F1**2*FVE1**2

      CPALL  =  6*F1*FVE1*F3*FVE3

      CPALS  =  +2*SR3*F1*FVE1*(F3*FVE2+F2*FVE3)

      CPASS  =  2*F1*FVE1*(3*F3*FVE3+4*F2*FVE2)

      CPADR  =  2*F1*FVE1*F2*FVE2

C     CROSSED:

      CCRNN  =  2*(3.D0+2.D0*ISFAC)*F1**2*FVE1**2

      CCRLL  =  6*F1*FVE1*F3*FVE3

      CCRLS  =  -2*SR3*F1*FVE1*(F3*FVE2+F2*FVE3)

      CCRSS  =  -2*F1*FVE1*F3*FVE3

      CCRDR  =  2*F1*FVE1*(2*F3*FVE3+3*F2*FVE2)



*     CALL YNFUN(1,X,PIM,AMRO,ALMP8,ALMV8,FUN)



      VPSVC(1,1,1,1)=VPSVC(1,1,1,1)+FACT2*( CPANN-CCRNN)*FUN(5)

      VPSVC(2,1,1,1)=VPSVC(2,1,1,1)+FACT2*( CPALL-CCRLL)*FUN(5)

      VPSVC(3,1,1,1)=VPSVC(3,1,1,1)+FACT2*( CPALS-CCRLS)*FUN(5)

      VPSVC(4,1,1,1)=VPSVC(4,1,1,1)+FACT2*( CPASS-CCRSS)*FUN(5)

      VPSVC(5,1,1,1)=VPSVC(5,1,1,1)+FACT2*( CPADR-CCRDR)*FUN(5)



      VPSVC(1,2,1,1)=VPSVC(1,2,1,1)+FACT2*( CPANN+CCRNN)*FUN(6)

      VPSVC(2,2,1,1)=VPSVC(2,2,1,1)+FACT2*( CPALL+CCRLL)*FUN(6)

      VPSVC(3,2,1,1)=VPSVC(3,2,1,1)+FACT2*( CPALS+CCRLS)*FUN(6)

      VPSVC(4,2,1,1)=VPSVC(4,2,1,1)+FACT2*( CPASS+CCRSS)*FUN(6)

      VPSVC(5,2,1,1)=VPSVC(5,2,1,1)+FACT2*( CPADR+CCRDR)*FUN(6)



      VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT2*( CPANN+CCRNN)*FUN(7)

      VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT2*( CPALL+CCRLL)*FUN(7)

      VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT2*( CPALS+CCRLS)*FUN(7)

      VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT2*( CPASS+CCRSS)*FUN(7)

      VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT2*( CPADR+CCRDR)*FUN(7)



C     EM-CONTRIBUTIONS:

      DO 31 ME=1,2

C     EM,2-CONTRIBUTION:

      IF(ME.EQ.1) THEN

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

      ENDIF

      IF(ME.EQ.2) THEN

      FVE1 = FD1+2*FV1

      FVE2 = FD2+2*FV2

      FVE3 = FD3+2*FV3

      ENDIF

C     PARALLEL:

      CPANN  =  2*(3.D0-2.D0*ISFAC)*F1**2*(2*FD1*FVE1)

      CPALL  =  6*F1*F3*(FD1*FVE3+FVE1*FD3)

      CPALS  =  +2*SR3*F1*FD1*(F3*FVE2+F2*FVE3)

     .          +2*SR3*F1*FVE1*(F3*FD2+F2*FD3)

      CPASS  =  2*F1*FD1*(3*F3*FVE3+4*F2*FVE2)

     .         +2*F1*FVE1*(3*F3*FD3+4*F2*FD2)

      CPADR  =  2*F1*F2*(FD1*FVE2+FVE1*FD2)



      CPALLM =  6*F1*F3*(FD1*FVE3-FVE1*FD3)

C     CROSSED:

      CCRNN  =  2*(3.D0+2.D0*ISFAC)*F1**2*(2*FD1*FVE1)

      CCRLL  =  6*F1*F3*(FD1*FVE3+FVE1*FD3)

      CCRLS  =  -2*SR3*F1*FD1*(F3*FVE2+F2*FVE3)

     .          -2*SR3*F1*FVE1*(F3*FD2+F2*FD3)

      CCRSS  =  -2*F1*F3*(FD1*FVE3+FVE1*FD3)

      CCRDR  =  2*F1*FD1*(2*F3*FVE3+3*F2*FVE2)

     .         +2*F1*FVE1*(2*F3*FD3+3*F2*FD2)



      CCRLLM =  6*F1*F3*(FD1*FVE3-FVE1*FD3)

**    write(*,*) ' YNPIBE: cpall =',cpall ,' ccrll =',ccrll 

**    write(*,*) ' YNPIBE: cpallm=',cpallm,' ccrllm=',ccrllm

      IF(ME.EQ.1) THEN

      VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT3*(CPANN+CCRNN)*FUN(3)

      VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT3*(CPALL+CCRLL)*FUN(3)

      VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT3*(CPALS+CCRLS)*FUN(3)

      VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT3*(CPASS+CCRSS)*FUN(3)

      VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT3*(CPADR+CCRDR)*FUN(3)



      VPSVC(1,4,1,1)=VPSVC(1,4,1,1)+FACT3*(CPANN-CCRNN)*FUN(4)

      VPSVC(2,4,1,1)=VPSVC(2,4,1,1)+FACT3*(CPALL-CCRLL)*FUN(4)

      VPSVC(3,4,1,1)=VPSVC(3,4,1,1)+FACT3*(CPALS-CCRLS)*FUN(4)

      VPSVC(4,4,1,1)=VPSVC(4,4,1,1)+FACT3*(CPASS-CCRSS)*FUN(4)

      VPSVC(5,4,1,1)=VPSVC(5,4,1,1)+FACT3*(CPADR-CCRDR)*FUN(4)



      VPSVC(2,5,1,1)=VPSVC(2,5,1,1)-FACT3*(CPALLM-CCRLLM)*FUN(4)

      ENDIF

      IF(ME.EQ.2) THEN

      VPSVC(1,2,1,1)=VPSVC(1,2,1,1)+FACT3*(CPANN-CCRNN)*FUN(8)

      VPSVC(2,2,1,1)=VPSVC(2,2,1,1)+FACT3*(CPALL-CCRLL)*FUN(8)

      VPSVC(3,2,1,1)=VPSVC(3,2,1,1)+FACT3*(CPALS-CCRLS)*FUN(8)

      VPSVC(4,2,1,1)=VPSVC(4,2,1,1)+FACT3*(CPASS-CCRSS)*FUN(8)

      VPSVC(5,2,1,1)=VPSVC(5,2,1,1)+FACT3*(CPADR-CCRDR)*FUN(8)



      VPSVC(1,3,1,1)=VPSVC(1,3,1,1)+FACT3*(CPANN-CCRNN)*FUN(9)

      VPSVC(2,3,1,1)=VPSVC(2,3,1,1)+FACT3*(CPALL-CCRLL)*FUN(9)

      VPSVC(3,3,1,1)=VPSVC(3,3,1,1)+FACT3*(CPALS-CCRLS)*FUN(9)

      VPSVC(4,3,1,1)=VPSVC(4,3,1,1)+FACT3*(CPASS-CCRSS)*FUN(9)

      VPSVC(5,3,1,1)=VPSVC(5,3,1,1)+FACT3*(CPADR-CCRDR)*FUN(9)



      VPSVC(1,4,1,1)=VPSVC(1,4,1,1)+FACT3*(CPANN-CCRNN)*FUN(10)

      VPSVC(2,4,1,1)=VPSVC(2,4,1,1)+FACT3*(CPALL-CCRLL)*FUN(10)

      VPSVC(3,4,1,1)=VPSVC(3,4,1,1)+FACT3*(CPALS-CCRLS)*FUN(10)

      VPSVC(4,4,1,1)=VPSVC(4,4,1,1)+FACT3*(CPASS-CCRSS)*FUN(10)

      VPSVC(5,4,1,1)=VPSVC(5,4,1,1)+FACT3*(CPADR-CCRDR)*FUN(10)



      VPSVC(2,5,1,1)=VPSVC(2,5,1,1)-FACT3*(CPALLM-CCRLLM)*FUN(10)

      ENDIF

      write(*,*) 'pi-ro: me=',me,' vpsvc(2,4,1,1)=',vpsvc(2,4,1,1)

     .,' vpsvc(2,5,1,1)=',vpsvc(2,5,1,1)

   31 CONTINUE

      ENDIF

C END PION-RHO



C

C PION-OMEGA EXCHANGE POTENTIALS:

C     PI-OMEGA

      IF(IPIOM.EQ.1) THEN

C     1/M^2-TERMS:

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*FVE6**2

      CPALS  =  -SR3*F1*FVE6*F3*(FVE7+FVE8)

      CPASS  =  -4*F1*FVE6*F2*FVE8

      CPADR  =  +2*F1*FVE6*F2*FVE8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR



*     CALL YNFUN(1,X,PIM,AMOM,ALMP8,ALMV1,FUN)

      CALL YNFUN(1,X,AMPI,AMOM,ALMP8,ALMV1,FUN)



      VPSVC(1,2,1,3)=VPSVC(1,2,1,3)+FACT2*( CPANN+CCRNN)*FUN(6)

      VPSVC(3,2,1,3)=VPSVC(3,2,1,3)+FACT2*( CPALS+CCRLS)*FUN(6)

      VPSVC(4,2,1,3)=VPSVC(4,2,1,3)+FACT2*( CPASS+CCRSS)*FUN(6)

      VPSVC(5,2,1,3)=VPSVC(5,2,1,3)+FACT2*( CPADR+CCRDR)*FUN(6)



      VPSVC(1,3,1,3)=VPSVC(1,3,1,3)+FACT2*( CPANN+CCRNN)*FUN(7)

      VPSVC(3,3,1,3)=VPSVC(3,3,1,3)+FACT2*( CPALS+CCRLS)*FUN(7)

      VPSVC(4,3,1,3)=VPSVC(4,3,1,3)+FACT2*( CPASS+CCRSS)*FUN(7)

      VPSVC(5,3,1,3)=VPSVC(5,3,1,3)+FACT2*( CPADR+CCRDR)*FUN(7)



C     EM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =   4*ISFAC*F1**2*FD6*FVE6

      CPALS  =  -SR3*F1*FVE6*F3*(FD8+FD7)

     .          -SR3*F1*(FD6)*F3*(FVE7+FVE8)

      CPASS  =  -4*F1*FVE6*F2*(FD8)

     .          -4*F1*(FD6)*F2*FVE8

      CPADR  =  +2*F1*FVE6*F2*(FD8)

     .          +2*F1*(FD6)*F2*FVE8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR



      VPSVC(1,3,1,3)=VPSVC(1,3,1,3)+FACT3*(CPANN+CCRNN)*FUN(3)

      VPSVC(3,3,1,3)=VPSVC(3,3,1,3)+FACT3*(CPALS+CCRLS)*FUN(3)

      VPSVC(4,3,1,3)=VPSVC(4,3,1,3)+FACT3*(CPASS+CCRSS)*FUN(3)

      VPSVC(5,3,1,3)=VPSVC(5,3,1,3)+FACT3*(CPADR+CCRDR)*FUN(3)



      ENDIF

C END PION-OMEGA



C PION-PHI EXCHANGE POTENTIALS:

      IF(IPIPH.EQ.1) THEN

C     1/M^2-TERMS:

      FVE9  = FD9+FV9

      FVE10 = FD10+FV10

      FVE11 = FD11+FV11

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =   2*ISFAC*F1**2*FVE9**2

      CPALS  =  -SR3*F1*FVE9*F3*(FVE10+FVE11)

      CPASS  =  -4*F1*FVE9*F2*FVE11

      CPADR  =  +2*F1*FVE9*F2*FVE11

C     CROSSED:

      CCRNN  =   CPANN

      CCRLS  =   CPALS

      CCRSS  =   CPASS

      CCRDR  =   CPADR



*     CALL YNFUN(1,X,PIM,AMFI,ALMP8,ALMV8,FUN)

      CALL YNFUN(1,X,AMPI,AMFI,ALMP8,ALMV8,FUN)



      VPSVC(1,2,1,4)=VPSVC(1,2,1,4)+FACT2*( CPANN+CCRNN)*FUN(6)

      VPSVC(3,2,1,4)=VPSVC(3,2,1,4)+FACT2*( CPALS+CCRLS)*FUN(6)

      VPSVC(4,2,1,4)=VPSVC(4,2,1,4)+FACT2*( CPASS+CCRSS)*FUN(6)

      VPSVC(5,2,1,4)=VPSVC(5,2,1,4)+FACT2*( CPADR+CCRDR)*FUN(6)



      VPSVC(1,3,1,4)=VPSVC(1,3,1,4)+FACT2*( CPANN+CCRNN)*FUN(7)

      VPSVC(3,3,1,4)=VPSVC(3,3,1,4)+FACT2*( CPALS+CCRLS)*FUN(7)

      VPSVC(4,3,1,4)=VPSVC(4,3,1,4)+FACT2*( CPASS+CCRSS)*FUN(7)

      VPSVC(5,3,1,4)=VPSVC(5,3,1,4)+FACT2*( CPADR+CCRDR)*FUN(7)



C     EM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =   4*ISFAC*F1**2*FD9*FVE9

      CPALS  =  -SR3*F1*FVE9*F3*(FD11+FD10)

     .          -SR3*F1*(FD9)*F3*(FVE10+FVE11)

      CPASS  =  -4*F1*FVE9*F2*(FD11)

     .          -4*F1*(FD9)*F2*FVE11

      CPADR  =  +2*F1*FVE9*F2*(FD11)

     .          +2*F1*(FD9)*F2*FVE11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR



      VPSVC(1,3,1,4)=VPSVC(1,3,1,4)+FACT3*( CPANN+CCRNN)*FUN(3)

      VPSVC(3,3,1,4)=VPSVC(3,3,1,4)+FACT3*( CPALS+CCRLS)*FUN(3)

      VPSVC(4,3,1,4)=VPSVC(4,3,1,4)+FACT3*( CPASS+CCRSS)*FUN(3)

      VPSVC(5,3,1,4)=VPSVC(5,3,1,4)+FACT3*( CPADR+CCRDR)*FUN(3)

      ENDIF

C END PION-PHI



C PION-KSTAR EXCHANGE POTENTIALS:

      IF(IPIKS.EQ.1) THEN

C     EE-CONTRIBUTION:

C     PARALLEL:

      CPALL  =  6*F1*FD4*F3*FD5

      CPALS  =  -SR3*F1*F3*(FD4**2-FD5**2)

     .          +2*SR3*F1*F2*FD4*FD5

      CPASS  =  F1*FD5*(6*F3*FD4+4*F2*FD5)

      CPADR  =  +4*F1*F2*FD5**2

C     CROSSED:

      CCRLL  =  3*(F1*F1*FD4**2+F3*F3*FD5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*FD4*FD5

     .         +2*SR3*F2*F3*FD5**2

      CCRSS  =  5*F1**2*FD5**2+F3*F3*FD4**2

     .         +4*F2*F3*FD4*FD5

      CCRDR  =  2*F1**2*FD5**2+F3**2*FD4**2

     .         +3*F2**2*FD5**2-2*F2*F3*FD4*FD5



*     CALL YNFUN(1,X,PIM,AMKS,ALMP8,ALMKS,FUN)

      CALL YNFUN(1,X,AMPI,AMKS,ALMP8,ALMKS,FUN)

**    CALL YNFUN2(1,X,PIM,AMKS,ALMP8,ALMKS,DAM,2,FUN)



      VPSVC(2,2,1,2)=

     .VPSVC(2,2,1,2) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11) )*P

      VPSVC(3,2,1,2)=

     .VPSVC(3,2,1,2) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11) )*P

      VPSVC(4,2,1,2)=

     .VPSVC(4,2,1,2) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11) )*P

      VPSVC(5,2,1,2)=

     .VPSVC(5,2,1,2) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11) )*P



      VPSVC(2,3,1,2)=

     .VPSVC(2,3,1,2) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12) )*P

      VPSVC(3,3,1,2)=

     .VPSVC(3,3,1,2) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12) )*P

      VPSVC(4,3,1,2)=

     .VPSVC(4,3,1,2) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12) )*P

      VPSVC(5,3,1,2)=

     .VPSVC(5,3,1,2) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12) )*P



C     1/M^2-TERMS:

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPALL  =  6*F1*FVE4*F3*FVE5

      CPALS  =  -SR3*F1*F3*(FVE4**2-FVE5**2)

     .          +2*SR3*F1*F2*FVE4*FVE5

      CPASS  =  F1*FVE5*(6*F3*FVE4+4*F2*FVE5)

      CPADR  =  +4*F1*F2*FVE5**2

C     CROSSED:

      CCRLL  =  3*(F1*F1*FVE4**2+F3*F3*FVE5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*FVE4*FVE5

     .         +2*SR3*F2*F3*FVE5**2

      CCRSS  =  5*F1**2*FVE5**2+F3**2*FVE4**2

     .         +4*F2*F3*FVE4*FVE5

      CCRDR  =  2*F1**2*FVE5**2+F3**2*FVE4**2

     .         +3*F2**2*FVE5**2-2*F2*F3*FVE4*FVE5



*     CALL YNFUN(1,X,PIM,AMKS,ALMP8,ALMKS,FUN)

      CALL YNFUN(1,X,AMPI,AMKS,ALMP8,ALMKS,FUN)

**    CALL YNFUN2(1,X,PIM,AMKS,ALMP8,ALMKS,DAM,2,FUN)



      VPSVC(2,1,1,2)=VPSVC(2,1,1,2)+FACT2*(CPALL-CCRLL)*FUN(5)*P

      VPSVC(3,1,1,2)=VPSVC(3,1,1,2)+FACT2*(CPALS-CCRLS)*FUN(5)*P

      VPSVC(4,1,1,2)=VPSVC(4,1,1,2)+FACT2*(CPASS-CCRSS)*FUN(5)*P

      VPSVC(5,1,1,2)=VPSVC(5,1,1,2)+FACT2*(CPADR-CCRDR)*FUN(5)*P



      VPSVC(2,2,1,2)=VPSVC(2,2,1,2)+FACT2*(CPALL+CCRLL)*FUN(6)*P

      VPSVC(3,2,1,2)=VPSVC(3,2,1,2)+FACT2*(CPALS+CCRLS)*FUN(6)*P

      VPSVC(4,2,1,2)=VPSVC(4,2,1,2)+FACT2*(CPASS+CCRSS)*FUN(6)*P

      VPSVC(5,2,1,2)=VPSVC(5,2,1,2)+FACT2*(CPADR+CCRDR)*FUN(6)*P



      VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT2*(CPALL+CCRLL)*FUN(7)*P

      VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT2*(CPALS+CCRLS)*FUN(7)*P

      VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT2*(CPASS+CCRSS)*FUN(7)*P

      VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT2*(CPADR+CCRDR)*FUN(7)*P



C     EM-CONTRIBUTIONS:

      DO 32 ME=1,2

C     EM,2-CONTRIBUTION:

      IF(ME.EQ.2) THEN

      FVE4 = FD4+2*FV4

      FVE5 = FD5+2*FV5

      ENDIF

C     PARALLEL:

      CPALL  =  6*F1*FVE4*F3*FD5 +6*F1*FD4*F3*FVE5

      CPALS  =  -SR3*F1*F3*(FD4*FVE4-FD5*FVE5)*2

     .          +2*SR3*F1*F2*(FD4*FVE5+FVE4*FD5)

      CPASS  =  F1*FD5*(6*F3*FVE4+4*F2*FVE5)

     .         +F1*FVE5*(6*F3*FD4+4*F2*FD5)

      CPADR  =  +4*F1*F2*FD5*FVE5*2



      CPALLM =  6*F1*FVE4*F3*FD5 -6*F1*FD4*F3*FVE5

C     CROSSED:

      CCRLL  =  3*(F1*F1*FD4*FVE4+F3*F3*FD5*FVE5)*2

      CCRLS  =  SR3*(F1**2-F3**2)*(FD4*FVE5+FVE4*FD5)

     .         +2*SR3*F2*F3*FD5*FVE5*2

      CCRSS  =  5*F1**2*FD5*FVE5*2+F3**2*FD4*FVE4*2

     .         +4*F2*F3*(FD4*FVE5+FD5*FVE4)

      CCRDR  =  2*F1**2*FD5*FVE5*2+F3**2*FD4*FVE4*2

     .         +3*F2**2*FD5*FVE5*2-2*F2*F3*(FD4*FVE5+FD5*FVE4)



      CCRLLM =  3*(F1*F1*FD4*FVE4-F3*F3*FD5*FVE5)*2

      IF(ME.EQ.1) THEN

      VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT3*(CPALL+CCRLL)*FUN(3)*P

      VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT3*(CPALS+CCRLS)*FUN(3)*P

      VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT3*(CPASS+CCRSS)*FUN(3)*P

      VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT3*(CPADR+CCRDR)*FUN(3)*P



      VPSVC(2,4,1,2)=VPSVC(2,4,1,2)+FACT3*(CPALL-CCRLL)*FUN(4)*P

      VPSVC(3,4,1,2)=VPSVC(3,4,1,2)+FACT3*(CPALS-CCRLS)*FUN(4)*P

      VPSVC(4,4,1,2)=VPSVC(4,4,1,2)+FACT3*(CPASS-CCRSS)*FUN(4)*P

      VPSVC(5,4,1,2)=VPSVC(5,4,1,2)+FACT3*(CPADR-CCRDR)*FUN(4)*P



      VPSVC(2,5,1,2)=VPSVC(2,5,1,2)-FACT3*(CPALLM-CCRLLM)*FUN(4)*P

      ENDIF

      IF(ME.EQ.2) THEN

      VPSVC(2,2,1,2)=VPSVC(2,2,1,2)+FACT3*(CPALL-CCRLL)*FUN(8)*P

      VPSVC(3,2,1,2)=VPSVC(3,2,1,2)+FACT3*(CPALS-CCRLS)*FUN(8)*P

      VPSVC(4,2,1,2)=VPSVC(4,2,1,2)+FACT3*(CPASS-CCRSS)*FUN(8)*P

      VPSVC(5,2,1,2)=VPSVC(5,2,1,2)+FACT3*(CPADR-CCRDR)*FUN(8)*P



      VPSVC(2,3,1,2)=VPSVC(2,3,1,2)+FACT3*(CPALL-CCRLL)*FUN(9)*P

      VPSVC(3,3,1,2)=VPSVC(3,3,1,2)+FACT3*(CPALS-CCRLS)*FUN(9)*P

      VPSVC(4,3,1,2)=VPSVC(4,3,1,2)+FACT3*(CPASS-CCRSS)*FUN(9)*P

      VPSVC(5,3,1,2)=VPSVC(5,3,1,2)+FACT3*(CPADR-CCRDR)*FUN(9)*P



      VPSVC(2,4,1,2)=VPSVC(2,4,1,2)+FACT3*(CPALL-CCRLL)*FUN(10)*P

      VPSVC(3,4,1,2)=VPSVC(3,4,1,2)+FACT3*(CPALS-CCRLS)*FUN(10)*P

      VPSVC(4,4,1,2)=VPSVC(4,4,1,2)+FACT3*(CPASS-CCRSS)*FUN(10)*P

      VPSVC(5,4,1,2)=VPSVC(5,4,1,2)+FACT3*(CPADR-CCRDR)*FUN(10)*P



      VPSVC(2,5,1,2)=VPSVC(2,5,1,2)-FACT3*(CPALLM-CCRLLM)*FUN(10)*P

      ENDIF

      write(*,*) 'pi K^*: me=',me,' vpsvc(2,4,1,2)=',vpsvc(2,4,1,1)

     .,' vpsvc(2,5,1,2)=',vpsvc(2,5,1,1)

   32 CONTINUE

      ENDIF

C END PION-KSTAR

c     if(icall.eq.0.and.nschr.eq.1) call writetm(2,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(2,x,p)

C END VECTOR MESONS



C

C B) PION-SCALAR MESONS: *****************************************

C

C PION-DELTA EXCHANGE POTENTIALS:

      RATOSA = 0.5D0*(AMN**2-AMLN**2)/AMN/AMLN

      ratosa=0d0

      IF(IPIDE.EQ.1) THEN

C     PARALLEL:

      CPANN  =  2*(3.D0-2.D0*ISFAC)*F1**2*GS1**2

      CPALL  =  6*F1*GS1*F3*GS3

      CPALS  =  +2*SR3*F1*GS1*(F3*GS2+F2*GS3)

      CPASS  =  2*F1*GS1*(3*F3*GS3+4*F2*GS2)

      CPADR  =  2*F1*GS1*F2*GS2

C     CROSSED:

      CCRNN  =  2*(3.D0+2.D0*ISFAC)*F1**2*GS1**2

      CCRLL  =  6*F1*GS1*F3*GS3

      CCRLS  =  -2*SR3*F1*GS1*(F3*GS2+F2*GS3)

      CCRSS  =  -2*F1*GS1*F3*GS3

      CCRDR  =  2*F1*GS1*(2*F3*GS3+3*F2*GS2)

      papssc(1,1,1,1)=cpann

      crpssc(1,1,1,1)=ccrnn

      papssc(5,1,1,1)=cpadr

      crpssc(5,1,1,1)=ccrdr

      papssc(2,1,1,1)=cpall

      crpssc(2,1,1,1)=ccrll

      papssc(3,1,1,1)=cpals

      crpssc(3,1,1,1)=ccrls

      papssc(4,1,1,1)=cpass

      crpssc(4,1,1,1)=ccrss



*     CALL YNFUN(2,X,PIM,AMD,ALMP8,ALMS8,FUN)

      CALL YNFUN(2,X,AMPI,AMD,ALMP8,ALMS8,FUN)



      VPSSC(1,2,1,1)=VPSSC(1,2,1,1)+FACT*( CPANN-CCRNN)*FUN(1)

      VPSSC(2,2,1,1)=VPSSC(2,2,1,1)+FACT*( CPALL-CCRLL)*FUN(1)

      VPSSC(3,2,1,1)=VPSSC(3,2,1,1)+FACT*( CPALS-CCRLS)*FUN(1)

      VPSSC(4,2,1,1)=VPSSC(4,2,1,1)+FACT*( CPASS-CCRSS)*FUN(1)

      VPSSC(5,2,1,1)=VPSSC(5,2,1,1)+FACT*( CPADR-CCRDR)*FUN(1)



      VPSSC(1,3,1,1)=VPSSC(1,3,1,1)+FACT*( CPANN-CCRNN)*FUN(2)

      VPSSC(2,3,1,1)=VPSSC(2,3,1,1)+FACT*( CPALL-CCRLL)*FUN(2)

      VPSSC(3,3,1,1)=VPSSC(3,3,1,1)+FACT*( CPALS-CCRLS)*FUN(2)

      VPSSC(4,3,1,1)=VPSSC(4,3,1,1)+FACT*( CPASS-CCRSS)*FUN(2)

      VPSSC(5,3,1,1)=VPSSC(5,3,1,1)+FACT*( CPADR-CCRDR)*FUN(2)



      VPSSC(1,4,1,1)=VPSSC(1,4,1,1)+FACT*( CPANN-CCRNN)*FUN(3)

      VPSSC(2,4,1,1)=VPSSC(2,4,1,1)+FACT*( CPALL-CCRLL)*FUN(3)

      VPSSC(3,4,1,1)=VPSSC(3,4,1,1)+FACT*( CPALS-CCRLS)*FUN(3)

      VPSSC(4,4,1,1)=VPSSC(4,4,1,1)+FACT*( CPASS-CCRSS)*FUN(3)

      VPSSC(5,4,1,1)=VPSSC(5,4,1,1)+FACT*( CPADR-CCRDR)*FUN(3)



      VPSSC(2,5,1,1)=VPSSC(2,5,1,1)+FACT*( CPALL-CCRLL)*FUN(3)

     .*RATOSA

      write(*,*) 'pi-a0',' vpsvc(2,4,1,1)=',vpsvc(2,4,1,1)

     .,' vpsvc(2,5,1,1)=',vpsvc(2,5,1,1)

      ENDIF

C END PION-DELTA



C PION-EPSILON1 EXCHANGE POTENTIALS: NO ADIABATIC CONTRIBUTIONS



C PION-SSTAR EXCHANGE POTENTIALS: NO ADIABATIC CONTRIBUTIONS



C PION-KAPPA EXCHANGE POTENTIALS:

      IF(IPIKSC.EQ.1) THEN

C     PARALLEL:

      CPALL  =  6*F1*GS4*F3*GS5

      CPALS  =  -SR3*F1*F3*(GS4**2-GS5**2)

     .          +2*SR3*F1*F2*GS4*GS5

      CPASS  =  F1*GS5*(6*F3*GS4+4*F2*GS5)

      CPADR  =  +4*F1*F2*GS5**2

C     CROSSED:

      CCRLL  =  3*(F1*F1*GS4**2+F3*F3*GS5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*GS4*GS5

     .         +2*SR3*F2*F3*GS5**2

      CCRSS  =  5*F1**2*GS5**2+F3*F3*GS4**2

     .         +4*F2*F3*GS4*GS5

      CCRDR  =  2*F1**2*GS5**2+F3**2*GS4**2

     .         +3*F2**2*GS5**2-2*F2*F3*GS4*GS5

      papssc(5,1,1,2)=cpadr

      crpssc(5,1,1,2)=ccrdr

      papssc(2,1,1,2)=cpall

      crpssc(2,1,1,2)=ccrll

      papssc(3,1,1,2)=cpals

      crpssc(3,1,1,2)=ccrls

      papssc(4,1,1,2)=cpass

      crpssc(4,1,1,2)=ccrss



*     CALL YNFUN(2,X,PIM,AMSCK,ALMP8,ALMS8,FUN)

      CALL YNFUN(2,X,AMPI,AMSCK,ALMP8,ALMS8,FUN)

**    CALL YNFUN2(2,X,PIM,AMSCK,ALMP8,ALMS8,DAM,2,FUN)



      VPSSC(2,2,1,2)=VPSSC(2,2,1,2)+FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSSC(3,2,1,2)=VPSSC(3,2,1,2)+FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSSC(4,2,1,2)=VPSSC(4,2,1,2)+FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSSC(5,2,1,2)=VPSSC(5,2,1,2)+FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSSC(2,3,1,2)=VPSSC(2,3,1,2)+FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSSC(3,3,1,2)=VPSSC(3,3,1,2)+FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSSC(4,3,1,2)=VPSSC(4,3,1,2)+FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSSC(5,3,1,2)=VPSSC(5,3,1,2)+FACT*(CPADR-CCRDR)*FUN(2)*P

C     toegevoegd may 2006:

      VPSSC(1,4,1,2)=VPSSC(1,4,1,2)+FACT*( CPANN-CCRNN)*FUN(3)

      VPSSC(2,4,1,2)=VPSSC(2,4,1,2)+FACT*( CPALL-CCRLL)*FUN(3)

      VPSSC(3,4,1,2)=VPSSC(3,4,1,2)+FACT*( CPALS-CCRLS)*FUN(3)

      VPSSC(4,4,1,2)=VPSSC(4,4,1,2)+FACT*( CPASS-CCRSS)*FUN(3)

      VPSSC(5,4,1,2)=VPSSC(5,4,1,2)+FACT*( CPADR-CCRDR)*FUN(3)



      VPSSC(2,5,1,2)=VPSSC(2,5,1,2)+FACT*( CPALL-CCRLL)*FUN(3)

     .*RATOSA

      write(*,*) 'pi-kap ',' vpsvc(2,4,1,2)=',vpsvc(2,4,1,2)

     .,' vpsvc(2,5,1,2)=',vpsvc(2,5,1,2)

      ENDIF

C END PION-KAPPA

c     if(icall.eq.0.and.nschr.eq.1) call writetm(3,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(3,x,p)

C END SCALAR MESONS



C

C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************

C

C PION-A2 EXCHANGE POTENTIALS:

      IF(IPIA2.EQ.1) THEN

C     PARALLEL:

      CPANN  =  2*(3.D0-2.D0*ISFAC)*F1**2*GD1**2

      CPALL  =  6*F1*GD1*F3*GD3

      CPALS  =  +2*SR3*F1*GD1*(F3*GD2+F2*GD3)

      CPASS  =  2*F1*GD1*(3*F3*GD3+4*F2*GD2)

      CPADR  =  2*F1*GD1*F2*GD2

C     CROSSED:

      CCRNN  =  2*(3.D0+2.D0*ISFAC)*F1**2*GD1**2

      CCRLL  =  6*F1*GD1*F3*GD3

      CCRLS  =  -2*SR3*F1*GD1*(F3*GD2+F2*GD3)

      CCRSS  =  -2*F1*GD1*F3*GD3

      CCRDR  =  2*F1*GD1*(2*F3*GD3+3*F2*GD2)



*     CALL YNFUN(4,X,PIM,AMPOM,ALMP8,AMPRO,FUN)

      CALL YNFUN(4,X,AMPI,AMPOM,ALMP8,AMPRO,FUN)



      VPSDF(1,2,1,1)=VPSDF(1,2,1,1)-FACT*(CPANN-CCRNN)*FUN(1)

      VPSDF(2,2,1,1)=VPSDF(2,2,1,1)-FACT*(CPALL-CCRLL)*FUN(1)

      VPSDF(3,2,1,1)=VPSDF(3,2,1,1)-FACT*(CPALS-CCRLS)*FUN(1)

      VPSDF(4,2,1,1)=VPSDF(4,2,1,1)-FACT*(CPASS-CCRSS)*FUN(1)

      VPSDF(5,2,1,1)=VPSDF(5,2,1,1)-FACT*(CPADR-CCRDR)*FUN(1)



      VPSDF(1,3,1,1)=VPSDF(1,3,1,1)-FACT*(CPANN-CCRNN)*FUN(2)

      VPSDF(2,3,1,1)=VPSDF(2,3,1,1)-FACT*(CPALL-CCRLL)*FUN(2)

      VPSDF(3,3,1,1)=VPSDF(3,3,1,1)-FACT*(CPALS-CCRLS)*FUN(2)

      VPSDF(4,3,1,1)=VPSDF(4,3,1,1)-FACT*(CPASS-CCRSS)*FUN(2)

      VPSDF(5,3,1,1)=VPSDF(5,3,1,1)-FACT*(CPADR-CCRDR)*FUN(2)

      ENDIF

C END PION-A2



C PION-POMERON: NO ADIABATIC CONTRIBUTIONS



C PION-K** EXCHANGE POTENTIALS:

      IF(IPIKSS.EQ.1) THEN

C     PARALLEL:

      CPALL  =  6*F1*GD4*F3*GD5

      CPALS  =  -SR3*F1*F3*(GD4**2-GD5**2)

     .          +2*SR3*F1*F2*GD4*GD5

      CPASS  =  F1*GD5*(6*F3*GD4+4*F2*GD5)

      CPADR  =  +4*F1*F2*GD5**2

C     CROSSED:

      CCRLL  =  3*(F1*F1*GD4**2+F3*F3*GD5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*GD4*GD5

     .         +2*SR3*F2*F3*GD5**2

      CCRSS  =  5*F1**2*GD5**2+F3*F3*GD4**2

     .         +4*F2*F3*GD4*GD5

      CCRDR  =  2*F1**2*GD5**2+F3**2*GD4**2

     .         +3*F2**2*GD5**2-2*F2*F3*GD4*GD5



*     CALL YNFUN(4,X,PIM,AMPOM,ALMP8,AMPRO,FUN)

      CALL YNFUN(4,X,AMPI,AMPOM,ALMP8,AMPRO,FUN)

**    CALL YNFUN2(4,X,PIM,AMPOM,ALMP8,AMPRO,DAM,2,FUN)



      VPSDF(2,2,1,2)=VPSDF(2,2,1,2)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,1,2)=VPSDF(3,2,1,2)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,1,2)=VPSDF(4,2,1,2)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,1,2)=VPSDF(5,2,1,2)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,1,2)=VPSDF(2,3,1,2)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,1,2)=VPSDF(3,3,1,2)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,1,2)=VPSDF(4,3,1,2)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,1,2)=VPSDF(5,3,1,2)-FACT*(CPADR-CCRDR)*FUN(2)*P

      ENDIF

C END PION-K**

  30  CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writetm(4,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(4,x,p)

C END DIFFRACTIVE CONTRIBUTIONS



C  1  CONTINUE



1000  CALL ERRSET(208,256,1,1)

      ICALL = ICALL + 1

      RETURN

C END YNPIBE ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE YNPSBE(X,INA,IPV,IOFF,APV)

C **********************************************************************

C *

C *   DATE: FEBRUARY 1995 , YNPSBE = COMPLEMENT YNPIBE

C

C *   KAON-MESON AND ETA(P)-MESON EXCHANGE YN-POTENTIALS

C *   (MESON= VECTOR, SCALAR, DIFFR.)

C *

C * THIS ROUTINE: BW ADIABATIC-APPROXIMATION, TMO LOWEST APPROXIMATION

C *               NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS

C * FROM: PI-EPSILON, PI-POMERON

C

C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET

C     VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET

C     SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET

C *

C **********************************************************************

C     CALL YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN):

C

C     KIND=1, PSEUDOSCALAR-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT  FUN(4) = OPAEMO

C     FUN(5) = OPAMMC  FUN(6) = OPAMMS  FUN(7) = OPAMMT

C     KIND=2, PSEUDOSCALAR-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C     KIND=4, PSEUDOSCALAR-DIFFRACTIVE EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT

C **********************************************************************

C

C     INCLUDED IN ENERGY-DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT,FACT2

C     INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKAP

      COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD,

     .ALPA

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

*     COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

*     COMMON/ALLAX/FA1,FA9,ALPAX

*     COMMON/OOM/ INA,IPV,IOFF

C

      DIMENSION FUN(12),FUNX(12),AMSIG(2),ASIG(2),AMVEC(2),AVEC(2)



      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))

      COMMON/PSBE/ 

     .VPSPS(5,5,4,4),VPSVC(5,5,4,4),VPSSC(5,5,4,4),VPSDF(5,5,4,4)

      CHARACTER *4 NTYPM(4,4)

      DATA NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','OM  ','PHI ',

     .'DE  ','KAP ','EPS ','S*  ','A2  ','K** ','POM ','POMP'/

C



      DATA IKARO/1/,IKAOM/1/,IKAPH/1/,IKAKS/1/,IKADE/1/,IKAEP/1/,

     .     IKAST/1/,IKAKSC/1/,IKAA2/1/,IKAPOM/1/,IKAKSS/1/,

     .     IETKSC/1/,IETPKP/1/,IETAKS/1/,IETPKS/1/,IEPEP/0/

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,DAM/230.D0/

*     DATA AMPRO/1138.2796D0/,AMRO/760.D0/,AMEPS/760.D0/

      DATA N3/27/,ICALL/0/,ISFAC/1/,NSCHR/1/

      SAVE AMN,FACT,FACT2,FACT3,ISFLL,ISFLS,ISFSS

C

      CALL ERRSET(208,256,-1,1)

C

      pim=pim0

*     pim=500.d0



      IF(ICALL.EQ.0) THEN

        AMN = AMPRO

        FACT = PIM0/2.D0

*       FACT2= 0.25D0*FACT*(PIM0/AMN)**2

*       FACT3=0.5D0*FACT2

        FACT2= 0.5D0*FACT*(PIM0/AMN)**2

        FACT3= 0.5D0*FACT2

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

        ISFLL=(1+ISFAC)/2

        ISFLS=(3-ISFAC)

        ISFSS=(9+ISFAC)/2



        PRINT 52, INA,IPV,IOFF,IKARO,IKAOM,IKAPH,IKAKS,

     .  IKADE,IKAEP,IKAST,IKAKSC,IKAA2,IKAPOM,IKAKSS,

     .  IETKSC,IETPKP,IETAKS,IETPKS

 52     FORMAT(//,'  IN YNPSBE: INA,IPV,IOFF=',3I3,//,

     .  11X,'  IKARO,IKAOM,IKAPH,IKAKS=',4I2,//,

     .  11X,'  IKADE,IKAEP,IKAST,IKAKSC=',4I2,//,

     .  11X,'  IPIA2,IPIPOM,IPIKSS=',3I2,//,

     .  11X,'  IETKSC,IETPKP,IETAKS,IETPKS=',4I2,//)

        PRINT 53, ALMP1,ALMV1,ALMS1,ALMP8,ALMV8,ALMS8,PIM,DAM

 53     FORMAT(/,' IN YNPSBE: ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=',

     .  D10.3,/,11X,' ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',D10.3,/,

     .  11X,'  PIM =',F10.3,'  DAM =',F10.3,/)

**      ICALL=1

      ENDIF

C     XI-COUPLINGS:

      XF12 = F1*(4*ALP-1.D0)/SR3

      XF13 = -F1

      XFD12= FD1*(4*ALVD-1.D0)/SR3

      XFD13= -FD1

      XFV12= FV1*(4*ALVV-1.D0)/SR3

      XFV13= -FV1

      XGS12= GS1*(4*ALS-1.D0)/SR3

      XGS13= -GS1

      XGD12= GD1*(4*ALD-1.D0)/SR3

      XGD13= -GD1

C

C     CONSTRUCTION OF THE POTENTIALS

C

*     DO 1 I=2,NMAX

*     X = XA(I)

c     VCNN =0.D0

c     VSNN =0.D0

c     VCLL =0.D0

c     VCLS =0.D0

c     VCSS =0.D0

c     VCDR =0.D0

c     VSLL =0.D0

c     VSLS =0.D0

c     VSSS =0.D0

c     VSDR =0.D0

c     VTLL =0.D0

c     VTLS =0.D0

c     VTSS =0.D0

c     VTDR =0.D0

c     VOLL =0.D0

c     VOLS =0.D0

c     VOSS =0.D0

c     VODR =0.D0

c     VALL =0.D0

c     VALS =0.D0

c     VASS =0.D0

c     VADR =0.D0



C     1/M-CORRECTIONS:

      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)

     .CALL OMPSBE(X,INA,IPV,IOFF,APV)

      IF(INA.EQ.1.AND.IEPEP.NE.0) CALL OMSCDF(X,INA)



C A)  PSEUDO-SCALAR-VECTOR-MESON POTENTIALS: **********************

C

      DO 100 II=1,12

      IF(II.LE.4) M=2

      IF(II.GE.5.and.II.LE.8) M=3

      IF(II.GE.9.and.II.LE.12) M=4

      DO 101 IVV=1,4

      GOTO(1,2,3,4,5,6,7,8,9,10,11,12), II

C     KA-RHO:

    1 N = 1

      PEX= P

      CALL YNFUN(1,X,AMK,AMRO,ALMKA,ALMV8,FUN)

**    CALL YNFUN2(1,X,AMK,AMRO,ALMKA,ALMV8,DAM,1,FUN)

C     EE-TERMS:

      IF(IVV.EQ.1) THEN

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*FD1*FD3*F4*F5

      CPALS  =  +2*SR3*FD1*FD2*F4*F5-SR3*FD1*FD3*(F4**2-F5**2)

      CPASS  =  6*FD1*FD3*F4*F5+4*FD1*FD2*F5**2

      CPADR  =  4*FD1*FD2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(FD1**2*F4**2+FD3**2*F5**2)

      CCRLS  =  SR3*(FD1**2*F4*F5-FD3**2*F4*F5+2*FD2*FD3*F5**2)

      CCRSS  =  5*FD1**2*F5**2+FD3**2*F4**2+4*FD2*FD3*F4*F5

      CCRDR  =  2*FD1**2*F5**2+FD3**2*F4**2

     .         +3*FD2**2*F5**2-2*FD2*FD3*F4*F5

      ENDIF



      IF(IVV.EQ.2) THEN

C     1/M^2-TERMS:

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*FVE1*FVE3*F4*F5

      CPALS  =  +2*SR3*FVE1*FVE2*F4*F5-SR3*FVE1*FVE3*(F4**2-F5**2)

      CPASS  =  6*FVE1*FVE3*F4*F5+4*FVE1*FVE2*F5**2

      CPADR  =  4*FVE1*FVE2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(FVE1**2*F4**2+FVE3**2*F5**2)

      CCRLS  =  SR3*(FVE1**2*F4*F5-FVE3**2*F4*F5+2*FVE2*FVE3*F5**2)

      CCRSS  =  5*FVE1**2*F5**2+FVE3**2*F4**2+4*FVE2*FVE3*F4*F5

      CCRDR  =  2*FVE1**2*F5**2+FVE3**2*F4**2+

     .          3*FVE2**2*F5**2-2*FVE2*FVE3*F4*F5

      ENDIF



C     EM-CONTRIBUTIONS:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE1 = FD1+2*FV1

      FVE2 = FD2+2*FV2

      FVE3 = FD3+2*FV3

      ENDIF

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*(FVE1*FD3+FD1*FVE3)*F4*F5

      CPALS  =  +2*SR3*FVE1*FD2*F4*F5-SR3*FVE1*FD3*(F4**2-F5**2)

     .          +2*SR3*FVE2*FD1*F4*F5-SR3*FVE3*FD1*(F4**2-F5**2)

      CPASS  =  6*FVE1*FD3*F4*F5+4*FVE1*FD2*F5**2

     .         +6*FVE3*FD1*F4*F5+4*FVE2*FD1*F5**2

      CPADR  =  4*(FVE1*FD2+FVE2*FD1)*F5**2



      CPALLM =  6*(FVE1*FD3-FD1*FVE3)*F4*F5

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  6*(FVE1*FD1*F4**2+FVE3*FD3*F5**2)

      CCRLS  =  SR3*(FVE1*FD1*F4*F5-FVE3*FD3*F4*F5+2*FVE2*FD3*F5**2)

     .         +SR3*(FVE1*FD1*F4*F5-FVE3*FD3*F4*F5+2*FVE3*FD2*F5**2)

      CCRSS  =  5*FVE1*FD1*F5**2+FVE3*FD3*F4**2+4*FVE2*FD3*F4*F5

     .         +5*FVE1*FD1*F5**2+FVE3*FD3*F4**2+4*FVE3*FD2*F4*F5

      CCRDR  =  (2*FVE1*FD1*F5**2+FVE3*FD3*F4**2)*2

     .         +6*FVE2*FD2*F5**2-2*(FVE2*FD3+FVE3*FD2)*F4*F5



      CCRLLM =  6*(FVE1*FD1*F4**2-FVE3*FD3*F5**2)

      ENDIF

      GOTO 102

C END KAON-RHO

C

C KAON-OMEGA EXCHANGE POTENTIALS:

    3 N = 3

      PEX= P

      CALL YNFUN(1,X,AMK,AMOM,ALMKA,ALMV1,FUN)

**    CALL YNFUN2(1,X,AMK,AMOM,ALMKA,ALMV1,DAM,1,FUN)

      IF(IVV.EQ.1) THEN

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD6*FD7*F4**2

      CPALS  =  -SR3*FD6*(FD7+FD8)*F4*F5

      CPASS  =  -2*FD6*FD8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FD6**2+FD7**2)*F4**2

      CCRLS  =  -SR3*(FD6**2+FD7*FD8)*F4*F5

      CCRSS  =  -(FD6**2+FD8**2)*F5**2

      CCRDR  =  -2*CCRSS

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FVE6*FVE7*F4**2

      CPALS  =  -SR3*FVE6*(FVE7+FVE8)*F4*F5

      CPASS  =  -2*FVE6*FVE8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FVE6**2+FVE7**2)*F4**2

      CCRLS  =  -SR3*(FVE6**2+FVE7*FVE8)*F4*F5

      CCRSS  =  -(FVE6**2+FVE8**2)*F5**2

      CCRDR  =  -2*CCRSS

      ENDIF



C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE6 = FD6+2*FV6

      FVE7 = FD7+2*FV7

      FVE8 = FD8+2*FV8

      ENDIF

c     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(FVE6*FD7+FVE7*FD6)*F4**2

      CPALS  =  -SR3*FVE6*(FD7+FD8)*F4*F5

     .          -SR3*FD6*(FVE7+FVE8)*F4*F5

      CPASS  =  -2*(FVE6*FD8+FVE8*FD6)*F5**2

      CPADR  =  -2*CPASS



      CPALLM =  2*(FVE6*FD7-FVE7*FD6)*F4**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  2*(FVE6*FD6+FVE7*FD7)*F4**2

      CCRLS  =  -SR3*(2*FVE6*FD6+FVE7*FD8+FVE8*FD7)*F4*F5

      CCRSS  =  -2*(FVE6*FD6+FVE8*FD8)*F5**2

      CCRDR  =  -2*CCRSS



      CCRLLM =  2*(FVE6*FD6-FVE7*FD7)*F4**2

      ENDIF

      GOTO 102

C END KAON-OMEGA



C KAON-PHI EXCHANGE POTENTIALS:

    4 N = 4

      PEX= P

      CALL YNFUN(1,X,AMK,AMFI,ALMKA,ALMV8,FUN)

**    CALL YNFUN2(1,X,AMK,AMFI,ALMKA,ALMV8,DAM,1,FUN)

      IF(IVV.EQ.1) THEN

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD9*FD10*F4**2

      CPALS  =  -SR3*FD9*(FD10+FD11)*F4*F5

      CPASS  =  -2*FD9*FD11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FD9**2+FD10**2)*F4**2

      CCRLS  =  -SR3*(FD9**2+FD10*FD11)*F4*F5

      CCRSS  =  -(FD9**2+FD11**2)*F5**2

      CCRDR  =  -2*CCRSS

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FVE9*FVE10*F4**2

      CPALS  =  -SR3*FVE9*(FVE10+FVE11)*F4*F5

      CPASS  =  -2*FVE9*FVE11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FVE9**2+FVE10**2)*F4**2

      CCRLS  =  -SR3*(FVE9**2+FVE10*FVE11)*F4*F5

      CCRSS  =  -(FVE9**2+FVE11**2)*F5**2

      CCRDR  =  -2*CCRSS

      ENDIF



C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE9 = FD9+2*FV9

      FVE10= FD10+2*FV10

      FVE11= FD11+2*FV11

      ENDIF

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(FVE9*FD10+FVE10*FD9)*F4**2

      CPALS  =  -SR3*FVE9*(FD10+FD11)*F4*F5

     .          -SR3*FD9*(FVE10+FVE11)*F4*F5

      CPASS  =  -2*(FVE9*FD11+FVE11*FD9)*F5**2

      CPADR  =  -2*CPASS



      CPALLM =  2*(FVE9*FD10-FVE10*FD9)*F4**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  2*(FVE9*FD9+FVE10*FD10)*F4**2

      CCRLS  =  -SR3*(2*FVE9*FD9+FVE10*FD11+FVE11*FD10)*F4*F5

      CCRSS  =  -2*(FVE9*FD9+FVE11*FD11)*F5**2

      CCRDR  =  -2*CCRSS



      CCRLLM =  2*(FVE9*FD9-FVE10*FD10)*F4**2

      ENDIF

      GOTO 102

C END KAON-PHI



C KAON-KSTAR EXCHANGE POTENTIALS:

    2 N = 2

      PEX= 1.D0

      CALL YNFUN(1,X,AMK,AMKS,ALMKA,ALMKS,FUN)

*     CALL YNFUN3(1,1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUN)

*     CALL YNFUN3(2,1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUNX)

*     FUN(11) = FUNX(1)

*     FUN(12) = FUNX(2)

**    CALL DKBFUN(1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUN)

      IF(IVV.EQ.1) THEN

C     PARALLEL:

      CPANN  = 0.D0

      CPALL  =  2*(FD4**2*F4**2+3*FD4*FD5*F4*F5)

      CPALS  =  SR3*(FD5**2*F4*F5+FD4*FD5*F5**2

     .          -FD4**2*F4*F5-FD4*FD5*F4**2)

      CPASS  =  2*(3*FD4*FD5*F4*F5+FD5**2*F5**2)

      CPADR  =  8*FD5**2*F5**2

C     CROSSED:

*     CCRNN  =  2*(ISFLL*FD4**2*F4**2+ISFLS*FD4*FD5*F4*F5+

*    .          ISFSS*FD5**2*F5**2)

      CCRNN  =  (FD4*F4+3*FD5*F5)**2+ISFAC*(FD4*F4-FD5*F5)**2

      CCRLL  =  +2*(FD4*XFD12*F4*XF12+3*FD5*XFD12*F5*XF12)

      CCRLS  =  SR3*(FD4*F4-FD5*F5)*(XFD13*XF12+XFD12*XF13)

      CCRSS  =  -2*FD4*XFD13*F4*XF13+10*FD5*XFD13*F5*XF13

      CCRDR  =  +4*FD5*F5*XFD13*XF13 + 4*FD4*F4*XFD13*XF13

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

      FVE12= XFD12+XFV12

      FVE13= XFD13+XFV13

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(FVE4**2*F4**2+3*FVE4*FVE5*F4*F5)

      CPALS  =  SR3*(FVE5**2*F4*F5+FVE4*FVE5*F5**2

     .          -FVE4**2*F4*F5-FVE4*FVE5*F4**2)

      CPASS  =  2*(3*FVE4*FVE5*F4*F5+FVE5**2*F5**2)

      CPADR  =  8*FVE5**2*F5**2

C     CROSSED:

*     CCRNN  =  2*(isfll*fve4**2*f4**2+isfls*fve4*fve5*f4*f5+

*    .             isfss*fve5**2*f5**2)

      CCRNN  =  (FVE4*F4+3*FVE5*F5)**2+ISFAC*(FVE4*F4-FVE5*F5)**2

      CCRLL  =  +2*(FVE4*FVE12*F4*XF12+3*FVE5*FVE12*F5*XF12)

      CCRLS  =  +SR3*(FVE4*F4-FVE5*F5)*(FVE13*XF12+FVE12*XF13)

      CCRSS  =  -2*FVE4*FVE13*F4*XF13+10*FVE5*FVE13*F5*XF13

      CCRDR  =  +4*FVE5*FVE13*F5*XF13 +4*FVE4*F4*FVE13*XF13

      ENDIF



C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.4) THEN

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

      FVE12= XFD12+XFV12

      FVE13= XFD13+XFV13

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE4 = FD4+2*FV4

      FVE5 = FD5+2*FV5

      FVE12= XFD12+2*XFV12

      FVE13= XFD13+2*XFV13

      ENDIF

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(2*FVE4*FD4*F4**2+3*(FVE4*FD5+FVE5*FD4)*F4*F5)

      CPALS  =  SR3*(2*FVE5*FD5*F4*F5+(FVE4*FD5+FD4*FVE5)*F5**2

     .          -2*FVE4*FD4*F4*F5-(FVE4*FD5+FVE5*FD4)*F4**2)

      CPASS  =  2*(3*(FVE4*FD5+FD4*FVE5)*F4*F5+2*FVE5*FD5*F5**2)

      CPADR  =  16*FVE5*FD5*F5**2



      CPALLM =  2*(3*(FVE4*FD5-FVE5*FD4)*F4*F5)

C     CROSSED:

*     CCRNN  =  2*(2*isfll*fve4*fd4*f4**2+isfls*(fve4*fd5+fd4*fve5)*

*    .            f4*f5+2*isfss*fve5*fd5*f5**2)

      CCRNN  =  (FVE4*F4+3*FVE5*F5)*(FD4*F4+3*FD5*F5)*2

     .          +ISFAC*(FVE4*F4-FVE5*F5)*(FD4*F4-FD5*F5)*2

      CCRLL  =  +2*(FD4*FVE12*F4*XF12+3*FD5*FVE12*F5*XF12)

     .          +2*(FVE4*XFD12*F4*XF12+3*FVE5*XFD12*F5*XF12)

      CCRLS  =  +SR3*(FVE4*F4-FVE5*F5)*(XFD13*XF12+XFD12*XF13)

     .          +SR3*(FD4*F4-FD5*F5)*(FVE13*XF12+FVE12*XF13)

      CCRSS  =  -2*FVE4*XFD13*F4*XF13+10*FVE5*XFD13*F5*XF13

     .          -2*FD4*FVE13*F4*XF13+10*FD5*FVE13*F5*XF13

      CCRDR  =  +4*(FVE4*XFD13+FD4*FVE13)*F4*XF13

     .          +4*(FVE5*XFD13+FD5*FVE13)*F5*XF13



      CCRLLM =  +2*(FVE4*XFD12*F4*XF12-3*FVE5*XFD12*F5*XF12)

      ENDIF

      GOTO 102

C END KAON-KSTAR



C ETA-RHO EXCHANGE POTENTIALS:

    5 N = 1

      PEX= 1.D0

      CALL YNFUN(1,X,AME,AMRO,ALMP8,ALMV8,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*ISFAC*FD1**2*F6**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*FD1*FD3*F6*(F7+F8)

      CPASS  =  -4*FD1*FD2*F6*F8

      CPADR  =  +2*FD1*F6*FD2*F8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*ISFAC*FVE1**2*F6**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*FVE1*FVE3*F6*(F7+F8)

      CPASS  =  -4*FVE1*FVE2*F6*F8

      CPADR  =  +2*FVE1*F6*FVE2*F8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE1 = FD1+2*FV1

      FVE2 = FD2+2*FV2

      FVE3 = FD3+2*FV3

      ENDIF

C     PARALLEL:

      CPANN  =  4*ISFAC*FVE1*FD1*F6**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*(FVE1*FD3+FVE3*FD1)*F6*(F7+F8)

      CPASS  =  -4*(FVE1*FD2+FVE2*FD1)*F6*F8

      CPADR  =  +2*(FVE1*FD2+FVE2*FD1)*F6*F8

      CPALLM = 0D0

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      CCRLLM = 0D0

      ENDIF

      GOTO 102



C ETA-KSTAR EXCHANGE POTENTIALS:

    6 N = 2

      PEX= P    

      CALL YNFUN(1,X,AME,AMKS,ALMP8,ALMKS,FUN)

**    CALL YNFUN2(1,X,AME,AMKS,ALMP8,ALMKS,DAM,2,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD4**2*F6*F7

      CPALS  =  -SR3*FD4*FD5*F6*(F7+F8)

      CPASS  =  -2*FD5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FD4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*FD4*FD5*(F6**2+F7*F8)

      CCRSS  =  -FD5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FVE4**2*F6*F7

      CPALS  =  -SR3*FVE4*FVE5*F6*(F7+F8)

      CPASS  =  -2*FVE5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FVE4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*FVE4*FVE5*(F6**2+F7*F8)

      CCRSS  =  -FVE5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE4 = FD4+2*FV4

      FVE5 = FD5+2*FV5

      ENDIF

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  4*FVE4*FD4*F6*F7

      CPALS  =  -SR3*(FVE4*FD5+FD4*FVE5)*F6*(F7+F8)

      CPASS  =  -4*FVE5*FD5*F6*F8

      CPADR  =  -2*CPASS

      CPALLM = 0D0

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  2*FVE4*FD4*(F6**2+F7**2)

      CCRLS  =  -SR3*(FVE4*FD5+FD4*FVE5)*(F6**2+F7*F8)

      CCRSS  =  -2*FVE5*FD5*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS

      CCRLLM = 0D0

      ENDIF

      GOTO 102

C END ETA-KSTAR



C ETA-OM EXCHANGE POTENTIALS:

    7 N = 3

      PEX= 1.D0 

      CALL YNFUN(1,X,AME,AMOM,ALMP8,ALMV1,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*FD6**2*F6**2

      CPALL  =  2*FD6*FD7*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*FD6*FD8*F6*F8 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*FVE6**2*F6**2

      CPALL  =  2*FVE6*FVE7*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*FVE6*FVE8*F6*F8 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE6 = FD6+2*FV6

      FVE7 = FD7+2*FV7

      FVE8 = FD8+2*FV8

      ENDIF

C     PARALLEL:

      CPANN  =  4*FVE6*FD6*F6**2

      CPALL  =  2*(FVE6*FD7+FVE7*FD6)*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*(FVE6*FD8+FVE8*FD7)*F6*F8 

      CPADR  =  CPASS             

      CPALLM =  2*(FVE6*FD7-FVE7*FD6)*F6*F7

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      CCRLLM =  CPALLM

      ENDIF

      GOTO 102



C ETA-PHI EXCHANGE POTENTIALS:

    8 N = 4

      PEX= 1.D0 

      CALL YNFUN(1,X,AME,AMFI,ALMP8,ALMV8,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*FD9**2*F6**2

      CPALL  =  2*FD9*FD10*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*FD9*FD11*F6*F8 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*FVE9**2*F6**2

      CPALL  =  2*FVE9*FVE10*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*FVE9*FVE11*F6*F8 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE9 = FD9+2*FV9

      FVE10= FD10+2*FV10

      FVE11= FD11+2*FV11

      ENDIF

C     PARALLEL:

      CPANN  =  4*FVE9*FD9*F6**2

      CPALL  =  2*(FVE9*FD10+FVE10*FD9)*F6*F7

      CPALS  =  0.D0   

      CPASS  =  2*(FVE9*FD11+FVE11*FD9)*F6*F8 

      CPADR  =  CPASS             

      CPALLM =  2*(FVE9*FD10-FVE10*FD9)*F6*F7

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      CCRLLM =  CPALLM                         

      ENDIF

      GOTO 102



C ETAP-RHO EXCHANGE POTENTIALS:

    9 N = 1

      PEX= 1.D0 

      CALL YNFUN(1,X,AMX,AMRO,ALMP1,ALMV8,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*ISFAC*FD1**2*F9**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*FD1*FD3*F9*(F10+F11)

      CPASS  =  -4*FD1*FD2*F9*F11

      CPADR  =  +2*FD1*F9*FD2*F11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*ISFAC*FVE1**2*F9**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*FVE1*FVE3*F9*(F11+F11)

      CPASS  =  -4*FVE1*FVE2*F9*F11

      CPADR  =  +2*FVE1*F9*FVE2*F11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE1 = FD1+FV1

      FVE2 = FD2+FV2

      FVE3 = FD3+FV3

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE1 = FD1+2*FV1

      FVE2 = FD2+2*FV2

      FVE3 = FD3+2*FV3

      ENDIF

C     PARALLEL:

      CPANN  =  4*ISFAC*FVE1*FD1*F9**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*(FVE1*FD3+FVE3*FD1)*F9*(F10+F11)

      CPASS  =  -4*(FVE1*FD2+FVE2*FD1)*F9*F11

      CPADR  =  +2*(FVE1*FD2+FVE2*FD1)*F9*F11



      CPALLM = 0D0

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    



      CCRLLM = 0D0

      ENDIF

      GOTO 102



C ETAP-KSTAR EXCHANGE POTENTIALS:

   10 N = 2

      PEX= P    

      CALL YNFUN(1,X,AMX,AMKS,ALMP1,ALMKS,FUN)

c*    CALL YNFUN2(1,X,AMX,AMKS,ALMP1,ALMKS,DAM,2,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD4**2*F9*F10

      CPALS  =  -SR3*FD4*FD5*F9*(F10+F11)

      CPASS  =  -2*FD5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FD4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*FD4*FD5*(F9**2+F10*F11)

      CCRSS  =  -FD5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FVE4**2*F9*F10

      CPALS  =  -SR3*FVE4*FVE5*F9*(F10+F11)

      CPASS  =  -2*FVE5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FVE4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*FVE4*FVE5*(F9**2+F10*F11)

      CCRSS  =  -FVE5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS

      ENDIF



C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.4) THEN

      FVE4 = FD4+FV4

      FVE5 = FD5+FV5

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE4 = FD4+2*FV4

      FVE5 = FD5+2*FV5

      ENDIF

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  4*FVE4*FD4*F9*F10

      CPALS  =  -SR3*(FVE4*FD5+FD4*FVE5)*F9*(F10+F11)

      CPASS  =  -4*FVE5*FD5*F9*F11

      CPADR  =  -2*CPASS

      CPALLM =  0D0

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  2*FVE4*FD4*(F9**2+F10**2)

      CCRLS  =  -SR3*(FVE4*FD5+FD4*FVE5)*(F9**2+F10*F11)

      CCRSS  =  -2*FVE5*FD5*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS

      CCRLLM =  0D0

      ENDIF

      GOTO 102

C END ETAP-KSTAR



C ETAP-OM EXCHANGE POTENTIALS:

   11 N = 3

      PEX = 1.D0

      CALL YNFUN(1,X,AMX,AMOM,ALMP1,ALMV1,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*FD6**2*F9**2

      CPALL  =  2*FD6*FD7*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*FD6*FD8*F9*F11 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*FVE6**2*F9**2

      CPALL  =  2*FVE6*FVE7*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*FVE6*FVE8*F9*F11 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE6 = FD6+FV6

      FVE7 = FD7+FV7

      FVE8 = FD8+FV8

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE6 = FD6+2*FV6

      FVE7 = FD7+2*FV7

      FVE8 = FD8+2*FV8

      ENDIF

C     PARALLEL:

      CPANN  =  4*FVE6*FD6*F9**2

      CPALL  =  2*(FVE6*FD7+FVE7*FD6)*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*(FVE6*FD8+FVE8*FD7)*F9*F11 

      CPADR  =  CPASS             

      CPALLM =  2*(FVE6*FD7-FVE7*FD6)*F9*F10

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      CCRLLM =  CPALLM

      ENDIF

      GOTO 102



C ETAP-PHI EXCHANGE POTENTIALS:

   12 N = 4

      PEX = 1.D0

      CALL YNFUN(1,X,AMX,AMFI,ALMP1,ALMV8,FUN)

      IF(IVV.EQ.1) THEN    

C     PARALLEL:

      CPANN  =  2*FD9**2*F9**2

      CPALL  =  2*FD9*FD10*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*FD9*FD11*F9*F11 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF



C     1/M^2-TERMS:

      IF(IVV.EQ.2) THEN    

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

C     MM-CONTRIBUTION:

C     PARALLEL:

      CPANN  =  2*FVE9**2*F9**2

      CPALL  =  2*FVE9*FVE10*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*FVE9*FVE11*F9*F11 

      CPADR  =  CPASS             

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    

      ENDIF

C

C     EM-CONTRIBUTION:

      IF(IVV.GE.3) THEN

      IF(IVV.EQ.3) THEN

      FVE9 = FD9+FV9

      FVE10= FD10+FV10

      FVE11= FD11+FV11

      ENDIF

      IF(IVV.EQ.4) THEN

      FVE9 = FD9+2*FV9

      FVE10= FD10+2*FV10

      FVE11= FD11+2*FV11

      ENDIF

C     PARALLEL:

      CPANN  =  4*FVE9*FD9*F9**2

      CPALL  =  2*(FVE9*FD10+FVE10*FD9)*F9*F10

      CPALS  =  0.D0   

      CPASS  =  2*(FVE9*FD11+FVE11*FD9)*F9*F11 

      CPADR  =  CPASS             



      CPALLM =  2*(FVE9*FD10-FVE10*FD9)*F9*F10

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                

      CCRLS  =  CPALS                        

      CCRSS  =  CPASS                  

      CCRDR  =  CPADR    



      CCRLLM =  CPALLM

      ENDIF

      GOTO 102



  102 IF(IVV.EQ.1) THEN

      VPSVC(1,2,M,N)=

     .VPSVC(1,2,M,N) + FACT*( CPANN*FUN(1) - CCRNN*FUN(11))*PEX

      VPSVC(2,2,M,N)=

     .VPSVC(2,2,M,N) + FACT*( CPALL*FUN(1) - CCRLL*FUN(11))*PEX

      VPSVC(3,2,M,N)=

     .VPSVC(3,2,M,N) + FACT*( CPALS*FUN(1) - CCRLS*FUN(11))*PEX

      VPSVC(4,2,M,N)=

     .VPSVC(4,2,M,N) + FACT*( CPASS*FUN(1) - CCRSS*FUN(11))*PEX

      VPSVC(5,2,M,N)=

     .VPSVC(5,2,M,N) + FACT*( CPADR*FUN(1) - CCRDR*FUN(11))*PEX



      VPSVC(1,3,M,N)=

     .VPSVC(1,3,M,N) + FACT*( CPANN*FUN(2) - CCRNN*FUN(12))*PEX

      VPSVC(2,3,M,N)=

     .VPSVC(2,3,M,N) + FACT*( CPALL*FUN(2) - CCRLL*FUN(12))*PEX

      VPSVC(3,3,M,N)=

     .VPSVC(3,3,M,N) + FACT*( CPALS*FUN(2) - CCRLS*FUN(12))*PEX

      VPSVC(4,3,M,N)=

     .VPSVC(4,3,M,N) + FACT*( CPASS*FUN(2) - CCRSS*FUN(12))*PEX

      VPSVC(5,3,M,N)=

     .VPSVC(4,3,M,N) + FACT*( CPADR*FUN(2) - CCRDR*FUN(12))*PEX

      ENDIF

      IF(IVV.EQ.2) THEN

      VPSVC(1,1,M,N)=VPSVC(1,1,M,N)+FACT2*(CPANN-CCRNN)*FUN(5)*PEX

      VPSVC(2,1,M,N)=VPSVC(2,1,M,N)+FACT2*(CPALL-CCRLL)*FUN(5)*PEX

      VPSVC(3,1,M,N)=VPSVC(3,1,M,N)+FACT2*(CPALS-CCRLS)*FUN(5)*PEX

      VPSVC(4,1,M,N)=VPSVC(4,1,M,N)+FACT2*(CPASS-CCRSS)*FUN(5)*PEX

      VPSVC(5,1,M,N)=VPSVC(5,1,M,N)+FACT2*(CPADR-CCRDR)*FUN(5)*PEX



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+FACT2*(CPANN+CCRNN)*FUN(6)*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+FACT2*(CPALL+CCRLL)*FUN(6)*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+FACT2*(CPALS+CCRLS)*FUN(6)*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+FACT2*(CPASS+CCRSS)*FUN(6)*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+FACT2*(CPADR+CCRDR)*FUN(6)*PEX



      VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT2*(CPANN+CCRNN)*FUN(7)*PEX

      VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT2*(CPALL+CCRLL)*FUN(7)*PEX

      VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT2*(CPALS+CCRLS)*FUN(7)*PEX

      VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT2*(CPASS+CCRSS)*FUN(7)*PEX

      VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT2*(CPADR+CCRDR)*FUN(7)*PEX

      ENDIF

      IF(IVV.EQ.3) THEN

      VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT3*(CPANN+CCRNN)*FUN(3)*PEX

      VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT3*(CPALL+CCRLL)*FUN(3)*PEX

      VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT3*(CPALS+CCRLS)*FUN(3)*PEX

      VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT3*(CPASS+CCRSS)*FUN(3)*PEX

      VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT3*(CPADR+CCRDR)*FUN(3)*PEX



      VPSVC(1,4,M,N)=VPSVC(1,4,M,N)+FACT3*(CPANN-CCRNN)*FUN(4)*PEX

      VPSVC(2,4,M,N)=VPSVC(2,4,M,N)+FACT3*(CPALL-CCRLL)*FUN(4)*PEX

      VPSVC(3,4,M,N)=VPSVC(3,4,M,N)+FACT3*(CPALS-CCRLS)*FUN(4)*PEX

      VPSVC(4,4,M,N)=VPSVC(4,4,M,N)+FACT3*(CPASS-CCRSS)*FUN(4)*PEX

      VPSVC(5,4,M,N)=VPSVC(5,4,M,N)+FACT3*(CPADR-CCRDR)*FUN(4)*PEX



      VPSVC(2,5,M,N)=VPSVC(2,5,M,N)-FACT3*(CPALLM-CCRLLM)*FUN(4)*PEX

      ENDIF

      IF(IVV.EQ.4) THEN

      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+FACT3*(CPANN-CCRNN)*FUN(8)*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+FACT3*(CPALL-CCRLL)*FUN(8)*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+FACT3*(CPALS-CCRLS)*FUN(8)*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+FACT3*(CPASS-CCRSS)*FUN(8)*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+FACT3*(CPADR-CCRDR)*FUN(8)*PEX



      VPSVC(1,3,M,N)=VPSVC(1,3,M,N)+FACT3*(CPANN-CCRNN)*FUN(9)*PEX

      VPSVC(2,3,M,N)=VPSVC(2,3,M,N)+FACT3*(CPALL-CCRLL)*FUN(9)*PEX

      VPSVC(3,3,M,N)=VPSVC(3,3,M,N)+FACT3*(CPALS-CCRLS)*FUN(9)*PEX

      VPSVC(4,3,M,N)=VPSVC(4,3,M,N)+FACT3*(CPASS-CCRSS)*FUN(9)*PEX

      VPSVC(5,3,M,N)=VPSVC(5,3,M,N)+FACT3*(CPADR-CCRDR)*FUN(9)*PEX



      VPSVC(1,4,M,N)=VPSVC(1,4,M,N)+FACT3*(CPANN-CCRNN)*FUN(10)*PEX

      VPSVC(2,4,M,N)=VPSVC(2,4,M,N)+FACT3*(CPALL-CCRLL)*FUN(10)*PEX

      VPSVC(3,4,M,N)=VPSVC(3,4,M,N)+FACT3*(CPALS-CCRLS)*FUN(10)*PEX

      VPSVC(4,4,M,N)=VPSVC(4,4,M,N)+FACT3*(CPASS-CCRSS)*FUN(10)*PEX

      VPSVC(5,4,M,N)=VPSVC(5,4,M,N)+FACT3*(CPADR-CCRDR)*FUN(10)*PEX



      VPSVC(2,5,M,N)=VPSVC(2,5,M,N)-FACT3*(CPALLM-CCRLLM)*FUN(10)*PEX

      ENDIF

      write(*,*) 'm,n=',m,n,' vpsvc(2,4,m,n)=',vpsvc(2,4,m,n),

     .' vpsvc(2,5,m,n)=',vpsvc(2,5,m,n)

  101 CONTINUE

  100 CONTINUE



C     TOTAL CONTRIBUTIONS:

      DO 20 IPS=1,4

      DO 20 IMES=1,4

      VCNN = VCNN + VPSVC(1,1,IPS,IMES)

      VCLL = VCLL + VPSVC(2,1,IPS,IMES)

      VCLS = VCLS + VPSVC(3,1,IPS,IMES)

      VCSS = VCSS + VPSVC(4,1,IPS,IMES)

      VCDR = VCDR + VPSVC(5,1,IPS,IMES)



      VSNN = VSNN + VPSVC(1,2,IPS,IMES)

      VSLL = VSLL + VPSVC(2,2,IPS,IMES)

      VSLS = VSLS + VPSVC(3,2,IPS,IMES)

      VSSS = VSSS + VPSVC(4,2,IPS,IMES)

      VSDR = VSDR + VPSVC(5,2,IPS,IMES)



      VTNN = VTNN + VPSVC(1,3,IPS,IMES)

      VTLL = VTLL + VPSVC(2,3,IPS,IMES)

      VTLS = VTLS + VPSVC(3,3,IPS,IMES)

      VTSS = VTSS + VPSVC(4,3,IPS,IMES)

      VTDR = VTDR + VPSVC(5,3,IPS,IMES)



      VONN = VONN + VPSVC(1,4,IPS,IMES)

      VOLL = VOLL + VPSVC(2,4,IPS,IMES)

      VOLS = VOLS + VPSVC(3,4,IPS,IMES)

      VOSS = VOSS + VPSVC(4,4,IPS,IMES)

      VODR = VODR + VPSVC(5,4,IPS,IMES)



      VALL = VALL + VPSVC(2,5,IPS,IMES)                  ! VSOA

c     nog te doen:

c     VALS = VALS + VPSVC(3,5,IPS,IMES)                  ! VSOA

c     VASS = VASS + VPSVC(4,5,IPS,IMES)                  ! VSOA

c     VADR = VADR + VPSVC(5,5,IPS,IMES)                  ! VSOA

  20  CONTINUE

C END VECTOR MESONS

c     if(icall.eq.0.and.nschr.eq.1) call writetm(5,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(5,x,p)



C

C B) KAON-SCALAR MESONS: *****************************************

C

      RATOSA = 0.5D0*(AMN**2-AMLN**2)/AMN/AMLN

      ratosa = 0d0

C KAON-DELTA EXCHANGE POTENTIALS:

      IF(IKADE.EQ.1) THEN

C     PARALLEL:

      CPALL  =  6*GS1*GS3*F4*F5

      CPALS  =  +2*SR3*GS1*GS2*F4*F5-SR3*GS1*GS3*(F4**2-F5**2)

      CPASS  =  6*GS1*GS3*F4*F5+4*GS1*GS2*F5**2

      CPADR  =  4*GS1*GS2*F5**2

C     CROSSED:

      CCRLL  =  3*(GS1**2*F4**2+GS3**2*F5**2)

      CCRLS  =  SR3*(GS1**2*F4*F5-GS3**2*F4*F5+2*GS2*GS3*F5**2)

      CCRSS  =  5*GS1**2*F5**2+GS3**2*F4**2+4*GS2*GS3*F4*F5

      CCRDR  =  2*GS1**2*F5**2+GS3**2*F4**2

     .         +3*GS2**2*F5**2-2*GS2*GS3*F4*F5



      CALL YNFUN(2,X,AMK,AMD,ALMKA,ALMS8,FUN)

c*    CALL YNFUN2(2,X,AMK,AMD,ALMKA,ALMS8,DAM,1,FUN)



      VPSSC(2,2,2,1)=VPSSC(2,2,2,1)+FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSSC(3,2,2,1)=VPSSC(3,2,2,1)+FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSSC(4,2,2,1)=VPSSC(4,2,2,1)+FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSSC(5,2,2,1)=VPSSC(5,2,2,1)+FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSSC(2,3,2,1)=VPSSC(2,3,2,1)+FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSSC(3,3,2,1)=VPSSC(3,3,2,1)+FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSSC(4,3,2,1)=VPSSC(4,3,2,1)+FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSSC(5,3,2,1)=VPSSC(5,3,2,1)+FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSSC(2,4,2,1)=VPSSC(2,4,2,1)+FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSSC(3,4,2,1)=VPSSC(3,4,2,1)+FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSSC(4,4,2,1)=VPSSC(4,4,2,1)+FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSSC(5,4,2,1)=VPSSC(5,4,2,1)+FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END KAON-DELTA



C KAON-EPSILON1 EXCHANGE POTENTIALS:

      IF(IKAEP.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GS6*GS7*F4**2

      CPALS  =  -SR3*GS6*(GS7+GS8)*F4*F5

      CPASS  =  -2*GS6*GS8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (GS6**2+GS7**2)*F4**2

      CCRLS  =  -SR3*(GS6**2+GS7*GS8)*F4*F5

      CCRSS  =  -(GS6**2+GS8**2)*F5**2

      CCRDR  =  -2*CCRSS



C KAON-EPSILON1 EXCHANGE POTENTIALS:



      CALL YNFUN(2,X,AMK,AM1SI,ALMKA,ALMS1,FUN)

c*    CALL YNFUN2(2,X,AMK,AM1SI,ALMKA,ALMS1,DAM,1,FUN)



      VPSSC(2,2,2,3)=VPSSC(2,2,2,3)+FACT*(CPALL-CCRLL)*FUN(1)*ASI*P

      VPSSC(3,2,2,3)=VPSSC(3,2,2,3)+FACT*(CPALS-CCRLS)*FUN(1)*ASI*P

      VPSSC(4,2,2,3)=VPSSC(4,2,2,3)+FACT*(CPASS-CCRSS)*FUN(1)*ASI*P

      VPSSC(5,2,2,3)=VPSSC(5,2,2,3)+FACT*(CPADR-CCRDR)*FUN(1)*ASI*P



      VPSSC(2,3,2,3)=VPSSC(2,3,2,3)+FACT*(CPALL-CCRLL)*FUN(2)*ASI*P

      VPSSC(3,3,2,3)=VPSSC(3,3,2,3)+FACT*(CPALS-CCRLS)*FUN(2)*ASI*P

      VPSSC(4,3,2,3)=VPSSC(4,3,2,3)+FACT*(CPASS-CCRSS)*FUN(2)*ASI*P

      VPSSC(5,3,2,3)=VPSSC(5,3,2,3)+FACT*(CPADR-CCRDR)*FUN(2)*ASI*P



      VPSSC(2,4,2,3)=VPSSC(2,4,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*ASI*P

      VPSSC(3,4,2,3)=VPSSC(3,4,2,3)+FACT*(CPALS-CCRLS)*FUN(3)*ASI*P

      VPSSC(4,4,2,3)=VPSSC(4,4,2,3)+FACT*(CPASS-CCRSS)*FUN(3)*ASI*P

      VPSSC(5,4,2,3)=VPSSC(5,4,2,3)+FACT*(CPADR-CCRDR)*FUN(3)*ASI*P



      VPSSC(2,5,2,3)=VPSSC(2,5,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*ASI*P

     .*RATOSA

C END KAON-EPSILON1



C KAON-EPSILON2 EXCHANGE POTENTIALS:



      CALL YNFUN(2,X,AMK,AM2SI,ALMKA,ALMS1,FUN)

c*    CALL YNFUN2(2,X,AMK,AM2SI,ALMKA,ALMS1,DAM,1,FUN)



      VPSSC(2,2,2,3)=VPSSC(2,2,2,3)+FACT*(CPALL-CCRLL)*FUN(1)*BSI*P

      VPSSC(3,2,2,3)=VPSSC(3,2,2,3)+FACT*(CPALS-CCRLS)*FUN(1)*BSI*P

      VPSSC(4,2,2,3)=VPSSC(4,2,2,3)+FACT*(CPASS-CCRSS)*FUN(1)*BSI*P

      VPSSC(5,2,2,3)=VPSSC(5,2,2,3)+FACT*(CPADR-CCRDR)*FUN(1)*BSI*P



      VPSSC(2,3,2,3)=VPSSC(2,3,2,3)+FACT*(CPALL-CCRLL)*FUN(2)*BSI*P

      VPSSC(3,3,2,3)=VPSSC(3,3,2,3)+FACT*(CPALS-CCRLS)*FUN(2)*BSI*P

      VPSSC(4,3,2,3)=VPSSC(4,3,2,3)+FACT*(CPASS-CCRSS)*FUN(2)*BSI*P

      VPSSC(5,3,2,3)=VPSSC(5,3,2,3)+FACT*(CPADR-CCRDR)*FUN(2)*BSI*P



      VPSSC(2,4,2,3)=VPSSC(2,4,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*BSI*P

      VPSSC(3,4,2,3)=VPSSC(3,4,2,3)+FACT*(CPALS-CCRLS)*FUN(3)*BSI*P

      VPSSC(4,4,2,3)=VPSSC(4,4,2,3)+FACT*(CPASS-CCRSS)*FUN(3)*BSI*P

      VPSSC(5,4,2,3)=VPSSC(5,4,2,3)+FACT*(CPADR-CCRDR)*FUN(3)*BSI*P



      VPSSC(2,5,2,3)=VPSSC(2,5,2,3)+FACT*(CPALL-CCRLL)*FUN(3)*BSI*P

     .*RATOSA

      ENDIF

C END KAON-EPSILON2

C END KAON-EPSILON



C KAON-SSTAR EXCHANGE POTENTIALS:

      IF(IKAST.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GS9*GS10*F4**2

      CPALS  =  -SR3*GS9*(GS10+GS11)*F4*F5

      CPASS  =  -2*GS9*GS11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (GS9**2+GS10**2)*F4**2

      CCRLS  =  -SR3*(GS9**2+GS10*GS11)*F4*F5

      CCRSS  =  -(GS9**2+GS11**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL YNFUN(2,X,AMK,AMSST,ALMKA,ALMS8,FUN)

c*    CALL YNFUN2(2,X,AMK,AMSST,ALMKA,ALMS8,DAM,1,FUN)



      VPSSC(2,2,2,4)=VPSSC(2,2,2,4)+FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSSC(3,2,2,4)=VPSSC(3,2,2,4)+FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSSC(4,2,2,4)=VPSSC(4,2,2,4)+FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSSC(5,2,2,4)=VPSSC(5,2,2,4)+FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSSC(2,3,2,4)=VPSSC(2,3,2,4)+FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSSC(3,3,2,4)=VPSSC(3,3,2,4)+FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSSC(4,3,2,4)=VPSSC(4,3,2,4)+FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSSC(5,3,2,4)=VPSSC(5,3,2,4)+FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSSC(2,4,2,4)=VPSSC(2,4,2,4)+FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSSC(3,4,2,4)=VPSSC(3,4,2,4)+FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSSC(4,4,2,4)=VPSSC(4,4,2,4)+FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSSC(5,4,2,4)=VPSSC(5,4,2,4)+FACT*(CPADR-CCRDR)*FUN(3)*P



      VPSSC(2,5,2,4)=VPSSC(2,5,2,4)+FACT*(CPALL-CCRLL)*FUN(3)*P

     .*RATOSA

      ENDIF

C END KAON-SSTAR



C KAON-KAPPA EXCHANGE POTENTIALS:

      IF(IKAKSC.EQ.1) THEN

C     PARALLEL:

      CPANN  = 0.D0

      CPALL  =  2*(GS4**2*F4**2+3*GS4*GS5*F4*F5)

      CPALS  =  SR3*(GS5**2*F4*F5+GS4*GS5*F5**2

     .          -GS4**2*F4*F5-GS4*GS5*F4**2)

      CPASS  =  2*(3*GS4*GS5*F4*F5+GS5**2*F5**2)

      CPADR  =  8*GS5**2*F5**2

C     CROSSED:

c     CCRNN  =  2*(ISFLL*GS4**2*F4**2+ISFLS*GS4*GS5*F4*F5+

c    .             ISFSS*GS5**2*F5**2)

      CCRNN  =  (GS4*F4+3*GS5*F5)**2+ISFAC*(GS4*F4-GS5*F5)**2

      CCRLL  =  +2*(GS4*XGS12*F4*XF12+3*GS5*XGS12*F5*XF12)

      CCRLS  =  +SR3*(GS4*F4-GS5*F5)*(XGS13*XF12+XGS12*XF13)

      CCRSS  =  -2*GS4*XGS13*F4*XF13+10*GS5*XGS13*F5*XF13

      CCRDR  = +4*GS5*XGS13*F5*XF13 +4*GS4*XGS13*F4*XF13



      CALL YNFUN(2,X,AMK,AMSCK,ALMKA,ALMS8,FUN)

c     CALL YNFUN3(1,2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUN)

c     CALL YNFUN3(2,2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUNX)

c     FUN(11) = FUNX(1)

c     FUN(12) = FUNX(2)

c*    CALL DKBFUN(2,X,AMK,AMSCK,ALMKA,ALMS8,DAM,FUN)



      VPSSC(1,2,2,2)=VPSSC(1,2,2,2)+FACT*(CPANN-CCRNN)*FUN(1)

      VPSSC(2,2,2,2)=VPSSC(2,2,2,2)+FACT*(CPALL-CCRLL)*FUN(1)

      VPSSC(3,2,2,2)=VPSSC(3,2,2,2)+FACT*(CPALS-CCRLS)*FUN(1)

      VPSSC(4,2,2,2)=VPSSC(4,2,2,2)+FACT*(CPASS-CCRSS)*FUN(1)

      VPSSC(5,2,2,2)=VPSSC(5,2,2,2)+FACT*(CPADR-CCRDR)*FUN(1)



      VPSSC(1,3,2,2)=VPSSC(1,3,2,2)+FACT*(CPANN-CCRNN)*FUN(2)

      VPSSC(2,3,2,2)=VPSSC(2,3,2,2)+FACT*(CPALL-CCRLL)*FUN(2)

      VPSSC(3,3,2,2)=VPSSC(3,3,2,2)+FACT*(CPALS-CCRLS)*FUN(2)

      VPSSC(4,3,2,2)=VPSSC(4,3,2,2)+FACT*(CPASS-CCRSS)*FUN(2)

      VPSSC(5,3,2,2)=VPSSC(5,3,2,2)+FACT*(CPADR-CCRDR)*FUN(2)



      VPSSC(1,4,2,2)=VPSSC(1,4,2,2)+FACT*(CPANN-CCRNN)*FUN(3)

      VPSSC(2,4,2,2)=VPSSC(2,4,2,2)+FACT*(CPALL-CCRLL)*FUN(3)

      VPSSC(3,4,2,2)=VPSSC(3,4,2,2)+FACT*(CPALS-CCRLS)*FUN(3)

      VPSSC(4,4,2,2)=VPSSC(4,4,2,2)+FACT*(CPASS-CCRSS)*FUN(3)

      VPSSC(5,4,2,2)=VPSSC(5,4,2,2)+FACT*(CPADR-CCRDR)*FUN(3)



      VPSSC(2,5,2,2)=VPSSC(2,5,2,4)+FACT*(CPALL-CCRLL)*FUN(3)

     .*RATOSA

      ENDIF

C END KAON-KAPPA



C ETA-KAPPA EXCHANGE POTENTIALS:

      IF(IETKSC.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GS4**2*F6*F7

      CPALS  =  -SR3*GS4*GS5*F6*(F7+F8)

      CPASS  =  -2*GS5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  GS4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*GS4*GS5*(F6**2+F7*F8)

      CCRSS  =  -GS5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS



      CALL YNFUN(2,X,AME,AMSCK,ALMP8,ALMS8,FUN)

c*    CALL YNFUN2(2,X,AME,AMSCK,ALMP8,ALMS8,DAM,2,FUN)



      VPSSC(2,2,3,2)=VPSSC(2,2,3,2)+FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSSC(3,2,3,2)=VPSSC(3,2,3,2)+FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSSC(4,2,3,2)=VPSSC(4,2,3,2)+FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSSC(5,2,3,2)=VPSSC(5,2,3,2)+FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSSC(2,3,3,2)=VPSSC(2,3,3,2)+FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSSC(3,3,3,2)=VPSSC(3,3,3,2)+FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSSC(4,3,3,2)=VPSSC(4,3,3,2)+FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSSC(5,3,3,2)=VPSSC(5,3,3,2)+FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSSC(2,4,3,2)=VPSSC(2,4,3,2)+FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSSC(3,4,3,2)=VPSSC(3,4,3,2)+FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSSC(4,4,3,2)=VPSSC(4,4,3,2)+FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSSC(5,4,3,2)=VPSSC(5,4,3,2)+FACT*(CPADR-CCRDR)*FUN(3)*P



      VPSSC(5,5,3,2)=VPSSC(5,5,3,2)+FACT*(CPADR-CCRDR)*FUN(3)*P

     .*RATOSA

      ENDIF

C END ETA-KAPPA



C ETAP-KAPPA EXCHANGE POTENTIALS:

      IF(IETPKP.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GS4**2*F9*F10

      CPALS  =  -SR3*GS4*GS5*F9*(F10+F11)

      CPASS  =  -2*GS5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  GS4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*GS4*GS5*(F9**2+F10*F11)

      CCRSS  =  -GS5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS



      CALL YNFUN(2,X,AMX,AMSCK,ALMP1,ALMS8,FUN)

c*    CALL YNFUN2(2,X,AME,AMSCK,ALMP1,ALMS8,DAM,2,FUN)



      VPSSC(2,2,4,2)=VPSSC(2,2,4,2)+FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSSC(3,2,4,2)=VPSSC(3,2,4,2)+FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSSC(4,2,4,2)=VPSSC(4,2,4,2)+FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSSC(5,2,4,2)=VPSSC(5,2,4,2)+FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSSC(2,3,4,2)=VPSSC(2,3,4,2)+FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSSC(3,3,4,2)=VPSSC(3,3,4,2)+FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSSC(4,3,4,2)=VPSSC(4,3,4,2)+FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSSC(5,3,4,2)=VPSSC(5,3,4,2)+FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSSC(2,4,4,2)=VPSSC(2,4,4,2)+FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSSC(3,4,4,2)=VPSSC(3,4,4,2)+FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSSC(4,4,4,2)=VPSSC(4,4,4,2)+FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSSC(5,4,4,2)=VPSSC(5,4,4,2)+FACT*(CPADR-CCRDR)*FUN(3)*P



      VPSSC(5,5,4,2)=VPSSC(5,5,4,2)+FACT*(CPADR-CCRDR)*FUN(3)*P

     .*RATOSA

      ENDIF

C END ETAP-KAPPA



C     TOTAL CONTRIBUTIONS:

      DO 30 IPS=1,4

      DO 30 IMES=1,4

      VCNN = VCNN + VPSSC(1,1,IPS,IMES)

      VCLL = VCLL + VPSSC(2,1,IPS,IMES)

      VCLS = VCLS + VPSSC(3,1,IPS,IMES)

      VCSS = VCSS + VPSSC(4,1,IPS,IMES)

      VCDR = VCDR + VPSSC(5,1,IPS,IMES)



      VSNN = VSNN + VPSSC(1,2,IPS,IMES)

      VSLL = VSLL + VPSSC(2,2,IPS,IMES)

      VSLS = VSLS + VPSSC(3,2,IPS,IMES)

      VSSS = VSSS + VPSSC(4,2,IPS,IMES)

      VSDR = VSDR + VPSSC(5,2,IPS,IMES)



      VTNN = VTNN + VPSSC(1,3,IPS,IMES)

      VTLL = VTLL + VPSSC(2,3,IPS,IMES)

      VTLS = VTLS + VPSSC(3,3,IPS,IMES)

      VTSS = VTSS + VPSSC(4,3,IPS,IMES)

      VTDR = VTDR + VPSSC(5,3,IPS,IMES)

C     toegevoegd may 2006:

      VONN = VONN + VPSSC(1,4,IPS,IMES)

      VOLL = VOLL + VPSSC(2,4,IPS,IMES)

      VOLS = VOLS + VPSSC(3,4,IPS,IMES)

      VOSS = VOSS + VPSSC(4,4,IPS,IMES)

      VODR = VODR + VPSSC(5,4,IPS,IMES)



      VALL = VALL + VPSSC(2,5,IPS,IMES)                  ! VSOA

c     nog te doen:

c     VALS = VALS + VPSSC(3,5,IPS,IMES)                  ! VSOA

c     VASS = VASS + VPSSC(4,5,IPS,IMES)                  ! VSOA

c     VADR = VADR + VPSSC(5,5,IPS,IMES)                  ! VSOA

  30  CONTINUE

C END SCALAR MESONS

c     if(icall.eq.0.and.nschr.eq.1) call writetm(6,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(6,x,p)

C

C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************

C

C KAON-A2 EXCHANGE POTENTIALS:

      IF(IKAA2.EQ.1) THEN

C     PARALLEL:

      CPALL  =  6*GD1*GD3*F4*F5

      CPALS  =  +2*SR3*GD1*GD2*F4*F5-SR3*GD1*GD3*(F4**2-F5**2)

      CPASS  =  6*GD1*GD3*F4*F5+4*GD1*GD2*F5**2

      CPADR  =  4*GD1*GD2*F5**2

C     CROSSED:

      CCRLL  =  3*(GD1**2*F4**2+GD3**2*F5**2)

      CCRLS  =  SR3*(GD1**2*F4*F5-GD3**2*F4*F5+2*GD2*GD3*F5**2)

      CCRSS  =  5*GD1**2*F5**2+GD3**2*F4**2+4*GD2*GD3*F4*F5

      CCRDR  =  2*GD1**2*F5**2+GD3**2*F4**2+

     .          3*GD2**2*F5**2-2*GD2*GD3*F4*F5



      CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN)

c*    CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN)



      VPSDF(2,2,2,1)=VPSDF(2,2,2,1)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,2,1)=VPSDF(3,2,2,1)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,2,1)=VPSDF(4,2,2,1)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,2,1)=VPSDF(5,2,2,1)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,2,1)=VPSDF(2,3,2,1)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,2,1)=VPSDF(3,3,2,1)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,2,1)=VPSDF(4,3,2,1)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,2,1)=VPSDF(5,3,2,1)-FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSDF(2,4,2,1)=VPSDF(2,4,2,1)-FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSDF(3,4,2,1)=VPSDF(3,4,2,1)-FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSDF(4,4,2,1)=VPSDF(4,4,2,1)-FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSDF(5,4,2,1)=VPSDF(5,4,2,1)-FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END KAON-A2



C KAON-POMERON:

      IF(IKAPOM.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GD6*GD7*F4**2

      CPALS  =  -SR3*GD6*(GD7+GD8)*F4*F5

      CPASS  =  -2*GD6*GD8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (GD6**2+GD7**2)*F4**2

      CCRLS  =  -SR3*(GD6**2+GD7*GD8)*F4*F5

      CCRSS  =  -(GD6**2+GD8**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN)

c*    CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN)



      VPSDF(2,2,2,3)=VPSDF(2,2,2,3)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,2,3)=VPSDF(3,2,2,3)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,2,3)=VPSDF(4,2,2,3)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,2,3)=VPSDF(5,2,2,3)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,2,3)=VPSDF(2,3,2,3)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,2,3)=VPSDF(3,3,2,3)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,2,3)=VPSDF(4,3,2,3)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,2,3)=VPSDF(5,3,2,3)-FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSDF(2,4,2,3)=VPSDF(2,4,2,3)-FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSDF(3,4,2,3)=VPSDF(3,4,2,3)-FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSDF(4,4,2,3)=VPSDF(4,4,2,3)-FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSDF(5,4,2,3)=VPSDF(5,4,2,3)-FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END KAON-POMERON



C KAON-POMP EXCHANGE POTENTIALS:

      IF(IKAPOM.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GD9*GD10*F4**2

      CPALS  =  -SR3*GD9*(GD10+GD11)*F4*F5

      CPASS  =  -2*GD9*GD11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  (GD9**2+GD10**2)*F4**2

      CCRLS  =  -SR3*(GD9**2+GD10*GD11)*F4*F5

      CCRSS  =  -(GD9**2+GD11**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN)

c*    CALL YNFUN2(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,1,FUN)



      VPSDF(2,2,2,4)=VPSDF(2,2,2,4)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,2,4)=VPSDF(3,2,2,4)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,2,4)=VPSDF(4,2,2,4)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,2,4)=VPSDF(5,2,2,4)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,2,4)=VPSDF(2,3,2,4)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,2,4)=VPSDF(3,3,2,4)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,2,4)=VPSDF(4,3,2,4)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,2,4)=VPSDF(5,3,2,4)-FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSDF(2,4,2,4)=VPSDF(2,4,2,4)-FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSDF(3,4,2,4)=VPSDF(3,4,2,4)-FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSDF(4,4,2,4)=VPSDF(4,4,2,4)-FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSDF(5,4,2,4)=VPSDF(5,4,2,4)-FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END KAON-POMP



C KAON-K** EXCHANGE POTENTIALS:

      IF(IKAKSS.EQ.1) THEN

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(GD4**2*F4**2+3*GD4*GD5*F4*F5)

      CPALS  =  SR3*(GD5**2*F4*F5+GD4*GD5*F5**2

     .          -GD4**2*F4*F5-GD4*GD5*F4**2)

      CPASS  =  2*(3*GD4*GD5*F4*F5+GD5**2*F5**2)

      CPADR  =  8*GD5**2*F5**2

C     CROSSED:

      CCRNN  =  2*(ISFLL*GD4**2*F4**2+ISFLS*GD5*GD4*F4*F5+

     .             ISFSS*GD5**2*F5**2)

      CCRLL  =  +2*(GD4*XGD12*F4*XF12+3*GD5*XGD12*F5*XF12)

      CCRLS  =  +SR3*(GD4*F4-GD5*F5)*(XGD13*XF12+XGD12*XF13)

      CCRSS  =  -2*GD4*XGD13*F4*XF13+10*GD5*XGD13*F5*XF13

      CCRDR  =  +4*GD5*XGD13*F5*XF13 + 4*GD4*XGD13*F4*XF13



      CALL YNFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN)

c     CALL YNFUN3(1,4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUN)

c     CALL YNFUN3(2,4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUNX)

c     FUN(11) = FUNX(1)

c     FUN(12) = FUNX(2)

c*    CALL DKBFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUN)



      VPSDF(1,2,2,2)=VPSDF(1,2,2,2)-FACT*(CPANN-CCRNN)*FUN(1)

      VPSDF(2,2,2,2)=VPSDF(2,2,2,2)-FACT*(CPALL-CCRLL)*FUN(1)

      VPSDF(3,2,2,2)=VPSDF(3,2,2,2)-FACT*(CPALS-CCRLS)*FUN(1)

      VPSDF(4,2,2,2)=VPSDF(4,2,2,2)-FACT*(CPASS-CCRSS)*FUN(1)

      VPSDF(5,2,2,2)=VPSDF(5,2,2,2)-FACT*(CPADR-CCRDR)*FUN(1)



      VPSDF(1,3,2,2)=VPSDF(1,3,2,2)-FACT*(CPANN-CCRNN)*FUN(2)

      VPSDF(2,3,2,2)=VPSDF(2,3,2,2)-FACT*(CPALL-CCRLL)*FUN(2)

      VPSDF(3,3,2,2)=VPSDF(3,3,2,2)-FACT*(CPALS-CCRLS)*FUN(2)

      VPSDF(4,3,2,2)=VPSDF(4,3,2,2)-FACT*(CPASS-CCRSS)*FUN(2)

      VPSDF(5,3,2,2)=VPSDF(5,3,2,2)-FACT*(CPADR-CCRDR)*FUN(2)



      VPSDF(1,4,2,2)=VPSDF(1,4,2,2)-FACT*(CPANN-CCRNN)*FUN(3)

      VPSDF(2,4,2,2)=VPSDF(2,4,2,2)-FACT*(CPALL-CCRLL)*FUN(3)

      VPSDF(3,4,2,2)=VPSDF(3,4,2,2)-FACT*(CPALS-CCRLS)*FUN(3)

      VPSDF(4,4,2,2)=VPSDF(4,4,2,2)-FACT*(CPASS-CCRSS)*FUN(3)

      VPSDF(5,4,2,2)=VPSDF(5,4,2,2)-FACT*(CPADR-CCRDR)*FUN(3)

      ENDIF

C END KAON-K**



C ETA-K** EXCHANGE POTENTIALS:

      IF(IETKSC.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GD4**2*F6*F7

      CPALS  =  -SR3*GD4*GD5*F6*(F7+F8)

      CPASS  =  -2*GD5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  GD4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*GD4*GD5*(F6**2+F7*F8)

      CCRSS  =  -GD5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS



      CALL YNFUN(4,X,AME,AMPOM,ALMP8,AMPRO,FUN)

c*    CALL YNFUN2(4,X,AME,AMPOM,ALMP8,AMPRO,DAM,2,FUN)



      VPSDF(2,2,3,2)=VPSDF(2,2,3,2)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,3,2)=VPSDF(3,2,3,2)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,3,2)=VPSDF(4,2,3,2)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,3,2)=VPSDF(5,2,3,2)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,3,2)=VPSDF(2,3,3,2)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,3,2)=VPSDF(3,3,3,2)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,3,2)=VPSDF(4,3,3,2)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,3,2)=VPSDF(5,3,3,2)-FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSDF(2,4,3,2)=VPSDF(2,4,3,2)-FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSDF(3,4,3,2)=VPSDF(3,4,3,2)-FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSDF(4,4,3,2)=VPSDF(4,4,3,2)-FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSDF(5,4,3,2)=VPSDF(5,4,3,2)-FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END ETA-K**



C ETAP-K** EXCHANGE POTENTIALS:

      IF(IETPKP.EQ.1) THEN

C     PARALLEL:

      CPALL  =  2*GD4**2*F9*F10

      CPALS  =  -SR3*GD4*GD5*F9*(F10+F11)

      CPASS  =  -2*GD5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRLL  =  GD4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*GD4*GD5*(F9**2+F10*F11)

      CCRSS  =  -GD5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS



      CALL YNFUN(4,X,AMX,AMPOM,ALMP1,AMPRO,FUN)

c*    CALL YNFUN2(4,X,AMX,AMPOM,ALMP1,AMPRO,DAM,2,FUN)



      VPSDF(2,2,4,2)=VPSDF(2,2,4,2)-FACT*(CPALL-CCRLL)*FUN(1)*P

      VPSDF(3,2,4,2)=VPSDF(3,2,4,2)-FACT*(CPALS-CCRLS)*FUN(1)*P

      VPSDF(4,2,4,2)=VPSDF(4,2,4,2)-FACT*(CPASS-CCRSS)*FUN(1)*P

      VPSDF(5,2,4,2)=VPSDF(5,2,4,2)-FACT*(CPADR-CCRDR)*FUN(1)*P



      VPSDF(2,3,4,2)=VPSDF(2,3,4,2)-FACT*(CPALL-CCRLL)*FUN(2)*P

      VPSDF(3,3,4,2)=VPSDF(3,3,4,2)-FACT*(CPALS-CCRLS)*FUN(2)*P

      VPSDF(4,3,4,2)=VPSDF(4,3,4,2)-FACT*(CPASS-CCRSS)*FUN(2)*P

      VPSDF(5,3,4,2)=VPSDF(5,3,4,2)-FACT*(CPADR-CCRDR)*FUN(2)*P



      VPSDF(2,4,4,2)=VPSDF(2,4,4,2)-FACT*(CPALL-CCRLL)*FUN(3)*P

      VPSDF(3,4,4,2)=VPSDF(3,4,4,2)-FACT*(CPALS-CCRLS)*FUN(3)*P

      VPSDF(4,4,4,2)=VPSDF(4,4,4,2)-FACT*(CPASS-CCRSS)*FUN(3)*P

      VPSDF(5,4,4,2)=VPSDF(5,4,4,2)-FACT*(CPADR-CCRDR)*FUN(3)*P

      ENDIF

C END ETAP-K**



C     TOTAL CONTRIBUTIONS:

      DO 40 IPS=1,4

      DO 40 IMES=1,4

      VCNN = VCNN + VPSDF(1,1,IPS,IMES)

      VCLL = VCLL + VPSDF(2,1,IPS,IMES)

      VCLS = VCLS + VPSDF(3,1,IPS,IMES)

      VCSS = VCSS + VPSDF(4,1,IPS,IMES)

      VCDR = VCDR + VPSDF(5,1,IPS,IMES)



      VSNN = VSNN + VPSDF(1,2,IPS,IMES)

      VSLL = VSLL + VPSDF(2,2,IPS,IMES)

      VSLS = VSLS + VPSDF(3,2,IPS,IMES)

      VSSS = VSSS + VPSDF(4,2,IPS,IMES)

      VSDR = VSDR + VPSDF(5,2,IPS,IMES)



      VTNN = VTNN + VPSDF(1,3,IPS,IMES)

      VTLL = VTLL + VPSDF(2,3,IPS,IMES)

      VTLS = VTLS + VPSDF(3,3,IPS,IMES)

      VTSS = VTSS + VPSDF(4,3,IPS,IMES)

      VTDR = VTDR + VPSDF(5,3,IPS,IMES)

  40  CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writetm(7,x,p)

      if(icall.eq.20.and.nschr.eq.1) call writetm(7,x,p)

C END DIFFRACTIVE CONTRIBUTIONS

c  1  CONTINUE



c     if(icall.eq.0.and.nschr.eq.1) then

      if(icall.eq.20.and.nschr.eq.1) then

      write(N3,*)'*****************************************************'

      write(N3,*) 'YNPIBE+YNPSBE total contributions: x=',x

      write(N3,*) 'vcll,vsll=',vcll,vsll

      write(N3,*) 'vcls,vsls=',vcls,vsls

      write(N3,*) 'vcss,vsss=',vcss,vsss

      write(N3,*) 'vcdr,vsdr=',vcdr,vsdr

      write(N3,*)'*****************************************************'

      endif

      ICALL=ICALL+1



1000  CALL ERRSET(208,256,1,1)

      RETURN

C END YNPSBE ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE WRITETM(NNCASE,X,P)

C **********************************************************************

C

C     NCASE = 1: PSEUDO-PSEUDO-SCALAR POTENTIALS,

C     NCASE = 2: PSEUDO-SCALAR-VECTOR POTENTIALS,

C     NCASE = 3: PSEUDO-SCALAR-SCALAR POTENTIALS,

C     NCASE = 4: PSEUDO-SCALAR-DIFFR. POTENTIALS.

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PSBE/ VPSBE(5,5,4,4,4)                              

      CHARACTER *4 NTYPM(4,4)

      DATA N3/27/,NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','OM  ','PHI ',

     .'DE  ','KAP ','EPS ','S*  ','A2  ','K** ','POM ','POMP'/

C

      if(nncase.le.4) ncase=nncase

      if(nncase.ge.5) ncase=nncase-3

      write(N3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

      write(N3,*)'*****************************************************'

      if(nncase.eq.1) write(N3,*) ' YNPSPS: CENTRAL POTENTIALS: x=',x

      if(nncase.ge.2.and.nncase.le.4)

     .               write(N3,*) ' YNPIBE: CENTRAL POTENTIALS: x=',x

      if(nncase.ge.5) write(N3,*) ' YNPSBE: CENTRAL POTENTIALS: x=',x

      write(N3,*)'*****************************************************'

      write(N3,110) (NTYPM(KK,NCASE),KK=1,4)

  110 format(10x,4(3x,a4,5x))

      write(N3,*)'-----------------------------------------------------'

      DO 111 II=1,4

  111 write(N3,112) NTYPM(II,1),(VPSBE(1,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 113 II=1,4

  113 write(N3,114) NTYPM(II,1),(VPSBE(5,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 123 II=1,4

  123 write(N3,124) NTYPM(II,1),(VPSBE(2,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 125 II=1,4

  125 write(N3,126) NTYPM(II,1),(VPSBE(3,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 127 II=1,4

  127 write(N3,128) NTYPM(II,1),(VPSBE(4,1,II,KK,NCASE),KK=1,4)

      call prsu3tm(1,ncase,x,p,n3)        

      write(N3,*)'*****************************************************'

      if(nncase.eq.1) write(N3,*) ' YNPSPS: SPIN-SPIN POTENTIALS: x=',x

      if(nncase.ge.2.and.nncase.le.4)

     .               write(N3,*) ' YNPIBE: SPIN-SPIN POTENTIALS: x=',x

      if(nncase.ge.5) write(N3,*) ' YNPSBE: SPIN-SPIN POTENTIALS: x=',x

      write(N3,*)'*****************************************************'

      write(N3,115) (NTYPM(KK,NCASE),KK=1,4)

  115 format(10x,4(3x,a4,5x))

      write(N3,*)'-----------------------------------------------------'

      DO 116 II=1,4

  116 write(N3,112) NTYPM(II,1),(VPSBE(1,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 118 II=1,4

  118 write(N3,114) NTYPM(II,1),(VPSBE(5,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 120 II=1,4

  120 write(N3,124) NTYPM(II,1),(VPSBE(2,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 129 II=1,4

  129 write(N3,126) NTYPM(II,1),(VPSBE(3,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 131 II=1,4

  131 write(N3,128) NTYPM(II,1),(VPSBE(4,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'*****************************************************'

      call prsu3tm(2,ncase,x,p,n3)        

      RETURN

  112 FORMAT(1x,'NN: ',A4,4(F10.2,2X))

  114 FORMAT(1x,'DR: ',A4,4(F10.2,2X))

  124 FORMAT(1x,'LL: ',A4,4(F10.2,2X))

  126 FORMAT(1x,'LS: ',A4,4(F10.2,2X))

  128 FORMAT(1x,'SS: ',A4,4(F10.2,2X))

C END WRITETM ROUTINE **************************************************

      END

C **********************************************************************

      SUBROUTINE YNFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN)

C **********************************************************************

C

C     VERSION: AUGUST 1996  ( 1/M^2-TERMS FROM IOFF=1 INCLUDED)

C              THIS VERSION IS, EXCEPT FOR A FACTOR 2, IDENTICAL

C              TO PHBFUN USED IN NN!

C     THIS ROUTINE IS CALLED FROM: YNPIBE.FORTRAN.C

C     IT IS UNDERSTOOD THAT AM1=PIM, SO INDEX 1 REFERS TO THE PION.

C

C     COMPUTES THE FOURIER TRANSFORMS OF

C

C                      1       [  1     1         1      ]

C   1*D^(0)(//)= ------------- [ --- + --- - ----------- ]  --->

C                  OM1^2 OM2^2 [ OM1   OM2   (OM1 + OM2) ]

C

C      YNFUN  = (1/PI) INT_{0}^{\INFTY} (D LAM/ LAM**2)

C

C              [      1                  1                 1        ]

C            X [ ------------  - ----------------  ---------------- ]

C              [ (OM1.OM2)^{2}   (OM1^{2}+LAM^{2}) (OM2^{2}+LAM^{2})]

C

C     FOR VARIOUS THE COMBINATIONS OF DERIVATIVES CORRESPONDING TO

C     THE OPERATORS O_{i} GIVEN IN TABLE II, PAPER I.

C

C     KIND = 1: PION-VECTOR-,   KIND = 2: PION-SCALAR-,

C     KIND = 3: PION-PSSCALAR-, KIND = 4: PION-POMERON-EXCHANGE,

C     KIND = 5: SCAL-DIFRAC-  , KIND = 6: PION-AXIAL  -EXCHANGE,

C     KIND = 7: VECTOR-VECTOR

C

C     SCHEMATICALLY:

C     PION-VECTOR EXCHANGE:

C     FUN(1) = OPAEES  FUN(2) = OPAEET  FUN(3) = OPAEMT1

C     FUN(4) = OPAEMO1 FUN(5) = OPAMMC  FUN(6) = OPAMMS

C     FUN(7) = OPAMMT  FUN(8) = OPAEMS2 FUN(9) = OPAEMT2

C     FUN(10)= OPAEMO2 FUN(11)= OCREES  FUN(12)= OCREET

C     PION-SCALAR EXCHANGE:

C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO

C     PION-PSSCALAR EXCHANGE:

C     FUN(1) = OPSC    FUN(2) = OPSS    FUN(3) = OPST

C     DIFRAC-DIFRAC EXCHANGE:

C     FUN(1) = ODFC    FUN(2) = ODFO

C     PION-AXIAL EXCHANGE:

C     FUN(1) = OAXC    FUN(2) = OAXS    FUN(3) = OAXT

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM                  



      DIMENSION XX(20),WW(20),YB(3),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA IPV/1/,YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      DATA AMPRO/938.2796D0/

      SAVE XX,WW,XBEGIN

C

C     ACCORDING TO THE PAPER I, TABLE II AND APPENDIX A,B,

C     APPROXIMATION: Q^2+K^2/4 = 0

C     DEFINITION STATEMENT OPERATORS:

C     (NOTICE: G-FUNTIONS REFER TO PION, F-FUNCTIONS TO MESONS.)

C

C 1)  PION-VECTOR EXCHANGE:

      OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)=

     .  2*FF*(2*D1G/XH+D2G)/3.D0



c    .+(4*D1F*(D3G+2*D2G/XH-2*D1G/XH/XH)

c    .+(2*D1F/XH+D2F)*(2*D1G/XH+D2G) )*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0



      OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)=

     . -2*FF*(D1G/XH-D2G)/3.D0



c    .+(4*D1F*(D3G-  D2G/XH+  D1G/XH/XH)

c    .+(2*D1F/XH+D2F)*(D2G-D1G/XH) )*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(D2F*D2G-D1F*D1G/XH/XH)*(PIM/AMPRO)**2/6.D0



      OCREES(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)=

     .OPAEES(FF,D1F,D2F,D1G,D2G,D3G,XH)



c    .+FF*(D4G+4*D3G/XH)*(PIM/AMPRO)**2/3.D0



      OCREET(FF,D1F,D2F,D1G,D2G,D3G,D4G,XH)=

     .OPAEET(FF,D1F,D2F,D1G,D2G,D3G,XH)



c    .+FF*(D4G+D3G/XH-6*D2G/XH**2+6*D1G/XH**3)*(PIM/AMPRO)**2/3.D0



      OPAEMT(D1F,D1G,D2G,XH)=  2*D1F*(D1G/XH-D2G)/XH

      OPAEMO(D1F,D1G,XH)=  4*D1F*D1G/XH/XH

      OPEMS2(D1F,D2F,D1G,D2G,XH)= (2*D1F/XH+D2F)*(2*D1G/XH+D2G)/3.D0

      OPEMT2(D1F,D2F,D1G,D2G,XH)=  (D1F/XH-D2F)*(D1G/XH-D2G)/3.D0

      OPEMO2(D1F,D1G,XH)=  2*D1F*D1G/XH/XH



      OPAMMC(D1F,D2F,D1G,D2G,XH)=

     .2*( D1F*D1G/XH + D1F*D2G + D2F*D1G)/XH

      OPAMMS(D1F,D2F,D1G,D2G,XH)=

     .-2*( 3*D1F*D1G/XH/XH + D1F*D2G/XH + D2F*D1G/XH +D2F*D2G)/3.D0

      OPAMMT(D1F,D2F,D1G,D2G,XH)=

     .+(D2F+D1F/XH)*(D2G-D1G/XH)/3.D0-1*(D2F-D1F/XH)*D1G/XH/3.D0

     .-1*(D2G-D1G/XH)*D1F/XH/3.D0



C 2)  PION-SCALAR EXCHANGE:

      OSCS(FF,D1F,D2F,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)/3.D0



c    .  +(2*D1F/XH+D2F)*(2*D1G/XH+D2G)*(PIM/AMPRO)**2/6.D0

c    .  -(1-2*IPV)*(2*D1F*D1G/XH/XH+D2F*D2G)*(PIM/AMPRO)**2/6.D0



      OSCT(FF,D1F,D2F,D1G,D2G,XH)= +2*FF*(D1G/XH-D2G)/3.D0



c    .      +(D1F/XH-D2F)*(D1G/XH-D2G)*(PIM/AMPRO)**2/6.D0

c    .  +(1-2*IPV)*(D1F*D1G/XH/XH-D2F*D2G)*(PIM/AMPRO)**2/6.D0



      OSCO(D1F,D1G,XH)= 0.D0



c    .                 +(D1F*D1G/XH/XH)*(PIM/AMPRO)**2



C 3)  PION-PSEUDO-SCALAR EXCHANGE:

      OPSC(D1F,D2F,D1G,D2G,XH)= 2*(2*D1F*D1G/XH/XH+D2F*D2G)

      OPSS(D1F,D2F,D1G,D2G,XH)=+4*(D1F*D1G/XH+D1F*D2G+D2F*D1G)/XH/3.D0

      OPST(D1F,D2F,D1G,D2G,XH)=+2*( (D1F/XH-D2F)*D1G/XH +

     . (D1G/XH-D2G)*D1F/XH )/3.D0



C 4)  DIFRAC-DIFRAC EXCHANGE:

      ODFC(FF,D1F,D2F,GG,D1G,D2G,XH)= 2*FF*GG -0.5D0*(PIM/AMPRO)**2

     . *((D2F+2*D1F/XH)*GG+FF*(D2G+2*D1G/XH)-2*D1F*D1G)

      ODFO(FF,D1F,GG,D1G,XH)= 0.D0



c    .                        -(D1F*GG+FF*D1G)/XH*(PIM/AMPRO)**2



C 5)  PION-AXIAL EXCHANGE:

      OAXC(FF,D1G,D2G,XH)= -2*FF*(2*D1G/XH+D2G)

      OAXS(FF,D1G,D2G,XH)= +2*FF*(2*D1G/XH+D2G)*2/3.D0

      OAXT(FF,D1G,D2G,XH)= -2*FF*( -D1G/XH+D2G)/3.D0

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        XBEGIN=X

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

      X4   = X1*X3

CC

      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1 =-0.5D0*(ALM1/PIM)**2*X*VKU1

      DDVKU1 =-0.5D0*(ALM1/PIM)**2*(VKU1+X*DVKU1)

      D3VKU1 =-0.5D0*(ALM1/PIM)**2*(2*DVKU1+X*DDVKU1)



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2



      IF(KIND.NE.5) THEN

      XA   =X*AM1/PIM

      RATA =AM1/ALM1

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM1 +RATA)

      EPA  =FDERFC( XLM1 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA

      DHIA  =-(AM1/PIM)*FIA -HIA*X1

      DDFIA  =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA

      DDHIA  =-(AM1/PIM)*DFIA -DHIA*X1 +HIA*X2

      D3FIA  =-(DDFIA-2*DDVKU1)*X1+2*(DFIA-2*DVKU1)*X2

     .        -2*(FIA-2*VKU1)*X3-(AM1/PIM)*DDHIA

      D3HIA  =-(AM1/PIM)*DDFIA -DDHIA*X1 +2*DHIA*X2-2*HIA*X3

      D4FIA  =-(D3FIA-2*D3VKU1)*X1+3*(DDFIA-2*DDVKU1)*X2

     .        -6*(DFIA-2*DVKU1)*X3+6*(FIA-2*VKU1)*X4-(AM1/PIM)*D3HIA

      FI1= FIA

      DFI1= DFIA

      DDFI1= DDFIA

      D3FI1= D3FIA

      D4FI1= D4FIA

      ENDIF

      IF(KIND.EQ.5) THEN

      XA   =X*AM1/PIM

      FI1  =(4.D0/SRPI)*(AM1/PIM)*(AM1/AMPRO)**2*FDEXP(-XA*XA)

      DFI1  = -2*(AM1/PIM)*XA*FI1

      DDFI1  = -2*(AM1/PIM)*(XA*DFI1 + FI1*AM1/PIM)

      ENDIF



      IF(KIND.LT.4.OR.KIND.GE.6) THEN

      XA   =X*AM2/PIM

      RATA =AM2/ALM2

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM2 +RATA)

      EPA  =FDERFC( XLM2 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU2)*X1-(AM2/PIM)*HIA

      DHIA  =-(AM2/PIM)*FIA -HIA *X1

      DDFIA  =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(AM2/PIM)*DHIA

      ENDIF

      IF(KIND.EQ.4.OR.KIND.EQ.5) THEN

      XA   =X*AM2/PIM

      FIA  =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA)

      DFIA  = -2*(AM2/PIM)*XA*FIA

      DDFIA  = -2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM)

      ENDIF

      FI2= FIA

      DFI2= DFIA

      DDFI2= DDFIA

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,12

  105 FUN(IFUN) = 0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*1.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*1.D0/PI

      ENDIF

c     IF(Y.GT.50.D0) GOTO 110

      IF(Y.GT.90.D0) GOTO 110

      GEW = GEW/(Y*Y)

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

      FDISP = FDISP1*FDISP2

C

      IF(KIND.NE.5) THEN

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM

      DDHIM  =-(AM/PIM)*DFIM -DHIM*X1 +HIM*X2

      D3FIM  =-(DDFIM-2*DDVKU1)*X1+2*(DFIM-2*DVKU1)*X2

     .        -2*(FIM-2*VKU1)*X3-(AM/PIM)*DDHIM

      D3HIM  =-(AM/PIM)*DDFIM -DDHIM*X1 +2*DHIM*X2-2*HIM*X3

      D4FIM  =-(D3FIM-2*D3VKU1)*X1+3*(DDFIM-2*DDVKU1)*X2

     .        -6*(DFIM-2*DVKU1)*X3+6*(FIM-2*VKU1)*X4-(AM/PIM)*D3HIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

      D3FIM1  = D3FIM

      D4FIM1  = D4FIM

      ENDIF

      IF(KIND.EQ.5) THEN

      FIM1= FI1

      DFIM1= DFI1

      DDFIM1= DDFI1

      ENDIF

C

      IF(KIND.LT.4.OR.KIND.GE.6) THEN

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM

      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

      ENDIF

      IF(KIND.EQ.4.OR.KIND.EQ.5) THEN

      FIM2= FI2

      DFIM2= DFI2

      DDFIM2= DDFI2

      ENDIF

C

      IF(KIND.EQ.1) THEN

      FUN(1)  = FUN(1)  + GEW*(

     .   OPAEES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)

     .  -FDISP*OPAEES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X))

      FUN(2)  = FUN(2)  + GEW*(

     .   OPAEET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)

     .  -FDISP*OPAEET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,X))

      FUN(11) = FUN(11) + GEW*(

     .   OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP*

     .   OCREES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X))

      FUN(12) = FUN(12) + GEW*(

     .   OCREET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP*

     .   OCREET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X))

      FUN(3)  = FUN(3)  + GEW*(OPAEMT(DFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAEMT(DFIM2,DFIM1,DDFIM1,X))

      FUN(4)  = FUN(4)  + GEW*(OPAEMO(DFI2,DFI1,X)

     .                  -FDISP*OPAEMO(DFIM2,DFIM1,X))

      FUN(5)  = FUN(5)  + GEW*(OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMC(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(6)  = FUN(6)  + GEW*(OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMS(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(7)  = FUN(7)  + GEW*(OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPAMMT(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(8)  = FUN(8)  + GEW*(OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPEMS2(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(9)  = FUN(9)  + GEW*(OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPEMT2(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(10) = FUN(10) + GEW*(OPEMO2(DFI2,DFI1,X)

     .                  -FDISP*OPEMO2(DFIM2,DFIM1,X))

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1)  = FUN(1)  + GEW*(OSCS(FI2,DFI2,DDFI2,DFI1,DDFI1,X)

     .         -FDISP*OSCS(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEW*(OSCT(FI2,DFI2,DDFI2,DFI1,DDFI1,X)

     .         -FDISP*OSCT(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(3)  = FUN(3)  + GEW*(OSCO(DFI2,DFI1,X)

     .         -FDISP*OSCO(DFIM2,DFIM1,X))

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1)  = FUN(1)  + GEW*(OPSC(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPSC(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEW*(OPSS(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPSS(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      FUN(3)  = FUN(3)  + GEW*(OPST(DFI2,DDFI2,DFI1,DDFI1,X)

     .                  -FDISP*OPST(DFIM2,DDFIM2,DFIM1,DDFIM1,X))

      ENDIF

C

      IF(KIND.EQ.5) THEN

      FUN(1)  = FUN(1)  + GEW*(ODFC(FI2,DFI2,DDFI2,FI1,DFI1,DDFI1,X)

     .         -FDISP*ODFC(FIM2,DFIM2,DDFIM2,FIM1,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEW*(ODFO(FI2,DFI2,FI1,DFI1,X)

     .         -FDISP*ODFO(FIM2,DFIM2,FIM1,DFIM1,X))

      ENDIF

C

      IF(KIND.EQ.6) THEN

      FUN(1)  = FUN(1)  + GEW*(OAXC(FI2,DFI1,DDFI1,X)

     .         -FDISP*OAXC(FIM2,DFIM1,DDFIM1,X))

      FUN(2)  = FUN(2)  + GEW*(OAXS(FI2,DFI1,DDFI1,X)

     .         -FDISP*OAXS(FIM2,DFIM1,DDFIM1,X))

      FUN(3)  = FUN(3)  + GEW*(OAXT(FI2,DFI1,DDFI1,X)

     .         -FDISP*OAXT(FIM2,DFIM1,DDFIM1,X))

      ENDIF

C

      IF(KIND.EQ.7) THEN

      FUN(1)  = FUN(1)  + GEW*(FI2*FI1-FDISP*FIM2*FIM1)

      ENDIF

C

110   CONTINUE

100   CONTINUE

C

C     CONTRIBUTIONS FROM Y>YMAX=YB(NINT+1)

C

      IF(IMETH.EQ.0) THEN

      YMAX = YB(NINT+1)

      IF(KIND.EQ.1) THEN

      FUN(1) = FUN(1)+

     .(1.D0/PI)*OPAEES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)/YMAX

      FUN(2) = FUN(2)+

     .(1.D0/PI)*OPAEET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,X)/YMAX

      FUN(11)= FUN(11)+(1.D0/PI)*

     .OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FIM1,X)/YMAX

      FUN(12)= FUN(12)+(1.D0/PI)*

     .OCREET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FIM1,X)/YMAX

      FUN(3) = FUN(3)+(1.D0/PI)*OPAEMT(DFI2,DFI1,DDFI1,X)/YMAX

      FUN(4) = FUN(4)+(1.D0/PI)*OPAEMO(DFI2,DFI1,X)/YMAX

      FUN(5) = FUN(5)+(1.D0/PI)*OPAMMC(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(6) = FUN(6)+(1.D0/PI)*OPAMMS(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(7) = FUN(7)+(1.D0/PI)*OPAMMT(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(8) = FUN(8)+(1.D0/PI)*OPEMS2(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(9) = FUN(9)+(1.D0/PI)*OPEMT2(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(10)= FUN(10)+(1.D0/PI)*OPEMO2(DFI2,DFI1,X)/YMAX

      ENDIF

C

      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN

      FUN(1) = FUN(1)+

     .(1.D0/PI)*OSCS(FI2,DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(2) = FUN(2)+

     .(1.D0/PI)*OSCT(FI2,DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(3) = FUN(3)+ (1.D0/PI)*OSCO(DFI2,DFI1,X)/YMAX

      ENDIF

C

      IF(KIND.EQ.3) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OPSC(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(2) = FUN(2)+(1.D0/PI)*OPSS(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      FUN(3) = FUN(3)+(1.D0/PI)*OPST(DFI2,DDFI2,DFI1,DDFI1,X)/YMAX

      ENDIF

C

      IF(KIND.EQ.5) THEN

      FUN(1) = FUN(1)+

     .(1.D0/PI)*ODFC(FI2,DFI2,DDFI2,FI1,DFI1,DDFI1,X)/YMAX

      FUN(2) = FUN(2)+(1.D0/PI)*ODFO(FI2,DFI2,FI1,DFI1,X)/YMAX

      ENDIF

C

      IF(KIND.EQ.6) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*OAXC(FI2,DFI1,DDFI1,X)/YMAX

      FUN(2) = FUN(2)+(1.D0/PI)*OAXS(FI2,DFI1,DDFI1,X)/YMAX

      FUN(3) = FUN(3)+(1.D0/PI)*OAXT(FI2,DFI1,DDFI1,X)/YMAX

      ENDIF

C

      IF(KIND.EQ.7) THEN

      FUN(1) = FUN(1)+(1.D0/PI)*FI2*FI1/YMAX

      ENDIF

      ENDIF

CC

c     PRINT 99, KIND,X,AM1,AM2,ALM1,ALM2,(FUN(II),II=1,12)

c99   FORMAT(/,' IN YNFUN: KIND=',I2,' X=',F10.3,/,

c    .'  AM1,AM2=',2(F10.3,3X),'  ALM1,ALM2=',2(F10.3,3X),/,

c    .       /,' IN YNFUN: FUN(II)=',/,5(D10.3,3X),/)

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE FFUN(N,X,AMES,ALAM,F,DF,DDF,D3F)

C **********************************************************************

C

C                                         1

C     FOURIER TRANSFORM OF  F(OMEGA)= ----------

C                                      OMEGA^{N}

C     FOR N=0,1,2,3,4

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM



      DIMENSION XX(20),WW(20),YB(3)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      SAVE XX,WW

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN FFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

CC

      RATP =PIM/ALAM

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)

      DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)

      D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA)

      IF(N.EQ.0) THEN

      F = (ALAM/PIM)**2*VKUA

      DF = (ALAM/PIM)**2*DVKUA

      DDF = (ALAM/PIM)**2*DDVKUA

      D3F = (ALAM/PIM)**2*D3VKUA

      RETURN

      ENDIF



      IF(N.NE.1) THEN

      XA   =X*AMES/PIM

      RATA =AMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA

      DHIA  =-(AMES/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

      F = FIA

      DF = DFIA

      DDF = DDFIA

      D3F = D3FIA

      IF(N.EQ.2) RETURN

      ENDIF

      IF(N.EQ.4) THEN

      D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3

      F = 0.5D0*(AMES/PIM)*X*HIA

      DF = 0.5D0*(AMES/PIM)*(HIA+X*DHIA)

      DDF = 0.5D0*(AMES/PIM)*(2*DHIA+X*DDHIA)

      D3F  = 0.5D0*(AMES/PIM)*(3*DDHIA+X*D3HIA)

      RETURN

      ENDIF

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      IF(N.EQ.1.OR.N.EQ.3) THEN

      GG   =0.D0

      DGG  =0.D0

      DDGG =0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

      IF(Y.GE.50.D0) GOTO 110

      IF(N.EQ.3) GEW = GEW/Y**2

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP =FDEXP(-Y*Y*RATP*RATP)

C

      AM=PIM*DSQRT((AMES/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALAM

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLAM+RATM)

      EPM  =FDERFC( XLAM+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKUA)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKUA)*X1+(FIM-2*VKUA)*X2-(AM/PIM)*DHIM



      IF(N.EQ.1) THEN

      GG    = GG   + GEW*FIM* FDISP

      DGG   = DGG  + GEW*DFIM* FDISP

      DDGG  = DDGG + GEW*DDFIM* FDISP

      ENDIF

      IF(N.EQ.3) THEN

      GG    = GG   + GEW*(FIA-FIM* FDISP)

      DGG   = DGG  + GEW*(DFIA-DFIM* FDISP)

      DDGG  = DDGG + GEW*(DDFIA-DDFIM* FDISP)

      ENDIF

C

110   CONTINUE

100   CONTINUE

C

      F = GG

      DF = DGG

      DDF = DDGG

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE FFUNZ(N,X,AMES,AMZ,ALAM,F,DF,DDF,D3F)

C **********************************************************************

C                             1-K^2/MZ^2)

C     ZERO: FOURIER F(OMEGA)= ----------  = (1+M^2/MZ^2) PHI_C^(0)

C                              OMEGA^{2}

C

C      - (M/MZ)^2 (LAMBDA/M)^3 EXP[-1/4 LAMBDA^2 R^2]

C              

C

C     FOR N=1,2,3  

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C              

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM



      DIMENSION XX(20),WW(20),YB(3)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      SAVE XX,WW

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

c       IF(IMETH.EQ.1) NINT=1

        IF(IMETH.LE.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN GFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF



CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

CC

      RATP =PIM/ALAM

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)

      DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)

      D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA)



      VKUM =(ALAM/AMES)**3*FDEXP(-XLAM2)/(2*SRPI)

      DVKUM=-0.5D0*(ALAM/PIM)**2*X*VKUM

      DDVKUM=-0.5D0*(ALAM/PIM)**2*(X*DVKUM+VKUM)

      D3VKUM=-0.5D0*(ALAM/PIM)**2*(X*DDVKUM+2*DVKUM)



      IF(N.EQ.0) THEN

      F = (ALAM/PIM)**2*VKUA

      DF = (ALAM/PIM)**2*DVKUA

      DDF = (ALAM/PIM)**2*DDVKUA

      D3F = (ALAM/PIM)**2*D3VKUA

      RETURN

      ENDIF



      IF(N.NE.1) THEN

      XA   =X*AMES/PIM

      RATA =AMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA

      DHIA  =-(AMES/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

C     WITH ZERO:

      FZERO = (AMES/AMZ)**2

      FIA = (1.D0+FZERO)*FIA - FZERO*VKUM*AMES/PIM

      DFIA = (1.D0+FZERO)*DFIA - FZERO*DVKUM*AMES/PIM

      DDFIA = (1.D0+FZERO)*DDFIA - FZERO*DDVKUM*AMES/PIM

      D3FIA = (1.D0+FZERO)*D3FIA - FZERO*D3VKUM*AMES/PIM

      IF(N.EQ.2) THEN   

      F = FIA

      DF = DFIA

      DDF = DDFIA

      D3F = D3FIA

      RETURN

      ENDIF

      ENDIF

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      IF(N.EQ.1.OR.N.EQ.3) THEN

      GG   =0.D0

      DGG  =0.D0

      DDGG =0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110

      IF(N.EQ.3) GEW = GEW/Y**2

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP =FDEXP(-Y*Y*RATP*RATP)

C

      AM=PIM*DSQRT((AMES/PIM)**2+Y*Y)

      FZEROM=(AM/AMZ)**2

      VKUM =(ALAM/AM)**3*FDEXP(-XLAM2)/(2*SRPI)

      DVKUM=-0.5D0*(ALAM/PIM)**2*X*VKUM

      DDVKUM=-0.5D0*(ALAM/PIM)**2*(X*DVKUM+VKUM)

      D3VKUM=-0.5D0*(ALAM/PIM)**2*(X*DDVKUM+2*DVKUM)

      XM=AM*X/PIM

      RATM =AM/ALAM

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLAM+RATM)

      EPM  =FDERFC( XLAM+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKUA)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKUA)*X1+(FIM-2*VKUA)*X2-(AM/PIM)*DHIM



      FIM = (1.D0+FZEROM)*FIM - FZEROM*VKUM*AM/PIM

      DFIM = (1.D0+FZEROM)*DFIM - FZEROM*DVKUM*AM/PIM

      DDFIM = (1.D0+FZEROM)*DDFIM - FZEROM*DDVKUM*AM/PIM



      IF(N.EQ.1) THEN

      GG    = GG   + GEW*FIM* FDISP

      DGG   = DGG  + GEW*DFIM* FDISP

      DDGG  = DDGG + GEW*DDFIM* FDISP

      ENDIF

      IF(N.EQ.3) THEN

      GG    = GG   + GEW*(FIA-FIM* FDISP)

      DGG   = DGG  + GEW*(DFIA-DFIM* FDISP)

      DDGG  = DDGG + GEW*(DDFIA-DDFIM* FDISP)

      ENDIF

C

110   CONTINUE

100   CONTINUE

C

      F = GG

      DF = DGG

      DDF = DDGG

      ENDIF

CC

      RETURN

      END



C **********************************************************************

      SUBROUTINE HFUN(N,X,AM1,AM2,ALM1,ALM2,DAM,FUN)

C **********************************************************************

C

C     FOURIER TRANSFORM OF

C                                 1                  1

C     H_{N,M}(A,OM1,OM2) = ------------------ ---------------

C                          OM1^{N} OM2^{N}    (OM1+A) (OM2+A)

C                              1

C                        X ---------

C                          (OM1+OM2)

C     FOR N = -1,0,1,2

C

C     SCHEMATICALLY:

C     FUN(1) = F*G,    FUN(2) = DF*G,   FUN(3) = F*DG,

C     FUN(4) = DF*DG,  FUN(5) = DDF*G,  FUN(6) = F*DDG,

C     FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM

      DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      SAVE XX,WW,AA,AA2

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        AA   =DAM/PIM

        AA2  =AA*AA

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

CC

      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1



      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2



      IF(N.EQ.2) THEN

      XA   =X*AM1/PIM

      RATA =AM1/ALM1

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM1 +RATA)

      EPA  =FDERFC( XLM1 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA

      DHIA  =-(AM1/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA

      FI1= FIA

      DFI1= DFIA

      DDFI1= DDFIA



      XA   =X*AM2/PIM

      RATA =AM2/ALM2

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM2 +RATA)

      EPA  =FDERFC( XLM2 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU2)*X1-(AM2/PIM)*HIA

      DHIA  =-(AM2/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKU2)*X1+(FIA-2*VKU2)*X2-(AM2/PIM)*DHIA

      FI2= FIA

      DFI2= DFIA

      DDFI2= DDFIA

      ENDIF

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,9

      FUN(IFUN) = 0.D0

  105 HH(IFUN)  = 0.D0

      GG1  =0.D0

      DGG1 =0.D0

      DDGG1=0.D0

      GG2  =0.D0

      DGG2 =0.D0

      DDGG2=0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

C

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

C

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM



      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

C

      IF(N.EQ.-1) THEN

      WGHTH= GEW*Y*Y * FDISP1*FDISP2

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

       IF(AA.NE.0.D0) THEN

      WGHT= WGHTH/(Y*Y+AA2)

      HH(1)   = HH(1)  + WGHT*FIM1*FIM2

      HH(2)   = HH(2)  + WGHT*DFIM1*FIM2

      HH(3)   = HH(3)  + WGHT*FIM1*DFIM2

      HH(4)   = HH(4)  + WGHT*DFIM1*DFIM2

      HH(5)   = HH(5)  + WGHT*DDFIM1*FIM2

      HH(6)   = HH(6)  + WGHT*FIM1*DDFIM2

      HH(7)   = HH(7)  + WGHT*DDFIM1*DFIM2

      HH(8)   = HH(8)  + WGHT*DFIM1*DDFIM2

      HH(9)   = HH(9)  + WGHT*DDFIM1*DDFIM2

      WGHT= GEW*Y*Y/(Y*Y+AA2)

      GG1   = GG1  + WGHT*FIM1* FDISP1

      DGG1  = DGG1 + WGHT*DFIM1* FDISP1

      DDGG1 = DDGG1+ WGHT*DDFIM1* FDISP1

      GG2   = GG2  + WGHT*FIM2* FDISP2

      DGG2  = DGG2 + WGHT*DFIM2* FDISP2

      DDGG2 = DDGG2+ WGHT*DDFIM1* FDISP2

       ENDIF



      ENDIF

C

      IF(N.EQ.0) THEN

      WGHTH= GEW*Y*Y/(Y*Y+AA2) * FDISP1*FDISP2

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

      ENDIF



      IF(N.EQ.1.AND.AA.NE.0.D0) THEN

      WGHTH= GEW*FDISP1*FDISP2/(Y*Y+AA2)

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

      WGHT= AA/(Y*Y+AA2)

      GG1   = GG1  + GEW*WGHT*FIM1* FDISP1

      DGG1  = DGG1 + GEW*WGHT*DFIM1* FDISP1

      DDGG1 = DDGG1+ GEW*WGHT*DDFIM1* FDISP1

      GG2   = GG2  + GEW*WGHT*FIM2* FDISP2

      DGG2  = DGG2 + GEW*WGHT*DFIM2* FDISP2

      DDGG2 = DDGG2+ GEW*WGHT*DDFIM1* FDISP2

      ENDIF

      IF(N.EQ.1.AND.AA.EQ.0.D0) THEN

      WGHTH= 1.D0/Y**2

      FUN(1)  = FUN(1)  + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(2)  = FUN(2)  + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(3)  = FUN(3)  + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(4)  = FUN(4)  + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(5)  = FUN(5)  + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(6)  = FUN(6)  + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2)

      FUN(7)  = FUN(7)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DFI2-DFIM2*FDISP2)

      FUN(8)  = FUN(8)  + WGHTH*(DFI1-DFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      FUN(9)  = FUN(9)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      ENDIF



      IF(N.EQ.2) THEN

      WGHTH= GEW/(Y*Y+AA2)/Y**2

      FUN(1)  = FUN(1)  + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(2)  = FUN(2)  + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(3)  = FUN(3)  + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(4)  = FUN(4)  + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(5)  = FUN(5)  + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(6)  = FUN(6)  + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2)

      FUN(7)  = FUN(7)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DFI2-DFIM2*FDISP2)

      FUN(8)  = FUN(8)  + WGHTH*(DFI1-DFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      FUN(9)  = FUN(9)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      ENDIF

C

110   CONTINUE

100   CONTINUE



      IF(N.EQ.-1.AND.AA.NE.0.D0) THEN

      FUN(1)  = FUN(1) - AA*GG1*GG2    -AA2*HH(1)

      FUN(2)  = FUN(2) - AA*DGG1*GG2   -AA2*HH(2)

      FUN(3)  = FUN(3) - AA*GG1*DGG2   -AA2*HH(3)

      FUN(4)  = FUN(4) - AA*DGG1*DGG2  -AA2*HH(4)

      FUN(5)  = FUN(5) - AA*DDGG1*GG2  -AA2*HH(5)

      FUN(6)  = FUN(6) - AA*GG1*DDGG2  -AA2*HH(6)

      FUN(7)  = FUN(7) - AA*DDGG1*DGG2 -AA2*HH(7)

      FUN(8)  = FUN(8) - AA*DGG1*DDGG2 -AA2*HH(8)

      FUN(9)  = FUN(9) - AA*DDGG1*DDGG2-AA2*HH(9)

      ENDIF



      IF(N.EQ.1.AND.AA.NE.0.D0) THEN

      FUN(1)  = FUN(1) - GG1*GG2/AA

      FUN(2)  = FUN(2) - DGG1*GG2/AA

      FUN(3)  = FUN(3) - GG1*DGG2/AA

      FUN(4)  = FUN(4) - DGG1*DGG2/AA

      FUN(5)  = FUN(5) - DDGG1*GG2/AA

      FUN(6)  = FUN(6) - GG1*DDGG2/AA

      FUN(7)  = FUN(7) - DDGG1*DGG2/AA

      FUN(8)  = FUN(8) - DGG1*DDGG2/AA

      FUN(9)  = FUN(9) - DDGG1*DDGG2/AA

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE HDIF(N,X,AM1,AM2,ALM1,DAM,FUN)

C **********************************************************************

C

C     SECOND EXCHANGE IS DIFFRACTIVE:  (ONLY READY FOR N=0)

C     FOURIER TRANSFORM OF

C                                 1                  1

C     H_{N,M}(A,OM1,OM2) = ------------------ ---------------

C                          OM1^{N} OM2^{N}    (OM1+A) (OM2+A)

C                              1

C                        X ---------

C                          (OM1+OM2)

C     FOR N = -1,0,1,2

C

C     SCHEMATICALLY:

C     FUN(1) = F*G,    FUN(2) = DF*G,   FUN(3) = F*DG,

C     FUN(4) = DF*DG,  FUN(5) = DDF*G,  FUN(6) = F*DDG,

C     FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM

      DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(12)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/

      DATA AMPRO/938.2796D0/

      SAVE XX,WW,AA,AA2

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

      IF(ICALL.EQ.0) THEN

        AA   =DAM/PIM

        AA2  =AA*AA

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN HFUN: IMETH=',I2,' NPNT=',I2,//)

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

CC



C     DIFFRACTIVE:

      XA   =X*AM2/PIM

      FIA  =(4.D0/SRPI)*(AM2/PIM)*(AM2/AMPRO)**2*FDEXP(-XA*XA)

      DFIA =-2*(AM2/PIM)*XA*FIA

      DDFIA =-2*(AM2/PIM)*(XA*DFIA + FIA*AM2/PIM)

      FI2= FIA

      DFI2= DFIA

      DDFI2= DDFIA



      RATP1=PIM/ALM1

      XLM1 =0.5D0*X*ALM1/PIM

      XLM12=XLM1*XLM1

      VKU1 =(ALM1/PIM)*FDEXP(-XLM12)/(2*SRPI)

      DVKU1=-0.5D0*(ALM1/PIM)**2*X*VKU1



C     DIFFRACTIVE:

      ALM2 = 2*AM2

      RATP2=PIM/ALM2

      XLM2 =0.5D0*X*ALM2/PIM

      XLM22=XLM2*XLM2

      VKU2 =(ALM2/PIM)*FDEXP(-XLM22)/(2*SRPI)

      DVKU2=-0.5D0*(ALM2/PIM)**2*X*VKU2



      IF(N.EQ.2) THEN

      XA   =X*AM1/PIM

      RATA =AM1/ALM1

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLM1 +RATA)

      EPA  =FDERFC( XLM1 +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKU1)*X1-(AM1/PIM)*HIA

      DHIA  =-(AM1/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKU1)*X1+(FIA-2*VKU1)*X2-(AM1/PIM)*DHIA

      FI1= FIA

      DFI1= DFIA

      DDFI1= DDFIA

      ENDIF

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      DO 105 IFUN=1,9

      FUN(IFUN) = 0.D0

  105 HH(IFUN)  = 0.D0

      GG1  =0.D0

      DGG1 =0.D0

      DDGG1=0.D0

      GG2  =0.D0

      DGG2 =0.D0

      DDGG2=0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

C

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

C

      FIM2  = FI2

      DFIM2  = DFI2

      DDFIM2  = DDFI2

C

      IF(N.EQ.-1) THEN

      WGHTH= GEW*Y*Y * FDISP1*FDISP2

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

       IF(AA.NE.0.D0) THEN

      WGHT= WGHTH/(Y*Y+AA2)

      HH(1)   = HH(1)  + WGHT*FIM1*FIM2

      HH(2)   = HH(2)  + WGHT*DFIM1*FIM2

      HH(3)   = HH(3)  + WGHT*FIM1*DFIM2

      HH(4)   = HH(4)  + WGHT*DFIM1*DFIM2

      HH(5)   = HH(5)  + WGHT*DDFIM1*FIM2

      HH(6)   = HH(6)  + WGHT*FIM1*DDFIM2

      HH(7)   = HH(7)  + WGHT*DDFIM1*DFIM2

      HH(8)   = HH(8)  + WGHT*DFIM1*DDFIM2

      HH(9)   = HH(9)  + WGHT*DDFIM1*DDFIM2

      WGHT= GEW*Y*Y/(Y*Y+AA2)

      GG1   = GG1  + WGHT*FIM1* FDISP1

      DGG1  = DGG1 + WGHT*DFIM1* FDISP1

      DDGG1 = DDGG1+ WGHT*DDFIM1* FDISP1

      GG2   = GG2  + WGHT*FIM2* FDISP2

      DGG2  = DGG2 + WGHT*DFIM2* FDISP2

      DDGG2 = DDGG2+ WGHT*DDFIM1* FDISP2

       ENDIF



      ENDIF

C

      IF(N.EQ.0) THEN

      WGHTH= GEW*Y*Y/(Y*Y+AA2) * FDISP1*FDISP2

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

      ENDIF



      IF(N.EQ.1.AND.AA.NE.0.D0) THEN

      WGHTH= GEW*FDISP1*FDISP2/(Y*Y+AA2)

      FUN(1)  = FUN(1)  + WGHTH*FIM1*FIM2

      FUN(2)  = FUN(2)  + WGHTH*DFIM1*FIM2

      FUN(3)  = FUN(3)  + WGHTH*FIM1*DFIM2

      FUN(4)  = FUN(4)  + WGHTH*DFIM1*DFIM2

      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*FIM2

      FUN(6)  = FUN(6)  + WGHTH*FIM1*DDFIM2

      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*DFIM2

      FUN(8)  = FUN(8)  + WGHTH*DFIM1*DDFIM2

      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*DDFIM2

      WGHT= AA/(Y*Y+AA2)

      GG1   = GG1  + GEW*WGHT*FIM1* FDISP1

      DGG1  = DGG1 + GEW*WGHT*DFIM1* FDISP1

      DDGG1 = DDGG1+ GEW*WGHT*DDFIM1* FDISP1

      GG2   = GG2  + GEW*WGHT*FIM2* FDISP2

      DGG2  = DGG2 + GEW*WGHT*DFIM2* FDISP2

      DDGG2 = DDGG2+ GEW*WGHT*DDFIM1* FDISP2

      ENDIF

      IF(N.EQ.1.AND.AA.EQ.0.D0) THEN

      WGHTH= 1.D0/Y**2

      FUN(1)  = FUN(1)  + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(2)  = FUN(2)  + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(3)  = FUN(3)  + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(4)  = FUN(4)  + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(5)  = FUN(5)  + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(6)  = FUN(6)  + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2)

      FUN(7)  = FUN(7)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DFI2-DFIM2*FDISP2)

      FUN(8)  = FUN(8)  + WGHTH*(DFI1-DFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      FUN(9)  = FUN(9)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      ENDIF



      IF(N.EQ.2) THEN

      WGHTH= GEW/(Y*Y+AA2)/Y**2

      FUN(1)  = FUN(1)  + WGHTH*(FI1-FIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(2)  = FUN(2)  + WGHTH*(DFI1-DFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(3)  = FUN(3)  + WGHTH*(FI1-FIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(4)  = FUN(4)  + WGHTH*(DFI1-DFIM1*FDISP1)*(DFI2-DFIM2*FDISP2)

      FUN(5)  = FUN(5)  + WGHTH*(DDFI1-DDFIM1*FDISP1)*(FI2-FIM2*FDISP2)

      FUN(6)  = FUN(6)  + WGHTH*(FI1-FIM1*FDISP1)*(DDFI2-DDFIM2*FDISP2)

      FUN(7)  = FUN(7)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DFI2-DFIM2*FDISP2)

      FUN(8)  = FUN(8)  + WGHTH*(DFI1-DFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      FUN(9)  = FUN(9)  + WGHTH*(DDFI1-DDFIM1*FDISP1)

     .                         *(DDFI2-DDFIM2*FDISP2)

      ENDIF

C

110   CONTINUE

100   CONTINUE



      IF(N.EQ.-1.AND.AA.NE.0.D0) THEN

      FUN(1)  = FUN(1) - AA*GG1*GG2    -AA2*HH(1)

      FUN(2)  = FUN(2) - AA*DGG1*GG2   -AA2*HH(2)

      FUN(3)  = FUN(3) - AA*GG1*DGG2   -AA2*HH(3)

      FUN(4)  = FUN(4) - AA*DGG1*DGG2  -AA2*HH(4)

      FUN(5)  = FUN(5) - AA*DDGG1*GG2  -AA2*HH(5)

      FUN(6)  = FUN(6) - AA*GG1*DDGG2  -AA2*HH(6)

      FUN(7)  = FUN(7) - AA*DDGG1*DGG2 -AA2*HH(7)

      FUN(8)  = FUN(8) - AA*DGG1*DDGG2 -AA2*HH(8)

      FUN(9)  = FUN(9) - AA*DDGG1*DDGG2-AA2*HH(9)

      ENDIF



      IF(N.EQ.1.AND.AA.NE.0.D0) THEN

      FUN(1)  = FUN(1) - GG1*GG2/AA

      FUN(2)  = FUN(2) - DGG1*GG2/AA

      FUN(3)  = FUN(3) - GG1*DGG2/AA

      FUN(4)  = FUN(4) - DGG1*DGG2/AA

      FUN(5)  = FUN(5) - DDGG1*GG2/AA

      FUN(6)  = FUN(6) - GG1*DDGG2/AA

      FUN(7)  = FUN(7) - DDGG1*DGG2/AA

      FUN(8)  = FUN(8) - DGG1*DDGG2/AA

      FUN(9)  = FUN(9) - DDGG1*DDGG2/AA

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE PRSU3TM(IV,NCASE,X,P,N3)

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PSBE/ VPR(5,5,4,4,4)                              

      DIMENSION VTOT(5)

C SUMMED CONTRIBUTIONS:                   

      DO 120 ICHAN=1,5

      VTOT(ICHAN)=0.D0

      DO 120 M=1,4

      DO 120 N=1,4

  120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE)

      if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/,

     .         ' VCLS=',F10.2,3x,' VCSS=',F10.2,/)

      if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/,

     .         ' VSLS=',F10.2,3x,' VSSS=',F10.2,/)

C CONTRIBUTIONS TO SU(3)-POTENTIALS:                        

      if(p.eq.1.d0) then

      V27a = VTOT(1)                                                    

      V27b = VTOT(5)                                                    

      V27c = (9*VTOT(2)-VTOT(4))/8.D0

c     V8Sa = 10*VTOT(2)-9*VTOT(5)

      V8Sa =    VTOT(2)+3*VTOT(3)

      V8Sb = (10*VTOT(4)-VTOT(5))/9.D0

      V8Sc = (9*VTOT(4)-VTOT(2))/8.D0

      VLSa = (-3*V27b+3*V8Sa)/10.D0

      VLSb = (-3*V27b+3*V8Sb)/10.D0

      VLSc = (-3*V27c+3*V8Sc)/10.D0

      write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc

  123 format(' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/,

     .       ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/,

     .       ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2,/)

      endif

      if(p.eq.-1.d0) then

      V10nn= VTOT(1)

      V10  = VTOT(5)

      V10sa= VTOT(2)+VTOT(3)                                            

      V10sb= VTOT(4)+VTOT(3)                                            

      V8Aa = VTOT(2)-VTOT(3)                                            

      V8Ab = VTOT(4)-VTOT(3)                                            

      write(N3,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10

  124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,3x,' V10nn=',F10.2,/,

     .       ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10  =',F10.2,/)

      endif

      RETURN

      END



C**********************************************************************

      SUBROUTINE POTGR(XCALL,PIM,P,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)          

C**********************************************************************

C     GREEN TRANSFORMATION FOR POTENTIALS ON SU(2)-BASIS

C     FOR AKS(I)=0

C----------------------------------------------------------------------



      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/POT/VCLL,VSIGLL,VTENLL,VSOLL,VASOLL,VSO2LL,

     .           FILL,DFILL,DDFILL,FISLL,DFISLL,DDFSLL,

     .           VCSS,VSIGSS,VTENSS,VSOSS,VASOSS,VSO2SS,

     .           FISS,DFISS,DDFISS,FISSS,DFISSS,DDFSSS,

     .           VCLS,VSIGLS,VTENLS,VSOLS,VASOLS,VSO2LS,

     .           FILS,DFILS,DDFILS,FISLS,DFISLS,DDFSLS,

     .           VCDR,VSIGDR,VTENDR,VSODR,VASODR,VSO2DR,

     .           FIDR,DFIDR,DDFIDR,FISDR,DFISDR,DDFSDR

c*   .          ,VCNN,VSIGNN,VTENNN,VSONN,VSO2NN

      COMMON/STPS/H,NMAX,NSTPD,KSTPD(5),NMIN

      DIMENSION XA(300),TGRA(3,3,300),TGRPA(3,3,300)

      DIMENSION PHI(3,3),DPHI(3,3),TGR(3,3),TGRP(3,3),

     .          AB(3,3),PHIO(3,3),DPHIO(3,3),TGINT(3,3,3),TGPINT(3,3,3)

      DATA ICALL/0/,PHI/9*0.D0/,DPHI/9*0.D0/,AB/9*0.D0/

      SAVE XA,TGRA,TGRAP

C----------------------------------------------------------------------



C     GENERATION GREEN TRANSFORMATIONS FOR THE POINT XA(I):

      IF(ICALL.EQ.0) THEN



      CALL XVALS(XA)       



C     FOR SUBROUTINE GREEN : REVERSAL LOOP VARIABLE :

C

      DO 4 II=2,NMAX

C

      I=NMAX+2-II

      X=XA(I)

      CALL VMATP(X,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)          

C

C     GREEN TRANSFORMATION MATRICES : TGR,TGRP,GRPP :

C

c     IF(XA(I).GE.0.35D0) THEN

      PHI(1,1)=1.D0+2*FILL

      PHI(1,2)=2*FILS

      PHI(2,2)=1.D0+2*FISS

      PHI(2,1)=PHI(1,2)

      PHI(3,3)=1.D0+2*FIDR

      DPHI(1,1)=2*DFILL/PIM

      DPHI(1,2)=2*DFILS/PIM

      DPHI(2,2)=2*DFISS/PIM

      DPHI(2,1)=DPHI(1,2)

      DPHI(3,3)=2*DFIDR/PIM

C

C     INPUT : PHI-,DPHI-MATRIX ON THE ISOSPIN BASIS

C

      IF(X.LT.0.7D0) CALL GRNTST(X,PHI,DPHI,IRET)

      CALL GREEN (1,II,X,PHI,DPHI,TGR,TGRP,PHIO,DPHIO)

C

C     OUTPUT: TGR,TGRP:  ON SU(2)-BASIS

C

      DO 14 KK=1,3

      DO 14 LL=1,3

      TGRA(KK,LL,I) = TGR(KK,LL)

   14 TGRPA(KK,LL,I) = TGRP(KK,LL)



    4 CONTINUE

      ENDIF

C----------------------------------------------------------------------

C

C     GREEN'S TRANSFORMATION

C

      IVAL = NMAX

      IIMIN=1

      IIMAX=NMAX

      DO 10 I=1,NMAX

   10 IF(XCALL.GE.XA(I).AND.XCALL.LE.XA(I+1)) IVAL=I

C

C     GENERATION GREEN TRANSFORMATION MATRICES BY INTERPOLATION:

C

      NMAX1 = NMAX-1

      IF(IVAL.LT.NMAX1) THEN

      DO 11 KK=1,3

      DO 11 LL=1,3

      DO 11 II=1,3

      TGINT(KK,LL,II)=TGRA(KK,LL,IVAL+II-1)

      TGPINT(KK,LL,II)=TGRPA(KK,LL,IVAL+II-1)

   11 CONTINUE

      CALL INTPOL3(XCALL,IVAL,NMAX,XA,TGINT,TGR)

      CALL INTPOL3(XCALL,IVAL,NMAX,XA,TGPINT,TGRP)

      ENDIF

      IF(IVAL.EQ.NMAX) THEN

      DO 12 KK=1,3

      DO 12 LL=1,3

      TGR(KK,LL) = 0.D0

      TGRP(KK,LL) = 0.D0

   12 IF(KK.EQ.LL) TGR(KK,LL)=1.D0

      ENDIF

c     write(*,*) 'at 3, grnpack: ival=',ival,' xcall=',xcall

c     write(*,*) 'grnpack: tgr=',tgr       

c     write(*,*) 'grnpack: tgrp=',tgrp       



      CALL VMATP(XCALL,PIM,P,PX,NCHAN,JSPIN,LINT,NLOC,ICSB,NS)          

      PHI(1,1)=1.D0+2*FILL

      PHI(1,2)=2*FILS

      PHI(2,2)=1.D0+2*FISS

      PHI(2,1)=PHI(1,2)

      PHI(3,3)=1.D0+2*FIDR

      DPHI(1,1)=2*DFILL/PIM

      DPHI(1,2)=2*DFILS/PIM

      DPHI(2,2)=2*DFISS/PIM

      DPHI(2,1)=DPHI(1,2)

      DPHI(3,3)=2*DFIDR/PIM

C

C     GREEN TRANSFORMATION CENTRAL POTENTIAL:

      AB(1,1  )= VCLL

      AB(1,2  )= VCLS                           

      AB(2,2  )= VCSS                                           

      AB(3,3  )= VCDR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VCLL = AB(1,1  )

      VCLS = AB(1,2  )                           

      VCSS = AB(2,2  )                                           

      VCDR = AB(3,3  )                                           

C     GREEN TRANSFORMATION SPIN-SPIN POTENTIAL:

      AB(1,1  )= VSIGLL

      AB(1,2  )= VSIGLS                           

      AB(2,2  )= VSIGSS                                           

      AB(3,3  )= VSIGDR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VSIGLL = AB(1,1  )

      VSIGLS = AB(1,2  )                           

      VSIGSS = AB(2,2  )                                           

      VSIGDR = AB(3,3  )                                           

C     GREEN TRANSFORMATION TENSOR POTENTIAL:

      AB(1,1  )= VTENLL

      AB(1,2  )= VTENLS                           

      AB(2,2  )= VTENSS                                           

      AB(3,3  )= VTENDR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VTENLL = AB(1,1  )

      VTENLS = AB(1,2  )                           

      VTENSS = AB(2,2  )                                           

      VTENDR = AB(3,3  )                                           

C     GREEN TRANSFORMATION SPIN-ORBIT POTENTIAL:

      AB(1,1  )= VSOLL

      AB(1,2  )= VSOLS                           

      AB(2,2  )= VSOSS                                           

      AB(3,3  )= VSODR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VSOLL = AB(1,1  )

      VSOLS = AB(1,2  )                           

      VSOSS = AB(2,2  )                                           

      VSODR = AB(3,3  )                                           

C     GREEN TRANSFORMATION QUADRATIC SPIN-ORBIT POTENTIAL:

      AB(1,1  )= VSO2LL

      AB(1,2  )= VSO2LS                           

      AB(2,2  )= VSO2SS                                           

      AB(3,3  )= VSO2DR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VSO2LL = AB(1,1  )

      VSO2LS = AB(1,2  )                           

      VSO2SS = AB(2,2  )                                           

      VSO2DR = AB(3,3  )                                           

C     GREEN TRANSFORMATION ANTI-SYMMETRIC SPIN-ORBIT POTENTIAL:

      AB(1,1  )= VSOALL

      AB(1,2  )= VSOALS                           

      AB(2,2  )= VSOASS                                           

      AB(3,3  )= VSOADR                                           

      AB(2,1  )= AB(1,2  )

      CALL GRNTRN(X,AB,PHI,DPHI,TGR,TGRP)

      VASOLL = AB(1,1  )

      VASOLS = AB(1,2  )                           

      VASOSS = AB(2,2  )                                           

      VASODR = AB(3,3  )                                           

C

      ICALL = 1

      RETURN

      END

c *******************************************************************

      subroutine xvals(xa)

c *******************************************************************

      implicit real*8(a-h,o-z)

      dimension xa(300)

      common /stps/h,nmax,nstpd,kstpd(5),nmin

      dimension kstps(5)

c     data hi/0.5d-02/,nmaxi/300/,nstps/4/,kstps/50,150,250,300,0/

      data hi/0.3d-01/,nmaxi/100/,nstps/2/,kstps/20,40,100,0,0/    

      data x0/0.d0/



      h=hi  

      nmax=nmaxi

      nstpd=nstps

      do 10 ii=1,5

   10 kstpd(ii)=kstps(ii)

      xa(1) = x0

      do 7 i=2,nmax

      hh=h

      do 71 ii=1,nstpd

   71 if(i.gt.kstpd(ii)) hh=2*hh

    7 xa(i) = xa(i-1)+hh

c     write(*,*) 'xvals: xa=',xa

      return

      end

C *******************************************************************

      SUBROUTINE GRNTRN(XA,AB,PHI,PHIP,TGR,TGRP)

C *******************************************************************

c

c     CALLED BY POTGR FOR CONSTRUCTION POT'S -MATRIX AFTER GREEN-TRANSF.

c

c     NOTE THAT HERE : PHI = M-MATRIX=1 + 2 * PHI ETC.

C *******************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION AB(3,3),TGR(3,3),TGRP(3,3),

     ,          PHI(3,3),PHIP(3,3),AI(3,3),

     ,          PHITGR(3,3),PHITGM(3,3),PHPTGP(3,3),ABTGR(3,3)

      DATA AI/1.D0,0.D0,0.D0,0.D0,1.D0,0.D0,0.D0,0.D0,1.D0/

      N=3

      NN=N/3

C     PRINT 51

C     DO 50 KK=1,N

C 50  PRINT 61, (AB(KK,LL),LL=1,N)

C 51  FORMAT('  ENTERING GRNTRN : ')

C     DO 2000 I=1,3

C2000 PRINT 2001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3)

C2001 FORMAT(/,'  GRNTRN PHI=',3(D12.5,2X),'  PHIP=',3(D12.5,2X))

C     DO 3000 I=1,3

C3000 PRINT 3001, (TGR(I,J),J=1,3),(TGRP(I,J),J=1,3)

C3001 FORMAT(/,'  GRNTRN TGR=',3(D12.5,2X),'  TGRP=',3(D12.5,2X))

C4000 CONTINUE

C

      DO 1 I=1,3

      DO 1 IA=1,NN

      IIA=NN*(I-1)+IA

      DO 2 J=1,3

      DO 2 JB=1,NN

      JJB=NN*(J-1)+JB

      PHITGR(IIA,JJB)=0.D0

      PHPTGP(IIA,JJB)=0.D0

      DO 11 K=1,3

      PHITGR(IIA,JJB)=PHITGR(IIA,JJB)+PHI(I,K)*TGR(K,J)*AI(IA,JB)

   11 PHPTGP(IIA,JJB)=PHPTGP(IIA,JJB)+PHIP(I,K)*TGRP(K,J)*AI(IA,JB)

    2 CONTINUE

    1 CONTINUE

C

      DO 3 I=1,3

      DO 3 IA=1,NN

      IIA=NN*(I-1)+IA

      DO 4 J=1,3

      DO 4 JB=1,NN

      JJB=NN*(J-1)+JB

      ABTGR (IIA,JJB)=0.D0

      DO 41 K=1,3

      DO 41 KC=1,NN

      KKC=NN*(K-1)+KC

   41 ABTGR(IIA,JJB)=ABTGR(IIA,JJB)+AB(IIA,KKC)*TGR(K,J)*AI(KC,JB)

    4 CONTINUE

    3 CONTINUE

C

      DO 5 I=1,3

      DO 5 J=1,3

      PHITGM(I,J)=0.D0

    5 PHITGM(I,I)=1.D0

      CALL INVER3(PHITGM,PHITGR)

C

      DO 6 I=1,N

      DO 6 J=1,N

      AB(I,J)=0.D0

      DO 7 K=1,N

    7 AB(I,J)=AB(I,J) +

     +            0.5D0*PHITGM(I,K) * PHPTGP(K,J)

    6 CONTINUE

      DO 8 I=1,N

      DO 8 J=1,N

      DO 9 K=1,N

    9 AB(I,J)=AB(I,J)+

     +             PHITGM(I,K) * ABTGR(K,J)

    8 CONTINUE

C     PRINT 62

C     DO 60 KK=1,N

C 60  PRINT 61, (AB(KK,LL),LL=1,N)

C 61  FORMAT(' GRNTRN AB=',6(D12.5,5X))

C 62  FORMAT('  LEAVING GRNTRN : ')

      RETURN

      END

C **************************************************************

      SUBROUTINE GREEN (ICH,INDX,X,BM,BMP,T,TP,BMO,BMPO)

c     CALLED BY :

c     AMATLP/AMATLN FOR CONSTRUCTION OF GREEN-TRANSFORMATION

C **************************************************************

C

*     THIS VERSION (2) SOLVES THE DIFFERENTIAL EQUATION :

*

*                  2 * BM * TP + BMP * T= 0

*

*     STARTING FROM X=XMAX AND GOING INSIDE TOWARDS X=0

*

*     FIRST CALLS SHOULD HAVE INDX=2       ,3         ,4         , ...

*     CORRESPONDING TO           X=XA(NMAX),XA(NMAX-1),XA(NMAX-2), ...

*

*     IN CALLING PROGRAM X=XA(IX), IX=NMAX+2-INDX, INDX=2,NMAX

*

*     ICH=1 : LAMBDA-PROTON  SYSTEM

*     ICH=2 : LAMBDA-NEUTRON SYSTEM

*

C

C     T   : GREEN-TRANSFORMATION MATRIX ON THE PARTICLE BASIS

C     TI  :   ,,       ,,          ,,   ,,  ,, ISOSPIN   ,,

C

C     INPUT  : BM   = COEFFICIENT MATRIX OF U'' (ISOSPIN=1/2)

C              BMP  =     ,,        ,,   OF U'  (     ,,    )

C              BM(3,3) = COEFFICIENT MATRIX OF U'' (ISOSPIN=3/2)

C              BMP(3,3)=     ,,        ,,   OF U'  (     ,,    )

C

C     OUTPUT : T AND TP=DT/DX

C

C **************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/STPS/H,NMAX,NSTPD,KSTPD(5),NMIN

      DIMENSION BM(3,3),BMP(3,3),BMO(3,3),BMPO(3,3)

      DIMENSION T(3,3),TP(3,3),TI(3,3),TIP(3,3,7),

     ,          AI(3,3),TRANS(3,3),TRAND(3,3),

     ,          A(3,3),AINV(3,3),BMINV(3,3),TIT(3,3)

      DATA ICALL/0/,AI/1.D0,0.D0,0.D0, 0.D0,1.D0,0.D0, 0.D0,0.D0,1.D0/

      DATA TI/9*0.D0/,TIP/63*0.D0/,BMINV/9*0.D0/,ONE/1.D0/,SGNLD/1.D0/

      DATA A /9*0.D0/,AINV/9*0.D0/,TIT/9*0.D0/,ITEST/0/

      SAVE TRANS,TRAND,TI,TIP

C

      IF(INDX.GT.7) GOTO 50

      IF(ICALL.EQ.0.AND.ICH.EQ.1) CALL TRANLP(TRANS,TRAND)

      IF(ICALL.EQ.0.AND.ICH.EQ.2) CALL TRANLN(TRANS,TRAND)

      ICALL=1

C

C     DEFINITION : T= UNIT MATRIX AT X=XA(NMAX),.....,XA(NMAX-6)

C

       DO 10 K=1,6

        KKK=7-K

         DO 10 I=1,3

          DO 10 J=1,3

10         TIP(I,J,KKK+1)=TIP(I,J,KKK)

      DET=BM(1,1)*BM(2,2)-BM(1,2)*BM(2,1)

      SGNLD=DSIGN(ONE,DET)

      BMINV(1,1)=BM(2,2)/DET

      BMINV(2,2)=BM(1,1)/DET

      BMINV(1,2)=-BM(1,2)/DET

      BMINV(2,1)=-BM(2,1)/DET

      BMINV(3,3)=1.D0/BM(3,3)

      CALL MULTM(BMINV,BMP,1)

      DO 11 I=1,2

      DO 11 J=1,2

 11   TI(I,J)=AI(I,J)

C

      DO 12 I=1,2

      DO 12 J=1,2

      TIP(I,J,1)=0.D0

      DO 13 K=1,2

13    TIP(I,J,1)=TIP(I,J,1)-0.5D0*BMINV(I,K)*TI(K,J)

12    CONTINUE

C

      TI(3,3)=1.0D0/DSQRT(BM(3,3))

      TIP(3,3,1)=-0.5D0*TI(3,3)**3*BMP(3,3)

      GOTO 100

C

50    ID=0

      HH=H

      IX=NMAX+2-INDX

      DO 500 II=1,NSTPD

      IF(IX.EQ.(KSTPD(II)-1)) ID=1

500   IF(IX.GT.KSTPD(II)) HH=2.D0*HH

      IF(ID.NE.1) GOTO 510

C

C     ADAPTIONS AFTER HALVING THE STEPSIZE : INTERPOLATION

C

      CALL INTPOL(IX,TIP,HH,7)

C

510   DET=BM(1,1)*BM(2,2)-BM(1,2)*BM(2,1)

      SGNNW=DSIGN(ONE,DET)

      IF(SGNNW.NE.SGNLD) PRINT 512, DET

512   FORMAT(/,' GREEN, WARNING: SIGN CHANGE IN DETERMINANT BM=',D12.5)

      BMINV(1,1)=BM(2,2)/DET

      BMINV(2,2)=BM(1,1)/DET

      BMINV(1,2)=-BM(1,2)/DET

      BMINV(2,1)=-BM(2,1)/DET

      BMINV(3,3)=1.D0/BM(3,3)

      CALL MULTM(BMINV,BMP,1)

      IF(ITEST.EQ.0) GOTO 35

      DO 39 I=1,3

      DO 38 J=1,3

  38  A(I,J)=0.5D0*BMINV(I,J)

  39  IF(ITEST.NE.0) PRINT 37,(A(I,J),J=1,3)

  37  FORMAT(/,' DT/DY=A * T , A =',3(D12.5,2X))

      DETA=(A(1,1)*A(2,2)-A(1,2)*A(2,1))*A(3,3)

      VALU1=A(1,1)+A(2,2)+DSQRT((A(1,1)-A(2,2))**2+4*A(1,2)*A(2,1))

      VALU2=A(1,1)+A(2,2)-DSQRT((A(1,1)-A(2,2))**2+4*A(1,2)*A(2,1))

      IF(ITEST.NE.0) PRINT 36, DETA,VALU1,VALU2,A(3,3)

  36  FORMAT(/,' DETERMINANT A =',D12.5,' EIGENVALUES : VALU1= ',D12.5,

     ,         '  VALU2= ',D12.5,'  VALU3= ',D12.5,/)

C

  35  DO 51 I=1,3

      DO 51 J=1,3

      AINV(I,J)=AI(I,J)

  51  A(I,J)=AI(I,J)-251.D0*HH*BMINV(I,J)/1440.D0

      DET=A(1,1)*A(2,2)-A(1,2)*A(2,1)

      AINV(1,1)=A(2,2)/DET

      AINV(2,2)=A(1,1)/DET

      AINV(1,2)=-A(1,2)/DET

      AINV(2,1)=-A(2,1)/DET

      DO 52 I=1,2

      DO 52 J=1,2

  52  TI(I,J)=TI(I,J)-HH*(646.D0*TIP(I,J,1)-264.D0*TIP(I,J,2)+

     2                    106.D0*TIP(I,J,3)- 19.D0*TIP(I,J,4))/720.D0

      TI(3,3)=1.0D0/DSQRT(BM(3,3))

      CALL MULTM(AINV,TI,2)

C

      KK=6

       DO 53 K=1,KK

        KKK=KK-K+1

         DO 53 I=1,3

          DO 53 J=1,3

53         TIP(I,J,KKK+1)=TIP(I,J,KKK)

      DO 54 I=1,2

       DO 54 J=1,2

        TIP(I,J,1)=0.D0

         DO 54 K=1,2

54        TIP(I,J,1)=TIP(I,J,1)-

     -               0.5D0*BMINV(I,K)*TI(K,J)

C

       TIP(3,3,1)=-0.5D0*TI(3,3)**3*BMP(3,3)

C

100   DO 101 I=1,3

      DO 101 J=1,3

      II=I

      JJ=J

      IF(I.EQ.3) II=2

      IF(J.EQ.3) JJ=2

C     PARTICLE BASIS:

      BMO (I,J)=TRANS(I,J)*BM  (II,JJ)  +TRAND(I,J)*BM (3,3)

      BMPO(I,J)=TRANS(I,J)*BMP (II,JJ)  +TRAND(I,J)*BMP(3,3)

c     T  (I,J)=TRANS(I,J)*TI  (II,JJ)  +TRAND(I,J)*TI(3,3)

c     TP (I,J)=TRANS(I,J)*TIP (II,JJ,1)+TRAND(I,J)*TIP(3,3,1)

C     SU(2)-BASIS:

      T  (I,J)= TI  (I,J)  

      TP (I,J)= TIP (I,J,1)

101   CONTINUE

C     DO 3000 I=1,3

C3000 PRINT 3001 , (T  (I,J),J=1,3)

C3001 FORMAT(/,'  GREEN TGR=',3(D12.5,3X))

C     DO 4000 I=1,3

C4000 PRINT 4001 , (TP (I,J),J=1,3)

C4001 FORMAT(/,'  GREEN TGRP=',3(D12.5,3X))

C

      IF(ITEST.EQ.0) RETURN

      DO 6000 I=1,3

 6000 PRINT 6001 , (TI(I,J),J=1,3),(TIP(I,J,1),J=1,3)

 6001 FORMAT(/,'  GREEN TI =',3(D12.5,3X),' TIP =',3(D12.5,3X))

C

      ADIA1=(BM(1,1)-1.D0)/2.D0

      ADIA2=(BM(2,2)-1.D0)/2.D0

      AOFF=BM(1,2)/2.D0

      A33=(BM(3,3)-1.D0)/2.D0

      T11=1.D0/DSQRT(1.D0+2.D0*(ADIA1-AOFF))

      T22=1.D0/DSQRT(1.D0+2.D0*(ADIA2+AOFF))

      GOTO (401,402),ITEST

  401 TIT(1,1)=T11

      TIT(2,2)=T22

      TIT(1,2)=0.D0

      TIT(2,1)=0.D0

      GOTO 400

  402 TIT(1,1)=(T22+T11)/2.D0

      TIT(1,2)=(T22-T11)/2.D0

      TIT(2,2)=TIT(1,1)

      TIT(2,1)=TIT(1,2)

  400 TIT(3,3)=1.D0/DSQRT(1.D0+2*A33)

      DO 7000 I=1,3

 7000 PRINT 7001 , (TIT(I,J),J=1,3),ITEST

 7001 FORMAT(/,' GREEN TIT =',3(D12.5,3X),'  ITEST=',I3)

C

      RETURN

      END

C **************************************************************

      SUBROUTINE INVER3(A,B)

      IMPLICIT REAL*8(A-H,O-Z)

C     ******************************************************************

C

C     OUTPUT : MATRIX  B**(-1) * A  (STORED IN LOCATIONS OF: A)

C

      DIMENSION A(3,3),B(3,3)

      N=3

      D=1.0D0

      DO 4 K=1,N

      DIV=B(K,K)

      D=D*DIV

      DO 1 J=1,N

    1 A(K,J)=A(K,J)/DIV

      DO 2 J=K,N

    2 B(K,J)=B(K,J)/DIV

      DO 4 I=1,N

      IF(I.EQ.K) GO TO 4

      DET=B(I,K)

      DO 3 J=K,N

    3 B(I,J)=B(I,J)-DET*B(K,J)

      DO 8 J=1,N

    8 A(I,J)=A(I,J)-DET*A(K,J)

    4 CONTINUE

      DS=D

      IF(DABS(DS).LT.0.1D-15) PRINT 5,D

    5 FORMAT(1X,' DETERMINANT INVER3 =  ',D25.16)

      RETURN

      END

C     ******************************************************************

      SUBROUTINE MULTM(A,B,IS)

      IMPLICIT REAL*8(A-H,O-Z)

C     ******************************************************************

C

C     OUTPUT IS=1 : A * B    ( STORED IN LOCATIONS OF MATRIX:  A )

C              =2 : A * B    ( STORED IN LOCATIONS OF MATRIX:  B )

C

      DIMENSION A(3,3),B(3,3),C(6,6)

      N=3

      DO 1 I=1,N

      DO 1 J=1,N

      C(I,J)=0.D0

      DO 2 K=1,N

    2 C(I,J)=C(I,J)+A(I,K)*B(K,J)

    1 CONTINUE

      DO 3 I=1,N

      DO 3 J=1,N

      IF(IS.EQ.1) THEN

      A(I,J)=C(I,J)

      ELSE

      B(I,J)=C(I,J)

      ENDIF

    3 CONTINUE

      RETURN

      END

C **************************************************************

      SUBROUTINE INTPOL(IXA,TIP,H,N)

C **************************************************************

C     INTERPOLATION AT STEPHALVING POINTS

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION TIP(3,3,7),X(7),Y(7),C(7),A(7,7),B(7,7)

      IF(N.NE.7) GOTO 100

      DO 1 I=1,N

    1 X(I)=(I-1)*2*H

C

      DO 2 I=1,3

      DO 2 J=1,3

c

      DO 3 K=1,N

    3 Y(K)=TIP(I,J,K)

C

C     POLYNOMIAL CONSTRUCTION

C

      DO 10 K=1,N

      DO 10 L=1,N

      A(K,L)=0.D0

      B(K,L)=0.D0

      A(K,K)=1.D0

   10 B(K,K)=1.D0

      DO 20 K=1,N

      XL=1.D0

      DO 21 L=1,N

      A(K,L)=XL

   21 XL=X(K)*XL

   20 CONTINUE

      CALL INVER7(B,A,N)

      DO 40 K=1,N

      C(K)=0.D0

      DO 40 L=1,N

   40 C(K)=C(K)+B(K,L)*Y(L)

C     INTERPOLATION

      TIP(I,J,7)=TIP(I,J,4)

      TIP(I,J,5)=TIP(I,J,3)

      TIP(I,J,3)=TIP(I,J,2)

C

      XK2=1.D0

      XK4=1.D0

      XK6=1.D0

      TIP(I,J,2)=0.D0

      TIP(I,J,4)=0.D0

      TIP(I,J,6)=0.D0

      DO 60 K=1,N

      TIP(I,J,2)=TIP(I,J,2)+C(K)*XK2

      TIP(I,J,4)=TIP(I,J,4)+C(K)*XK4

      TIP(I,J,6)=TIP(I,J,6)+C(K)*XK6

      XK2=XK2*H

      XK4=3*XK4*H

   60 XK6=5*XK6*H

C

C     PRINT RESULTS INTERPOLATION

C

C     PRINT 29, IXA,H,I,J

C  29 FORMAT(//,' IN INTPOL : IXA=',I4,' H=',D12.5,' I=',I1,' J=',I1,/)

C     PRINT 30, (TIP(I,J,K),K=1,7)

C  30 FORMAT(/,' TIP(I,J,K)=',7(D12.5,3X),/)

C

 2    CONTINUE

      RETURN

 100  PRINT 101, N

 101  FORMAT(/,' STOP OCCURRED IN SUBROUTINE INTPOL! REASON :',/,

     2         ' ONLY INTERPOLATION WITH N=7 IS ALLOWED',/,' N=',I3)

      STOP

      END

C     ******************************************************************

      SUBROUTINE INVER7(A,B,N)

      IMPLICIT REAL*8(A-H,O-Z)

C     ******************************************************************

C

C     OUTPUT : MATRIX  B**(-1) * A  (STORED IN LOCATIONS OF: A)

C

      DIMENSION A(7,7),B(7,7)

      IF(N.NE.7) WRITE(*,*) 'WARNING: IN INVER7 N=',N

C     N=7 : this statement not accepted by g77!

      D=1.D0

      DO 4 K=1,N

      DIV=B(K,K)

      D=D*DIV

      DO 1 J=1,N

    1 A(K,J)=A(K,J)/DIV

      DO 2 J=K,N

    2 B(K,J)=B(K,J)/DIV

      DO 4 I=1,N

      IF(I.EQ.K) GO TO 4

      DET=B(I,K)

      DO 3 J=K,N

    3 B(I,J)=B(I,J)-DET*B(K,J)

      DO 8 J=1,N

    8 A(I,J)=A(I,J)-DET*A(K,J)

    4 CONTINUE

      DS=D

c     IF(DABS(DS).LT.0.1D-15) PRINT 5,D

c   5 FORMAT(1X,' DETERMINANT INVER7 =  ',D25.16)

      RETURN

      END

C *******************************************************************

      SUBROUTINE GRNTST(XA,PHI,PHIP,IRET)

c

c     CALLED BY AMATLN FOR CHECKING EIGENVALUES                      

c

c     NOTE THAT HERE : PHI = M-MATRIX=1 + 2 * PHI ETC.

C *******************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION PHI(3,3),PHIP(3,3),AI(3,3),

     .          PHI2(2,2),PHIP2(2,2),PHI2D(2,2),PHIDH(2,2)

      DIMENSION O(2,2),OMIN(2,2),U1(2),U2(2)

      DATA AI/1.D0,0.D0,0.D0,0.D0,1.D0,0.D0,0.D0,0.D0,1.D0/

      DATA EPS/1.D-16/,PHI2D/4*0.D0/,PHIDH/4*0.D0/

c     DATA PHIH/5.D0/,PHIL/ 0.2D0/,DPHIH/10.D0/,DPHIL/-10.D0/

      DATA PHIH/5.D0/,PHIL/ 1.0D0/,DPHIH/10.D0/,DPHIL/-10.D0/



c     PRINT 51, XA

c 51  FORMAT(72('*'),/,'  ENTERING GRNTST : XA=',F10.3)

c     DO 2000 I=1,3

c2000 PRINT 2001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3)

c2001 FORMAT(/,'  GRNTST PHI=',3(D9.3,1X),'  PHIP=',3(D9.3,1X))

C

      DO 1 I=1,2

      DO 1 J=1,2   

      PHI2(I,J) = PHI(I,J)

c     PHIP2(I,J) = PHIP(I,J)

    1 CONTINUE

C

C     DIAGONALIZATION PHI2:

C

      A = PHI(1,1)

      D = PHI(2,2)

      C = PHI(1,2)

C

C     DECOMPOSITION PHI2-MATRIX: (A+D)/2 + C \SIGMAX + (A-D)/2 \SIGMA3

C                               =(A+D)/2 + ROOT*\SIGMA\CDOT\NVECTOR

C

      ROOT = DSQRT(C**2+0.25D0*(A-D)**2)

      IF(ROOT.LT.EPS) RETURN



      IF(C.NE.0.D0) THEN

C     

C     EIGENVALUES:                

C

      ALMD1 = 0.5D0*(A+D)+ROOT

      ALMD2 = 0.5D0*(A+D)-ROOT



      ENX= C/ROOT

      ENZ= 0.5D0*(A-D)/ROOT

C     EIGENVECTORS: 

      ROOTP = 1.D0/DSQRT(2*(1.D0+ENZ))

      U1(1) = (1.D0+ENZ)*ROOTP

      U1(2) = ENX*ROOTP

      ROOTM = 1.D0/DSQRT(2*(1.D0-ENZ))

      U2(1) = (1.D0-ENZ)*ROOTM

      U2(2) = -ENX*ROOTM

C     

C     DIAGONALIZING TRANSFORMATION:

C

      DO 2 J=1,2

      O(1,J) = U1(J)

      O(2,J) = U2(J)

      OMIN(J,1)= U1(J)

      OMIN(J,2)= U2(J)

    2 CONTINUE

      ENDIF



      IF(C.EQ.0.D0) THEN

      ALMD1 = A

      ALMD2 = D

      DO 20 I=1,2

      DO 20 J=1,2

      O(I,J) = AI(I,J)

      OMIN(I,J)= AI(I,J)

   20 CONTINUE

      ENDIF



      DETPH2=ALMD1*ALMD2

      DETPHI=DETPH2*PHI(3,3)

c     PRINT 3001, ALMD1,ALMD2

c3001 FORMAT(/,'  GRNTST EIGENVALUES: ALMD1=',D9.3,' ALMD2=',D9.3,/)

c     PRINT 3002, DETPH2,DETPHI

c3002 FORMAT(/,'  GRNTST DETERMINANT: DETPH2=',D9.3,' DETPHI=',D9.3,/)

c     DO 3000 I=1,2

c3000 PRINT 3003, (O(I,J),J=1,2),(OMIN(I,J),J=1,2)

c3003 FORMAT(/,' GRNTST O  =',2(D9.3,1X),'  OMIN=',2(D9.3,1X))



C     TEST EIGENVALUES BEFORE GREEN TRANSFORMATION:

      ITEST = 0

      IF(IRET.EQ.0) THEN

      IF(ALMD1.GT.PHIH) ALMD1=PHIH

      IF(ALMD2.GT.PHIH) ALMD2=PHIH

      ENDIF

      IF(ALMD1.LT.PHIL) ALMD1=PHIL

      IF(ALMD2.LT.PHIL) ALMD2=PHIL

      IF(ALMD1.EQ.PHIH.OR.ALMD1.EQ.PHIL) ITEST=1

      IF(ALMD2.EQ.PHIH.OR.ALMD2.EQ.PHIL) ITEST=1

      IF(ITEST.EQ.0) GOTO 7000 



      PHI2D(1,1) = ALMD1

      PHI2D(2,2) = ALMD2



C     CHECK: PHI2D = PHIDH

      DO 3 I=1,2

      DO 3 J=1,2

      PHIDH(I,J) = 0.D0

      DO 4 K=1,2

      DO 4 L=1,2

    4 PHIDH(I,J) = PHIDH(I,J) + O(I,K)*PHI2(K,L)*OMIN(L,J)

    3 CONTINUE

c     DO 4000 I=1,2

c4000 PRINT 4001, (PHI2D(I,J),J=1,2),(PHIDH(I,J),J=1,2)

c4001 FORMAT(/,'  GRNTST PHI2D=',2(D9.3,1X),'  PHIDH=',2(D9.3,1X))

C

C     BACK TRANSFORMATION:

C

      DO 5 I=1,2

      DO 5 J=1,2

      PHI2(I,J) = 0.D0

      DO 6 K=1,2

      DO 6 L=1,2

    6 PHI2(I,J) = PHI2(I,J) + OMIN(I,K)*PHI2D(K,L)*O(L,J)

      PHI (I,J) = PHI2(I,J)

    5 CONTINUE



 7000 IF(PHI(3,3).GT.PHIH) PHI(3,3)=PHIH

      IF(PHI(3,3).LT.PHIL) PHI(3,3)=PHIL

      IF(PHI(3,3).EQ.PHIH.OR.PHI(3,3).EQ.PHIL) ITEST=1

      IF(ITEST.EQ.0) RETURN

      DO 7 I=1,2

      DO 7 J=1,2

    7 PHI(I,J) = PHI2(I,J)



c5010 DO 5000 I=1,3

c5000 PRINT 5001, (PHI(I,J),J=1,3),(PHIP(I,J),J=1,3)

c5001 FORMAT(/,'  GRNTST PHI=',3(D9.3,1X),'  PHIP=',3(D9.3,1X))



c     PRINT 62

c 62  FORMAT('  LEAVING GRNTST . ')

      RETURN

      END

c *******************************************************************

      subroutine intpol3(xcall,i,nmax,xa,grpot,cnpot)

c *******************************************************************

      implicit real*8(a-h,o-z)

      dimension xa(300),grpot(3,3,3),tm(2,2),fun(2)

      dimension cnpot(3,3)

      data method/2/,nch/3/



      x = xcall

      if(xcall.eq.xa(nmax)) x=xa(nmax-2)

      if(x.lt.xa(1).or.x.gt.xa(nmax)) then

      write(*,*) ' x-value out of range for Green transf. !!'

      return

      endif



      do 15 ll=1,nch

      do 15 kk=1,ll 



c *******************************************************************

c     two-point interpolation: f=ay+b

      if(method.eq.1) then

      cnpot(kk,ll) = grpot(kk,ll,1) + (x-xa(i))*

     .                 (grpot(kk,ll,2)-grpot(kk,ll,1))/

     .                 (xa(i+1)-xa(i))

      endif

c *******************************************************************

c     three-point interpolation: f=ay**2+by+c

      if(method.eq.2) then

      cc = grpot(kk,ll,1)

      y2 = xa(i+2)-xa(i)

      y1 = xa(i+1)-xa(i)

      det = (y2-y1)*y1*y2

      tm(1,1) = y1/det

      tm(2,2) = y2**2/det

      tm(1,2) = -y2/det

      tm(2,1) = -y1**2/det

      fun(1) = grpot(kk,ll,3)-cc

      fun(2) = grpot(kk,ll,2)-cc

      aa=0.d0

      bb=0.d0

      do 21 kkk=1,2

      aa = aa + tm(1,kkk)*fun(kkk)

      bb = bb + tm(2,kkk)*fun(kkk)

   21 continue

      y = x-xa(i)

      cnpot(kk,ll) = aa*y**2+bb*y+cc              

      endif

c *******************************************************************



   15 continue



      do 25 kk=1,nch

      do 25 ll=1,kk  

      if(kk.ne.ll) 

     .cnpot(kk,ll) = cnpot(ll,kk)

   25 continue

      return

      end









**********************************************************************

C     UPDATED VERSION 2012:

C     AXIAL gecorrigeerd -> +2*GFALL*GFAC1*FTLL0 etc. (NOV 2012)

C---------------------------------------------------------------------

C     UPDATED VERSION: AUGUST 2011, SEE AXIAL AND AXIALU

C     UPDATED VERSION: NOVEMBER 2010: SECOND DERIVATIVES FI, FIS FUNCTIONS!

C     VERSION: JUNE 2009: A LA LPPROGS.02/HVYPOT.YN09.f

C     CHANGES W.R.T. PREVIOUS VERSION: SEE ROUTINE AXIAL!

**********************************************************************

      BLOCK DATA HAMS

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4)



      DATA HAMPS/1300.D0,1280.D0,1430.D0,1460.D0/

      DATA HAMVC/1450.D0,1420.D0,1680.D0,1410.D0/

      DATA HAMSC/1450.D0,1370.D0,1580.D0,1430.D0/



      END 

**********************************************************************

C

c*    SUBROUTINE PSSCA2(NMAX,NLOC,ICSB,P)

      SUBROUTINE PSSCA2(XA,ICSB,NLOC,P,PX)

C

C**********************************************************************



C

C     HEAVY PS-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

c*    COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF

      COMMON/HVY/HF(11),GT(11),FT(11),FD(11),FV(11)

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c*    COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL   ,VCSS   ,VCLS   ,VCDR ,

     .            VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR ,

     .            VTENLL ,VTENSS ,VTENLS ,VTENDR ,

     .            VSOLL  ,VSOSS  ,VSOLS  ,VSODR ,

     .            VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR ,

     .            VASOLL ,VASOSS ,VASOLS ,VASODR ,

     .            VNNC   ,VNNSIG ,VNNTEN ,VNNSO  ,

     .            FILL   ,FISS   ,FILS   ,FIDR ,

     .            DFILL  ,DFISS  ,DFILS  ,DFIDR ,

     .            FISLL  ,FISSS  ,FISLS  ,FISDR ,

     .            DFISLL ,DFISSS ,DFISLS ,DFISDR,

     .            FITLL  ,FITSS  ,FITLS  ,FITDR ,

     .            DFITLL ,DFITSS ,DFITLS ,DFITDR 

      DIMENSION AMPS(5)

      DATA AMP2,AME2,AMX2,AMK2/1300.D0,1280.D0,1430.D0,1460.D0/

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,ICALL/0/

C

C   NOTE : PION2(IN=1),ETA2 (IN=2),ETAP2(IN=3),KAON2(IN=4)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C

C

      IF(ICALL.EQ.0.AND.NSU3F.EQ.1) THEN

      AME2 = AMP2

      AMX2 = AMP2

      AMK2 = AMP2

      ICALL= 1

      ENDIF

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GPLL = 0.D0                                    

      GPSS= -2. *HF(1)*HF(2)*(AMP2/PIM)**2

      GPLS= -SR3*HF(1)*HF(3)*(AMP2/PIM)**2

      GPDR=      HF(1)*HF(2)*(AMP2/PIM)**2

      AMPS(1)=AMP2

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1052  GPLL=  HF(6)*HF(7)*(AME2/PIM)**2

      GPSS=  HF(6)*HF(8)*(AME2/PIM)**2

      GPLS=  0.

      GPDR=  HF(6)*HF(8)*(AME2/PIM)**2

      AMPS(2)=AME2

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1053  GPLL=  HF(9)*HF(10)*(AMX2/PIM)**2

      GPSS=  HF(9)*HF(11)*(AMX2/PIM)**2

      GPLS=  0.

      GPDR=  HF(9)*HF(11)*(AMX2/PIM)**2

      AMPS(3)=AMX2

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP1

      GOTO 1056

1054  GPLL=      HF(4)*HF(4)*P*(AMK2/PIM)**2

      GPSS=     -HF(5)*HF(5)*P*(AMK2/PIM)**2

      GPLS= -SR3*HF(4)*HF(5)*P*(AMK2/PIM)**2

      GPDR=    2*HF(5)*HF(5)*P*(AMK2/PIM)**2

      AMPS(4)=AMK2

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMKA

      GOTO 1056

C

1056  ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

      RATM1=AMPS(IN)/ALM1

      RATM2=AMPS(IN)/ALM2

      RATM3=AMPS(IN)/ALM3

      FAC1=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(1))

      FAC2=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(2))

      FAC3=AMPS(IN)*AMPS(IN)/(AM(1)*AMH)

C

c*    DO 104 I=2,NMAX

c*    X = XA(I)

      X = XA

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMPS(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMPS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMPS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMPS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN)

      FTENLL = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN)

      FSOLL  = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN)

C



      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN)

      FTENSS = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS(IN)

      FSOSS  = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS(IN)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN)

      FTENLS = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS(IN)

      FSOLS  = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS(IN)

C

      FCLL1  = FCLL0  - VKULL*AMPS(IN)

      FCSS1  = FCSS0  - VKUSS*AMPS(IN)

      FCLS1  = FCLS0  - VKULS*AMPS(IN)

C

        VSIGLL   = VSIGLL  + GPLL*FCLL1/3.D0

        VTENLL   = VTENLL  + GPLL*FTENLL

        VSIGDR   = VSIGDR  + GPDR*FCSS1/3.D0

        VTENDR   = VTENDR  + GPDR*FTENSS

        VSIGSS   = VSIGSS  + GPSS*FCSS1/3.D0

        VTENSS   = VTENSS  + GPSS*FTENSS

        VSIGLS   = VSIGLS  + GPLS*FCLS1/3.D0

        VTENLS   = VTENLS  + GPLS*FTENLS

C------------------------------------------------------------

C     BROWN, DOWNS AND IDDINGS TERMS:

C     HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.4) THEN

c      PX = -1D0

        VASOLL  = VASOLL - PX*GPLL*FSOLL*

     .               4*(AMY(1)-AM(1))/(AMY(1)+AM(1))

        VASOSS  = VASOSS - PX*GPSS*FSOSS*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

        VASOLS  = VASOLS - PX*GPLS*FSOLS*

     .               4*(AMY(3)-AM(3))/(AMY(3)+AM(3))

        VASODR  = VASODR - PX*GPDR*FSODR*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

      ENDIF

C

  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END

C**********************************************************************

C

**    SUBROUTINE VECTOR2(NMAX,NLOC,ICSB,P)

      SUBROUTINE VECTOR2(XA,ICSB,NLOC,P,PX)

C

C**********************************************************************

C

C     HEAVY VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

c*    COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF

      COMMON/HVY/HFPS(11),GT(11),FT(11),FD(11),FV(11)

      COMMON/HVYAMS/HAMPS(4),HAMVC(4),HAMSC(4)

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c*    COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL   ,VCSS   ,VCLS   ,VCDR ,

     .            VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR ,

     .            VTENLL ,VTENSS ,VTENLS ,VTENDR ,

     .            VSOLL  ,VSOSS  ,VSOLS  ,VSODR ,

     .            VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR ,

     .            VASOLL ,VASOSS ,VASOLS ,VASODR ,

     .            VNNC   ,VNNSIG ,VNNTEN ,VNNSO  ,

     .            FILL   ,FISS   ,FILS   ,FIDR ,

     .            DFILL  ,DFISS  ,DFILS  ,DFIDR ,

     .            FISLL  ,FISSS  ,FISLS  ,FISDR ,

     .            DFISLL ,DFISSS ,DFISLS ,DFISDR,

     .            FITLL  ,FITSS  ,FITLS  ,FITDR ,

     .            DFITLL ,DFITSS ,DFITLS ,DFITDR 

      DIMENSION AMVC(4),FVC(4),XM1(3),XM2(3)

c     DATA AMVC/1450.D0,1420.D0,1680.D0,1410.D0/

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/

     .    ,FMNL/1.D0/,ICALL/0/

C

C   NOTE : RHO'(IN=1),OME'(IN=2),PHI'(IN=3),KSTAR'(IN=4)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

C

      IF(ICALL.EQ.0.AND.NSU3F.EQ.1) THEN

      HAMVC(2)= HAMVC(1)

      HAMVC(3)= HAMVC(1)

      HAMVC(4)= HAMVC(1)

      ICALL= 1

      ENDIF

c*    AMKS = AMVC(4)

      AMKS = HAMVC(4)

      PROSLL=-(AM(1)-AMY(1))*(AMY(1)-AM(1))/AMKS/AMKS

      PROSLS=-(AM(1)-AMY(1))*(AMY(2)-AM(1))/AMKS/AMKS

      PROSSS=-(AM(1)-AMY(2))*(AMY(2)-AM(1))/AMKS/AMKS

C

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GDLL = 0.D0                    

      GDFLL= 0.D0                    

      GFDLL= 0.D0                   

      GFLL = 0.D0                  

      GDSS = -2*FD(1)*FD(2)

      GDFSS= -2*FD(1)*FV(2)

      GFDSS= -2*FV(1)*FD(2)

      GFSS = -2*FV(1)*FV(2)

      GDLS = -FD(1)*FD(3)*SR3

      GDFLS= -FD(1)*FV(3)*SR3

      GFDLS= -FV(1)*FD(3)*SR3

      GFLS = -FV(1)*FV(3)*SR3

      GDDR =  FD(1)*FD(2)

      GDFDR=  FD(1)*FV(2)

      GFDDR=  FV(1)*FD(2)

      GFDR =  FV(1)*FV(2)

      AMVC(1) = HAMVC(1)

      IF(IN.EQ.1) THEN

      XM1(1)=AM(1)

      XM1(2)=AM(1)

      XM1(3)=AM(1)

      XM2(1)=AMY(1)

      XM2(2)=AMY(2)

      XM2(3)=AMH

      ENDIF

      GOTO 1056

1052  GDLL =  FD(6)*FD(7)

      GDFLL=  FD(6)*FV(7)

      GFDLL=  FV(6)*FD(7)

      GFLL =  FV(6)*FV(7)

      GDSS =  FD(6)*FD(8)

      GDFSS=  FD(6)*FV(8)

      GFDSS=  FV(6)*FD(8)

      GFSS =  FV(6)*FV(8)

      GDLS =  0.D0

      GDFLS=  0.D0

      GFDLS=  0.D0

      GFLS =  0.D0

      GDDR =  GDSS

      GDFDR=  GDFSS

      GFDDR=  GFDSS

      GFDR =  GFSS

      AMVC(2) = HAMVC(2)

      GOTO 1056

1053  GDLL =  FD(9)*FD(10)

      GDFLL=  FD(9)*FV(10)

      GFDLL=  FV(9)*FD(10)

      GFLL =  FV(9)*FV(10)

      GDSS =  FD(9)*FD(11)

      GDFSS=  FD(9)*FV(11)

      GFDSS=  FV(9)*FD(11)

      GFSS =  FV(9)*FV(11)

      GDLS =  0.D0

      GDFLS=  0.D0

      GFDLS=  0.D0

      GFLS =  0.D0

      GDDR =  GDSS

      GDFDR=  GDFSS

      GFDDR=  GFDSS

      GFDR =  GFSS

      AMVC(3) = HAMVC(3)

      GOTO 1056

1054  GDLL =  FD(4)*FD(4)*P

      GDFLL=  FD(4)*FV(4)*P

      GFDLL=  FV(4)*FD(4)*P

      GFLL =  FV(4)*FV(4)*P

      GDSS = -FD(5)*FD(5)*P

      GDFSS= -FD(5)*FV(5)*P

      GFDSS= -FV(5)*FD(5)*P

      GFSS = -FV(5)*FV(5)*P

      GDLS = -FD(4)*FD(5)*P*SR3

      GDFLS= -FD(4)*FV(5)*P*SR3

      GFDLS= -FV(4)*FD(5)*P*SR3

      GFLS = -FV(4)*FV(5)*P*SR3

      GDDR = -2*GDSS

      GDFDR= -2*GDFSS

      GFDDR= -2*GFDSS

      GFDR = -2*GFSS

      AMVC(4) = HAMVC(4)

C     CASE IN=4:

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMLS

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMLS

C

1056  FVC(IN) = 1.D0

      IF(IMODEL.EQ.1) ALAM=ALMOBE

      IF(IMODEL.GE.2) THEN

       ALAM = ALMV8

       IF(IN.EQ.3) ALAM=ALMV1

       IF(IN.EQ.4) ALAM=ALMKS

      ENDIF

      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM



      RATM1=AMVC(IN)/ALM1

      RATM2=AMVC(IN)/ALM2

      RATM3=AMVC(IN)/ALM3

      FAC0=AMVC(IN)*AMVC(IN)/AMPRO/AMPRO

      FAC1=AMVC(IN)*AMVC(IN)/(XM1(1)*XM2(1))

      FAC2=AMVC(IN)*AMVC(IN)/(XM1(2)*XM2(2))

      FAC3=AMVC(IN)*AMVC(IN)/(XM1(3)*XM2(3))

      FFAC1 = XM2(1)/XM1(1)-XM1(1)/XM2(1)                 

      FFAC2 = XM2(2)/XM1(2)-XM1(2)/XM2(2)                 

      FFAC3 = XM2(3)/XM1(3)-XM1(3)/XM2(3)                 

      AMVC2 = AMVC(IN)**2

C

      CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM1(1)+GDFLL/XM2(1))*AMVC(IN)**2

     .      /(4.*AMPRO)

      CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM1(2)+GDFSS/XM2(2))*AMVC(IN)**2

     .      /(4.*AMPRO)

      CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM1(3)+GDFLS/XM2(3))*AMVC(IN)**2

     .      /(4.*AMPRO)

      CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM1(2)+GDFDR/XM2(2))*AMVC(IN)**2

     .      /(4.*AMPRO)

      CSLL1= GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1)+GFLL*XM1(1)*XM2(1)/AMPRO)

     .       /AMPRO

      CSSS1= GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2)+GFSS*XM1(2)*XM2(2)/AMPRO)

     .       /AMPRO

      CSLS1= GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3)+GFLS*XM1(3)*XM2(3)/AMPRO)

     .       /AMPRO

      CSDR1= GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2)+GFDR*XM1(2)*XM2(2)/AMPRO)

     .       /AMPRO

      CTLL0= CSLL1

      CTSS0= CSSS1

      CTLS0= CSLS1

      CTDR0= CSDR1

      COLL0= 1.5D0*GDLL+(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO

      COSS0= 1.5D0*GDSS+(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO

      COLS0= 1.5D0*GDLS+(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO

      CODR0= 1.5D0*GDDR+(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO



      CALL0= 

     .GDLL*FFAC1/4D0-(GFDLL-GDFLL)*DSQRT(XM1(1)*XM2(1))/AMPRO

      CASS0= 

     .GDSS*FFAC2/4D0-(GFDSS-GDFSS)*DSQRT(XM1(2)*XM2(2))/AMPRO

      CALS0= 

     .GDLS*FFAC3/4D0-(GFDLS-GDFLS)*DSQRT(XM1(3)*XM2(3))/AMPRO

      CADR0= 

     .GDDR*FFAC2/4D0-(GFDDR-GDFDR)*DSQRT(XM1(2)*XM2(2))/AMPRO

      CALL1= GFLL*FFAC1*AMVC2/(16*AMPRO*AMPRO)

      CASS1= GFSS*FFAC2*AMVC2/(16*AMPRO*AMPRO)

      CALS1= GFLS*FFAC3*AMVC2/(16*AMPRO*AMPRO)

      CADR1= GFDR*FFAC2*AMVC2/(16*AMPRO*AMPRO)



C     BROWN, DOWNS AND IDDINGS TERM:

C     HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.5) THEN

c      PX = -1D0

      CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2*

     .       (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1))

      CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2*

     .       (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3))

      CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      ENDIF



      CO2LL= GDLL+4*(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO +

     +       8*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO

      CO2SS= GDSS+4*(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO +

     +       8*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO

      CO2LS= GDLS+4*(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO +

     +       8*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO

      CO2DR= GDDR+4*(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO +

     +       8*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO

C

**    DO 104 I=2,NMAX

**    X = XA(I)

      X = XA   

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMVC(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMVC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMVC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMVC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENLL = FVC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOLL  = FVC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2LL = 3*FTENLL/(X*X)

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENSS = FVC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOSS  = FVC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2SS = 3*FTENLL/(X*X)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENLS = FVC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOLS  = FVC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2LS = 3*FTENLL/(X*X)

C

      FCLL1  = FCLL0  - FVC(IN)*VKULL*AMVC(IN)

      FCSS1  = FCSS0  - FVC(IN)*VKUSS*AMVC(IN)

      FCLS1  = FCLS0  - FVC(IN)*VKULS*AMVC(IN)

      FCLL2  = FCLL1+

     .         FVC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMVC(IN)/RATM1/RATM1

      FCSS2  = FCSS1+

     .         FVC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMVC(IN)/RATM2/RATM2

      FCLS2  = FCLS1+

     .         FVC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMVC(IN)/RATM3/RATM3

      FTLL1  = FTENLL - FVC(IN)*XLAM1*XLAM1*VKULL*AMVC(IN)

     .                / (3*RATM1*RATM1)

      FTSS1  = FTENSS - FVC(IN)*XLAM2*XLAM2*VKUSS*AMVC(IN)

     .                / (3*RATM2*RATM2)

      FTLS1  = FTENLS - FVC(IN)*XLAM3*XLAM3*VKULS*AMVC(IN)

     .                / (3*RATM3*RATM3)

      FOLL1  = FSOLL  - FVC(IN)*VKULL*AMVC(IN)

     .                / (2*RATM1*RATM1)

      FOSS1  = FSOSS  - FVC(IN)*VKUSS*AMVC(IN)

     .                / (2*RATM2*RATM2)

      FOLS1  = FSOLS  - FVC(IN)*VKULS*AMVC(IN)

     .                / (2*RATM3*RATM3)

C

      VCLL   = VCLL    + GDLL*FCLL0 + CCLL1*FCLL1 +

     .                       GFLL*FAC0*FAC1*FCLL2/16.D0

     .                     + (1-INRS)*FAC1*(GDLL*FAC1/64.D0+(GDFLL

     .                       +GFDLL)*DSQRT(FAC0*FAC1)/16.D0)*FCLL2

      VCSS   = VCSS    + GDSS*FCSS0 + CCSS1*FCSS1 +

     .                       GFSS*FAC0*FAC2*FCSS2/16.D0

     .                     + (1-INRS)*FAC2*(GDSS*FAC2/64.D0+(GDFSS

     .                       +GFDSS)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2

      VCLS   = VCLS    + GDLS*FCLS0 + CCLS1*FCLS1 +

     .                       GFLS*FAC0*FAC3*FCLS2/16.D0

     .                     + (1-INRS)*FAC3*(GDLS*FAC3/64.D0+(GDFLS

     .                       +GFDLS)*DSQRT(FAC0*FAC3)/16.D0)*FCLS2

      VCDR   = VCDR    + GDDR*FCSS0 + CCDR1*FCSS1 +

     .                       GFDR*FAC0*FAC2*FCSS2/16.D0

     .                     + (1-INRS)*FAC2*(GDDR*FAC2/64.D0+(GDFDR

     .                       +GFDDR)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2

C

      VSIGLL = VSIGLL  + (CSLL1*FCLL1 + INRS*GFLL*FAC0*FCLL2/8.D0)

     .                     * FAC1/6.D0

      VSIGSS = VSIGSS  + (CSSS1*FCSS1 + INRS*GFSS*FAC0*FCSS2/8.D0)

     .                     * FAC2/6.D0

      VSIGLS = VSIGLS  + (CSLS1*FCLS1 + INRS*GFLS*FAC0*FCLS2/8.D0)

     .                     * FAC3/6.D0

      VSIGDR = VSIGDR  + (CSDR1*FCSS1 + INRS*GFDR*FAC0*FCSS2/8.D0)

     .                     * FAC2/6.D0

C

      VTENLL = VTENLL  - (CTLL0*FTENLL + INRS*GFLL*FAC0*FTLL1/8.D0)

     .                     * FAC1/4.D0

      VTENSS = VTENSS  - (CTSS0*FTENSS + INRS*GFSS*FAC0*FTSS1/8.D0)

     .                     * FAC2/4.D0

      VTENLS = VTENLS  - (CTLS0*FTENLS + INRS*GFLS*FAC0*FTSS1/8.D0)

     .                     * FAC3/4.D0

      VTENDR = VTENDR  - (CTDR0*FTENSS + INRS*GFDR*FAC0*FTSS1/8.D0)

     .                     * FAC2/4.D0

C

      VSOLL  = VSOLL   - (COLL0*FSOLL + GFLL*FAC0*FOLL1*3/8.D0)

     .                     * FAC1

      VSOSS  = VSOSS   - (COSS0*FSOSS + GFSS*FAC0*FOSS1*3/8.D0)

     .                     * FAC2

      VSOLS  = VSOLS   - (COLS0*FSOLS + GFLS*FAC0*FOLS1*3/8.D0)

     .                     * FAC3

      VSODR  = VSODR   - (CODR0*FSOSS + GFDR*FAC0*FOSS1*3/8.D0)

     .                     * FAC2

C

      VASOLL= VASOLL - (CALL0*FSOLL-CALL1*FOLL1)*FAC1

      VASOSS= VASOSS - (CASS0*FSOSS-CASS1*FOSS1)*FAC2

      VASOLS= VASOLS - (CALS0*FSOLS-CALS1*FOLS1)*FAC3

      VASODR= VASODR - (CADR0*FSOSS-CADR1*FOSS1)*FAC2

C

      VSO2LL = VSO2LL  + CO2LL*FSO2LL*FAC1*FAC1/16.D0

      VSO2SS = VSO2SS  + CO2SS*FSO2SS*FAC2*FAC2/16.D0

      VSO2LS = VSO2LS  + CO2LS*FSO2LS*FAC3*FAC3/16.D0

      VSO2DR = VSO2DR  + CO2DR*FSO2SS*FAC2*FAC2/16.D0

      IF(IN.NE.4) GOTO 105

C

C     K-STAR : CONTRIBUTION SECOND TERM IN VECTOR MESON PROPAGATOR

C

      VCLL  = VCLL  - GDLL*PROSLL*FCLL0*(1.D0-FAC1/4.D0)

      VCSS  = VCSS  - GDSS*PROSSS*FCSS0*(1.D0-FAC2/4.D0)

      VCLS  = VCLS  - GDLS*PROSLS*FCLS0*(1.D0-FAC3/4.D0)

      VCDR  = VCDR  - GDDR*PROSSS*FCSS0*(1.D0-FAC2/4.D0)

C

      VSOLL  = VSOLL  - GDLL*PROSLL*FSOLL*FAC1/2.D0

      VSOSS  = VSOSS  - GDSS*PROSSS*FSOSS*FAC2/2.D0

      VSOLS  = VSOLS  - GDLS*PROSLS*FSOLS*FAC3/2.D0

      VSODR  = VSODR  - GDDR*PROSSS*FSOSS*FAC2/2.D0

C    

      VASOLL  = VASOLL - GDLL*PROSLL*FSOLL*FFAC1*FAC1/4.D0   

      VASOSS  = VASOSS - GDSS*PROSSS*FSOSS*FFAC2*FAC2/4.D0   

      VASOLS  = VASOLS - GDLS*PROSLS*FSOLS*FFAC3*FAC3/4.D0   

      VASODR  = VASODR - GDDR*PROSSS*FSOSS*FFAC2*FAC2/4.D0   

C

      VSO2LL  = VSO2LL  - GDLL*PROSLL*FSO2LL*FAC1*FAC1/16.D0

      VSO2SS  = VSO2SS  - GDSS*PROSSS*FSO2SS*FAC2*FAC2/16.D0

      VSO2LS  = VSO2LS  - GDLS*PROSLS*FSO2LS*FAC3*FAC3/16.D0

      VSO2DR  = VSO2DR  - GDDR*PROSSS*FSO2SS*FAC2*FAC2/16.D0

C

105   IF(NLOC.EQ.0) GOTO 104

      FILL   = FILL    + 1.5D0*REDMM*GDLL*FCLL0/(XM1(1)*XM2(1))

      FISS   = FISS    + 1.5D0*REDMM*GDSS*FCSS0/(XM1(2)*XM2(2))

      FILS   = FILS    + 1.5D0*REDMM*GDLS*FCLS0/(XM1(3)*XM2(3))

      FIDR   = FIDR    + 1.5D0*REDMM*GDDR*FCSS0/(XM1(2)*XM2(2))

C

      DFILL =DFILL -1.5D0*REDMM*GDLL*FSOLL*X*FAC1/AMVC(IN)

      DFISS =DFISS -1.5D0*REDMM*GDSS*FSOSS*X*FAC2/AMVC(IN)

      DFILS =DFILS -1.5D0*REDMM*GDLS*FSOLS*X*FAC3/AMVC(IN)

      DFIDR =DFIDR -1.5D0*REDMM*GDDR*FSOSS*X*FAC2/AMVC(IN)

C

  104 CONTINUE

C

c     print spin-orbit potentials:

*     write(*,*) ' VECTOR2: x=',xa,' IN=',in,' vsoll=',vsoll,

*    .' vasoll=',vasoll

 1040 CONTINUE

C

      RETURN

      END



c---------------------------------------------------------------------

c version: november 2012:

C**********************************************************************

**    SUBROUTINE AXIAL(NMAX,NLOC,ICSB,P)

      SUBROUTINE AXIAL(XA,ICSB,NLOC,LC,P,PX)

C

C**********************************************************************

C     VERSION JUNE 2009:  

C     1) WITH CORRECT B-FIELD FORMALISM POTENTIALS!!

C     2) WITH RKS91-TREATMENT QUADRATIC-SPIN-ORBIT

C     3) DIRECT (FA) AND DERIVATIVE (FFA) COUPLINGS

C     4) THREE OPTIONS: IBLFD=1: LTA-METHOD

C                       IBFLD=2: OM-METHOD,  IBFLD=3: NLT-METHOD

C**********************************************************************

C     DIRECT (FA) AND DERIVATIVE (FFA) COUPLINGS

C**********************************************************************

C

C     AXIAL MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

C------------------------------------------------------------------------

C     IN MOMENTUM SPACE AXIAL-EXCHANGE:                         

C------------------------------------------------------------------------

C

C     FIRST TERM PROPAGATOR:

C     1. LOCAL-TENSOR-APPROXIMATION (LTA):

C     V_A^(1) = -GA2*[[(1+(Q2+K2/4)/(6M'M)](SIGMA1.SIGMA2)+

C                     +(2/M'M)[(SIGMA1.Q)(SIGMA2.Q)-Q2(SIGMA1.SIGMA2)/3]

C                     -(1/4M'M)[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3]

C                     +(i/4M'M)(SIGMA1+SIGMA2).QXK ]]/(K2+MA2)

C------------------------------------------------------------------------

C     2. USED OKUBO-MARSHAK IDENTITY TO ELIMINATE (SIGMA1.Q)(SIGMA2.Q)-TERM:   

C     V_A^(1) => -GA2*[ {1-K2/(6M'M)+5(Q2+K2/4)/(6M'M)}(SIGMA1.SIGMA2)+

C     -(1/4M'M){-1+8(Q2+K2/4)}[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3]

C     +(i/4M'M)(SIGMA1+SIGMA2).QXK -2/(M'M)(SIGMA1.QxK)(SIGMA2.QxK)/K2 ]

C     /(K2+MA2)

C------------------------------------------------------------------------

C     3. NLT-METHOD RKS91 FOR EVALUATION OF (SIGMA1.Q)(SIGMA2.Q)-TERM:   

C     V_A^(1) => -GA2*[ {1-2K2/(3M'M)+3(Q2+K2/4)/(2M'M)}(SIGMA1.SIGMA2)+

C     +(1/4M'M){-1+8(Q2+K2/4)}[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3]

C     +(i/4M'M)(SIGMA1+SIGMA2).QXK -2/(M'M)(SIGMA1.QxK)(SIGMA2.QxK)/K2 ]

C     /(K2+MA2)

C     -GA2*[(2/M'M){[SIGMA1.QXK][SIGMA2.QXK].H(K2)-V(K,Q)}]

C**********************************************************************

C

C   NOTE : A1(1270)(IN=1),D=F1(1285)(IN=2),E=F1(1420)(IN=3)

C

C   COUPLING: A LA CHIRAL LAGR., SEE STOKS & RIJKEN (NUCL.PHYS. A613 (1997))    

C

C   PROPAGATOR OPTIONS: A) PROCA,IBFLD=0, B) B-FIELD FORMALISM, IBFLD=1,2,3

C----------------------------------------------------------------------

C   IN THIS VERSION PROCA-PROPAGATOR NOT INCLUDED -> ONLY IBFLD=1,2,3 !!

C**********************************************************************

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX                           

      COMMON/AMSAX/AMA1,AMD1,AME1,AMK1

      COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

*     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL   ,VCSS   ,VCLS   ,VCDR   ,

     .            VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR ,

     .            VTENLL ,VTENSS ,VTENLS ,VTENDR ,

     .            VSOLL  ,VSOSS  ,VSOLS  ,VSODR  ,

     .            VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR ,

     .            VASOLL ,VASOSS ,VASOLS ,VASODR ,

     .            VNNC   ,VNNSIG ,VNNTEN ,VNNSO  ,

     .            FILL   ,FISS   ,FILS   ,FIDR   ,

     .            DFILL  ,DFISS  ,DFILS  ,DFIDR  ,

     .            FISLL  ,FISSS  ,FISLS  ,FISDR  ,

     .            DFISLL ,DFISSS ,DFISLS ,DFISDR ,

     .            FITLL  ,FITSS  ,FITLS  ,FITDR ,

     .            DFITLL ,DFITSS ,DFITLS ,DFITDR 

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS, DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS, DDFSDR 

      DIMENSION AMAX(4)

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/

c     DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1273.D0/   !11-version

      DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1400.D0/   !16-version

      DATA IBFLD/3/,ICALL/0/,FZERO/0.D0/,AMCRA/750.D0/

      DATA CFSIG/0.D0/,CFTEN/0.D0/,CFFIS/0.D0/

      DATA NS/0/

C ------------------------------------------------------------------

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C ------------------------------------------------------------------

C

      IF(ICALL.EQ.0) THEN

      IF(IBFLD.EQ.1.and.NS.NE.0)

     .WRITE(*,*) ' AXIALYN.NLT: LTA-TREATMENT, IBFLD=',IBFLD

      IF(IBFLD.EQ.2.and.NS.NE.0)

     .WRITE(*,*) ' AXIALYN.NLT: OM-TREATMENT, IBFLD=',IBFLD

      IF(IBFLD.EQ.3.and.NS.NE.0)

     .WRITE(*,*) ' AXIALYN.NLT: NLT-TREATMENT, IBFLD=',IBFLD

c     WRITE(*,*) ' AXIALYN.NLT: IGRAZ=',IGRAZ                   



      IF(IBFLD.LE.1) THEN

      CFSIG= 1.D0

      CFTEN=-0.75D0    

      CFFIS= 1.D0      

      ENDIF

      IF(IBFLD.EQ.2) THEN

      CFSIG= 1.D0

      CFTEN=+0.25D0    

      CFFIS= 5.D0      

      ENDIF

      IF(IBFLD.EQ.3) THEN

      CFSIG= 4.D0

      CFTEN=+0.25D0    

      CFFIS= 9.D0      

      ENDIF

C ---------------------------------------------------------------------

      IF(NSU3F.EQ.1) THEN

      AMD1 = AMA1

      AME1 = AMA1

      AMK1 = AMA1

      ENDIF

      ICALL=1

      ENDIF

C ---------------------------------------------------------------------

c     write(*,*) 'IN AXIAL.08: FFA=0!'

c     do 1672 kk=1,11

c1672 ffa(kk)=0.d0



      DIV1 =1.D0/(AM(1)*AMY(1))

      DIV2 =1.D0/(AM(1)*AMY(2))

      DIV3 =1.D0/(AM(1)*AMH   )

C     RATIO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT:

      SOALL = 0.5D0*(AMNN/AMLN-AMLN/AMNN)

      SOALS = 0.5D0*(AMNN/AMH -AMH /AMNN)

      SOASS = 0.5D0*(AMNN/AMSN-AMSN/AMNN)

      

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GALL= 0.D0   

      GASS= -2*FA(1)*FA(2)

      GALS= -SR3*FA(1)*FA(3)

      GADR= FA(1)*FA(2)

      FFALL= 0.D0   

      FFASS= -2*FFA(1)*FFA(2)

      FFALS= -SR3*FFA(1)*FFA(3)

      FFADR= FFA(1)*FFA(2)

      GFALL= 0.D0   

      GFASS= -2*(FA(1)*FFA(2)+FFA(1)*FA(2))

      GFALS= -SR3*(FA(1)*FFA(3)+FFA(1)*FA(3))

      GFADR= FA(1)*FFA(2)+FFA(1)*FA(2)

      AMAX(1)=AMA1

      GOTO 1055

1052  GALL=  FA(6)*FA(7)

      GASS=  FA(6)*FA(8)  

      GALS=  0.D0

      GADR=  FA(6)*FA(8)  

      FFALL= FFA(6)*FFA(7)

      FFASS= FFA(6)*FFA(8)

      FFALS= 0.D0                 

      FFADR= FFA(6)*FFA(8)

      GFALL= FA(6)*FFA(7)+FFA(6)*FA(7)

      GFASS= FA(6)*FFA(8)+FFA(6)*FA(8)

      GFALS= 0.D0                                 

      GFADR= FA(6)*FFA(8)+FFA(6)*FA(8)

      AMAX(2)=AMD1                        ! AUGUST 2011

      GOTO 1055

1053  GALL=  FA(9)*FA(10)

      GASS=  FA(9)*FA(11)

      GALS=  0.D0

      GADR=  FA(9)*FA(11)

      FFALL= FFA(9)*FFA(10)

      FFASS= FFA(9)*FFA(11)

      FFALS= 0.D0                 

      FFADR= FFA(9)*FFA(11)

      GFALL= FA(9)*FFA(10)+FFA(9)*FA(10)

      GFASS= FA(9)*FFA(11)+FFA(9)*FA(11)

      GFALS= 0.D0                                 

      GFADR= FA(9)*FFA(11)+FFA(9)*FA(11)

      AMAX(3)=AME1                        ! AUGUST 2011

      GOTO 1055

1054  GALL=  FA(4)*FA(4)*P

      GASS= -FA(5)*FA(5)*P

      GALS= -SR3*FA(4)*FA(5)*P

      GADR= 2*FA(5)*FA(5)*P

      FFALL=  FFA(4)*FFA(4)*P

      FFASS= -FFA(5)*FFA(5)*P

      FFALS= -SR3*FFA(4)*FFA(5)*P 

      FFADR= 2*FFA(5)*FFA(5)*P

      GFALL=  (FA(4)*FFA(4)+FFA(4)*FA(4))*P

      GFASS= -(FA(5)*FFA(5)+FFA(5)*FA(5))*P

      GFALS= -SR3*(FA(4)*FFA(5)+FFA(4)*FA(5))*P

      GFADR= 2*(FA(5)*FFA(5)+FFA(5)*FA(5))*P

      AMAX(4)=AMK1

C

1055  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN      

      ALAM = ALMAX

      IF(ALAM.EQ.0.D0) ALAM=ALMP8

      IF(IN.EQ.2.AND.ALMAX.EQ.0.D0) ALAM=ALMP1

      IF(IN.EQ.4.AND.ALMAX.EQ.0.D0) ALAM=ALMKA

      ENDIF



      AMAX2=AMAX(IN)*AMAX(IN)

      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

      RATM1=AMAX(IN)/ALM1

      RATM2=AMAX(IN)/ALM2

      RATM3=AMAX(IN)/ALM3

      FAC1 =AMAX(IN)**2/(AM(1)*AMY(1))

      FAC2 =AMAX(IN)**2/(AM(1)*AMY(2))

      FAC3 =AMAX(IN)**2/(AM(1)*AMH   )

      IF(IZAX.NE.0) FZERO = (AMAX(IN)/AMCRA)**2



C     FOR DERIVATIVE TERMS:

      FFAC1 = AMAX(IN)**4/(4*AM(1)*AMY(1)*AMPRO**2)

      FFAC2 = AMAX(IN)**4/(4*AM(1)*AMY(2)*AMPRO**2)

      FFAC3 = AMAX(IN)**4/(4*AM(1)*AMH*AMPRO**2)

      GFAC1 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMY(1))*AMPRO)

      GFAC2 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMY(2))*AMPRO)

      GFAC3 = AMAX(IN)**2/(2*DSQRT(AM(1)*AMH)*AMPRO)

C

c*    DO 104 I=2,NMAX

c*    X = XA(I)

      X = XA   

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMAX(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLL0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLL1  = FCLL0  - VKULL*AMAX(IN)

      DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM

      DFCLL1 =  DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN)     

      DFTLL0 =  DFCLL1/3.D0-3*FTLL0*PIM/XA

      FTLL1  = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1)

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTSS0  = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCSS1  = FCSS0  - VKUSS*AMAX(IN)

      DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM

      DFCSS1 =  DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN)     

      DFTSS0 =  DFCSS1/3.D0-3*FTSS0*PIM/XA

      FTSS1  = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLS0  = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLS1  = FCLS0  - VKULS*AMAX(IN)

      DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM

      DFCLS1 =  DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN)     

      DFTLS0 =  DFCLS1/3.D0-3*FTLS0*PIM/XA

      FTLS1  = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3)



c     IF(IZAX.NE.0) THEN

      FCLL2  = FCLL1 + (1.5D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/RATM1/RATM1

      DFCLL2 = DFCLL1 -ALM1*XLAM1*(2.5D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/RATM1/RATM1

      FTLL1  = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1)

      DFTLL1 = DFTLL0- ALM1*XLAM1*(1D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/(3*RATM1*RATM1)

      FSOLL1 = FSOLL0 - 0.5D0*(ALM1/AMAX(IN))**2*VKULL*AMAX(IN)



      FCSS2  = FCSS1 + (1.5D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/RATM2/RATM2

      DFCSS2 = DFCSS1 -ALM2*XLAM2*(2.5D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/RATM2/RATM2

      FTSS1  = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2)

      DFTSS1 = DFTSS0- ALM2*XLAM2*(1D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/(3*RATM2*RATM2)

      FSOSS1 = FSOSS0 - 0.5D0*(ALM2/AMAX(IN))**2*VKUSS*AMAX(IN)



      FCLS2  = FCLS1 + (1.5D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/RATM3/RATM3

      DFCLS2 = DFCLS1 -ALM3*XLAM3*(2.5D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/RATM3/RATM3

      FTLS1  = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3)

      DFTLS1 = DFTLS0- ALM3*XLAM3*(1D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/(3*RATM3*RATM3)

      FSOLS1 = FSOLS0 - 0.5D0*(ALM3/AMAX(IN))**2*VKULS*AMAX(IN)

      FO2LS1 = -3*FTLS0/(X*X)



C*    NO K^4-TERMS:

c     IF(IZAX.NE.2) THEN

      FCLL2  = 0D0

      FCSS2  = 0D0

      FCLS2  = 0D0

      DFCLL2 = 0D0

      DFCSS2 = 0D0

      DFCLS2 = 0D0

      FTLL1  = 0D0

      FTSS1  = 0D0

      FTLS1  = 0D0

      DFTLL1 = 0D0

      DFTSS1 = 0D0

      DFTLS1 = 0D0

C*    NO FITEN!

c     ENDIF

C     FOR LTA,OM,NLT: NO Q12 and NON-LOCAL S12:

      FO2LL0 = 0.D0

      FO2LS0 = 0.D0

      FO2SS0 = 0.D0

      FO2LL1 = 0.D0

      FO2LS1 = 0.D0

      FO2SS1 = 0.D0

c     ENDIF

C---------------------------------------------------------------

C

C     FIRST TERM AXIAL PROPAGATOR:

C

C---------------------------------------------------------------

      VSIGLL = VSIGLL - GALL*(FCLL0+FAC1*FCLL1*CFSIG/6D0)

      VSIGSS = VSIGSS - GASS*(FCSS0+FAC2*FCSS1*CFSIG/6D0)

      VSIGLS = VSIGLS - GALS*(FCLS0+FAC3*FCLS1*CFSIG/6D0)

      VSIGDR = VSIGDR - GADR*(FCSS0+FAC2*FCSS1*CFSIG/6D0)



      VTENLL = VTENLL + CFTEN *GALL*FAC1 *FTLL0

      VTENSS = VTENSS + CFTEN *GASS*FAC2 *FTSS0

      VTENLS = VTENLS + CFTEN *GALS*FAC3 *FTLS0

      VTENDR = VTENDR + CFTEN *GADR*FAC2 *FTSS0



      VSOLL  = VSOLL  - 0.5D0*GALL*FAC1 *FSOLL0

      VSOSS  = VSOSS  - 0.5D0*GASS*FAC2 *FSOSS0

      VSOLS  = VSOLS  - 0.5D0*GALS*FAC3 *FSOLS0

      VSODR  = VSODR  - 0.5D0*GADR*FAC2 *FSOSS0



      VSO2LL  = VSO2LL  + 2.0D0*GALL*FAC1 *FO2LL0

      VSO2SS  = VSO2SS  + 2.0D0*GASS*FAC2 *FO2SS0

      VSO2LS  = VSO2LS  + 2.0D0*GALS*FAC3 *FO2LS0

      VSO2DR  = VSO2DR  + 2.0D0*GADR*FAC2 *FO2SS0



c-------------------------------------------------------------

c  check sign vasoll etc. !

c     VASOLL  = VASOLL  + 0.5D0*GALL*FAC1 *FSOLL0

c    .                    *SOALL

      VASOLL  = VASOLL  - 0.5D0*GALL*FAC1 *FSOLL0

     .                    *SOALL

      VASOSS  = VASOSS  - 0.5D0*GASS*FAC2 *FSOSS0

     .                    *SOASS

      VASOLS  = VASOLS  - 0.5D0*GALS*FAC3 *FSOLS0

     .                    *SOALS

      VASODR  = VASODR  - 0.5D0*GADR*FAC2 *FSOSS0

     .                    *SOASS

C---------------------------------------------------------------

C     BROWN, DOWNS AND IDDINGS TERM:

C     HERE, INSTEAD OF P, WE HAVE P_x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.4) THEN

c      PX = -1D0

      VASOLL  = VASOLL  - PX*GALL*FAC1 *FSOLL0

     .                    *SOALL

      VASOSS  = VASOSS  - PX*GASS*FAC2 *FSOSS0

     .                    *SOASS

      VASOLS  = VASOLS  - PX*GALS*FAC3 *FSOLS0

     .                    *SOALS

      VASODR  = VASODR  - PX*GADR*FAC2 *FSOSS0

     .                    *SOASS

      ENDIF



C---------------------------------------------------------------

      FISLL   = FISLL  - CFFIS*GALL*FCLL0*DIV1*REDM(1)/6.D0

      FISSS   = FISSS  - CFFIS*GASS*FCSS0*DIV2*REDM(2)/6.D0

      FISLS   = FISLS  - CFFIS*GALS*FCLS0*DIV3*REDM(3)/6.D0

      FISDR   = FISDR  - CFFIS*GADR*FCSS0*DIV2*REDM(2)/6.D0



      DFISLL  = DFISLL - CFFIS*GALL*DFCLL0*DIV1*REDM(1)/6.D0

      DFISSS  = DFISSS - CFFIS*GASS*DFCSS0*DIV2*REDM(2)/6.D0

      DFISLS  = DFISLS - CFFIS*GALS*DFCLS0*DIV3*REDM(3)/6.D0

      DFISDR  = DFISDR - CFFIS*GADR*DFCSS0*DIV2*REDM(2)/6.D0



      DDFSLL = DDFSLL - CFFIS*GALL*AMAX2*(FCLL1+2*FSOLL0)*

     .                    DIV1*REDM(1)/6.D0

      DDFSSS = DDFSSS - CFFIS*GASS*AMAX2*(FCSS1+2*FSOSS0)*

     .                    DIV2*REDM(2)/6.D0

      DDFSLS = DDFSLS - CFFIS*GALS*AMAX2*(FCLS1+2*FSOLS0)*

     .                    DIV3*REDM(3)/6.D0

      DDFSDR = DDFSDR - CFFIS*GADR*AMAX2*(FCSS1+2*FSOSS0)*

     .                    DIV2*REDM(2)/6.D0

C---------------------------------------------------------------

      IF(IZAX.NE.0) THEN

      VSIGLL  = VSIGLL  - FZERO*GALL*(FCLL1+FAC1*FCLL2*CFSIG/6D0)

      VSIGSS  = VSIGSS  - FZERO*GASS*(FCSS1+FAC2*FCSS2*CFSIG/6D0)

      VSIGLS  = VSIGLS  - FZERO*GALS*(FCLS1+FAC3*FCLS2*CFSIG/6D0)

      VSIGDR  = VSIGDR  - FZERO*GADR*(FCSS1+FAC2*FCSS2*CFSIG/6D0)



      VTENLL  = VTENLL  + CFTEN *FZERO*GALL*FAC1 *FTLL1

      VTENSS  = VTENSS  + CFTEN *FZERO*GASS*FAC2 *FTSS1

      VTENLS  = VTENLS  + CFTEN *FZERO*GALS*FAC3 *FTLS1

      VTENDR  = VTENDR  + CFTEN *FZERO*GADR*FAC2 *FTSS1



      VSOLL   = VSOLL   - 0.5D0*FZERO*GALL*FAC1 *FSOLL1

      VSOSS   = VSOSS   - 0.5D0*FZERO*GASS*FAC2 *FSOSS1

      VSOLS   = VSOLS   - 0.5D0*FZERO*GALS*FAC3 *FSOLS1

      VSODR   = VSODR   - 0.5D0*FZERO*GADR*FAC2 *FSOSS1



      VSO2LL   = VSO2LL + 2.0D0*FZERO*GALL*FAC1 *FO2LL1

      VSO2SS   = VSO2SS + 2.0D0*FZERO*GASS*FAC2 *FO2SS1

      VSO2LS   = VSO2LS + 2.0D0*FZERO*GALS*FAC3 *FO2LS1

      VSO2DR   = VSO2DR + 2.0D0*FZERO*GADR*FAC2 *FO2SS1



      VASOLL  = VASOLL  - 0.5D0*FZERO*GALL*FAC1 *FSOLL1

     .                    *SOALL

      VASOSS  = VASOSS  - 0.5D0*FZERO*GASS*FAC2 *FSOSS1

     .                    *SOASS

      VASOLS  = VASOLS  - 0.5D0*FZERO*GALS*FAC3 *FSOLS1

     .                    *SOALS

      VASODR  = VASODR  - 0.5D0*FZERO*GADR*FAC2 *FSOSS1

     .                    *SOASS

c-------------------------------------------------------------

C     BROWN, DOWNS AND IDDINGS TERM:

C     HERE, INSTEAD OF P, WE HAVE P_x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.4) THEN

c      PX = -1D0

      VASOLL = VASOLL - PX*FZERO*GALL*FAC1 *FSOLL1

     .                    *SOALL

      VASOSS = VASOSS - PX*FZERO*GASS*FAC2 *FSOSS1

     .                    *SOASS

      VASOLS = VASOLS - PX*FZERO*GALS*FAC3 *FSOLS1

     .                    *SOALS

      VASODR = VASODR - PX*FZERO*GADR*FAC2 *FSOSS1

     .                    *SOASS

      ENDIF

c-------------------------------------------------------------



c     IF(IZAX.EQ.2) THEN     ! inconsistent with bbprogs.aug12.csb

      FISLL  = FISLL - FZERO*GALL*FCLL1*DIV1*REDM(1)*CFFIS/6.D0

      FISSS  = FISSS - FZERO*GASS*FCSS1*DIV2*REDM(2)*CFFIS/6.D0

      FISLS  = FISLS - FZERO*GALS*FCLS1*DIV3*REDM(3)*CFFIS/6.D0

      FISDR  = FISDR - FZERO*GADR*FCSS1*DIV2*REDM(2)*CFFIS/6.D0



      DFISLL = DFISLL- FZERO*GALL*DFCLL1*DIV1*REDM(1)*CFFIS/6.D0

      DFISSS = DFISSS- FZERO*GASS*DFCSS1*DIV2*REDM(2)*CFFIS/6.D0

      DFISLS = DFISLS- FZERO*GALS*DFCLS1*DIV3*REDM(3)*CFFIS/6.D0

      DFISDR = DFISDR- FZERO*GADR*DFCSS1*DIV2*REDM(2)*CFFIS/6.D0



      DDFSLL = DDFSLL- FZERO*GALL*AMAX2*(FCLL2+2*FSOLL1)*

     .                 DIV1*REDM(1)*CFFIS/6.D0

      DDFSSS = DDFSSS- FZERO*GASS*AMAX2*(FCSS2+2*FSOSS1)*

     .                 DIV2*REDM(2)*CFFIS/6.D0

      DDFSLS = DDFSLS- FZERO*GALS*AMAX2*(FCLS2+2*FSOLS1)*

     .                 DIV3*REDM(3)*CFFIS/6.D0

      DDFSDR = DDFSDR- FZERO*GADR*AMAX2*(FCSS2+2*FSOSS1)*

     .                 DIV2*REDM(2)*CFFIS/6.D0

c     ENDIF

      ENDIF

C---------------------------------------------------------------

C

C     SECOND TERM AXIAL PROPAGATOR:

C

C---------------------------------------------------------------

      IF(IBFLD.EQ.0) THEN

C---------------------------------------------------------------

      VSIGLL  = VSIGLL  + GALL*FCLL1/3

      VSIGSS  = VSIGSS  + GASS*FCSS1/3

      VSIGLS  = VSIGLS  + GALS*FCLS1/3

      VSIGDR  = VSIGDR  + GADR*FCSS1/3



      VTENLL  = VTENLL  + GALL*FTLL0

      VTENSS  = VTENSS  + GASS*FTSS0

      VTENLS  = VTENLS  + GALS*FTLS0

      VTENDR  = VTENDR  + GADR*FTSS0



      FISLL   = FISLL   - GALL*REDM(1)*FCLL1*DIV1/6.D0

      FISSS   = FISSS   - GASS*REDM(2)*FCSS1*DIV2/6.D0

      FISLS   = FISLS   - GALS*REDM(3)*FCLS1*DIV3/6.D0

      FISDR   = FISDR   - GADR*REDM(2)*FCSS1*DIV2/6.D0



      DFISLL  = DFISLL  - GALL*REDM(1)*DFCLL1*DIV1/6.D0

      DFISSS  = DFISSS  - GASS*REDM(2)*DFCSS1*DIV2/6.D0

      DFISLS  = DFISLS  - GALS*REDM(3)*DFCLS1*DIV3/6.D0

      DFISDR  = DFISDR  - GADR*REDM(2)*DFCSS1*DIV2/6.D0



c     FITEN     = FITEN  - GAX2*REDM*FT0 *DIV/2.D0

c     DFITEN    = DFITEN - GAX2*REDM*DFT0*DIV/2.D0



c------------------------------------------------------------

      IF(IZAX.NE.0) THEN

      VSIGLL  = VSIGLL  + FZERO*GALL*FCLL2/3D0

      VSIGSS  = VSIGSS  + FZERO*GASS*FCSS2/3D0

      VSIGLS  = VSIGLS  + FZERO*GALS*FCLS2/3D0

      VSIGDR  = VSIGDR  + FZERO*GADR*FCSS2/3D0



      VTENLL  = VTENLL  + FZERO*GALL*FTLL1

      VTENSS  = VTENSS  + FZERO*GASS*FTSS1

      VTENLS  = VTENLS  + FZERO*GALS*FTLS1

      VTENDR  = VTENDR  + FZERO*GADR*FTSS1



c----------------------------------------------------------------

c     IF(IZAX.EQ.2) THEN

      FISLL   = FISLL   - FZERO*GALL*REDM(1)*FCLL2*DIV1/6.D0

      FISSS   = FISSS   - FZERO*GASS*REDM(2)*FCSS2*DIV2/6.D0

      FISLS   = FISLS   - FZERO*GALS*REDM(3)*FCLS2*DIV3/6.D0

      FISDR   = FISDR   - FZERO*GADR*REDM(2)*FCSS2*DIV2/6.D0



      DFISLL  = DFISLL  - FZERO*GALL*REDM(1)*DFCLL2*DIV1/6.D0

      DFISSS  = DFISSS  - FZERO*GASS*REDM(2)*DFCSS2*DIV2/6.D0

      DFISLS  = DFISLS  - FZERO*GALS*REDM(3)*DFCLS2*DIV3/6.D0

      DFISDR  = DFISDR  - FZERO*GADR*REDM(2)*DFCSS2*DIV2/6.D0

c     ENDIF

C---------------------------------------------------------------

      ENDIF     ! END IZAX.NE.0

C---------------------------------------------------------------

      ENDIF     ! END IBFLD.EQ.0

C---------------------------------------------------------------

C---------------------------------------------------------------

      IF(IBFLD.GE.1) THEN

C---------------------------------------------------------------

C     FEYNMAN-GAUGE: ALPHA_R=1:

      FC2B1 = 0.D0

      FT2B0 = 0.D0

      FC2B2 = 0.D0

      FT2B1 = 0.D0

      DFC2B1 = 0.D0

      DFC2B2 = 0.D0

      DDFC2B1 = 0.D0

      DDFC2B2 = 0.D0

C---------------------------------------------------------------

      VSIGLL = VSIGLL + GALL*FC2B1/3

      VSIGSS = VSIGSS + GASS*FC2B1/3

      VSIGLS = VSIGLS + GALS*FC2B1/3

      VSIGDR = VSIGDR + GADR*FC2B1/3



      VTENLL = VTENLL + GALL*FT2B0

      VTENSS = VTENSS + GASS*FT2B0

      VTENLS = VTENLS + GALS*FT2B0

      VTENDR = VTENDR + GADR*FT2B0



      FISLL  = FISLL  - GALL*REDM(1)*FC2B1*DIV1/6.D0

      FISSS  = FISSS  - GASS*REDM(2)*FC2B1*DIV2/6.D0

      FISLS  = FISLS  - GALS*REDM(3)*FC2B1*DIV3/6.D0

      FISDR  = FISDR  - GADR*REDM(2)*FC2B1*DIV2/6.D0



      DFISLL = DFISLL - GALL*REDM(1)*DFC2B1*DIV1/6.D0

      DFISSS = DFISSS - GASS*REDM(2)*DFC2B1*DIV2/6.D0

      DFISLS = DFISLS - GALS*REDM(3)*DFC2B1*DIV3/6.D0

      DFISDR = DFISDR - GADR*REDM(2)*DFC2B1*DIV2/6.D0

c     FITEN     = FITEN  - GAX2*REDM*FT2B1*DIV/4.D0

c     DFITEN    = DFITEN - GAX2*REDM*DFT2B1*DIV/4.D0



      DDFSLL = DDFSLL - GALL*REDM(1)*DDFC2B1*DIV1/6.D0

      DDFSSS = DDFSSS - GASS*REDM(2)*DDFC2B1*DIV2/6.D0

      DDFSLS = DDFSLS - GALS*REDM(3)*DDFC2B1*DIV3/6.D0

      DDFSDR = DDFSDR - GADR*REDM(2)*DDFC2B1*DIV2/6.D0

       IF(IZAX.NE.0) THEN

      VSIGLL = VSIGLL + FZERO*GALL*FC2B2/3

      VSIGSS = VSIGSS + FZERO*GASS*FC2B2/3

      VSIGLS = VSIGLS + FZERO*GALS*FC2B2/3

      VSIGDR = VSIGDR + FZERO*GADR*FC2B2/3



      VTENLL = VTENLL + FZERO*GALL*FT2B1

      VTENSS = VTENSS + FZERO*GASS*FT2B1

      VTENLS = VTENLS + FZERO*GALS*FT2B1

      VTENDR = VTENDR + FZERO*GADR*FT2B1

c       IF(IZAX.EQ.2) THEN

      FISLL  = FISLL  - FZERO*GALL*REDM(1)*FC2B2*DIV1/6.D0

      FISSS  = FISSS  - FZERO*GASS*REDM(2)*FC2B2*DIV2/6.D0

      FISLS  = FISLS  - FZERO*GALS*REDM(3)*FC2B2*DIV3/6.D0

      FISDR  = FISDR  - FZERO*GADR*REDM(2)*FC2B2*DIV2/6.D0



      DFISLL = DFISLL - FZERO*GALL*REDM(1)*DFC2B2*DIV1/6.D0

      DFISSS = DFISSS - FZERO*GASS*REDM(2)*DFC2B2*DIV2/6.D0

      DFISLS = DFISLS - FZERO*GALS*REDM(3)*DFC2B2*DIV3/6.D0

      DFISDR = DFISDR - FZERO*GADR*REDM(2)*DFC2B2*DIV2/6.D0



      DSDFSLL = DSDFSLL - FZERO*GALL*REDM(1)*DDFC2B2*DIV1/6.D0

      DSDFSSS = DSDFSSS - FZERO*GASS*REDM(2)*DDFC2B2*DIV2/6.D0

      DSDFSLS = DSDFSLS - FZERO*GALS*REDM(3)*DDFC2B2*DIV3/6.D0

      DSDFSDR = DSDFSDR - FZERO*GADR*REDM(2)*DDFC2B2*DIV2/6.D0

c       ENDIF     ! IZAXI.EQ.2

         ENDIF     ! IZAXI.NE.0

C---------------------------------------------------------------

      ENDIF       ! END IBFLF.EQ.1

C---------------------------------------------------------------

C---------------------------------------------------------------

C

C     DERIVATIVE COUPLINGS: -> GAUSSIAN CONTRIBUTIONS:

C

C---------------------------------------------------------------

C     GAUSSIAN CONTRIBUTIONS:

      IF(IBFLD.EQ.0) THEN

C---------------------------------------------------------------

C     ASSUMED: ALM1=ALM2=ALM3:

      UPSS0 = VKULL*AMAX(IN)

      UPSS1 = (1.D0-2*XLAM1**2/3D0)*UPSS0

      UPSS2 = (15.D0-20*XLAM1**2+4*XLAM1**4)*UPSS0/3D0

      UPST0 = +2*XLAM1**2*UPSS0/3.D0

      UPST1 = +2*XLAM1**2*(7D0-2*XLAM1**2)*UPSS0/3.D0



      VSIGLL= VSIGLL + FFALL*FFAC1*UPSS2 + GFALL*GFAC1*UPSS1

      VSIGLS= VSIGLS + FFALS*FFAC3*UPSS2 + GFALS*GFAC3*UPSS1

      VSIGSS= VSIGSS + FFASS*FFAC2*UPSS2 + GFASS*GFAC2*UPSS1

      VSIGDR= VSIGDR + FFADR*FFAC2*UPSS2 + GFADR*GFAC2*UPSS1



      VTENLL= VTENLL - FFALL*FFAC1*UPST1 - GFALL*GFAC1*UPST0

      VTENLS= VTENLS - FFALS*FFAC3*UPST1 - GFALS*GFAC3*UPST0

      VTENSS= VTENSS - FFASS*FFAC2*UPST1 - GFASS*GFAC2*UPST0

      VTENDR= VTENDR - FFADR*FFAC2*UPST1 - GFADR*GFAC2*UPST0

C---------------------------------------------------------------

      ENDIF

C---------------------------------------------------------------

C     gecorrigeerd -> +1*GFALL*GFAC1*FTLL0 etc. (NOV 2012)

C     FEYNMAN-GAUGE: ALPHA_R=1 -> m_A' = m_A:

      IF(IBFLD.GE.1) THEN

      VSIGLL= VSIGLL-(FFALL*FFAC1*FCLL2+1*GFALL*GFAC1*FCLL1)/3D0

      VSIGLS= VSIGLS-(FFALS*FFAC3*FCLS2+1*GFALS*GFAC3*FCLS1)/3D0

      VSIGSS= VSIGSS-(FFASS*FFAC2*FCSS2+1*GFASS*GFAC2*FCSS1)/3D0

      VSIGDR= VSIGDR-(FFADR*FFAC2*FCSS2+1*GFADR*GFAC2*FCSS1)/3D0



      VTENLL= VTENLL-(FFALL*FFAC1*FTLL1+1*GFALL*GFAC1*FTLL0)

      VTENLS= VTENLS-(FFALS*FFAC3*FTLS1+1*GFALS*GFAC3*FTLS0)

      VTENSS= VTENSS-(FFASS*FFAC2*FTSS1+1*GFASS*GFAC2*FTSS0)

      VTENDR= VTENDR-(FFADR*FFAC2*FTSS1+1*GFADR*GFAC2*FTSS0)

      ENDIF

C---------------------------------------------------------------

C

  104 CONTINUE

 1040 CONTINUE

C

      RETURN

      END

C**********************************************************************

C

c*    SUBROUTINE AXIALU(NMAX,NLOC,ICSB,P)

      SUBROUTINE AXIALU(XA,ICSB,NLOC,P,PX)

C

C**********************************************************************

C

C     AXIAL MESONS (UNNATURAL PARITY) POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,

     .             IFRMF,NSU3F

      COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX                           

      COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL   ,VCSS   ,VCLS   ,VCDR   ,

     .            VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR ,

     .            VTENLL ,VTENSS ,VTENLS ,VTENDR ,

     .            VSOLL  ,VSOSS  ,VSOLS  ,VSODR  ,

     .            VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR ,

     .            VASOLL ,VASOSS ,VASOLS ,VASODR ,

     .            VNNC   ,VNNSIG ,VNNTEN ,VNNSO  ,

     .            FILL   ,FISS   ,FILS   ,FIDR   ,

     .            DFILL  ,DFISS  ,DFILS  ,DFIDR  ,

     .            FISLL  ,FISSS  ,FISLS  ,FISDR  ,

     .            DFISLL ,DFISSS ,DFISLS ,DFISDR ,

     .            FITLL  ,FITSS  ,FITLS  ,FITDR  ,

     .            DFITLL ,DFITSS ,DFITLS ,DFITDR 

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS, DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS, DDFSDR 

      DIMENSION AMAX(4)

      DATA SR3/1.732051D0/,SRPI/1.7724538509D0/,IPV/1/,ICALl/0/

      DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1170.D0,1380.D0,1273.D0/

c     DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1380.D0,1170D0,1400.D0/

C

C   NOTE : B1(IN=1),H11 (IN=2),H11'(IN=3),K1B(IN=4)

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C

      IF(ICALL.EQ.0.and.NSU3F.EQ.1) THEN

      AMH1 = AMB1

      AMH2 = AMB1

      AMK1 = AMB1

      ICALL=1

      ENDIF

C

      DIV1 =1.D0/(AM(1)*AMY(1))

      DIV2 =1.D0/(AM(1)*AMY(2))

      DIV3 =1.D0/(AM(1)*AMH   )

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GALL= 0.D0   

      GASS= -2*FB(1)*FB(2)

      GALS= -SR3*FB(1)*FB(3)

      GADR= FB(1)*FB(2)

      AMAX(1)=AMB1

      GOTO 1055

1052  GALL=  FB(6)*FB(7)

      GASS=  FB(6)*FB(8)  

      GALS=  0.D0

      GADR=  FB(6)*FB(8)  

      AMAX(2)=AMH1

      GOTO 1055

1053  GALL=  FB(9)*FB(10)

      GASS=  FB(9)*FB(11)

      GALS=  0.D0

      GADR=  FB(9)*FB(11)

      AMAX(3)=AMH2

      GOTO 1055

1054  GALL=  FB(4)*FB(4)*P

      GASS= -FB(5)*FB(5)*P

      GALS= -SR3*FB(4)*FB(5)*P

      GADR= 2*FB(5)*FB(5)*P

      AMAX(4)=AMK1

C

1055  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN      

      ALAM = ALMP8

      IF(IN.EQ.2) ALAM=ALMP1

      IF(IN.EQ.4) ALAM=ALMKA

      ENDIF

      AMAX2=AMAX(IN)*AMAX(IN)

C

      ALM1 = ALAM

      ALM2 = ALAM

      ALM3 = ALAM

      RATM1=AMAX(IN)/ALM1

      RATM2=AMAX(IN)/ALM2

      RATM3=AMAX(IN)/ALM3

c     FAC1=AMAX(IN)**2/(4*AM(1)*AMY(1))

c     FAC2=AMAX(IN)**2/(4*AM(1)*AMY(2))

c     FAC3=AMAX(IN)**2/(4*AM(1)*AMH   )

C     SCALING COUPLING WITH PIM:

      FAC1=AMAX(IN)**2/(PIM*PIM)         

      FAC2=AMAX(IN)**2/(PIM*PIM)             

      FAC3=AMAX(IN)**2/(PIM*PIM)           

C

c*    DO 104 I=2,NMAX

c*    X = XA(I)

      X = XA   

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMAX(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLL0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLL1  = FCLL0  - VKULL*AMAX(IN)

      FCLL2  = FCLL1  + (1.5D0-XLAM1*XLAM1)*VKULL*AMAX(IN)/RATM1**2

      FSOLL1 = FSOLL0 - 0.5D0*VKULL*AMAX(IN)/RATM1**2

c*    DFCLL0 = -X*FSOLL0

      DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM

      DFCLL1 =  DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN)     ! MARCH 2009

      DFTLL0 =  DFCLL1/3.D0-3*FTLL0*PIM/XA

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTSS0  = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCSS1  = FCSS0  - VKUSS*AMAX(IN)

      FCSS2  = FCSS1  + (1.5D0-XLAM2*XLAM2)*VKUSS*AMAX(IN)/RATM2**2

      FSOSS1 = FSOSS0  - 0.5D0*VKUSS*AMAX(IN)/RATM2**2

c*    DFCSS0 = -X*FSOSS0

      DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM

      DFCSS1 =  DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN)     ! MARCH 2009

      DFTSS0 =  DFCSS1/3.D0-3*FTSS0*PIM/XA

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLS0  = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLS1  = FCLS0  - VKULS*AMAX(IN)

      FCLS2  = FCLS1  + (1.5D0-XLAM3*XLAM3)*VKULS*AMAX(IN)/RATM3**2

      FSOLS1 = FSOLS0  - 0.5D0*VKULS*AMAX(IN)/RATM3**2

c*    DFCLS0 = -X*FSOLS0

      DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM

      DFCLS1 =  DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN)     ! MARCH 2009

      DFTLS0 =  DFCLS1/3.D0-3*FTLS0*PIM/XA

C

1041   VSIGLL   = VSIGLL  - GALL*FAC1*FCLL1/3.D0

       VSIGSS   = VSIGSS  - GASS*FAC2*FCSS1/3.D0

       VSIGLS   = VSIGLS  - GALS*FAC3*FCLS1/3.D0

       VSIGDR   = VSIGDR  - GADR*FAC2*FCSS1/3.D0



       VTENLL   = VTENLL  - GALL*FAC1*FTLL0

       VTENSS   = VTENSS  - GASS*FAC2*FTSS0

       VTENLS   = VTENLS  - GALS*FAC3*FTLS0

       VTENDR   = VTENDR  - GADR*FAC2*FTSS0

C------------------------------------------------------------

C     BROWN, DOWNS AND IDDINGS TERMS:

C     HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.4) THEN

c      PX = -1D0

        VASOLL  = VASOLL + PX*GALL*FAC1*FSOLL0*

     .               4*(AMY(1)-AM(1))/(AMY(1)+AM(1))

        VASOSS  = VASOSS + PX*GASS*FAC2*FSOSS0*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

        VASOLS  = VASOLS + PX*GALS*FAC3*FSOLS0*

     .               4*(AMY(3)-AM(3))/(AMY(3)+AM(3))

        VASODR  = VASODR + PX*GADR*FAC2*FSOSS0*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

      ENDIF

C------------------------------------------------------------



      IF(NLOC.EQ.0) GO TO 104

       FISLL = FISLL  - GALL*FAC1*REDMM*FCLL1 *DIV1/2.D0

       FISSS = FISSS  - GASS*FAC2*REDMM*FCSS1 *DIV2/2.D0

       FISLS = FISLS  - GALS*FAC3*REDMM*FCLS1 *DIV3/2.D0

       FISDR = FISDR  - GADR*FAC2*REDMM*FCSS1 *DIV2/2.D0



       DFISLL= DFISLL - GALL*FAC1*REDMM*DFCLL1*DIV1/2.D0

       DFISSS= DFISSS - GASS*FAC2*REDMM*DFCSS1*DIV2/2.D0

       DFISLS= DFISLS - GALS*FAC3*REDMM*DFCLS1*DIV3/2.D0

       DFISDR= DFISDR - GADR*FAC2*REDMM*DFCSS1*DIV2/2.D0



       DDFSLL= DDFSLL - GALL*FAC1*REDMM*AMAX2*(FCLL2+2*FSOLL1)*

     .                  DIV1/2.D0

       DDFSSS= DDFSSS - GASS*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)*

     .                  DIV2/2.D0

       DDFSLS= DDFSLS - GALS*FAC3*REDMM*AMAX2*(FCLS2+2*FSOLS1)*

     .                  DIV3/2.D0

       DDFSDR= DDFSDR - GADR*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)*

     .                  DIV2/2.D0



c      FITLL = FITLL  - GALL*FAC1*REDMM*FTLL0 *DIV1/2.D0

c      DFITLL= DFITLL - GALL*FAC1*REDMM*DFTLL0*DIV1/2.D0

C

  104 CONTINUE

c     print spin-orbit potentials:

c     write(*,*) ' AXIALB : x=',xa,' IN=',in,' vsoll=',vsoll,

c    .' vasoll=',vasoll,' p=',p

C

 1040 CONTINUE

C

      RETURN

      END



C**********************************************************************

C

c*    SUBROUTINE TENSOR(NMAX,NLOC,ICSB,P)

      SUBROUTINE TENSOR(XA,ICSB,NLOC,P,PX)

C

C**********************************************************************

C

C     TENSOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C     VERSION: 13 SEPTEMBER 2006: WITH ZERO IN FORM FACTOR

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

c*    COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGRTST,IGERST,IFRMF

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/HVY/HFPS(11),GT(11),FT(11),FD(11),FV(11)

      COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c*    COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL   ,VCSS   ,VCLS   ,VCDR   ,

     .            VSIGLL ,VSIGSS ,VSIGLS ,VSIGDR ,

     .            VTENLL ,VTENSS ,VTENLS ,VTENDR ,

     .            VSOLL  ,VSOSS  ,VSOLS  ,VSODR  ,

     .            VSO2LL ,VSO2SS ,VSO2LS ,VSO2DR ,

     .            VASOLL ,VASOSS ,VASOLS ,VASODR ,

     .            VNNC   ,VNNSIG ,VNNTEN ,VNNSO  ,

     .            FILL   ,FISS   ,FILS   ,FIDR   ,

     .            DFILL  ,DFISS  ,DFILS  ,DFIDR  ,

     .            FISLL  ,FISSS  ,FISLS  ,FISDR  ,

     .            DFISLL ,DFISSS ,DFISLS ,DFISDR ,

     .            FITLL  ,FITSS  ,FITLS  ,FITDR  ,

     .            DFITLL ,DFITSS ,DFITLS ,DFITDR 

      DIMENSION AMTS(4),FTS(4),XM1(3),XM2(3)

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/

      DATA AMTS/1310.4D0,1272.9D0,1520.4D0,1430.D0/,AMCRS/750D0/

      data icall/0/

C

C   NOTE : A2(1320),F(1270),FP(1525),K*(1430): IN=1,2,3,4 RESP.

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

C

C     ANTI-SYMMETRIC SPIN-ORBIT MASS DIFFERENCE FACTOR:

      SOALL = 0.5D0*(AMNN/AMLN-AMLN/AMNN)

      SOALS = 0.5D0*(AMNN/AMH -AMH /AMNN)

      SOASS = 0.5D0*(AMNN/AMSN-AMSN/AMNN)

C

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GDLL = 0.D0        

      GDFLL= 0.D0

      GFDLL= 0.D0

      GFLL = 0.D0

      GDSS = -2*GT(1)*GT(2)

      GDFSS= -2*GT(1)*FT(2)

      GFDSS= -2*FT(1)*GT(2)

      GFSS = -2*FT(1)*FT(2)

      GDLS = -GT(1)*GT(3)*SR3

      GDFLS= -GT(1)*FT(3)*SR3

      GFDLS= -FT(1)*GT(3)*SR3

      GFLS = -FT(1)*FT(3)*SR3

      GDDR = GT(1)*GT(2)

      GDFDR= GT(1)*FT(2)

      GFDDR= FT(1)*GT(2)

      GFDR = FT(1)*FT(2)

      XM1(1)=AM(1)

      XM1(2)=AM(1)

      XM1(3)=AM(1)

      XM2(1)=AMY(1)

      XM2(2)=AMY(1)

      XM2(3)=AMH   

      GOTO 1055

1052  GDLL = GT(6)*GT(7) 

      GDFLL= GT(6)*FT(7)

      GFDLL= FT(6)*GT(7)

      GFLL = FT(6)*FT(7)

      GDSS = GT(6)*GT(8)

      GDFSS= GT(6)*FT(8)

      GFDSS= FT(6)*GT(8)

      GFSS = FT(6)*FT(8)

      GDLS = 0.D0

      GDFLS= 0.D0

      GFDLS= 0.D0

      GFLS = 0.D0

      GDDR = GDSS       

      GDFDR= GDFSS      

      GFDDR= GFDSS      

      GFDR = GFSS        

      GOTO 1055

1053  GDLL = GT(9)*GT(10) 

      GDFLL= GT(9)*FT(10)

      GFDLL= FT(9)*GT(10)

      GFLL = FT(9)*FT(10)

      GDSS = GT(9)*GT(11)

      GDFSS= GT(9)*FT(11)

      GFDSS= FT(9)*GT(11)

      GFSS = FT(9)*FT(11)

      GDLS = 0.D0

      GDFLS= 0.D0

      GFDLS= 0.D0

      GFLS = 0.D0

      GDDR = GDSS       

      GDFDR= GDFSS      

      GFDDR= GFDSS      

      GFDR = GFSS        

      GOTO 1055

1054  GDLL = GT(4)*GT(4)*P

      GDFLL= GT(4)*FT(4)*P

      GFDLL= FT(4)*GT(4)*P

      GFLL = FT(4)*FT(4)*P

      GDSS = -GT(5)*GT(5)*P

      GDFSS= -GT(5)*FT(5)*P

      GFDSS= -FT(5)*GT(5)*P

      GFSS = -FT(5)*FT(5)*P

      GDLS = -GT(4)*GT(5)*P*SR3

      GDFLS= -GT(4)*FT(5)*P*SR3

      GFDLS= -FT(4)*GT(5)*P*SR3

      GFLS = -FT(4)*FT(5)*P*SR3

      GDDR = -2*GDSS       

      GDFDR= -2*GDFSS      

      GFDDR= -2*GFDSS      

      GFDR = -2*GFSS        

      XM1(1)=AMLN 

      XM1(2)=AMSN  

      XM1(3)=AMLS 

      XM2(1)=AMLN  

      XM2(2)=AMSN  

      XM2(3)=AMLS  

C

1055  FTS(IN) = 1.D0

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN        

       ALAM = ALMV8

       IF(IN.EQ.2) ALAM = ALMV1

       IF(IN.EQ.4) ALAM = ALMKS

      ENDIF

c     alam = 600d0

c     if(icall.eq.0) write(*,*) ' TENSOR: alam=600!'

c     icall=1

      ALM1 = ALAM

      ALM2 = ALAM

      ALM3 = ALAM



      RATM1=AMTS(IN)/ALM1

      RATM2=AMTS(IN)/ALM2

      RATM3=AMTS(IN)/ALM3

      FAC0=AMTS(IN)*AMTS(IN)/AMPRO/AMPRO

      FAC1=AMTS(IN)*AMTS(IN)/(XM1(1)*XM2(1))

      FAC2=AMTS(IN)*AMTS(IN)/(XM1(2)*XM2(2))

      FAC3=AMTS(IN)*AMTS(IN)/(XM1(3)*XM2(3))

C

c     CCNN1=-FAC1*(5*GDNN/6.D0+(GFDNN+GDFNN)*DSQRT(XM1*XM2)

c    .       /6.D0/AMPRO)

c?    CCLL1=-FAC1*5*GDLL/6.D0-(GFDLL/XM1(1)+GDFLL/XM2(1))

c?   .       *AMTS(IN)**2/(6.D0*AMPRO)

c?    CCSS1=-FAC2*5*GDSS/6.D0-(GFDSS/XM1(2)+GDFSS/XM2(2))

c?   .       *AMTS(IN)**2/(6.D0*AMPRO)

c?    CCLS1=-FAC3*5*GDLS/6.D0-(GFDLS/XM1(3)+GDFLS/XM2(3))

c?   .       *AMTS(IN)**2/(6.D0*AMPRO)

c?    CCDR1=-FAC2*5*GDDR/6.D0-(GFDDR/XM1(2)+GDFDR/XM2(2))

c?   .       *AMTS(IN)**2/(6.D0*AMPRO)



c     CCNN1=-FAC1*(2*GDNN/3.D0+(GFDNN+GDFNN)*DSQRT(XM1*XM2)

c    .       /6.D0/AMPRO)

      CCLL1=-FAC1*2*GDLL/3.D0-(GFDLL/XM1(1)+GDFLL/XM2(1))

     .       *AMTS(IN)**2/(6.D0*AMPRO)

      CCSS1=-FAC2*2*GDSS/3.D0-(GFDSS/XM1(2)+GDFSS/XM2(2))

     .       *AMTS(IN)**2/(6.D0*AMPRO)

      CCLS1=-FAC3*2*GDLS/3.D0-(GFDLS/XM1(3)+GDFLS/XM2(3))

     .       *AMTS(IN)**2/(6.D0*AMPRO)

      CCDR1=-FAC2*2*GDDR/3.D0-(GFDDR/XM1(2)+GDFDR/XM2(2))

     .       *AMTS(IN)**2/(6.D0*AMPRO)



c     CSNN1=-FAC1*(GDNN*AMPRO+GFDNN*XM1+GDFNN*XM2+GFNN*XM1*XM2/AMPRO)

c    .       /AMPRO/12.D0

      CSLL1=-FAC1*(GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1))/AMPRO

     .            +GFLL*XM1(1)*XM2(1)/AMPRO**2)/12.D0

      CSSS1=-FAC2*(GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2))/AMPRO

     .            +GFSS*XM1(2)*XM2(2)/AMPRO**2)/12.D0

      CSLS1=-FAC3*(GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3))/AMPRO

     .            +GFLS*XM1(3)*XM2(3)/AMPRO**2)/12.D0

      CSDR1=-FAC2*(GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2))/AMPRO

     .            +GFDR*XM1(2)*XM2(2)/AMPRO**2)/12.D0



c     CTNN0=-1.50D0*CSNN1

      CTLL0=-1.50D0*CSLL1

      CTSS0=-1.50D0*CSSS1

      CTLS0=-1.50D0*CSLS1

      CTDR0=-1.50D0*CSDR1



c     CONN0= FAC1*(5*GDNN/3.D0+(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO )

      COLL0= FAC1*(5*GDLL/3.D0+(GDFLL*XM2(1)+GFDLL*XM1(1))/AMPRO )

      COSS0= FAC2*(5*GDSS/3.D0+(GDFSS*XM2(2)+GFDSS*XM1(2))/AMPRO )

      COLS0= FAC3*(5*GDLS/3.D0+(GDFLS*XM2(3)+GFDLS*XM1(3))/AMPRO )

      CODR0= FAC2*(5*GDDR/3.D0+(GDFDR*XM2(2)+GFDDR*XM1(2))/AMPRO )



      CALL0= FAC1*( GDLL*SOALL/4.D0 

     .       -(GDFLL-GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO )

      CASS0= FAC1*( GDSS*SOASS/4.D0 

     .       -(GDFSS-GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO )

      CALS0= FAC1*( GDLS*SOALS/4.D0 

     .       -(GDFLS-GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO )

      CADR0= FAC1*( GDDR*SOASS/4.D0 

     .       -(GDFDR-GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO )



C     BROWN, DOWNS AND IDDINGS TERM: COPIED FROM VECTOR CASE (CHECK!!)

C     HERE, INSTEAD OF P, WE HAVE P-x=SPACE-EXCHANGE, L=1 ->

      IF(IN.EQ.4) THEN

c      PX = -1D0

      CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2*

     .       (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1))

      CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2*

     .       (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3))

      CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      ENDIF



c     CO2NN=-FAC1**2*(7*GDNN/6.D0+2*(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO

c    +      +3*GFNN*XM1*XM2/AMPRO/AMPRO)/4.D0

      CO2LL=-FAC1**2*(7*GDLL/6.D0+2*(GDFLL*XM2(1)+GFDLL*XM1(1))/AMPRO

     +      +3*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO)/4.D0

      CO2SS=-FAC2**2*(7*GDSS/6.D0+2*(GDFSS*XM2(2)+GFDSS*XM1(2))/AMPRO

     +      +3*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO)/4.D0

      CO2LS=-FAC3**2*(7*GDLS/6.D0+2*(GDFLS*XM2(3)+GFDLS*XM1(3))/AMPRO

     +      +3*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO)/4.D0

      CO2DR=-FAC2**2*(7*GDDR/6.D0+2*(GDFDR*XM2(2)+GFDDR*XM1(2))/AMPRO

     +      +3*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO)/4.D0



c     FINN0=-(11*GDNN/3.D0)

      FILL0=-(11*GDLL/3.D0)

      FISS0=-(11*GDSS/3.D0)

      FILS0=-(11*GDLS/3.D0)

      FIDR0=-(11*GDDR/3.D0)

C

c*    DO 104 I=2,NMAX

c*    X = XA(I)

      X = XA   

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMTS(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMTS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMTS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMTS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN)

      FTENLL=FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSOLL =FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSO2LL= 3*FTENLL/(X*X)

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN)

      FTENSS=FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSOSS =FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSO2SS= 3*FTENSS/(X*X)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0= FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN)

      FTENLS=FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSOLS =FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMTS(IN)

      FSO2LS= 3*FTENLS/(X*X)

C

      FCLL1= FCLL0  - VKULL*AMTS(IN)

      FCLL2= FCLL1  + (1.5D0-XLAM1*XLAM1)*VKULL*AMTS(IN)/RATM1**2

      FTLL1= FTENLL - XLAM1*XLAM1*VKULL*AMTS(IN)/(3*RATM1*RATM1)

      FOLL1= FSOLL  - VKULL*AMTS(IN)/(2*RATM1*RATM1)

c**   FO2LL1= 3*FTLL1/(X*X)

C

      FCSS1= FCSS0  - VKUSS*AMTS(IN)

      FCSS2= FCSS1  + (1.5D0-XLAM2*XLAM2)*VKUSS*AMTS(IN)/RATM2**2

      FTSS1= FTENSS - XLAM2*XLAM2*VKUSS*AMTS(IN)/(3*RATM2*RATM2)

      FOSS1= FSOSS  - VKUSS*AMTS(IN)/(2*RATM2*RATM2)

      FO2SS1= 3*FTSS1/(X*X)

C

      FCLS1= FCLS0  - VKULS*AMTS(IN)

      FCLS2= FCLS1  + (1.5D0-XLAM3*XLAM3)*VKULS*AMTS(IN)/RATM3**2

      FTLS1= FTENLS - XLAM3*XLAM3*VKULS*AMTS(IN)/(3*RATM3*RATM3)

      FOLS1= FSOLS  - VKULS*AMTS(IN)/(2*RATM3*RATM3)

      FO2LS1= 3*FTLS1/(X*X)

C---------------------------------------------------------------

C     NO K^4-TERMS:

      FCLL2 = 0D0

      FCLS2 = 0D0

      FCSS2 = 0D0

C---------------------------------------------------------------

C

      VCLL    = VCLL  -  2*GDLL*FCLL0/3.D0 + CCLL1*FCLL1

     .                     -GFLL*FAC0*FAC1*FCLL2/96.D0

      VCSS    = VCSS  -  2*GDSS*FCSS0/3.D0 + CCSS1*FCSS1

     .                     -GFSS*FAC0*FAC2*FCSS2/96.D0

      VCLS    = VCLS  -  2*GDLS*FCLS0/3.D0 + CCLS1*FCLS1

     .                     -GFLS*FAC0*FAC3*FCLS2/96.D0

      VCDR    = VCDR  -  2*GDDR*FCSS0/3.D0 + CCDR1*FCSS1

     .                     -GFDR*FAC0*FAC2*FCSS2/96.D0



      VSIGLL  = VSIGLL   +  CSLL1*FCLL1

     .                    -INRS*GFLL*FAC0*FCLL2*FAC1/96.D0

      VSIGSS  = VSIGSS   +  CSSS1*FCSS1

     .                    -INRS*GFSS*FAC0*FCSS2*FAC2/96.D0

      VSIGLS  = VSIGLS   +  CSLS1*FCLS1

     .                    -INRS*GFLS*FAC0*FCLS2*FAC3/96.D0

      VSIGDR  = VSIGDR   +  CSDR1*FCSS1

     .                    -INRS*GFDR*FAC0*FCSS2*FAC2/96.D0



      VTENLL  = VTENLL   +  CTLL0*FTENLL

     .                    +INRS*GFLL*FAC0*FTLL1*FAC1/64.D0

      VTENSS  = VTENSS   +  CTSS0*FTENSS

     .                    +INRS*GFSS*FAC0*FTSS1*FAC2/64.D0

      VTENLS  = VTENLS   +  CTLS0*FTENLS

     .                    +INRS*GFLS*FAC0*FTLS1*FAC3/64.D0

      VTENDR  = VTENDR   +  CTDR0*FTENSS

     .                    +INRS*GFDR*FAC0*FTSS1*FAC2/64.D0



      VSOLL   = VSOLL    +  COLL0*FSOLL

     .                    +3*GFLL*FAC0*FOLL1*FAC1/16.D0

      VSOSS   = VSOSS    +  COSS0*FSOSS

     .                    +3*GFSS*FAC0*FOSS1*FAC2/16.D0

      VSOLS   = VSOLS    +  COLS0*FSOLS

     .                    +3*GFLS*FAC0*FOLS1*FAC3/16.D0

      VSODR   = VSODR    +  CODR0*FSOSS

     .                    +3*GFDR*FAC0*FOSS1*FAC2/16.D0



      VASOLL   = VASOLL  +  CALL0*FSOLL

      VASOSS   = VASOSS  +  CASS0*FSOSS

      VASOLS   = VASOLS  +  CALS0*FSOLS

      VASODR   = VASODR  +  CADR0*FSOSS



      VSO2LL  = VSO2LL   +  CO2LL*FSO2LL

      VSO2SS  = VSO2SS   +  CO2SS*FSO2SS

      VSO2LS  = VSO2LS   +  CO2LS*FSO2LS

      VSO2DR  = VSO2DR   +  CO2DR*FSO2SS

C

C     K*(1430): K_{MU}K_{NU}-TERMS IN TENSOR MESON PROPAGATOR:

C

c     SUPPOSED CAN BE NEGLECTED

C

C--------------------------------------------------------------

C

      IF(NLOC.NE.0) THEN         

      FILL   = FILL     +  REDMM*FILL0*FCLL0/(XM1(1)*XM2(1))

      FISS   = FISS     +  REDMM*FISS0*FCSS0/(XM1(2)*XM2(2))

      FILS   = FILS     +  REDMM*FILS0*FCLS0/(XM1(3)*XM2(3))

      FIDR   = FIDR     +  REDMM*FIDR0*FCSS0/(XM1(2)*XM2(2))

C

      DFILL  = DFILL    -  REDMM*FILL0*FSOLL*X*FAC1/AMTS(IN)

      DFISS  = DFISS    -  REDMM*FISS0*FSOSS*X*FAC2/AMTS(IN)

      DFILS  = DFILS    -  REDMM*FILS0*FSOLS*X*FAC3/AMTS(IN)

      DFIDR  = DFIDR    -  REDMM*FIDR0*FSOSS*X*FAC2/AMTS(IN)

      ENDIF

C--------------------------------------------------------------

C     ZERO IN FORM-FACTOR:

      IF(IZTEN.NE.0) THEN      

      FZERO = (AMTS(IN)/AMCRS)**2



      VCLL= VCLL - FZERO*(2*GDLL*FCLL1/3.D0+CCLL1*FCLL2)

      VCSS= VCSS - FZERO*(2*GDSS*FCSS1/3.D0+CCSS1*FCSS2)

      VCLS= VCLS - FZERO*(2*GDLS*FCLS1/3.D0+CCLS1*FCLS2)

      VCDR= VCDR - FZERO*(2*GDDR*FCSS1/3.D0+CCDR1*FCSS2)



      VSIGLL = VSIGLL  +  FZERO*CSLL1*FCLL2

      VSIGSS = VSIGSS  +  FZERO*CSSS1*FCSS2

      VSIGLS = VSIGLS  +  FZERO*CSLS1*FCLS2

      VSIGDR = VSIGDR  +  FZERO*CSDR1*FCSS2



      VTENLL = VTENLL  +  FZERO*CTLL0*FTLL1

      VTENSS = VTENSS  +  FZERO*CTSS0*FTSS1

      VTENLS = VTENLS  +  FZERO*CTLS0*FTLS1

      VTENDR = VTENDR  +  FZERO*CTDR0*FTSS1



      VSOLL  = VSOLL   +  FZERO*COLL0*FOLL1

      VSOSS  = VSOSS   +  FZERO*COSS0*FOSS1

      VSOLS  = VSOLS   +  FZERO*COLS0*FOLS1

      VSODR  = VSODR   +  FZERO*CODR0*FOSS1



      VASOLL = VASOLL  +  FZERO*CALL0*FOLL1

      VASOSS = VASOSS  +  FZERO*CASS0*FOSS1

      VASOLS = VASOLS  +  FZERO*CALS0*FOLS1

      VASODR = VASODR  +  FZERO*CADR0*FOSS1



c*    VSO2LL = VSO2LL  +  FZERO*CO2LL*FO2LL1

c*    VSO2SS = VSO2SS  +  FZERO*CO2SS*FO2SS1

c*    VSO2LS = VSO2LS  +  FZERO*CO2LS*FO2LS1

c*    VSO2DR = VSO2DR  +  FZERO*CO2DR*FO2SS1



c*    IF(NLOC.NE.0) THEN

c*    FILL = FILL + FZERO*REDMM*FILL0*FCLL1/(XM1(1)*XM2(1))

c*    FISS = FISS + FZERO*REDMM*FISS0*FCSS1/(XM1(2)*XM2(2))

c*    FILS = FILS + FZERO*REDMM*FILS0*FCLS1/(XM1(3)*XM2(3))

c*    FIDR = FIDR + FZERO*REDMM*FIDR0*FCSS1/(XM1(2)*XM2(2))

C

c*    DFILL= DFILL- FZERO*REDMM*FILL0*FOLL1*FAC1/AMTS(IN)

c*    DFISS= DFISS- FZERO*REDMM*FISS0*FOSS1*X*FAC2/AMTS(IN)

c*    DFILS= DFILS- FZERO*REDMM*FILS0*FOLS1*X*FAC3/AMTS(IN)

c*    DFIDR= DFIDR- FZERO*REDMM*FIDR0*FOSS1*X*FAC2/AMTS(IN)

c*    ENDIF

      ENDIF

C--------------------------------------------------------------

C--------------------------------------------------------------

c     print spin-orbit potentials:

c     write(*,*) ' TENSOR : x=',xa,' IN=',in,' vsoll=',vsoll,

c    .' vasoll=',vasoll



  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END





C***********************************************************************

C

C  PROGRAM: OBE00.F                  

C

C  updated december 2000, from YNRMP2k2.f , introducing mass               

C  differences in meson propagators in the OBE-potentials, 

C  according to Macke-Klein

C

C  updated june 2004, from obe00.f, introducing a zero in AXIAL-EXCH.  

C  updated oct  2004, introducing diffractive singlet+nonet  



C  updated jan  2007, for dealing with very heavy meson masses

C *********************************************************************

C *********************************************************************

C

      SUBROUTINE BIGMASS(XA,AMES,ALAM,FICN,FITN,FILS)    

C

C**********************************************************************

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/PIMAS/PIM

      DATA SRPI/1.772454D0/

CC

      XLAM = 0.5D0*XA*ALAM/PIM

      XLAM2= XLAM*XLAM

      ELAM = FDEXP(-XLAM2)

      FICN = (ALAM/AMES)**3*ELAM/(2*SRPI)

      FITN = (ALAM/AMES)**5*XLAM2*ELAM/(6*SRPI)

      FILS = (ALAM/AMES)**5*ELAM/(4*SRPI)



      FIC1 = -(ALAM/AMES)**5*(3D0-2*XLAM2)*ELAM/(4*SRPI)



      RETURN

      END

C *********************************************************************

C

      SUBROUTINE PSSCAL(XA,ICSB,NLOC,LC) 

C

C**********************************************************************

C  updated december 2000, from YNRMP2k2.f , introducing mass               

C  differences in meson propagators in the OBE-potentials, 

C  according to Macke-Klein 

C----------------------------------------------------------------------

C

C     PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB

     .             ,CORTPS,CORTV,CORTA,CORTB

      DIMENSION F(11),AMPS(5)

      EQUIVALENCE (F1,F(1))

      DATA SR3/1.732051D0/,SRPI/1.772454D0/

      DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/

c**   DATA DAMLN/0.D0/,DAMSN/0.D0/,DAMSL/0.D0/

      DATA ICALL/0/



      DATA NAPION/1/,AMCRP/750.D0/

C

C   NOTE : PION(IN=1),ETA (IN=2),ETAP(IN=3),KAON(IN=4)               

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C------------------------------------------------------------------

C   THE POTENTIAL FUNCTIONS

C

c     FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

c     FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

c    . *(1.D0+XH)-EXH*EP*(1.D0-XH)-4.D0*XLAMH*EXLAM/ERATH/SRPI)

c    .  /(2.D0*XH*XH*XH)

c     FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

c    .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

c    .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

c    .  1.7724538509D0)/(2.D00*XH*XH*XH)

C------------------------------------------------------------------

C

      DIV1 = 1D0/AMLN**2

      DIV2 = 1D0/AMSN**2

      DIV3 = 1D0/AMLS**2

      SR3 = DSQRT(3.D0)

      SRPI= DSQRT(DACOS(-1.D0))

      IF(LC.EQ.1) SIGN= 1.D0

      IF(LC.NE.1) SIGN=-1.D0

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GPLL = -0.0271D0*ICSB*F1*F3

      GPSS= -2*F1*F2

      GPLS= -SR3*F1*F3                  

      GPDR=      F1*F2

      AMPS(1)=AMPI

      GPLL = GPLL*(AMPS(1)/PIM)**0

      GPSS = GPSS*(AMPS(1)/PIM)**0

      GPLS = GPLS*(AMPS(1)/PIM)**0

      GPDR = GPDR*(AMPS(1)/PIM)**0

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1052  GPLL=  F6*F7*(AME/PIM)**0

      GPSS=  F6*F8*(AME/PIM)**0

      GPLS=  0.D0

      GPDR=  F6*F8*(AME/PIM)**0

      AMPS(2)=AME

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1053  GPLL=  F9*F10*(AMX/PIM)**0

      GPSS=  F9*F11*(AMX/PIM)**0

      GPLS=  0.D0

      GPDR=  F9*F11*(AMX/PIM)**0

      AMPS(3)=AMX

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP1

      GOTO 1056

1054  GPLL=      F4*F4*P*(BMK/PIM)**0

      GPSS=     -F5*F5*P*(BMK/PIM)**0

      GPLS= -SR3*F4*F5*P*(BMK/PIM)**0

      GPDR=    2*F5*F5*P*(BMK/PIM)**0

      AMPS(4)=BMK

      IF(IMODEL.EQ.1) ALAM=ALMOBE

      IF(IMODEL.GE.2) ALAM=ALMKA

      GOTO 1056

C

1056  ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

      RATM1=AMPS(IN)/ALM1

      RATM2=AMPS(IN)/ALM2

      RATM3=AMPS(IN)/ALM3

      FAC1=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(1))

      FAC2=AMPS(IN)*AMPS(IN)/(AM(1)*AMY(2))

      FAC3=AMPS(IN)*AMPS(IN)/(AM(1)*AMH)

C

      AMES = AMPS(IN)

c     DO 104 I=2,NMAX

c     X = XA(I)

      CALL FUNPS2(2,XA,AMES,ALM1,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO)

      FCLL0 = PIM*FC0

      FCLL1 = PIM*FC1

      FTENLL = PIM*FTEN

      FSOLL  = PIM*FSO

      DFCLL1 = PIM**2*DFC1

      DFTENLL= PIM**2*DFTEN

C

      CALL FUNPS2(2,XA,AMES,ALM2,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO)

      FCSS0 = PIM*FC0

      FCSS1 = PIM*FC1

      FTENSS = PIM*FTEN

      FSOSS  = PIM*FSO

      DFCSS1 = PIM**2*DFC1

      DFTENSS= PIM**2*DFTEN

C

      CALL FUNPS2(2,XA,AMES,ALM3,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO)

      FCLS0 = PIM*FC0

      FCLS1 = PIM*FC1

      FTENLS = PIM*FTEN

      FSOLS  = PIM*FSO

      DFCLS1 = PIM**2*DFC1

      DFTENLS= PIM**2*DFTEN

C

C------------------------------------------------------------

C     THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS:

      IF(IDAM.NE.0.AND.IN.NE.4) THEN

      CALL YMKFUN(XA,AMPS(IN),ALAM,SIGN,IDAM*DAMSL,

     .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1)

C------------------------------------------------------------

      IF(LC.EQ.1) THEN

      FCSS1 = AMPS(IN)*FXC1 

      FTENSS = AMPS(IN)*FXTEN             

      ENDIF

      IF(LC.NE.1) THEN

      FCLL1 = AMPS(IN)*FXC1 

      FTENLL = AMPS(IN)*FXTEN             

      ENDIF

      FCLS1  = 0.5D0*(FCLS1 + AMPS(IN)*FXC1 )     

      FTENLS = 0.5D0*(FTENLS+ AMPS(IN)*FXTEN)     

      ENDIF

C------------------------------------------------------------

C

        VSIGLL  = VSIGLL + GPLL*FCLL1/3.D0

        VTENLL  = VTENLL + GPLL*FTENLL

        VSIGDR  = VSIGDR + GPDR*FCSS1/3.D0

        VTENDR  = VTENDR + GPDR*FTENSS

        VSIGSS  = VSIGSS + GPSS*FCSS1/3.D0

        VTENSS  = VTENSS + GPSS*FTENSS

        VSIGLS  = VSIGLS + GPLS*FCLS1/3.D0

        VTENLS  = VTENLS + GPLS*FTENLS

C-----------------------------------------------------------------

C

C     NONLOCAL TERMS PSEUDOSCALAR MESONS:

C

C-----------------------------------------------------------------

      IF(NAPION.EQ.1) THEN

C-----------------------------------------------------------------

C     GRAZ 1978:

c     corrps= 1.d0

      FISLL = FISLL  -corsps*REDM(1)*GPLL*FCLL1*DIV1/6D0

      FITLL = FITLL  -cortps*REDM(1)*GPLL*FTENLL*DIV1/2D0

      DFISLL= DFISLL -corsps*REDM(1)*GPLL*DFCLL1*DIV1/6D0

      DFITLL= DFITLL -cortps*REDM(1)*GPLL*DFTENLL*DIV1/2D0

      FISSS = FISSS  -corsps*REDM(2)*GPSS*FCSS1*DIV2/6D0

      FITSS = FITSS  -cortps*REDM(2)*GPSS*FTENSS*DIV2/2D0

      DFISSS= DFISSS -corsps*REDM(2)*GPSS*DFCSS1*DIV2/6D0

      DFITSS= DFITSS -cortps*REDM(2)*GPSS*DFTENSS*DIV2/2D0

      FISLS = FISLS  -corsps*REDMM  *GPLS*FCLS1*DIV3/6D0

      FITLS = FITLS  -cortps*REDMM  *GPLS*FTENLS*DIV3/2D0

      DFISLS= DFISLS -corsps*REDMM  *GPLS*FCLS1*DIV3/6D0

      DFITLS= DFITLS -cortps*REDMM  *GPLS*DFCLS1*DIV3/6D0

      FISDR = FISDR  -corsps*REDMM  *GPDR*FCLS1*DIV2/6D0

      FITDR = FITDR  -cortps*REDMM  *GPDR*FTENLS*DIV2/2D0

      DFISDR= DFISDR -corsps*REDMM  *GPDR*FCLS1*DIV2/6D0

      DFITDR= DFITDR -cortps*REDMM  *GPDR*DFCLS1*DIV2/6D0

C     END GRAZ 1978.

      ENDIF

C-----------------------------------------------------------------

C------------------------------------------------------------

C     BROWN, DOWNS AND IDDINGS TERM:

      IF(IN.EQ.4) THEN

C     HERE INSTEAD OF P, WE MUST TAKE P_x=SPACE-EXCHANGE: L=1 -> -1:

c     PX = -1D0

        VASOLL  = VASOLL - PX*GPLL*FSOLL*

     .               4*(AMY(1)-AM(1))/(AMY(1)+AM(1))

        VASOSS  = VASOSS - PX*GPSS*FSOSS*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

        VASOLS  = VASOLS - PX*GPLS*FSOLS*

     .               4*(AMY(3)-AM(3))/(AMY(3)+AM(3))

        VASODR  = VASODR - PX*GPDR*FSOSS*

     .               4*(AMY(2)-AM(2))/(AMY(2)+AM(2))

      ENDIF

C

C------------------------------------------------------------

C     ZERO IN FORM-FACTOR:

      IF(IZPS.EQ.1) THEN

      FZERO = (AMPS(IN)/AMCRP)**2

      FC2   = FCLL1 + (1.5D0-XLAM1*XLAM1)

     .              * VKULL*AMPS(IN)/RATM1/RATM1

      FT1   = FTENLL - XLAM1*XLAM1 * VKULL*AMPS(IN)

     .               /(3*RATM1*RATM1)

        VSIGLL  = VSIGLL + FZERO*GPLL*FC2/3.D0

        VTENLL  = VTENLL + FZERO*GPLL*FT1     

        VSIGDR  = VSIGDR + FZERO*GPDR*FC2/3.D0

        VTENDR  = VTENDR + FZERO*GPDR*FT1     

        VSIGSS  = VSIGSS + FZERO*GPSS*FC2/3.D0

        VTENSS  = VTENSS + FZERO*GPSS*FT1     

        VSIGLS  = VSIGLS + FZERO*GPLS*FC2/3.D0

        VTENLS  = VTENLS + FZERO*GPLS*FT1     

      ENDIF

C

  104 CONTINUE

C

 1040 CONTINUE

C

      ICALL = 1

      RETURN

      END

C**********************************************************************

C

      SUBROUTINE VECTOR(XA,ICSB,NLOC,LC) 

C

C**********************************************************************

C  updated december 2000, from YNRMP2k2.f , introducing mass               

C  differences in meson propagators in the OBE-potentials, 

C  according to Macke-Klein 

C----------------------------------------------------------------------

C

C     VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI,AMKS,BMKS

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      DIMENSION FD(11),FV(11)

      DIMENSION AMVC(5),FVC(5),XM1(3),XM2(3)

      EQUIVALENCE (FD1,FD(1)),(FV1,FV(1))

      DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/

      DATA SR3/1.732050808D0/,SRPI/1.77245385D0/,AMPRO/938.2796D0/

     .,FMNL/1.D0/,AMCRV/750.D0/

C

C   NOTE : RHO1(IN=1),RHO2(IN=2),OME(IN=3),PHI(IN=4),KSTAR(IN=5)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C-------------------------------------------------------------------

C   NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> HYPERONS !

C                                 : INDEX 2,4 -> NUCLEONS !

C-------------------------------------------------------------------

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

C

      IF(LC.EQ.1) SIGN= 1.D0

      IF(LC.NE.1) SIGN=-1.D0

C

      PROSLL=-(AM(1)-AMY(1))*(AMY(1)-AM(1))/AMKS/AMKS

      PROSSS=-(AMNN -AMSS  )*(AMSS  -AMNN )/AMKS/AMKS

      PROSLS=-(AMNN -AMY(1))*(AMSS  -AM(1))/AMKS/AMKS

C

      IF(IRET.EQ.1) THEN

      WKIN1 = PIM**2*AKS(1)/(2*REDM(1))

      WKIN2 = PIM**2*AKS(3)/(2*REDM(3))

      WKIN3 = 0.5D0*(WKIN1+WKIN2)

      ENDIF

C

      DO 1040 IN=1,5

      IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMSS

c**   XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

      ENDIF

      GOTO(1051,1051,1053,1054,1055),IN

1051  GDLL = -0.0271D0*ICSB*FD1*FD3

      GDFLL= -0.0271D0*ICSB*FD1*FV3

      GFDLL= -0.0271D0*ICSB*FV1*FD3

      GFLL = -0.0271D0*ICSB*FV1*FV3

      GDSS = -2*FD1*FD2

      GDFSS= -2*FD1*FV2

      GFDSS= -2*FV1*FD2

      GFSS = -2*FV1*FV2

      GDLS = -FD1*FD3*SR3

      GDFLS= -FD1*FV3*SR3

      GFDLS= -FV1*FD3*SR3

      GFLS = -FV1*FV3*SR3

      GDDR =  FD1*FD2

      GDFDR=  FD1*FV2

      GFDDR=  FV1*FD2

      GFDR =  FV1*FV2

      IF(IN.EQ.1) THEN

      FVC(1)=ARO

      AMVC(1)=AM1RO

      ELSE

      FVC(2)=BRO

      AMVC(2)=AM2RO

      ENDIF

      GOTO 1056

1053  GDLL =  FD6*FD7

      GDFLL=  FD6*FV7

      GFDLL=  FV6*FD7

      GFLL =  FV6*FV7

      GDSS =  FD6*FD8

      GDFSS=  FD6*FV8

      GFDSS=  FV6*FD8

      GFSS =  FV6*FV8

      GDLS =  0.D0

      GDFLS=  0.D0

      GFDLS=  0.D0

      GFLS =  0.D0

      GDDR =  GDSS

      GDFDR=  GDFSS

      GFDDR=  GFDSS

      GFDR =  GFSS

      FVC(3)=1.D0

      AMVC(3)=AMOM

      GOTO 1056

1054  GDLL =  FD9*FD10

      GDFLL=  FD9*FV10

      GFDLL=  FV9*FD10

      GFLL =  FV9*FV10

      GDSS =  FD9*FD11

      GDFSS=  FD9*FV11

      GFDSS=  FV9*FD11

      GFSS =  FV9*FV11

      GDLS =  0.D0

      GDFLS=  0.D0

      GFDLS=  0.D0

      GFLS =  0.D0

      GDDR =  GDSS

      GDFDR=  GDFSS

      GFDDR=  GFDSS

      GFDR =  GFSS

      FVC(4)=1.D0

      AMVC(4)=AMFI

      GOTO 1056

1055  GDLL =  FD4*FD4*P

      GDFLL=  FD4*FV4*P

      GFDLL=  FV4*FD4*P

      GFLL =  FV4*FV4*P

      GDSS = -FD5*FD5*P

      GDFSS= -FD5*FV5*P

      GFDSS= -FV5*FD5*P

      GFSS = -FV5*FV5*P

      GDLS = -FD4*FD5*P*SR3

      GDFLS= -FD4*FV5*P*SR3

      GFDLS= -FV4*FD5*P*SR3

      GFLS = -FV4*FV5*P*SR3

      GDDR = -2*GDSS

      GDFDR= -2*GDFSS

      GFDDR= -2*GFDSS

      GFDR = -2*GFSS

      FVC(5)=1.D0

      AMVC(5)=BMKS

C     CASE IN=5:

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMSN

c**   XM1(3)=(AMSN+AMLS)/2.D0

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMSN

c**   XM2(3)=(AMSN+AMLS)/2.D0

C

1056  AMVC2 = AMVC(IN)*AMVC(IN)

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN

       ALAM = ALMV8

       IF(IN.EQ.3) ALAM=ALMV1

       IF(IN.EQ.5) ALAM=ALMKS

      ENDIF

      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM



      RATM1=AMVC(IN)/ALM1

      RATM2=AMVC(IN)/ALM2

      RATM3=AMVC(IN)/ALM3

      FAC0=AMVC(IN)*AMVC(IN)/AMPRO/AMPRO

      FAC1=AMVC(IN)*AMVC(IN)/(XM1(1)*XM2(1))

      FAC2=AMVC(IN)*AMVC(IN)/(XM1(2)*XM2(2))

      FAC3=AMVC(IN)*AMVC(IN)/(XM1(3)*XM2(3))

      FFAC1 = XM2(1)/XM1(1)-XM1(1)/XM2(1)                 

      FFAC2 = XM2(2)/XM1(2)-XM1(2)/XM2(2)                 

      FFAC3 = XM2(3)/XM1(3)-XM1(3)/XM2(3)                 

C

c     23/4/2001: wrong:

c     CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM1(1)+GDFLL/XM2(1))*AMVC(IN)**2

c    .      /(4.*AMPRO)

c     CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM1(2)+GDFSS/XM2(2))*AMVC(IN)**2

c    .      /(4.*AMPRO)

c     CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM1(3)+GDFLS/XM2(3))*AMVC(IN)**2

c    .      /(4.*AMPRO)

c     CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM1(2)+GDFDR/XM2(2))*AMVC(IN)**2

c    .      /(4.*AMPRO)

c     CSLL1= GDLL+(GFDLL*XM1(1)+GDFLL*XM2(1)+GFLL*XM1(1)*XM2(1)/AMPRO)

c    .       /AMPRO

c     CSSS1= GDSS+(GFDSS*XM1(2)+GDFSS*XM2(2)+GFSS*XM1(2)*XM2(2)/AMPRO)

c    .       /AMPRO

c     CSLS1= GDLS+(GFDLS*XM1(3)+GDFLS*XM2(3)+GFLS*XM1(3)*XM2(3)/AMPRO)

c    .       /AMPRO

c     CSDR1= GDDR+(GFDDR*XM1(2)+GDFDR*XM2(2)+GFDR*XM1(2)*XM2(2)/AMPRO)

c    .       /AMPRO

 

c     23/4/2001: mass goes wth f-coupling: f13 -> 1/M_Y,f24 -> 1/M_N:

      CCLL1=0.5D0*GDLL*FAC1+(GFDLL/XM2(1)+GDFLL/XM1(1))*AMVC2           

     .      /(4.*AMPRO)

      CCSS1=0.5D0*GDSS*FAC2+(GFDSS/XM2(2)+GDFSS/XM1(2))*AMVC2       

     .      /(4.*AMPRO)

      CCLS1=0.5D0*GDLS*FAC3+(GFDLS/XM2(3)+GDFLS/XM1(3))*AMVC2        

     .      /(4.*AMPRO)

      CCDR1=0.5D0*GDDR*FAC2+(GFDDR/XM2(2)+GDFDR/XM1(2))*AMVC2        

     .      /(4.*AMPRO)

c     23/4/2001: mass goes wth f-coupling: f13 -> 1/M_Y,f24 -> 1/M_N:

      CSLL1= GDLL+(GFDLL*XM2(1)+GDFLL*XM1(1)+GFLL*XM1(1)*XM2(1)/AMPRO)

     .       /AMPRO

      CSSS1= GDSS+(GFDSS*XM2(2)+GDFSS*XM1(2)+GFSS*XM1(2)*XM2(2)/AMPRO)

     .       /AMPRO

      CSLS1= GDLS+(GFDLS*XM2(3)+GDFLS*XM1(3)+GFLS*XM1(3)*XM2(3)/AMPRO)

     .       /AMPRO

      CSDR1= GDDR+(GFDDR*XM2(2)+GDFDR*XM1(2)+GFDR*XM1(2)*XM2(2)/AMPRO)

     .       /AMPRO



      CTLL0= CSLL1

      CTSS0= CSSS1

      CTLS0= CSLS1

      CTDR0= CSDR1

      COLL0= 1.5D0*GDLL+(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO

      COSS0= 1.5D0*GDSS+(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO

      COLS0= 1.5D0*GDLS+(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO

      CODR0= 1.5D0*GDDR+(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO



      CALL0= 

     .GDLL*FFAC1/4D0-(GFDLL-GDFLL)*DSQRT(XM1(1)*XM2(1))/AMPRO

      CASS0= 

     .GDSS*FFAC2/4D0-(GFDSS-GDFSS)*DSQRT(XM1(2)*XM2(2))/AMPRO

      CALS0= 

     .GDLS*FFAC3/4D0-(GFDLS-GDFLS)*DSQRT(XM1(3)*XM2(3))/AMPRO

      CADR0= 

     .GDDR*FFAC2/4D0-(GFDDR-GDFDR)*DSQRT(XM1(2)*XM2(2))/AMPRO

      CALL1= GFLL*FFAC1*AMVC2/(16*AMPRO*AMPRO)

      CASS1= GFSS*FFAC2*AMVC2/(16*AMPRO*AMPRO)

      CALS1= GFLS*FFAC3*AMVC2/(16*AMPRO*AMPRO)

      CADR1= GFDR*FFAC2*AMVC2/(16*AMPRO*AMPRO)



C     BROWN, DOWNS AND IDDINGS TERM:

      IF(IN.EQ.5) THEN

C     HERE INSTEAD OF P, WE MUST TAKE P_x=SPACE-EXCHANGE: L=1 -> -1:

c     PX = -1D0

      CALL0= CALL0+PX*(GDLL+0.5d0*GFLL*(XM1(1)+XM2(1))/AMPRO)**2*

     .       (1.d0+FAC1/16.D0)*(XM1(1)-XM2(1))/(XM1(1)+XM2(1))

      CASS0= CASS0+PX*(GDSS+0.5d0*GFSS*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      CALS0= CALS0+PX*(GDLS+0.5d0*GFLS*(XM1(3)+XM2(3))/AMPRO)**2*

     .       (1.d0+FAC3/16.D0)*(XM1(3)-XM2(3))/(XM1(3)+XM2(3))

      CADR0= CADR0+PX*(GDDR+0.5d0*GFDR*(XM1(2)+XM2(2))/AMPRO)**2*

     .       (1.d0+FAC2/16.D0)*(XM1(2)-XM2(2))/(XM1(2)+XM2(2))

      ENDIF



      CO2LL= GDLL+4*(GDFLL+GFDLL)*DSQRT(XM1(1)*XM2(1))/AMPRO +

     +       8*GFLL*XM1(1)*XM2(1)/AMPRO/AMPRO

      CO2SS= GDSS+4*(GDFSS+GFDSS)*DSQRT(XM1(2)*XM2(2))/AMPRO +

     +       8*GFSS*XM1(2)*XM2(2)/AMPRO/AMPRO

      CO2LS= GDLS+4*(GDFLS+GFDLS)*DSQRT(XM1(3)*XM2(3))/AMPRO +

     +       8*GFLS*XM1(3)*XM2(3)/AMPRO/AMPRO

      CO2DR= GDDR+4*(GDFDR+GFDDR)*DSQRT(XM1(2)*XM2(2))/AMPRO +

     +       8*GFDR*XM1(2)*XM2(2)/AMPRO/AMPRO

C

c     DO 104 I=2,NMAX

c     X = XA(I)

      X = XA   

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMVC(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMVC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMVC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMVC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENLL = FVC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOLL  = FVC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2LL = 3*FTENLL/(X*X)

C



      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENSS = FVC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOSS  = FVC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2SS = 3*FTENSS/(X*X)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)

      FTENLS = FVC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSOLS  = FVC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMVC(IN)

      FSO2LS = 3*FTENLS/(X*X)

C

      FCLL1  = FCLL0  - FVC(IN)*VKULL*AMVC(IN)

      FCSS1  = FCSS0  - FVC(IN)*VKUSS*AMVC(IN)

      FCLS1  = FCLS0  - FVC(IN)*VKULS*AMVC(IN)

      FCLL2  = FCLL1+

     .         FVC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMVC(IN)/RATM1/RATM1

      FCSS2  = FCSS1+

     .         FVC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMVC(IN)/RATM2/RATM2

      FCLS2  = FCLS1+

     .         FVC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMVC(IN)/RATM3/RATM3

      FTLL1  = FTENLL - FVC(IN)*XLAM1*XLAM1*VKULL*AMVC(IN)

     .                / (3*RATM1*RATM1)

      FTSS1  = FTENSS - FVC(IN)*XLAM2*XLAM2*VKUSS*AMVC(IN)

     .                / (3*RATM2*RATM2)

      FTLS1  = FTENLS - FVC(IN)*XLAM3*XLAM3*VKULS*AMVC(IN)

     .                / (3*RATM3*RATM3)

      FOLL1  = FSOLL  - FVC(IN)*VKULL*AMVC(IN)

     .                / (2*RATM1*RATM1)

      FOSS1  = FSOSS  - FVC(IN)*VKUSS*AMVC(IN)

     .                / (2*RATM2*RATM2)

      FOLS1  = FSOLS  - FVC(IN)*VKULS*AMVC(IN)

     .                / (2*RATM3*RATM3)

C

C------------------------------------------------------------

C     THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS:

c**   IF(IN.NE.5) THEN

      IF(IDAM.NE.0.AND.IN.NE.5) THEN

      CALL YMKFUN(XA,AMVC(IN),ALAM,SIGN,IDAM*DAMSL,

     .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1)

      FXSO2 = 3*FXTEN/(X*X)

C------------------------------------------------------------

      IF(LC.EQ.1) THEN

      FCSS0 = FVC(IN)*AMVC(IN)*FXC0 

      FTENSS= FVC(IN)*AMVC(IN)*FXTEN             

      FSOSS = FVC(IN)*AMVC(IN)*FXSO              

      FSO2SS= FVC(IN)*AMVC(IN)*FXSO2             

      FCSS1 = FVC(IN)*AMVC(IN)*FXC1 

      FCSS2 = FVC(IN)*AMVC(IN)*FXC2   

      FTSS1 = FVC(IN)*AMVC(IN)*FXTEN1

      FOSS1 = FVC(IN)*AMVC(IN)*FXSO1

      ENDIF

      IF(LC.NE.1) THEN

      FCLL0 = FVC(IN)*AMVC(IN)*FXC0 

      FTENLL= FVC(IN)*AMVC(IN)*FXTEN             

      FSOLL = FVC(IN)*AMVC(IN)*FXSO             

      FSO2LL= FVC(IN)*AMVC(IN)*FXSO2             

      FCLL1 = FVC(IN)*AMVC(IN)*FXC1 

      FCLL2 = FVC(IN)*AMVC(IN)*FXC2 

      FTLL1 = FVC(IN)*AMVC(IN)*FXTEN1

      FOLL1 = FVC(IN)*AMVC(IN)*FXSO1

      ENDIF

      FCLS0  = 0.5D0*(FCLS0  + FVC(IN)*AMVC(IN)*FXC0 )     

      FTENLS = 0.5D0*(FTENLS + FVC(IN)*AMVC(IN)*FXTEN)     

      FSOLS  = 0.5D0*(FSOLS  + FVC(IN)*AMVC(IN)*FXSO )      

      FSO2LS = 0.5D0*(FSO2LS + FVC(IN)*AMVC(IN)*FXSO2)      

      FCLS1  = 0.5D0*(FCLS1  + FVC(IN)*AMVC(IN)*FXC1 )     

      FCLS2  = 0.5D0*(FCLS2  + FVC(IN)*AMVC(IN)*FXC2 )     

      FTLS1  = 0.5D0*(FTLS1  + FVC(IN)*AMVC(IN)*FXTEN1)    

      FOLS1  = 0.5D0*(FOLS1  + FVC(IN)*AMVC(IN)*FXSO1)     

      ENDIF

C------------------------------------------------------------

C

      VCLL  = VCLL   + GDLL*FCLL0 + CCLL1*FCLL1 +

     .                       GFLL*FAC0*FAC1*FCLL2/16.D0

     .                     + (1-INRS)*FAC1*(GDLL*FAC1/64.D0+(GDFLL

     .                       +GFDLL)*DSQRT(FAC0*FAC1)/16.D0)*FCLL2

      VCSS  = VCSS   + GDSS*FCSS0 + CCSS1*FCSS1 +

     .                       GFSS*FAC0*FAC2*FCSS2/16.D0

     .                     + (1-INRS)*FAC2*(GDSS*FAC2/64.D0+(GDFSS

     .                       +GFDSS)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2

      VCLS  = VCLS   + GDLS*FCLS0 + CCLS1*FCLS1 +

     .                       GFLS*FAC0*FAC3*FCLS2/16.D0

     .                     + (1-INRS)*FAC3*(GDLS*FAC3/64.D0+(GDFLS

     .                       +GFDLS)*DSQRT(FAC0*FAC3)/16.D0)*FCLS2

      VCDR  = VCDR   + GDDR*FCSS0 + CCDR1*FCSS1 +

     .                       GFDR*FAC0*FAC2*FCSS2/16.D0

     .                     + (1-INRS)*FAC2*(GDDR*FAC2/64.D0+(GDFDR

     .                       +GFDDR)*DSQRT(FAC0*FAC2)/16.D0)*FCSS2

C

      VSIGLL= VSIGLL + (CSLL1*FCLL1 + INRS*GFLL*FAC0*FCLL2/8.D0)

     .                     * FAC1/6.D0

      VSIGSS= VSIGSS + (CSSS1*FCSS1 + INRS*GFSS*FAC0*FCSS2/8.D0)

     .                     * FAC2/6.D0

      VSIGLS= VSIGLS + (CSLS1*FCLS1 + INRS*GFLS*FAC0*FCLS2/8.D0)

     .                     * FAC3/6.D0

      VSIGDR= VSIGDR + (CSDR1*FCSS1 + INRS*GFDR*FAC0*FCSS2/8.D0)

     .                     * FAC2/6.D0

C

      VTENLL= VTENLL - (CTLL0*FTENLL + INRS*GFLL*FAC0*FTLL1/8.D0)

     .                     * FAC1/4.D0

      VTENSS= VTENSS - (CTSS0*FTENSS + INRS*GFSS*FAC0*FTSS1/8.D0)

     .                     * FAC2/4.D0

      VTENLS= VTENLS - (CTLS0*FTENLS + INRS*GFLS*FAC0*FTSS1/8.D0)

     .                     * FAC3/4.D0

      VTENDR= VTENDR - (CTDR0*FTENSS + INRS*GFDR*FAC0*FTSS1/8.D0)

     .                     * FAC2/4.D0

C

      VSOLL = VSOLL  - (COLL0*FSOLL + GFLL*FAC0*FOLL1*3/8.D0)

     .                     * FAC1

      VSOSS = VSOSS  - (COSS0*FSOSS + GFSS*FAC0*FOSS1*3/8.D0)

     .                     * FAC2

      VSOLS = VSOLS  - (COLS0*FSOLS + GFLS*FAC0*FOLS1*3/8.D0)

     .                     * FAC3

      VSODR = VSODR  - (CODR0*FSOSS + GFDR*FAC0*FOSS1*3/8.D0)

     .                     * FAC2



c     if(icall.eq.0.and.in.eq.5) then

c     write(*,*) 'vector: in=',in,' amvc=',amvc(in),' coll0=',coll0  

c    .,' alm1=',alm1,' fac1=',fac1

c     write(*,*) ' in=',in,' xa=',xa,' fsoll=',fsoll,' vsoll=',vsoll   

c     write(*,*) 'fvc=',fvc(in),' ex,x,xlam1,derfcm,derfcp,elam=',

c    .                            ex,x,xlam1,derfcm,derfcp,elam    

c     endif

      

C

      VASOLL= VASOLL - (CALL0*FSOLL-CALL1*FOLL1)*FAC1

      VASOSS= VASOSS - (CASS0*FSOSS-CASS1*FOSS1)*FAC2

      VASOLS= VASOLS - (CALS0*FSOLS-CALS1*FOLS1)*FAC3

      VASODR= VASODR - (CADR0*FSOSS-CADR1*FOSS1)*FAC2

C

      VSO2LL= VSO2LL + CO2LL*FSO2LL*FAC1*FAC1/16.D0

      VSO2SS= VSO2SS + CO2SS*FSO2SS*FAC2*FAC2/16.D0

      VSO2LS= VSO2LS + CO2LS*FSO2LS*FAC3*FAC3/16.D0

      VSO2DR= VSO2DR + CO2DR*FSO2SS*FAC2*FAC2/16.D0

C

      IF(IN.NE.5) GOTO 105



C     K-STAR: CONTRIBUTION SECOND TERM IN VECTOR PROPAGATOR

C    

      VCLL   = VCLL - GDLL*PROSLL*(FCLL0-0.25D0*FAC1*FCLL1)

      VCSS   = VCSS - GDSS*PROSSS*(FCSS0-0.25D0*FAC2*FCSS1)

      VCLS   = VCLS - GDLS*PROSLS*(FCLS0-0.25D0*FAC3*FCLS1)

      VCDR   = VCDR - GDDR*PROSSS*(FCSS0-0.25D0*FAC2*FCSS1)

C

      VSOLL   = VSOLL - GDLL*PROSLL*FSOLL*FAC1/2.D0   

      VSOSS   = VSOSS - GDSS*PROSSS*FSOSS*FAC2/2.D0   

      VSOLS   = VSOLS - GDLS*PROSLS*FSOLS*FAC3/2.D0   

      VSODR   = VSODR - GDDR*PROSSS*FSOSS*FAC2/2.D0   

C

      VASOLL  = VASOLL - GDLL*PROSLL*FSOLL*FFAC1*FAC1/4.D0   

      VASOSS  = VASOSS - GDSS*PROSSS*FSOSS*FFAC2*FAC2/4.D0   

      VASOLS  = VASOLS - GDLS*PROSLS*FSOLS*FFAC3*FAC3/4.D0   

      VASODR  = VASODR - GDDR*PROSSS*FSOSS*FFAC2*FAC2/4.D0   

C

      VSO2LL = VSO2LL - GDLL*PROSLL*FSO2LL*FAC1*FAC1/16.D0

      VSO2SS = VSO2SS - GDSS*PROSSS*FSO2SS*FAC2*FAC2/16.D0

      VSO2LS = VSO2LS - GDLS*PROSLS*FSO2LS*FAC3*FAC3/16.D0

      VSO2DR = VSO2DR - GDDR*PROSSS*FSO2SS*FAC2*FAC2/16.D0

C

      IF(NLOC.NE.0) THEN

      FILL = FILL  + 0.5D0*GDLL*PROSLL*FCLL0/(XM1(1)*XM2(1))

      FISS = FISS  + 0.5D0*GDSS*PROSSS*FCSS0/(XM1(2)*XM2(2))

      FILS = FILS  + 0.5D0*GDLS*PROSLS*FCLS0/(XM1(3)*XM2(3))

      FIDR = FIDR  + 0.5D0*GDDR*PROSSS*FCSS0/(XM1(2)*XM2(2))



      DFILL= DFILL - 0.5D0*GDLL*PROSLL*FSOLL*X*REDM(1)/      

     .                          (AMVC(IN)*XM1(1)*XM2(1))

      DFISS= DFISS - 0.5D0*GDSS*PROSSS*FSOSS*X*REDM(2)/      

     .                          (AMVC(IN)*XM1(2)*XM2(2))

      DFILS= DFILS - 0.5D0*GDLS*PROSLS*FSOLS*X*REDM(3)/      

     .                          (AMVC(IN)*XM1(3)*XM2(3))

      DFIDR= DFIDR - 0.5D0*GDLS*PROSSS*FSOSS*X*REDM(2)/      

     .                          (AMVC(IN)*XM1(2)*XM2(2))



      DDFILL= DDFILL + 0.5D0*GDLL*PROSLL*(3*FTENLL-FSOLL)      

     .                     *REDM(1)*AMVC(IN)**2/(XM1(1)*XM2(1))

      DDFISS= DDFISS + 0.5D0*GDSS*PROSSS*(3*FTENSS-FSOSS)      

     .                     *REDM(2)*AMVC(IN)**2/(XM1(2)*XM2(2))

      DDFILS= DDFILS + 0.5D0*GDLS*PROSLS*(3*FTENLS-FSOLS)      

     .                     *REDM(3)*AMVC(IN)**2/(XM1(3)*XM2(3))

      DDFIDR= DDFIDR + 0.5D0*GDDR*PROSSS*(3*FTENSS-FSOSS)      

     .                     *REDM(2)*AMVC(IN)**2/(XM1(2)*XM2(2))

      ENDIF

C

C     AUGUST 1998 ADDITIONS:

C     BEGIN RETARDATION

      IF(IRET.EQ.1) THEN      

      CALL FFUN(3,XA,AMVC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3)

      VCLL  = VCLL   - GDLL*PROSLL*WKIN1*VARFI0                     

      VCSS  = VCSS   - GDSS*PROSSS*WKIN2*VARFI0

      VCLS  = VCLS   - GDLS*PROSLS*WKIN3*VARFI0

      VCDR  = VCDR   - GDDR*PROSSS*WKIN2*VARFI0

C

      FILL  = FILL   + 0.5D0*GDLL*PROSLL*VARFI0

      FISS  = FISS   + 0.5D0*GDSS*PROSSS*VARFI0

      FILS  = FILS   + 0.5D0*GDLS*PROSLS*VARFI0

      FIDR  = FIDR   + 0.5D0*GDDR*PROSSS*VARFI0

C

      DFILL = DFILL  + 0.5D0*GDLL*PROSLL*VARFI1*PIM

      DFISS = DFISS  + 0.5D0*GDSS*PROSSS*VARFI1*PIM

      DFILS = DFILS  + 0.5D0*GDLS*PROSLS*VARFI1*PIM

      DFIDR = DFIDR  + 0.5D0*GDDR*PROSSS*VARFI1*PIM

      ENDIF

C     END RETARDATION

C

105   IF(NLOC.EQ.0) GOTO 106

      FILL  = FILL   + 1.5D0*REDMM*GDLL*FCLL0/(XM1(1)*XM2(1))

      FISS  = FISS   + 1.5D0*REDMM*GDSS*FCSS0/(XM1(2)*XM2(2))

      FILS  = FILS   + 1.5D0*REDMM*GDLS*FCLS0/(XM1(3)*XM2(3))

      FIDR  = FIDR   + 1.5D0*REDMM*GDDR*FCSS0/(XM1(2)*XM2(2))

C

      DFILL=DFILL-1.5D0*REDMM*GDLL*FSOLL*X*FAC1/AMVC(IN)

      DFISS=DFISS-1.5D0*REDMM*GDSS*FSOSS*X*FAC2/AMVC(IN)

      DFILS=DFILS-1.5D0*REDMM*GDLS*FSOLS*X*FAC3/AMVC(IN)

      DFIDR=DFIDR-1.5D0*REDMM*GDDR*FSOSS*X*FAC2/AMVC(IN)

C

      DDFILL=DDFILL+1.5D0*REDMM*GDLL*(FCLL1+2*FSOLL)*FAC1   ! NOVEMBER 2010

      DDFISS=DDFISS+1.5D0*REDMM*GDSS*(FCSS1+2*FSOSS)*FAC2

      DDFILS=DDFILS+1.5D0*REDMM*GDLS*(FCLS1+2*FSOLS)*FAC3

      DDFIDR=DDFIDR+1.5D0*REDMM*GDDR*(FCSS1+2*FSOSS)*FAC2

C

C------------------------------------------------------------

C     AUGUST 1998 ADDITIONS:

C     BEGIN RETARDATION

      IF(IRET.EQ.1) THEN      

      CALL FFUN(3,XA,AMVC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3)

      VCLL  = VCLL   + GDLL*WKIN1*VARFI0                     

      VCSS  = VCSS   + GDSS*WKIN2*VARFI0

      VCLS  = VCLS   + GDLS*WKIN3*VARFI0

      VCDR  = VCDR   + GDDR*WKIN2*VARFI0

C

      FILL  = FILL   - 0.5D0*GDLL*VARFI0

      FISS  = FISS   - 0.5D0*GDSS*VARFI0

      FILS  = FILS   - 0.5D0*GDLS*VARFI0

      FIDR  = FIDR   - 0.5D0*GDDR*VARFI0

C

      DFILL = DFILL  - 0.5D0*GDLL*VARFI1*PIM

      DFISS = DFISS  - 0.5D0*GDSS*VARFI1*PIM

      DFILS = DFILS  - 0.5D0*GDLS*VARFI1*PIM

      DFIDR = DFIDR  - 0.5D0*GDDR*VARFI1*PIM

      ENDIF

C     END RETARDATION



C------------------------------------------------------------

C     BEGIN ZERO IN FORM-FACTOR:

  106 IF(IZVC.EQ.1) THEN

      FZERO = (AMVC(IN)/AMCRV)**2

      FC3   = FCLL2  - FVC(IN)*(3.75D0-5*XLAM1**2+XLAM1**4)        

     .               * VKULL*AMVC(IN)/(RATM1**4)

      FT2   = FTLL1  - FVC(IN)*(-7.D0+2*XLAM1**2)*XLAM1**2*VKULL

     .               * AMVC(IN)/(6*RATM1**4)

      FO2   = FOLL1  + FVC(IN)*(2.5D0-XLAM1**2)*VKULL*AMVC(IN)            

     .               / (2*RATM1**4)

      FO21  = 3*FTLL1/(X*X)                            



      VCLL  = VCLL   + FZERO*(GDLL*FCLL1+CCLL1*FCLL2+          

     .                        GFLL*FAC0*FAC1*FC3/16.D0)

      VCSS  = VCSS   + FZERO*(GDSS*FCSS1+CCSS1*FCSS2+          

     .                        GFSS*FAC0*FAC1*FC3/16.D0)

      VCLS  = VCLS   + FZERO*(GDLS*FCLS1+CCLS1*FCLS2+          

     .                        GFLS*FAC0*FAC1*FC3/16.D0)

      VCDR  = VCDR   + FZERO*(GDLL*FCSS1+CCDR1*FCSS2+          

     .                        GFDR*FAC0*FAC1*FC3/16.D0)



      VSIGLL= VSIGLL + FZERO*(CSLL1*FCLL2+GFLL*FAC0*FC3/8.D0)

     .                      * FAC1/6.D0                     

      VSIGSS= VSIGSS + FZERO*(CSSS1*FCSS2+GFSS*FAC0*FC3/8.D0)

     .                      * FAC1/6.D0                     

      VSIGLS= VSIGLS + FZERO*(CSLS1*FCLS2+GFLS*FAC0*FC3/8.D0)

     .                      * FAC1/6.D0                     

      VSIGDR= VSIGDR + FZERO*(CSDR1*FCSS2+GFDR*FAC0*FC3/8.D0)

     .                      * FAC1/6.D0                     



      VTENLL= VTENLL - FZERO*(CTLL0*FTLL1+GFLL*FAC0*FT2/8.D0)

     .                      * FAC1/4.D0                     

      VTENSS= VTENSS - FZERO*(CTSS0*FTSS1+GFSS*FAC0*FT2/8.D0)

     .                      * FAC1/4.D0                     

      VTENLS= VTENLS - FZERO*(CTLS0*FTLS1+GFLS*FAC0*FT2/8.D0)

     .                      * FAC1/4.D0                     

      VTENDR= VTENDR - FZERO*(CTDR0*FTSS1+GFDR*FAC0*FT2/8.D0)

     .                      * FAC1/4.D0                     



      VSOLL = VSOLL  - FZERO*(COLL0*FOLL1+GFLL*FAC0*FO2*3/8.D0)

     .                      * FAC1                          

      VSOSS = VSOSS  - FZERO*(COSS0*FOSS1+GFSS*FAC0*FO2*3/8.D0)

     .                      * FAC1                          

      VSOLS = VSOLS  - FZERO*(COLS0*FOLS1+GFLS*FAC0*FO2*3/8.D0)

     .                      * FAC1                          

      VSODR = VSODR  - FZERO*(CODR0*FOSS1+GFDR*FAC0*FO2*3/8.D0)

     .                      * FAC1                          

 

      VASOLL= VASOLL - FZERO*(CALL0*FOLL1-CALL1*FO2)*FAC1

      VASOSS= VASOSS - FZERO*(CASS0*FOSS1-CASS1*FO2)*FAC2

      VASOLS= VASOLS - FZERO*(CALS0*FOLS1-CALS1*FO2)*FAC3

      VASODR= VASODR - FZERO*(CADR0*FOSS1-CADR1*FO2)*FAC2



      VSO2LL= VSO2LL + FZERO* CO2LL*FO21*FAC1*FAC1/16.D0   

      VSO2SS= VSO2SS + FZERO* CO2SS*FO21*FAC2*FAC2/16.D0   

      VSO2LS= VSO2LS + FZERO* CO2LS*FO21*FAC3*FAC3/16.D0   

      VSO2DR= VSO2DR + FZERO* CO2DR*FO21*FAC2*FAC2/16.D0   

      IF(NLOC.NE.0) THEN

      FILL  = FILL   + FZERO*1.5D0*REDMM*GDLL*FCLL1/(XM1(1)*XM2(1))

      FISS  = FISS   + FZERO*1.5D0*REDMM*GDSS*FCSS1/(XM1(1)*XM2(1))

      FILS  = FILS   + FZERO*1.5D0*REDMM*GDLS*FCLS1/(XM1(1)*XM2(1))

      FIDR  = FIDR   + FZERO*1.5D0*REDMM*GDDR*FCSS1/(XM1(1)*XM2(1))



      DFILL = DFILL  - FZERO*1.5D0*REDMM*GDLL*FOLL1*X*FAC1/AMVC(IN)

      DFISS = DFISS  - FZERO*1.5D0*REDMM*GDSS*FOSS1*X*FAC2/AMVC(IN)

      DFILS = DFILS  - FZERO*1.5D0*REDMM*GDLS*FOLS1*X*FAC3/AMVC(IN)

      DFIDR = DFIDR  - FZERO*1.5D0*REDMM*GDDR*FOSS1*X*FAC2/AMVC(IN)

C

      DDFILL=DDFILL  + FZERO*1.5D0*REDMM*GDLL*(FCLL2+2*FOLL1)*FAC1   ! NOVEMBER 2010

      DDFISS=DDFISS  + FZERO*1.5D0*REDMM*GDSS*(FCSS2+2*FOSS1)*FAC2

      DDFILS=DDFILS  + FZERO*1.5D0*REDMM*GDLS*(FCLS2+2*FOLS1)*FAC3

      DDFIDR=DDFIDR  + FZERO*1.5D0*REDMM*GDDR*(FCSS2+2*FOSS1)*FAC2

      ENDIF

      IF(IN.NE.5) GOTO 104

C     K-STAR: CONTRIBUTION SECOND TERM IN VECTOR PROPAGATOR

C    

      VCLL   = VCLL - FZERO*GDLL*PROSLL*(FCLL1-0.25D0*FAC1*FCLL2)

      VCSS   = VCSS - FZERO*GDSS*PROSSS*(FCSS1-0.25D0*FAC2*FCSS2)

      VCLS   = VCLS - FZERO*GDLS*PROSLS*(FCLS1-0.25D0*FAC3*FCLS2)

      VCDR   = VCDR - FZERO*GDDR*PROSSS*(FCSS1-0.25D0*FAC2*FCSS2)



      VSOLL  = VSOLL - FZERO*GDLL*PROSLL*FOLL1*FAC1/2.D0   

      VSOSS  = VSOSS - FZERO*GDSS*PROSSS*FOSS1*FAC2/2.D0   

      VSOLS  = VSOLS - FZERO*GDLS*PROSLS*FOLS1*FAC3/2.D0   

      VSODR  = VSODR - FZERO*GDDR*PROSSS*FOSS1*FAC2/2.D0   



      VASOLL = VASOLL - FZERO*GDLL*PROSLL*FOLL1*FFAC1*FAC1/4.D0   

      VASOSS = VASOSS - FZERO*GDSS*PROSSS*FOSS1*FFAC1*FAC2/4.D0   

      VASOLS = VASOLS - FZERO*GDLS*PROSLS*FOLS1*FFAC1*FAC3/4.D0   

      VASODR = VASODR - FZERO*GDDR*PROSSS*FOSS1*FFAC1*FAC2/4.D0   



      VSO2LL = VSO2LL - FZERO*GDLL*PROSLL*FO21*FAC1*FAC1/16.D0

      VSO2SS = VSO2SS - FZERO*GDSS*PROSSS*FO21*FAC2*FAC2/16.D0

      VSO2LS = VSO2LS - FZERO*GDLS*PROSLS*FO21*FAC3*FAC3/16.D0

      VSO2DR = VSO2DR - FZERO*GDDR*PROSDR*FO21*FAC2*FAC2/16.D0

      IF(NLOC.NE.0) THEN

      FILL = FILL  + FZERO* 0.5D0*GDLL*PROSLL*FCLL1/(XM1(1)*XM2(1))

      FISS = FISS  + FZERO* 0.5D0*GDSS*PROSSS*FCSS1/(XM1(2)*XM2(2))

      FILS = FILS  + FZERO* 0.5D0*GDLS*PROSLS*FCLS1/(XM1(3)*XM2(3))

      FIDR = FIDR  + FZERO* 0.5D0*GDDR*PROSSS*FCSS1/(XM1(2)*XM2(2))



      DFILL= DFILL - FZERO*0.5D0*GDLL*PROSLL*FOLL1*X*REDM(1)/      

     .                          (AMVC(IN)*XM1(1)*XM2(1))

      DFISS= DFISS - FZERO*0.5D0*GDSS*PROSSS*FOSS1*X*REDM(2)/      

     .                          (AMVC(IN)*XM1(2)*XM2(2))

      DFILS= DFILS - FZERO*0.5D0*GDLS*PROSLS*FOLS1*X*REDM(3)/      

     .                          (AMVC(IN)*XM1(3)*XM2(3))

      DFIDR= DFIDR - FZERO*0.5D0*GDDR*PROSSS*FOSS1*X*REDM(2)/      

     .                          (AMVC(IN)*XM1(2)*XM2(2))

      ENDIF

       ENDIF

C     END ZERO IN FORM-FACTOR. 

C------------------------------------------------------------



  104 CONTINUE

C

c     print spin-orbit potentials LL:

c     if(in.eq.1) write(*,*)

c     if(in.eq.1) write(*,*)

c    .'in=1,2 <-> rho, in=3 <-> omega, in=4 <-> phi, in=5 <-> K*:'

c     write(*,*) ' VECTOR : x=',xa,' IN=',in,' vsoll=',vsoll,

c    .' vasoll=',vasoll

 1040 CONTINUE

C

      icall = 1

      RETURN

      END

C**********************************************************************

C

c*    SUBROUTINE SCALAR(LC,NMAX,NLOC,ICSB)

      SUBROUTINE SCALAR(XA,ICSB,NLOC,LC)

C

C**********************************************************************

C

C     VERSION FEBRUARY 07: DIRECT AND DERIVATIVE COUPLING SCALARS 

C     VERSION AUGUST 2000: FIRST SU3-NONET, ASSIGNMENTS CHOOSEN: 

C       EPS=f0(760), DEL=A0(962), S*=f0(993), KAPPA=K0(900)              

C**********************************************************************

C  updated december 2000, from YNRMP2k2.f , introducing mass               

C  differences in meson propagators in the OBE-potentials, 

C  according to Macke-Klein 

C----------------------------------------------------------------------



C

C     SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/ALLSC3/FS1,FS2,FS3,FS4,FS5,FS6,FS7,FS8,FS9,FS10,FS11 

      COMMON/ALLSC2/XALLSC2(5),GSA(11),GSB(11),IOPTSC

      DIMENSION GS(11),FS(11),AMSC(6),FSC(6),XM1(3),XM2(3)

      EQUIVALENCE (GS1,GS(1)),(FS1,FS(1))

      EQUIVALENCE (GSA1,GSA(1))

      DATA SR3/1.732051D0/,SRPI/1.772453851D0/,FMNL/1.D0/

      DATA AMCRS/750.D0/,DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/

     .,AMPRO/938.2796D0/

C

C   NOTE : DELTA(IN=1),EPS1(IN=2),EPS2(IN=3),SSTAR(IN=4),KAPPA(IN=5)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C-------------------------------------------------------------------

C   NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS !

C                                 : INDEX 2,4 -> HYPERONS !

C-------------------------------------------------------------------

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

C

C

c     SKAP = FS(1)/GS(1)/AMPRO

c     SKAP2= SKAP*SKAP

      RAMLN= DAMLN/AMPRO

      RAMSN= DAMSN/AMPRO

      RAMSL= DAMSL/AMPRO

      IF(LC.EQ.1) SIGN= 1.D0

      IF(LC.NE.1) SIGN=-1.D0

      IF(IRET.EQ.1) THEN

      WKIN1 = PIM**2*AKS(1)/(2*REDM(1))

      WKIN2 = PIM**2*AKS(3)/(2*REDM(3))

      WKIN3 = 0.5D0*(WKIN1+WKIN2)

      ENDIF



      DO 1040 IN=1,5

c     IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

c     ENDIF

      DGSLL = 0D0

      DGSLS = 0D0

      DGSSS = 0D0

      DGSDR = 0D0

      GOTO(1051,1052,1053,1054,1055),IN

1051  GSLL = -0.0271D0*ICSB*GS1*GS3

      GSSS=  -2*GS1*GS2

      GSLS= -SR3*GS1*GS3

c     GSLS= -SR3*(GS1*GS3-SIGN*RAMSL*GS1*FS3)

      GSDR=      GS1*GS2

      DGSLS= +SR3*SIGN*RAMSL*GS1*FS3

      FSC(1)=1.D0

      AMSC(1)=AMD

      GOTO 1056

1052  GSLL=  GS6*GS7

      GSSS=  GS6*GS8

      GSLS=  0.D0

      GSDR=  GS6*GS8

      FSC(2)=ASI

      AMSC(2)=AM1SI

      GOTO 1056

1053  GSLL=  GS6*GS7

      GSSS=  GS6*GS8

      GSLS=  0.D0

      GSDR=  GS6*GS8

      FSC(3)=BSI

      AMSC(3)=AM2SI

      GOTO 1056

1054  GSLL=  GS9*GS10

      GSSS=  GS9*GS11 

      GSLS=  0.D0

      GSDR=  GS9*GS11 

      FSC(4)=1.D0

      AMSC(4)=AMSST

      GOTO 1056



c*1055  GSLL=  GS4*GS4*P*(1D0+SKAP2*DAMLN**2)

c*      GSSS= -GS5*GS5*P*(1D0+SKAP2*DAMSN**2)

c*      GSLS= -SR3*GS4*GS5*P*(1D0-SIGN*SKAP*DAMSL+SKAP2*DAMSN*DAMLN)

c*      GSDR= 2*GS5*GS5*P*(1D0+SKAP2*DAMSN**2)

c1055  GSLL=  (GS4*GS4+FS4*FS4*RAMLN**2)*P

c      GSSS=  (GS5*GS5+FS5*FS5*RAMSN**2)*P

c      GSLS= -SR3*(GS4*GS5-SIGN*GS4*FS5*RAMSN+SIGN*GS5*FS4*RAMLN

c     .           +FS4*FS5*RAMSN*RAMLN)*P

c      GSDR= 2*(GS5*GS5+FS5*FS5*RAMSN**2)*P



1055  GSLL=      GS4*GS4*P

      GSSS=     -GS5*GS5*P

      GSLS= -SR3*GS4*GS5*P

      GSDR=    2*GS5*GS5*P

      DGSLL=  FS4*FS4*RAMLN**2*P

      DGSSS=  FS5*FS5*RAMSN**2*P

      DGSLS= -SR3*(-SIGN*GS4*FS5*RAMSN+SIGN*GS5*FS4*RAMLN

     .           +FS4*FS5*RAMSN*RAMLN)*P

      DGSDR= 2*FS5*FS5*RAMSN**2*P

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMLN

c**   XM1(3)=AMSN

c**   XM1(3)=(AMSN+AMLS)/2.D0

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMSN

c**   XM2(3)=(AMSN+AMLS)/2.D0

c**   XM2(3)=AMLS

      FSC(5)=1.D0

      AMSC(5)=AMSCK

C

1056  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN

       ALAM = ALMS8

       IF(IN.EQ.2.OR.IN.EQ.3) ALAM=ALMS1

       IF(IN.EQ.5) ALAM=ALMKP

      ENDIF



      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM



      RATM1=AMSC(IN)/ALM1

      RATM2=AMSC(IN)/ALM2

      RATM3=AMSC(IN)/ALM3

      AMSC2=AMSC(IN)**2

      AMSC3=AMSC(IN)**3

      AMSC5=AMSC(IN)**5

      FAC1=AMSC(IN)*AMSC(IN)/(XM1(1)*XM2(1))

      FAC2=AMSC(IN)*AMSC(IN)/(XM1(2)*XM2(2))

      FAC3=AMSC(IN)*AMSC(IN)/(XM1(3)*XM2(3))

      FFAC1 = (1.D0/XM1(1)**2-1.D0/XM2(1)**2)

      FFAC2 = (1.D0/XM1(2)**2-1.D0/XM2(2)**2)

      FFAC3 = (1.D0/XM1(3)**2-1.D0/XM2(3)**2)

C

c     DO 104 I=2,NMAX

c     X = XA(I)

      X = XA

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMSC(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMSC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMSC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOLL  = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2LL = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOSS  = FSC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2SS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOLS  = FSC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2LS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C

      FCLL1  = FCLL0  - FSC(IN)*VKULL*AMSC(IN)

      FCSS1  = FCSS0  - FSC(IN)*VKUSS*AMSC(IN)

      FCLS1  = FCLS0  - FSC(IN)*VKULS*AMSC(IN)



      FOLL1  = FSOLL -0.5D0*FSC(IN)*VKULL*AMSC3/RATM1**2

      FOSS1  = FSOSS -0.5D0*FSC(IN)*VKUSS*AMSC3/RATM2**2

      FOLS1  = FSOLS -0.5D0*FSC(IN)*VKULS*AMSC3/RATM3**2

C

      FCLL2  = FCLL1+

     .         FSC(IN)*(1.5D0-XLAM1*XLAM1)*VKULL*AMSC(IN)/RATM1/RATM1

      FCSS2  = FCSS1+

     .         FSC(IN)*(1.5D0-XLAM2*XLAM2)*VKUSS*AMSC(IN)/RATM2/RATM2

      FCLS2  = FCLS1+

     .         FSC(IN)*(1.5D0-XLAM3*XLAM3)*VKULS*AMSC(IN)/RATM3/RATM3

c     FCLL2 = 0.D0

c     FCSS2 = 0.D0

c     FCLS2 = 0.D0

C------------------------------------------------------------

C     THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS:

      IF(IDAM.NE.0.AND.IN.NE.5) THEN

      CALL YMKFUN(XA,AMSC(IN),ALAM,SIGN,IDAM*DAMSL,

     .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1)

      FXSO2 = 3*FXTEN/(X*X)

C------------------------------------------------------------

      IF(LC.EQ.1) THEN

      FCSS0 = FSC(IN)*AMSC(IN)*FXC0 

      FCSS1 = FSC(IN)*AMSC(IN)*FXC1 

      FSOSS = FSC(IN)*AMSC3*FXSO              

      FSO2SS= FSC(IN)*AMSC5*FXSO2             

      ENDIF

      IF(LC.NE.1) THEN

      FCLL0 = FSC(IN)*AMSC(IN)*FXC0 

      FCLL1 = FSC(IN)*AMSC(IN)*FXC1 

      FSOLL = FSC(IN)*AMSC3*FXSO              

      FSO2LL= FSC(IN)*AMSC5*FXSO2             

      ENDIF

      FCLS0  = 0.5D0*(FCLS0  + FSC(IN)*AMSC(IN)*FXC0 )     

      FCLS1  = 0.5D0*(FCLS1  + FSC(IN)*AMSC(IN)*FXC1 )     

      FSOLS  = 0.5D0*(FSOLS  + FSC(IN)*AMSC3*FXSO )      

      FSO2LS = 0.5D0*(FSO2LS + FSC(IN)*AMSC5*FXSO2)      

      ENDIF

C--------------------------------------------------------------------

C     CONTRIBUTION DERIVATIVE COUPLING:

c     IF(I.EQ.2) THEN

      GSLL = GSLL + DGSLL

      GSLS = GSLS + DGSLS

      GSSS = GSSS + DGSSS

      GSDR = GSDR + DGSDR

c     ENDIF

C--------------------------------------------------------------------

C

      VCLL  = VCLL   - GSLL*(FCLL0-0.25D0*FAC1*FCLL1)

      VCSS  = VCSS   - GSSS*(FCSS0-0.25D0*FAC2*FCSS1)

      VCLS  = VCLS   - GSLS*(FCLS0-0.25D0*FAC3*FCLS1)

      VCDR  = VCDR   - GSDR*(FCSS0-0.25D0*FAC2*FCSS1)

C

      VSOLL = VSOLL  - 0.5D0*GSLL*FSOLL/(XM1(1)*XM2(1))

      VSOSS = VSOSS  - 0.5D0*GSSS*FSOSS/(XM1(2)*XM2(2))

      VSOLS = VSOLS  - 0.5D0*GSLS*FSOLS/(XM1(3)*XM2(3))

      VSODR = VSODR  - 0.5D0*GSDR*FSOSS/(XM1(2)*XM2(2))

C

      VASOLL = VASOLL  - GSLL*FSOLL*FFAC1/4.D0

      VASOSS = VASOSS  - GSSS*FSOSS*FFAC2/4.D0

      VASOLS = VASOLS  - GSLS*FSOLS*FFAC3/4.D0

      VASODR = VASODR  - GSDR*FSOSS*FFAC2/4.D0

C

      VSO2LL= VSO2LL - GSLL*FSO2LL/(4*XM1(1)*XM2(1))**2

      VSO2SS= VSO2SS - GSSS*FSO2SS/(4*XM1(2)*XM2(2))**2          

      VSO2LS= VSO2LS - GSLS*FSO2LS/(4*XM1(3)*XM2(3))**2    

      VSO2DR= VSO2DR - GSDR*FSO2SS/(4*XM1(2)*XM2(2))**2           

C--------------------------------------------------------------------

      IF(NLOC.NE.0) THEN      

      FILL  = FILL   + 0.5D0*REDMM*GSLL*FCLL0/(XM1(1)*XM2(1))

      FISS  = FISS   + 0.5D0*REDMM*GSSS*FCSS0/(XM1(2)*XM2(2))

      FILS  = FILS   + 0.5D0*REDMM*GSLS*FCLS0/(XM1(3)*XM2(3))

      FIDR  = FIDR   + 0.5D0*REDMM*GSDR*FCSS0/(XM1(2)*XM2(2))

C

      DFILL=DFILL-0.5*REDMM*GSLL*FSOLL*X/(AMSC(IN)*XM1(1)*XM2(1))

      DFISS=DFISS-0.5*REDMM*GSSS*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2))

      DFILS=DFILS-0.5*REDMM*GSLS*FSOLS*X/(AMSC(IN)*XM1(3)*XM2(3))

      DFIDR=DFIDR-0.5*REDMM*GSDR*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2))

C

      DDFILL=DDFILL+0.5*REDMM*GSLL*(FCLL1*AMSC2+2*FSOLL)/       ! NOVEMBER 2010

     .              (XM1(1)*XM2(1))

      DDFISS=DDFISS+0.5*REDMM*GSSS*(FCSS1*AMSC2+2*FSOSS)/

     .              (XM1(2)*XM2(2))

      DDFILS=DDFILS+0.5*REDMM*GSLS*(FCLS1*AMSC2+2*FSOLS)/

     .              (XM1(3)*XM2(3))

      DDFIDR=DDFIDR+0.5*REDMM*GSDR*(FCSS1*AMSC2+2*FSOSS)/

     .              (XM1(2)*XM2(2))

      ENDIF

C--------------------------------------------------------------------

C     ZERO IN FORM FACTOR:

      IF(IZSC.NE.0) THEN

C--------------------------------------------------------------------

C     NO CONTRIBUTION DERIVATIVE COUPLING:

c*    IF(I.EQ.2) THEN

c*    GSLL = GSLL - DGSLL

c*    GSLS = GSLS - DGSLS

c*    GSSS = GSSS - DGSSS

c*    GSDR = GSDR - DGSDR

c*    ENDIF

C--------------------------------------------------------------------

      FZERO = (AMSC(IN)/AMCRS)**2

      FC2   = FCLL1 + FSC(IN)*(1.5D0-XLAM1*XLAM1)

     .              * VKULL*AMSC(IN)/RATM1/RATM1

      FO1   = FSOLL - FSC(IN)*(VKULL/(2*RATM1*RATM1))

     .                *AMSC3

      FO21  = FSO2LL- FSC(IN)*VKULL/(4*RATM1**4)*AMSC5   

 

      VCLL  = VCLL   - FZERO*GSLL*(FCLL1-0.25D0*FAC1*FC2)

      VCSS  = VCSS   - FZERO*GSSS*(FCSS1-0.25D0*FAC2*FC2)

      VCLS  = VCLS   - FZERO*GSLS*(FCLS1-0.25D0*FAC3*FC2)

      VCDR  = VCDR   - FZERO*GSDR*(FCSS1-0.25D0*FAC2*FC2)

 

c     VSOLL = VSOLL  - FZERO*0.5D0*GSLL*FO1   

c     VSOSS = VSOSS  - FZERO*0.5D0*GSSS*FO1   

c     VSOLS = VSOLS  - FZERO*0.5D0*GSLS*FO1  

c     VSODR = VSODR  - FZERO*0.5D0*GSDR*FO1  

      VSOLL = VSOLL  - FZERO*0.5D0*GSLL*FO1/(XM1(1)*XM2(1))

      VSOSS = VSOSS  - FZERO*0.5D0*GSSS*FO1/(XM1(2)*XM2(2))

      VSOLS = VSOLS  - FZERO*0.5D0*GSLS*FO1/(XM1(3)*XM2(3))

      VSODR = VSODR  - FZERO*0.5D0*GSDR*FO1/(XM1(2)*XM2(2))

C

      VASOLL = VASOLL - FZERO*GSLL*FO1*FFAC1/4.D0

      VASOSS = VASOSS - FZERO*GSSS*FO1*FFAC2/4.D0

      VASOLS = VASOLS - FZERO*GSLS*FO1*FFAC3/4.D0

      VASODR = VASODR - FZERO*GSDR*FO1*FFAC2/4.D0

 

c     VSO2LL= VSO2LL - FZERO*GSLL*FO21/16.D0

c     VSO2SS= VSO2SS - FZERO*GSSS*FO21/16.D0   

c     VSO2LS= VSO2LS - FZERO*GSLS*FO21/16.D0

c     VSO2DR= VSO2DR - FZERO*GSDR*FO21/16.D0    

      VSO2LL= VSO2LL - FZERO*GSLL*FO21/(4*XM1(1)*XM2(1))**2

      VSO2SS= VSO2SS - FZERO*GSSS*FO21/(4*XM1(2)*XM2(2))**2          

      VSO2LS= VSO2LS - FZERO*GSLS*FO21/(4*XM1(3)*XM2(3))**2    

      VSO2DR= VSO2DR - FZERO*GSDR*FO21/(4*XM1(2)*XM2(2))**2           



      IF(NLOC.NE.0.AND.IZSC.EQ.2) THEN

c*    IF(NLOC.NE.0.AND.IZSC.LT.0) THEN

      FILL  = FILL + FZERO*0.5D0*REDMM*GSLL*FCLL1/(XM1(1)*XM2(1))

      FISS  = FISS + FZERO*0.5D0*REDMM*GSSS*FCSS1/(XM1(2)*XM2(2))

      FILS  = FILS + FZERO*0.5D0*REDMM*GSLS*FCLS1/(XM1(3)*XM2(3))

      FIDR  = FIDR + FZERO*0.5D0*REDMM*GSDR*FCSS1/(XM1(2)*XM2(2))



      DFILL=DFILL - FZERO*0.5*REDMM*GSLL*FOLL1*X/

     .                    (AMSC(IN)*XM1(1)*XM2(1))

      DFISS=DFISS - FZERO*0.5*REDMM*GSSS*FOSS1*X/

     .                    (AMSC(IN)*XM1(2)*XM2(2))

      DFILS=DFILS - FZERO*0.5*REDMM*GSLS*FOLS1*X/

     .                    (AMSC(IN)*XM1(3)*XM2(3))

      DFIDR=DFIDR - FZERO*0.5*REDMM*GSDR*FOSS1*X/

     .                    (AMSC(IN)*XM1(2)*XM2(2))

C

      DDFILL=DDFILL+FZERO*0.5D0*REDMM*GSLL*(FCLL2*AMSC2+2*FOLL1)/       ! NOVEMBER 2010

     .              (XM1(1)*XM2(1))

      DDFISS=DDFISS+FZERO*0.5D0*REDMM*GSSS*(FCSS2*AMSC2+2*FOSS1)/

     .              (XM1(2)*XM2(2))

      DDFILS=DDFILS+FZERO*0.5D0*REDMM*GSLS*(FCLS2*AMSC2+2*FOLS1)/

     .              (XM1(3)*XM2(3))

      DDFIDR=DDFIDR+FZERO*0.5D0*REDMM*GSDR*(FCSS2*AMSC2+2*FOSS1)/

     .              (XM1(2)*XM2(2))

      ENDIF

      ENDIF

C--------------------------------------------------------------------

C

C     AUGUST 1998 ADDITIONS:

C     BEGIN RETARDATION

      IF(IRET.EQ.1) THEN      

      CALL FFUN(3,XA,AMSC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3)

      VCLL  = VCLL   - GSLL*WKIN1*VARFI0                     

      VCSS  = VCSS   - GSSS*WKIN2*VARFI0

      VCLS  = VCLS   - GSLS*WKIN3*VARFI0

      VCDR  = VCDR   - GSDR*WKIN2*VARFI0

C

      FILL  = FILL   + 0.5D0*GSLL*VARFI0

      FISS  = FISS   + 0.5D0*GSSS*VARFI0

      FILS  = FILS   + 0.5D0*GSLS*VARFI0

      FIDR  = FIDR   + 0.5D0*GSDR*VARFI0

C

      DFILL = DFILL  + 0.5D0*GSLL*VARFI1*PIM

      DFISS = DFISS  + 0.5D0*GSSS*VARFI1*PIM

      DFILS = DFILS  + 0.5D0*GSLS*VARFI1*PIM

      DFIDR = DFIDR  + 0.5D0*GSDR*VARFI1*PIM

      ENDIF

C     END RETARDATION



  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END

C**********************************************************************

C

c*    SUBROUTINE SCALARH(LC,NMAX,NLOC,ICSB)

      SUBROUTINE SCALAR2(XA,ICSB,NLOC,LC)

C

C**********************************************************************

C

C     VERSION AUGUST 2000: SECOND SU3-NONET, ASSIGNMENTS CHOOSEN:

C       DEL2=A0(1450), EPS2=F0(1370), S*2=f0(1580), KAPPA2=K*(1430)

C**********************************************************************

C  updated december 2000, from YNRMP2k2.f , introducing mass               

C  differences in meson propagators in the OBE-potentials, 

C  according to Macke-Klein 

C----------------------------------------------------------------------



C

C     SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX



      DIMENSION GSA(11),AMSC(4),FSC(4),XM1(3),XM2(3)

      COMMON/ALLSC2/XALLSC2(5),                

     .GSA1,GSA2,GSA3,GSA4,GSA5,GSA6,GSA7,GSA8,GSA9,GSA10,GSA11,

     .GSB1,GSB2,GSB3,GSB4,GSB5,GSB6,GSB7,GSB8,GSB9,GSB10,GSB11,

     .IOPTSC

      EQUIVALENCE (GSA1,GSA(1))

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/

      DATA AMDEL2/1450.D0/,AMEPS2/1370.D0/,AMST2/1580.D0/,

     .     AMSCK2/1430.D0/

      DATA AMCRS/750.D0/,DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/

C

C   NOTE : DELTA2(IN=1),EPS2(IN=2),SSTAR2(IN=3),KAPPA2(IN=4)

C          EPS(1300)(IN=6)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C-------------------------------------------------------------------

C   NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS !

C                                 : INDEX 2,4 -> HYPERONS !

C-------------------------------------------------------------------

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

C

C

      IF(LC.EQ.1) SIGN= 1.D0

      IF(LC.NE.1) SIGN=-1.D0

      IF(IRET.EQ.1) THEN

      WKIN1 = PIM**2*AKS(1)/(2*REDM(1))

      WKIN2 = PIM**2*AKS(3)/(2*REDM(3))

      WKIN3 = 0.5D0*(WKIN1+WKIN2)

      ENDIF



      DO 1040 IN=1,4

      IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

      ENDIF

      GOTO(1051,1052,1053,1054),IN

1051  GSLL = 0.D0                   

      GSSS=  -2*GSA1*GSA2

      GSLS= -SR3*GSA1*GSA3

      GSDR=      GSA1*GSA2

      FSC(1)=1.D0

      AMSC(1)=AMDEL2

      GOTO 1055

1052  GSLL=  GSA6*GSA7

      GSSS=  GSA6*GSA8

      GSLS=  0.D0

      GSDR=  GSA6*GSA8

      FSC(2)=1.D0 

      AMSC(2)=AMEPS2

      GOTO 1055

1053  GSLL=  GSA9*GSA10

      GSSS=  GSA9*GSA11

      GSLS=  0.D0

      GSDR=  GSA9*GSA11

      FSC(3)=1.D0 

      AMSC(3)=AMST2

      GOTO 1055

1054  GSLL=      GSA4*GSA4*P

      GSSS=     -GSA5*GSA5*P

      GSLS= -SR3*GSA4*GSA5*P

      GSDR=    2*GSA5*GSA5*P

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMSN

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMSN

      FSC(4)=1.D0

      AMSC(4)=AMSCK2

C

1055  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN

       ALAM = ALMS8

       IF(IN.EQ.2.OR.IN.EQ.3) ALAM=ALMS1

       IF(IN.EQ.5) ALAM=ALMKP

       IF(IN.EQ.6) ALAM=ALMS1

      ENDIF



      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM



      RATM1=AMSC(IN)/ALM1

      RATM2=AMSC(IN)/ALM2

      RATM3=AMSC(IN)/ALM3

      AMSC3=AMSC(IN)**3

      AMSC5=AMSC(IN)**5

      FAC1=AMSC(IN)*AMSC(IN)/(XM1(1)*XM2(1))

      FAC2=AMSC(IN)*AMSC(IN)/(XM1(2)*XM2(2))

      FAC3=AMSC(IN)*AMSC(IN)/(XM1(3)*XM2(3))

      FFAC1 = (1.D0/XM1(1)**2-1.D0/XM2(1)**2)

      FFAC2 = (1.D0/XM1(2)**2-1.D0/XM2(2)**2)

      FFAC3 = (1.D0/XM1(3)**2-1.D0/XM2(3)**2)

C

c     DO 104 I=2,NMAX

c     X = XA(I)

      X = XA    

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMSC(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMSC(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMSC(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOLL  = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2LL = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C



      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOSS  = FSC(IN)*FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2SS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)

      FSOLS  = FSC(IN)*FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC3

      FSO2LS = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMSC5/

     /         (X*X)

C

      FCLL1  = FCLL0  - FSC(IN)*VKULL*AMSC(IN)

      FCSS1  = FCSS0  - FSC(IN)*VKUSS*AMSC(IN)

      FCLS1  = FCLS0  - FSC(IN)*VKULS*AMSC(IN)

C

      VCLL  = VCLL   - GSLL*(FCLL0-0.25D0*FAC1*FCLL1)

      VCSS  = VCSS   - GSSS*(FCSS0-0.25D0*FAC2*FCSS1)

      VCLS  = VCLS   - GSLS*(FCLS0-0.25D0*FAC3*FCLS1)

      VCDR  = VCDR   - GSDR*(FCSS0-0.25D0*FAC2*FCSS1)

C

      VSOLL = VSOLL  - 0.5D0*GSLL*FSOLL/(XM1(1)*XM2(1))

      VSOSS = VSOSS  - 0.5D0*GSSS*FSOSS/(XM1(2)*XM2(2))

      VSOLS = VSOLS  - 0.5D0*GSLS*FSOLS/(XM1(3)*XM2(3))

      VSODR = VSODR  - 0.5D0*GSDR*FSOSS/(XM1(2)*XM2(2))

C

      VASOLL = VASOLL  - GSLL*FSOLL*FFAC1/4.D0

      VASOSS = VASOSS  - GSSS*FSOSS*FFAC2/4.D0

      VASOLS = VASOLS  - GSLS*FSOLS*FFAC3/4.D0

      VASODR = VASODR  - GSDR*FSOSS*FFAC2/4.D0

C

      VSO2LL= VSO2LL - GSLL*FSO2LL/(4*XM1(1)*XM2(1))**2

      VSO2SS= VSO2SS - GSSS*FSO2SS/(4*XM1(2)*XM2(2))**2          

      VSO2LS= VSO2LS - GSLS*FSO2LS/(4*XM1(3)*XM2(3))**2    

      VSO2DR= VSO2DR - GSDR*FSO2SS/(4*XM1(2)*XM2(2))**2           

C

C------------------------------------------------------------

C     THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS:

      IF(IN.NE.5) THEN

      CALL YMKFUN(XA,AMSC(IN),ALAM,SIGN,IDAM*DAMSL,

     .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1)

      FXSO2 = 3*FXTEN/(X*X)

C------------------------------------------------------------

      IF(LC.EQ.1) THEN

      FCSS0 = FSC(IN)*AMSC(IN)*FXC0 

      FCSS1 = FSC(IN)*AMSC(IN)*FXC1 

      FSOSS = FSC(IN)*AMSC3*FXSO              

      FSO2SS= FSC(IN)*AMSC5*FXSO2             

      ENDIF

      IF(LC.NE.1) THEN

      FCLL0 = FSC(IN)*AMSC(IN)*FXC0 

      FCLL1 = FSC(IN)*AMSC(IN)*FXC1 

      FSOLL = FSC(IN)*AMSC3*FXSO              

      FSO2LL= FSC(IN)*AMSC5*FXSO2             

      ENDIF

      FCLS0  = 0.5D0*(FCLS0  + FSC(IN)*AMSC(IN)*FXC0 )     

      FCLS1  = 0.5D0*(FCLS1  + FSC(IN)*AMSC(IN)*FXC1 )     

      FSOLS  = 0.5D0*(FSOLS  + FSC(IN)*AMSC3*FXSO )      

      FSO2LS = 0.5D0*(FSO2LS + FSC(IN)*AMSC5*FXSO2)      

      ENDIF

C------------------------------------------------------------

C

      IF(NLOC.NE.0) THEN     

      FILL  = FILL   + 0.5D0*REDMM*GSLL*FCLL0/(XM1(1)*XM2(1))

      FISS  = FISS   + 0.5D0*REDMM*GSSS*FCSS0/(XM1(2)*XM2(2))

      FILS  = FILS   + 0.5D0*REDMM*GSLS*FCLS0/(XM1(3)*XM2(3))

      FIDR  = FIDR   + 0.5D0*REDMM*GSDR*FCSS0/(XM1(2)*XM2(2))

C

      DFILL=DFILL-0.5*REDMM*GSLL*FSOLL*X/(AMSC(IN)*XM1(1)*XM2(1))

      DFISS=DFISS-0.5*REDMM*GSSS*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2))

      DFILS=DFILS-0.5*REDMM*GSLS*FSOLS*X/(AMSC(IN)*XM1(3)*XM2(3))

      DFIDR=DFIDR-0.5*REDMM*GSDR*FSOSS*X/(AMSC(IN)*XM1(2)*XM2(2))

      ENDIF

C--------------------------------------------------------------------

C     ZERO IN FORM FACTOR:

      IF(IZSC.NE.0) THEN

c*    IF(IABS(IZSC).EQ.2) THEN

      FZERO = (AMSC(IN)/AMCRS)**2

      FC2   = FCLL1 + FSC(IN)*(1.5D0-XLAM1*XLAM1)

     .              * VKULL*AMSC(IN)/RATM1/RATM1

      FO1   = FSOLL - FSC(IN)*(VKULL/(2*RATM1*RATM1))

     .                *AMSC3

      FO21  = FSO2LL- FSC(IN)*VKULL/(4*RATM1**4)*AMSC5   

 

      VCLL  = VCLL   - FZERO*GSLL*(FCLL1-0.25D0*FAC1*FC2)

      VCSS  = VCSS   - FZERO*GSSS*(FCSS1-0.25D0*FAC2*FC2)

      VCLS  = VCLS   - FZERO*GSLS*(FCLS1-0.25D0*FAC3*FC2)

      VCDR  = VCDR   - FZERO*GSDR*(FCSS1-0.25D0*FAC2*FC2)

 

c     VSOLL = VSOLL  - FZERO*0.5D0*GSLL*FO1   

c     VSOSS = VSOSS  - FZERO*0.5D0*GSSS*FO1   

c     VSOLS = VSOLS  - FZERO*0.5D0*GSLS*FO1  

c     VSODR = VSODR  - FZERO*0.5D0*GSDR*FO1  

      VSOLL = VSOLL  - FZERO*0.5D0*GSLL*FO1/(XM1(1)*XM2(1))

      VSOSS = VSOSS  - FZERO*0.5D0*GSSS*FO1/(XM1(2)*XM2(2))

      VSOLS = VSOLS  - FZERO*0.5D0*GSLS*FO1/(XM1(3)*XM2(3))

      VSODR = VSODR  - FZERO*0.5D0*GSDR*FO1/(XM1(2)*XM2(2))

C

      VASOLL= VASOLL - FZERO*GSLL*FO1*FFAC1/4.D0

      VASOSS= VASOSS - FZERO*GSSS*FO1*FFAC2/4.D0

      VASOLS= VASOLS - FZERO*GSLS*FO1*FFAC3/4.D0

      VASODR= VASODR - FZERO*GSDR*FO1*FFAC2/4.D0

 

c     VSO2LL= VSO2LL - FZERO*GSLL*FO21/16.D0

c     VSO2SS= VSO2SS - FZERO*GSSS*FO21/16.D0   

c     VSO2LS= VSO2LS - FZERO*GSLS*FO21/16.D0

c     VSO2DR= VSO2DR - FZERO*GSDR*FO21/16.D0    

      VSO2LL= VSO2LL - FZERO*GSLL*FO21/(4*XM1(1)*XM2(1))**2

      VSO2SS= VSO2SS - FZERO*GSSS*FO21/(4*XM1(2)*XM2(2))**2          

      VSO2LS= VSO2LS - FZERO*GSLS*FO21/(4*XM1(3)*XM2(3))**2    

      VSO2DR= VSO2DR - FZERO*GSDR*FO21/(4*XM1(2)*XM2(2))**2           



c*    IF(NLOC.NE.0.AND.IZSC.EQ.-2) THEN

      IF(NLOC.NE.0.AND.IZSC.EQ.2) THEN

      FILL  = FILL + FZERO*0.5D0*REDMM*GSLL*FCLL1/(XM1(1)*XM2(1))

      FISS  = FISS + FZERO*0.5D0*REDMM*GSSS*FCSS1/(XM1(2)*XM2(2))

      FILS  = FILS + FZERO*0.5D0*REDMM*GSLS*FCLS1/(XM1(3)*XM2(3))

      FIDR  = FIDR + FZERO*0.5D0*REDMM*GSDR*FCSS1/(XM1(2)*XM2(2))



      DFILL=DFILL - FZERO*0.5*REDMM*GSLL*FO1*X/

     .                    (AMSC(IN)*XM1(1)*XM2(1))

      DFISS=DFISS - FZERO*0.5*REDMM*GSSS*FO1*X/

     .                    (AMSC(IN)*XM1(2)*XM2(2))

      DFILS=DFILS - FZERO*0.5*REDMM*GSLS*FO1*X/

     .                    (AMSC(IN)*XM1(3)*XM2(3))

      DFIDR=DFIDR - FZERO*0.5*REDMM*GSDR*FO1*X/

     .                    (AMSC(IN)*XM1(2)*XM2(2))

      ENDIF

      ENDIF

C--------------------------------------------------------------------

C

C     AUGUST 1998 ADDITIONS:

C     BEGIN RETARDATION

      IF(IRET.EQ.1) THEN      

      CALL FFUN(3,XA,AMSC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3)

      VCLL  = VCLL   - GSLL*WKIN1*VARFI0                     

      VCSS  = VCSS   - GSSS*WKIN2*VARFI0

      VCLS  = VCLS   - GSLS*WKIN3*VARFI0

      VCDR  = VCDR   - GSDR*WKIN2*VARFI0



      FILL  = FILL   + 0.5D0*GSLL*VARFI0

      FISS  = FISS   + 0.5D0*GSSS*VARFI0

      FILS  = FILS   + 0.5D0*GSLS*VARFI0

      FIDR  = FIDR   + 0.5D0*GSDR*VARFI0

C

      DFILL = DFILL  + 0.5D0*GSLL*VARFI1*PIM

      DFISS = DFISS  + 0.5D0*GSSS*VARFI1*PIM

      DFILS = DFILS  + 0.5D0*GSLS*VARFI1*PIM

      DFIDR = DFIDR  + 0.5D0*GSDR*VARFI1*PIM

      ENDIF

C     END RETARDATION

      

  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END



C**********************************************************************

C

      SUBROUTINE DIFRAC(XA,ICSB,NLOC,LC,I51)       

C

C**********************************************************************

C     VERSION AUGUST 2009: REFINED TREATMENT QUARK-CORE EFFECTS

C     VERSION OCTOBER 2004: SU3-SINGLET POMERON + SU3-NONET (A2, F2, FP2, K2)

C**********************************************************************

C

C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/PRMTRS/PAR(20,8)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

c*    DIMENSION GD(11),AMDF(5),FDC(5),XM1(3),XM2(3)

c*    EQUIVALENCE (GD1,GD(1))

      DIMENSION AMDF(6),FDC(6),XM1(3),XM2(3)

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/

     .     AMPRO/938.2796D0/,ICALL/0/,NATSCAL/0/

C

C   NOTE : POM(IN=1),A2(IN=2),F2(IN=3),POMP(IN=4),K**(IN=5)

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C-------------------------------------------------------------------

C   NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS !

C                                 : INDEX 2,4 -> HYPERONS !

C-------------------------------------------------------------------

C

      IF(IRET.EQ.1) THEN

      WKIN1 = PIM**2*AKS(1)/(2*REDM(1))

      WKIN2 = PIM**2*AKS(3)/(2*REDM(3))

      WKIN3 = 0.5D0*(WKIN1+WKIN2)

      ENDIF

C-------------------------------------------------------------------------

C     OLD:

C     QUARK-CLUSTER PAULI-REPULSION:

c     FLL51 = 1.D0+1D0/8D0*PAR(19,5)       ! NEW TREATMENT FI51 MARIUS

c     IF(I51.EQ.1) THEN

c     FSS51 = 1.D0+9D0/8D0*PAR(19,5)       ! NEW TREATMENT FI51 MARIUS

c     FDR51= 1D0

c     ENDIF

c     IF(I51.EQ.0) THEN

c     FDR51 = 1.D0+PAR(19,5)

c     FSS51 = 1.D0+1D0/8D0*PAR(19,5)       ! NEW TREATMENT FI51 MARIUS

c     ENDIF

C-------------------------------------------------------------------------

C     QUARK-CLUSTER PAULI-REPULSION:

C-----BBPROGS.AUG12.CSB/LPPROGS.02/YNRMP10.F-------------------------------

      FI51 = PAR(19,5)

      AMFI51= PAR(17,5)

      IF(AMFI51.EQ.0D0) AMFI51=AMPOM

C

      FLL51 = (1.D0+1D0/8D0)*FI51       ! NEW TREATMENT FI51 MARIUS

      IF(I51.EQ.1) THEN

      FSS51 = (1.D0+9D0/8D0)*FI51       ! NEW TREATMENT FI51 MARIUS

      FDR51= 1.D0*FI51

      ENDIF

      IF(I51.EQ.0) THEN

      FDR51 = 2.D0*FI51        

      FSS51 = (1.D0+1D0/8D0)*FI51       ! NEW TREATMENT FI51 MARIUS

      ENDIF

c     if(icall.eq.0) write(*,*) 'difrac:: I51=',I51,' FDR51=',FDR51,

c    .' P=',P      

C-------------------------------------------------------------------------



      DO 1040 IN=1,6

      IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

      ENDIF

      GOTO(1050,1051,1052,1053,1054,1055),IN

1050  GDLL = GD9*GD10

      GDSS=  GD9*GD11

      GDLS=  0D0

      GDDR=  GD9*GD11

      FDC(IN)=1.D0

      AMDF(IN)=AMFI51

C     QUARK-CLUSTER-MODEL PAULI-REPULSION:

      GDLL=  FLL51*GDLL             ! NEW TREATMENT FI51 MARIUS

      GDSS=  FSS51*GDSS 

      GDDR=  FDR51*GDDR 

      GOTO 1056

1051  GDLL = GD9*GD10*(1D0-FI51)

      GDSS=  GD9*GD11*(1D0-FI51)

      GDLS=  0D0

      GDDR=  GD9*GD11*(1D0-FI51)

      FDC(IN)=1.D0

      AMDF(IN)=AMPOM  

      GOTO 1056

1052  GDLL = -0.0271D0*ICSB*GDA(1)*GDA(3)

      GDSS=      -2.*GDA(1)*GDA(2)

      GDLS=     -SR3*GDA(1)*GDA(3)

      GDDR=          GDA(1)*GDA(2)

      FDC(IN)=1.D0

      AMDF(IN)=AMA2

      GOTO 1056

1053  GDLL=  GDA(6)*GDA(7)

      GDSS=  GDA(6)*GDA(8)

      GDLS=  0.D0

      GDDR=  GDA(6)*GDA(8)

      FDC(IN)=1.D0

      AMDF(IN)=AMPOM

      GOTO 1056

1054  GDLL=  GDA(9)*GDA(10)

      GDSS=  GDA(9)*GDA(11)

      GDLS=  0.D0

      GDDR=  GDA(9)*GDA(11)

      FDC(IN)=1.D0

      AMDF(IN)=AMF2

      GOTO 1056

1055  GDLL=      GDA(4)*GDA(4)*P

      GDSS=     -GDA(5)*GDA(5)*P

      GDLS= -SR3*GDA(4)*GDA(5)*P

      GDDR=    2*GDA(5)*GDA(5)*P

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMSN

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMSN

      FDC(IN)=1.D0

      AMDF(IN)=AMKSS

C

1056  AMDF2=AMDF(IN)*AMDF(IN)

      FAC1=AMDF2/(XM1(1)*XM2(1))

      FAC2=AMDF2/(XM1(2)*XM2(2))

      FAC3=AMDF2/(XM1(3)*XM2(3))

      FFAC1 = AMDF2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2)

      FFAC2 = AMDF2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2)

      FFAC3 = AMDF2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2)

      FAC12=FAC1*FAC1

      FAC22=FAC2*FAC2

      FAC32=FAC3*FAC3

c     universal scaling:

      IF(NATSCAL.EQ.0) THEN

c     if(icall.eq.0) write(*,*) 'obe.oct08, difrac: universal scaling'

      FLLDF=4*GDLL*AMDF2/(SRPI*AMPRO**2)

      FSSDF=4*GDSS*AMDF2/(SRPI*AMPRO**2)

      FLSDF=4*GDLS*AMDF2/(SRPI*AMPRO**2)

      FDRDF=4*GDDR*AMDF2/(SRPI*AMPRO**2)

      ENDIF

c     natural scaling:

      IF(NATSCAL.EQ.1) THEN

c     if(icall.eq.0) write(*,*) 'obe.oct08, difrac: natural scaling'

      FLLDF=4*GDLL*AMDF2/(SRPI*XM1(1)*XM2(1))

      FSSDF=4*GDSS*AMDF2/(SRPI*XM1(2)*XM2(2))

      FLSDF=4*GDLS*AMDF2/(SRPI*XM1(3)*XM2(3))

      FDRDF=4*GDDR*AMDF2/(SRPI*XM1(2)*XM2(2))

      ENDIF

c     if(icall.eq.0.and.in.le.2) then

c     write(*,*) ' DIFRAC : IN=',in,' I51=',i51,' FI51',fi51,

c    .' gddr=',gddr   

c     endif

C

c     DO 104 I=2,NMAX

c     X =(AMDF(IN)/PIM)*XA(I)

      X =(AMDF(IN)/PIM)*XA   

      X2=X*X

      VGSSX=AMDF(IN)*FDEXP(-X2)

      FCLL=1.D0+0.5D0*FAC1*(3.D0-2*X2)

      FCSS=1.D0+0.5D0*FAC2*(3.D0-2*X2)

      FCLS=1.D0+0.5D0*FAC3*(3.D0-2*X2)

      FCDR=1.D0+0.5D0*FAC2*(3.D0-2*X2)

C

      VCLL  = VCLL   + FLLDF*FCLL*VGSSX

      VCSS  = VCSS   + FSSDF*FCSS*VGSSX

      VCLS  = VCLS   + FLSDF*FCLS*VGSSX

      VCDR  = VCDR   + FDRDF*FCDR*VGSSX

C

      VSOLL = VSOLL  + FAC1*FLLDF*VGSSX

      VSOSS = VSOSS  + FAC2*FSSDF*VGSSX

      VSOLS = VSOLS  + FAC3*FLSDF*VGSSX

      VSODR = VSODR  + FAC2*FDRDF*VGSSX

C

      VASOLL = VASOLL  + FFAC1*FLLDF*VGSSX/4.D0

      VASOSS = VASOSS  + FFAC2*FSSDF*VGSSX/4.D0

      VASOLS = VASOLS  + FFAC3*FLSDF*VGSSX/4.D0

      VASODR = VASODR  + FFAC2*FDRDF*VGSSX/4.D0

C

      VSO2LL= VSO2LL + FAC12*FLLDF*VGSSX/4

      VSO2SS= VSO2SS + FAC22*FSSDF*VGSSX/4

      VSO2LS= VSO2LS + FAC32*FLSDF*VGSSX/4

      VSO2DR= VSO2DR + FAC22*FDRDF*VGSSX/4

C

      IF(NLOC.EQ.0) GOTO 104

      FILL  = FILL  - 0.5D0*REDMM*FLLDF*VGSSX/(XM1(1)*XM2(1))

      FISS  = FISS  - 0.5D0*REDMM*FSSDF*VGSSX/(XM1(2)*XM2(2))

      FILS  = FILS  - 0.5D0*REDMM*FLSDF*VGSSX/(XM1(3)*XM2(3))

      FIDR  = FIDR  - 0.5D0*REDMM*FDRDF*VGSSX/(XM1(2)*XM2(2))

C

      DFILL = DFILL+ 2*0.5D0*REDMM*FLLDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMY(1))

      DFISS = DFISS+ 2*0.5D0*REDMM*FSSDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMSS)

      DFILS = DFILS+ 2*0.5D0*REDMM*FLSDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMH)

      DFIDR = DFIDR+ 2*0.5D0*REDMM*FDRDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMSS)

C

      DDFILL = DDFILL+ 2*0.5D0*REDMM*FLLDF*(1D0-2*X*X)*VGSSX*FAC1   ! NOVEMBER 2010

      DDFISS = DDFISS+ 2*0.5D0*REDMM*FSSDF*(1D0-2*X*X)*VGSSX*FAC2

      DDFILS = DDFILS+ 2*0.5D0*REDMM*FLSDF*(1D0-2*X*X)*VGSSX*FAC3

      DDFIDR = DDFIDR+ 2*0.5D0*REDMM*FDRDF*(1D0-2*X*X)*VGSSX*FAC2

C

C     AUGUST 1998 ADDITIONS:

C     BEGIN RETARDATION

      IF(IRET.EQ.1) THEN      

      VARFI0 = FDEXP(-X2)

      VARFI1 = -2*X*VARFI0 

      VCLL  = VCLL   + FLLDF*WKIN1*VARFI0                     

      VCSS  = VCSS   + FSSDF*WKIN2*VARFI0

      VCLS  = VCLS   + FLSDF*WKIN3*VARFI0

      VCDR  = VCDR   + FDRDF*WKIN2*VARFI0

C

      FILL  = FILL   - 0.5D0*FLLDF*VARFI0

      FISS  = FISS   - 0.5D0*FSSDF*VARFI0

      FILS  = FILS   - 0.5D0*FLSDF*VARFI0

      FIDR  = FIDR   - 0.5D0*FDRDF*VARFI0

C

      DFILL = DFILL  - 2*0.5D0*FLLDF*VARFI1*PIM

      DFISS = DFISS  - 2*0.5D0*FSSDF*VARFI1*PIM

      DFILS = DFILS  - 2*0.5D0*FLSDF*VARFI1*PIM

      DFIDR = DFIDR  - 2*0.5D0*FDRDF*VARFI1*PIM

      ENDIF

C     END RETARDATION

C

  104 CONTINUE

c

c     print spin-orbit potentials LL:

c     write(*,*) ' DIFRAC : x=',xa,' IN=',in,' vsoll=',vsoll,

c    .' vasoll=',vasoll

c     if(icall.eq.0) then

c     write(*,*) ' DIFRAC : x=',xa,' IN=',in,' vcll',vcll,

c    .' vcss=',vcss,' vcls=',vcls   

c     write(*,*) ' DIFRAC : gdll=',gdll                      

c     endif



 1040 CONTINUE

C

C     JULY 2007: HEAVY (HARD) POMERON:

      CALL HDIFRAC(XA,NLOC,NATSCAL,ICSB,I51,PX)

C

      RETURN

      END

************************************************************************

C

      SUBROUTINE HDIFRAC(XA,NLOC,NATSCAL,ICSB,I51,PX)

C

C**********************************************************************

C     VERSION MAY 2007:   HEAVY(HARD) POMERON = SU3-SINGLET  

C**********************************************************************

C

C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRMTRS/PAR(20,8)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,IPSC2

c*    COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c*    COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      DIMENSION AMDF(5),FDC(5),XM1(3),XM2(3)         

      DATA SR3/1.732051D0/,SRPI/1.772454D0/,FMNL/1.D0/

     .     AMPRO/938.2796D0/,AMPOMH/600D0/,ICALL/0/,NS/0/

      DATA AKAP1/0D0/,AKAP2/0D0/

C-------------------------------------------------------------------

C

C   NOTE : IDIF =1 -> NORMAL (HEAVY) POMERON

C          IDIF =2 -> VOLUME INT=0 (HEAVY) POMERON

C          IDIF =3 -> COMPLETE ODDERON: P=C=-1       

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C   NOTE : FOR SIGMA-NUCLEON INTERACTION:

C          I=1/2,1S0: I51 = 1 -> QCM PREDICTS STRONG PAULI REPULSION

C          I=1/2,3S1: I51 = 0 -> QCM REPULSION APPROX. A LA POMERON ETC.

C-------------------------------------------------------------------

C   NOTE : FOR 'DIRECT POTENTIALS': INDEX 1,3 -> NUCLEONS !

C                                 : INDEX 2,4 -> HYPERONS !

C-------------------------------------------------------------------

C

C

      IF(IDIF.EQ.1) RETURN          ! MARCH 2009

c*    RSCAL = DSQRT(PAR(15,1))

      RSCAL = 1D0                   ! APRIL 2009

      AMPOMH= PAR(14,6)

      GHPOM = PAR(13,6)*RSCAL

      FHPOM = PAR(12,6)*RSCAL



      IF(FHPOM.EQ.0D0) FHPOM = -GHPOM              

      GHPOM2= GHPOM*GHPOM

      FHPOM2= FHPOM*FHPOM

      IF(PAR(13,6).LT.0D0) GHPOM2=-GHPOM2



      DO 1040 IN=1,1

      IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

      ENDIF

1051  GDLL=  GHPOM2 

      GDSS=  GHPOM2

      GDLS=  0.D0

      GDDR=  GHPOM2

      FDLL=  0.D0

      FDSS=  0.D0

      FDLS=  0.D0

      FDDR=  0.D0

      IF(IDIF.EQ.3) THEN

      FDLL=  FHPOM2     

      FDSS=  FHPOM2     

      FDLS=  0D0        

      FDDR=  FHPOM2     

      ENDIF

      IF(GHPOM.NE.0D0) THEN

      AKAP1= FHPOM/GHPOM

      AKAP2= FHPOM/GHPOM

      ENDIF

C     moved to DIFRAC:

C     QUARK-CLUSTER-MODEL (QCM):

c     GDSS=  FSS51*GDSS

c     FDSS=  FSS51*FDSS

c     GDDR=  FDR51*GDDR

c     FDDR=  FDR51*FDDR



      FDC(1)=1.D0

      AMDF(1)=AMPOMH

      GOTO 1056

C

1056  AMDF2=AMDF(IN)*AMDF(IN)

      FAC1=AMDF2/(XM1(1)*XM2(1))

      FAC2=AMDF2/(XM1(2)*XM2(2))

      FAC3=AMDF2/(XM1(3)*XM2(3))

      FAC0=AMDF2/AMPRO/AMPRO



      FFAC1 = AMDF2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2)

      FFAC2 = AMDF2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2)

      FFAC3 = AMDF2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2)

      FAC12=FAC1*FAC1

      FAC22=FAC2*FAC2

      FAC32=FAC3*FAC3

c     universal scaling:

      IF(NATSCAL.EQ.0) THEN

      if(icall.eq.0.and.ns.ne.0) write(*,*) 

     .'obe.oct08, difrac: universal scaling'

      FLLDF=4*GDLL*AMDF2/(SRPI*AMPRO**2)

      FSSDF=4*GDSS*AMDF2/(SRPI*AMPRO**2)

      FLSDF=4*GDLS*AMDF2/(SRPI*AMPRO**2)

      FDRDF=4*GDDR*AMDF2/(SRPI*AMPRO**2)

      ENDIF

c     natural scaling:

      IF(NATSCAL.EQ.1) THEN

      if(icall.eq.0.and.ns.ne.0) write(*,*) 

     .'obe.oct08, difrac: natural scaling'

      FLLDF=4*GDLL*AMDF2/(SRPI*XM1(1)*XM2(1))

      FSSDF=4*GDSS*AMDF2/(SRPI*XM1(2)*XM2(2))

      FLSDF=4*GDLS*AMDF2/(SRPI*XM1(3)*XM2(3))

      FDRDF=4*GDDR*AMDF2/(SRPI*XM1(2)*XM2(2))

      ENDIF

      ICALL=1

C     FOR IDIF=3:

      RATXM1 = DSQRT(XM1(1)*XM2(1))/AMPRO

      CLLC= 1D0

      CLLS= (1D0+AKAP1*RATXM1)*(1D0+AKAP2*RATXM1)

      CLLT= CLLS

      CLLO= (3D0+(AKAP1+AKAP2)*RATXM1)

      CLLQ= (1D0+4*(AKAP1+AKAP2)*RATXM1+8*AKAP1*AKAP2*RATXM1**2)

C

c*    DO 104 I=2,NMAX

      X =(AMDF(IN)/PIM)*XA

      X2=X*X

      VGSSX=AMDF(IN)*FDEXP(-X2)

     

      IF(IDIF.EQ.1) THEN

      FCLL=1.D0+0.5D0*FAC1*(3.D0-2*X2)

      FCSS=1.D0+0.5D0*FAC2*(3.D0-2*X2)

      FCLS=1.D0+0.5D0*FAC3*(3.D0-2*X2)

      FCDR=1.D0+0.5D0*FAC2*(3.D0-2*X2)

C

      VCLL  = VCLL   + FLLDF*FCLL*VGSSX

      VCSS  = VCSS   + FSSDF*FCSS*VGSSX

      VCLS  = VCLS   + FLSDF*FCLS*VGSSX

      VCDR  = VCDR   + FDRDF*FCDR*VGSSX

C

      VSOLL = VSOLL  + FAC1*FLLDF*VGSSX

      VSOSS = VSOSS  + FAC2*FSSDF*VGSSX

      VSOLS = VSOLS  + FAC3*FLSDF*VGSSX

      VSODR = VSODR  + FAC2*FDRDF*VGSSX

C

      VASOLL = VASOLL  + FFAC1*FLLDF*VGSSX/4.D0

      VASOSS = VASOSS  + FFAC2*FSSDF*VGSSX/4.D0

      VASOLS = VASOLS  + FFAC3*FLSDF*VGSSX/4.D0

      VASODR = VASODR  + FFAC2*FDRDF*VGSSX/4.D0

C

      VSO2LL= VSO2LL + FAC12*FLLDF*VGSSX/4

      VSO2SS= VSO2SS + FAC22*FSSDF*VGSSX/4

      VSO2LS= VSO2LS + FAC32*FLSDF*VGSSX/4

      VSO2DR= VSO2DR + FAC22*FDRDF*VGSSX/4

C

      IF(NLOC.EQ.0) GOTO 104

      FILL  = FILL  - 0.5D0*REDMM*FLLDF*VGSSX/(XM1(1)*XM2(1))

      FISS  = FISS  - 0.5D0*REDMM*FSSDF*VGSSX/(XM1(2)*XM2(2))

      FILS  = FILS  - 0.5D0*REDMM*FLSDF*VGSSX/(XM1(3)*XM2(3))

      FIDR  = FIDR  - 0.5D0*REDMM*FDRDF*VGSSX/(XM1(2)*XM2(2))

C

      DFILL = DFILL + REDMM*FLLDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMY(1))

      DFISS = DFISS + REDMM*FSSDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMSS)

      DFILS = DFILS + REDMM*FLSDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMH)

      DFIDR = DFIDR + REDMM*FDRDF*AMDF(IN)*X*VGSSX

     .                     /(AM(1)*AMSS)



      DDFILL  = DDFILL + REDMM*FLLDF*(1D0-2*X*X)*VGSSX*FAC1            

      DDFISS  = DDFISS + REDMM*FSSDF*(1D0-2*X*X)*VGSSX*FAC2            

      DDFILS  = DDFILS + REDMM*FLSDF*(1D0-2*X*X)*VGSSX*FAC3            

      DDFIDR  = DDFIDR + REDMM*FDRDF*(1D0-2*X*X)*VGSSX*FAC2            

      ENDIF

C

C------------------------------------------------------------------

C     ODDERON: P=C=-1

C------------------------------------------------------------------

      IF(IDIF.EQ.2) THEN

      FCLL1=FAC1*(3.D0-2*X2)

      FCSS1=FAC2*(3.D0-2*X2)

      FCLS1=FAC3*(3.D0-2*X2)

      FCDR1=FAC2*(3.D0-2*X2)

C

      VCLL  = VCLL + FLLDF*FCLL1*VGSSX

      VCSS  = VCSS + FSSDF*FCSS1*VGSSX

      VCLS  = VCLS + FLSDF*FCLS1*VGSSX

      VCDR  = VCDR + FDRDF*FCDR1*VGSSX

      ENDIF

C------------------------------------------------------------------

C     ADDITIONS AUGUST 29, 2007/AMENDED IN MARCH 2009:

C------------------------------------------------------------------

      IF(IDIF.EQ.3) THEN

      FCLL1=FAC0*(3.D0-2*X2)

      FCSS1=FAC0*(3.D0-2*X2)

      FCLS1=FAC0*(3.D0-2*X2)

      FCDR1=FAC0*(3.D0-2*X2)



      FCLL2=FAC0*(15D0-20*X2+4*X2*X2)

      FCSS2=FAC0*(15D0-20*X2+4*X2*X2)

      FCLS2=FAC0*(15D0-20*X2+4*X2*X2)

      FCDR2=FAC0*(15D0-20*X2+4*X2*X2)



      FCLL2= 0.D0       ! NO K^4-TERMS, APRIL 2209

      FCSS2= 0.D0       ! NO K^4-TERMS, APRIL 2209

      FCLS2= 0.D0       ! NO K^4-TERMS, APRIL 2209

      FCDR2= 0.D0       ! NO K^4-TERMS, APRIL 2209



      FTLL1=FAC0*X2*(7D0-2*X2)

      FTSS1=FAC0*X2*(7D0-2*X2)

      FTLS1=FAC0*X2*(7D0-2*X2)

      FTDR1=FAC0*X2*(7D0-2*X2)



      FOLL1=FAC0*(5D0-2*X2)    

      FOSS1=FAC0*(5D0-2*X2)    

      FOLS1=FAC0*(5D0-2*X2)    

      FODR1=FAC0*(5D0-2*X2)    



      FO2LL1=FAC0*(7D0-2*X2)

      FO2SS1=FAC0*(7D0-2*X2)

      FO2LS1=FAC0*(7D0-2*X2)

      FO2DR1=FAC0*(7D0-2*X2)



      DFCLL1 = -2*AMDF(IN)*X*FOLL1      ! FEB2009

      DFCSS1 = -2*AMDF(IN)*X*FOSS1      ! FEB2009

      DFCLS1 = -2*AMDF(IN)*X*FOLS1      ! FEB2009

      DFCDR1 = -2*AMDF(IN)*X*FODR1      ! FEB2009

C

      VCLL = VCLL + FLLDF*CLLC*FCLL1*VGSSX*2D0

     .             - FLLDF*CLLC*FCLL2*VGSSX*FAC1*2D0       ! FEB2009

      VCSS = VCSS + FSSDF*CLLC*FCSS1*VGSSX*2D0

     .             - FSSDF*CLLC*FCSS2*VGSSX*FAC2*2D0       ! FEB2009

      VCLS = VCLS + FLSDF*CLLC*FCLS1*VGSSX*2D0

     .             - FLSDF*CLLC*FCLS2*VGSSX*FAC3*2D0       ! FEB2009

      VCDR = VCDR + FDRDF*CLLC*FCDR1*VGSSX*2D0

     .             - FDRDF*CLLC*FCDR2*VGSSX*FAC2*2D0       ! FEB2009

C

      VSIGLL = VSIGLL - FLLDF*CLLS*FCLL2*VGSSX*FAC1*2/3D0

      VSIGSS = VSIGSS - FSSDF*CLLS*FCSS2*VGSSX*FAC2*2/3D0

      VSIGLS = VSIGLS - FLSDF*CLLS*FCLS2*VGSSX*FAC3*2/3D0

      VSIGDR = VSIGDR - FDRDF*CLLS*FCDR2*VGSSX*FAC2*2/3D0

C

      VTENLL = VTENLL - FLLDF*CLLT*FTLL1*VGSSX*FAC1*2/3D0

      VTENSS = VTENSS - FSSDF*CLLT*FTSS1*VGSSX*FAC2*2/3D0

      VTENLS = VTENLS - FLSDF*CLLT*FTLS1*VGSSX*FAC3*2/3D0

      VTENDR = VTENDR - FDRDF*CLLT*FTDR1*VGSSX*FAC2*2/3D0

C

      VSOLL = VSOLL - FLLDF*CLLO*FOLL1*VGSSX*FAC1*2D0

      VSOSS = VSOSS - FSSDF*CLLO*FOSS1*VGSSX*FAC2*2D0

      VSOLS = VSOLS - FLSDF*CLLO*FOLS1*VGSSX*FAC3*2D0

      VSODR = VSODR - FDRDF*CLLO*FODR1*VGSSX*FAC2*2D0

C

c*    geen extra factor zoals cllo ? etc.

      VASOLL = VASOLL -FFAC1*FLLDF*FOLL1*VGSSX

      VASOSS = VASOSS -FFAC2*FSSDF*FOSS1*VGSSX

      VASOLS = VASOLS -FFAC3*FLSDF*FOLS1*VGSSX

      VASODR = VASODR -FFAC2*FDRDF*FODR1*VGSSX

C

      VSO2LL = VSO2LL +FLLDF*CLLQ*FO2LL1*VGSSX*FAC1**2/2D0

      VSO2SS = VSO2SS +FSSDF*CLLQ*FO2SS1*VGSSX*FAC2**2/2D0

      VSO2LS = VSO2LS +FLSDF*CLLQ*FO2LS1*VGSSX*FAC3**2/2D0

      VSO2DR = VSO2DR +FDRDF*CLLQ*FO2DR1*VGSSX*FAC2**2/2D0



C     NON-LOCAL ADDITIONS FEB2009:

      IF(NLOC.NE.0) THEN         

      FILL  = FILL  +4*0.75D0*REDMM*FCLL1*VGSSX/(XM1(1)*XM2(1))

     .*FLLDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      FISS  = FISS  +4*0.75D0*REDMM*FCSS1*VGSSX/(XM1(2)*XM2(2))

     .*FSSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      FILS  = FILS  +4*0.75D0*REDMM*FCLS1*VGSSX/(XM1(3)*XM2(3))

     .*FLSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      FIDR  = FIDR  +4*0.75D0*REDMM*FCDR1*VGSSX/(XM1(2)*XM2(2))

     .*FDRDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

C

      DFILL = DFILL +4*0.75D0*REDMM*DFCLL1*VGSSX/(XM1(1)*XM2(1))

     .*FLLDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      DFISS = DFISS +4*0.75D0*REDMM*DFCSS1*VGSSX/(XM1(2)*XM2(2))

     .*FSSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      DFILS = DFILS +4*0.75D0*REDMM*DFCLS1*VGSSX/(XM1(3)*XM2(3))

     .*FLSDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb

      DFIDR = DFIDR +4*0.75D0*REDMM*DFCDR1*VGSSX/(XM1(2)*XM2(2))

     .*FDRDF ! APRIL 2009, but not in SP a la bbprogs.aug12.csb



      FCLL2 = FAC0*(5D0-16*X2+4*X2*X2)

      DDFILL = DDFILL  -8*0.75D0*REDMM*FCLL2*VGSSX*FAC1*FLLDF ! NOVEMBER 2010

      DDFISS = DDFISS  -8*0.75D0*REDMM*FCLL2*VGSSX*FAC2*FSSDF ! NOVEMBER 2010

      DDFILS = DDFILS  -8*0.75D0*REDMM*FCLL2*VGSSX*FAC3*FLSDF ! NOVEMBER 2010

      DDFIDR = DDFIDR  -8*0.75D0*REDMM*FCLL2*VGSSX*FAC2*FDRDF ! NOVEMBER 2010

      ENDIF

      ENDIF         ! END IDIF.EQ.3

C

  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END

C **************************************************************

      SUBROUTINE AXIAL1(XA,NLOC,ICSB,LC,P,PX)

C     SUBROUTINE AXIAL1(NMAX,NLOC,ICSB,P,PX)

C**********************************************************************

C

C     AXIAL MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

C     IN MOMENTUM SPACE AXIAL-EXCHANGE:                         

C

C     FIRST TERM PROPAGATOR:

C     V_A^(1) = -GA2*[[(1+(Q2+K2/4)/(6M'M)](SIGMA1.SIGMA2)+

C                     +(2/M'M)[(SIGMA1.Q)(SIGMA2.Q)-Q2(SIGMA1.SIGMA2)/3]

C                     -(1/4M'M)[(SIGMA1.K)(SIGMA2.K)-K2(SIGMA1.SIGMA2)/3]

C                     +(i/4M'M)(SIGMA1+SIGMA2).QXK ]]/(K2+MA2)

C

C     APPROXIMATION: FROM Q-TENSOR TERM: ONLY LOCAL CONTRIBUTION KEPT!

C                    ------------------------------------------------

C

C   NOTE : A1(1270)(IN=1),D=F1(1285)(IN=2),E=F1(1420)(IN=3)

C

C   ONLY PSEUDO-VECTOR COUPLING INCLUDED !

C

C   PROPAGATOR OPTIONS: A) PROCA,IBFLD=0, B) B-FIELD FORMALISM, IBFLD=1

C**********************************************************************

C

C   THE POTENTIAL FUNCTIONS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN

      COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX

      COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      DIMENSION AMAX(4),XM1(3),XM2(3)

      DATA SR3/1.732051D0/,SRPI/1.772454D0/

      DATA AMA1,AMD1,AME1,AMK1/1270.D0,1285.D0,1420.D0,1273.D0/

      DATA IBFLD/0/,ICALL/0/,FZERO/0.D0/,AMCRA/750.D0/



      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C

      IF(ICALL.EQ.0) THEN

      IF(NS.NE.0) WRITE(*,*) ' AXIAL.02: IBFLD=',IBFLD

      ICALL=1

      ENDIF

C

      DIV1 =1.D0/(AM(1)*AMY(1))

      DIV2 =1.D0/(AM(1)*AMY(2))

      DIV3 =1.D0/(AM(1)*AMH   )

      DO 1040 IN=1,4

      IF(IN.EQ.1) THEN

      XM1(1)=AMY(1)

      XM1(2)=AMSS  

      XM1(3)=AMH

      XM2(1)=AM(1)

      XM2(2)=AMNN 

      XM2(3)=AM(1)

      ENDIF

      GOTO(1051,1052,1053,1054),IN

1051  GALL= 0.D0   

      GASS= -2*FA(1)*FA(2)

      GALS= -SR3*FA(1)*FA(3)

      GADR= FA(1)*FA(2)

      AMAX(1)=AMA1

      GOTO 1055

1052  GALL=  FA(6)*FA(7)

      GASS=  FA(6)*FA(8)  

      GALS=  0.D0

      GADR=  FA(6)*FA(8)  

      AMAX(2)=AME1

      GOTO 1055

1053  GALL=  FA(9)*FA(10)

      GASS=  FA(9)*FA(11)

      GALS=  0.D0

      GADR=  FA(9)*FA(11)

      AMAX(3)=AMD1

      GOTO 1055

1054  GALL=  FA(4)*FA(4)*P

      GASS= -FA(5)*FA(5)*P

      GALS= -SR3*FA(4)*FA(5)*P

      GADR= 2*FA(5)*FA(5)*P

      AMAX(4)=AMK1

      XM1(1)=AMLN

      XM1(2)=AMSN

      XM1(3)=AMSN

      XM2(1)=AMLN

      XM2(2)=AMSN

      XM2(3)=AMSN

C

1055  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN      

      ALAM = ALMAX

      IF(ALAM.EQ.0.D0) ALAM=ALMP8

      IF(IN.EQ.2.AND.ALAM.EQ.0.D0) ALAM=ALMP1

      IF(IN.EQ.4.AND.ALAM.EQ.0.D0) ALAM=ALMKA

      ENDIF



      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

      AMAX2=AMAX(IN)*AMAX(IN)

      RATM1=AMAX(IN)/ALM1

      RATM2=AMAX(IN)/ALM2

      RATM3=AMAX(IN)/ALM3

      FAC1 =AMAX(IN)**2/(AM(1)*AMY(1))

      FAC2 =AMAX(IN)**2/(AM(1)*AMY(2))

      FAC3 =AMAX(IN)**2/(AM(1)*AMH   )

      FFAC1 = AMAX2*(1.D0/XM1(1)**2-1.D0/XM2(1)**2)

      FFAC2 = AMAX2*(1.D0/XM1(2)**2-1.D0/XM2(2)**2)

      FFAC3 = AMAX2*(1.D0/XM1(3)**2-1.D0/XM2(3)**2)



      IF(IZAX.NE.0) FZERO = (AMAX(IN)/AMCRA)**2

C

C     DO 104 I=2,NMAX

      XLAM1=0.5D0*XA*ALM1/PIM

      XLAM2=0.5D0*XA*ALM2/PIM

      XLAM3=0.5D0*XA*ALM3/PIM

      X =(AMAX(IN)/PIM)*XA

      EX=FDEXP(X)

      VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLL0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLL1  = FCLL0  - VKULL*AMAX(IN)

      DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM

      DFCLL1 =  DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN)

      DFTLL0 =  DFCLL1/3.D0-3*FTLL0*PIM/XA

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTSS0  = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCSS1  = FCSS0  - VKUSS*AMAX(IN)

      DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM

      DFCSS1 =  DFCSS0 + ALM2*XLAM2*VKUSS*AMAX(IN)

      DFTSS0 =  DFCSS1/3.D0-3*FTSS0*PIM/XA

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLS0  = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLS1  = FCLS0  - VKULS*AMAX(IN)

      DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM

      DFCLS1 =  DFCLS0 + ALM3*XLAM3*VKULS*AMAX(IN)

      DFTLS0 =  DFCLS1/3.D0-3*FTLS0*PIM/XA



      IF(IZAX.NE.0) THEN

      FCLL2  = FCLL1 + (1.5D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/RATM1/RATM1

      DFCLL2 = DFCLL1 -ALM1*XLAM1*(2.5D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/RATM1/RATM1

      FTLL1  = FTLL0 - XLAM1*XLAM1*VKULL*AMAX(IN)/(3*RATM1*RATM1)

      DFTLL1 = DFTLL0- ALM1*XLAM1*(1D0-XLAM1*XLAM1)

     .               * VKULL*AMAX(IN)/(3*RATM1*RATM1)

      FSOLL1 = FSOLL0 - 0.5D0*(ALM1/AMAX(IN))**2*VKULL*AMAX(IN)



      FCSS2  = FCSS1 + (1.5D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/RATM2/RATM2

      DFCSS2 = DFCSS1 -ALM2*XLAM2*(2.5D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/RATM2/RATM2

      FTSS1  = FTSS0 - XLAM2*XLAM2*VKUSS*AMAX(IN)/(3*RATM2*RATM2)

      DFTSS1 = DFTSS0- ALM2*XLAM2*(1D0-XLAM2*XLAM2)

     .               * VKUSS*AMAX(IN)/(3*RATM2*RATM2)

      FSOSS1 = FSOSS0 - 0.5D0*(ALM2/AMAX(IN))**2*VKUSS*AMAX(IN)



      FCLS2  = FCLS1 + (1.5D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/RATM3/RATM3

      DFCLS2 = DFCLS1 -ALM3*XLAM3*(2.5D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/RATM3/RATM3

      FTLS1  = FTLS0 - XLAM3*XLAM3*VKUSS*AMAX(IN)/(3*RATM3*RATM3)

      DFTLS1 = DFTLS0- ALM3*XLAM3*(1D0-XLAM3*XLAM3)

     .               * VKULS*AMAX(IN)/(3*RATM3*RATM3)

      FSOLS1 = FSOLS0 - 0.5D0*(ALM3/AMAX(IN))**2*VKULS*AMAX(IN)

      

C*    neglecting k^4-terms:

      fcll2 = 0d0

      fcss2 = 0d0

      fcls2 = 0d0

      dfcll2 = 0d0

      dfcss2 = 0d0

      dfcls2 = 0d0

      ENDIF

C---------------------------------------------------------------

C

C     FIRST TERM AXIAL PROPAGATOR:

C

C---------------------------------------------------------------

      VSIGLL = VSIGLL - GALL*FCLL0 

      VSIGSS = VSIGSS - GASS*FCSS0 

      VSIGLS = VSIGLS - GALS*FCLS0 

      VSIGDR = VSIGDR - GADR*FCSS0 



      VTENLL = VTENLL - 0.75D0*GALL*FAC1 *FTLL0

      VTENSS = VTENSS - 0.75D0*GASS*FAC2 *FTSS0

      VTENLS = VTENLS - 0.75D0*GALS*FAC3 *FTLS0

      VTENDR = VTENDR - 0.75D0*GADR*FAC2 *FTSS0



      VSOLL  = VSOLL  - 0.5D0*GALL*FAC1 *FSOLL0

      VSOSS  = VSOSS  - 0.5D0*GASS*FAC2 *FSOSS0

      VSOLS  = VSOLS  - 0.5D0*GALS*FAC3 *FSOLS0

      VSODR  = VSODR  - 0.5D0*GADR*FAC2 *FSOSS0

 

      VASOLL = VASOLL + 0.25D0*GALL*FSOLL0*FFAC1

      VASOSS = VASOSS + 0.25D0*GASS*FSOSS0*FFAC2

      VASOLS = VASOLS + 0.25D0*GALS*FSOLS0*FFAC3

      VASODR = VASODR + 0.25D0*GADR*FSOSS0*FFAC2



      FISLL  = FISLL  - GALL*FCLL0*DIV1*REDM(1)/6.D0

      FISSS  = FISSS  - GASS*FCSS0*DIV2*REDM(2)/6.D0

      FISLS  = FISLS  - GALS*FCLS0*DIV3*REDM(3)/6.D0

      FISDR  = FISDR  - GADR*FCSS0*DIV2*REDM(2)/6.D0



      DFISLL = DFISLL - GALL*DFCLL0*DIV1*REDM(1)/6.D0

      DFISSS = DFISSS - GASS*DFCSS0*DIV2*REDM(2)/6.D0

      DFISLS = DFISLS - GALS*DFCLS0*DIV3*REDM(3)/6.D0

      DFISDR = DFISDR - GADR*DFCSS0*DIV2*REDM(2)/6.D0



      DDFSLL = DDFSLL - GALL*AMAX2*(FCLL1+2*FSOLL0)*DIV1*REDM(1)/6.D0

      DDFSSS = DDFSSS - GASS*AMAX2*(FCSS1+2*FSOSS0)*DIV2*REDM(2)/6.D0

      DDFSLS = DDFSLS - GALS*AMAX2*(FCLS1+2*FSOLS0)*DIV3*REDM(3)/6.D0

      DDFSDR = DDFSDR - GADR*AMAX2*(FCSS1+2*FSOSS0)*DIV2*REDM(2)/6.D0



      IF(IZAX.NE.0) THEN

      VSIGLL = VSIGLL - FZERO*GALL*(FCLL1 + 2*FAC1*FCLL2/3D0)

      VSIGSS = VSIGSS - FZERO*GASS*(FCSS1 + 2*FAC2*FCSS2/3D0)

      VSIGLS = VSIGLS - FZERO*GALS*(FCLS1 + 2*FAC3*FCLS2/3D0)

      VSIGDR = VSIGDR - FZERO*GADR*(FCSS1 + 2*FAC2*FCSS2/3D0)



      VTENLL = VTENLL + 0.25D0*FZERO*GALL*FAC1 *FTLL1

      VTENSS = VTENSS + 0.25D0*FZERO*GASS*FAC2 *FTSS1

      VTENLS = VTENLS + 0.25D0*FZERO*GALS*FAC3 *FTLS1

      VTENDR = VTENDR + 0.25D0*FZERO*GADR*FAC2 *FTSS1



      VSOLL  = VSOLL  - 0.5D0*FZERO*GALL*FAC1 *FSOLL1

      VSOSS  = VSOSS  - 0.5D0*FZERO*GASS*FAC2 *FSOSS1

      VSOLS  = VSOLS  - 0.5D0*FZERO*GALS*FAC3 *FSOLS1

      VSODR  = VSODR  - 0.5D0*FZERO*GADR*FAC2 *FSOSS1



      FISLL  = FISLL  - FZERO*3*GALL*FCLL1*DIV1*REDM(1)/2.D0

      FISSS  = FISSS  - FZERO*3*GASS*FCSS1*DIV2*REDM(2)/2.D0

      FISLS  = FISLS  - FZERO*3*GALS*FCLS1*DIV3*REDM(3)/2.D0

      FISDR  = FISDR  - FZERO*3*GADR*FCSS1*DIV2*REDM(2)/2.D0



      DFISLL = DFISLL - FZERO*3*GALL*DFCLL1*DIV1*REDM(1)/2.D0

      DFISSS = DFISSS - FZERO*3*GASS*DFCSS1*DIV2*REDM(2)/2.D0

      DFISLS = DFISLS - FZERO*3*GALS*DFCLS1*DIV3*REDM(3)/2.D0

      DFISDR = DFISDR - FZERO*3*GADR*DFCSS1*DIV2*REDM(2)/2.D0



      DDFSLL = DDFSLL - FZERO*GALL*AMAX2*(FCLL2+2*FSOLL1)*

     .                    DIV1*REDM(1)/6.D0

      DDFSSS = DDFSSS - FZERO*GASS*AMAX2*(FCSS2+2*FSOSS1)*

     .                    DIV2*REDM(2)/6.D0

      DDFSLS = DDFSLS - FZERO*GALS*AMAX2*(FCLS2+2*FSOLS1)*

     .                    DIV3*REDM(3)/6.D0

      DDFSDR = DDFSDR - FZERO*GADR*AMAX2*(FCSS2+2*FSOSS1)*

     .                    DIV2*REDM(2)/6.D0

      ENDIF

C---------------------------------------------------------------

C

C     SECOND TERM AXIAL PROPAGATOR:

C

C---------------------------------------------------------------

      IF(IBFLD.EQ.0) THEN

C---------------------------------------------------------------

      VSIGLL = VSIGLL + GALL*FCLL1/3

      VSIGSS = VSIGSS + GASS*FCSS1/3

      VSIGLS = VSIGLS + GALS*FCLS1/3

      VSIGDR = VSIGDR + GADR*FCSS1/3



      VTENLL = VTENLL + GALL*FTLL0

      VTENSS = VTENSS + GASS*FTSS0

      VTENLS = VTENLS + GALS*FTLS0

      VTENDR = VTENDR + GADR*FTSS0



      FISLL  = FISLL  - GALL*REDM(1)*FCLL1*DIV1/6.D0

      FISSS  = FISSS  - GASS*REDM(2)*FCSS1*DIV2/6.D0

      FISLS  = FISLS  - GALS*REDM(3)*FCLS1*DIV3/6.D0

      FISDR  = FISDR  - GADR*REDM(2)*FCSS1*DIV2/6.D0



      DFISLL = DFISLL - GALL*REDM(1)*DFCLL1*DIV1/6.D0

      DFISSS = DFISSS - GASS*REDM(2)*DFCSS1*DIV2/6.D0

      DFISLS = DFISLS - GALS*REDM(3)*DFCLS1*DIV3/6.D0

      DFISDR = DFISDR - GADR*REDM(2)*DFCSS1*DIV2/6.D0



c     FITEN     = FITEN  - GAX2*REDM*FT0 *DIV/2.D0

c     DFITEN    = DFITEN - GAX2*REDM*DFT0*DIV/2.D0



      IF(IZAX.NE.0) THEN

      VSIGLL = VSIGLL + FZERO*GALL*FCLL2/3D0

      VSIGSS = VSIGSS + FZERO*GASS*FCSS2/3D0

      VSIGLS = VSIGLS + FZERO*GALS*FCLS2/3D0

      VSIGDR = VSIGDR + FZERO*GADR*FCSS2/3D0



      VTENLL = VTENLL + FZERO*GALL*FTLL1

      VTENSS = VTENSS + FZERO*GASS*FTSS1

      VTENLS = VTENLS + FZERO*GALS*FTLS1

      VTENDR = VTENDR + FZERO*GADR*FTSS1



      FISLL  = FISLL  - FZERO*GALL*REDM(1)*FCLL2*DIV1/6.D0

      FISSS  = FISSS  - FZERO*GASS*REDM(2)*FCSS2*DIV2/6.D0

      FISLS  = FISLS  - FZERO*GALS*REDM(3)*FCLS2*DIV3/6.D0

      FISDR  = FISDR  - FZERO*GADR*REDM(2)*FCSS2*DIV2/6.D0



      DFISLL = DFISLL - FZERO*GALL*REDM(1)*DFCLL2*DIV1/6.D0

      DFISSS = DFISSS - FZERO*GASS*REDM(2)*DFCSS2*DIV2/6.D0

      DFISLS = DFISLS - FZERO*GALS*REDM(3)*DFCLS2*DIV3/6.D0

      DFISDR = DFISDR - FZERO*GADR*REDM(2)*DFCSS2*DIV2/6.D0

      ENDIF

      ENDIF

C---------------------------------------------------------------

      IF(IBFLD.EQ.1) THEN

      write(*,*)'warning:in axial.02: ibfld=1: not yet implemented'

      return

      ENDIF

C---------------------------------------------------------------

C

C     GAUSSIAN CONTRIBUTION (ANN.PHYS. 208, EQN. (7.16)):

C

C---------------------------------------------------------------

c     UPSC0 =   VKULL*AMAX(IN)

c     UPSC1 =  -(1.5D0-XLAM1**2)*UPSC0

c     UPST0 =  + XLAM1**2*UPSC0/3.D0

c     DUPSC0=  -ALM1*XLAM1*UPSC0/PIM

c     FIC1 = -VKULL*AMAX(IN)

c     DFIC1= -ALM1*XLAM1*FIC1/PIM



c     VSIGLL(I) = VSIGLL(I) + 5*GALL*UPSC1*ALM1**2*DIV1/12.D0

c     VTENLL(I) = VTENLL(I) - GALL*UPST0*ALM1**2*DIV1/4.D0

c     FISLL(I)  = FISLL(I)  - GALL*REDM(1)*(UPSC0-FIC1/3.D0)*DIV1

c     DFISLL(I) = DFISLL(I) - GALL*REDM(1)*(DUPSC0-DFIC1/3.D0)*DIV1

C

c     UPSC0 =   VKULS*AMAX(IN)

c     UPSC1 =  -(1.5D0-XLAM3**2)*UPSC0

c     UPST0 =  + XLAM3**2*UPSC0/3.D0

c     DUPSC0=  -ALM3*XLAM3*UPSC0/PIM

c     FIC1 = -VKULS*AMAX(IN)

c     DFIC1= -ALM3*XLAM3*FIC1/PIM



c     VSIGLS(I) = VSIGLS(I) + 5*GALS*UPSC1*ALM3**2*DIV3/12.D0

c     VTENLS(I) = VTENLS(I) - GALS*UPST0*ALM3**2*DIV3/4.D0

c     FISLS(I)  = FISLS(I)  - GALS*REDM(3)*(UPSC0-FIC1/3.D0)*DIV3

c     DFISLS(I) = DFISLS(I) - GALS*REDM(3)*(DUPSC0-DFIC1/3.D0)*DIV3

C

c     UPSC0 =   VKUSS*AMAX(IN)

c     UPSC1 =  -(1.5D0-XLAM2**2)*UPSC0

c     UPST0 =  + XLAM2**2*UPSC0/3.D0

c     DUPSC0=  -ALM2*XLAM2*UPSC0/PIM

c     FIC1 = -VKUSS*AMAX(IN)

c     DFIC1= -ALM2*XLAM2*FIC1/PIM



c     VSIGSS(I) = VSIGSS(I) + 5*GASS*UPSC1*ALM2**2*DIV2/12.D0

c     VTENSS(I) = VTENSS(I) - GASS*UPST0*ALM2**2*DIV2/4.D0

c     FISSS(I)  = FISSS(I)  - GASS*REDM(2)*(UPSC0-FIC1/3.D0)*DIV2

c     DFISSS(I) = DFISSS(I) - GASS*REDM(2)*(DUPSC0-DFIC1/3.D0)*DIV2



c     VSIGDR(I) = VSIGDR(I) + 5*GADR*UPSC1*ALM2**2*DIV2/12.D0

c     VTENDR(I) = VTENDR(I) - GADR*UPST0*ALM2**2*DIV2/4.D0

c     FISDR(I)  = FISDR(I)  - GADR*REDM(2)*(UPSC0-FIC1/3.D0)*DIV2

c     DFISDR(I) = DFISDR(I) - GADR*REDM(2)*(DUPSC0-DFIC1/3.D0)*DIV2



  104 CONTINUE

 1040 CONTINUE

c     fiss = 0.d0

c     dfiss=0.d0

c     fiten=0.d0

c     dfiten=0.d0

C

      RETURN

      END

C**********************************************************************

C

      SUBROUTINE AXIALU1(XA,NLOC,ICSB,LC,P,PX)

C

C**********************************************************************

C

C     AXIAL MESONS (UNNATURAL PARITY) POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ALLAX/FA(11),FFA(11),FB(11),ALMAX

      COMMON/MASSES/ PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/DDPOTF/DDFILL ,DDFISS ,DDFILS ,DDFIDR,

     .              DDFSLL ,DDFSSS ,DDFSLS ,DDFSDR

      DIMENSION AMAX(4)

      DATA SR3/1.732051D0/,SRPI/1.7724538509D0/,IPV/1/

      DATA AMB1,AMH1,AMH2,AMK1/1235.D0,1170.D0,1380.D0,1273.D0/

C

C   NOTE : B1(IN=1),H11 (IN=2),H11'(IN=3),K1B(IN=4)

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C

      DIV1 =1.D0/(AM(1)*AMY(1))

      DIV2 =1.D0/(AM(1)*AMY(2))

      DIV3 =1.D0/(AM(1)*AMH   )

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GALL= 0.D0   

      GASS= -2*FB(1)*FB(2)

      GALS= -SR3*FB(1)*FB(3)

      GADR= FB(1)*FB(2)

      AMAX(1)=AMB1

      GOTO 1055

1052  GALL=  FB(6)*FB(7)

      GASS=  FB(6)*FB(8)  

      GALS=  0.D0

      GADR=  FB(6)*FB(8)  

      AMAX(2)=AMH1

      GOTO 1055

1053  GALL=  FB(9)*FB(10)

      GASS=  FB(9)*FB(11)

      GALS=  0.D0

      GADR=  FB(9)*FB(11)

      AMAX(3)=AMH2

      GOTO 1055

1054  GALL=  FB(4)*FB(4)*P

      GASS= -FB(5)*FB(5)*P

      GALS= -SR3*FB(4)*FB(5)*P

      GADR= 2*FB(5)*FB(5)*P

      AMAX(4)=AMK1

C

1055  IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) THEN      

      ALAM = ALMP8

      IF(IN.EQ.2) ALAM=ALMP1

      IF(IN.EQ.4) ALAM=ALMKA

      ENDIF

C

      ALM1 = ALAM

      ALM2 = ALAM

      ALM3 = ALAM

      RATM1=AMAX(IN)/ALM1

      RATM2=AMAX(IN)/ALM2

      RATM3=AMAX(IN)/ALM3

      FAC1=AMAX(IN)**2/(4*AM(1)*AMY(1))

      FAC2=AMAX(IN)**2/(4*AM(1)*AMY(2))

      FAC3=AMAX(IN)**2/(4*AM(1)*AMH   )

      AMAX2=AMAX(IN)*AMAX(IN)

C

C     DO 104 I=2,NMAX

      X = XA

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMAX(IN)/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMAX(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMAX(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLL0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLL0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLL1  = FCLL0  - VKULL*AMAX(IN)

      FCLL2  = FCLL1  + (1.5D0-XLAM1**2)*VKULL*AMAX(IN)/RATM1**2

c*    DFCLL0 = -X*FSOLL0

      DFCLL0 = -FSOLL0*XA*AMAX(IN)**2/PIM

      DFCLL1 =  DFCLL0 + ALM1*XLAM1*VKULL*AMAX(IN)  ! MARCH 2009

      DFTLL0 =  DFCLL1/3.D0-3*FTLL0*PIM/XA

      FSOLL1 = FSOLL0-0.5D0*VKULL*(ALM1/AMAX(IN))**2*AMAX(IN)

C

      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTSS0  = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOSS0 = FF1(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCSS1  = FCSS0  - VKUSS*AMAX(IN)

      FCSS2  = FCSS1  + (1.5D0-XLAM2**2)*VKUSS*AMAX(IN)/RATM2**2

c*    DFCSS0 = -X*FSOSS0

      DFCSS0 = -FSOSS0*XA*AMAX(IN)**2/PIM

      DFCSS1 =  DFCSS0 + ALM1*XLAM1*VKUSS*AMAX(IN)  ! MARCH 2009

      DFTSS0 =  DFCSS1/3.D0-3*FTSS0*PIM/XA

      FSOSS1 = FSOSS0-0.5D0*VKUSS*(ALM2/AMAX(IN))**2*AMAX(IN)

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)

      FTLS0  = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FSOLS0 = FF1(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMAX(IN)

      FCLS1  = FCLS0  - VKULS*AMAX(IN)

      FCLS2  = FCLS1  + (1.5D0-XLAM3**2)*VKULS*AMAX(IN)/RATM3**2

c*    DFCLS0 = -X*FSOLS0

      DFCLS0 = -FSOLS0*XA*AMAX(IN)**2/PIM

      DFCLS1 =  DFCLS0 + ALM1*XLAM1*VKULS*AMAX(IN)  ! MARCH 2009

      DFTLS0 =  DFCLS1/3.D0-3*FTLS0*PIM/XA

      FSOLS1 = FSOLS0-0.5D0*VKULS*(ALM2/AMAX(IN))**2*AMAX(IN)

C

1041   VSIGLL  = VSIGLL - GALL*FAC1*FCLL1/3.D0

       VSIGSS  = VSIGSS - GASS*FAC2*FCSS1/3.D0

       VSIGLS  = VSIGLS - GALS*FAC3*FCLS1/3.D0

       VSIGDR  = VSIGDR - GADR*FAC2*FCSS1/3.D0



       VTENLL  = VTENLL - GALL*FAC1*FTLL0

       VTENSS  = VTENSS - GASS*FAC2*FTSS0

       VTENLS  = VTENLS - GALS*FAC3*FTLS0

       VTENDR  = VTENDR - GADR*FAC2*FTSS0



      IF(NLOC.EQ.0) GO TO 104

       FISLL   = FISLL + GALL*FAC1*REDMM*FCLL1 *DIV1/6.D0

       FISSS   = FISSS + GASS*FAC2*REDMM*FCSS1 *DIV2/6.D0

       FISLS   = FISLS + GALS*FAC3*REDMM*FCLS1 *DIV3/6.D0

       FISDR   = FISDR + GADR*FAC2*REDMM*FCSS1 *DIV2/6.D0



       DFISLL  = DFISLL+ GALL*FAC1*REDMM*DFCLL1*DIV1/6.D0

       DFISSS  = DFISSS+ GASS*FAC2*REDMM*DFCSS1*DIV2/6.D0

       DFISLS  = DFISLS+ GALS*FAC3*REDMM*DFCLS1*DIV3/6.D0

       DFISDR  = DFISDR+ GADR*FAC2*REDMM*DFCSS1*DIV2/6.D0



       DDFSLL = DDFSLL+ GALL*FAC1*REDMM*AMAX2*(FCLL2+2*FSOLL1)*

     .                     DIV1/6.D0

       DDFSSS = DDFSSS+ GASS*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)*

     .                     DIV2/6.D0

       DDFSLS = DDFSLS+ GALS*FAC3*REDMM*AMAX2*(FCLS2+2*FSOLS1)*

     .                     DIV3/6.D0

       DDFSDR = DDFSDR+ GADR*FAC2*REDMM*AMAX2*(FCSS2+2*FSOSS1)*

     .                     DIV2/6.D0



c      FITLL   = FITLL + GALL*FAC1*REDMM*FTLL0 *DIV1/2.D0

c      DFITLL  = DFITLL+ GALL*FAC1*REDMM*DFTLL0*DIV1/2.D0

C

  104 CONTINUE

C

 1040 CONTINUE

C

      RETURN

      END



C *********************************************************************

C

      SUBROUTINE PSSCAL02(XA,ICSB,NLOC,LC) 

C

C**********************************************************************

C  updated august 2002, from PSSCAL98.F + YNRMP00.f , introducing GRAZ terms.        

C----------------------------------------------------------------------

C

C     PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS

C

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/MODEL/IMODEL,INRS,ICNSTR,IRET,IDAM,IGERST,IGRTST,

     .             IFRMF,NSU3F

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FRMFAC/ALMOBE,ALMNN,ALMLL,ALMSS,ALMLS,ALMLK,ALMSK

      COMMON/FORMF/ALAMH,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

c     COMMON/AMAT/XA(300),A(9,6,300)

      COMMON/POTF/VCLL  ,VCSS  ,VCLS  ,VCDR,

     .            VSIGLL,VSIGSS,VSIGLS,VSIGDR,

     .            VTENLL,VTENSS,VTENLS,VTENDR,

     .            VSOLL ,VSOSS ,VSOLS ,VSODR,

     .            VSO2LL,VSO2SS,VSO2LS,VSO2DR,

     .            VASOLL,VASOSS,VASOLS,VASODR,

     .            VCNN  ,VSIGNN,VTENNN,VSONN ,

     .            FILL  ,FISS  ,FILS  ,FIDR,

     .            DFILL ,DFISS ,DFILS ,DFIDR,

     .            FISLL ,FISSS ,FISLS ,FISDR,

     .            DFISLL,DFISSS,DFISLS,DFISDR,

     .            FITLL ,FITSS ,FITLS ,FITDR,

     .            DFITLL,DFITSS,DFITLS,DFITDR

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      DIMENSION F(11),AMPS(5)

      EQUIVALENCE (F1,F(1))

      DATA SR3/1.732051D0/,SRPI/1.772454D0/

      DATA DAMLN/175.D0/,DAMSN/255.D0/,DAMSL/80.D0/

c**   DATA DAMLN/0.D0/,DAMSN/0.D0/,DAMSL/0.D0/

      DATA PIMC/138.041D0/,ICALL/0/

      data napion/1/

C

C   NOTE : PION(IN=1),ETA (IN=2),ETAP(IN=3),KAON(IN=4)               

C

C   NOTE : INDEX              1    ,    2    ,    3

C          REFERS TO       LN -> LN, SN -> SN, LN -> SN  REACTION

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.D0*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D0+XH+XH*XH/3.D0)-EXH*EP*(1.D0-XH+XH*XH/3.D0)

     .  -8.D0*XLAMH*(0.5D0+XLAMH*XLAMH/3.D0)*EXLAM/ERATH/

     .  SRPI)/(2.D0*XH*XH*XH)

      FH0(ERATH,EXH,XH,EMH,EPH)=ERATH*(EMH/EXH+EXH*EPH)/(2*XH)

C

C

      SR3 = DSQRT(3.D0)

      SRPI= DSQRT(DACOS(-1.D0))

      IF(LC.EQ.1) SIGN= 1.D0

      IF(LC.NE.1) SIGN=-1.D0

      DIV1 =1.D0/(AM(1)*AMY(1))

      DIV2 =1.D0/(AM(1)*AMY(2))

      DIV3 =1.D0/(AM(1)*AMH   )

      DO 1040 IN=1,4

      GOTO(1051,1052,1053,1054),IN

1051  GPLL = -0.0271D0*ICSB*F1*F3

      GPSS= -2*F1*F2

      GPLS= -SR3*F1*F3                  

      GPDR=      F1*F2

      AMPS(1)=PIM

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1052  GPLL=  F6*F7                 

      GPSS=  F6*F8                

      GPLS=  0.D0

      GPDR=  F6*F8                

      AMPS(2)=AME

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP8

      GOTO 1056

1053  GPLL=  F9*F10                 

      GPSS=  F9*F11                 

      GPLS=  0.D0

      GPDR=  F9*F11                       

      AMPS(3)=AMX

      IF(IMODEL.LE.3) ALAM=ALMOBE

      IF(IMODEL.GE.4) ALAM=ALMP1

      GOTO 1056

1054  GPLL=      F4*F4*P                  

      GPSS=     -F5*F5*P                 

      GPLS= -SR3*F4*F5*P                

      GPDR=    2*F5*F5*P                  

      AMPS(4)=BMK

      IF(IMODEL.EQ.1) ALAM=ALMOBE

      IF(IMODEL.GE.2) ALAM=ALMKA

      GOTO 1056

C

1056  FACPS=(AMPS(IN)/PIMC)**2

      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

C

c     DO 104 I=2,NMAX

c     X = XA(I)



      XLAM1=0.5D0*XA*ALM1/PIM

      XLAM2=0.5D0*XA*ALM2/PIM 

      XLAM3=0.5D0*XA*ALM3/PIM

      VKULL=(ALM1/AMPS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMPS(IN))**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMPS(IN))**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)



      X =XA*(AMPS(IN)/PIM)

      EX=FDEXP(X)

C

      RATM1=AMPS(IN)/ALM1

      EXPM1=DEXP(RATM1*RATM1)

      ELAM1=FDEXP(-XLAM1*XLAM1)

      DERFCM1=FDERFC(-XLAM1+RATM1)

      DERFCP1=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM1,EX,X,DERFCM1,DERFCP1)*AMPS(IN) 

      FTENLL = FF3(EXPM1,EX,X,XLAM1,DERFCM1,DERFCP1,ELAM1)*AMPS(IN)  

C

      RATM2=AMPS(IN)/ALM2

      EXPM2=DEXP(RATM2*RATM2)

      ELAM2=FDEXP(-XLAM2*XLAM2)

      DERFCM2=FDERFC(-XLAM2+RATM2)

      DERFCP2=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM2,EX,X,DERFCM2,DERFCP2)*AMPS(IN)  

      FTENSS = FF3(EXPM2,EX,X,XLAM2,DERFCM2,DERFCP2,ELAM2)*AMPS(IN) 

C

      RATM3=AMPS(IN)/ALM3

      EXPM3=DEXP(RATM3*RATM3)

      ELAM3=FDEXP(-XLAM3*XLAM3)

      DERFCM3=FDERFC(-XLAM3+RATM3)

      DERFCP3=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM3,EX,X,DERFCM3,DERFCP3)*AMPS(IN)

      FTENLS = FF3(EXPM3,EX,X,XLAM3,DERFCM3,DERFCP3,ELAM3)*AMPS(IN)  

C

      FCLL1  = FCLL0  - VKULL*AMPS(IN)   

      FCSS1  = FCSS0  - VKUSS*AMPS(IN)  

      FCLS1  = FCLS0  - VKULS*AMPS(IN)     

C

C------------------------------------------------------------

C     THRESHOLD-DIFFERENCE MODIFICATION BASE FUNCTIONS:

      IF(IDAM.NE.0.AND.IN.NE.4) THEN

      CALL YMKFUN(XA,AMPS(IN),ALAM,SIGN,IDAM*DAMSL,

     .FXC0,FXC1,FXC2,FXTEN,FXTEN1,FXSO,FXSO1)

                                                                

      IF(LC.EQ.1) THEN

      FCSS1 = AMPS(IN)*FXC1 

      FTENSS = AMPS(IN)*FXTEN             

      ENDIF

      IF(LC.NE.1) THEN

      FCLL1 = AMPS(IN)*FXC1 

      FTENLL= AMPS(IN)*FXTEN             

      ENDIF

      FCLS1  = 0.5D0*(FCLS1 + AMPS(IN)*FXC1 )     

      FTENLS = 0.5D0*(FTENLS+ AMPS(IN)*FXTEN)     

      ENDIF

C------------------------------------------------------------

C

        VSIGLL     = VSIGLL    + FACPS*GPLL*FCLL1/3.D0

        VTENLL     = VTENLL    + FACPS*GPLL*FTENLL

        VSIGDR     = VSIGDR    + FACPS*GPDR*FCSS1/3.D0

        VTENDR     = VTENDR    + FACPS*GPDR*FTENSS

        VSIGSS     = VSIGSS    + FACPS*GPSS*FCSS1/3.D0

        VTENSS     = VTENSS    + FACPS*GPSS*FTENSS

        VSIGLS     = VSIGLS    + FACPS*GPLS*FCLS1/3.D0

        VTENLS     = VTENLS    + FACPS*GPLS*FTENLS

C-----------------------------------------------------------------

C

C     NONLOCAL TERMS PSEUDOSCALAR MESONS:

C

C------------------------------------------------------------

      IF(NAPION.EQ.1) THEN

C------------------------------------------------------------

C     GRAZ 1978:

CC

      X  = XA

      X1 = 1.D0/X  

      X2 = X1*X1     

      X3 = X1*X2     

      AMES=AMPS(IN)



      VKU1 =(ALM1/AMPS(IN))*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKU2 =(ALM2/AMPS(IN))*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKU3 =(ALM3/AMPS(IN))*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

      DVKU1 =-0.5D0*(ALM1/PIM)**2*X*VKU1 

      DDVKU1=-0.5D0*(ALM1/PIM)**2*(X*DVKU1+VKU1)

      D3VKU1=-0.5D0*(ALM1/PIM)**2*(X*DDVKU1+2*DVKU1)

      DVKU2 =-0.5D0*(ALM2/PIM)**2*X*VKU2 

      DDVKU2=-0.5D0*(ALM2/PIM)**2*(X*DVKU2+VKU2)

      D3VKU2=-0.5D0*(ALM2/PIM)**2*(X*DDVKU2+2*DVKU2)

      DVKU3 =-0.5D0*(ALM3/PIM)**2*X*VKU3 

      DDVKU3=-0.5D0*(ALM3/PIM)**2*(X*DVKU3+VKU3)

      D3VKU3=-0.5D0*(ALM3/PIM)**2*(X*DDVKU3+2*DVKU3)

C

      FI1    = FF0(EXPM1,EX,X,DERFCM1,DERFCP1)           

      HI1    = FH0(EXPM1,EX,X,DERFCM1,DERFCP1)           

      DFI1 =-(FI1 -2*VKU1)*X1-(AMES/PIM)*HI1

      DHI1  =-(AMES/PIM)*FI1 -HI1 *X1

      DDFI1 =-(DFI1-2*DVKU1)*X1+(FI1-2*VKU1)*X2-(AMES/PIM)*DHI1

      DDHI1 =-(AMES/PIM)*DFI1-DHI1*X1+HI1*X2

      D3FI1 =-(DDFI1-2*DDVKU1)*X1+(DFI1-2*DVKU1)*X2-(AMES/PIM)*DDHI1

     .       +(DFI1-2*DVKU1)*X2-2*(FI1-2*VKU1)*X3

      FC11  = (DDFI1+2*DFI1*X1)

      FT01  = (DDFI1-DFI1*X1)/3.D0

      DFC11 = (D3FI1+2*DDFI1*X1-2*DFI1*X2)

      DFT01 = (D3FI1-DDFI1*X1+DFI1*X2)/3.D0               

C

      FI2    = FF0(EXPM2,EX,X,DERFCM2,DERFCP2)           

      HI2    = FH0(EXPM2,EX,X,DERFCM2,DERFCP2)           

      DFI2 =-(FI2 -2*VKU2)*X1-(AMES/PIM)*HI2

      DHI2  =-(AMES/PIM)*FI2 -HI2 *X1

      DDFI2 =-(DFI2-2*DVKU2)*X1+(FI2-2*VKU2)*X2-(AMES/PIM)*DHI2

      DDHI2 =-(AMES/PIM)*DFI2-DHI2*X1+HI2*X2

      D3FI2 =-(DDFI2-2*DDVKU2)*X1+(DFI2-2*DVKU2)*X2-(AMES/PIM)*DDHI2

     .       +(DFI2-2*DVKU2)*X2-2*(FI2-2*VKU2)*X3

      FC12  = (DDFI2+2*DFI2*X1)

      FT02  = (DDFI2-DFI2*X1)/3.D0

      DFC12 = (D3FI2+2*DDFI2*X1-2*DFI2*X2)

      DFT02 = (D3FI2-DDFI2*X1+DFI2*X2)/3.D0               

C

      FI3    = FF0(EXPM3,EX,X,DERFCM3,DERFCP3)           

      HI3    = FH0(EXPM3,EX,X,DERFCM3,DERFCP3)           

      DFI3 =-(FI3 -2*VKU3)*X1-(AMES/PIM)*HI3

      DHI3  =-(AMES/PIM)*FI3 -HI3 *X1

      DDFI3 =-(DFI3-2*DVKU3)*X1+(FI3-2*VKU3)*X2-(AMES/PIM)*DHI3

      DDHI3 =-(AMES/PIM)*DFI3-DHI3*X1+HI3*X2

      D3FI3 =-(DDFI3-2*DDVKU3)*X1+(DFI3-2*DVKU3)*X2-(AMES/PIM)*DDHI3

     .       +(DFI3-2*DVKU3)*X2-2*(FI3-2*VKU3)*X3

      FC13  = (DDFI3+2*DFI3*X1)

      FT03  = (DDFI3-DFI3*X1)/3.D0

      DFC13 = (D3FI3+2*DDFI3*X1-2*DFI3*X2)

      DFT03 = (D3FI3-DDFI3*X1+DFI3*X2)/3.D0               



      FISLL = FISLL  -corsps*REDM(1)*GPLL*FC11*DIV1*PIM/6.D0         

      FITLL = FITLL  -cortps*REDM(1)*GPLL*FT11*DIV1*PIM/2.D0         

      FISSS = FISSS  -corsps*REDM(2)*GPSS*FC12*DIV2*PIM/6.D0         

      FITSS = FITSS  -cortps*REDM(2)*GPSS*FT12*DIV2*PIM/2.D0         

      FISLS = FISLS  -corsps*REDM(3)*GPLS*FC13*DIV3*PIM/6.D0         

      FITLS = FITLS  -cortps*REDM(3)*GPLS*FCT3*DIV3*PIM/2.D0         

      FISDR = FISDR  -corsps*REDM(2)*GPDR*FC12*DIV2*PIM/6.D0         

      FITDR = FITDR  -cortps*REDM(2)*GPDR*FT12*DIV2*PIM/2.D0         

      DFISLL= DFISLL -corsps*REDM(1)*GPLL*DFC11*DIV1*PIM**2/6.D0

      DFITLL= DFITLL -cortps*REDM(1)*GPLL*DFT11*DIV1*PIM**2/2.D0

      DFISSS= DFISSS -corsps*REDM(2)*GPSS*DFC12*DIV2*PIM**2/6.D0

      DFITSS= DFITSS -cortps*REDM(2)*GPSS*DFT12*DIV2*PIM**2/2.D0

      DFISLS= DFISLS -corsps*REDM(3)*GPLS*DFC13*DIV3*PIM**2/6.D0

      DFITLS= DFITLS -cortps*REDM(3)*GPLS*DFT13*DIV3*PIM**2/2.D0

      DFISDR= DFISDR -corsps*REDM(2)*GPDR*DFC12*DIV2*PIM**2/6.D0

      DFITDR= DFITDR -cortps*REDM(2)*GPDR*DFT12*DIV2*PIM**2/2.D0



      if(x.lt.0.2d0) then

      write(*,*) 'psscal02: xa=',xa

      write(*,*) 'fi1,dfi1,ddfi1,d3fi1=',fi1,dfi1,ddfi1,d3fi1

      write(*,*) 'hi1,dhi1,ddhi1,fisll=',hi1,dhi1,ddhi1,fisll

      endif

c     FITLL = FITLL  -0.5D0*REDM(1)*GPLL*FT01*DIV1*PIM

c     FITSS = FITSS  -0.5D0*REDM(2)*GPSS*FT02*DIV2*PIM

c     FITLS = FITLS  -0.5D0*REDM(3)*GPLS*FT03*DIV3*PIM

c     FITDR = FITDR  -0.5D0*REDM(2)*GPDR*FT02*DIV2*PIM

c     DFITLL= DFITLL -0.5D0*REDM(1)*GPLL*DFT01*DIV1*PIM**2

c     DFITSS= DFITSS -0.5D0*REDM(2)*GPSS*DFT02*DIV2*PIM**2

c     DFITLS= DFITLS -0.5D0*REDM(3)*GPLS*DFT03*DIV3*PIM**2

c     DFITDR= DFITDR -0.5D0*REDM(2)*GPDR*DFT02*DIV2*PIM**2



C     END GRAZ 1978.

      ENDIF

C-----------------------------------------------------------------

C

c 104 CONTINUE

C

 1040 CONTINUE

C

      ICALL = 1

      RETURN

      END

C *********************************************************************

C

      SUBROUTINE PLFORM(XA,UMAS,ALAM)           

C

C**********************************************************************

C  september 2002: Pagnamenta-Licht Form-factor function:                  

C  from extra monopole factor U^2/(k^2+U^2) in g^2.

C----------------------------------------------------------------------

      IMPLICIT REAL *8(A-H,O-Z)

      COMMON/UFUNC/FCLL0,FCLS0,FCSS0,FCLL1,FCLS1,FCSS1,

     .UCLl2,UCLS2,UCSS2

      COMMON/MASSES/PIM,AM(3),AMY(3),REDM(3),PLAB,AK(3),AKS(3),TEM(3)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN



      DATA PIM/138.041D0/,SR3/1.732051D0/,SRPI/1.772454D0/

C

C   THE POTENTIAL FUNCTIONS

C

      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*XH)

      FF1(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D00*XH*XH*XH)

      FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH

     .  *(1.D00+XH+XH*XH/3.D00)-EXH*EP*(1.D00-XH+XH*XH/3.D00)

     .  -8.D00*XLAMH*(0.5D00+XLAMH*XLAMH/3.D00)*EXLAM/ERATH/

     .  1.7724538509D0)/(2.D00*XH*XH*XH)

C



      AMPS= UMAS

      ALM1=ALAM

      ALM2=ALAM

      ALM3=ALAM

      RATM1=AMPS/ALM1

      RATM2=AMPS/ALM2

      RATM3=AMPS/ALM3

c     FAC1=AMPS*AMPS/(AM(1)*AMY(1))

c     FAC2=AMPS*AMPS/(AM(1)*AMY(2))

c     FAC3=AMPS*AMPS/(AM(1)*AMH)

C

      X = XA    

      XLAM1=0.5D0*X*ALM1/PIM

      XLAM2=0.5D0*X*ALM2/PIM

      XLAM3=0.5D0*X*ALM3/PIM

      X =(AMPS/PIM)*X

      EX=FDEXP(X)

      VKULL=(ALM1/AMPS)**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)

      VKUSS=(ALM2/AMPS)**3*FDEXP(-XLAM2*XLAM2)/(2.D0*SRPI)

      VKULS=(ALM3/AMPS)**3*FDEXP(-XLAM3*XLAM3)/(2.D0*SRPI)

C

      EXPM=DEXP(RATM1*RATM1)

      ELAM=FDEXP(-XLAM1*XLAM1)

      DERFCM=FDERFC(-XLAM1+RATM1)

      DERFCP=FDERFC( XLAM1+RATM1)

      FCLL0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS

      FTENLL = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS

C



      EXPM=DEXP(RATM2*RATM2)

      ELAM=FDEXP(-XLAM2*XLAM2)

      DERFCM=FDERFC(-XLAM2+RATM2)

      DERFCP=FDERFC( XLAM2+RATM2)

      FCSS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS

      FTENSS = FF3(EXPM,EX,X,XLAM2,DERFCM,DERFCP,ELAM)*AMPS

C

      EXPM=DEXP(RATM3*RATM3)

      ELAM=FDEXP(-XLAM3*XLAM3)

      DERFCM=FDERFC(-XLAM3+RATM3)

      DERFCP=FDERFC( XLAM3+RATM3)

      FCLS0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS

      FTENLS = FF3(EXPM,EX,X,XLAM3,DERFCM,DERFCP,ELAM)*AMPS

C

      FCLL1  = FCLL0  - VKULL*AMPS

      FCSS1  = FCSS0  - VKUSS*AMPS

      FCLS1  = FCLS0  - VKULS*AMPS

C

      FCLL2  = FCLL1+(1.5D0-XLAM1*XLAM1)*VKULL*AMPS/RATM1/RATM1

      FCSS2  = FCSS1+(1.5D0-XLAM2*XLAM2)*VKUSS*AMPS/RATM2/RATM2

      FCLS2  = FCLS1+(1.5D0-XLAM3*XLAM3)*VKULS*AMPS/RATM3/RATM3



      RETURN

      END





C **********************************************************************

      SUBROUTINE SU3SB03(F,ALP,SON)

C **********************************************************************

C     VERSION SEPTEMBER 2003

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION F(11)

C ----------------------------------------------------------------------

c     f(9)=0d0

C     SU3 SYMMETRIC COUPLINGS:

      CALL SU3(F,ALP)

C ----------------------------------------------------------------------

C     SU3 SYMMETRY BREAKING I=1/2 STATES:



      F(4) = F(4) - F(4)*(1.D0-SON)

      F(5) = F(5) - F(5)*(1.D0-SON)



C ----------------------------------------------------------------------

C     SU3 SYMMETRY BREAKING I=0 STATES:



C     ROTATION TO IDEAL MIXED STATES:

      COST = DSQRT(2.D0/3.D0)

      SINT = DSQRT(1.D0/3.D0)



C     NUCLEON COUPLINGS:

      FNNU = COST*F(9)+SINT*F(6)

      FNNS =-SINT*F(9)+COST*F(6)

      FNNS = FNNS- FNNS*(1.D0-SON*SON)

C     BACK ROTATION TO SU3 SINGLET AND OCTET STATES:

      F(9)= COST*FNNU -SINT*FNNS 

      F(6)= SINT*FNNU +COST*FNNS 



C     LAMBDA COUPLINGS:

      FLLU = COST*F(10)+SINT*F(7)

      FLLS =-SINT*F(10)+COST*F(7)

      FLLS = FLLS- FLLS*(1.D0-SON*SON)

C     BACK ROTATION TO SU3 SINGLET AND OCTET STATES:

      F(10)= COST*FLLU -SINT*FLLS 

      F(7) = SINT*FLLU +COST*FLLS 



C     SIGMA  COUPLINGS:

      FSSU = COST*F(11)+SINT*F(8)

      FSSS =-SINT*F(11)+COST*F(8)

      FSSS = FSSS- FSSS*(1.D0-SON*SON)

C     BACK ROTATION TO SU3 SINGLET AND OCTET STATES:

      F(11)= COST*FSSU -SINT*FSSS 

      F(8) = SINT*FSSU +COST*FSSS 



      RETURN

      END





C***********************************************************************

      FUNCTION FDEXP(X)

C***********************************************************************

      IMPLICIT REAL*8 (A-H,O-Z)

      IF(X.LE.-170.D00) GOTO 1

      IF(X.GT.+170.D00) GOTO 2

      FDEXP=DEXP(X)

      RETURN

 1    FDEXP=0.0D00

      RETURN

 2    FDEXP=1.0D 60

      RETURN

      END



C***********************************************************************

      SUBROUTINE GAUSS(N,X,W,NT)

C***********************************************************************

      IMPLICIT REAL*8 (A-H,O-Z)

      DIMENSION WGAUS1(30), WGAUS2(30), WGAUSS(60), X(20), W(20)

c     EQUIVALENCE (WGAUS1(1),WGAUSS(1)), (WGAUS2(1),WGAUSS(31))

C

C  THIS ROUTINE CALCULATES THE WEIGHT-FACTORS AND ARGUMENT-DISTRIBUTIONS

C  FOR A GAUSSIAN-INTEGRATION IN THE INTERVAL -1.0 TO +1.0. WHEN N IS

C  NOT EQUAL TO 4,8,12,16 OR 20, A WARNING WILL BE GIVEN AND THE

C  WEIGHT-FACTORS AND DISTRIBUTIONS WILL BE THOSE OF A TWO POINT-SIMPS.

C           WHEN NT=1 ,ONE GETS A N-POINTS GAUSS

C           WHEN NT=2 ,ONE GETS A N-POINTS GAUSS ON THE INTERVAL -1,0

C                              AND A N-POINTS GAUSS ON 0,+1

C

      IF (MOD(N,4).NE.0) GO TO 2

C

C  THE ABSCISSAS AND WEIGHTS FOR GAUSSIAN INTEGRATION.

C  N=4,8,12,16,20 ONLY.

C

      DATA WGAUS1

     1/.339981043584856D0, .652145154862546D0,

     * .861136311594053D0, .347854845137454D0,

     * .183434642495650D0, .362683783378362D0,

     * .525532409916329D0, .313706645877887D0,

     * .796666477413627D0, .222381034453374D0,

     * .960289856497536D0, .101228536290376D0,

     * .125233408511469D0, .249147045813403D0,

     * .367831498998180D0, .233492536538355D0,

     * .587317954286617D0, .203167426723066D0,

     * .769902674194305D0, .160078328543346D0,

     * .904117256370475D0, .106939325995318D0,

     * .981560634246719D0, .047175336386512D0,

     * .0950125098376374D0, .1894506104550685D0,

     * .2816035507792589D0, .1826034150449236D0,

     * .4580167776572274D0, .1691565193950025D0/

      DATA WGAUS2  /

     * .6178762444026437D0, .1495959888165767D0,

     * .7554044083550030D0, .1246289712555339D0,

     * .8656312023878317D0, .0951585116824928D0,

     * .9445750230732326D0, .0622535239386479D0,

     * .9894009349916499D0, .0271524594117541D0,

     * .0765265211334973D0, .1527533871307259D0,

     * .2277858511416451D0, .1491729864726037D0,

     * .3737060887154196D0, .1420961093183821D0,

     * .5108670019508271D0, .1316886384491766D0,

     * .6360536807265150D0, .1181945319615184D0,

     * .7463319064601508D0, .1019301198172404D0,

     * .8391169718222188D0, .0832767415767047D0,

     * .9122344282513259D0, .0626720483341091D0,

     * .9639719272779138D0, .0406014298003869D0,

     * .9931285991850949D0, .0176140071391521D0/



      do 100 kk=1,30

      wgauss(kk) = wgaus1(kk)

  100 wgauss(kk+30) = wgaus2(kk)



      K=N/4-1

      INIT=2*K*(K+1)+1

      M=N/2

      DO 1 I=1,M

      J=INIT-2+I*2

      X(M+I)=WGAUSS(J)

      X(M+1-I)=-WGAUSS(J)

      W(M+I)=WGAUSS(J+1)

    1 W(M+1-I)=WGAUSS(J+1)

      IF (NT.EQ.1) RETURN

      DO 10 I=1,N

      X(N+I)=(X(I)+1.0)/2.

      X(I)=(X(I)-1.0)/2.

      W(N+I)=W(I)/2.

   10 W(I)=W(N+I)

      RETURN

C

C  SIMPSON'S RULE : ONLY ODD N

C

    2 H=2.0/(N-1.0)

      X(1)=-1.0

      W(1)=H/3.0

      W23=(2.0*H)/3.0

      W43=2.0*W23

      NN=(N-1)/2

      DO 3 I=1,NN

      J=2*I

      X(J)=X(J-1)+H

      W(J)=W43

      X(J+1)=X(J)+H

    3 W(J+1)=W23

      X(N)=1.0

      W(N)=W(1)

      RETURN

      END



C***********************************************************************

      FUNCTION FDERFC(X)

C***********************************************************************

c Ref: W.J. Cody, Mathematics of Computation, 22 (1969) 631.

      IMPLICIT REAL*8(A-H,O-Z)

      REAL*8 P1(0:3),Q1(0:3),P2(0:7),Q2(0:7),P3(0:4),Q3(0:4)

      REAL*8 XPOWER(0:7)

      DATA PI/3.1415926535897932384626433832795028D0/

      DATA P1/ 2.42667 95523 05318 D+2,

     .         2.19792 61618 29415 D+1,

     .         6.99638 34886 19136 D+0,

     .        -3.56098 43701 81538 D-2 /

      DATA Q1/ 2.15058 87586 98612 D+2,

     .         9.11649 05404 51490 D+1,

     .         1.50827 97630 40779 D+1,

     .         1.00000 00000 00000 D+0 /

      DATA P2/ 3.00459 26102 01616 D+2,

     .         4.51918 95371 18729 D+2,

     .         3.39320 81673 43437 D+2,

     .         1.52989 28504 69404 D+2,

     .         4.31622 27222 05674 D+1,

     .         7.21175 82508 83094 D+0,

     .         5.64195 51747 89740 D-1,

     .        -1.36864 85738 27167 D-7 /

      DATA Q2/ 3.00459 26095 69833 D+2,

     .         7.90950 92532 78980 D+2,

     .         9.31354 09485 06096 D+2,

     .         6.38980 26446 56312 D+2,

     .         2.77585 44474 39876 D+2,

     .         7.70001 52935 22947 D+1,

     .         1.27827 27319 62942 D+1,

     .         1.00000 00000 00000 D+0 /

      DATA P3/-2.99610 70770 35422 D-3,

     .        -4.94730 91062 32507 D-2,

     .        -2.26956 59353 96869 D-1,

     .        -2.78661 30860 96478 D-1,

     .        -2.23192 45973 41847 D-2 /

      DATA Q3/ 1.06209 23052 84679 D-2,

     .         1.91308 92610 78298 D-1,

     .         1.05167 51070 67932 D+0,

     .         1.98733 20181 71353 D+0,

     .         1.00000 00000 00000 D+0 /



      Y = DABS(X)

      IF(Y.LE.0.46875D0) THEN

        A=P1(0)

        B=Q1(0)

        XPOWER(0)=1.D0

        DO J=1,3

          XPOWER(J)=XPOWER(J-1)*Y*Y

          A=A+P1(J)*XPOWER(J)

          B=B+Q1(J)*XPOWER(J)

        ENDDO

        FDERFC=1.D0-Y*A/B

      ELSEIF(Y.LE.4.D0) THEN

        A=P2(0)

        B=Q2(0)

        XPOWER(0)=1.D0

        DO J=1,7

          XPOWER(J)=XPOWER(J-1)*Y

          A=A+P2(J)*XPOWER(J)

          B=B+Q2(J)*XPOWER(J)

        ENDDO

        FDERFC=DEXP(-Y*Y)*A/B

      ELSEIF(Y.LE.10.D0) THEN

        A=P3(0)

        B=Q3(0)

        XPOWER(0)=1.D0

        DO J=1,4

          XPOWER(J)=XPOWER(J-1)/(Y*Y)

          A=A+P3(J)*XPOWER(J)

          B=B+Q3(J)*XPOWER(J)

        ENDDO

        FDERFC=DEXP(-Y*Y)/Y*(1.D0/DSQRT(PI)+A/B*XPOWER(1))

      ELSE

        FDERFC=0.D0

      ENDIF

      IF(X.LT.0.D0) FDERFC=2.D0-FDERFC



      RETURN

      END





      subroutine errset(i,j,k,l)

      integer i,j,k,l        

      return

      end





************************************************************************

      subroutine gausss(n,x,w,nt)

C*      The abcissas and weights for Gaussian integration,

C*      N=4,8,12,16,20,32,48 only:

      implicit real*8 (a-h,o-z)

      dimension wgauss(61), weulra(32),weulrb(48)

      dimension x(*),w(*)

      data wgauss

     1/.33998104358486,.65214515486255,.86113631159405,.34785484513745

     *,.18343464249565,.36268378337836,.52553240991633,.31370664587789

     *,.79666647741362,.22238103445337,.96028985649753,.10122853629038

     *,.12523340851147,.24914704581340,.36783149899818,.23349253653835

     *,.58731795428661,.20316742672307,.76990267419430,.16007832854335

     *,.90411725637048,.10693932599532,.98156063424672,.04717533638651

     *,.09501250983764,.18945061045507,.28160355077926,.18260341504492

     *,.45801677765722,.16915651939500,.61787624440264,.14959598881658

     *,.75540440835500,.12462897125553,.86563120238783,.09515851168249

     *,.94457502307323,.06225352393865,.98940093499165,.02715245941175

     *,.07652652113350,.15275338713072,.22778585114164,.14917298647260

     *,.37370608871542,.14209610931838,.51086700195082,.13168863844918

     *,.63605368072652,.11819453196152,.74633190646015,.10193011981724

     *,.83911697182222,.08327674157670,.91223442825132,.06267204833411

     *,.96397192727791,.04060142980039,.99312859918509,.01761400713915

     *,.00/



C  32 POINTS:

      data weulra

     1/.04830766568774,.09654008851473,.14447196158280,.09563872007927

     *,.23928736225214,.09384439908080,.33186860228213,.09117387869576

     *,.42135127613064,.08765209300440,.50689990893223,.08331192422695

     *,.58771575724076,.07819389578707,.66304426693022,.07234579410885

     *,.73218211874029,.06582222277636,.79448379596794,.05868409347854

     *,.84936761373257,.05099805926238,.89632115576605,.04283589802223

     *,.93490607593774,.03427386291302,.96476225558751,.02539206530926

     *,.98561151154527,.01627439473091,.99726386184948,.00701861000947

     */



C  48 POINTS:

      data weulrb

     1/.03238017096287,.06473769681268,.09700469920946,.06446616443595

     *,.16122235606889,.06392423858465,.22476379039469,.06311419228625

     *,.28736248735546,.06203942315989,.34875588629216,.06070443916589

     *,.40868648199071,.05911483969840,.46690290475096,.05727729210040

     *,.52316097472223,.05519950369998,.57722472608397,.05289018948519

     *,.62886739677651,.05035903555385,.67787237963266,.04761665849249

     *,.72403413092381,.04467456085669,.76715903251574,.04154508294346

     *,.80706620402944,.03824135106583,.84358826162439,.03477722256477

     *,.87657202027425,.03116722783280,.90587913671557,.02742650970836

     *,.93138669070655,.02357076083932,.95298770316043,.01961616045736

     *,.97059159254625,.01557931572294,.98412458372283,.01147723457923

     *,.99353017226635,.00732755390128,.99877100725243,.00315334605231

     */



      if(mod(n,4).ne.0) then

C*      Simpson's rule: only odd N

        h=2d0/(n+1d0)

        x(1)=-1d0+h

        w23=2d0*h/3d0

        w43=2d0*w23

        w(1)=w43

        nn=(n-1)/2

        do 10 i=1,nn

          j=2*i

          x(j)=x(j-1)+h

          x(j+1)=x(j)+h

          w(j)=w23

          w(j+1)=w43

   10   continue

        return

      endif



      if(n.le.20) then

        k=n/4-1

        init=2*k*(k+1)+1

        m=n/2

        do 1 i=1,m

          j=init-2+i*2

          x(m+i)=wgauss(j)

          x(m+1-i)=-wgauss(j)

          w(m+i)=wgauss(j+1)

          w(m+1-i)=wgauss(j+1)

    1   continue

      endif

      if(n.eq.32) then

        m=n/2

        do 2 i=1,m

          j=2*i-1

          x(m+i)=weulra(j)

          x(m+1-i)=-weulra(j)

          w(m+i)=weulra(j+1)

          w(m+1-i)=weulra(j+1)

    2   continue

      endif

      if(n.eq.48) then

        m=n/2

        do 3 i=1,m

          j=2*i-1

          x(m+i)=weulrb(j)

          x(m+1-i)=-weulrb(j)

          w(m+i)=weulrb(j+1)

          w(m+1-i)=weulrb(j+1)

    3   continue

      endif

      if(nt.eq.1) return



      do 5 i=1,n

        x(n+i)=(x(i)+1d0)/2d0

        x(i)=(x(i)-1d0)/2d0

        w(n+i)=w(i)/2d0

        w(i)=w(n+i)

    5 continue



      return

      end

************************************************************************

      subroutine chebsv(nogp,xx,ww)

      implicit real*8 (a-h,o-z)

      parameter( mxgp=96)

      dimension xx(*),ww(*)

      dimension b(mxgp+2,mxgp+2),x(mxgp+2),t(mxgp+2)

      data ichck/0/, pi/3.14159265358979323846d0/



      n1=nogp+2

      n=n1-1

      nm1=n-1



C*    Generation Chebyshev points

      do 1 k=1,n1

    1   x(k)=-dcos((k-1)*pi/n)

      do 4 i=1,n1

        argi=dacos(x(i))

        do 5 k=1,n1

    5     t(k)=dcos((k-1)*argi)

        do 4 j=1,n1

          argj=dacos(x(j))

          b(j,i)=0d0

          do 6 k=2,nm1

            tkj=dcos((k-1)*argj)

    6       b(j,i)=b(j,i)+0.5d0*tkj*(t(k-1)-t(k+1))/(k-1)

          tnm1=dcos((n-1)*argj)

          b(j,i)=b(j,i)+tnm1*0.5d0*(t(n-1)-0.5d0*t(n+1))/(n-1)

          tn=dcos(n*argj)

          b(j,i)=b(j,i)+tn*0.5d0*t(n)/n

          tn1=dcos((n+1)*argj)

          b(j,i)=b(j,i)+tn1*0.25d0*t(n+1)/(n+1)

          t0=0.5d0-0.25d0*t(2)-0.5d0*(-1)**n*t(n+1)/(n*n-1)

          do 7 k=2,nm1

    7       t0=t0-(-1)**k*t(k+1)/(k*k-1)

          b(j,i)=b(j,i)+t0

          b(j,i)=b(j,i)*2d0/n

          if(i.eq.1 .or. i.eq.n1) b(j,i)=b(j,i)/2d0

    4 continue



      do 41 i1=1,nogp

        xx(i1)=x(i1+1)

   41   ww(i1)=b(n1,i1+1)



      return

      end

C **********************************************************************

      SUBROUTINE YMKFUN(X,AMES,ALAM,SIGN,DAM,FC0,FC1,FC2,

     .                  FT0,FT1,FO0,FO1)

C **********************************************************************

C

C     YUKAWA-MACKE-KLEIN PROPAGATOR:

C                                        1          1

C     FOURIER TRANSFORM OF  F(OMEGA)=  ----- --------------

C                                      OMEGA (OMEGA +/- DAM)

C     IN THE FORM OF THE PHI^N_{C,T,SO}-FUNCTIONS DEFINED IN PRD17,PRC40

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1991).

C

C     VERSION: PHI-FUNCTIONS A LA PRD17 AND PRC40 !!

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION XX(96),WW(96),YB(3)

c**   COMMON/PIMAS/PIM

      DATA PIM/138.031D0/



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/,NS/0/

c     DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/



      DATA PCUT/5.0D0/,PMAX/20/,IKIND/-1/,NPNT/32/,IQUADR/1/

c**   DATA PCUT/5.0D0/,PMAX/40/,IKIND/+2/,NPNT/20/,IQUADR/1/

c**   DATA PCUT/5.0D0/,PMAX/20/,IKIND/+3/,NPNT/32/,IQUADR/1/



      SAVE XX,WW

C ---------------------------------------------------------------

C

C     POTENTIAL FUNTIONS DEFINITION

C

C-------------------------------------------------------------------

      F0(ERATH,EXH,EM,EP,XH)=ERATH*(EM/EXH-EXH*EP)/(2.D0*XH)

      F1(ERATH,EXH,EM,EP,EXLAM,XH,XLAMH)=ERATH*(EM/EXH

     . *(1.D0+XH)-EXH*EP*(1.D0-XH)-4.D0*XLAMH*EXLAM/ERATH/SRPI)

     .  /(2.D0*XH*XH*XH)

      F3(ERATH,EXH,EM,EP,EXLAM,XH,XLAMH)=ERATH*(EM/EXH

     .  *(1.D0+XH+XH*XH/3.D0)-EXH*EP*(1.D0-XH+XH*XH/3.D0)

     .  -8.D0*XLAMH*(0.5D0+XLAMH*XLAMH/3.D0)*EXLAM/ERATH/SRPI)

     .  /(2.D0*XH*XH*XH)

C

C-------------------------------------------------------------------

c     IF(ICALL.EQ.0) THEN

c       CALL GAUSS(NPNT,XX,WW,1)

c       IF(IMETH.EQ.1) NINT=1

C       PRINT 52, IMETH,NPNT

C52     FORMAT(//,'  IN FFUN: IMETH=',I2,' NPNT=',I2,//)

C       PI = DACOS(-1.D0)

C       SRPI= DSQRT(PI)

c**     ICALL=1

c     ENDIF

C ---------------------------------------------------------------

      IF(ICALL.EQ.0) THEN

C     GENERATION INTEGRATION POINTS:

      IF(NS.NE.0) PRINT 1, NPNT,IKIND,PCUT,PMAX,IQUADR

    1 FORMAT(/,'  YMKFUN METHOD PARAMETERS ARE: NPNT=',I2,

     .' IKIND=',I2,' PCUT=',F10.3,' PMAX=',F10.3,' IQUADR=',I2,/) 

      CALL GRID(XX,WW,NPNT,0.D0,PCUT,PMAX,IKIND,IQUADR)

      PI = DACOS(-1.D0)

      SRPI= DSQRT(PI)

      ICALL=1

      ENDIF

C ---------------------------------------------------------------

CC

      AA   = DAM/PIM

CC

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      EXLAM=FDEXP(-XLAM2)

      RATP = PIM/ALAM

C-------------------------------------------------------------------

      IF(SIGN.EQ.-1.D0.OR.DAM.EQ.0.D0) THEN

      FDISAA= DEXP(AA*AA/ALAM/ALAM)

      BMES = DSQRT(AMES**2-DAM**2)

      BMES1= BMES/PIM

      BMES3=(BMES/PIM)**3

      BMES5=(BMES/PIM)**5

      VKUA =(ALAM/BMES)**3*FDEXP(-XLAM2)/(2*SRPI)

      XA   =X*BMES/PIM

      RATA =BMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,XA)      

      FIAT =F3(ERATA,EXA ,EMA ,EPA ,EXLAM, XA, XLAM)      

      FIAO =F1(ERATA,EXA ,EMA ,EPA ,EXLAM, XA, XLAM)      

c     FIAO2=3*FIAT/(XA*XA)

C

      FIA1 = FIA - VKUA             

      FIA2 = FIA1 + (1.5D0-XLAM*XLAM)*VKUA/RATA/RATA   

      FIAT1= FIAT - XLAM*XLAM*VKUA/(3*RATA*RATA)  

      FIAO1= FIAO - VKUA/(2*RATA*RATA)    

C-------------------------------------------------------------------

C

       IF(DAM.EQ.0.D0) THEN

      FC0 = FIA  

      FC1 = FIA1

      FC2 = FIA2

      FT0 = FIAT

      FT1 = FIAT1

      FO0 = FIAO

      FO1 = FIAO1

      RETURN

       ENDIF

C                              

      FIB  = FIA*FDISAA*BMES1

      FIB1 = FIA1*FDISAA*BMES3

      FIB2 = FIA2*FDISAA*BMES5

      FIBT = FIAT*FDISAA*BMES3

      FIBT1= FIAT1*FDISAA*BMES5

      FIBO = FIAO*FDISAA*BMES3

      FIBO1= FIAO1*FDISAA*BMES5



      ENDIF

C ---------------------------------------------------------------

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      if(icall.eq.0) test1=0.d0

      GG   =0.D0

      GG1  =0.D0

      GG2  =0.D0

      GGT  =0.D0

      GGO  =0.D0

      GGT1 =0.D0

      GGO1 =0.D0



C ---------------------------------------------------------------

C     USING GAUSS DIRECTLY:

c     DO 100 INT=1,NINT

c     ABM=0.5D0*(YB(INT+1)-YB(INT))

c     ABP=0.5D0*(YB(INT+1)+YB(INT))

c     DO 110 IY=1,NPNT

c     IF(IMETH.EQ.0) THEN

c     Y=ABM*XX(IY)+ABP

c     GEW=WW(IY)*ABM*2.D0/PI

c     ENDIF

c     IF(IMETH.EQ.1) THEN

c     Y=(1.D0+XX(IY))/(1.D0-XX(IY))

c     GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

c     ENDIF

c     IF(Y.GE.50.D0) GOTO 110

C ---------------------------------------------------------------

C     USING GRID:              

      DO 110 IY=1,NPNT

      Y = XX(IY)

      GEW = (2.D0/PI)*WW(IY)

C ---------------------------------------------------------------



      GEW = GEW*AA/(Y**2+AA**2)

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP =FDEXP(-Y*Y*RATP*RATP)

C

      AM=PIM*DSQRT((AMES/PIM)**2+Y*Y)

      AM1 = AM/PIM

      AM3 = (AM/PIM)**3

      AM5 = (AM/PIM)**5

      VKUM =(ALAM/AM)**3*FDEXP(-XLAM2)/(2*SRPI)

      XM=AM*X/PIM

      RATM =AM/ALAM

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLAM+RATM)

      EPM  =FDERFC( XLAM+RATM)



      FIM  =F0(ERATM,EXM ,EMM ,EPM ,XM)      

      FIMT =F3(ERATM,EXM ,EMM ,EPM ,EXLAM, XM, XLAM)      

      FIMO =F1(ERATM,EXM ,EMM ,EPM ,EXLAM, XM, XLAM)      

c     FIMO2=3*FIAT/(XM*XM)

C

      FIM1 = FIM - VKUM            

      FIM2 = FIM1 + (1.5D0-XLAM*XLAM)*VKUM/RATM/RATM   

      FIMT1= FIMT - XLAM*XLAM*VKUM/(3*RATM*RATM)  

      FIMO1= FIMO - VKUM/(2*RATM*RATM)    

C

      IF(SIGN.EQ.1.D0) THEN

      GG    = GG   + GEW*FIM  *FDISP*AM1

      GG1   = GG1  + GEW*FIM1 *FDISP*AM3

      GG2   = GG2  + GEW*FIM2 *FDISP*AM5

      GGT   = GGT  + GEW*FIMT *FDISP*AM3            

      GGO   = GGO  + GEW*FIMO *FDISP*AM3         

      GGT1  = GGT1 + GEW*FIMT1*FDISP*AM5          

      GGO1  = GGO1 + GEW*FIMO1*FDISP*AM5           

      ENDIF

      IF(SIGN.EQ.-1.D0) THEN

      GG    = GG   + GEW*(2*FIB- FIM *FDISP*AM1)

      GG1   = GG1  + GEW*(2*FIB1-FIM1*FDISP*AM3)

      GG2   = GG2  + GEW*(2*FIB2-FIM2*FDISP*AM5)

      GGT   = GGT  + GEW*(2*FIBT-FIMT*FDISP*AM3)           

      GGO   = GGO  + GEW*(2*FIBO-FIMO*FDISP*AM3)             

      GGT1  = GGT1 + GEW*(2*FIBT1-FIMT1*FDISP*AM5)         

      GGO1  = GGO1 + GEW*(2*FIBO1-FIMO1*FDISP*AM5)             

      ENDIF

C

 110   CONTINUE

c100   CONTINUE

C ---------------------------------------------------------------

C

C     PHI-FUNCTIONS A LA PRD17 ANDPRC40:

      FC0 = (PIM/AMES)**1*GG

      FC1 = (PIM/AMES)**3*GG1

      FC2 = (PIM/AMES)**5*GG2

      FT0 = (PIM/AMES)**3*GGT

      FT1 = (PIM/AMES)**5*GGT1

      FO0 = (PIM/AMES)**3*GGO

      FO1 = (PIM/AMES)**5*GGO1

CC

C ---------------------------------------------------------------

      ICALL=1

      RETURN

      END

C **********************************************************************

      SUBROUTINE GRID(P,WH,NOGP,P0,PCUT,PMAX,IKIND,IQUADR)

C **********************************************************************

C

C  GENERATING THE INTEGRATION POINTS

C

C-----------------------------------------------------------------------

      IMPLICIT REAL*8(A-H,O-Z)

c*    INCLUDE 'DIMPARS'

c*    DIMENSION P(NGAUSS),WH(NGAUSS),X(NGAUSS),W(NGAUSS)

      DIMENSION P(96),WH(96),X(96),W(96)

      DATA NS/0/

      NT=1

      IF (IKIND.LT.0) NT=2

      IS=IABS(IKIND)

      NOGP=NOGP/NT

      IF(IQUADR.EQ.1) THEN

      IF(NS.EQ.1) PRINT 1007

      CALL GAUSSS(NOGP,X,W,NT)

      ENDIF

c     IF(IQUADR.EQ.2) THEN

c     IF(NS.EQ.1) PRINT 1008

c     CALL CHEBSV(NOGP,X,W)

c     ENDIF

      NOGP=NOGP*NT

C-----------------------------------------------------------------------

C

C  MAPPING BY HYPERBOLIC MAPPING:               

C

C-----------------------------------------------------------------------

C  INTERVAL: P0 - INFTY:

      IF(IABS(IKIND).EQ.1) THEN

      DO 20 I=1,NOGP

      P(I)=PCUT*(2.D0/(1.D0-X(I))-1.D0)

     . -2*P0*X(I)/(1.D0-X(I))

   20 WH(I)=2*(PCUT-P0)*W(I)/(1.D0-X(I))**2

      IF(NS.EQ.1) PRINT 1010

      ENDIF

C-----------------------------------------------------------------------

C

C  MAPPING BY LINEAR FRACTION:       

C

C-----------------------------------------------------------------------

C  INTERVAL: P0 - PMAX:   

      IF(IABS(IKIND).EQ.2) THEN

C  PARAMETERS ARE

      AA = ( (PMAX-PCUT)*P0+(P0-PCUT)*PMAX)/(PMAX+P0-2*PCUT)

      DD = (P0-PMAX)/(PMAX+P0-2*PCUT)

      BB = PCUT*DD                                               



      DO 30 I=1,NOGP

      P(I)=( AA*X(I)+BB )/( X(I)+DD )      

   30 WH(I)= W(I)*( AA*DD-BB )/( X(I)+DD)**2           

      IF(NS.EQ.1) PRINT 1030

      ENDIF

C-----------------------------------------------------------------------

C

C  MAPPING BY ARCTANGENT FUNCTION    

C

C-----------------------------------------------------------------------

C  INTERVAL: P0 - PMAX:   

      IF(IABS(IKIND).EQ.3) THEN

      PI4 = 0.25D0*DACOS(-1.D0)



      DO 40 I=1,NOGP

      AA = PI4*(X(I)+1.D0)

      P(I)=PCUT*DTAN(AA)                   

      CS  =DCOS(AA)

   40 WH(I)= PI4*PCUT*W(I)/(CS*CS)                              

      IF(NS.EQ.1) PRINT 1040

      ENDIF

C-----------------------------------------------------------------------

C

      IF(NS.EQ.1) THEN

      WRITE(6,1009) IKIND,NOGP,P0,PCUT,PMAX,(P(I),I=1,NOGP)

      WRITE(6,1019) (WH(I),I=1,NOGP)

      ENDIF

C-----------------------------------------------------------------------

      RETURN

 1007 FORMAT ('   GRID :  QUADRATURE = GAUSSIAN,',/)

 1008 FORMAT ('   GRID :  QUADRATURE = CHEBYSHEV,',/)

 1009 FORMAT ('           IKIND=',I2,' NOGP=',I3,' P0=',F10.3,' PCUT=',  

     .F10.3,' PMAX=',F10.3,/,10X,' GRID POINTS :',/,4(5D14.5,/))

 1019 FORMAT (10X,' GRID WEIGHTS:',/,4(5D14.5,/))

 1010 FORMAT ('           MAPPING WITH HYPERBOLA,',/)

 1030 FORMAT ('           MAPPING WITH LINEAR FRACTION,',/)

 1040 FORMAT ('           MAPPING WITH ARCTANGENT,',/)            

      END



















C **********************************************************************

C VERSION DECEMBER 2009: 1. 1/M-TERMS PI-OMEGA INCLUDED !!

C                        2. VSIG, VTEN, VASO

C                        3. AXIAL 1^{++} SU3-SINGLET PAIRS 

C **********************************************************************

C NOTICE: IN COMMON/ALLPS/ added AMPI, w.r.t. bbprogs!!

C **********************************************************************

C VERSION YNOOM.F: 15 SEPT. 1997, SU3-relations okay!

C **********************************************************************

C

C NOTICE: 1) FOR DOUBLE SCALAR/DIFFRACTIVE: ALD = 0.25!

C         2) IN OMPAIR : COMMON/CCPR/ !

C

C **********************************************************************

      SUBROUTINE OMPSPS(X,INA,IPV,IOFF,ALP,APV)

C **********************************************************************

C *

C *   DATE: AUGUST, 1995

C

C *   THIS ROUTINE: POTENTIALS FROM DOUBLE PSEUDO-SCALAR EXCHANGE

C *                 CALLED BY SUBROUTINE YNPSPS

C *

C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX

C *

C *        NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET

C *

C **********************************************************************

C

C     INCLUDED IN ENERGY DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT.

C     INCLUDED IN COUPLING-COMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13,

     .XGD12,XGD13

      COMMON/PSBEOM/

     .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4),

     .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4)

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA IPIPI/1/,IPIET/1/,IPIETP/1/,IPIKA/1/,IKAKA/1/,

     .     IETA2/1/,IETKA/1/,IETETP/1/,IETPKA/1/,IETAP2/1/

      DATA FACT/70.D0/,ICALL/0/,NSCHR/0/,POLD/-123D0/



c     character*6 typ(10)

c     data typ/'PIPI','IPIET','IPIETP','IPIKA','IKAKA',

c    .'IETA2','IETKA','IETETP','IETPKA','IETAP2'/



      SAVE FACT,AMB,BPV       

c     SAVE SOALL,SOALS,SOASS

C

      CALL ERRSET(208,256,-1,1)

C

      pim=pim0

c*    pim=500.d0

      IF(ICALL.EQ.0) THEN

        FACT = PIM0/2.D0

        BPV  = 2*APV-1.D0

C       AVERAGE MASS:

        AMB = 2*AMNN*AMH/(AMNN+AMH)

        FACT = (PIM0/AMB)*FACT

        IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB,APV

   52   FORMAT(//,'  IN OMPSPS: INA, IPV, IOFF=',3I3,' PIM=',F7.3,

     .            ' AMB=',F10.3,' APV=',F10.3,/)

c       ICALL=1

c       SOALL = (AMNN-AMLN)/(AMNN+AMLN)

c       SOALS = (AMNN-AMH )/(AMNN+AMH )

c       SOASS = (AMNN-AMSN)/(AMNN+AMSN)

      ENDIF



        if(pold.ne.p) then

        icall=0

        pold = p

        nschr= 1



        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

        ISFLL = (1+ISFAC)/2

        ISFLS = (3-ISFAC)

        ISFSS = (9+ISFAC)/2

        endif



        if(icall.eq.20.and.nschr.eq.1) then

        DO 250 NCHAN=1,5

        DO 250 ITYPV=1,4

        DO 250 M=1,4

        DO 250 N=1,4

  250   VPSPS(NCHAN,ITYPV,M,N)=0.D0

        endif

        

        XF12=F1*(4*ALP-1.D0)/SR3

        XF13=-F1  

C

C     1/M-CORRECTIONS:

C

      DO 100 II=1,10

      PEX = 1.D0

      GOTO(10,20,30,40,50,60,70,80,90,95),II

C PION-PION EXCHANGE POTENTIALS:

   10 IF(IPIPI.EQ.1) THEN

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  1*(3-2*ISFAC)*F1**2*F1**2

      CPALL  =  3*F1*F1*F3*F3

      CPALS  =  2*SR3*F1*F1*F3*F2

      CPASS  =  F1*F1*(3*F3*F3+4*F2*F2)

      CPADR  =  +F1*F1*F2*F2

C     CROSSED:

      CCRNN  =  1*(3+2*ISFAC)*F1**2*F1**2

      CCRLL  =  3*F1*F1*F3*F3

      CCRLS  = -2*SR3*F1*F1*F3*F2

      CCRSS  =  -F1*F1*F3*F3

      CCRDR  =  F1*F1*(2*F3*F3+3*F2*F2)



      CALL FOOM(1,X,PIM,PIM,ALMP8,ALMP8)

      ENDIF

      GOTO 200



C PION-ETA EXCHANGE POTENTIALS:

   20 IF(IPIET.EQ.1) THEN

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*F6**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*F6*F3*(F8+F7)

      CPASS  =  -4*F1*F6*F2*F8

      CPADR  =  +2*F1*F6*F2*F8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*F6*F3*(F8+F7)

      CCRSS  =  -4*F1*F6*F2*F8

      CCRDR  =  +2*F1*F6*F2*F8



      CALL FOOM(1,X,PIM,AME,ALMP8,ALMP8)

      GOTO 200

      ENDIF



C PION-ETA' EXCHANGE POTENTIALS:

   30 IF(IPIETP.EQ.1) THEN

      M = 1

      N = 4

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*F9**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*F9*F3*(F11+F10)

      CPASS  =  -4*F1*F9*F2*F11

      CPADR  =  +2*F1*F9*F2*F11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*F9*F3*(F11+F10)

      CCRSS  =  -4*F1*F9*F2*F11

      CCRDR  =  +2*F1*F9*F2*F11



      CALL FOOM(1,X,PIM,AMX,ALMP8,ALMP1)

      ENDIF

      GOTO 200



C PION-KAON EXCHANGE POTENTIALS:

   40 IF(IPIKA.EQ.1) THEN

      PEX = P

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*F1*F4*F3*F5

      CPALS  =  -SR3*F1*F3*(F4**2-F5**2)

     .          +2*SR3*F1*F2*F4*F5

      CPASS  =  F1*F5*(6*F3*F4+4*F2*F5)

      CPADR  =  +4*F1*F2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(F1*F1*F4**2+F3*F3*F5**2)

      CCRLS  =  SR3*F4*F5*(F1**2-F3**2)

     .         +2*SR3*F2*F3*F5**2

      CCRSS  =  5*F1**2*F5**2+F3**2*F4**2

     .         +4*F2*F3*F4*F5

      CCRDR  =  2*F1**2*F5**2+F3**2*F4**2

     .         +3*F2**2*F5**2-2*F2*F3*F4*F5



      CALL FOOM(1,X,PIM,AMK,ALMP8,ALMKA)

      ENDIF

      GOTO 200



C KAON-KAON EXCHANGE POTENTIALS:

   50 IF(IKAKA.EQ.1) THEN

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  (F4**2+3*F5**2)*F4**2

      CPALS  =  SR3*(F5**2-F4**2)*F4*F5

      CPASS  =  (3*F4**2+F5**2)*F5**2

      CPADR  =  4*F5**4

C     CROSSED:

      CCRNN  =  1*(ISFLL*F4**2*F4**2+ISFLS*F4*F5*F4*F5+

     .             ISFSS*F5**2*F5**2)

      CCRLL  = +(F4**2+3*F5**2)*XF12**2

      CCRLS  = +SR3*(F4**2-F5**2)*1*XF12*XF13

      CCRSS  = +(-F4**2+5*F5**2)*XF13**2

      CCRDR  =  +2*XF13**2*(F4**2+F5**2)



      CALL FOOM(1,X,AMK,AMK,ALMKA,ALMKA)

      ENDIF

      GOTO 200



C ETA-ETA EXCHANGE POTENTIALS:

   60 IF(IETA2.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  F6**2*F6**2

      CPALL  =  F6**2*F7**2

      CPALS  =  0.D0

      CPASS  =  F6**2*F8**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  F6**2*F7**2

      CCRLS  =  0.D0

      CCRSS  =  F6**2*F8**2

      CCRDR  =  CCRSS



      CALL FOOM(1,X,AMK,AMK,ALMKA,ALMKA)

      ENDIF

      GOTO 200



C ETA-KAON EXCHANGE POTENTIALS:

   70 IF(IETKA.EQ.1) THEN

      PEX = P

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*F6*F7*F4**2

      CPALS  =  -SR3*F6*(F7+F8)*F4*F5

      CPASS  =  -2*F6*F8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (F6**2+F7**2)*F4**2

      CCRLS  =  -SR3*(F6**2+F7*F8)*F4*F5

      CCRSS  =  -1*(F6**2+F8**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL FOOM(1,X,AME,AMK,ALMP8,ALMKA)

      ENDIF

      GOTO 200



C ETA-ETA' EXCHANGE POTENTIALS:

   80 IF(IETETP.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 4

C     PARALLEL:

      CPANN  =  2*F6**2*F9**2

      CPALL  =  2*F6*F9*F7*F10

      CPALS  =  0.D0

      CPASS  =  2*F6*F9*F8*F11

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  2*F6*F9*F7*F10

      CCRLS  =  0.D0

      CCRSS  =  2*F6*F9*F8*F11

      CCRDR  =  CCRSS



      CALL FOOM(1,X,AME,AMX,ALMP8,ALMP1)

      ENDIF

      GOTO 200



C ETA'-KAON EXCHANGE POTENTIALS:

   90 IF(IETPKA.EQ.1) THEN

      PEX = P

      M = 2

      N = 4

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*F9*F10*F4**2

      CPALS  =  -SR3*F9*(F10+F11)*F4*F5

      CPASS  =  -2*F9*F11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (F9**2+F10**2)*F4**2

      CCRLS  =  -SR3*(F9**2+F10*F11)*F4*F5

      CCRSS  =  -1*(F9**2+F11**2)*F5**2

      CCRDR  =  -2*CCRSS



      CALL FOOM(1,X,AMX,AMK,ALMP1,ALMKA)

      ENDIF

      GOTO 200



C ETA'-ETA' EXCHANGE POTENTIALS:

   95 IF(IETAP2.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 4

C     PARALLEL:

      CPANN  =  F9**2*F9**2

      CPALL  =  F9**2*F10**2

      CPALS  =  0.D0

      CPASS  =  F9**2*F11**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  F9**2*F10**2

      CCRLS  =  0.D0

      CCRSS  =  F9**2*F11**2

      CCRDR  =  CCRSS



      CALL FOOM(1,X,AMX,AMX,ALMP1,ALMP1)

      ENDIF

      GOTO 200



200   IF(INA.EQ.1) THEN



C     NON-ADIABATIC 1/M-CORRECTIONS:

      VCLL  =   VCLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX

      VCLS  =   VCLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX

      VCSS  =   VCSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX

      VCDR  =   VCDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX



      VSLL  =   VSLL + FACT*( CPALL+2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS + FACT*( CPALS+2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS + FACT*( CPASS+2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR + FACT*( CPADR+2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL + FACT*( CPALL+2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS + FACT*( CPALS+2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS + FACT*( CPASS+2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR + FACT*( CPADR+2*CCRDR )*FNONT*PEX

c     new may 2006: (was forgotten before !!, but is small)

c     VOLL  =   VOLL - FACT*  CPALL *FNONO*PEX

c     VOLS  =   VOLS - FACT*  CPALS *FNONO*PEX

c     VOSS  =   VOSS - FACT*  CPASS *FNONO*PEX

c     VODR  =   VODR - FACT*  CPADR *FNONO*PEX



      VPSPS(1,1,M,N)=VPSPS(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX

      VPSPS(2,1,M,N)=VPSPS(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX

      VPSPS(3,1,M,N)=VPSPS(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX

      VPSPS(4,1,M,N)=VPSPS(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX

      VPSPS(5,1,M,N)=VPSPS(5,1,M,N)-FACT*(CPADR-2*CCRDR)*FNONC*PEX



      VPSPS(1,2,M,N)=VPSPS(1,2,M,N)+FACT*(CPANN+2*CCRNN)*FNONS*PEX

      VPSPS(2,2,M,N)=VPSPS(2,2,M,N)+FACT*(CPALL+2*CCRLL)*FNONS*PEX

      VPSPS(3,2,M,N)=VPSPS(3,2,M,N)+FACT*(CPALS+2*CCRLS)*FNONS*PEX

      VPSPS(4,2,M,N)=VPSPS(4,2,M,N)+FACT*(CPASS+2*CCRSS)*FNONS*PEX

      VPSPS(5,2,M,N)=VPSPS(5,2,M,N)+FACT*(CPADR+2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

C     PV-VERTEX 1/M-CORRECTIONS:

      VCLL  =   VCLL + APV*FACT*CCRLL *FPVC*PEX

      VCLS  =   VCLS + APV*FACT*CCRLS *FPVC*PEX

      VCSS  =   VCSS + APV*FACT*CCRSS *FPVC*PEX

      VCDR  =   VCDR + APV*FACT*CCRDR *FPVC*PEX



      VOLL  =   VOLL + APV*FACT*CCRLL *FPVO*PEX

      VOLS  =   VOLS + APV*FACT*CCRLS *FPVO*PEX

      VOSS  =   VOSS + APV*FACT*CCRSS *FPVO*PEX

      VODR  =   VODR + APV*FACT*CCRDR *FPVO*PEX

c     new may 2006: (was forgotten before !!)

c     VALL  =   VALL + APV*FACT*CCRLL *FPVO*PEX

c    .                 *SOALL

c     VALS  =   VALS + APV*FACT*CCRLS *FPVO*PEX

c    .                 *SOALS

c     VASS  =   VASS + APV*FACT*CCRSS *FPVO*PEX

c    .                 *SOASS

c     VADR  =   VADR + APV*FACT*CCRDR *FPVO*PEX

c    .                 *SOASS



      VPSPS(1,1,M,N)=VPSPS(1,1,M,N)+APV*FACT*CCRNN*FPVC*PEX

      VPSPS(2,1,M,N)=VPSPS(2,1,M,N)+APV*FACT*CCRLL*FPVC*PEX

      VPSPS(3,1,M,N)=VPSPS(3,1,M,N)+APV*FACT*CCRLS*FPVC*PEX

      VPSPS(4,1,M,N)=VPSPS(4,1,M,N)+APV*FACT*CCRSS*FPVC*PEX

      VPSPS(5,1,M,N)=VPSPS(5,1,M,N)+APV*FACT*CCRDR*FPVC*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VCLL  =   VCLL + BPV*FACT*CPALL *FOFFC*PEX/3.D0

      VCLS  =   VCLS + BPV*FACT*CPALS *FOFFC*PEX/3.D0

      VCSS  =   VCSS + BPV*FACT*CPASS *FOFFC*PEX/3.D0

      VCDR  =   VCDR + BPV*FACT*CPADR *FOFFC*PEX/3.D0



      VOLL  =   VOLL + BPV*FACT*CPALL *FOFFO*PEX/3.D0

      VOLS  =   VOLS + BPV*FACT*CPALS *FOFFO*PEX/3.D0

      VOSS  =   VOSS + BPV*FACT*CPASS *FOFFO*PEX/3.D0

      VODR  =   VODR + BPV*FACT*CPADR *FOFFO*PEX/3.D0



      VPSPS(1,1,M,N)=VPSPS(1,1,M,N)+BPV*FACT*CPANN*FOFFC*PEX/3.D0

      VPSPS(2,1,M,N)=VPSPS(2,1,M,N)+BPV*FACT*CPALL*FOFFC*PEX/3.D0

      VPSPS(3,1,M,N)=VPSPS(3,1,M,N)+BPV*FACT*CPALS*FOFFC*PEX/3.D0

      VPSPS(4,1,M,N)=VPSPS(4,1,M,N)+BPV*FACT*CPASS*FOFFC*PEX/3.D0

      VPSPS(5,1,M,N)=VPSPS(5,1,M,N)+BPV*FACT*CPADR*FOFFC*PEX/3.D0

      ENDIF

c     if(icall.eq.0) then

c     write(6,*) 'OMPSPS: x=',x,' ii=',ii,' ',typ(ii),' apv=',apv

c     write(6,*) ' cpall=',cpall,' ccrll=',ccrll,' voll=',voll

c     endif

100   CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(1,x,p)

c**   if(icall.eq.20.and.nschr.eq.1) call wromtm(1,x,p)

c     if(icall.eq.40.and.nschr.eq.1) call wromtm(1,x,p)



1000  CALL ERRSET(208,256,1,1)

      ICALL=ICALL+1

      RETURN

C END OOPSPS ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE OMPIBE(X,INA,IPV,IOFF,APV)

C **********************************************************************

C *

C *   DATE: AUGUST, 1995

C

C *   THIS ROUTINE: PI-MESON EXCHANGE YN-POTENTIALS

C *                 CALLED BY SUBROUTINE YNPIBE

C

C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX

C *

C *   NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS

C * FROM: PI-EPSILON, PI-POMERON

C

C *

C **********************************************************************

C

C     INCLUDED IN ENERGY-DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT,FACT2

C     INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR                       

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASI,BSI,AM1SI,AM2SI,ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/KAPPA/AMSCKH,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK ! BROAD KAPPA 13 AUGUSTUS 2010

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

c     COMMON/ALLAX/FA1,FA9,ALPA

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      COMMON/PSBEOM/

     .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4),

     .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4)

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))

C

      DIMENSION FUN(9),AMSIG(2),ASIG(2)

      COMMON/TREATV/IPIRO,IPIOM,IPIPH,IPIKS

      COMMON/TREATS/IPIDE,IPIEP,IPIST,IPIKSC

      COMMON/TREATD/IPIA2,IPIPOM,IPIKSS

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/

      DATA NS/0/,ICALL/0/,ISFAC/1/,FACT/70.D0/

      SAVE FACT,AMB,BPV

C

      CALL ERRSET(208,256,-1,1)

C

      pim=pim0

c*    pim=500.d0

  12  IF(ICALL.EQ.0) THEN

        BPV  = 2*APV-1.D0

        FACT = PIM0/2.D0

c       FACT = PIM0

c       AMB  = 2*AMNN*AMH/(AMNN+AMH)

        amb  = ampro

        FACT = FACT*(PIM0/AMB)

        IF(NS.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB

   52   FORMAT(//,'  IN OMPIBE: INA, IPV, IOFF=',3I3,' PIM=',F7.3,

     .            ' AMB=',F10.3,/)

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

        DO 750 NCHAN=1,5

        DO 750 ITYPV=1,4

        DO 750 M=1,4

        DO 750 N=1,4

        VPSVC(NCHAN,ITYPV,M,N)=0.D0

        VPSSC(NCHAN,ITYPV,M,N)=0.D0

  750   VPSDF(NCHAN,ITYPV,M,N)=0.D0

c       ICALL=1

      ENDIF

     

C

C     1/M-CORRECTIONS:

C

C A)  PION-VECTOR-MESON POTENTIALS: ******************************

C

      DO 100 II=1,4

      PEX = 1.D0

      GOTO(10,20,30,40),II

C     PI-RHO:

   10 IF(IPIRO.EQ.1) THEN

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  2*(3-2*ISFAC)*F1**2*FD1**2

      CPALL  =  6*F1*FD1*F3*FD3

      CPALS  =  +2*SR3*F1*FD1*(F3*FD2+F2*FD3)

      CPASS  =  2*F1*FD1*(3*F3*FD3+4*F2*FD2)

      CPADR  =  2*F1*FD1*F2*FD2

C     CROSSED:

      CCRNN  =  2*(3+2*ISFAC)*F1**2*FD1**2

      CCRLL  =  6*F1*FD1*F3*FD3

      CCRLS  =  -2*SR3*F1*FD1*(F3*FD2+F2*FD3)

      CCRSS  =  -2*F1*FD1*F3*FD3

      CCRDR  =  2*F1*FD1*(2*F3*FD3+3*F2*FD2)



c     CALL FOOM(2,X,PIM,AMRO,ALMP8,ALMV8)

      FNONSH=0.D0

      FPVSH =0.D0

      FOFFSH=0.D0

      FNONTH=0.D0

      FPVTH =0.D0

      FOFFTH=0.D0

      DO 710 KK=1,2

      CALL FOOM(2,X,PIM,AMVEC(KK),ALMP8,ALMV8)

      FNONSH=FNONSH+AVEC(KK)*FNONS

      FPVSH =FPVSH +AVEC(KK)*FPVS 

      FOFFSH=FOFFSH+AVEC(KK)*FOFFS

      FNONTH=FNONTH+AVEC(KK)*FNONT

      FPVTH =FPVTH +AVEC(KK)*FPVT 

  710 FOFFTH=FOFFTH+AVEC(KK)*FOFFT

      FNONS = FNONSH

      FPVS  = FPVSH

      FOFFS = FOFFSH

      FNONT = FNONTH

      FPVT  = FPVTH

      FOFFT = FOFFTH

      ENDIF

      GOTO 150

C

C PION-OMEGA EXCHANGE POTENTIALS:

C     PI-OMEGA

   20 IF(IPIOM.EQ.1) THEN

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*FD6**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*FD6*F3*(FD7+FD8)

      CPASS  =  -4*F1*FD6*F2*FD8

      CPADR  =  +2*F1*FD6*F2*FD8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*FD6*F3*(FD7+FD8)

      CCRSS  =  -4*F1*FD6*F2*FD8

      CCRDR  =  +2*F1*FD6*F2*FD8



      CALL FOOM(2,X,PIM,AMOM,ALMP8,ALMV1)

      ENDIF

      GOTO 150



C PION-PHI EXCHANGE POTENTIALS:

   30 IF(IPIPH.EQ.1) THEN

      M = 1

      N = 4

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*FD9**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*FD9*F3*(FD10+FD11)

      CPASS  =  -4*F1*FD9*F2*FD11

      CPADR  =  +2*F1*FD9*F2*FD11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*FD9*F3*(FD10+FD11)

      CCRSS  =  -4*F1*FD9*F2*FD11

      CCRDR  =  +2*F1*FD9*F2*FD11



      CALL FOOM(2,X,PIM,AMFI,ALMP8,ALMV1)

      ENDIF

      GOTO 150



C PION-KSTAR EXCHANGE POTENTIALS:

   40 IF(IPIKS.EQ.1) THEN

      M = 1

      N = 2

      PEX = P

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*F1*FD4*F3*FD5

      CPALS  =  -SR3*F1*F3*(FD4**2-FD5**2)

     .          +2*SR3*F1*F2*FD4*FD5

      CPASS  =  F1*FD5*(6*F3*FD4+4*F2*FD5)

      CPADR  =  +4*F1*F2*FD5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(F1*F1*FD4**2+F3*F3*FD5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*FD4*FD5

     .         +2*SR3*F2*F3*FD5**2

      CCRSS  =  5*F1**2*FD5**2+F3*F3*FD4**2

     .         +4*F2*F3*FD4*FD5

      CCRDR  =  2*F1**2*FD5**2+F3**2*FD4**2

     .         +3*F2**2*FD5**2-2*F2*F3*FD4*FD5



      CALL FOOM(2,X,PIM,AMKS,ALMP8,ALMKS)

      ENDIF

      GOTO 150



  150 IF(INA.EQ.1) THEN

      VSLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL + APV*FACT*(      +1*CCRLL )*FPVS*PEX

      VSLS  =   VSLS + APV*FACT*(      +1*CCRLS )*FPVS*PEX

      VSSS  =   VSSS + APV*FACT*(      +1*CCRSS )*FPVS*PEX

      VSDR  =   VSDR + APV*FACT*(      +1*CCRDR )*FPVS*PEX



      VTLL  =   VTLL + APV*FACT*(      +1*CCRLL )*FPVT*PEX

      VTLS  =   VTLS + APV*FACT*(      +1*CCRLS )*FPVT*PEX

      VTSS  =   VTSS + APV*FACT*(      +1*CCRSS )*FPVT*PEX

      VTDR  =   VTDR + APV*FACT*(      +1*CCRDR )*FPVT*PEX



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

c     if(icall.eq.0.and.ii.eq.1) then

c     write(*,*) 'in ompibe, pi-ro: m,n=',m,n

c     write(*,*) 'cpann,ccrnn=',cpann,ccrnn

c     write(*,*) 'cpall,ccrll=',cpall,ccrll

c     write(*,*) 'vpsvc(1,2,m,n)=',vpsvc(1,2,m,n)

c     write(*,*) 'vpsvc(2,2,m,n)=',vpsvc(2,2,m,n)

c     write(*,*) 'vpsvc(3,2,m,n)=',vpsvc(3,2,m,n)

c     write(*,*) 'vpsvc(4,2,m,n)=',vpsvc(4,2,m,n)

c     write(*,*) 'vpsvc(5,2,m,n)=',vpsvc(5,2,m,n)

c     endif

  100 CONTINUE

C END VECTOR MESONS



C

C B) PION-SCALAR MESONS: *****************************************

C

      DO 200 II=1,6                                   ! BROAD KAPPA 13 AUGUSTUS 2010

      PEX = 1.D0

      GOTO(11,21,21,41,51,51),II                     ! BROAD KAPPA 13 AUGUSTUS 2010

C PION-DELTA EXCHANGE POTENTIALS:

   11 IF(IPIDE.EQ.1) THEN

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  2*(3-2*ISFAC)*F1**2*GS1**2

      CPALL  =  6*F1*GS1*F3*GS3

      CPALS  =  +2*SR3*F1*GS1*(F3*GS2+F2*GS3)

      CPASS  =  2*F1*GS1*(3*F3*GS3+4*F2*GS2)

      CPADR  =  2*F1*GS1*F2*GS2

C     CROSSED:

      CCRNN  =  2*(3+2*ISFAC)*F1**2*GS1**2

      CCRLL  =  6*F1*GS1*F3*GS3

      CCRLS  =  -2*SR3*F1*GS1*(F3*GS2+F2*GS3)

      CCRSS  =  -2*F1*GS1*F3*GS3

      CCRDR  =  2*F1*GS1*(2*F3*GS3+3*F2*GS2)



      CALL FOOM(3,X,PIM,AMD,ALMP8,ALMS8)

      ENDIF

      GOTO 250



C PION-EPSILON EXCHANGE POTENTIALS:

   21 IF(IPIEP.EQ.1) THEN

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*GS6**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*GS6*F3*(GS8+GS7)

      CPASS  =  -4*F1*GS6*F2*GS8

      CPADR  =  +2*F1*GS6*F2*GS8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*GS6*F3*(GS8+GS7)

      CCRSS  =  -4*F1*GS6*F2*GS8

      CCRDR  =  +2*F1*GS6*F2*GS8



      IF(II.EQ.2) THEN

      PEX = ASI

      CALL FOOM(3,X,PIM,AM1SI,ALMP8,ALMS1)

      ELSE

      PEX = BSI

      CALL FOOM(3,X,PIM,AM2SI,ALMP8,ALMS1)

      ENDIF

      ENDIF

      GOTO 250



C PION-SSTAR EXCHANGE POTENTIALS:

   41 IF(IPIST.EQ.1) THEN

      PEX = 1.D0

      M = 1

      N = 4

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*GS9**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*GS9*F3*(GS11+GS10)

      CPASS  =  -4*F1*GS9*F2*GS11

      CPADR  =  +2*F1*GS9*F2*GS11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*GS9*F3*(GS11+GS10)

      CCRSS  =  -4*F1*GS9*F2*GS11

      CCRDR  =  +2*F1*GS9*F2*GS11



      CALL FOOM(3,X,PIM,AMSST,ALMP8,ALMS1)

      ENDIF

      GOTO 250



C PION-KAPPA EXCHANGE POTENTIALS:

   51 IF(IPIKSC.EQ.1) THEN

c      PEX = P

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*F1*GS4*F3*GS5

      CPALS  =  -SR3*F1*F3*(GS4**2-GS5**2)

     .          +2*SR3*F1*F2*GS4*GS5

      CPASS  =  F1*GS5*(6*F3*GS4+4*F2*GS5)

      CPADR  =  +4*F1*F2*GS5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(F1*F1*GS4**2+F3*F3*GS5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*GS4*GS5

     .         +2*SR3*F2*F3*GS5**2

      CCRSS  =  5*F1**2*GS5**2+F3*F3*GS4**2

     .         +4*F2*F3*GS4*GS5

      CCRDR  =  2*F1**2*GS5**2+F3**2*GS4**2

     .         +3*F2**2*GS5**2-2*F2*F3*GS4*GS5

C

      IF(II.EQ.5) THEN

      PEX = P*ASCK

      CALL FOOM(3,X,PIM,AM1SCK,ALMP8,ALMS8)

      ELSE

      PEX = P*BSCK

      CALL FOOM(3,X,PIM,AM2SCK,ALMP8,ALMS8)

      ENDIF

C

c      CALL FOOM(3,X,PIM,AMSCK,ALMP8,ALMS8)

      ENDIF

      GOTO 250



  250 IF(INA.EQ.1) THEN

      VSLL  =   VSLL + FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS + FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS + FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR + FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL + FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS + FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS + FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR + FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)+FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)+FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)+FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)+FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL - APV*FACT*(      +1*CCRLL )*FPVS*PEX

      VSLS  =   VSLS - APV*FACT*(      +1*CCRLS )*FPVS*PEX

      VSSS  =   VSSS - APV*FACT*(      +1*CCRSS )*FPVS*PEX

      VSDR  =   VSDR - APV*FACT*(      +1*CCRDR )*FPVS*PEX



      VTLL  =   VTLL - APV*FACT*(      +1*CCRLL )*FPVT*PEX

      VTLS  =   VTLS - APV*FACT*(      +1*CCRLS )*FPVT*PEX

      VTSS  =   VTSS - APV*FACT*(      +1*CCRSS )*FPVT*PEX

      VTDR  =   VTDR - APV*FACT*(      +1*CCRDR )*FPVT*PEX



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-APV*FACT*CCRNN*FPVS*PEX

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-APV*FACT*CCRLL*FPVS*PEX

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-APV*FACT*CCRLS*FPVS*PEX

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-APV*FACT*CCRSS*FPVS*PEX

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL - BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS - BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS - BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR - BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL - BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS - BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS - BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR - BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

  200 CONTINUE

C END SCALAR MESONS



C

C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************

C

      DO 300 II=1,3

      PEX = 1.D0

      GOTO(31,32,33),II

C PION-A2 EXCHANGE POTENTIALS:

  31  IF(IPIA2.EQ.1) THEN

      PEX = 1.D0

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  2*(3-2*ISFAC)*F1**2*GD1**2

      CPALL  =  6*F1*GD1*F3*GD3

      CPALS  =  +2*SR3*F1*GD1*(F3*GD2+F2*GD3)

      CPASS  =  2*F1*GD1*(3*F3*GD3+4*F2*GD2)

      CPADR  =  2*F1*GD1*F2*GD2

C     CROSSED:

      CCRNN  =  2*(3+2*ISFAC)*F1**2*GD1**2

      CCRLL  =  6*F1*GD1*F3*GD3

      CCRLS  =  -2*SR3*F1*GD1*(F3*GD2+F2*GD3)

      CCRSS  =  -2*F1*GD1*F3*GD3

      CCRDR  =  2*F1*GD1*(2*F3*GD3+3*F2*GD2)



      CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



C PION-POMERON:

  32  IF(IPIPOM.EQ.1) THEN

      PEX = 1.D0

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*F1**2*GD6**2

      CPALL  =  0.D0

      CPALS  =  -SR3*F1*GD6*F3*(GD8+GD7)

      CPASS  =  -4*F1*GD6*F2*GD8

      CPADR  =  +2*F1*GD6*F2*GD8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  -SR3*F1*GD6*F3*(GD8+GD7)

      CCRSS  =  -4*F1*GD6*F2*GD8

      CCRDR  =  +2*F1*GD6*F2*GD8



      CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



C PION-K** EXCHANGE POTENTIALS:

  33  IF(IPIKSS.EQ.1) THEN

      PEX = P

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*F1*GD4*F3*GD5

      CPALS  =  -SR3*F1*F3*(GD4**2-GD5**2)

     .          +2*SR3*F1*F2*GD4*GD5

      CPASS  =  F1*GD5*(6*F3*GD4+4*F2*GD5)

      CPADR  =  +4*F1*F2*GD5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(F1*F1*GD4**2+F3*F3*GD5**2)

      CCRLS  =  SR3*(F1**2-F3**2)*GD4*GD5

     .         +2*SR3*F2*F3*GD5**2

      CCRSS  =  5*F1**2*GD5**2+F3*F3*GD4**2

     .         +4*F2*F3*GD4*GD5

      CCRDR  =  2*F1**2*GD5**2+F3**2*GD4**2

     .         +3*F2**2*GD5**2-2*F2*F3*GD4*GD5



      CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



  350 IF(INA.EQ.1) THEN

      VSLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSDF(5,2,M,N)=VPSDf(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL + APV*FACT*(      +1*CCRLL )*FPVS*PEX

      VSLS  =   VSLS + APV*FACT*(      +1*CCRLS )*FPVS*PEX

      VSSS  =   VSSS + APV*FACT*(      +1*CCRSS )*FPVS*PEX

      VSDR  =   VSDR + APV*FACT*(      +1*CCRDR )*FPVS*PEX



      VTLL  =   VTLL + APV*FACT*(      +1*CCRLL )*FPVT*PEX

      VTLS  =   VTLS + APV*FACT*(      +1*CCRLS )*FPVT*PEX

      VTSS  =   VTSS + APV*FACT*(      +1*CCRSS )*FPVT*PEX

      VTDR  =   VTDR + APV*FACT*(      +1*CCRDR )*FPVT*PEX



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX

      VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

  300 CONTINUE

C END DIFFRACTIVE CONTRIBUTIONS



      ICALL = 1

C  1  CONTINUE



1000  CALL ERRSET(208,256,1,1)

      RETURN

C END OMPIBE ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE OMPSBE(X,INA,IPV,IOFF,APV)

C **********************************************************************

C *

C *   DATE: AUGUST 1995, COMPLETED DECEMBER 96

C

C     THIS ROUTINE: KAON-MESON AND ETA(P)-MESON YN-POTENTIALS

C          +++++++  AND THE DOUBLE SCALAR/DIFFRACTIVE YN-POTENTIALS

C *   (MESON= VECTOR, SCALAR, DIFFR.)

C *                 CALLED BY SUBROUTINE YNPSBE

C *

C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROMTHE PV-VERTEX

C *

C *   NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C * NOTE THAT IN THE ADIABATIC APPROXIMATION THERE ARE NO CONTRIBUTIONS

C * FROM: PI-EPSILON, PI-POMERON

C

C **********************************************************************

C

C     INCLUDED IN ENERGY-DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT,FACT2

C     INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR                       

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKAP

      COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD,

     .ALPAX

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/KAPPA/AMSCKH,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK ! BROAD KAPPA 13 AUGUSTUS 2010

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

c     COMMON/ALLAX/FA1,FA9,ALPAX

      COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13,

     .XGD12,XGD13

      COMMON/PSBEOM/

     .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4),

     .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4)

C

      DIMENSION FUN(9)



      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))



      DATA IKARO/1/,IKAOM/1/,IKAPH/1/,IKAKS/1/,IKADE/1/,IKAEP/1/,

     .     IKAST/1/,IKAKSC/1/,IKAA2/1/,IKAPOM/1/,IKAKSS/1/,

     .     IETKSC/1/,IETPKP/1/,IETAKS/1/,IETPKS/1/,IEPEP/0/,

     .     IETRHO/1/,IETOME/1/,IETPHI/1/,IETPRH/1/,IETPOM/1/,IETPPH/1/,

     .     IETDE/1/,IETEP/1/,IETST/1/,IETPDE/1/,IETPEP/1/,IETPST/1/,

     .     IETA2/1/,IETPO/1/,IETKD/1/,IETPA2/1/,IETPPO/1/,IETPKD/1/

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/

      DATA ICALL/0/,NSCHR/0/,ISFAC/1/,FACT/70.D0/

      SAVE AMN,FACT,BPV

C

      CALL ERRSET(208,256,-1,1)

C

      pim=pim0

c*    pim=500.d0

      IF(ICALL.EQ.0) THEN

        BPV = 2*APV-1.D0

        AMN = AMPRO

        FACT = PIM0/2.D0

c       FACT = PIM0

        AMB = 2*AMNN*AMH/(AMNN+AMH)

        amb=ampro

        FACT = FACT*(PIM0/AMB)

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

        ISFLL = (1+ISFAC)/2

        ISFLS = (3-ISFAC)

        ISFSS = (9+ISFAC)/2

        IF(NSCHR.NE.0) PRINT 52, INA,IPV,IOFF,PIM,AMB

   52   FORMAT(//,'  IN OMPSBE: INA, IPV, IOFF=',3I3,' PIM=',F7.3,

     .            ' AMB=',F10.3,/)

c       ICALL=1

      ENDIF

     

C     XI-COUPLINGS:

      XF12 = F1*(4*ALP-1.D0)/SR3

      XF13 = -F1

      XFD12 = FD1*(4*ALVD-1.D0)/SR3

      XFD13 = -FD1

      XFV12 = FV1*(4*ALVV-1.D0)/SR3

      XFV13 = -FV1

      XGS12 = GS1*(4*ALS-1.D0)/SR3

      XGS13 = -GS1

      XGD12 = GD1*(4*ALD-1.D0)/SR3

      XGD13 = -GD1

C

C     1/M-CORRECTIONS:

C

C A)  PSEUDO-SCALAR-VECTOR-MESON POTENTIALS: ********************

C

      DO 100 II=1,12

      PEX = 1.D0

      GOTO(101,102,103,104,105,106,107,108,109,110,111,112), II

*     KA-RHO:

  101 IF(IKARO.EQ.1) THEN

      PEX = P

      M = 2

      N = 1

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*FD1*FD3*F4*F5

      CPALS  =  +2*SR3*FD1*FD2*F4*F5-SR3*FD1*FD3*(F4**2-F5**2)

      CPASS  =  6*FD1*FD3*F4*F5+4*FD1*FD2*F5**2

      CPADR  =  4*FD1*FD2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(FD1**2*F4**2+FD3**2*F5**2)

      CCRLS  =  SR3*(FD1**2*F4*F5-FD3**2*F4*F5+2*FD2*FD3*F5**2)

      CCRSS  =  5*FD1**2*F5**2+FD3**2*F4**2+4*FD2*FD3*F4*F5

      CCRDR  =  2*FD1**2*F5**2+FD3**2*F4**2+

     .          3*FD2**2*F5**2-2*FD2*FD3*F4*F5



      CALL FOOM(2,X,AMK,AMRO,ALMKA,ALMV8)

      ENDIF

      GOTO 150

C

C KAON-OMEGA EXCHANGE POTENTIALS:

  102 IF(IKAOM.EQ.1) THEN

      PEX = P

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD6*FD7*F4**2

      CPALS  =  -SR3*FD6*(FD7+FD8)*F4*F5

      CPASS  =  -2*FD6*FD8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FD6**2+FD7**2)*F4**2

      CCRLS  =  -SR3*(FD6**2+FD7*FD8)*F4*F5

      CCRSS  =  -(FD6**2+FD8**2)*F5**2

      CCRDR  =  -2*CCRSS

      CALL FOOM(2,X,AMK,AMOM,ALMKA,ALMV1)

      ENDIF

      GOTO 150



C KAON-PHI EXCHANGE POTENTIALS:

  103 IF(IKAPH.EQ.1) THEN

      PEX = P

      M = 2

      N = 4

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD9*FD10*F4**2

      CPALS  =  -SR3*FD9*(FD10+FD11)*F4*F5

      CPASS  =  -2*FD9*FD11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (FD9**2+FD10**2)*F4**2

      CCRLS  =  -SR3*(FD9**2+FD10*FD11)*F4*F5

      CCRSS  =  -(FD9**2+FD11**2)*F5**2

      CCRDR  =  -2*CCRSS

      CALL FOOM(2,X,AMK,AMFI,ALMKA,ALMV8)

      ENDIF

      GOTO 150



C KAON-KSTAR EXCHANGE POTENTIALS:

  104 IF(IKAKS.EQ.1) THEN

      PEX = 1.D0

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(FD4**2*F4**2+3*FD4*FD5*F4*F5)

      CPALS  =  SR3*(FD5**2*F4*F5+FD4*FD5*F5**2

     .          -FD4**2*F4*F5-FD4*FD5*F4**2)

      CPASS  =  2*(3*FD4*FD5*F4*F5+FD5**2*F5**2)

      CPADR  =  8*FD5**2*F5**2

C     CROSSED:

      CCRNN  =  2*(ISFLL*F4**2*FD4**2+ISFLS*F4*F5*FD4*FD5+

     .             ISFSS*F5**2*FD5**2)

      CCRLL  =  2*(FD4*XFD12*F4*XF12+3*FD5*XFD12*F5*XF12)

      CCRLS  =  SR3*(FD4*F4-FD5*F5)*(XFD13*XF12+XFD12*XF13)

      CCRSS  = -2*FD4*XFD13*F4*XF13+10*FD5*XFD13*F5*XF13

      CCRDR  =  4*(FD5*F5*XFD13*XF13+FD4*F4*XFD13*XF13)

      CALL FOOM(2,X,AMK,AMKS,ALMKA,ALMKS)

      ENDIF

      GOTO 150



C ETA-RHO EXCHANGE POTENTIALS:

  105 IF(IETRHO.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*FD1**2*F6**2

      CPALL  =  0.D0            

      CPALS  =  -SR3*FD1*FD3*F6*(F7+F8)

      CPASS  =  -4*FD1*FD2*F6*F8

      CPADR  =  -0.5D0*CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AME,AMRO,ALMP8,ALMV8)

      ENDIF

      GOTO 150



C ETA-KSTAR EXCHANGE POTENTIALS:

  106 IF(IETAKS.EQ.1) THEN

      PEX = P

      M = 3

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD4**2*F6*F7

      CPALS  =  -SR3*FD4*FD5*F6*(F7+F8)

      CPASS  =  -2*FD5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FD4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*FD4*FD5*(F6**2+F7*F8)

      CCRSS  =  -FD5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS

      CALL FOOM(2,X,AME,AMKS,ALMP8,ALMKS)

      ENDIF

      GOTO 150



C ETA-OMEGA EXCHANGE POTENTIALS:

  107 IF(IETOME.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  2*FD6*FD6*F6*F6 

      CPALL  =  2*FD6*FD7*F6*F7 

      CPALS  =  0.D0                         

      CPASS  =  2*FD6*FD8*F6*F8 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AME,AMOM,ALMP8,ALMV1)

      ENDIF

      GOTO 150



C ETA-PHI EXCHANGE POTENTIALS:

  108 IF(IETPHI.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 4

C     PARALLEL:

      CPANN  =  2*FD9*FD9*F6*F6 

      CPALL  =  2*FD9*FD10*F6*F7 

      CPALS  =  0.D0                         

      CPASS  =  2*FD9*FD11*F6*F8 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AME,AMFI,ALMP8,ALMV8)

      ENDIF

      GOTO 150



C ETAP-RHO EXCHANGE POTENTIALS:

  109 IF(IETPRH.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*FD1**2*F9**2

      CPALL  =  0.D0            

      CPALS  =  -SR3*FD1*FD3*F9*(F10+F11)

      CPASS  =  -4*FD1*FD2*F9*F11

      CPADR  =  -0.5D0*CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AMX,AMRO,ALMP1,ALMV8)

      ENDIF

      GOTO 150



C ETAP-KSTAR EXCHANGE POTENTIALS:

  110 IF(IETPKS.EQ.1) THEN

      PEX = P

      M = 4

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*FD4**2*F9*F10

      CPALS  =  -SR3*FD4*FD5*F9*(F10+F11)

      CPASS  =  -2*FD5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  FD4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*FD4*FD5*(F9**2+F10*F11)

      CCRSS  =  -FD5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS

      CALL FOOM(2,X,AMX,AMKS,ALMP1,ALMKS)

      ENDIF

      GOTO 150



C ETAP-OMEGA EXCHANGE POTENTIALS:

  111 IF(IETPOM.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 3

C     PARALLEL:

      CPANN  =  2*FD6*FD6*F9*F9 

      CPALL  =  2*FD6*FD7*F9*F10 

      CPALS  =  0.D0                         

      CPASS  =  2*FD6*FD8*F9*F11 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AMX,AMOM,ALMP1,ALMV1)

      ENDIF

      GOTO 150



C ETAP-PHI EXCHANGE POTENTIALS:

  112 IF(IETPPH.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 4

C     PARALLEL:

      CPANN  =  2*FD9*FD9*F9*F9 

      CPALL  =  2*FD9*FD10*F9*F10 

      CPALS  =  0.D0                         

      CPASS  =  2*FD9*FD11*F9*F11 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                  	

      CCRLS  =  CPALS                       

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR     

      CALL FOOM(2,X,AMX,AMFI,ALMP1,ALMV8)

      ENDIF

      GOTO 150



  150 IF(INA.EQ.1) THEN

      VSLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL + APV*FACT*(      +1*CCRLL )*FPVS *PEX

      VSLS  =   VSLS + APV*FACT*(      +1*CCRLS )*FPVS *PEX

      VSSS  =   VSSS + APV*FACT*(      +1*CCRSS )*FPVS *PEX

      VSDR  =   VSDR + APV*FACT*(      +1*CCRDR )*FPVS *PEX



      VTLL  =   VTLL + APV*FACT*(      +1*CCRLL )*FPVT *PEX

      VTLS  =   VTLS + APV*FACT*(      +1*CCRLS )*FPVT *PEX

      VTSS  =   VTSS + APV*FACT*(      +1*CCRSS )*FPVT *PEX

      VTDR  =   VTDR + APV*FACT*(      +1*CCRDR )*FPVT *PEX



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSVC(1,2,M,N)=VPSVC(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSVC(2,2,M,N)=VPSVC(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSVC(3,2,M,N)=VPSVC(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSVC(4,2,M,N)=VPSVC(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSVC(5,2,M,N)=VPSVC(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

  100 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(2,x,p)

C END VECTOR MESONS



C

C B) PSEUDO-SCALAR-SCALAR MESONS: ******************************

C

      DO 200 II=1,3  

      DO 200 JJ=1,6                     ! BROAD KAPPA 13 AUGUSTUS 2010

      KK = 5*(II-1)+JJ

      GOTO(11,12,12,13,14,14,15,16,16,17,18,18,19,20,20,21,22,22),KK

C KAON-DELTA EXCHANGE POTENTIALS:

   11 IF(IKADE.EQ.1) THEN

      PEX = P

      M = 2

      N = 1

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GS1*GS3*F4*F5

      CPALS  =  +2*SR3*GS1*GS2*F4*F5-SR3*GS1*GS3*(F4**2-F5**2)

      CPASS  =  6*GS1*GS3*F4*F5+4*GS1*GS2*F5**2

      CPADR  =  4*GS1*GS2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GS1**2*F4**2+GS3**2*F5**2)

      CCRLS  =  SR3*(GS1**2*F4*F5-GS3**2*F4*F5+2*GS2*GS3*F5**2)

      CCRSS  =  5*GS1**2*F5**2+GS3**2*F4**2+4*GS2*GS3*F4*F5

      CCRDR  =  2*GS1**2*F5**2+GS3**2*F4**2+

     .          3*GS2**2*F5**2-2*GS2*GS3*F4*F5

      CALL FOOM(3,X,AMK,AMD,ALMKA,ALMS8)

      ENDIF

      GOTO 250



C KAON-EPSILON EXCHANGE POTENTIALS:

   12 IF(IKAEP.EQ.1) THEN

      PEX = P

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GS6*GS7*F4**2

      CPALS  =  -SR3*GS6*(GS7+GS8)*F4*F5

      CPASS  =  -2*GS6*GS8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (GS6**2+GS7**2)*F4**2

      CCRLS  =  -SR3*(GS6**2+GS7*GS8)*F4*F5

      CCRSS  =  -(GS6**2+GS8**2)*F5**2

      CCRDR  =  -2*CCRSS

      IF(JJ.EQ.2) THEN

       PEX = ASIG(1)*P

       CALL FOOM(3,X,AMK,AMSIG(1),ALMKA,ALMS1)

       ELSE

       PEX = ASIG(2)*P

       CALL FOOM(3,X,AMK,AMSIG(2),ALMKA,ALMS1)

      ENDIF

      ENDIF

      GOTO 250



C KAON-SSTAR EXCHANGE POTENTIALS:

   13 IF(IKAST.EQ.1) THEN

      PEX = P

      M = 2

      N = 4

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GS9*GS10*F4**2

      CPALS  =  -SR3*GS9*(GS10+GS11)*F4*F5

      CPASS  =  -2*GS9*GS11*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (GS9**2+GS10**2)*F4**2

      CCRLS  =  -SR3*(GS9**2+GS10*GS11)*F4*F5

      CCRSS  =  -(GS9**2+GS11**2)*F5**2

      CCRDR  =  -2*CCRSS

      CALL FOOM(3,X,AMK,AMSST,ALMKA,ALMS1)

      ENDIF

      GOTO 250



C KAON-KAPPA EXCHANGE POTENTIALS:

   14 IF(IKAKSC.EQ.1) THEN

C      PEX = 1.D0                 ! BROAD KAPPA 13 AUGUSTUS 2010

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(GS4**2*F4**2+3*GS4*GS5*F4*F5)

      CPALS  =  SR3*(GS5**2*F4*F5+GS4*GS5*F5**2

     .          -GS4**2*F4*F5-GS4*GS5*F4**2)

      CPASS  =  2*(3*GS4*GS5*F4*F5+GS5**2*F5**2)

      CPADR  =  8*GS5**2*F5**2

C     CROSSED:

      CCRNN  =  2*(ISFLL*F4**2*GS4**2+ISFLS*F4*F5*GS4*GS5+

     .             ISFSS*F5**2*GS5**2)

      CCRLL  =  2*(GS4*XGS12*F4*XF12+3*GS5*XGS12*F5*XF12)

      CCRLS  =  SR3*(GS4*F4-GS5*F5)*(XGS13*XF12+XGS12*XF13)

      CCRSS  = -2*GS4*XGS13*F4*XF13+10*GS5*XGS13*F5*XF13

      CCRDR  =  4*(GS5*F5*XGS13*XF13+GS4*F4*XGS13*XF13)

C

      IF(JJ.EQ.5) THEN                 ! BROAD KAPPA 13 AUGUSTUS 2010

       PEX = ASCK

       CALL FOOM(3,X,AMK,AM1SCK,ALMKA,ALMS8)

       ELSE

       PEX = BSCK

       CALL FOOM(3,X,AMK,AM2SCK,ALMKA,ALMS8)

      ENDIF                           ! BROAD KAPPA 13 AUGUSTUS 2010



C      CALL FOOM(3,X,AMK,AMSCK,ALMKA,ALMS8)

      ENDIF

      GOTO 250



C ETA-DELTA EXCHANGE POTENTIALS:

   15 IF(IETDE.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*GS1**2*F6**2

      CPALL  =  0.D0              

      CPALS  =  -SR3*GS1*GS3*F6*(F7+F8)                           

      CPASS  =  -4*GS1*GS2*F6*F8                 

      CPADR  =  -0.5D0*CPASS    

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                           

      CCRLS  =  CPALS                                            

      CCRSS  =  CPASS                                         

      CCRDR  =  CPADR                          

      CALL FOOM(3,X,AME,AMD,ALMP8,ALMS8)

      ENDIF

      GOTO 250



C ETA-EPSILON EXCHANGE POTENTIALS:

   16 IF(IETEP.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  2*GS6**2*F6**2

      CPALL  =  2*GS6*GS7*F6*F7 

      CPALS  =  0.D0                        

      CPASS  =  2*GS6*GS8*F6*F8  

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                    

      CCRLS  =  0.D0                         

      CCRSS  =  CPASS                    

      CCRDR  =  CPADR    

      IF(JJ.EQ.2) THEN

       PEX = ASIG(1)

       CALL FOOM(3,X,AME,AMSIG(1),ALMP8,ALMS1)

       ELSE

       PEX = ASIG(2)

       CALL FOOM(3,X,AME,AMSIG(2),ALMP8,ALMS1)

      ENDIF

      ENDIF

      GOTO 250



C ETA-SSTAR EXCHANGE POTENTIALS:

   17 IF(IETST.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 4

C     PARALLEL:

      CPANN  =  2*GS9**2*F6**2

      CPALL  =  2*GS9*GS10*F6*F7 

      CPALS  =  0.D0                           

      CPASS  =  2*GS9*GS11*F6*F8 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                     

      CCRLS  =  0.D0                             

      CCRSS  =  CPASS                    

      CCRDR  =  CPADR  

      CALL FOOM(3,X,AME,AMSST,ALMP8,ALMS8)

      ENDIF

      GOTO 250



C ETA-KAPPA EXCHANGE POTENTIALS:

   18 IF(IETKSC.EQ.1) THEN

c      PEX = P                     ! BROAD KAPPA 13 AUGUSTUS 2010

      M = 3

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GS4**2*F6*F7

      CPALS  =  -SR3*GS4*GS5*F6*(F7+F8)

      CPASS  =  -2*GS5**2*F6*F8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GS4**2*(F6**2+F7**2)

      CCRLS  =  -SR3*GS4*GS5*(F6**2+F7*F8)

      CCRSS  =  -GS5**2*(F6**2+F8**2)

      CCRDR  =  -2*CCRSS

C

      IF(JJ.EQ.5) THEN                 ! BROAD KAPPA 13 AUGUSTUS 2010

       PEX = ASCK*P

       CALL FOOM(3,X,AME,AM1SCK,ALMP8,ALMS8)

       ELSE

       PEX = BSCK*P

       CALL FOOM(3,X,AME,AM2SCK,ALMP8,ALMS8)

      ENDIF                             ! BROAD KAPPA 13 AUGUSTUS 2010

c      CALL FOOM(3,X,AME,AMSCK,ALMP1,ALMS8)

      ENDIF

      GOTO 250



C ETAP-DELTA EXCHANGE POTENTIALS:

   19 IF(IETPDE.EQ.1) THEN

      PEX = 1.D0 

      M = 4

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*GS1**2*F9**2

      CPALL  =  0.D0              

      CPALS  =  -SR3*GS1*GS3*F9*(F10+F11)                           

      CPASS  =  -4*GS1*GS2*F9*F11                 

      CPADR  =  -0.5D0*CPASS    

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                           

      CCRLS  =  CPALS                                            

      CCRSS  =  CPASS                                         

      CCRDR  =  CPADR                          

      CALL FOOM(3,X,AMX,AMD,ALMP1,ALMS8)

      ENDIF

      GOTO 250



C ETAP-EPSILON EXCHANGE POTENTIALS:

   20 IF(IETPEP.EQ.1) THEN

      PEX = 1.D0 

      M = 4

      N = 3

C     PARALLEL:

      CPANN  =  2*GS6*GS6*F9*F9  

      CPALL  =  2*GS6*GS7*F9*F10 

      CPALS  =  0.D0                        

      CPASS  =  2*GS6*GS8*F9*F11  

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                    

      CCRLS  =  0.D0                         

      CCRSS  =  CPASS                    

      CCRDR  =  CPADR    

      IF(JJ.EQ.2) THEN

       PEX = ASIG(1)

       CALL FOOM(3,X,AMX,AMSIG(1),ALMP1,ALMS1)

       ELSE

       PEX = ASIG(2)

       CALL FOOM(3,X,AMX,AMSIG(2),ALMP1,ALMS1)

      ENDIF

      ENDIF

      GOTO 250



C ETAP-SSTAR EXCHANGE POTENTIALS:

   21 IF(IETPST.EQ.1) THEN

      PEX = 1.D0 

      M = 4

      N = 4

C     PARALLEL:

      CPANN  =  2*GS9*GS9*F9*F9  

      CPALL  =  2*GS9*GS10*F9*F10 

      CPALS  =  0.D0                           

      CPASS  =  2*GS9*GS11*F9*F11 

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                     

      CCRLS  =  0.D0                             

      CCRSS  =  CPASS                    

      CCRDR  =  CPADR  

      CALL FOOM(3,X,AMX,AMSST,ALMP1,ALMS8)

      ENDIF

      GOTO 250



C ETAP-KAPPA EXCHANGE POTENTIALS:

   22 IF(IETPKP.EQ.1) THEN

c      PEX = P                     ! BROAD KAPPA 13 AUGUSTUS 2010

      M = 4

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GS4**2*F9*F10

      CPALS  =  -SR3*GS4*GS5*F9*(F10+F11)

      CPASS  =  -2*GS5**2*F9*F11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GS4**2*(F9**2+F10**2)

      CCRLS  =  -SR3*GS4*GS5*(F9**2+F10*F11)

      CCRSS  =  -GS5**2*(F9**2+F11**2)

      CCRDR  =  -2*CCRSS

C

      IF(JJ.EQ.5) THEN                 ! BROAD KAPPA 13 AUGUSTUS 2010

       PEX = ASCK*P

       CALL FOOM(3,X,AMX,AM1SCK,ALMP1,ALMS8)

       ELSE

       PEX = BSCK*P

       CALL FOOM(3,X,AMX,AM2SCK,ALMP1,ALMS8)

      ENDIF                              ! BROAD KAPPA 13 AUGUSTUS 2010

c      CALL FOOM(3,X,AMX,AMSCK,ALMP1,ALMS8)

      ENDIF

      GOTO 250



  250 IF(INA.EQ.1) THEN

      VSLL  =   VSLL + FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS + FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS + FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR + FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL + FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS + FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS + FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR + FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)+FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)+FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)+FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)+FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL - APV*FACT*(      +1*CCRLL )*FPVS *PEX

      VSLS  =   VSLS - APV*FACT*(      +1*CCRLS )*FPVS *PEX

      VSSS  =   VSSS - APV*FACT*(      +1*CCRSS )*FPVS *PEX

      VSDR  =   VSDR - APV*FACT*(      +1*CCRDR )*FPVS *PEX



      VTLL  =   VTLL - APV*FACT*(      +1*CCRLL )*FPVT *PEX

      VTLS  =   VTLS - APV*FACT*(      +1*CCRLS )*FPVT *PEX

      VTSS  =   VTSS - APV*FACT*(      +1*CCRSS )*FPVT *PEX

      VTDR  =   VTDR - APV*FACT*(      +1*CCRDR )*FPVT *PEX



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-APV*FACT*CCRNN*FPVS*PEX

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-APV*FACT*CCRLL*FPVS*PEX

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-APV*FACT*CCRLS*FPVS*PEX

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-APV*FACT*CCRSS*FPVS*PEX

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL - BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS - BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS - BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR - BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL - BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS - BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS - BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR - BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)-BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSSC(2,2,M,N)=VPSSC(2,2,M,N)-BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSSC(3,2,M,N)=VPSSC(3,2,M,N)-BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSSC(4,2,M,N)=VPSSC(4,2,M,N)-BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSSC(5,2,M,N)=VPSSC(5,2,M,N)-BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

  200 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(3,x,p)

C END SCALAR MESONS

C

C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************

C

      DO 300 II=1,9

      GOTO(31,32,33,34,35,36,37,38,39), II

C KAON-A2 EXCHANGE POTENTIALS:

   31 IF(IKAA2.EQ.1) THEN

      PEX = P

      M = 2

      N = 1

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GD1*GD3*F4*F5

      CPALS  =  +2*SR3*GD1*GD2*F4*F5-SR3*GD1*GD3*(F4**2-F5**2)

      CPASS  =  6*GD1*GD3*F4*F5+4*GD1*GD2*F5**2

      CPADR  =  4*GD1*GD2*F5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GD1**2*F4**2+GD3**2*F5**2)

      CCRLS  =  SR3*(GD1**2*F4*F5-GD3**2*F4*F5+2*GD2*GD3*F5**2)

      CCRSS  =  5*GD1**2*F5**2+GD3**2*F4**2+4*GD2*GD3*F4*F5

      CCRDR  =  2*GD1**2*F5**2+GD3**2*F4**2+

     .          3*GD2**2*F5**2-2*GD2*GD3*F4*F5

      CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM)

      ENDIF

      GOTO 350



C KAON-POMERON:

   32 IF(IKAPOM.EQ.1) THEN

      PEX = P

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD6*GD7*F4**2

      CPALS  =  -SR3*GD6*(GD7+GD8)*F4*F5

      CPASS  =  -2*GD6*GD8*F5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  (GD6**2+GD7**2)*F4**2

      CCRLS  =  -SR3*(GD6**2+GD7*GD8)*F4*F5

      CCRSS  =  -(GD6**2+GD8**2)*F5**2

      CCRDR  =  -2*CCRSS

      CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM)

      ENDIF

      GOTO 350



C KAON-K** EXCHANGE POTENTIALS:

   33 IF(IKAKSS.EQ.1) THEN

      PEX = 1.D0

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(GD4**2*F4**2+3*GD4*GD5*F4*F5)

      CPALS  =  SR3*(GD5**2*F4*F5+GD4*GD5*F5**2

     .          -GD4**2*F4*F5-GD4*GD5*F4**2)

      CPASS  =  2*(3*GD4*GD5*F4*F5+GD5**2*F5**2)

      CPADR  =  8*GD5**2*F5**2

C     CROSSED:

      CCRNN  =  2*(ISFLL*F4**2*GD4**2+ISFLS*F4*F5*GD4*GD5+

     .             ISFSS*F5**2*GD5**2)

      CCRLL  =  2*(GD4*XGD12*F4*XF12+3*GD5*XGD12*F5*XF12)

      CCRLS  =  SR3*(GD4*F4-GD5*F5)*(XGD13*XF12+XGD12*XF13)

      CCRSS  = -2*GD4*XGD13*F4*XF13+10*GD5*XGD13*F5*XF13

      CCRDR  =  4*(GD5*F5*XGD13*XF13+GD4*F4*XGD13*XF13)

      CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM)

      ENDIF

      GOTO 350



C ETA-A2 EXCHANGE POTENTIALS:

   34 IF(IETA2.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*GD1**2*F6**2

      CPALL  =  0.D0             

      CPALS  =  -SR3*GD1*GD3*F6*(F7+F8)                         

      CPASS  =  -4*GD1*GD2*F6*F8                   

      CPADR  =  +2*GD1*GD2*F6*F8 

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0                             

      CCRLS  =  CPALS                                             

      CCRSS  =  CPASS                                          

      CCRDR  =  CPADR                          

      CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



C ETA-POMERON EXCHANGE POTENTIALS:

   35 IF(IETPO.EQ.1) THEN

      PEX = 1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  2*GD6**2*F6**2   

      CPALL  =  2*GD6*GD7*F6*F7   

      CPALS  =  0.D0                                            

      CPASS  =  2*GD6*GD8*F6*F8                    

      CPADR  =  CPASS                  

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                            

      CCRLS  =  0.D0                                              

      CCRSS  =  CPASS                                          

      CCRDR  =  CPADR                          

      CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



C ETA-K** EXCHANGE POTENTIALS:

   36 IF(IETKD.EQ.1) THEN

      PEX = P    

      M = 3

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD4**2*F6*F7   

      CPALS  =  -SR3*GD4*GD5*F6*(F7+F8)                         

      CPASS  =  -2*GD5**2*F6*F8                    

      CPADR  =  -2*CPASS                  

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GD4**2*(F6**2+F7**2)             

      CCRLS  =  -SR3*GD4*GD5*(F6**2+F7*F8)                        

      CCRSS  =  -GD5**2*(F6**2+F8**2)                          

      CCRDR  =  -2*CCRSS                           

      CALL FOOM(4,X,AME,AMPOM,ALMP8,AMPOM)

      ENDIF

      GOTO 350



C ETAP-A2 EXCHANGE POTENTIALS:

   37 IF(IETPA2.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 2

C     PARALLEL:

      CPANN  =  2*ISFAC*GD1**2*F9**2

      CPALL  =  0.D0             

      CPALS  =  -SR3*GD1*GD3*F9*(F10+F11)                         

      CPASS  =  -4*GD1*GD2*F9*F11                   

      CPADR  =  +2*GD1*GD2*F9*F11 

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0                             

      CCRLS  =  CPALS                                             

      CCRSS  =  CPASS                                          

      CCRDR  =  CPADR                          

      CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM)

      ENDIF

      GOTO 350



C ETAP-POMERON EXCHANGE POTENTIALS:

   38 IF(IETPPO.EQ.1) THEN

      PEX = 1.D0

      M = 4

      N = 3

C     PARALLEL:

      CPANN  =  2*GD6**2*F9**2   

      CPALL  =  2*GD6*GD7*F9*F10  

      CPALS  =  0.D0                                            

      CPASS  =  2*GD6*GD8*F9*F11                    

      CPADR  =  CPASS                  

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL                            

      CCRLS  =  0.D0                                              

      CCRSS  =  CPASS                                          

      CCRDR  =  CPADR                          

      CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM)

      ENDIF

      GOTO 350



C ETAP-K** EXCHANGE POTENTIALS:

   39 IF(IETPKD.EQ.1) THEN

      PEX = P    

      M = 4

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD4**2*F9*F10   

      CPALS  =  -SR3*GD4*GD5*F9*(F10+F11)                         

      CPASS  =  -2*GD5**2*F9*F11                    

      CPADR  =  -2*CPASS                  

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GD4**2*(F9**2+F10**2)             

      CCRLS  =  -SR3*GD4*GD5*(F9**2+F10*F11)                        

      CCRSS  =  -GD5**2*(F9**2+F11**2)                          

      CCRDR  =  -2*CCRSS                           

      CALL FOOM(4,X,AMX,AMPOM,ALMP1,AMPOM)

      ENDIF

      GOTO 350



  350 IF(INA.EQ.1) THEN

      VSLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONS*PEX

      VSLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONS*PEX

      VSSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONS*PEX

      VSDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONS*PEX



      VTLL  =   VTLL - FACT*( CPALL-2*CCRLL )*FNONT*PEX

      VTLS  =   VTLS - FACT*( CPALS-2*CCRLS )*FNONT*PEX

      VTSS  =   VTSS - FACT*( CPASS-2*CCRSS )*FNONT*PEX

      VTDR  =   VTDR - FACT*( CPADR-2*CCRDR )*FNONT*PEX



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-FACT*(CPANN-2*CCRNN)*FNONS*PEX

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)-FACT*(CPALL-2*CCRLL)*FNONS*PEX

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)-FACT*(CPALS-2*CCRLS)*FNONS*PEX

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)-FACT*(CPASS-2*CCRSS)*FNONS*PEX

      VPSDF(5,2,M,N)=VPSDf(5,2,M,N)-FACT*(CPADR-2*CCRDR)*FNONS*PEX

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL  =   VSLL + APV*FACT*(      +1*CCRLL )*FPVS *PEX

      VSLS  =   VSLS + APV*FACT*(      +1*CCRLS )*FPVS *PEX

      VSSS  =   VSSS + APV*FACT*(      +1*CCRSS )*FPVS *PEX

      VSDR  =   VSDR + APV*FACT*(      +1*CCRDR )*FPVS *PEX



      VTLL  =   VTLL + APV*FACT*(      +1*CCRLL )*FPVT *PEX

      VTLS  =   VTLS + APV*FACT*(      +1*CCRLS )*FPVT *PEX

      VTSS  =   VTSS + APV*FACT*(      +1*CCRSS )*FPVT *PEX

      VTDR  =   VTDR + APV*FACT*(      +1*CCRDR )*FPVT *PEX



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+APV*FACT*CCRNN*FPVS*PEX

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+APV*FACT*CCRLL*FPVS*PEX

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+APV*FACT*CCRLS*FPVS*PEX

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+APV*FACT*CCRSS*FPVS*PEX

      VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+APV*FACT*CCRDR*FPVS*PEX

      ENDIF

      IF(IOFF.EQ.1) THEN

C     PIONIC OFF-SHELL CORRECTIONS INTMO:

      VSLL  =   VSLL + BPV*FACT*CPALL *FOFFS*PEX/3.D0

      VSLS  =   VSLS + BPV*FACT*CPALS *FOFFS*PEX/3.D0

      VSSS  =   VSSS + BPV*FACT*CPASS *FOFFS*PEX/3.D0

      VSDR  =   VSDR + BPV*FACT*CPADR *FOFFS*PEX/3.D0



      VTLL  =   VTLL + BPV*FACT*CPALL *FOFFT*PEX/3.D0

      VTLS  =   VTLS + BPV*FACT*CPALS *FOFFT*PEX/3.D0

      VTSS  =   VTSS + BPV*FACT*CPASS *FOFFT*PEX/3.D0

      VTDR  =   VTDR + BPV*FACT*CPADR *FOFFT*PEX/3.D0



      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)+BPV*FACT*CPANN*FOFFS*PEX/3.D0

      VPSDF(2,2,M,N)=VPSDF(2,2,M,N)+BPV*FACT*CPALL*FOFFS*PEX/3.D0

      VPSDF(3,2,M,N)=VPSDF(3,2,M,N)+BPV*FACT*CPALS*FOFFS*PEX/3.D0

      VPSDF(4,2,M,N)=VPSDF(4,2,M,N)+BPV*FACT*CPASS*FOFFS*PEX/3.D0

      VPSDF(5,2,M,N)=VPSDF(5,2,M,N)+BPV*FACT*CPADR*FOFFS*PEX/3.D0

      ENDIF

  300 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(4,x,p)

C END DIFFRACTIVE CONTRIBUTIONS



1000  CALL ERRSET(208,256,1,1)

        ICALL=ICALL+1

      RETURN

C END OMPSBE ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE OMSCDF(X,INA)

C **********************************************************************

C *

C *   DATE: DECEMBER 1996

C

C     THIS ROUTINE: THE DOUBLE SCALAR/DIFFRACTIVE YN-POTENTIALS

C *

C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC 

C *

C *   NO MASS-DIFFERENCES BETWEEN BARYONS TAKEN INTO ACCOUNT

C *

C **********************************************************************

C

C     INCLUDED IN ENERGY-DENOMINATORS:

C     (i) L+R contributions included, 1/4 -> 1/2, the latter is

C         put into FACT,FACT2

C     INCLUDED IN COUPLINGCOMBINATIONS CPANLL ETC.:

C     (ii) 1 <-> 2 interchange effects for non-identical mesons.

C

C **********************************************************************

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR                      

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKAP

      COMMON/COUCON/ALP,XZ1(3),ALVD,XZ2(2),ALVV,XZ3(12),ALS,XZ4,ALD,

     .ALPAX

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/XICOUPL/XF12,XF13,XFD12,XFD13,XFV12,XFV13,XGS12,XGS13,

     .XGD12,XGD13

      COMMON/PSBEOM/

     .VPSPS(5,4,4,4),VPSVC(5,4,4,4),VPSSC(5,4,4,4),VPSDF(5,4,4,4),

     .VSCSC(5,4,4,4),VSCDF(5,4,4,4),VDFDF(5,4,4,4)

C

      COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

     .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

     .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

     .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

     .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

     .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

     . ,(GS1,GS(1)),(GD1,GD(1))



      DATA IEPEP/1/,ICALL/0/,NSCHR/1/

C

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,

     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/

      DATA AMPRO/938.2796D0/,AMEPS/760.D0/

      SAVE AMN,FACT

C

      CALL ERRSET(208,256,-1,1)

C

      pim=pim0

c     pim=500.d0

      IF(ICALL.EQ.0) THEN

        AMN = AMPRO

        FACT = PIM0/2.D0

c       FACT = PIM0

c       AMB = 2*AMNN*AMH/(AMNN+AMH)

        amb=ampro

        FACT = FACT*(PIM0/AMB)

        IF(P.EQ.+1.D0) ISFAC=+1

        IF(P.EQ.-1.D0) ISFAC=-3

        ISFLL = (1+ISFAC)/2

        ISFLS = (3-ISFAC)

        ISFSS = (9+ISFAC)/2

        DO 250 NCHAN=1,5

        DO 250 ITYPV=1,4

        DO 250 M=1,4

        DO 250 N=1,4

        VSCSC(NCHAN,ITYPV,M,N)=0.D0

        VSCDF(NCHAN,ITYPV,M,N)=0.D0

  250   VDFDF(NCHAN,ITYPV,M,N)=0.D0

c       ICALL=1

      ENDIF

C

C     1/M-CORRECTIONS:

C **************************************************************

C E) BEGIN DOUBLE SCALAR/DIFFRACTIVE EXCHANGE 

C **************************************************************

C

      IF(INA.EQ.1.AND.IEPEP.EQ.1) THEN

C

C     DOUBLE SCALAR CONTRIBUTIONS:

C

      DO 100 II=1,10

      CPALS = 0.D0

      CCRLS = 0.D0

      GOTO(1,2,3,4,5,6,7,8,9,10), II         

C

C DELTA-DELTA EXCHANGE POTENTIALS:

C     PARALLEL:

    1 PEX = 1.D0 

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  1*(3-2*ISFAC)*GS1**2*GS1**2

      CPALL  =  3*GS1**2*GS3**2            

      CPALS  =  1*SR3*GS1**2*(GS3*GS2+GS2*GS3)

      CPASS  =  1*GS1**2*(3*GS3**2+4*GS2**2)

      CPADR  =  1*GS1**2*GS2**2    

C     CROSSED:

      CCRNN  =  1*(3+2*ISFAC)*GS1**2*GS1**2

      CCRLL  =  3*GS1**2*GS3**2                

      CCRLS  = -1*SR3*GS1**2*(GS3*GS2+GS2*GS3)      

      CCRSS  = -1*GS1**2*GS3**2                

      CCRDR  =  1*GS1**2*(2*GS3**2+3*GS2**2)     



      CALL FOOM(5,X,AMD,AMD,ALMS8,ALMS8)

      GOTO 150

C

C DELTA-KAPPA EXCHANGE POTENTIALS:

    2 PEX = P    

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GS1*GS3*GS4*GS5

      CPALS  =  2*SR3*GS1*GS2*GS4*Gs5-SR3*GS1*GS3*(GS4**2-GS5**2)

      CPASS  =  6*GS1*GS3*GS4*GS5+4*GS1*GS2*GS5**2

      CPADR  =  4*GS1*GS2*GS5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GS1**2*GS4**2+GS3**2*GS5**2)

      CCRLS  =  SR3*(GS1**2*GS4*GS5-GS3**2*GS4*GS5+2*Gs2*GS3*GS5**2)

      CCRSS  =  5*GS1**2*GS5**2+GS3**2*GS4**2+4*Gs2*GS3*GS4*Gs5

      CCRDR  =  2*GS1**2*GS5**2+GS3**2*GS4**2+

     .          3*GS2**2*GS5**2-2*GS2*GS3*GS4*GS5

      CALL FOOM(5,X,AMD,AMSCK,ALMS8,ALMS8)

      GOTO 150

C

C KAPPA-KAPPA EXCHANGE POTENTIALS:

C     PARALLEL:

    3 PEX = 1.D0 

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  1*(GS4**4+3*GS4**2*GS5**2)

      CPALS  =  1*SR3*(GS5**2-GS4**2)*GS4*GS5

      CPASS  =  1*(3*GS4**2+GS5**2)*GS5**2

      CPADR  =  4*GS5**4

C     CROSSED:

      CCRNN  =  1*(ISFLL*GS4**2*GS4**2+ISFLS*GS4*GS5*GS4*GS5+

     .             ISFSS*GS5**2*GS5**2)

      CCRLL  =  1*(GS4**2+3*GS5**2)*XGS12**2

      CCRLS  =  1*SR3*(GS4*GS4-GS5*GS5)*XGS13*XGS12

      CCRSS  = -1*(GS4**2-5*GS5**2)*XGS13**2

      CCRDR  =  2*(GS5*GS5+GS4*GS4)*XGS13**2     



      CALL FOOM(5,X,AMSCK,AMSCK,ALMS8,ALMS8)

      GOTO 150

C

C S*-DELTA EXCHANGE POTENTIALS:

C     PARALLEL:

    4 PEX = 1.D0

      M = 1

      N = 4

      CPANN  =  2*ISFAC*GS1**2*GS9**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*GS1*GS3*GS9*(GS10+GS11)

      CPASS  =  -4*GS1*GS2*GS9*GS11

      CPADR  =  -0.5D0*CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0     

      CCRLS  =  CPALS 

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMSST,AMD,ALMS8,ALMS8)

      GOTO 150

C

C S*-KAPPA EXCHANGE POTENTIALS:

C     PARALLEL:

    5 PEX = P    

      M = 2

      N = 4

      CPANN  =  0.D0

      CPALL  =  2*GS4**2*GS9*GS10

      CPALS  =  -SR3*GS4*GS5*GS9*(GS10+GS11)

      CPASS  =  -2*GS5**2*GS9*GS11

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GS4**2*(GS9**2+GS10**2)

      CCRLS  =  -SR3*GS4*GS5*(G9**2+GS10*GS11) 

      CCRSS  =  -GS5**2*(GS9**2+GS11**2)

      CCRDR  =  -2*CCRSS

      CALL FOOM(5,X,AMSST,AMSCK,ALMS8,ALMS8)

      GOTO 150

C

C S*-S* EXCHANGE POTENTIALS:

C     PARALLEL:

    6 PEX = 1.D0

      M = 4

      N = 4

      CPANN  =  GS9**2*GS9**2

      CPALL  =  GS9**2*GS10**2

      CPASS  =  GS9**2*GS11**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMSST,AMSST,ALMS8,ALMS8)

      GOTO 150

C

C EPSILON-DELTA EXCHANGE POTENTIALS:

C     PARALLEL:

    7 PEX = 1.D0

      M = 1

      N = 3

      CPANN  =  2*ISFAC*GS1**2*GS6**2

      CPALL  =  0.D0           

      CPALS  =  -SR3*GS1*GS3*GS6*(GS7+GS8)

      CPASS  =  -4*GS1*GS2*GS6*GS8

      CPADR  =  -0.5D0*CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0     

      CCRLS  =  CPALS 

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      FNONH = 0.D0

      DO 101 JJ=1,2

c     CALL FOOM(5,X,AMEPS,AMD,ALMS1,ALMS8)

      CALL FOOM(5,X,AMSIG(JJ),AMD,ALMS1,ALMS8)

  101 FNONH = FNONH + FNONC*ASIG(JJ)

      FNONC = FNONH

      GOTO 150

C EPSILON-KAPPA EXCHANGE POTENTIALS:

C     PARALLEL:

    8 PEX = P    

      M = 2

      N = 3

      CPANN  =  0.D0

      CPALL  =  2*GS4**2*GS6*GS7

      CPALS  =  -SR3*GS4*GS5*GS6*(GS7+GS8)

      CPASS  =  -2*GS5**2*GS6*GS8

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GS4**2*(GS6**2+GS7**2)

      CCRLS  =  -SR3*GS4*GS5*(GS6**2+GS7*GS8) 

      CCRSS  =  -GS5**2*(GS6**2+GS8**2)

      CCRDR  =  -2*CCRSS

      FNONH = 0.D0

      DO 102 JJ=1,2

c     CALL FOOM(5,X,AMEPS,AMSCK,ALMS1,ALMS8)

      CALL FOOM(5,X,AMSIG(JJ),AMSCK,ALMS1,ALMS8)

  102 FNONH = FNONH + FNONC*ASIG(JJ)

      FNONC = FNONH

      GOTO 150

C

C EPSILON-S* EXCHANGE POTENTIALS:

C     PARALLEL:

    9 PEX = 1.D0

      M = 3

      N = 4

      CPANN  =  2*GS6**2*GS9**2

      CPALL  =  2*GS6*GS7*GS9*GS10

      CPASS  =  2*GS6*GS8*GS9*GS11

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      FNONH = 0.D0

      DO 103 JJ=1,2

c     CALL FOOM(5,X,AMEPS,AMSST,ALMS1,ALMS8)

      CALL FOOM(5,X,AMSIG(JJ),AMSST,ALMS1,ALMS8)

  103 FNONH = FNONH + FNONC*ASIG(JJ)

      FNONC = FNONH

      GOTO 150

C

C EPSILON-EPSILON EXCHANGE POTENTIALS:

C     PARALLEL:

   10 PEX = 1.D0

      M = 3

      N = 3

      CPANN  =  GS6**2*GS6**2

      CPALL  =  GS6**2*GS7**2

      CPASS  =  GS6**2*GS8**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      FNONH = 0.D0

      DO 104 JJ=1,2

      DO 104 KK=1,2

c     CALL FOOM(5,X,AMEPS,AMEPS,ALMS1,ALMS1)

      CALL FOOM(5,X,AMSIG(JJ),AMSIG(KK),ALMS1,ALMS1)

  104 FNONH = FNONH + FNONC*ASIG(JJ)*ASIG(KK)

      FNONC = FNONH

      GOTO 150



  150 VCLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX

      VCLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX

      VCSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX

      VCDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX



      VSCSC(1,1,M,N)=VSCSC(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX

      VSCSC(2,1,M,N)=VSCSC(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX

      VSCSC(3,1,M,N)=VSCSC(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX

      VSCSC(4,1,M,N)=VSCSC(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX

      VSCSC(5,1,M,N)=VSCSC(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX

  100 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(5,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wromtm(5,x,p)

C

C **************************************************************

C     DOUBLE SCALAR/DIFFRACTIVE CONTRIBUTIONS:

C **************************************************************

C

      DO 300 II=1,12 

      CPALS = 0.D0

      CCRLS = 0.D0

      GOTO(31,32,33,34,35,36,37,38,39,40,41,42),II

C DELTA-A2 EXCHANGE POTENTIALS:

   31 PEX = -1.D0

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  2*(3-2*ISFAC)*GS1**2*GD1**2

      CPALL  =  6*GS1*GS3*GD1*Gd3

      CPALS  =  +2*SR3*GS1*GD1*(GD3*GS2+GD2*GS3)

      CPASS  =  2*Gs1*GD1*(3*GD3*GS3+4*GD2*GS2)

      CPADR  =  2*GS1*GD1*GS2*GD2    

C     CROSSED:

      CCRNN  =  2*(3+2*ISFAC)*GS1**2*GD1**2

      CCRLL  =  6*GS1*GS3*GD1*Gd3         

      CCRLS  =  -2*SR3*GS1*GD1*(GS2*GD3+GS3*GD2)

      CCRSS  =  -2*GS1*GD1*GS3*GD3      

      CCRDR  =  2*GS1*GD1*(2*GS3*GD3+3*GS2*GD2)

      CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM)

      GOTO 350

C DELTA-K** EXCHANGE POTENTIALS:

   32 PEX = -P    

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GD1*GD3*GS4*GS5

      CPALS  =  +2*SR3*GD1*GD2*GS4*GS5-SR3*GD1*GD3*(GS4**2-GS5**2)

      CPASS  =  6*GD1*GD3*GS4*GS5+4*GD1*GD2*GS5**2

      CPADR  =  4*GD1*GD2*GS5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GD1**2*GS4**2+GD3**2*GS5**2)

      CCRLS  =  SR3*(GD1**2*GS4*GS5-GD3**2*GS4*GS5+2*GD2*GD3*GS5**2)

      CCRSS  =  5*GD1**2*GS5**2+GD3**2*GS4**2+4*GD2*GD3*GS4*GS5

      CCRDR  =  2*GD1**2*GS5**2+GD3**2*GS4**2+

     .          3*GD2**2*GS5**2-2*GD2*GD3*GS4*GS5

      CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM)

      GOTO 350

C DELTA-POMERON EXCHANGE POTENTIALS:

   33 PEX = -1.D0

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*GS1**2*GD6**2

      CPALL  =  0.D0             

      CPALS  =  -SR3*GS1*GS3*GD6*(GD7+GD8)

      CPASS  =  -4*GS1*GS2*GD6*GD8

      CPADR  =  -0.5D0*CPASS 

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0                      

      CCRLS  =  CPALS                          

      CCRSS  =  CPASS                   

      CCRDR  =  CPADR    

      CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM)

      GOTO 350

C KAPPA-A2 EXCHANGE POTENTIALS:

   34 PEX = -P 

      M = 2

      N = 1

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GD1*GD3*GS4*GS5

      CPALS  =  2*SR3*GD1*GD2*GS4*GS5-SR3*GD1*GD3*(GS4**2-GS5**2)

      CPASS  =  6*GD1*GD3*GS4*GS5+4*GD1*GD2*GS5**2

      CPADR  =  4*GD1*GD2*GS5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GD1**2*GS4**2+GD3**2*GS5**2)

      CCRLS  =  SR3*(GD1**2*GS4*GS5-GD3**2*GS4*GS5+2*GD2*GD3*GS5**2)

      CCRSS  =  5*GD1**2*GS5**2+GD3**2*GS4**2+4*GD2*GD3*GS4*Gs5

      CCRDR  =  2*GD1**2*GS5**2+GD3**2*GS4**2+

     .          3*GD2**2*GS5**2-2*GD2*GD3*GS4*GS5

      CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM)

      GOTO 350

C KAPPA-K** EXCHANGE POTENTIALS:

   35 PEX = -1.D0

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*(GD4**2*GS4**2+3*GD4*GD5*GS4*GS5)

      CPALS  =  SR3*(GD5**2*GS4*GS5+GD4*GD5*GS5**2

     .          -GD4**2*GS4*GS5-GD4*GD5*GS4**2)

      CPASS  =  2*(3*GD4*GD5*GS4*GS5+GD5**2*GS5**2)

      CPADR  =  8*GD5**2*GS5**2

C     CROSSED:

      CCRNN  =  2*(ISFLL*GS4**2*GD4**2+ISFLS*GS4*GS5*GD4*GD5+

     .             ISFSS*GS5**2*GD5**2)

      CCRLL  =  2*(GD4*XGD12*GS4*XGS12+3*GD5*XGD12*GS5*XGS12)

      CCRLS  =  SR3*(GD4*GS4-GD5*GS5)*(XGD13*XGS12+XGD12*XGs13)

      CCRSS  = -2*GD4*XGD13*GS4*XGS13+10*GD5*XGD13*GS5*XGS13

      CCRDR  =  4*(GD5*GS5*XGD13*XGS13+GD4*GS4*XGD13*XGS13)

      CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM)

      GOTO 350

C KAPPA-POMERON EXCHANGE POTENTIALS:

   36 PEX = -P 

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GS4*GD6*GD7    

      CPALS  =  -SR3*GS4*GS5*GD6*(GD7+GD8)

      CPASS  =  -2*GS5**2*GD6*GD8 

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GS4**2*(GD6**2+GD7**2)

      CCRLS  =  -SR3*GS4*GS5*(GD6**2+GD7*GD8)

      CCRSS  =  -GS5*2*(GD6**2+GD8**2)

      CCRDR  =  -2*CCRSS

      CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM)

      GOTO 350

C S*-A2 EXCHANGE POTENTIALS:

   37 PEX = -1.D0

      M = 4

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*GS9**2*GD1**2

      CPALL  =  0.D0

      CPALS  =  -SR3*GD1*GS9*GD3*(GS10+GS11)

      CPASS  =  -4*GD1*GS9*GD2*GS11

      CPADR  =  +2*GD1*GS9*GD2*GS11

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0  

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM)

      GOTO 350

C S*-K** EXCHANGE POTENTIALS:

   38 PEX = -P   

      M = 4

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD4**2*GS9*GS10

      CPALS  =  -SR3*GD4*GD5*GS9*(GS10+GS11)

      CPASS  =  -2*GD5**2*GS9*GS11 

      CPADR  =  -2*CPASS            

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GD4**2*(GS9**2+GS10**2)

      CCRLS  =  -SR3*GD4*GD5*(GS9**2+GD10*GD11)

      CCRSS  =  -GD5**2*(GS9**2+GS11**2)

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM)

      GOTO 350

C S*-POMERON EXCHANGE POTENTIALS:

   39 PEX = -1.D0

      M = 4

      N = 3

C     PARALLEL:

      CPANN  =  2*GS9**2*GD6**2

      CPALL  =  2*GS9*GD6*GS10*GD7

      CPASS  =  2*GS9*GD6*GS11*GD8

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM)

      GOTO 350

C EPSILON-POMERON EXCHANGE POTENTIALS:

   40 PEX = -1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  2*GS6**2*GD6**2

      CPALL  =  2*GS6*GD6*GS7*GD7

      CPASS  =  2*GS6*GD6*GS8*GD8

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      HNONC = 0.D0

      DO 241 JJ=1,2

      CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM)

c     CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM)

  241 HNONC = HNONC + ASIG(JJ)*FNONC

      FNONC = HNONC

      GOTO 350

C EPSILON-A2 EXCHANGE POTENTIALS:

   41 PEX = -1.D0

      M = 3

      N = 1

C     PARALLEL:

      CPANN  =  2*ISFAC*GS6**2*GD1**2

      CPALL  =  0.D0

      CPALS  =  -SR3*GD1*GS6*GD3*(GS7+GS8)

      CPASS  =  -4*GD1*GS6*GD2*GS8

      CPADR  =  +2*GD1*GS6*GD2*GS8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      HNONC = 0.D0

      DO 341 JJ=1,2

      CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM)

c     CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM)

  341 HNONC = HNONC + ASIG(JJ)*FNONC

      FNONC = HNONC

      GOTO 350

C EPSILON-K** EXCHANGE POTENTIALS:

   42 PEX = -P   

      M = 3

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD4**2*GS6*GS7

      CPALS  =  -SR3*GD4*GD5*GS6*(GS7+GS8)

      CPASS  =  -2*GD5**2*GS6*GS8 

      CPADR  =  -2*CPASS            

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  GD4**2*(GS6**2+GS7**2)

      CCRLS  =  -SR3*GD4*GD5*(GS6**2+GD7*GD8)

      CCRSS  =  -GD5**2*(GS6**2+GS8**2)

      CCRDR  =  CPADR

      HNONC = 0.D0

      DO 441 JJ=1,2

      CALL FOOM(5,X,AMSIG(JJ),AMPOM,ALMS1,AMPOM)

c     CALL FOOM(5,X,AMEPS,AMPOM,ALMS1,AMPOM)

  441 HNONC = HNONC + ASIG(JJ)*FNONC

      FNONC = HNONC

      GOTO 350

  350 VCLL  =   VCLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX

      VCLS  =   VCLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX

      VCSS  =   VCSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX

      VCDR  =   VCDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX



      VSCDF(1,1,M,N)=VSCDF(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX

      VSCDF(2,1,M,N)=VSCDF(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX

      VSCDF(3,1,M,N)=VSCDF(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX

      VSCDF(4,1,M,N)=VSCDF(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX

      VSCDF(5,1,M,N)=VSCDF(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX

  300 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(6,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wromtm(6,x,p)

C

C **************************************************************

C     DOUBLE DIFFRACTIVE CONTRIBUTIONS:

C **************************************************************

C

      DO 400 II=1,6  

      CPALS = 0.D0

      CCRLS = 0.D0

      GOTO(44,54,64,74,84,94), II            

C POMERON-POMERON EXCHANGE POTENTIALS:

   44 PEX = +1.D0

      M = 3

      N = 3

C     PARALLEL:

      CPANN  =  GD6**2*GD6**2

      CPALL  =  GD6**2*GD7**2

      CPASS  =  GD6**2*GD8**2

      CPADR  =  CPASS

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  CPALL

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450

C POMERON-A2 EXCHANGE POTENTIALS:

   54 PEX = +1.D0

      M = 1

      N = 3

C     PARALLEL:

      CPANN  =  2*ISFAC*GD6**2*GD1**2

      CPALL  =  0.D0

      CPALS  =  -SR3*GD1*GD6*GD3*(GD7+GD8)

      CPASS  =  -4*GD1*GD6*GD2*GD8

      CPADR  =  +2*GD1*GD6*GD2*GD8

C     CROSSED:

      CCRNN  =  CPANN

      CCRLL  =  0.D0

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450

C POMERON-K** EXCHANGE POTENTIALS:

   64 PEX = +P

      M = 2

      N = 3

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  2*GD6*GD7*GD4**2

      CPALS  =  -SR3*GD6*(GD7+GD8)*GD4*GD5

      CPASS  =  -2*GD6*GD8*GD5**2

      CPADR  =  -2*CPASS

C     CROSSED:

      CCRNN  =  0.D0

      CCRLS  =  CPALS

      CCRSS  =  CPASS

      CCRDR  =  CPADR

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450

C A2-A2 EXCHANGE POTENTIALS:

   74 PEX = +1.D0

      M = 1

      N = 1

C     PARALLEL:

      CPANN  =  1*(3-2*ISFAC)*GD1**2*GD1**2

      CPALL  =  3*GD1**2*GD3**2

      CPALS  =  2*SR3*GD1**2*GD3*GD2

      CPASS  =  GD1**2*(3*GD3**2+4*GD2**2)

      CPADR  =  GD1**2*GD2**2

C     CROSSED:

      CCRNN  =  1*(3+2*ISFAC)*GD1**2*GD1**2

      CCRLL  =  CPALL

      CCRLS  =  -CPALS

      CCRSS  =  -GD1**2*GD2**2

      CCRDR  =  GD1**2*(2*GD3**2+2*GD2**2)

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450

C A2-K** EXCHANGE POTENTIALS:

   84 PEX = +P

      M = 1

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  6*GD1*GD4*GD3*GD5

      CPALS  =  -SR3*GD1*GD3*(GD4**2-GD5**2)

     .          +2*SR3*GD1*GD2*GD4*GD5

      CPASS  =  GD1*GD5*(6*GD3*GD4+4*GD2*GD5)

      CPADR  =  +4*GD1*GD2*GD5**2

C     CROSSED:

      CCRNN  =  0.D0

      CCRLL  =  3*(GD1**2*GD4**2+GD3**2*GD5**2)

      CCRLS  =  SR3*GD4*GD5*(GD1**2-GD3**2)

     .          +2*SR3*GD2*GD3*GD5**2

      CCRSS  =  5*GD1**2*GD5**2+GD3**2*GD4**2

     .          +4*GD2*GD3*GD4*GD5

      CCRDR  =  2*GD1**2*GD5**2+GD3**2*GD4**2

     .          +3*GD2**2*GD5**2-2*GD2*GD3*GD4*GD5

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450

C K**-K** EXCHANGE POTENTIALS:

   94 PEX = +1.D0

      M = 2

      N = 2

C     PARALLEL:

      CPANN  =  0.D0

      CPALL  =  (GD4**2+3*GD5**2)*GD4**2

      CPALS  =  SR3*(GD5**2-GD4**2)*GD4*GD5

      CPASS  =  (3*GD4**2+GD5**2)*GD5**2

      CPADR  =  +4*GD5**4

C     CROSSED:

      CCRNN  =  1*(ISFLL*GD4**2*GD4**2+ISFLS*GD4*GD5*GD4*GD5+

     .             ISFSS*GD5**2*GD5**2)

      CCRLL  =  (GD4**2*XGD12**2+3*GD5**2*XGD12**2)

      CCRLS  =  SR3*(GD4**2-GD5**2)*(XGD13*XGD12)

      CCRSS  =  -1*GD4**2*XGD13**2+5*GD5**2*XGD13**2

      CCRDR  =  2*(GD5*GD5*XGD13*XGD13+GD4*GD4*XGD13*XGD13)

      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)

      GOTO 450



  450 VCLL  =   VSLL - FACT*( CPALL-2*CCRLL )*FNONC*PEX

      VCLS  =   VSLS - FACT*( CPALS-2*CCRLS )*FNONC*PEX

      VCSS  =   VSSS - FACT*( CPASS-2*CCRSS )*FNONC*PEX

      VCDR  =   VSDR - FACT*( CPADR-2*CCRDR )*FNONC*PEX



      VDFDF(1,1,M,N)=VDFDF(1,1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX

      VDFDF(2,1,M,N)=VDFDF(2,1,M,N)-FACT*(CPALL-2*CCRLL)*FNONC*PEX

      VDFDF(3,1,M,N)=VDFDF(3,1,M,N)-FACT*(CPALS-2*CCRLS)*FNONC*PEX

      VDfDF(4,1,M,N)=VDFDF(4,1,M,N)-FACT*(CPASS-2*CCRSS)*FNONC*PEX

      VDFDF(5,1,M,N)=VDFDF(5,1,M,N)-FACT*(CPADR-2*CCRDr)*FNONC*PEX

  400 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wromtm(7,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wromtm(7,x,p)

      ENDIF

C     END DOUBLE SCALAR/DIFFRACTIVE EXCHANGE



1000  CALL ERRSET(208,256,1,1)

      ICALL = ICALL + 1

      RETURN

C END OMSCDF ROUTINE ***************************************************

      END

C **********************************************************************

      SUBROUTINE OMPAIR(X,INA,IPV,APV)

C **********************************************************************

C *

C *   DATE AUGUST 1995

C

C *   PHENOMENOLOGICAL PION-MESON PAIR YN-POTENTIALS

C     CALLED BY SUBROUTINE YNPAIR.FORTRAN

C *

C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX

C

C     IN COUPLING COMBINATIONS CENLL1 ETC.:

C     (i) YNCCPR: L+R contributions included,

C     (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams)

C

C     PISI and PIRO1 A LA paper II

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/PRMTRS/ PAR(20,8)

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR                     

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,GDA(11)

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA          ! MARCH 2009

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI

     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV

     .,IKKB0,IKKB1,IPIA1,IOMETA                  ! MARCH 2009

C

      DIMENSION WGHTID(2)

C

C     COMMUNICATION WITH ROUTINE YNPAIRS:

      COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10),

     .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10)  ,CCPR7(3,10),

     .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10),

     .CCPR11(4,10),CCPR11F(4,10)                 ! MARCH 2009



C     COMMUNICATION WITH ROUTINE WROMPR:

      COMMON/PROMPR/VPRA(5,3,4,4),VPRB(5,3,4,4),VPRC(5,3,4,4),

     .              VPRD(5,3,4,4),VPRE(5,3,4,4),VPRF(5,3,4,4)



c     COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5,

c    .              VALL1,VALL2,VALL3,VALL4,VALL5



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/

c*    DATA FACID/0.5D0/,SR2/1.4142136D0/,SR3/1.732051D0/,NSCHR/0/ ! was voor su3-check

      DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,NSCHR/0/ ! na su3-checK 2008

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,

     .     AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/

      SAVE FACT,AMN,DAM,AA,AMB

c     SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7

C

cc    CALL ERRSET(208,256,-1,1)



      pim=pim0

      IF(ICALL.EQ.0) THEN

        FACT  = PIM0

c       AMB  = 2*AMNN*AMH/(AMNN+AMH)

        AMB  = AMPRO

        FACT = FACT*(PIM0/AMB)/4.D0

        IF(NSCHR.NE.0) PRINT 52, INA,IPV,PIM,AMB

   52   FORMAT(//,'  IN OMPAIR: INA, IPV=',2I3,' PIM=',F7.3,

     .  ' AMB=',F10.3,/)

c       ICALL=1

      ENDIF

C

C     WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING

C     THV = 37.5D0*PI/180.D0

      THV = PAR(10,3)*PI/180.D0

      WGHTID(1) = DSIN(THV)       

      WGHTID(2) = DCOS(THV)       



      if(p.ne.pold) then

      icall=0

      pold=p

c***  nschr=1

      nschr=0

      endif



c     IF(ICALL.EQ.0) THEN

      IF(ICALL.EQ.20.AND.NSCHR.EQ.1) THEN

        DO 250 NCHAN=1,5

        DO 250 ITYPV=1,3

        DO 250 M=1,4

        DO 250 N=1,4

        VPRA(NCHAN,ITYPV,M,N)=0.D0

        VPRB(NCHAN,ITYPV,M,N)=0.D0

        VPRC(NCHAN,ITYPV,M,N)=0.D0

        VPRD(NCHAN,ITYPV,M,N)=0.D0

        VPRE(NCHAN,ITYPV,M,N)=0.D0

  250   VPRF(NCHAN,ITYPV,M,N)=0.D0

      ENDIF

C

C     CONSTRUCTION 1/M-CORRECTIONS TO THE POTENTIALS:

C

C A)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :

C

      IF(IPIPI0.NE.0) THEN

      ITYPE=1

      DO 10 II=1,3

      GOTO(11,12,13),II



C     PI-PI(I=0):

11    CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8)

      M = 1

      GOTO 14



C     ETA-ETA:

12    CALL FOOMPR(ITYPE,X,AME,AME,ALMP8,ALMP8)

      M = 3

      GOTO 14



C     KA-KA(I=0):

13    CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA)

      M = 2

      GOTO 14



14    IF(INA.EQ.1) THEN

      VCLL     =   VCLL    - FACT*CCPR1(II,2)*FNONC        

      VCSS     =   VCSS    - FACT*CCPR1(II,4)*FNONC        

      VCDR     =   VCDR    - FACT*CCPR1(II,5)*FNONC         

      VOLL     =   VOLL    - FACT*CCPR1(II,2)*FNONO         

      VOSS     =   VOSS    - FACT*CCPR1(II,4)*FNONO         

      VODR     =   VODR    - FACT*CCPR1(II,5)*FNONO        

      VPRA(1,1,M,M)=VPRA(1,1,M,M)-FACT*CCPR1(II,1)*FNONC        

      VPRA(2,1,M,M)=VPRA(2,1,M,M)-FACT*CCPR1(II,2)*FNONC        

      VPRA(4,1,M,M)=VPRA(4,1,M,M)-FACT*CCPR1(II,4)*FNONC        

      VPRA(5,1,M,M)=VPRA(5,1,M,M)-FACT*CCPR1(II,5)*FNONC        

      ENDIF

      IF(IPV.EQ.1) THEN

      VCLL     =   VCLL    - APV*FACT*CCPR1(II,2)*FPVC        

      VCSS     =   VCSS    - APV*FACT*CCPR1(II,4)*FPVC        

      VCDR     =   VCDR    - APV*FACT*CCPR1(II,5)*FPVC        

      VOLL     =   VOLL    - APV*FACT*CCPR1(II,2)*FPVO        

      VOSS     =   VOSS    - APV*FACT*CCPR1(II,4)*FPVO        

      VODR     =   VODR    - APV*FACT*CCPR1(II,5)*FPVO        

      VPRA(1,1,M,M)=VPRA(1,1,M,M)-APV*FACT*CCPR1(II,1)*FPVC         

      VPRA(2,1,M,M)=VPRA(2,1,M,M)-APV*FACT*CCPR1(II,2)*FPVC         

      VPRA(4,1,M,M)=VPRA(4,1,M,M)-APV*FACT*CCPR1(II,4)*FPVC         

      VPRA(5,1,M,M)=VPRA(5,1,M,M)-APV*FACT*CCPR1(II,5)*FPVC         

      ENDIF

10    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wrompr(1,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wrompr(1,x,p)

      ENDIF

C

C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(IPIET.NE.0) THEN

c*    ITYPE = 5

      ITYPE = 1          ! in NN, is correct

      DO 20 II=1,10

      PEX = 1.D0

      GOTO(21,22,23,24,25,26,27,21,23,24),II

C     PI-ETA:

21    CALL FOOMPR(ITYPE,X,PIM,AME,ALMP8,ALMP8)

      IF(II.EQ.1) THEN

      M = 1

      N = 3

      ENDIF

      IF(II.EQ.8) THEN

      M = 3

      N = 1

      ENDIF

      GOTO 28



C     KA-KA(8S)(I=1):

22    CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA)

      M = 2

      N = 2

      GOTO 28



C     PI-KA(8s):

23    CALL FOOMPR(ITYPE,X,PIM,AMK,ALMP8,ALMKA)

      PEX = P

      IF(II.EQ.3) THEN

      M = 1

      N = 2

      ENDIF

      IF(II.EQ.9) THEN

      M = 2

      N = 1

      ENDIF

      GOTO 28



C     ETA-KA(8s):

24    CALL FOOMPR(ITYPE,X,AME,AMK,ALMP8,ALMKA)

      PEX = P

      IF(II.EQ.4) THEN

      M = 2

      N = 3

      ENDIF

      IF(II.EQ.10) THEN

      M = 3

      N = 2

      ENDIF

      GOTO 28



C     PI-PI(8S)(I=0):

25    CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8)

      M = 1

      N = 1

      GOTO 28



C     ETA-ETA(8s):

26    CALL FOOMPR(ITYPE,X,AME,AME,ALMP8,ALMP8)

      M = 3

      N = 3

      GOTO 28



C     KA-KA(8S)(I=0):

27    CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA)

      M = 2

      N = 2

      GOTO 28



28    IF(INA.EQ.1) THEN

      VCLL   =   VCLL    - FACT*CCPR2(II,2)*FNONC*PEX

      VCLS   =   VCLS    - FACT*CCPR2(II,3)*FNONC*PEX

      VCSS   =   VCSS    - FACT*CCPR2(II,4)*FNONC*PEX

      VCDR   =   VCDR    - FACT*CCPR2(II,5)*FNONC*PEX

      VOLL   =   VOLL    - FACT*CCPR2(II,2)*FNONO*PEX

      VOLS   =   VOLS    - FACT*CCPR2(II,3)*FNONO*PEX

      VOSS   =   VOSS    - FACT*CCPR2(II,4)*FNONO*PEX

      VODR   =   VODR    - FACT*CCPR2(II,5)*FNONO*PEX

      VPRB(1,1,M,N)=VPRB(1,1,M,N)-FACT*CCPR2(II,1)*FNONC*PEX    

      VPRB(2,1,M,N)=VPRB(2,1,M,N)-FACT*CCPR2(II,2)*FNONC*PEX    

      VPRB(3,1,M,N)=VPRB(3,1,M,N)-FACT*CCPR2(II,3)*FNONC*PEX    

      VPRB(4,1,M,N)=VPRB(4,1,M,N)-FACT*CCPR2(II,4)*FNONC*PEX    

      VPRB(5,1,M,N)=VPRB(5,1,M,N)-FACT*CCPR2(II,5)*FNONC*PEX    

      ENDIF

      IF(IPV.EQ.1) THEN

      VCLL   =   VCLL    - APV*FACT*CCPR2(II,2)*FPVC*PEX

      VCLS   =   VCLS    - APV*FACT*CCPR2(II,3)*FPVC*PEX

      VCSS   =   VCSS    - APV*FACT*CCPR2(II,4)*FPVC*PEX

      VCDR   =   VCDR    - APV*FACT*CCPR2(II,5)*FPVC*PEX

      VOLL   =   VOLL    - APV*FACT*CCPR2(II,2)*FPVO*PEX

      VOLS   =   VOLS    - APV*FACT*CCPR2(II,3)*FPVO*PEX

      VOSS   =   VOSS    - APV*FACT*CCPR2(II,4)*FPVO*PEX

      VODR   =   VODR    - APV*FACT*CCPR2(II,5)*FPVO*PEX

      VPRB(1,1,M,N)=VPRB(2,1,M,N)-APV*FACT*CCPR2(II,1)*FPVC*PEX    

      VPRB(2,1,M,N)=VPRB(2,1,M,N)-APV*FACT*CCPR2(II,2)*FPVC*PEX    

      VPRB(3,1,M,N)=VPRB(3,1,M,N)-APV*FACT*CCPR2(II,3)*FPVC*PEX    

      VPRB(4,1,M,N)=VPRB(4,1,M,N)-APV*FACT*CCPR2(II,4)*FPVC*PEX    

      VPRB(5,1,M,N)=VPRB(5,1,M,N)-APV*FACT*CCPR2(II,5)*FPVC*PEX    

      ENDIF

c     xfm=x*197.32d0/pim

c     if(xfm.ge.0.1d0.and.xfm.le.0.7d0) then

c     write(*,*) 'ompair, ii=',ii,' xfm=',xfm,' vsll=',vsll

c     endif

20    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wrompr(2,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wrompr(2,x,p)

      ENDIF



C     PI-ETA':

*     IF(IPIETP.EQ.1) THEN

*     VC    =   VC + FACT*ISFAC*GPIETP*(

*    .               2*FP*FETAP*DFI*DFIETP-0.5D0*GPIETP*FIPEP2)

*     ENDIF

C

C C)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :

C

C     NOTE: for identical mesons: FACID=1/2 is included for 1-pair's!!

C

      IF(IPIPI1.NE.0) THEN

      ITYPE = 2

c     DO 30 II=1,9

      DO 30 II=1,6

      PEX = 1.D0

      GOTO(31,32,33,34,341,35,33,34,341),II

C     PI-PI(I=1):

31    CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8)

      PEX = FACID

      M = 1

      N = 1

      GOTO 36



C     KA-KA(8A)(I=1):

32    CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA)

      PEX = FACID

      M = 2

      N = 2

      GOTO 36



C     PI-KA(8a):

33    CALL FOOMPR(ITYPE,X,PIM,AMK,ALMP8,ALMKA)

      PEX = P*2

      IF(II.EQ.3) THEN

      M = 1

      N = 2

      ENDIF

      IF(II.EQ.7) THEN

      M = 2

      N = 1

      ENDIF

      GOTO 36



C     ETA-KA(8a):

34    CALL FOOMPR(ITYPE,X,AME,AMK,ALMP8,ALMKA)

      PEX = P*2

      IF(II.EQ.4) THEN

      M = 3

      N = 2

      ENDIF

      IF(II.EQ.8) THEN

      M = 2

      N = 3

      ENDIF

      GOTO 36



C     ETAP-KA(8a):

341   CALL FOOMPR(ITYPE,X,AMX,AMK,ALMP8,ALMKA)

      PEX = P*2

      IF(II.EQ.5) THEN

      M = 4

      N = 2

      ENDIF

      IF(II.EQ.9) THEN

      M = 2

      N = 4

      ENDIF

      GOTO 36



C     KA-KA(8A)(I=0):

35    CALL FOOMPR(ITYPE,X,AMK,AMK,ALMKA,ALMKA)

      PEX = FACID

      M = 2

      N = 2

      GOTO 36



36    IF(INA.EQ.1) THEN

      VCLL   =   VCLL    - FACT*CCPRG(II,2)*FNONC*PEX

      VCLS   =   VCLS    - FACT*CCPRG(II,3)*FNONC*PEX

      VCSS   =   VCSS    - FACT*CCPRG(II,4)*FNONC*PEX

      VCDR   =   VCDR    - FACT*CCPRG(II,5)*FNONC*PEX

      VOLL   =   VOLL    - FACT*CCPRG(II,2)*FNONO*PEX

      VOLS   =   VOLS    - FACT*CCPRG(II,3)*FNONO*PEX

      VOSS   =   VOSS    - FACT*CCPRG(II,4)*FNONO*PEX

      VODR   =   VODR    - FACT*CCPRG(II,5)*FNONO*PEX

      VPRC(1,1,M,N)=VPRC(1,1,M,N)-FACT*CCPRG(II,1)*FNONC*PEX    

      VPRC(2,1,M,N)=VPRC(2,1,M,N)-FACT*CCPRG(II,2)*FNONC*PEX    

      VPRC(3,1,M,N)=VPRC(3,1,M,N)-FACT*CCPRG(II,3)*FNONC*PEX    

      VPRC(4,1,M,N)=VPRC(4,1,M,N)-FACT*CCPRG(II,4)*FNONC*PEX    

      VPRC(5,1,M,N)=VPRC(5,1,M,N)-FACT*CCPRG(II,5)*FNONC*PEX    

      ENDIF

      IF(IPV.EQ.1) THEN

      VCLL   =   VCLL    - APV*FACT*CCPRG(II,2)*FPVC*PEX

      VCLS   =   VCLS    - APV*FACT*CCPRG(II,3)*FPVC*PEX

      VCSS   =   VCSS    - APV*FACT*CCPRG(II,4)*FPVC*PEX

      VCDR   =   VCDR    - APV*FACT*CCPRG(II,5)*FPVC*PEX

      VOLL   =   VOLL    - APV*FACT*CCPRG(II,2)*FPVO*PEX

      VOLS   =   VOLS    - APV*FACT*CCPRG(II,3)*FPVO*PEX

      VOSS   =   VOSS    - APV*FACT*CCPRG(II,4)*FPVO*PEX

      VODR   =   VODR    - APV*FACT*CCPRG(II,5)*FPVO*PEX

      VPRC(1,1,M,N)=VPRC(1,1,M,N)-APV*FACT*CCPRG(II,1)*FPVC*PEX    

      VPRC(2,1,M,N)=VPRC(2,1,M,N)-APV*FACT*CCPRG(II,2)*FPVC*PEX    

      VPRC(3,1,M,N)=VPRC(3,1,M,N)-APV*FACT*CCPRG(II,3)*FPVC*PEX    

      VPRC(4,1,M,N)=VPRC(4,1,M,N)-APV*FACT*CCPRG(II,4)*FPVC*PEX    

      VPRC(5,1,M,N)=VPRC(5,1,M,N)-APV*FACT*CCPRG(II,5)*FPVC*PEX    

      ENDIF

30    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wrompr(3,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wrompr(3,x,p)

      ENDIF

C

C 3)  AXIAL PAIR TERMS OF THE FIRST CLASS:

C

c     ITYPE=3

c     NO EXTRA 1/M-CORRECTIONS (ADIABATIC TERMS ARE 1/M!)

c     IF(GPIRO1.NE.0.D0) THEN

c     ENDIF



C

C 4)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

c     ITYPE=4

c     NOT INCLUDED IN YNPAIRS

c     IF(IPIRO0.EQ.1) THEN

c     ENDIF

C

C------------------------------------------------------------

C 5)  AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :

c     INCLUDED IN YNOOM DEC.06

C------------------------------------------------------------

C     HERE: ETA8 = ETA(548) (THPS IS SMALL), 

C           PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019)

C------------------------------------------------------------

      IF(IPIOM.EQ.2) THEN

      ITYPE=5

      DO 90 II=1,13

      PEX = 1.D0

      GOTO(91,911,92,93,94,95,96,97,971,98,981,991,992),II



C     PI-OMEGA  

91    CALL FOOMPR(ITYPE,X,PIM,AMOM,ALMP8,ALMV1)

      FPVS = FPVS*WGHTID(1)

      FPVT = FPVT*WGHTID(1)

      GOTO 990

C     PI-PHI:   

911   CALL FOOMPR(ITYPE,X,PIM,AMFI,ALMP8,ALMV8)

      FPVS = FPVS*WGHTID(2)

      FPVT = FPVT*WGHTID(2)

c     IMES1 = 1

c     IMES2 = 3

      GOTO 990



C     ETA-RHO:   

92    CALL FOOMPR(ITYPE,X,AME,AMRO,ALMP8,ALMV8)             

c     IMES1 = 3

c     IMES2 = 1

      GOTO 990



C     KA-K*(8S)(I=1):

93    CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8)             

c     IMES1 = 2

c     IMES2 = 2

      GOTO 990



C     PI-K*(8S):

94    CALL FOOMPR(ITYPE,X,PIM,AMKS,ALMP8,ALMV8)             

c     IMES1 = 1

c     IMES2 = 2

      PEX = P

      GOTO 990



C     KA-RHO(8S)(I=1):

95    CALL FOOMPR(ITYPE,X,AMK,AMRO,ALMP8,ALMV8)             

c     IMES1 = 2

c     IMES2 = 1

      PEX = P

      GOTO 990



C     ETA-K*:    

96    CALL FOOMPR(ITYPE,X,AME,AMKS,ALMP8,ALMV8)             

c     IMES1 = 3

c     IMES2 = 2

      PEX = P

      GOTO 990



C     KA-PHI8:  

C     KA-OMEGA:

97    CALL FOOMPR(ITYPE,X,AMK,AMOM,ALMP8,ALMV8)             

      FPVS = FPVS*WGHTID(1)

      FPVT = FPVT*WGHTID(1)

      PEX = P

      GOTO 990



C     KA-PHI:   

971   CALL FOOMPR(ITYPE,X,AMK,AMFI,ALMP8,ALMV8)             

      FPVS = FPVS*WGHTID(2)

      FPVT = FPVT*WGHTID(2)

c     IMES1 = 2

c     IMES2 = 3

      PEX = P

      GOTO 990



C     PI-RHO(8S)(I=0):

98    CALL FOOMPR(ITYPE,X,PIM,AMRO,ALMP8,ALMV8)             

c     IMES1 = 1

c     IMES2 = 1

      GOTO 990



C     KA-K*(8S)(I=0):

981   CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8)             

c     IMES1 = 2

c     IMES2 = 2

      GOTO 990



C     ETA-OMEGA(8s):

991   CALL FOOMPR(ITYPE,X,AME,AMOM,ALMP8,ALMV1)             

      FPVS = FPVS*WGHTID(1)

      FPVT = FPVT*WGHTID(1)

      GOTO 990



C     ETA-PHI(8s):

992   CALL FOOMPR(ITYPE,X,AME,AMFI,ALMP8,ALMV8)             

      FPVS = FPVS*WGHTID(2)

      FPVT = FPVT*WGHTID(2)

c     IMES1 = 3

c     IMES2 = 3

      GOTO 990



990   CONTINUE          

c*    question: factor 4, is that right? yes!

c*    UFAC1=4.D0/8.D0  ! old

      UFAC1=1.D0       !  new (check) !!

      UFAC1=2.D0       !  -> the correct factor!

      UFAC1=4.D0       !  -> factor 2 overshoot, a la NN-program!

c     if(icall.eq.0) write(6,*) ' ynoom.f/ompair: UFAC1=',UFAC1

c     VSNN   =   VSNN  + PEX*APV*FACT*CCPR10(II,1)*FPVS*1/3.D0

c    .*UFAC1

      VSLL   =   VSLL  + PEX*APV*FACT*CCPR10(II,2)*FPVS*1/3.D0

     .*UFAC1

      VSLS   =   VSLS  + PEX*APV*FACT*CCPR10(II,3)*FPVS*1/3.D0

     .*UFAC1

      VSSS   =   VSSS  + PEX*APV*FACT*CCPR10(II,4)*FPVS*1/3.D0

     .*UFAC1

      VSDR   =   VSDR  + PEX*APV*FACT*CCPR10(II,5)*FPVS*1/3.D0

     .*UFAC1



c*    VTNN   =   VTNN  + PEX*APV*FACT*CCPR10(II,1)*FPVT*1/3.D0

c    .*UFAC1

      VTLL   =   VTLL  + PEX*APV*FACT*CCPR10(II,2)*FPVT*1/3.D0

     .*UFAC1

      VTLS   =   VTLS  + PEX*APV*FACT*CCPR10(II,3)*FPVT*1/3.D0

     .*UFAC1

      VTSS   =   VTSS  + PEX*APV*FACT*CCPR10(II,4)*FPVT*1/3.D0

     .*UFAC1

      VTDR   =   VTDR  + PEX*APV*FACT*CCPR10(II,5)*FPVT*1/3.D0

     .*UFAC1



c------------------------------------------------------------

      if(ii.eq.1) then

      dvsnn=0.d0

      dvsll=0.d0

      dvsls=0.d0

      dvsss=0.d0

      dvsdr=0.d0

      dvtnn=0.d0

      dvtll=0.d0

      dvtls=0.d0

      dvtss=0.d0

      dvtdr=0.d0

      endif

      DVSNN = DVSNN+ 2*PEX*APV*FACT*CCPR10(II,1)*FPVS*1/6.D0

      DVSLL = DVSLl+ 2*PEX*APV*FACT*CCPR10(II,2)*FPVS*1/6.D0

      DVSLS = DVSLS+ 2*PEX*APV*FACT*CCPR10(II,3)*FPVS*1/6.D0

      DVSSS = DVSSS+ 2*PEX*APV*FACT*CCPR10(II,4)*FPVS*1/6.D0

      DVSDR = DVSDR+ 2*PEX*APV*FACT*CCPR10(II,5)*FPVS*1/6.D0



      DVTNN = DVTNN+ 2*PEX*APV*FACT*CCPR10(II,1)*FPVT*1/6.D0

      DVTLL = DVTLL+ 2*PEX*APV*FACT*CCPR10(II,2)*FPVT*1/6.D0

      DVTLS = DVTLS+ 2*PEX*APV*FACT*CCPR10(II,3)*FPVT*1/6.D0

      DVTSS = DVTSS+ 2*PEX*APV*FACT*CCPR10(II,4)*FPVT*1/6.D0

      DVTDR = DVTDR+ 2*PEX*APV*FACT*CCPR10(II,5)*FPVT*1/6.D0

c     xfm=x*197.32d0/pim

c     if(xfm.ge.0.1d0.and.xfm.le.0.7d0) then

c     write(*,*) 'ompair, ii=',ii,' xfm=',xfm,' vsll=',vsll

c     if(ii.eq.13) then

c     write(*,*) 'ompair, ii=',ii,' xfm=',xfm

c     write(*,*) ' dvsnn,dvsll,dvsls,dvsss,dvsdr=', 

c    .             dvsnn,dvsll,dvsls,dvsss,dvsdr

c     write(*,*) ' dvtnn,dvtll,dvtls,dvtss,dvtdr=', 

c    .             dvtnn,dvtll,dvtls,dvtss,dvtdr

c     write(*,1313) xfm,dvsdr,dvsll,dvtdr,dvtll

1313  format('YNPRS,PIOM: xfm=',f5.2,' dvsdr=',f8.2,' dvsll=',f8.2,

     .' dvtdr=',f7.2,' dvtll=',f7.2,/)

c     endif

c     endif

c------------------------------------------------------------



90    CONTINUE

      ENDIF

C------------------------------------------------------------

C

C 6)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:

      IF(IPISI.NE.0) THEN

      ITYPE = 6

      DO 50 II=1,6

      PEX = 1.D0

      GOTO(51,51,51,54,55,56),II



C     PI-EPSILON:

C     KA-EPSILON:

C     ETA-EPSILON:



51    HNONS = 0.D0

      HNONT = 0.D0

      HPVS  = 0.D0

      HPVT  = 0.D0

      DO 510 JJ=1,2

      IF(II.EQ.1) CALL FOOMPR(ITYPE,X,PIM,AMSIG(JJ),ALMP8,ALMS1)

      IF(II.EQ.2) CALL FOOMPR(ITYPE,X,AMK,AMSIG(JJ),ALMKA,ALMS1)

      IF(II.EQ.3) CALL FOOMPR(ITYPE,X,AME,AMSIG(JJ),ALMP8,ALMS1)

      HNONS = HNONS + ASIG(JJ)*FNONS

      HNONT = HNONT + ASIG(JJ)*FNONT

      HPVS  = HPVS  + ASIG(JJ)*FPVS

510   HPVT  = HPVT  + ASIG(JJ)*FPVT

      FNONS = HNONS

      FNONT = HNONT

      FPVS  = HPVS

      FPVT  = HPVT

      IF(II.EQ.2) PEX = P

      M = II

      N = 4

      GOTO 57



C     PI-SSTAR:

54    CALL FOOMPR(ITYPE,X,PIM,AMSST,ALMP8,ALMS8)

      M = 1 

      N = 3

      GOTO 57



C     KA-SSTAR:

55    CALL FOOMPR(ITYPE,X,AMK,AMSST,ALMKA,ALMS8)

      PEX = P

      M = 2 

      N = 3

      GOTO 57



C     ETA-SSTAR:

56    CALL FOOMPR(ITYPE,X,AME,AMSST,ALMP8,ALMS8)

      M = 3 

      N = 3

      GOTO 57



57    IF(INA.EQ.1) THEN

      VSLL   =   VSLL    - FACT*CCPR5(II,2)*FNONS*PEX/3.D0

      VSLS   =   VSLS    - FACT*CCPR5(II,3)*FNONS*PEX/3.D0

      VSSS   =   VSSS    - FACT*CCPR5(II,4)*FNONS*PEX/3.D0

      VSDR   =   VSDR    - FACT*CCPR5(II,5)*FNONS*PEX/3.D0

      VTLL   =   VTLL    - FACT*CCPR5(II,2)*FNONT*PEX/3.D0

      VTLS   =   VTLS    - FACT*CCPR5(II,3)*FNONT*PEX/3.D0

      VTSS   =   VTSS    - FACT*CCPR5(II,4)*FNONT*PEX/3.D0

      VTDR   =   VTDR    - FACT*CCPR5(II,5)*FNONT*PEX/3.D0

      VPRE(1,2,M,N)=VPRE(1,2,M,N)-FACT*CCPR5(II,1)*FNONS*PEX/3.D0

      VPRE(2,2,M,N)=VPRE(2,2,M,N)-FACT*CCPR5(II,2)*FNONS*PEX/3.D0

      VPRE(3,2,M,N)=VPRE(3,2,M,N)-FACT*CCPR5(II,3)*FNONS*PEX/3.D0

      VPRE(4,2,M,N)=VPRE(4,2,M,N)-FACT*CCPR5(II,4)*FNONS*PEX/3.D0

      VPRE(5,2,M,N)=VPRE(5,2,M,N)-FACT*CCPR5(II,5)*FNONS*PEX/3.D0

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL   =   VSLL    + APV*FACT*CCPR5(II,2)*FPVS*PEX/3.D0

      VSLS   =   VSLS    + APV*FACT*CCPR5(II,3)*FPVS*PEX/3.D0

      VSSS   =   VSSS    + APV*FACT*CCPR5(II,4)*FPVS*PEX/3.D0

      VSDR   =   VSDR    + APV*FACT*CCPR5(II,5)*FPVS*PEX/3.D0

      VTLL   =   VTLL    + APV*FACT*CCPR5(II,2)*FPVT*PEX/3.D0

      VTLS   =   VTLS    + APV*FACT*CCPR5(II,3)*FPVT*PEX/3.D0

      VTSS   =   VTSS    + APV*FACT*CCPR5(II,4)*FPVT*PEX/3.D0

      VTDR   =   VTDR    + APV*FACT*CCPR5(II,5)*FPVT*PEX/3.D0

      VPRE(1,2,M,N)=VPRE(1,2,M,N)+APV*FACT*CCPR5(II,1)*FPVS*PEX/3.D0

      VPRE(2,2,M,N)=VPRE(2,2,M,N)+APV*FACT*CCPR5(II,2)*FPVS*PEX/3.D0

      VPRE(3,2,M,N)=VPRE(3,2,M,N)+APV*FACT*CCPR5(II,3)*FPVS*PEX/3.D0

      VPRE(4,2,M,N)=VPRE(4,2,M,N)+APV*FACT*CCPR5(II,4)*FPVS*PEX/3.D0

      VPRE(5,2,M,N)=VPRE(5,2,M,N)+APV*FACT*CCPR5(II,5)*FPVS*PEX/3.D0

      ENDIF

50    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wrompr(5,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wrompr(5,x,p)

      ENDIF

C

C     PSEUDO SCALAR (PS-POMERON) PAIR TERMS:

      IF(IPIPOM.NE.0) THEN

      ITYPE = 7

      DO 70 II=1,3

      PEX = 1.D0

      GOTO(71,72,73),II



C     PI-POMERON:

71    CALL FOOMPR(ITYPE,X,PIM,AMPOM,ALMP8,AMPOM)

      M = 1

      N = 4

      GOTO 74



C     KA-POMERON:

72    CALL FOOMPR(ITYPE,X,AMK,AMPOM,ALMKA,AMPOM)

      PEX = P

      M = 2

      N = 4

      GOTO 74



C     ETA-POMERON:

73    CALL FOOMPR(ITYPE,X,AME,AMPOM,ALMP8,AMPOM)

      M = 3

      N = 4

      GOTO 74



74    IF(INA.EQ.1) THEN

      VSLL   =   VSLL    + FACT*CCPR7(II,2)*FNONS*PEX/3.D0

      VSLS   =   VSLS    + FACT*CCPR7(II,3)*FNONS*PEX/3.D0

      VSSS   =   VSSS    + FACT*CCPR7(II,4)*FNONS*PEX/3.D0

      VSDR   =   VSDR    + FACT*CCPR7(II,5)*FNONS*PEX/3.D0

      VTLL   =   VTLL    + FACT*CCPR7(II,2)*FNONT*PEX/3.D0

      VTLS   =   VTLS    + FACT*CCPR7(II,3)*FNONT*PEX/3.D0

      VTSS   =   VTSS    + FACT*CCPR7(II,4)*FNONT*PEX/3.D0

      VTDR   =   VTDR    + FACT*CCPR7(II,5)*FNONT*PEX/3.D0

      VPRF(1,2,M,N)=VPRF(1,2,M,N)+FACT*CCPR7(II,1)*FNONS*PEX/3.D0

      VPRF(2,2,M,N)=VPRF(2,2,M,N)+FACT*CCPR7(II,2)*FNONS*PEX/3.D0

      VPRF(3,2,M,N)=VPRF(3,2,M,N)+FACT*CCPR7(II,3)*FNONS*PEX/3.D0

      VPRF(4,2,M,N)=VPRF(4,2,M,N)+FACT*CCPR7(II,4)*FNONS*PEX/3.D0

      VPRF(5,2,M,N)=VPRF(5,2,M,N)+FACT*CCPR7(II,5)*FNONS*PEX/3.D0

      ENDIF

      IF(IPV.EQ.1) THEN

      VSLL   =   VSLL    - APV*FACT*CCPR7(II,2)*FPVS*PEX/3.D0

      VSLS   =   VSLS    - APV*FACT*CCPR7(II,3)*FPVS*PEX/3.D0

      VSSS   =   VSSS    - APV*FACT*CCPR7(II,4)*FPVS*PEX/3.D0

      VSDR   =   VSDR    - APV*FACT*CCPR7(II,5)*FPVS*PEX/3.D0

      VTLL   =   VTLL    - APV*FACT*CCPR7(II,2)*FPVT*PEX/3.D0

      VTLS   =   VTLS    - APV*FACT*CCPR7(II,3)*FPVT*PEX/3.D0

      VTSS   =   VTSS    - APV*FACT*CCPR7(II,4)*FPVT*PEX/3.D0

      VTDR   =   VTDR    - APV*FACT*CCPR7(II,5)*FPVT*PEX/3.D0

      VPRF(1,2,M,N)=VPRF(1,2,M,N)-APV*FACT*CCPR7(II,1)*FPVS*PEX/3.D0

      VPRF(2,2,M,N)=VPRF(2,2,M,N)-APV*FACT*CCPR7(II,2)*FPVS*PEX/3.D0

      VPRF(3,2,M,N)=VPRF(3,2,M,N)-APV*FACT*CCPR7(II,3)*FPVS*PEX/3.D0

      VPRF(4,2,M,N)=VPRF(4,2,M,N)-APV*FACT*CCPR7(II,4)*FPVS*PEX/3.D0

      VPRF(5,2,M,N)=VPRF(5,2,M,N)-APV*FACT*CCPR7(II,5)*FPVS*PEX/3.D0

      ENDIF

70    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call wrompr(6,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call wrompr(6,x,p)

      ENDIF

C

C D)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :

C



C 7)  SCALAR (EPSILON-EPSILON) PAIR TERMS:

      IF(ISISI.NE.0) THEN

      ITYPE = 8

C     EPSILON-EPSILON:

c     if(icall.eq.0.and.nschr.eq.1) then

c     if(icall.eq.20.and.nschr.eq.1) then

c     vprgnn = 0.d0

c     vprgll = 0.d0

c     vprgls = 0.d0

c     vprgss = 0.d0

c     vprgdr = 0.d0

c     endif

      DO 710 JJ=1,2

      DO 710 KK=1,2

      CALL FOOMPR(ITYPE,X,AMSIG(JJ),AMSIG(KK),ALMS1,ALMS1)

      AJK = ASIG(JJ)*ASIG(KK)



      IF(INA.EQ.1) THEN

      VCLL    = VCLL    -AJK*FACT*CCPR6(2)*FNONC

      VCSS    = VCSS    -AJK*FACT*CCPR6(4)*FNONC

      VCDR    = VCDR    -AJK*FACT*CCPR6(5)*FNONC

      ENDIF

c     if(icall.eq.0.and.nschr.eq.1) then                 

c*    if(icall.eq.20.and.nschr.eq.1) then

c     VPRGNN  = VPRGNN  -AJK*FACT*CCPR6(1)*FNONC

c     VPRGLL  = VPRGLL  -AJK*FACT*CCPR6(2)*FNONC

c     VPRGLS  = VPRGLS  -AJK*FACT*CCPR6(3)*FNONC

c     VPRGSS  = VPRGSS  -AJK*FACT*CCPR6(4)*FNONC

c     VPRGDR  = VPRGDR  -AJK*FACT*CCPR6(5)*FNONC

c*    endif

  710 CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) then                 

c*    if(icall.eq.-20.and.nschr.eq.1) then

c     write(*,*) ' OMPAIR: EPSILON-EPSILON:'

c     write(*,*) ' ccpr6=',ccpr6                 

c     write(*,*) ' VCNN=',vprgnn,' VCDR=',vprgdr

c     write(*,*) ' VCLL=',vprgll,' VCLS=',vprgls,' VCSS=',vprgss

c     endif

      ENDIF

C

C 8)  VECTOR (PION-A1) PAIR TERMS:

C

c     IF(IPIA1.EQ.1) THEN

c     ENDIF

C

CC



1000  CALL ERRSET(208,256,1,1)

        ICALL=ICALL+1

      RETURN

      END

C **********************************************************************

      SUBROUTINE FOOM(ITYP,X,AM1,AM2,ALM1,ALM2)

C **********************************************************************

C

C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO PS-EXCHANGE

C

C     ITYP = 1 : PS-PS, ITYP = 2 : PS-VCT, ITYP = 3 : PS-SCA,

C     ITYP = 4 : PS-DIF

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

CC

      DO 1 IMES=1,2

      IF(IMES.EQ.1) THEN

      AMES = AM1

      ALAM = ALM1

      ENDIF

      IF(IMES.EQ.2) THEN

      AMES = AM2

      ALAM = ALM2

      ENDIF

C     NORMAL (I.E. NON-DIFFRACTIVE) CASE:

      IF(ALAM.NE.AMES) THEN

      RATP =PIM/ALAM

      RATPM=PIM/AMES

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)

      DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)

      D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA)



      XA   =X*AMES/PIM

      RATA =AMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA   =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA   =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA  =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA

      DHIA  =-(AMES/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

      D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3



      F4A   = 0.5D0*(PIM/AMES)*X*HIA

      DF4A  = 0.5D0*(PIM/AMES)*(HIA+X*DHIA)

      DDF4A = 0.5D0*(PIM/AMES)*(2*DHIA+X*DDHIA)

      D3F4A  = 0.5D0*(PIM/AMES)*(3*DDHIA+X*D3HIA)

C     NAIVELY:

C     F4A   = 0.5D0*RATPM*(X*HIA -2*RATA**2*FIA)

C     DF4A  = 0.5D0*RATPM*(HIA+X*DHIA -2*RATA**2*DFIA*RATPM)

C     DDF4A = 0.5D0*RATPM*(2*DHIA+X*DDHIA -2*RATA**2*DDFIA*RATPM)

C     D3F4A  = 0.5D0*RATPM*(3*DDHIA+X*D3HIA -2*RATA**2*D3FIA*RATPM)

      ENDIF

C     DIFFRACTIVE CASE:

      IF(ALAM.EQ.AMES) THEN

      AMPOM = AMES

      RATD  = 0.5D0*PIM/AMPOM

      XPOM = X*AMPOM/PIM

      FIPO = (4.D0/SRPI)*(AMPOM/PIM)*(AMPOM/AMPRO)**2*

     .       FDEXP(-XPOM*XPOM)

      DFIPO = -2*(AMPOM/PIM)*XPOM*FIPO

      DDFIPO= -2*(AMPOM/PIM)*(XPOM*DFIPO + FIPO*AMPOM/PIM)

      D3FIPO= -2*(AMPOM/PIM)*(XPOM*DDFIPO + 2*DFIPO*AMPOM/PIM)

      FIA  = FIPO

      DFIA = DFIPO

      DDFIA= DDFIPO

      D3FIA= D3FIPO

      F4A  = FIA*RATD**2

      DF4A = DFIA*RATD**2

      DDF4A= DDFIA*RATD**2

      D3F4A= D3FIA*RATD**2

      ENDIF

      IF(IMES.EQ.1) THEN

C     N=2:

C     F2 = FIA

      DF2 = DFIA

      DDF2 = DDFIA

      D3F2 = D3FIA

C     N=4:

C     F4 = F4A

      DF4 = DF4A

      DDF4 = DDF4A

      D3F4  = D3F4A

      DVKU1  = DVKUA*(ALAM/PIM)**2

      ENDIF

      IF(IMES.EQ.2) THEN

C     N=2:

      DG2 = DFIA

      DDG2 = DDFIA

      D3G2 = D3FIA

C     N=4:

C     G4 = F4A

      DG4 = DF4A

      DDG4 = DDF4A

      D3G4  = D3F4A

      DVKU2  = DVKUA*(ALAM/PIM)**2

      ENDIF

    1 CONTINUE

C

C     CONSTRUCTION BASE FUNCTIONS

C

      GOTO(100,200,200,200,500), ITYP



  100 FNONC = +0.5D0*(

     .         6*X2*(DDF4-X1*DF4)*(DDG2-X1*DG2)+D3F4*D3G2

     .        +6*X2*(DDG4-X1*DG4)*(DDF2-X1*DF2)+D3G4*D3F2 )

      FNONS = -(1.D0/3.D0)*(

     .  X2*(DDF4-X1*DF4-X*D3F4)*(DDG2-X1*DG2-X*D3G2)-D3F4*D3G2

     . +X2*(DDG4-X1*DG4-X*D3G4)*(DDF2-X1*DF2-X*D3F2)-D3G4*D3F2 )

      FNONT = +(1.D0/6.D0)*(

     .        4*X2*(DDF4-X1*DF4-X*D3F4/4)*(DDG2-X1*DG2-X*D3G2/4)

     .       +4*X2*(DDG4-X1*DG4-X*D3G4/4)*(DDF2-X1*DF2-X*D3F2/4)

     .       -D3F4*D3G2/4-D3G4*D3F2/4    )

      FNONO =  -2*X2*( (DDF4-X1*DF4)*(DDG2-X1*DG2)

     .                +(DDF2-X1*DF2)*(DDG4-X1*DG4) )



      FPVC  = +( (-2*X2*DF2+2*X1*DDF2+D3F2)*DG2

     .                    +(-2*X2*DG2+2*X1*DDG2+D3G2)*DF2 )

      FPVO  = +(2*X1*(DF2*DDG2+DDF2*DG2)+4*X2*DF2*DG2)



      FOFFC = 0.5D0*( ((AM1/PIM)**2+(AM2/PIM)**2)*DF2*DG2

     .                -DVKU1*DG2-DF2*DVKU2 )

      FOFFO = 0.5D0*( 2*X1*( DDF2*DG2+DF2*DDG2-2*X1*DF2*DG2 ))  !april16

      RETURN

  200 FNONS = 0.5D0*( (D3F2+2*X1*DDF2-2*X2*DF2)*DG4

     .               +(D3F4+2*X1*DDF4-2*X2*DF4)*DG2 )/3.D0

      FNONT = 0.5D0*( (D3F2-  X1*DDF2+  X2*DF2)*DG4

     .               +(D3F4-  X1*DDF4+  X2*DF4)*DG2 )/3.D0

      FPVS  = + DF2*DG2/3.D0

      FPVT  =   FPVS

      FOFFS = 0.5D0*DF2*DG2

      FOFFT = FOFFS

      RETURN

  500 FNONC = 0.5D0*( DF2*DG4 + DF4*DG2 )

      RETURN

CC

      END

C **********************************************************************

      SUBROUTINE FOOMPR(ITYP,X,AM1,AM2,ALM1,ALM2)

C **********************************************************************

C

C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO PS-EXCHANGE

C

C     ITYP = 1 : (PIPI)_0  ITYP = 2 : (PIPI)_1,

C     ITYP = 3 : (PIRHO)_0 ITYP = 4 : (PIRHO)_1,

C     ITYP = 5 : (PI-OM)   ITYP = 6 : (PISIG)

C     ITYP = 7 : (PIPOM)   ITYP = 8 : (SI SI_)

C

C---------------------------------------------------------------

C     FUN(1) = F*G ,   FUN(2) = DF*G ,  FUN(3) = F*DG , 

C     FUN(4) = DF*DG , FUN(5) = DDF*G , FUN(6) = F*DDG , 

C     FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG , 

C     FUN(10)= D3F*DG

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

     .            ,FASO

      DIMENSION XX(20),WW(20),YB(3),FUN(10),FUNPV(10)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/

      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/,ICALL/0/

c     DATA YB/0.D0,5.D0,20.D0/,NINT/2/,NPNT/16/,IMETH/0/,ICALL/0/

      DATA AKMAX/0000.D0/,XKMAX/1.D0/

      SAVE XX,WW

C

C     POTENTIAL FUNTION DEFINITION

C

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C

      CALL ERRSET(208,256,-1,1)

C

      IF(ICALL.EQ.0) THEN

        CALL GAUSS(NPNT,XX,WW,1)

        IF(IMETH.EQ.1) NINT=1

        ICALL=1

      ENDIF

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

CC

      DO 1 IMES=1,2

      IF(IMES.EQ.1) THEN

      AMES = AM1

      ALAM = ALM1

      RATP1=PIM/ALAM

      ENDIF

      IF(IMES.EQ.2) THEN

      AMES = AM2

      ALAM = ALM2

      RATP2=PIM/ALAM

      ENDIF

C     NORMAL CASE (I.E. NON-DIFFRACTIVE)

      IF(ALAM.NE.AMES) THEN

      RATP =PIM/ALAM

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      VKUA =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)

      DVKUA=-0.5D0*(ALAM/PIM)**2*X*VKUA

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)



      XA   =X*AMES/PIM

      RATA =AMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA

      DHIA  =-(AMES/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

      ENDIF



C     DIFFRACTIVE CASE:

      IF(ALAM.EQ.AMES) THEN

      AMPOM = AMES

      RATP2 = 0.5D0*PIM/AMPOM

      XLAM  = X*AMPOM

      XPOM = X*AMPOM/PIM

      FIPO = (4.D0/SRPI)*(AMPOM/PIM)*(AMPOM/AMPRO)**2*

     .       FDEXP(-XPOM*XPOM)

      DFIPO = -2*(AMPOM/PIM)*XPOM*FIPO

      DDFIPO= -2*(AMPOM/PIM)*(XPOM*DFIPO + FIPO*AMPOM/PIM)

      D3FIPO= -2*(AMPOM/PIM)*(XPOM*DDFIPO + 2*DFIPO*AMPOM/PIM)

      FIA  = FIPO

      DFIA = DFIPO

      DDFIA= DDFIPO

      D3FIA= D3FIPO

      VKUA = FIPO

      DVKUA= DFIPO

      DDVKUA= DDFIPO

      ENDIF



      IF(IMES.EQ.1) THEN

C     N=2:

C     FINITE CUT-OFF CORRECTIONS:

      IF(ITYP.LE.7.AND.AMES.NE.ALAM.AND.

     .AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AMES,ALAM,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FIA = FIA + DFIC0*AMES/PIM

      DFIA = DFIA + DFIC1*AMES/PIM

      DDFIA = DDFIA + DFIC2*AMES/PIM

      D3FIA  = D3FIA + DFIC3*AMES/PIM

      ENDIF

      XLM1 = XLAM

      FI1 = FIA

      DFI1 = DFIA

      DDFI1 = DDFIA

      D3FI1 = D3FIA

      VKU1  = VKUA

      DVKU1 = DVKUA

      DDVKU1= DDVKUA

      ENDIF



      IF(IMES.EQ.2) THEN

C     N=2:

C     FINITE CUT-OFF CORRECTIONS:

      IF((ITYP.LE.2.OR.ITYP.EQ.5).AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AMES,ALAM,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FIA = FIA + DFIC0*AMES/PIM

      DFIA = DFIA + DFIC1*AMES/PIM

      DDFIA = DDFIA + DFIC2*AMES/PIM

      D3FIA  = D3FIA + DFIC3*AMES/PIM

      ENDIF

      XLM2 = XLAM

      FI2 = FIA

      DFI2 = DFIA

      DDFI2 = DDFIA

      D3FI2 = D3FIA

      VKU2  = VKUA

      DVKU2 = DVKUA

      ENDIF

    1 CONTINUE

C

C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION

C

      IF(ITYP.EQ.2) GOTO 200

      DO 105 II=1,10

      FUN(II) = 0.D0

  105 FUNPV(II) = 0.D0

      DO 100 INT=1,NINT

      ABM=0.5D0*(YB(INT+1)-YB(INT))

      ABP=0.5D0*(YB(INT+1)+YB(INT))

      DO 110 IY=1,NPNT 

      IF(IMETH.EQ.0) THEN

      Y=ABM*XX(IY)+ABP

      GEW=WW(IY)*ABM*2.D0/PI

      ENDIF

      IF(IMETH.EQ.1) THEN

      Y=(1.D0+XX(IY))/(1.D0-XX(IY))

      GEW=WW(IY)*(2.D0/(1.D0-XX(IY))**2)*2.D0/PI

      ENDIF

      IF(Y.GT.50.D0) GOTO 110

      GEWNA = GEW/Y/Y

C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :

      FDISP1=FDEXP(-Y*Y*RATP1*RATP1)

      FDISP2=FDEXP(-Y*Y*RATP2*RATP2)

C

      AM=PIM*DSQRT((AM1/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM1

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM1+RATM)

      EPM  =FDERFC( XLM1+RATM)

C

      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU1)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU1)*X1+(FIM-2*VKU1)*X2-(AM/PIM)*DHIM

      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2

      D3FIM =-(DDFIM-2*DDVKU1)*X1+(DFIM-2*DVKU1)*X2-(AM/PIM)*DDHIM

     .       +(DFIM-2*DVKU1)*X2-2*(FIM-2*VKU1)*X3



C     FINITE CUT-OFF CORRECTIONS:

      IF(ITYP.LE.7.AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AM,ALM1,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FIM = FIM + DFIC0*AM/PIM

      DFIM = DFIM + DFIC1*AM/PIM

      DDFIM = DDFIM + DFIC2*AM/PIM

      D3FIM  = D3FIM + DFIC3*AM/PIM

      ENDIF



      FIM1  = FIM

      DFIM1  = DFIM

      DDFIM1  = DDFIM

      D3FIM1  = D3FIM

C

      IF(ITYP.NE.7) THEN

      AM=PIM*DSQRT((AM2/PIM)**2+Y*Y)

      XM=AM*X/PIM

      RATM =AM/ALM2

      ERATM=FDEXP(RATM*RATM)

      EXM  =FDEXP(XM)

      EMM  =FDERFC(-XLM2+RATM)

      EPM  =FDERFC( XLM2+RATM)



      FIM   = F0(ERATM,EXM,EMM,EPM,X )

      HIM   = H0(ERATM,EXM,EMM,EPM,X )

      DFIM  =-(FIM-2*VKU2)*X1-(AM/PIM)*HIM

      DHIM  =-(AM/PIM)*FIM-HIM*X1

      DDFIM =-(DFIM-2*DVKU2)*X1+(FIM-2*VKU2)*X2-(AM/PIM)*DHIM



C     FINITE CUT-OFF CORRECTIONS:

      IF((ITYP.LE.2.OR.ITYP.EQ.5).AND.AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AM,ALM2,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FIM = FIM + DFIC0*AM/PIM

      DFIM = DFIM + DFIC1*AM/PIM

      DDFIM = DDFIM + DFIC2*AM/PIM

c*    D3FIM  = D3FIM + DFIC3*AM/PIM

      ENDIF

      ENDIF

      IF(ITYP.EQ.7) THEN

      FIM = FI2

      DFIM = DFI2

      DDFIM = DDFI2

      ENDIF

      FIM2  = FIM

      DFIM2  = DFIM

      DDFIM2  = DDFIM

C

      FDISP  = FDISP1*FDISP2

      FUN(1) = FUN(1) + GEWNA*(  FI1*  FI2-  FIM1*  FIM2*FDISP)

      FUN(2) = FUN(2) + GEWNA*( DFI1*  FI2- DFIM1*  FIM2*FDISP)

      FUN(3) = FUN(3) + GEWNA*(  FI1* DFI2-  FIM1* DFIM2*FDISP)

      FUN(4) = FUN(4) + GEWNA*( DFI1* DFI2- DFIM1* DFIM2*FDISP)

      FUN(5) = FUN(5) + GEWNA*(DDFI1*  FI2-DDFIM1*  FIM2*FDISP)

      FUN(6) = FUN(6) + GEWNA*(  FI1*DDFI2-  FIM1*DDFIM2*FDISP)

      FUN(7) = FUN(7) + GEWNA*(DDFI1* DFI2-DDFIM1* DFIM2*FDISP)

      FUN(8) = FUN(8) + GEWNA*( DFI1*DDFI2- DFIM1*DDFIM2*FDISP)

      FUN(9) = FUN(9) + GEWNA*(DDFI1*DDFI2-DDFIM1*DDFIM2*FDISP)

      FUN(10)= FUN(10)+ GEWNA*(D3FI1* DFI2-D3FIM1* DFIM2*FDISP)



      FUNPV(2)= FUNPV(2)+ GEW*( DFIM1*  FIM2*FDISP)

      FUNPV(3)= FUNPV(3)+ GEW*(  FIM1* DFIM2*FDISP)

      FUNPV(4)= FUNPV(4)+ GEW*( DFIM1* DFIM2*FDISP)

      FUNPV(5)= FUNPV(5)+ GEW*(DDFIM1*  FIM2*FDISP)

      FUNPV(6)= FUNPV(6)+ GEW*(  FIM1*DDFIM2*FDISP)

110   CONTINUE

100   CONTINUE

c*    FPVS = 2*X1*FUNPV(3)+FUNPV(4)+FUNPV(6)

c*    FPVT =-1*X1*FUNPV(3)+FUNPV(4)-FUNPV(6)  ! this is wrong , does not vanish at r=0

C

C     CONSTRUCTION BASE FUNCTIONS

C

C     (PIPI)_{0}:

      IF(ITYP.EQ.1) THEN

      FNONC = FUN(9) + 2*X2*FUN(4)

      FNONO = 2*X2*FUN(4)

      FPVC  = (FUNPV(5)+2*X1*FUNPV(2)) + (FUNPV(6)+2*X1*FUNPV(3))

      FPVO  = 2*X1*( FUNPV(2) + FUNPV(3) )

      RETURN

      ENDIF

C     (PIPI)_{1}:

200   IF(ITYP.EQ.2) THEN

      FNONC = 2*(DDFI1*DDFI2+2*X2*DFI1*DFI2)

      FNONO = 4*X2*DFI1*DFI2

      FPVC  = (DDFI1+2*X1*DFI1)*VKU2/RATP2**2

     .      + (DDFI2+2*X1*DFI2)*VKU1/RATP1**2

      FPVO  = 2*X1*(DFI1*VKU2/RATP2**2 + DFI2*VKU1/RATP1**2)

      RETURN

      ENDIF

C     (PIOM)_{1}:

      IF(ITYP.EQ.5) THEN

      FPVS = 2*X1*FUNPV(3)+FUNPV(4)+FUNPV(6)

      FPVT = -X1*FUNPV(3)+FUNPV(4)+FUNPV(6)

      FASO = -X1*(FUNPV(2)+FUNPV(3))

      RETURN

      ENDIF

C     {PI-SIGM}, {PI-POM}:

      IF(ITYP.EQ.6.OR.ITYP.EQ.7) THEN

      FNONS = -(+4*X2*FUN(4)-2*X1*FUN(7)-FUN(10)+FUN(9) )

      FNONT = -(-2*X2*FUN(4)+  X1*FUN(7)-FUN(10)+FUN(9) )



      FPVS  =  2*X1*FUNPV(3)+FUNPV(6)-FUNPV(4)

      FPVT  =   -X1*FUNPV(3)+FUNPV(6)-FUNPV(4)

      RETURN

      ENDIF

      IF(ITYP.EQ.8) THEN

      FNONC = FUN(4)

      RETURN

      ENDIF

CC

1000  CALL ERRSET(208,256,1,1)

      RETURN

      END

C **********************************************************************

      SUBROUTINE WROMPR(NCASE,X,P)

C **********************************************************************

C

C     NCASE = 1,2,7 : VC ; NCASE = 3 : VC,VS,VT ; NCASE = 4,5,6 : VS,VT

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PROMPR/VPR(5,3,4,4,6)

      CHARACTER *4 NTYPM(4,4)

      DATA N3/27/,NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','PHI ','OM  ',

     .'DE  ','KAP ','S*  ','EPS ','A2  ','K** ','POMP','POM '/

C

      write(n3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

      if(ncase.eq.1) write(n3,101)

      if(ncase.eq.2) write(n3,102)

      if(ncase.eq.3) write(n3,103)

      if(ncase.eq.4) write(n3,104)

      if(ncase.eq.5) write(n3,105)

      if(ncase.eq.6) write(n3,106)

      if(ncase.le.3) JJ=1

      if(ncase.eq.4) JJ=2

      if(ncase.eq.5) JJ=3

      if(ncase.eq.6) JJ=4



c     if(ncase.le.3 .OR. ncase.eq.7) then

      write(n3,100) x

      write(n3,110) (NTYPM(KK,JJ),KK=1,4)

  110 format(10x,4(3x,a4,5x))

      write(n3,*)'-----------------------------------------------------'

      DO 111 II=1,4

  111 write(n3,1) NTYPM(II,1),(VPR(1,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 112 II=1,4

  112 write(n3,2) NTYPM(II,1),(VPR(2,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 113 II=1,4

  113 write(n3,3) NTYPM(II,1),(VPR(3,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 114 II=1,4

  114 write(n3,4) NTYPM(II,1),(VPR(4,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 115 II=1,4

  115 write(n3,5) NTYPM(II,1),(VPR(5,1,II,KK,NCASE),KK=1,4)

      call wrsu3pr(1,ncase,x,p)

c     endif



      if(ncase.ge.3 .AND. ncase.ne.7) then

      write(n3,200) x

      write(n3,110) (NTYPM(KK,JJ),KK=1,4)

      write(n3,*)'-----------------------------------------------------'

      DO 211 II=1,4

  211 write(n3,1) NTYPM(II,1),(VPR(1,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 212 II=1,4

  212 write(n3,2) NTYPM(II,1),(VPR(2,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 213 II=1,4

  213 write(n3,3) NTYPM(II,1),(VPR(3,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 214 II=1,4

  214 write(n3,4) NTYPM(II,1),(VPR(4,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 215 II=1,4

  215 write(n3,5) NTYPM(II,1),(VPR(5,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'*****************************************************'

      call wrsu3pr(2,ncase,x,p)

      endif

      return              



  101 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :',/)

  102 format(/,' SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :',/)

  103 format(/,' VECTOR SU(3)-OCTET PAIR TERMS,  {8a}->{8}x{8} :',/)

  104 format(/,' AXIAL (PION-RHO) PAIR TERMS OF THE FIRST CLASS:',/)

  105 format(/,' PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:',/)

  106 format(/,' PSEUDO SCALAR (PS-POMERON) PAIR TERMS:',/)

  107 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :',/)



  100 format(55('*'),/,' OMPAIR: CENTRAL POTENTIALS: x=',f7.3,/,55('*'))    

  200 format(55('*'),/,' OMPAIR: SPIN-SPIN POTENTIALS: x=',f7.3,/,    

     .55('*'))

    1 FORMAT(1x,'NN: ',A4,4(F10.2,2X))

    2 FORMAT(1x,'LL: ',A4,4(F10.2,2X))

    3 FORMAT(1x,'LS: ',A4,4(F10.2,2X))

    4 FORMAT(1x,'SS: ',A4,4(F10.2,2X))

    5 FORMAT(1x,'DR: ',A4,4(F10.2,2X))

      end

C **********************************************************************

      SUBROUTINE WROMTM(NCASE,X,P)

C **********************************************************************

C

C     NCASE = 1: PSEUDO-SCALAR-PSEUDO POTENTIALS,

C     NCASE = 2: PSEUDO-SCALAR-VECTOR POTENTIALS,

C     NCASE = 3: PSEUDO-SCALAR-SCALAR POTENTIALS,

C     NCASE = 4: PSEUDO-SCALAR-DIFFR. POTENTIALS.

C     NCASE = 5: SCALAR-SCALAR        POTENTIALS.

C     NCASE = 6: SCALAR-DIFFRACTIVE   POTENTIALS.

C     NCASE = 7: DIFFRA-DIFFRACTIVE   POTENTIALS.

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PSBEOM/ VPSBE(5,4,4,4,7)                              

      CHARACTER*4 NTYPM(4,4)

      DATA N3/27/,NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','OM  ','PHI ',

     .'DE  ','KAP ','EPS ','S*  ','A2  ','K** ','POM ','POMP'/

C

      if(ncase.le.4) i1=1

      if(ncase.le.4) i2=ncase

      if(ncase.eq.5) i1=3

      if(ncase.eq.5) i2=3

      if(ncase.eq.6) i1=3

      if(ncase.eq.6) i2=4

      if(ncase.eq.7) i1=4

      if(ncase.eq.7) i2=4

      write(n3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

C     write(n3,*)'*****************************************************'

      if(ncase.eq.1) write(n3,*) ' OMPSPS: CENTRAL POTENTIALS: x=',x

      if(ncase.ge.2.and.ncase.le.4)

     .write(n3,*) ' OMPSBE: CENTRAL POTENTIALS: x=',x

      if(ncase.eq.5) write(n3,*) ' OMSCSC: CENTRAL POTENTIALS: x=',x

      if(ncase.eq.6) write(n3,*) ' OMSCDF: CENTRAL POTENTIALS: x=',x

      if(ncase.eq.7) write(n3,*) ' OMDFDF: CENTRAL POTENTIALS: x=',x

      write(n3,*)'*****************************************************'

      write(n3,110) (NTYPM(KK,I2),KK=1,4)

  110 format(10x,4(3x,a4,5x))

      write(n3,*)'-----------------------------------------------------'

      DO 111 II=1,4

  111 write(n3,112) NTYPM(II,I1),(VPSBE(1,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 113 II=1,4

  113 write(n3,114) NTYPM(II,I1),(VPSBE(5,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 123 II=1,4

  123 write(n3,124) NTYPM(II,I1),(VPSBE(2,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 125 II=1,4

  125 write(n3,126) NTYPM(II,I1),(VPSBE(3,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 127 II=1,4

  127 write(n3,128) NTYPM(II,I1),(VPSBE(4,1,II,KK,NCASE),KK=1,4)

      write(n3,*)'*****************************************************'

      call wrsu3tm(1,ncase,x,p)

      if(ncase.ge.5) return

      if(ncase.eq.1) write(n3,*) ' OMPSPS: SPIN-SPIN POTENTIALS: x=',x

      if(ncase.ge.2.and.ncase.le.4)

     .write(n3,*) ' OMPSBE: SPIN-SPIN POTENTIALS: x=',x

      if(ncase.eq.5) write(n3,*) ' OMSCSC: SPIN-SPIN POTENTIALS: x=',x

      if(ncase.eq.6) write(n3,*) ' OMSCDF: SPIN-SPIN POTENTIALS: x=',x

      if(ncase.eq.7) write(n3,*) ' OMDFDF: SPIN-SPIN POTENTIALS: x=',x

      write(n3,*)'*****************************************************'

      write(n3,115) (NTYPM(KK,I2),KK=1,4)

  115 format(10x,4(3x,a4,5x))

      write(n3,*)'-----------------------------------------------------'

      DO 116 II=1,4

  116 write(n3,112) NTYPM(II,I1),(VPSBE(1,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 118 II=1,4

  118 write(n3,114) NTYPM(II,I1),(VPSBE(5,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 120 II=1,4

  120 write(n3,124) NTYPM(II,I1),(VPSBE(2,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 129 II=1,4

  129 write(n3,126) NTYPM(II,I1),(VPSBE(3,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'====================================================='

      DO 131 II=1,4

  131 write(n3,128) NTYPM(II,I1),(VPSBE(4,2,II,KK,NCASE),KK=1,4)

      write(n3,*)'*****************************************************'

      call wrsu3tm(2,ncase,x,p)

      RETURN

  112 FORMAT(1x,'NN: ',A4,4(F10.2,2X))

  114 FORMAT(1x,'DR: ',A4,4(F10.2,2X))

  124 FORMAT(1x,'LL: ',A4,4(F10.2,2X))

  126 FORMAT(1x,'LS: ',A4,4(F10.2,2X))

  128 FORMAT(1x,'SS: ',A4,4(F10.2,2X))

C END WROMTM ROUTINE **************************************************

      END

C **********************************************************************

      SUBROUTINE WRSU3TM(IV,NCASE,X,P)

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PSBEOM/ VPR(5,4,4,4,7)                              

      DIMENSION VTOT(5)

      DATA N3/27/

C SUMMED CONTRIBUTIONS:                   

      DO 120 ICHAN=1,5

      VTOT(ICHAN)=0.D0

      DO 120 M=1,4

      DO 120 N=1,4

  120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE)

      if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/,

     .       ' VCLS=',F10.2,3x,' VCSS=',F10.2,/)

      if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/,

     .       ' VSLS=',F10.2,3x,' VSSS=',F10.2,/)

C CONTRIBUTIONS TO SU(3)-POTENTIALS:                        

      if(p.eq.1.d0) then

      V27a = VTOT(1)                                                    

      V27b = VTOT(5)                                                    

      V27c = (9*VTOT(2)-VTOT(4))/8.D0

c     V8Sa = 10*VTOT(2)-9*VTOT(5)

      V8Sa =    VTOT(2)+3*VTOT(3)

      V8Sb = (10*VTOT(4)-VTOT(5))/9.D0

      V8Sc = (9*VTOT(4)-VTOT(2))/8.D0

      VLSa = (-3*V27b+3*V8Sa)/10.D0

      VLSb = (-3*V27b+3*V8Sb)/10.D0

      VLSc = (-3*V27c+3*V8Sc)/10.D0

      write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc

  123 format(/,' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/,

     .         ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/,

     .         ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2)

      endif

      if(p.eq.-1.d0) then

      V10  = VTOT(5)

      V10sa= VTOT(2)+VTOT(3)                                            

      V10sb= VTOT(4)+VTOT(3)                                            

      V8Aa = VTOT(2)-VTOT(3)                                            

      V8Ab = VTOT(4)-VTOT(3)                                            

      write(n3,124) V10sa,V10sb,V8Aa,V8Ab,V10

  124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,/,

     .       ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,' V10 =',F10.2,/)

      endif

      write(n3,*)'*****************************************************'

      RETURN

      END

C **********************************************************************

      SUBROUTINE WRSU3PR(IV,NCASE,X,P)

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PROMPR/VPR(5,3,4,4,6)

      DIMENSION VTOT(5)

      DATA N3/27/

C SUMMED CONTRIBUTIONS:                   

      DO 120 ICHAN=1,5

      VTOT(ICHAN)=0.D0

      DO 120 M=1,4

      DO 120 N=1,4

  120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE)

      if(iv.eq.1) write(n3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/,

     .       ' VCLS=',F10.2,3x,' VCSS=',F10.2,/)

      if(iv.eq.2) write(n3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/,

     .       ' VSLS=',F10.2,3x,' VSSS=',F10.2,/)

C CONTRIBUTIONS TO SU(3)-POTENTIALS:                        

      if(p.eq.1.d0) then

      V27a = VTOT(1)                                                    

      V27b = VTOT(5)                                                    

      V27c = (9*VTOT(2)-VTOT(4))/8.D0

c     V8Sa = 10*VTOT(2)-9*VTOT(5)

      V8Sa =    VTOT(2)+3*VTOT(3)

      V8Sb = (10*VTOT(4)-VTOT(5))/9.D0

      V8Sc = (9*VTOT(4)-VTOT(2))/8.D0

      VLSa = (-3*V27b+3*V8Sa)/10.D0

      VLSb = (-3*V27b+3*V8Sb)/10.D0

      VLSc = (-3*V27c+3*V8Sc)/10.D0

      write(n3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc

  123 format(' V27a =',F10.2,3x,' V27b =',F10.2,3x,' V27c =',F10.2,/,

     .       ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/,

     .       ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2,/)

      endif

      if(p.eq.-1.d0) then

      V10  = VTOT(5)

      V10sa= VTOT(2)+VTOT(3)                                            

      V10sb= VTOT(4)+VTOT(3)                                            

      V8Aa = VTOT(2)-VTOT(3)                                            

      V8Ab = VTOT(4)-VTOT(3)                                            

      write(n3,124) V10sa,V10sb,V8Aa,V8Ab,V10

  124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,/,

     .       ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10 =',F10.2,/)

      endif

      write(n3,*)'*****************************************************'

      RETURN

      END



C **********************************************************************

C     VERSION DD. MARCH 2009: WRT OCTOBER 2008:

C         IPIOM.EQ.2: NO 1/M^2-TERMS, BUT KEPT FOR IPIRO1.EQ.1 !



C     SPLITTING YNPAIR: YNPRCOP + YNPAIR

C     version with explicit pi-omega , pi-phi for ntype=6

C **********************************************************************

C     FOR TREATMENT PAIR-EXCHANGES:

C **********************************************************************

      BLOCK DATA BLKDAT

c     subroutine setpar

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI

     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA                  ! MARCH 2009

      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB



      DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/2/,

     . IPISI/1/,ISISI/0/,IPIET/1/,IPIETP/0/,IPIPOM/1/,

     . IPIROV/0/,IPIOMV/0/,IKKB0/0/,IKKB1/0/,IPIA1/0/,IOMETA/0/



c     DATA IPIPI0/0/,IPIPI1/1/,IPIRO1/0/,IPIRO0/0/,IPIOM/0/,

c    . IPISI/0/,ISISI/0/,IPIET/0/,IPIETP/0/,IPIPOM/0/,

c    . IPIROV/0/,IPIOMV/0/,IKKB0/0/,IKKB1/0/,IPIA1/0/



c*    DATA N2PR0/1/,N2PR1/1/,N2PRV/0/,N2PRA/1/,N2PRB/1/

      DATA N2PR0/0/,N2PR1/0/,N2PRV/0/,N2PRA/0/,N2PRB/0/

c     return

      END

C **********************************************************************

      SUBROUTINE YNPRCOP(ICSB,NSU3F)    

C **********************************************************************

C *

C

C *   COUPLINGS PION-MESON PAIR YN-POTENTIALS

C *

C     IN COUPLING COMBINATIONS CENLL1 ETC.:

C     (i) YNCCPR: L+R contributions included,

C     (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams)

C     (iii) FFUN2: identical particle factor included (2 contractions),

C                  facip=2.

C

C     ALTERNATIVE NOMENCLATURE PAIR COUPLINGS:

C     GAPAIR=GPIRO1, HAPAIR=GPIRO0, GPPAIR=GPISI, GEPAIR=GSISI



C     PISI and PIRO1 a la paper II !!

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRMTRS/PAR(20,8)

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA

c     COMMON/COUPL/ F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,

c    .              G1,G2,G3,G4,G5,G6,G7,G8,G9,G10,G11,

c    .              FD1,FD2,FD3,FD4,FD5,FD6,FD7,FD8,FD9,FD10,FD11,

c    .              FV1,FV2,FV3,FV4,FV5,FV6,FV7,FV8,FV9,FV10,FV11,

c    .              GS1,GS2,GS3,GS4,GS5,GS6,GS7,GS8,GS9,GS10,GS11,

c    .              GD1,GD2,GD3,GD4,GD5,GD6,GD7,GD8,GD9,GD10,GD11,P,PX

c     DIMENSION F(11),G(11),FD(11),FV(11),GS(11),GD(11)

c     EQUIVALENCE (F1,F(1)),(G1,G(1)),(FD1,FD(1)),(FV1,FV(1))

c    . ,(GS1,GS(1)),(GD1,GD(1))

      COMMON/COUPL/ F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX

C

      DIMENSION PRF(11)

C

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR

      COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11),

     .             PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11),

     .             PRTEN(11),PRTENF(11)



C     communication with routine YNPRCC:

C

C !!  NOTICE: THIS VERSION IN YNPRCC ALL COUPLINGS ARE ORDERED AS       !!!!!

C !!          FOR THE PS-SCALARS !!!!                                   !!!!!

C

      COMMON/PRCPLS/CENPR(10),SIGPR(10)

      COMMON/CPLRIJ/FA(11),FB(11),PR(11)

      COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10),

     .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10)  ,CCPR7(3,10),

     .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10),

     .CCPR11(4,10),CCPR11F(4,10)                 ! MARCH 2009

C

      DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,

     .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA  ! MARCH 2009

      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB

c     SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7

      DATA SONV/1D0/,SONPV/1D0/,SONSC/1D0/,SON1/1D0/

      DATA ISU3/0/,ICALL/0/,NSCHR/0/                    

***   DATA ISU3/1/,ICALL/0/,NSCHR/1/                    

      DATA I3P0/1/

      data ipipi2/0/



C     SU3-BREAKING IN PAIR COUPLINGS:

       IF(NSU3F.NE.1) THEN

c       SONV  = PAR(10,7)

c       SONPV = PAR(11,7)

c       SONSC = PAR(12,7)

        SONV  = PAR(13,7)

        SONPV = PAR(14,7)

        SONSC = PAR(15,7)

        SON1  = PAR(14,1) 

        IF(I3P0.EQ.1) THEN

        SONPV = PAR(11,7)

        SONV  = PAR(10,7)

        SONSC = PAR(10,7)

        SONVA = PAR(10,7)

        SON1  = PAR(10,7)

        ENDIF

        ENDIF

C

       IF(NSU3F.EQ.1) THEN

c*      CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS)

CC      New organization: the next statements are wrong:

CC      because in amatlp ynpair-routine is called 

CC      prior to OBE-routines!

c?      GS(9)=PAR(3,5)

c?      GD(9)=PAR(3,6)

c?      CALL SU3(F,ALP)

c?      CALL SU3(FD,ALVD)

c?      CALL SU3(FV,ALVV)

c?      CALL SU3(GS,ALS)  

c?      CALL SU3(GD,ALD)  

       ENDIF

      ALPBPR= PAR(19,1)

      IF(ALPBPR.EQ.0.D0) ALPBPR = ALP



      IF(ICALL.EQ.0) THEN

        IF(NSCHR.NE.0) PRINT 99, 

     .  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV,

     .  IPISI,ISISI,IPIET,IPIETP,IKKB0,IKKB1,IPIPOM,

     .  GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIET,GPISI,GSISI,GPIRO0,

     .  HOPAIR,GPIETP,GPIPOM

     . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR

     . ,SONV,SONPV,SONSC,SON1

c    . ,N2PR0,N2PR1,N2PRV,N2PRA,N2PRB,PIM,DAM 

     . ,F,FD,FV,GS,GD

 99     FORMAT(//,'  IN YNPRCOP:',//,

     .  11X,'  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV=',7I2,//,

     .  11X,'  IPISI ,ISISI ,IPIET ,IPIETP,IKKB0 ,IKKB1,IPIPOM=',7I2,//,

     .  11X,'  GSPAIR=',F10.5,'  GVPAIR=',F10.5,'  FVPAIR=',F10.5,//,   

     .  11X,'  GPIRO1=',F10.5,'  GPIET =',F10.5,'  GPISI =',F10.5,//,   

     .  11X,'  GSISI =',F10.5,'  GPIRO0=',F10.5,'  HOPAIR=',F10.5,//,   

     .  11X,'  GPIETP=',F10.5,'  GPIPOM=',F10.5,//,   

     .  11X,'  ALPVPR=',F10.5,'  ALVDPR=',F10.5,'  ALVVPR=',F10.5,//,

     .  11X,'  ALSCPR=',F10.5,'  ALPAPR=',F10.5,'  ALPBPR=',F10.5,//,

     .  11X,'  SONVPR=',F10.5,'  SONPPR=',F10.5,'  SONSPR=',F10.5,//,

     .  11X,'  SON{1}=',F10.5,//,

c    .  11X,'  N2PR0,N2PR1 ,N2PRV ,N2PRA ,N2PRB =',5(I3,2X),/, 

c    .  11X,'  PIM=',F10.3,' DAM=',F10.3,//,

     .  11X,'  F  =',6(F10.5),/,17X,5(F10.5),/,

     .  11X,'  FD =',6(F10.5),/,17X,5(F10.5),/,

     .  11X,'  FV =',6(F10.5),/,17X,5(F10.5),/,

     .  11X,'  GS =',6(F10.5),/,17X,5(F10.5),/,

     .  11X,'  GD =',6(F10.5),/,17X,5(F10.5))

c       ICALL=1

      ENDIF

C

C     CONSTRUCTION OF COUPLING COMBINATIONS

C

C !!  NOTICE: THIS VERSION ALL COUPLINGS ARE ORDERED AS       !!!!!

C !!          FOR THE PS-SCALARS!!                            !!!!!

C

C a)  scalar SU(3)-singlet pair terms, {1}->{8}x{8} :

C

      IF(IPIPI0.NE.0) THEN

      PR(1) = GSPAIR

c     PR(1) = GSPAIR*DCOS(THS)

c     PR(1) = GSPAIR*(1.D0-GPIET)

      DO 110 KK=1,11

      FA(KK) = F(KK)

 110  FB(KK) = F(KK)

      DO 111 II=1,3

      CALL YNPRCC(1,II,ICSB,ALP,ALP,P)

      DO 111 KK=1,5 

      CCPR1(II,KK) = CENPR(KK)

 111  CCPR1(II,KK+5) = CENPR(KK+5)*N2PR0

      ENDIF

C

C b)  scalar SU(3)-octet pair terms, {8s}->{8}x{8} :

C

      IF(IPIET.NE.0) THEN

      PR(1) = GPIET

      PR(9) = 0.D0

      CALL SU3(PR,ALSCPR)

      IF(SONSC.NE.1.D0) CALL SU3SB03(PR,ALSCPR,SONSC)

      DO 120 KK=1,11

      if(icall.eq.0) prpe1(kk)=pr(kk)

      prpe1(kk)= pr(kk)

      FA(KK) = F(KK)

 120  FB(KK) = F(KK)

      DO 121 II=1,7  

      CALL YNPRCC(2,II,ICSB,ALP,ALP,P)

      DO 121 KK=1,5 

      CCPR2(II,KK) = CENPR(KK)

 121  CCPR2(II,KK+5) = CENPR(KK+5)*N2PR0

      ENDIF

C

C c)  vector SU(3)-octet pair terms, {8a}->{8}x{8} :

C

      IF(IPIPI1.NE.0) THEN

      PR(1) = GVPAIR

      PR(9) = 0.D0

      CALL SU3(PR,ALVDPR)

      IF(SONV.NE.1.D0) CALL SU3SB03(PR,ALVDPR,SONV)

      DO 130 KK=1,11

      if(icall.eq.0) prppg(kk)=pr(kk)

      FA(KK) = F(KK)

 130  FB(KK) = F(KK)

      DO 131 II=1,9

      CALL YNPRCC(3,II,ICSB,ALP,ALP,P)

      DO 131 KK=1,5 

      CCPRG(II,KK) = SIGPR(KK)

 131  CCPRG(II,KK+5) = SIGPR(KK+5)*N2PR1

      PRF(1) = FVPAIR

      PRF(9) = 0.D0

      CALL SU3(PRF,ALVVPR)

      IF(SONV.NE.1.D0) CALL SU3SB03(PRF,ALVVPR,SONV)

      DO 135 II=1,11

      if(icall.eq.0) prppf(ii)=prf(ii)

 135  PR(II) = PR(II)+PRF(II)

      DO 136 II=1,9

      CALL YNPRCC(3,II,ICSB,ALP,ALP,P)

      DO 136 KK=1,5 

      CCPRF(II,KK) = SIGPR(KK)

 136  CCPRF(II,KK+5) = SIGPR(KK+5)*N2PR1

      ENDIF

C

C d)  axial pair terms, {8a}->{8}x{8} :

C

      IF(IPIRO1.NE.0) THEN

      PR(1) = GPIRO1

      PR(9) = 0.D0

      CALL SU3(PR,ALPAPR)

      IF(SONPV.NE.1.D0) CALL SU3SB03(PR,ALPAPR,SONPV)

      DO 140 KK=1,11

      if(icall.eq.0) prpr1(kk)=pr(kk)

      FA(KK) = F(KK)

 140  FB(KK) = FD(KK)

      call reordr(fb)   ! NOTE: FD-ordering is .ne. F-ordering

      DO 141 II=1,9

      CALL YNPRCC(3,II,ICSB,ALP,ALVD,P)

      DO 141 KK=1,5 

      CCPR4(II,KK) = SIGPR(KK)

 141  CCPR4(II,KK+5) = SIGPR(KK+5)*N2PRA

      DO 145 KK=1,11

      FA(KK) = F(KK)

 145  FB(KK) = FV(KK)

      call reordr(fb)   ! NOTE: FV-ordering is .ne. F-ordering

      DO 146 II=1,9

      CALL YNPRCC(3,II,ICSB,ALP,ALVV,P)

      DO 146 KK=1,5 

      CCPR4F(II,KK) = SIGPR(KK)

 146  CCPR4F(II,KK+5) = SIGPR(KK+5)*N2PRA

      ENDIF

C

C e)  axial pair terms, {8}->{8}x{1} :

C

      IF(IPISI.NE.0) THEN

C     PS-EPSILON CONTRIBUTIONS:

      PR(1) = GPISI

c*    PR(1) = GPISI*DCOS(THS)

      PR(9) = 0.D0

      CALL SU3(PR,ALPAPR)

      DO 150 KK=1,11

      if(icall.eq.0) prpsi(kk)=pr(kk)

      FA(KK) = F(KK)

 150  FB(KK) = GS(KK)

      call reordr(fb)   ! NOTE: GS-ordering is .ne. F-ordering

      DO 151 II=1,3

      CALL YNPRCC(4,II,ICSB,ALP,ALS,P)

      DO 151 KK=1,5 

      CCPR5(II,KK) = SIGPR(KK)

 151  CCPR5(II,KK+5) = SIGPR(KK+5)*N2PRA

C     PS-SSTAR CONTRIBUTIONS:

c     PR(1) = 0.D0

      PR(1) =-GPISI*DSIN(THS)

      PR(9) = 0.D0

      CALL SU3(PR,ALPAPR)

      DO 155 KK=1,11

      FA(KK) = F(KK)

 155  FB(KK) = GS(KK)

      call reordr(fb)   ! NOTE: GS-ordering is .ne. F-ordering

      DO 156 II=4,6

      CALL YNPRCC(4,II,ICSB,ALP,ALS,P)

      DO 156 KK=1,5 

      CCPR5(II,KK) = SIGPR(KK)

 156  CCPR5(II,KK+5) = SIGPR(KK+5)*N2PRA

      ENDIF



      IF(IPIPOM.NE.0) THEN

C     PS-POMERON CONTRIBUTIONS:

      PR(1) = GPIPOM

      PR(9) = 0.D0

      CALL SU3(PR,ALPAPR)

      DO 170 KK=1,11

      if(icall.eq.0) prppo(kk)=pr(kk)

      FA(KK) = F(KK)

 170  FB(KK) = GD(KK)

      call reordr(fb)

      DO 171 II=1,3

      CALL YNPRCC(4,II,ICSB,ALP,ALD,P)

      DO 171 KK=1,5 

      CCPR7(II,KK) = SIGPR(KK)

 171  CCPR7(II,KK+5) = SIGPR(KK+5)*N2PRA

      ENDIF

C

C f)  SU(3)-singlet pair terms, {1}->{1}x{1} :

C

      IF(ISISI.NE.0) THEN

c     PR(1) = GSISI*DCOS(THS)

      PR(1) = GSISI

      PR(2) = GSISI*DABS(SON1)

      PR(3) = GSISI*DABS(SON1)

      DO 160 KK=1,11

      FA(KK) = GS(KK)

 160  FB(KK) = GS(KK)

      call reordr(fa)

      call reordr(fb)

      DO 161 II=1,1

      CALL YNPRCC(5,II,ICSB,ALS,ALS,P)

      DO 161 KK=1,5 

      CCPR6(KK) = CENPR(KK)

 161  CCPR6(KK+5) = CENPR(KK+5)*N2PR0

      ENDIF

C

C h)  second-class axial pair terms, {8s}->{8}x{8} :

C

      IF(IPIOM.NE.0) THEN

C     PI-OMEGA CONTRIBUTIONS:

      ALPBPR= PAR(19,1)

      IF(ALPBPR.EQ.0D0) ALPBPR= ALP 

c*    PR(1) = GPIOM

      PR(1) = HOPAIR

c*   ./dsqrt(2d0)      ! we choose to include this factor in xnprcc

      PR(9) = 0.D0

      CALL SU3(PR,ALPBPR)

      DO 190 KK=1,11

      if(icall.eq.0) prpo1(kk)=pr(kk)

      prpo1(kk)= pr(kk)

      FA(KK) = F(KK)

 190  FB(KK) = FD(KK)

      call reordr(fb)

      DO 191 II=1,13

      CALL YNPRCC(6,II,ICSB,ALP,ALVD,P)

c*    CALL YNPRCC(2,II,ICSB,ALP,ALVD,P)

      DO 191 KK=1,5 

      CCPR10(II,KK) = CENPR(KK)

 191  CCPR10(II,KK+5) = CENPR(KK+5)*N2PRB

      ENDIF

C

C i)  tensor SU(3)-octet pair terms, {8s}->{8}x{8} :

C

      IF(IPIPI2.NE.0) THEN

      GTENPR = par(16,8)

      PR(1) = GTENPR

      PR(9) = 0.D0

      ALTDPR = 0d0

      CALL SU3(PR,ALTDPR)

      DO 220 KK=1,11

      if(icall.eq.0) prten(kk)=pr(kk)

      FA(KK) = F(KK)

 220  FB(KK) = F(KK)

      DO 221 II=1,7  

      CALL YNPRCC(2,II,ICSB,ALP,ALP,P)

      DO 221 KK=1,5 

      CCPR8(II,KK) = CENPR(KK)

 221  CCPR8(II,KK+5) = CENPR(KK+5)*N2PR0

      ftenpr = par(17,8)

      PRF(1) = FTENPR

      PRF(9) = 0.D0

      ALTVPR = ALVVPR

      CALL SU3(PR,ALTVPR)

      DO 222 KK=1,11

      if(icall.eq.0) prten(kk)=pr(kk)

 222  PR(KK)=PR(KK)+PRF(KK)

      DO 223 II=1,7  

      CALL YNPRCC(2,II,ICSB,ALP,ALP,P)

      DO 223 KK=1,5 

      CCPR8F(II,KK) = CENPR(KK)

 223  CCPR8F(II,KK+5) = CENPR(KK+5)*N2PR0

      ENDIF



c     PRINT 199, ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR

 199  FORMAT(/,'  ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR=',   

     .5F10.5,//)

C ******************************************************************

      if(icall.eq.0.and.ns.ne.0) then

      write(6,94) prpe1,prppg,prppf,prpr1,prpo1,prpsi,prppo,

     .prten,prtenf

      endif

   94 format(/,72('*'),/,' Pair Coupling Constants:',/,72('-'),/,

     .'       ','   nnp  ','   ssp  ','   lsp  ','   lnk  ',

     .'   snk  ',/,'       ','   nne  ','   lle  ','   sse  ',

     .'   nnx  ','   llx  ','   ssx  ',/,72('-'),/,

     .' gpie =',5f8.5,/,7x,6f8.5,//,' gpp1 =',5f8.5,/,7x,6f8.5,//,

     .' fpp1 =',5f8.5,/,7x,6f8.5,//,' gpr1 =',5f8.5,/,7x,6f8.5,//,

     .' gpo1 =',5f8.5,/,7x,6f8.5,//,' gpsi =',5f8.5,/,7x,6f8.5,//,

     .' gppo"=',5f8.5,/,7x,6f8.5,//,' gpp2 =',5f8.5,/,7x,6f8.5,//,

     .' fpp2 =',5f8.5,/,7x,6f8.5,//)

C ******************************************************************



      ICALL=1

      RETURN

      END

C **********************************************************************

      SUBROUTINE REORDR(FA)       

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION FA(11)

      DO 5 JO=6,8

      JS=JO+3

      WOA=FA(JO)

      WSA=FA(JS)

      FA(JO)=WSA

    5 FA(JS)=WOA

      RETURN

      END

C **********************************************************************

C     FOR SU(3)-SYMMETRIC TREATMENT PAIR-EXCHANGES:

C **********************************************************************

      SUBROUTINE SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS)

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRMTRS/PAR(20,8)

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11)

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA



      THPS = 0.D0

      THV  = 0.D0     ! Why? For pi-omega?

      THS  = 0.D0

c*    ALVVPR = ALVDPR ! why?



      ALMP1=ALMP8

      ALMV1=ALMV8

      ALMS1=ALMS8

      ALMKA=ALMP8

      ALMKS=ALMV8

      ALMKP=ALMS8



c*    AMPRO= 1115.6D0

      AMPRO= 938.2796D0  ! for FOOMPR

c*    AMN  = 1115.6D0

      AMN  = AMPRO     



c*    PIM  = 200.D0

c*    PIM  = AMK     ! GMO-value, see ynlp08.f

      AMPI = AMK     ! GMO-value, see ynlp08.f

c     AMK = AMPI

c     BMK = AMPI

c     AME = AMPI

c     AMX = AMPI



      AMRO = 800.D0

      AMEPS= 800.D0

      AMOM = AMRO

      AMFI = AMRO

      AMKS = AMRO

      BMKS = AMRO

      AMD  = AMEPS

      AMSCK= AMEPS

      AMSST= AMEPS



      AMSIG(1) = AMEPS

      AMSIG(2) = AMEPS

      ASIG(1)  = 1.D0

      ASIG(2)  = 0.D0

      AMVEC(1) = AMRO

      AMVEC(2) = AMRO

      AVEC(1)  = 1.D0

      AVEC(2)  = 0.D0



      PAR(11,6)=0.d0  ! AHYPC=0

      RETURN

      END

C **********************************************************************

      SUBROUTINE YNPAIR(X,INA,IPV,ICSB,APV)

C **********************************************************************

C *

C     VERSION WITH K-FORM FACTOR: ALMKA (SEPT. 2000)

C

C *   PHENOMENOLOGICAL PION-MESON PAIR YN-POTENTIALS

C *

C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET

C     VECTOR : ALMV1 = SU(3)-SINGLET, ALMV8 = SU(3)-OCTET

C     SCALAR : ALMS1 = SU(3)-SINGLET, ALMS8 = SU(3)-OCTET

C *

C     IN CALLS AAFUN, ETC. SCHEMATICALLY:

C     FUN(1) = F*G,    FUN(2) = DF*G,   FUN(3) = F*DG,

C     FUN(4) = DF*DG,  FUN(5) = DDF*G,  FUN(6) = F*DDG,

C     FUN(7) = DDF*DG, FUN(8) = DF*DDG, FUN(9) = DDF*DDG

C

C     IN COUPLING COMBINATIONS CENLL1 ETC.:

C     (i) YNCCPR: L+R contributions included,

C     (ii) YNCCPR: 1 <-> 2 interchange factor included (extra diagrams)

C     (iii) FFUN2: identical particle factor included (2 contractions),

C                  facip=2.

C

C     FOR FORM FACTOR TREATMENT SEE:

C     TH.A.RIJKEN, ANNALS OF PHYSICS 208, P.253 (1990).

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/MODEL/IXXX(8),NSU3F

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      common/nn/vcnn,vsnn,vtnn,vonn

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11)

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA

      COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX

C     COMMON/OOM/ INA,IPV,IOFF

C

      DIMENSION FUN(12),WGHTID(2)

C

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR



      COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11),

     .             PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11),

     .             PRTEN(11),PRTENF(11)



C     communication with routine YNPRCC:

C

      COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10),

     .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10)  ,CCPR7(3,10),

     .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10),

     .CCPR11(4,10),CCPR11F(4,10)                 ! MARCH 2009



C     communication with routine WRITEPR:

      COMMON/PRWRITE/VPRA(5,3,4,4),VPRB(5,3,4,4),VPRC(5,3,4,4)

     .              ,VPRD(5,3,4,4),VPRE(5,3,4,4),VPRF(5,3,4,4)

     .              ,VPRG(5,3,4,4),VPRH(5,3,4,4)              

C

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,

     .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA  ! MARCH 2009

      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN



c     COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5,

c    .              VALL1,VALL2,VALL3,VALL4,VALL5               



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/

      DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/,

     .     AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/,

     .     AKMAX/0000.D0/,XKMAX/1.D0/,

     .     AMLAM/1115D0/,AMSIGM/1190D0/



      DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/

      data ipipi2/0/      ! if ipipi2.ne.0 -> su3f-breaking!?



      SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL

C

      if(p.eq.+1.d0) isfac=1

      if(p.eq.-1.d0) isfac=-3

c*    isu3=1



C     WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING

      WGHTID(1) = DSIN(THV)       

      WGHTID(2) = DCOS(THV)       



      IF(ICALL.EQ.0) THEN

        PIM = PIM0

        IF(NSU3F.EQ.1) CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS)

C       F1 = F(1)

C       GS6= GS(6)

        XBEGIN=X

        pim0=pim

        FACT  = PIM0

c       AMNC = DSQRT(AM(2)*AM(3))

c       AMHY = DSQRT(AMY(1)*AMY(2))

C       AMN  = DSQRT(AMNN*AMH )

        DAM  = AMH-AMNN

        AA   = DAM/PIM0



        IF(NSCHR.NE.0) PRINT 99, IZSC,INA,IPV,

     .  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV,

     .  IPISI,ISISI,IPIET,IPIETP,IKKB0,IKKB1,IPIPOM,

     .  N2PR0,N2PR1,N2PRV,N2PRA,N2PRB,PIM,DAM,ALMKA,

     .  AKMAX,XKMAX

 99     FORMAT(//,'  IN YNPAIR.NOV02: IZSC, INA, IPV=',3I3,//,

     .  11X,'  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV=',7I2,//,

     .  11X,'  IPISI ,ISISI ,IPIET ,IPIETP,IKKB0 ,IKKB1,IPIPOM=',7I2,//,

     .  11X,'  N2PR0,N2PR1 ,N2PRV ,N2PRA ,N2PRB =',5(I3,2X),/, 

     .  11X,'  PIM=',F10.3,' DAM=',F10.3,' ALMKA=',F10.3,//, 

     .  '  IN YNPAIR,FOOMPR:  AKMAX=',F10.3,' XKMAX=',F10.3//)

c       ICALL=1

      ENDIF



      if(p.ne.pold) then

      icall=0

      pold=p

      nschr=1

      endif



c     DO 1 I=2,NMAX

c     X = XA(I)

      VCLL  =0.D0

      VCLS  =0.D0

      VCSS  =0.D0

      VCDR  =0.D0

      VSLL  =0.D0

      VSLS  =0.D0

      VSSS  =0.D0

      VSDR  =0.D0

      VTLL  =0.D0

      VTLS  =0.D0

      VTSS  =0.D0

      VTDR  =0.D0

      VOLL  =0.D0

      VOLS  =0.D0

      VOSS  =0.D0

      VODR  =0.D0

      VALL  =0.D0

      VALS  =0.D0

      VASS  =0.D0

      VADR  =0.D0

      VCNN  =0.D0

      VSNN  =0.D0

      VTNN  =0.D0

      VONN  =0.D0

      DO 250 NCHAN=1,5

      DO 250 ITYPV=1,3

      DO 250 IMES1=1,4

      DO 250 IMES2=1,4

      VPRA(NCHAN,ITYPV,IMES1,IMES2)=0.D0

      VPRB(NCHAN,ITYPV,IMES1,IMES2)=0.D0

      VPRC(NCHAN,ITYPV,IMES1,IMES2)=0.D0

      VPRD(NCHAN,ITYPV,IMES1,IMES2)=0.D0

      VPRE(NCHAN,ITYPV,IMES1,IMES2)=0.D0

      VPRF(NCHAN,ITYPV,IMES1,IMES2)=0.D0

  250 VPRH(NCHAN,ITYPV,IMES1,IMES2)=0.D0



CC

      X1   =1.D0/X

      X2   =X1*X1     

CC

c     CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI)

c     CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1)

c     CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU)

      CALL FFUN(2,X,AMPI,ALMP8,FI,DFI,DDFI,D3FI)

      CALL FFUN(1,X,AMPI,ALMP8,FI1,DFI1,DDFI1,D3FI1)

      CALL FFUN(0,X,AMPI,ALMP8,VKU,DVKU,DDVKU,D3VKU)

C     FINITE CUT-OFF CORRECTIONS:

      IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

c     CALL DCOFUN(X,PIM,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      CALL DCOFUN(X,AMPI,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FI = FI + DFIC0

      DFI = DFI + DFIC1

      DDFI = DDFI + DFIC2

      D3FI  = D3FI + DFIC3

      ENDIF

C     ETA:

      CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA)

C     FINITE CUT-OFF CORRECTIONS:

      IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AME,ALMP8,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3)

      FIETA = FIETA + DFIC0*AME/PIM

      DFIETA = DFIETA + DFIC1*AME/PIM

      DDFETA  = DDFETA + DFIC2*AME/PIM

      D3FETA   = D3FETA + DFIC3*AME/PIM

      ENDIF

C     ETAP:

      CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP)

C     FINITE CUT-OFF CORRECTIONS:

      IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AMX,ALMP1,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) 

      FIETP = FIETP + DFIC0*AMX/PIM

      DFIETP = DFIETP + DFIC1*AMX/PIM

      DDFETP  = DDFETP + DFIC2*AMX/PIM

      D3FETP   = D3FETP + DFIC3*AMX/PIM

      ENDIF

  

C     KAON:

c*    CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA)

      CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA)

C     FINITE CUT-OFF CORRECTIONS:

      IF(AKMAX.NE.0.D0.AND.X.LT.XKMAX) THEN

      CALL DCOFUN(X,AMK,ALMKA,AKMAX,DFIC0,DFIC1,DFIC2,DFIC3) 

      FIKA = FIKA + DFIC0*AMK/PIM

      DFIKA = DFIKA + DFIC1*AMK/PIM

      DDFKA  = DDFKA + DFIC2*AMK/PIM

      D3FKA   = D3FKA + DFIC3*AMK/PIM

      ENDIF

CC

c     CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR)

      FIRO  = 0.D0

      DFIR  = 0.D0

      DDFIR = 0.D0

      DO 410 JJ=1,2

      CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIRO = FIRO + AVEC(JJ)*FJJ

      DFIR = DFIR  + AVEC(JJ)*DFJJ

 410  DDFIR= DDFIR + AVEC(JJ)*DDFJJ

C     K*(892):

      CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS)

  

      CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO)

  

      CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH)

CC

c     CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1)



CC    CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP)

      FIEP  = 0.D0

      DFIEP = 0.D0

      DDFIEP= 0.D0

      DO 510 JJ=1,2

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIEP = FIEP + ASIG(JJ)*FJJ

      DFIEP= DFIEP + ASIG(JJ)*DFJJ

 510  DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ

C     S*:

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST)



C     POMERON:

      XPOM = X*AMPOM/PIM0

      FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2*

     .       FDEXP(-XPOM*XPOM)

      DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO

      DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0)



C------------------------------------------------------------

C

C     CONSTRUCTION OF THE POTENTIALS

C

C------------------------------------------------------------

C A)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :

C

      IF(IPIPI0.NE.0) THEN

      DO 10 II=1,3

      GOTO(11,12,13),II



C     PI-PI(I=0):

11    FFUN1 = 0.5D0*DFI*DFI

c     CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMPI,ALMP8,ALMP8,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*FACIP

c     VCNN     =   VCNN    + FACT*(

c    .             6*GSPAIR*F1**2*FFUN1 + 3*GSPAIR**2*FFUN2 )*FACIP

      IMES = 1

      GOTO 14



C     ETA-ETA:

12    FFUN1 = 0.5D0*DFIETA*DFIETA

      CALL HFUN(0,X,AME,AME,ALMP8,ALMP8,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*FACIP

      IMES = 3

      GOTO 14



C     KA-KA(I=0):

13    FFUN1 = 0.5D0*DFIKA*DFIKA

c*    CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)

      IMES = 2

      GOTO 14



 14   CONTINUE

      VCLL     =   VCLL    + FACT*(

     .             CCPR1(II,2)*FFUN1 + CCPR1(II,7 )*FFUN2 )

      VCSS     =   VCSS    + FACT*(

     .             CCPR1(II,4)*FFUN1 + CCPR1(II,9 )*FFUN2 )

      VCDR     =   VCDR    + FACT*(

     .             CCPR1(II,5)*FFUN1 + CCPR1(II,10)*FFUN2 )



      VPRA(1,1,IMES,IMES) = VPRA(1,1,IMES,IMES) +  FACT*(

     .             CCPR1(II,1)*FFUN1 + CCPR1(II,6 )*FFUN2 )

      VPRA(2,1,IMES,IMES) = VPRA(2,1,IMES,IMES) +  FACT*(

     .             CCPR1(II,2)*FFUN1 + CCPR1(II,7 )*FFUN2 )

      VPRA(4,1,IMES,IMES) = VPRA(4,1,IMES,IMES) +  FACT*(

     .             CCPR1(II,4)*FFUN1 + CCPR1(II,9 )*FFUN2 )

      VPRA(5,1,IMES,IMES) = VPRA(5,1,IMES,IMES) +  FACT*(

     .             CCPR1(II,5)*FFUN1 + CCPR1(II,10)*FFUN2 )

10    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(1,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(1,x,p)

      ENDIF

C

C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(IPIET.NE.0) THEN

c     DO 20 II=1,7    ! zie verschil met xnpairs: ii=1,10!

c     GOTO(21,22,23,24,25,26,27),II

c*    DO 20 III=1,10

      DO 20 III=1,7  

      II = III

      GOTO(21,22,23,24,25,26,27,21,23,24),III

      II = III

C     PI-ETA:

21    FFUN1 = 0.5D0*DFI*DFIETA

c     CALL HFUN(0,X,PIM,AME,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AME,ALMP8,ALMP8,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)

      FFSO1 = 0.D0

      if(iii.eq.1) then

      IMES1 = 1

      IMES2 = 3

      endif

      if(iii.eq.8) then

      IMES1 = 3

      IMES2 = 1

      endif

      ii = 1

      GOTO 28



C     KA-KA(8S)(I=1):

22    FFUN1 = 0.5D0*DFIKA*DFIKA

c*    CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)

      FFSO1 = 0.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 28



C     PI-KA(8s):

23    FFUN1 = 0.5D0*DFI*DFIKA*P

c*    CALL HFUN(0,X,PIM,AMK,ALMP8,ALMP8,0.D0,FUN)

c     CALL HFUN(0,X,PIM,AMK,ALMP8,ALMKA,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMK,ALMP8,ALMKA,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*P

      FFSO1 = -X1*DFI*FIKA*P

      if(iii.eq.3) then

      IMES1 = 1

      IMES2 = 2

      endif

      if(iii.eq.9) then

      IMES1 = 2

      IMES2 = 1

      endif

      ii = 3

      GOTO 28



C     ETA-KA(8s):

24    FFUN1 = 0.5D0*DFIETA*DFIKA*P

c*    CALL HFUN(0,X,AME,AMK,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AME,AMK,ALMP8,ALMKA,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*P

      FFSO1 = -X1*DFIETA*FIKA*P

      if(iii.eq.4) then

      IMES1 = 2

      IMES2 = 3

      endif

      if(iii.eq.10) then

      IMES1 = 3

      IMES2 = 2

      endif

      ii = 4

      GOTO 28



C     PI-PI(8S)(I=0):

25    FFUN1 = 0.5D0*DFI*DFI

c     CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMPI,ALMP8,ALMP8,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*FACIP

c*    FFUN2 = -0.5D0*FUN(1)

      FFSO1 = 0.D0

      IMES1 = 1

      IMES2 = 1

      GOTO 28



C     ETA-ETA(8s):

26    FFUN1 = 0.5D0*DFIETA*DFIETA

      CALL HFUN(0,X,AME,AME,ALMP8,ALMP8,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*FACIP

c*    FFUN2 = -0.5D0*FUN(1)

      FFSO1 = 0.D0

      IMES1 = 3

      IMES2 = 3

      GOTO 28



C     KA-KA(8S)(I=0):

27    FFUN1 = 0.5D0*DFIKA*DFIKA

c*    CALL HFUN(0,X,AMK,AMK,ALMP8,ALMP8,0.D0,FUN)

      CALL HFUN(0,X,AMK,AMK,ALMKA,ALMKA,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)

      FFSO1 = 0.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 28



 28   CONTINUE



      VCNN   =   VCNN    + FACT*(

     .           CCPR2(II,1)*FFUN1 + CCPR2(II,6)*FFUN2 )

      VCLL   =   VCLL    + FACT*(

     .           CCPR2(II,2)*FFUN1 + CCPR2(II,7)*FFUN2 )

      VCLS   =   VCLS    + FACT*(

     .           CCPR2(II,3)*FFUN1 + CCPR2(II,8)*FFUN2 )

      VCSS   =   VCSS    + FACT*(

     .           CCPR2(II,4)*FFUN1 + CCPR2(II,9)*FFUN2 )

      VCDR   =   VCDR    + FACT*(

     .           CCPR2(II,5)*FFUN1 + CCPR2(II,10)*FFUN2 )



c*    if(x.le.0.05d0) write(*,*) 'ipiet: ii=',ii,' x=',x,

c*   .' vcdr=',vcdr,' vcnn=',vcnn

c*    if(x.le.0.05d0) write(*,*) 'ffun1=',ffun1             



      VPRB(1,1,IMES1,IMES2) = VPRB(1,1,IMES1,IMES2) +  FACT*(

     .           CCPR2(II,1)*FFUN1 + N2PR0*CCPR2(II,6)*FFUN2 )

      VPRB(2,1,IMES1,IMES2) = VPRB(2,1,IMES1,IMES2) +  FACT*(

     .           CCPR2(II,2)*FFUN1 + N2PR0*CCPR2(II,7)*FFUN2 )

      VPRB(3,1,IMES1,IMES2) = VPRB(3,1,IMES1,IMES2) +  FACT*(

     .           CCPR2(II,3)*FFUN1 + N2PR0*CCPR2(II,8)*FFUN2 )

      VPRB(4,1,IMES1,IMES2) = VPRB(4,1,IMES1,IMES2) +  FACT*(

     .           CCPR2(II,4)*FFUN1 + N2PR0*CCPR2(II,9)*FFUN2 )

      VPRB(5,1,IMES1,IMES2) = VPRB(5,1,IMES1,IMES2) +  FACT*(

     .           CCPR2(II,5)*FFUN1 + N2PR0*CCPR2(II,10)*FFUN2 )

20    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(2,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(2,x,p)

      ENDIF



C     PI-ETA':

c     IF(IPIETP.EQ.1) THEN

c     VC    =   VC + FACT*ISFAC*GPIETP*(

c    .               2*FP*FETAP*DFI*DFIETP-0.5D0*GPIETP*FIPEP2)

c     ENDIF

C

C C)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :

C

C     FOR IDENTICAL MESONS, WE HERE APPLY FACID=1.0D0!!

c     for non-identical mesons, we add a factor 2: P*2!

C

      IF(IPIPI1.NE.0) THEN

c*    ALM1 = ALMP8

c*    ALM2 = ALMP8

c*    DO 30 II=1,9

      DO 30 II=1,6

      GOTO(31,32,33,34,341,35,33,34,341),II

C     PI-PI(I=1):

c31    AM1 = PIM

c      AM2 = PIM

31    AM1 = AMPI

      AM2 = AMPI

      ALM1= ALMP8

      ALM2= ALMP8

      FFSIG1 = 0.5D0*X1*DFI*(X1*DFI+2*DDFI)*(PIM0/AMPRO)

      FFTEN1 = 0.5D0*X1*DFI*(X1*DFI-1*DDFI)*(PIM0/AMPRO)

      FFSO1  = X2*DFI*DFI*PIM0/AMPRO/2.D0

c     PEX = 1.D0

      PEX = FACID

      IMES1 = 1

      IMES2 = 1

      GOTO 36



C     KA-KA(8A)(I=1):

32    AM1 = AMK

      AM2 = AMK

      ALM1= ALMKA

      ALM2= ALMKA

      FFSIG1 = 0.5D0*X1*DFIKA*(X1*DFIKA+2*DDFKA)*(PIM0/AMPRO)

      FFTEN1 = 0.5D0*X1*DFIKA*(X1*DFIKA-1*DDFKA)*(PIM0/AMPRO)

      FFSO1  = X2*DFIKA*DFIKA*PIM0/AMPRO/2.D0

c     PEX = 1.D0

      PEX = FACID

      IMES1 = 2

      IMES2 = 2

      GOTO 36



C     PI-KA(8a):

c33   AM1 = PIM

33    AM1 = AMPI

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FFSIG1 = 0.5D0*X1*(X1*DFI*DFIKA+DFI*DDFKA

     .          + DDFI*DFIKA )*(PIM0/AMPRO)

      FFTEN1 = 0.25D0*X1*(2*X1*DFI*DFIKA-DFI*DDFKA

     .          - DDFI*DFIKA )*(PIM0/AMPRO)

      FFSO1  = X2*DFI*DFIKA*PIM0/AMPRO/2.D0

      PEX = P*2

      IF(II.EQ.3) THEN

      IMES1 = 1

      IMES2 = 2

      ENDIF

      IF(II.EQ.7) THEN

      IMES1 = 2

      IMES2 = 1

      ENDIF

      GOTO 36



C     ETA-KA(8a):

34    AM1 = AME

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FFSIG1 = 0.5D0*X1*(X1*DFIETA*DFIKA+DFIETA*DDFKA

     .          + DDFETA*DFIKA )*(PIM0/AMPRO)

      FFTEN1 = 0.25D0*X1*(2*X1*DFIETA*DFIKA-DFIETA*DDFKA

     .          - DDFETA*DFIKA)*(PIM0/AMPRO)

      FFSO1  = X2*DFIETA*DFIKA*PIM0/AMPRO/2.D0

      PEX = P*2

      IF(II.EQ.4) THEN

      IMES1 = 3

      IMES2 = 2

      ENDIF

      IF(II.EQ.8) THEN

      IMES1 = 2

      IMES2 = 3

      ENDIF

      GOTO 36



C     ETAP-KA(8a):

341   AM1 = AMX

      AM2 = AMK

      ALM1= ALMP1

      ALM2= ALMKA

      FFSIG1 = 0.5D0*X1*(X1*DFIETP*DFIKA+DFIETP*DDFKA

     .          + DDFETP*DFIKA )*(PIM0/AMPRO)

      FFTEN1 = 0.25D0*X1*(2*X1*DFIETP*DFIKA-DFIETP*DDFKA

     .          - DDFETP*DFIKA)*(PIM0/AMPRO)

      FFSO1  = X2*DFIETP*DFIKA*PIM0/AMPRO/2.D0

      PEX = P*2

      IF(II.EQ.5) THEN

      IMES1 = 4

      IMES2 = 2

      ENDIF

      IF(II.EQ.9) THEN

      IMES1 = 2

      IMES2 = 4

      ENDIF

      GOTO 36



C     KA-KA(8A)(I=0):

35    AM1 = AMK

      AM2 = AMK

      ALM1= ALMKA

      ALM2= ALMKA

      FFSIG1 = 0.5D0*X1*(X1*DFIKA*DFIKA+2*DFIKA*DDFKA)*(PIM0/AMPRO)

      FFTEN1 = 0.5D0*X1*(X1*DFIKA*DFIKA-1*DFIKA*DDFKA)*(PIM0/AMPRO)

      FFSO1  = X2*DFIKA*DFIKA*PIM0/AMPRO/2.D0

      PEX = FACID

      IMES1 = 2

      IMES2 = 2

      GOTO 36



36    FFSIG1 = FFSIG1*PEX

      FFTEN1 = FFTEN1*PEX

      FFSO1  = FFSO1*PEX    ! was ik vergeten !!

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      FGCEN1 = 0.5D0*FUN(4)*PEX

      CALL FFUN(0,X,AM1,ALM1,FI10,DFI10,DDFI10,D3FI10)

      CALL FFUN(1,X,AM1,ALM1,FI11,DFI11,DDFI11,D3FI11)

      CALL FFUN(0,X,AM2,ALM2,FI20,DFI20,DDFI20,D3FI20)

      CALL FFUN(1,X,AM2,ALM2,FI21,DFI21,DDFI21,D3FI21)

      CALL HFUN(-1,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      HFUN0 = FUN(1)

      FGCEN2 = -.25D0*(FI11*FI20+FI10*FI21-4*HFUN0)*PEX

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      DA11 = FUN(4)

      DA12 = FUN(8)

      FFSIG2 = -.5D0*X1*(X1*DA11+2*DA12)*(PIM0/AMPRO)**2*PEX

      FFTEN2 = -.5D0*X1*(2*X1*DA11-2*DA12)*(PIM0/AMPRO)**2*PEX



      VCNN  =   VCNN    + FACT*( CCPRG(II,1)*FGCEN1)

c*   .                          +CCPRG(II,6)*FGCEN2 )

      VCLL  =   VCLL    + FACT*( CCPRG(II,2)*FGCEN1)

c*   .                          +CCPRG(II,7)*FGCEN2 )

      VCLS  =   VCLS    + FACT*( CCPRG(II,3)*FGCEN1)

c*   .                          +CCPRG(II,8)*FGCEN2 )

      VCSS  =   VCSS    + FACT*( CCPRG(II,4)*FGCEN1)

c*   .                          +CCPRG(II,9)*FGCEN2 )

      VCDR  =   VCDR    + FACT*( CCPRG(II,5)*FGCEN1)

c*   .                          +CCPRG(II,10)*FGCEN2 )



      VSNN  =   VSNN    - FACT*( CCPRF(II,1)*FFSIG1/3.D0)

c    .                         + CCPRF(II,6)*FFSIG2/3.D0 )

      VSLL  =   VSLL    - FACT*( CCPRF(II,2)*FFSIG1/3.D0)

c    .                         + CCPRF(II,7)*FFSIG2/3.D0 )

      VSLS  =   VSLS    - FACT*( CCPRF(II,3)*FFSIG1/3.D0)

c    .                         + CCPRF(II,8)*FFSIG2/3.D0 )

      VSSS  =   VSSS    - FACT*( CCPRF(II,4)*FFSIG1/3.D0)

c    .                         + CCPRF(II,9)*FFSIG2/3.D0 )

      VSDR  =   VSDR    - FACT*( CCPRF(II,5)*FFSIG1/3.D0)

c    .                         + CCPRF(II,10)*FFSIG2/3.D0 )



      VTNN  =   VTNN    - FACT*( CCPRF(II,1)*FFTEN1/3.D0)

c    .                         + CCPRF(II,6)*FFTEN2/3.D0 )

      VTLL  =   VTLL    - FACT*( CCPRF(II,2)*FFTEN1/3.D0)

c    .                         + CCPRF(II,7)*FFTEN2/3.D0 )

      VTLS  =   VTLS    - FACT*( CCPRF(II,3)*FFTEN1/3.D0)

c    .                         + CCPRF(II,8)*FFTEN2/3.D0 )

      VTSS  =   VTSS    - FACT*( CCPRF(II,4)*FFTEN1/3.D0)

c    .                         + CCPRF(II,9)*FFTEN2/3.D0 )

      VTDR  =   VTDR    - FACT*( CCPRF(II,5)*FFTEN1/3.D0)

c    .                         + CCPRF(II,10)*FFTEN2/3.D0 )



      VONN  =   VONN    - FACT*( CCPRG(II,1)*FFSO1)        

      VOLL  =   VOLL    - FACT*( CCPRG(II,2)*FFSO1)        

      VOLS  =   VOLS    - FACT*( CCPRG(II,3)*FFSO1)       

      VOSS  =   VOSS    - FACT*( CCPRG(II,4)*FFSO1)       

      VODR  =   VODR    - FACT*( CCPRG(II,5)*FFSO1)       



c     if(x.le.0.05d0) then

c     write(*,*) 'ynpair: ii=',ii,' x=',x,

c    .' vcnn,vcdr=',vcnn,vcdr,' vonn,vodr=',vonn,vodr

c     write(*,*) ' fgcen1=',fgcen1,' ccprg=',ccprg(ii,1),' vcnn=',vcnn

c     endif

c     write(*,*) 'ratco=',fgcen1/ffso1,' vc/vo(nn)=',vcnn/vonn,

c    . ' vc/vo(dr)=',vcdr/vodr

c*    write(*,*) 'ynpair: ii=',ii,' x=',x,

c*   .' vcnn,vcdr=',vcnn,vcdr,' vsnn,vsdr=',vsnn,vsdr

c     write(*,*) 'ratcs=',fgcen1/ffsig1,

c    .' vc/vs(nn)=',vcnn/vsnn,' vc/vs(dr)=',vcdr/vsdr

c     write(*,*) ' ccprg1-5=',ccprg(ii,1),ccprg(ii,2),ccprg(ii,3),

c    .ccprg(ii,4),ccprg(ii,5)

c     write(*,*) ' ccprg6- =',ccprg(ii,6),ccprg(ii,7),ccprg(ii,8),

c    .ccprg(ii,9),ccprg(ii,10)

c     write(*,*) ' ccprf1-5=',ccprf(ii,1),ccprf(ii,2),ccprf(ii,3),

c    .ccprf(ii,4),ccprf(ii,5)

c     write(*,*) ' ccprf6- =',ccprf(ii,6),ccprf(ii,7),ccprf(ii,8),

c    .ccprf(ii,9),ccprf(ii,10)

c*    endif



      VPRC(1,1,IMES1,IMES2) = VPRC(1,1,IMES1,IMES2) +  FACT*(

     .                        CCPRG(II,1)*FGCEN1 +CCPRG(II,6)*FGCEN2 )

      VPRC(2,1,IMES1,IMES2) = VPRC(2,1,IMES1,IMES2) +  FACT*(

     .                        CCPRG(II,2)*FGCEN1 +CCPRG(II,7)*FGCEN2 )

      VPRC(3,1,IMES1,IMES2) = VPRC(3,1,IMES1,IMES2) +  FACT*(

     .                        CCPRG(II,3)*FGCEN1 +CCPRG(II,8)*FGCEN2 )

      VPRC(4,1,IMES1,IMES2) = VPRC(4,1,IMES1,IMES2) +  FACT*(

     .                        CCPRG(II,4)*FGCEN1 +CCPRG(II,9)*FGCEN2 )

      VPRC(5,1,IMES1,IMES2) = VPRC(5,1,IMES1,IMES2) +  FACT*(

     .                        CCPRG(II,5)*FGCEN1 +CCPRG(II,10)*FGCEN2 )



      VPRC(1,2,IMES1,IMES2) = VPRC(1,2,IMES1,IMES2) -  FACT*(

     .                                 CCPRF(II,1)*FFSIG1/3.D0 )

c    .                               + CCPRF(II,6)*FFSIG2/3.D0 )

      VPRC(2,2,IMES1,IMES2) = VPRC(2,2,IMES1,IMES2) -  FACT*(

     .                                 CCPRF(II,2)*FFSIG1/3.D0 )

c    .                               + CCPRF(II,7)*FFSIG2/3.D0 )

      VPRC(3,2,IMES1,IMES2) = VPRC(3,2,IMES1,IMES2) -  FACT*(

     .                                 CCPRF(II,3)*FFSIG1/3.D0 )

c    .                               + CCPRF(II,8)*FFSIG2/3.D0 )

      VPRC(4,2,IMES1,IMES2) = VPRC(4,2,IMES1,IMES2) -  FACT*(

     .                                 CCPRF(II,4)*FFSIG1/3.D0 )

c    .                               + CCPRF(II,9)*FFSIG2/3.D0 )

      VPRC(5,2,IMES1,IMES2) = VPRC(5,2,IMES1,IMES2) -  FACT*(

     .                                 CCPRF(II,5)*FFSIG1/3.D0 )

c    .                               + CCPRF(II,10)*FFSIG2/3.D0 )



30    CONTINUE

      if(icall.eq.0.and.nschr.eq.1) call writepr(3,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(3,x,p)

      ENDIF

C

C 3)  AXIAL PAIR TERMS OF THE FIRST CLASS:

C

      IF(IPIRO1.NE.0) THEN

c*    ALM1 = ALMP8

      ALM2 = ALMV8

      DO 40 II=1,9

      FMASO1= 0.D0

      FMASO2= 0.D0

      FACISC= 0.D0

      GOTO(41,42,43,44,488,45,46,47,49),II



C     PI-RHO(I=1):

41    FMSIG1= 0.5D0* (2*X1*DFI+DDFI)*FIRO

      FESIG1= 0.5D0* DFI*DFIR

      FMTEN1= 0.5D0* (-X1*DFI+DDFI)*FIRO

c     AM1 = PIM

      AM1 = AMPI

      AM2 = AMRO

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 1

      IMES2 = 1

      GOTO 48



C     KA-K*(AXIAL)(I=1):

42    FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS

      FESIG1= 0.5D0* DFIKA*DFIKS

      FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIKS

      AM1 = AMK

      AM2 = AMKS

      ALM1= ALMKA

      PEX = 1.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 48



C     PI-K*(AXIAL):

43    FMSIG1= 0.5D0* (2*X1*DFI+DDFI)*FIKS*P

      FESIG1= 0.5D0* DFI*DFIKS*P

      FMTEN1= 0.5D0* (-X1*DFI+DDFI)*FIKS*P

c     AM1 = PIM

      AM1 = AMPI

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      IMES1 = 1

      IMES2 = 2

      GOTO 48



C     ETA-K*(AXIAL):

44    FMSIG1= 0.5D0* (2*X1*DFIETA+DDFETA)*FIKS*P

      FESIG1= 0.5D0* DFIETA*DFIKS*P

      FMTEN1= 0.5D0* (-X1*DFIETA+DDFETA)*FIKS*P

      AM1 = AME

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      IMES1 = 3

      IMES2 = 2

      GOTO 48



C     ETA'-K*(AXIAL):

488   FMSIG1= 0.5D0* (2*X1*DFIETP+DDFETP)*FIKS*P

      FESIG1= 0.5D0* DFIETP*DFIKS*P

      FMTEN1= 0.5D0* (-X1*DFIETP+DDFETP)*FIKS*P

      AM1 = AMX

      AM2 = AMKS

      ALM1= ALMP1

      PEX = P

      IMES1 = 4

      IMES2 = 2

      GOTO 48



C     KA-K*(AXIAL)(I=0):

45    FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS

      FESIG1= 0.5D0* DFIKA*DFIKS

      FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIKS

      AM1 = AMK

      AM2 = AMKS

      ALM1= ALMKA

      PEX = 1.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 48



C     KA-RO(AXIAL):

46    FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIRO*P

      FESIG1= 0.5D0* DFIKA*DFIR*P

      FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIRO*P

      AM1 = AMK

      AM2 = AMRO

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 1

      GOTO 48



C     KA-PHI(AXIAL):

47    FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIPH*P

      FESIG1= 0.5D0* DFIKA*DFIPH*P

      FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIPH*P

      AM1 = AMK

      AM2 = AMFI

      ALM1= ALMKA

      ALM2= ALMV8

      PEX = P

      IMES1 = 2

      IMES2 = 3

      GOTO 48



C     KA-OMEGA(AXIAL):

49    FMSIG1= 0.5D0* (2*X1*DFIKA+DDFKA)*FIOM*P

      FESIG1= 0.5D0* DFIKA*DFIOM*P

      FMTEN1= 0.5D0* (-X1*DFIKA+DDFKA)*FIOM*P

      AM1 = AMK

      AM2 = AMOM

      ALM1= ALMKA

      ALM2= ALMV1

      PEX = P

      IMES1 = 2

      IMES2 = 4

      GOTO 48



48    FFSIG1 = FMSIG1

      FFTEN1 = FMTEN1

      FETEN1 = FESIG1

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      FFSIG2 = -.5D0*FUN(1)*PEX



c     if(x.lt.0.05d0) then

c     write(*,*) ' in ynpairs: ii,x=',ii,x,' am1,am2=',am1,am2,    

c    .' alm1,alm2=',alm1,alm2

c     write(*,*) ' ffsig1,fften1,feten1,ffsig2=',

c    .             ffsig1,fften1,feten1,ffsig2

c     endif



c     if(ii.eq.3) then

c     vsig3  = 2*fact*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 

c    .          *(pim0/amn/6d0)

c     write(*,*) 'YNPAIR: II=',ii,' vsig3  =',vsig3  

c     endif



      VSNN   =   VSNN    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFSIG1

     .             -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 )

     .             - CCPR4(II,6)*FFSIG2 )

      VSLL   =   VSLL    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFSIG1

     .             -2*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 )

     .             - CCPR4(II,7)*FFSIG2 )

      VSLS   =   VSLS    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFSIG1

     .             -2*(CCPR4(II,3)+CCPR4F(II,3))*FESIG1 )

     .             - CCPR4(II,8)*FFSIG2 )

      VSSS   =   VSSS    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFSIG1

     .             -2*(CCPR4(II,4)+CCPR4F(II,4))*FESIG1 )

     .             - CCPR4(II,9)*FFSIG2 )

      VSDR   =   VSDR    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFSIG1

     .             -2*(CCPR4(II,5)+CCPR4F(II,5))*FESIG1 )

     .             - CCPR4(II,10)*FFSIG2 )



      VTNN   =   VTNN    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFTEN1

     .              + (CCPR4(II,1)+CCPR4F(II,1))*FETEN1 ))

      VTLL   =   VTLL    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFTEN1

     .              + (CCPR4(II,2)+CCPR4F(II,2))*FETEN1 ))

      VTLS   =   VTLS    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFTEN1

     .              + (CCPR4(II,3)+CCPR4F(II,3))*FETEN1 ))

      VTSS   =   VTSS    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFTEN1

     .              + (CCPR4(II,4)+CCPR4F(II,4))*FETEN1 ))

      VTDR   =   VTDR    - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFTEN1

     .              + (CCPR4(II,5)+CCPR4F(II,5))*FETEN1 ))



      VPRD(1,2,IMES1,IMES2) = VPRD(1,2,IMES1,IMES2) - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,1)*FFSIG1

     .             -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 )

     .             - CCPR4(II,6)*FFSIG2 )

      VPRD(2,2,IMES1,IMES2) = VPRD(2,2,IMES1,IMES2) - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,2)*FFSIG1

     .             -2*(CCPR4(II,2)+CCPR4F(II,2))*FESIG1 )

     .             - CCPR4(II,7)*FFSIG2 )

      VPRD(3,2,IMES1,IMES2) = VPRD(3,2,IMES1,IMES2) - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,3)*FFSIG1

     .             -2*(CCPR4(II,3)+CCPR4F(II,3))*FESIG1 )

     .             - CCPR4(II,8)*FFSIG2 )

      VPRD(4,2,IMES1,IMES2) = VPRD(4,2,IMES1,IMES2) - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,4)*FFSIG1

     .             -2*(CCPR4(II,4)+CCPR4F(II,4))*FESIG1 )

     .             - CCPR4(II,9)*FFSIG2 )

      VPRD(5,2,IMES1,IMES2) = VPRD(5,2,IMES1,IMES2) - FACT*(

     .              (PIM0/AMN/6.D0)*( CCPR4(II,5)*FFSIG1

     .             -2*(CCPR4(II,5)+CCPR4F(II,5))*FESIG1 )

     .             - CCPR4(II,10)*FFSIG2 )



c     if(x.le.0.05d0) then

c     write(*,*) 'ccpr4(ii,1),ccpr4f(ii,1)=',ccpr4(ii,1),ccpr4f(ii,1)

c     write(*,*) 'ccpr4(ii,2),ccpr4f(ii,2)=',ccpr4(ii,2),ccpr4f(ii,2)

c     write(*,*) 'ccpr4(ii,3),ccpr4f(ii,3)=',ccpr4(ii,3),ccpr4f(ii,3)

c     write(*,*) 'ccpr4(ii,4),ccpr4f(ii,4)=',ccpr4(ii,4),ccpr4f(ii,4)

c     write(*,*) 'ccpr4(ii,5),ccpr4f(ii,5)=',ccpr4(ii,5),ccpr4f(ii,5)

c     write(*,*) 'ynpair: ii=',ii,' x=',x,

c    .' vsnn,vsdr=',vsnn,vsdr,' vtnn,vtdr=',vtnn,vtdr

c     endif



40    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(4,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(4,x,p)

      ENDIF



C

C 4)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

c     IF(IPIRO0.EQ.1) THEN

c     VSIG  =   VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2

c    .      -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) )

c

c     VTEN  =   VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2

c    .      -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) )

c     ENDIF

C

C 5)  AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :

c     IF(IPIOM.EQ.1) THEN

c     IF(HOPAIR.NE.0.D0) THEN

c     VSIG  =   VSIG  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     VTEN  =   VTEN  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     ENDIF

c     ENDIF

C------------------------------------------------------------

C

C E)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

C------------------------------------------------------------

C     HERE: ETA8 = ETA(548) (THPS IS SMALL), 

C           PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019)

C------------------------------------------------------------

      IF(IPIOM.EQ.2) THEN

c**   DO 90 II=IIMIN,10

      DO 90 II=1,13

      PEX = 1.D0

      FFSO1 = 0.D0

      copln = 0d0

      GOTO(91,911,92,93,94,95,96,97,971,98,981,991,992),II



C     PI-OMEGA  

91    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIOM+DFI*DFIOM)*WGHTID(1)

      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIOM+DFI*DFIOM)*WGHTID(1)

c     CALL HFUN(0,X,PIM,AMOM,ALMP8,ALMV1,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMOM,ALMP8,ALMV1,0.D0,FUN)

      GOTO 990

C     PI-PHI:   

911   FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIPH+DFI*DFIPH)*WGHTID(2)

      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIPH+DFI*DFIPH)*WGHTID(2)

c     CALL HFUN(0,X,PIM,AMFI,ALMP8,ALMV8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMFI,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 1

      IMES2 = 3

      GOTO 990



C     ETA-RHO:   

92    FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIRO+DFIETA*DFIR )

      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIRO+DFIETA*DFIR )

      CALL HFUN(0,X,AME,AMRO,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 3

      IMES2 = 1

      GOTO 990



C     KA-K*(8S)(I=1):

93    FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS )

      FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS )

      CALL HFUN(0,X,AMK,AMKS,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 2

      IMES2 = 2

      GOTO 990



C     PI-K*(8S):

94    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIKS+DFI*DFIKS )*P

      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIKS+DFI*DFIKS )*P

c     CALL HFUN(0,X,PIM,AMKS,ALMP8,ALMV8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMKS,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 1

      IMES2 = 2

      PEX = P

      GOTO 990



C     KA-RHO(8S)(I=1):

95    FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIRO+DFIKA*DFIR )*P

      FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIRO+DFIKA*DFIR )*P

      CALL HFUN(0,X,AMK,AMRO,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 2

      IMES2 = 1

      PEX = P

      FFSO1 = -X1*DFIR*VKU*P

      copln = 1*prpo1(4)*f(4)*(fd(1)+fv(1))

      GOTO 990



C     ETA-K*:    

96    FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIKS+DFIETA*DFIKS )*P

      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIKS+DFIETA*DFIKS )*P

      CALL HFUN(0,X,AME,AMKS,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 3

      IMES2 = 2

      PEX = P

      GOTO 990



C     KA-PHI8:  

C     KA-OMEGA:

97    FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIOM+DFIKA*DFIOM)

     .*WGHTID(1)*P

      FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIOM+DFIKA*DFIOM)

     .*WGHTID(1)*P

      CALL HFUN(0,X,AMK,AMOM,ALMP8,ALMV1,0.D0,FUN)

      PEX = P

      FFSO1 = -X1*DFIOM*VKU*P

      copln = 1*prpo1(4)*f(4)*(fd(6)+fv(6))

      GOTO 990



C     KA-PHI:   

971   FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIPH+DFIKA*DFIPH)

     .*WGHTID(2)*P

      FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIPH+DFIKA*DFIPH)

     .*WGHTID(2)*P

      CALL HFUN(0,X,AMK,AMFI,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 2

      IMES2 = 3

      PEX = P

      FFSO1 = -X1*DFIPH*VKU*P

      copln = 1*prpo1(4)*f(4)*(fd(9)+fv(9))

      GOTO 990



C     PI-RHO(8S)(I=0):

98    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIRO+DFI*DFIR )

      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIRO+DFI*DFIR )

c     CALL HFUN(0,X,PIM,AMRO,ALMP8,ALMV8,0.D0,FUN)

      CALL HFUN(0,X,AMPI,AMRO,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 1

      IMES2 = 1

      GOTO 990



C     KA-K*(8S)(I=0):

981   FFSIG1= -0.5D0*((2*X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS )

      FFTEN1= -0.5D0*(( -X1*DFIKA+DDFKA)*FIKS+DFIKA*DFIKS )

      CALL HFUN(0,X,AMK,AMKS,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 2

      IMES2 = 2

      GOTO 990



C     ETA-OMEGA(8s):

991   FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM)

     .*WGHTID(1)

      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM)

     .*WGHTID(1)

      CALL HFUN(0,X,AME,AMOM,ALMP8,ALMV1,0.D0,FUN)

      GOTO 990



C     ETA-PHI(8s):

992   FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH)

     .*WGHTID(2)

      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH)

     .*WGHTID(2)

      CALL HFUN(0,X,AME,AMFI,ALMP8,ALMV8,0.D0,FUN)

      IMES1 = 3

      IMES2 = 3

      GOTO 990



990   FFSIG2 = -0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) +2*FUN(4) )*PEX

      FFTEN2 = -0.5D0*( (-X1*FUN(2)+FUN(5))

     .                  +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )*PEX



c !!! note: checked with nnpairs.f -> reason 'extra' factor 4 ->    !!!!!

c !!! note: NO EXTRA FACTOR HERE:

      UFAC0=4.D0      ! old, factor 2 overshoot a la NN-program!

c*    UFAC0=2.D0      ! -> the correct factor!

c*    UFAC0=1.D0      ! new,check!!

c*    if(icall.eq.0) write(6,*) ' ynpairs.02.f: UFAC0=',ufac0,' !!!!!'



      VSNN   =   VSNN    + FACT*(UFAC0*

     .           CCPR10(II,1)*FFSIG1 + CCPR10(II,6)*FFSIG2 )/3.D0

      VSLL   =   VSLL    + FACT*(UFAC0*

     .           CCPR10(II,2)*FFSIG1 + CCPR10(II,7)*FFSIG2 )/3.D0

      VSLS   =   VSLS    + FACT*(UFAC0*

     .           CCPR10(II,3)*FFSIG1 + CCPR10(II,8)*FFSIG2 )/3.D0

      VSSS   =   VSSS    + FACT*(UFAC0*

     .           CCPR10(II,4)*FFSIG1 + CCPR10(II,9)*FFSIG2 )/3.D0

      VSDR   =   VSDR    + FACT*(UFAC0*

     .           CCPR10(II,5)*FFSIG1 + CCPR10(II,10)*FFSIG2 )/3.D0



      VTNN   =   VTNN    + FACT*(UFAC0*

     .           CCPR10(II,1)*FFTEN1 + CCPR10(II,6)*FFTEN2 )/3.D0

      VTLL   =   VTLL    + FACT*(UFAC0*

     .           CCPR10(II,2)*FFTEN1 + CCPR10(II,7)*FFTEN2 )/3.D0

      VTLS   =   VTLS    + FACT*(UFAC0*

     .           CCPR10(II,3)*FFTEN1 + CCPR10(II,8)*FFTEN2 )/3.D0

      VTSS   =   VTSS    + FACT*(UFAC0*

     .           CCPR10(II,4)*FFTEN1 + CCPR10(II,9)*FFTEN2 )/3.D0

      VTDR   =   VTDR    + FACT*(UFAC0*

     .           CCPR10(II,5)*FFTEN1 + CCPR10(II,10)*FFTEN2 )/3.D0



c     VALL   =   VALL + 2*FACT* copln*FFSO1*PIM0**2/AMN/(AMLAM+AMN) 

c     write(*,*) ' ynpairs, piom: ii=',ii,' copln=',copln,

c    .' prpo1(4)=',prpo1(4)

c     write(*,*) ' FFSO1=',FFSO1,' vall=',vall



      VPRH(1,2,IMES1,IMES2) = VPRH(1,2,IMES1,IMES2) + FACT*(

     .           1*CCPR10(II,1)*FFSIG1 + CCPR10(II,6)*FFSIG2 )/3.D0

      VPRH(2,2,IMES1,IMES2) = VPRH(2,2,IMES1,IMES2) + FACT*(

     .           1*CCPR10(II,2)*FFSIG1 + CCPR10(II,7)*FFSIG2 )/3.D0

      VPRH(3,2,IMES1,IMES2) = VPRH(3,2,IMES1,IMES2) + FACT*(

     .           1*CCPR10(II,3)*FFSIG1 + CCPR10(II,8)*FFSIG2 )/3.D0

      VPRH(4,2,IMES1,IMES2) = VPRH(4,2,IMES1,IMES2) + FACT*(

     .           1*CCPR10(II,4)*FFSIG1 + CCPR10(II,9)*FFSIG2 )/3.D0

      VPRH(5,2,IMES1,IMES2) = VPRH(5,2,IMES1,IMES2) + FACT*(

     .           1*CCPR10(II,5)*FFSIG1 + CCPR10(II,10)*FFSIG2 )/3.D0



c     if(x.le.0.05d0) then

c     write(*,*) 'ccpr10(ii,1)=',ccpr10(ii,1),

c    .           'ccpr10(ii,2)=',ccpr10(ii,2)

c     write(*,*) 'ccpr10(ii,3)=',ccpr10(ii,3),

c    .           'ccpr10(ii,4)=',ccpr10(ii,4)

c     write(*,*) 'ccpr10(ii,5)=',ccpr10(ii,5)

c     write(*,*) 'ynpair: ii=',ii,' x=',x,

c    .' vsnn,vsdr=',vsnn,vsdr,' vtnn,vtdr=',vtnn,vtdr

c     write(*,*) 'ratst=',fgsig1/ften1,' vs/vt(nn)=',vsnn/vtnn,

c    . ' vs/vt(dr)=',vsdr/vtdr

c     endif



90    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(8,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) write(37,*) 'ccpr10=',ccpr10        

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(8,x,p)

      ENDIF

C------------------------------------------------------------

C

C 6)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:

      IF(IPISI.NE.0) THEN

      DO 50 II=1,6

      GOTO(51,52,53,54,55,56),II



C     PI-EPSILON:

51    FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIEP -DFI*DFIEP)

      FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIEP -DFI*DFIEP )

c     AM1 = PIM

      AM1 = AMPI

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 1

      IMES2 = 4

      GOTO 57



C     KA-EPSILON:

52    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P

      AM1 = AMK

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 4

      GOTO 57



C     ETA-EPSILON:

53    FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIEP -DFIETA*DFIEP)

      FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIEP -DFIETA*DFIEP )

      AM1 = AME

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 3

      IMES2 = 4

      GOTO 57



C     PI-SSTAR:

54    FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIST -DFI*DFIST)

      FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIST -DFI*DFIST )

c     AM1 = PIM

      AM1 = AMPI

      AM2 = AMSST

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 1

      IMES2 = 3

      GOTO 57



C     KA-SSTAR:

55    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P

      AM1 = AMK

      AM2 = AMSST

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 3

      GOTO 57



C     ETA-SSTAR:

56    FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIST -DFIETA*DFIST)

      FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIST -DFIETA*DFIST )

      AM1 = AME

      AM2 = AMSST

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 3

      IMES2 = 3

      GOTO 57



57    IF(II.LE.3) THEN

      FFSIG2 = 0.D0

      FFTEN2 = 0.D0

      IF(N2PRA.EQ.1) THEN

      DO 112 JJ=1,2

      AM2=AMSIG(JJ)

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN)

      FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

  112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN)

      FFSIG2 =        +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      FFTEN2 =        +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF



      VSNN   =   VSNN    + FACT*(

     .           CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0

      VSLL   =   VSLL    + FACT*(

     .           CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0

      VSLS   =   VSLS    + FACT*(

     .           CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0

      VSSS   =   VSSS    + FACT*(

     .           CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0

      VSDR   =   VSDR    + FACT*(

     .           CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0



      VTNN   =   VTNN    + FACT*(

     .           CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0

      VTLL   =   VTLL    + FACT*(

     .           CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0

      VTLS   =   VTLS    + FACT*(

     .           CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0

      VTSS   =   VTSS    + FACT*(

     .           CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0

      VTDR   =   VTDR    + FACT*(

     .           CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0



c*    if(x.le.0.05d0) write(*,*) 'ipisi: ii=',ii,' x=',x,' vsdr=',vsdr,

c*   .' vcnn=',vsnn

c*    if(x.le.0.05d0) write(*,*) 'ffsig1=',ffsig1                          



      VPRE(1,2,IMES1,IMES2) = + FACT*(

     .           1*CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0

      VPRE(2,2,IMES1,IMES2) = + FACT*(

     .           1*CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0

      VPRE(3,2,IMES1,IMES2) = + FACT*(

     .           1*CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0

      VPRE(4,2,IMES1,IMES2) = + FACT*(

     .           1*CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0

      VPRE(5,2,IMES1,IMES2) = + FACT*(

     .           1*CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0

50    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(5,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(5,x,p)

      ENDIF

C

C     PSEUDO SCALAR (PS-POMERON) PAIR TERMS:

      IF(IPIPOM.NE.0) THEN

      DO 70 II=1,3

      GOTO(71,72,73),II



C     PI-POMERON:

71    FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIPO -DFI*DFIPO)

      FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIPO -DFI*DFIPO )

c     AM1 = PIM

      AM1 = AMPI

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 1

      IMES2 = 4

      GOTO 74



C     KA-POMERON:

72    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIPO -DFIKA*DFIPO)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIPO -DFIKA*DFIPO )*P

      AM1 = AMK

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 4

      GOTO 74



C     ETA-POMERON:

73    FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIPO -DFIETA*DFIPO)

      FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIPO -DFIETA*DFIPO )

      AM1 = AME

      ALM1= ALMP8

      PEX = 1.D0

      IMES1 = 3

      IMES2 = 4

      GOTO 74



74    FFSIG2 = 0.D0

      FFTEN2 = 0.D0

      AM2=AMPOM

      CALL HDIF(0,X,AM1,AM2,ALM1,0.D0,FUN)

      FFSIG2 =         0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      FFTEN2 =         0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX



      VSNN   =   VSNN    - FACT*(

     .           CCPR7(II,1)*FFSIG1 + CCPR7(II,6)*FFSIG2 )/3.D0

      VSLL   =   VSLL    - FACT*(

     .           CCPR7(II,2)*FFSIG1 + CCPR7(II,7)*FFSIG2 )/3.D0

      VSLS   =   VSLS    - FACT*(

     .           CCPR7(II,3)*FFSIG1 + CCPR7(II,8)*FFSIG2 )/3.D0

      VSSS   =   VSSS    - FACT*(

     .           CCPR7(II,4)*FFSIG1 + CCPR7(II,9)*FFSIG2 )/3.D0

      VSDR   =   VSDR    - FACT*(

     .           CCPR7(II,5)*FFSIG1 + CCPR7(II,10)*FFSIG2 )/3.D0



      VTNN   =   VTNN    - FACT*(

     .           CCPR7(II,1)*FFTEN1 + CCPR7(II,6)*FFTEN2 )/3.D0

      VTLL   =   VTLL    - FACT*(

     .           CCPR7(II,2)*FFTEN1 + CCPR7(II,7)*FFTEN2 )/3.D0

      VTLS   =   VTLS    - FACT*(

     .           CCPR7(II,3)*FFTEN1 + CCPR7(II,8)*FFTEN2 )/3.D0

      VTSS   =   VTSS    - FACT*(

     .           CCPR7(II,4)*FFTEN1 + CCPR7(II,9)*FFTEN2 )/3.D0

      VTDR   =   VTDR    - FACT*(

     .           CCPR7(II,5)*FFTEN1 + CCPR7(II,10)*FFTEN2 )/3.D0



      VPRF(1,2,IMES1,IMES2) = - FACT*(

     .           1*CCPR7(II,1)*FFSIG1 + CCPR7(II,6)*FFSIG2 )/3.D0

      VPRF(2,2,IMES1,IMES2) = - FACT*(

     .           1*CCPR7(II,2)*FFSIG1 + CCPR7(II,7)*FFSIG2 )/3.D0

      VPRF(3,2,IMES1,IMES2) = - FACT*(

     .           1*CCPR7(II,3)*FFSIG1 + CCPR7(II,8)*FFSIG2 )/3.D0

      VPRF(4,2,IMES1,IMES2) = - FACT*(

     .           1*CCPR7(II,4)*FFSIG1 + CCPR7(II,9)*FFSIG2 )/3.D0

      VPRF(5,2,IMES1,IMES2) = - FACT*(

     .           1*CCPR7(II,5)*FFSIG1 + CCPR7(II,10)*FFSIG2 )/3.D0

70    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(6,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(6,x,p)

      ENDIF



C

C D)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :

C



C 7)  SCALAR (EPSILON-EPSILON) PAIR TERMS:

      IF(ISISI.NE.0) THEN

C     EPSILON-EPSILON:

      FFUN1 = 0.5D0*FIEP*FIEP

      CALL HFUN(0,X,AMEPS,AMEPS,ALMS1,ALMS1,0.D0,FUN)

      FFUN2 = -0.5D0*FUN(1)*FACIP



      VCNN    = VCNN    +FACT*(CCPR6(6)*FFUN2+CCPR6(1)*FFUN1)

      VCLL    = VCLL    +FACT*(CCPR6(7)*FFUN2+CCPR6(2)*FFUN1)

      VCSS    = VCSS    +FACT*(CCPR6(9)*FFUN2+CCPR6(4)*FFUN1)

      VCDR    = VCDR    +FACT*(CCPR6(10)*FFUN2+CCPR6(5)*FFUN1)

c     if(icall.eq.0.and.nschr.eq.1) then                    

      if(icall.eq.20.and.nschr.eq.1) then                    

      VPRGNN  =         +FACT*(CCPR6(6)*FFUN2+CCPR6(1)*FFUN1)

      VPRGLL  =         +FACT*(CCPR6(7)*FFUN2+CCPR6(2)*FFUN1)

      VPRGSS  =         +FACT*(CCPR6(9)*FFUN2+CCPR6(4)*FFUN1)

      VPRGDR  =         +FACT*(CCPR6(10)*FFUN2+CCPR6(5)*FFUN1)

      write(N3,*) ' EPSILON-EPSILON PAIR-TERMS: x=',x

      write(N3,*) ' VCNN=',vprgnn,' VCDR=',vprgdr

      write(N3,*) ' VCLL=',vprgll,' VCSS=',vprgss

      write(N3,*) '***************************************************'

      endif

      ENDIF

C     --------------------------------------------------------------

C 8)  TENSOR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C     --------------------------------------------------------------

C     only 1-pair terms included!!

      IF(IPIPI2.NE.0) THEN

      DO 80 II=1,7 

      GOTO(81,82,83,84,85,86,87),II

C     PI-ETA:

*81   AM1 = PIM

81    AM1 = AMPI

      AM2 = AME

      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIETA)

     .       +0.5D0*(2*X2*DFI*DFIETA+DDFI*DDFETA)/3.D0

     .       -0.25D0*(1.D0+(AME/PIM)**2)*DFI*DFIETA/3.D0

      IMES1 = 1

      IMES2 = 3

      GOTO 88



C     KA-KA(8S)(I=1):

82    AM1 = AMK 

      AM2 = AMK

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFIKA*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFIKA*DFIKA+DDFKA*DDFKA)/3.D0

     .       -0.5D0*(AMK/PIM)**2*DFIKA*DFIKA/3.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 88



C     PI-KA(8s):

c83   AM1 = PIM 

83    AM1 = AMPI

      AM2 = AMK

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0

      IMES1 = 1

      IMES2 = 2

      GOTO 88



C     ETA-KA(8s):

84    AM1 = AMK 

      AM2 = AME

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0

      IMES1 = 2

      IMES2 = 3

      GOTO 88



C     PI-PI(8S)(I=0):

c85   AM1 = PIM 

c     AM2 = PIM

85    AM1 = AMPI

      AM2 = AMPI

      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFI)

     .       +0.5D0*(2*X2*DFI*DFI+DDFI*DDFI)/3.D0

     .       -0.5D0*DFI*DFI/3.D0

      IMES1 = 1

      IMES2 = 1

      GOTO 88



C     ETA-ETA(8s):

86    AM1 = AME 

      AM2 = AME

      FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIETA)

     .       +0.5D0*(2*X2*DFIETA*DFIETA+DDFETA*DDFETA)/3.D0

     .       -0.5D0*(AME/PIM)**2*DFIETA*DFIETA/3.D0

      IMES1 = 3

      IMES2 = 3

      GOTO 88



C     KA-KA(8S)(I=0):

87    AM1 = AMK 

      AM2 = AMK

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFIKA*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFIKA*DFIKA+DDFKA*DDFKA)/3.D0

     .       -0.5D0*(AMK/PIM)**2*DFIKA*DFIKA/3.D0

      IMES1 = 2

      IMES2 = 2

      GOTO 88



88    IF(II.EQ.2.OR.II.EQ.5) THEN

      CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN)

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN)

      ENDIF

      FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO)

      FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO)

      FSO1  = -X2*FUN(4)*(PIM/AMPRO)



      VCNN   =   VCNN    + ISFAC*FACT* CCPR8(II,1)*FCEN1  

      VSNN   =   VSNN    + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0

      VTNN   =   VTNN    + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0

      VONN   =   VONN    + ISFAC*FACT* CCPR8(II,1)*FSO1 



      VCLL   =   VCLL    + FACT* CCPR8(II,2)*FCEN1  

      VSLL   =   VSLL    + FACT* CCPR8F(II,2)*FSIG1/3.D0

      VTLL   =   VTLL    + FACT* CCPR8F(II,2)*FTEN1/3.D0

      VOLL   =   VOLL    + FACT* CCPR8(II,2)*FSO1 



      VCLS   =   VCLS    + FACT* CCPR8(II,3)*FCEN1  

      VSLS   =   VSLS    + FACT* CCPR8F(II,3)*FSIG1/3.D0

      VTLS   =   VTLS    + FACT* CCPR8F(II,3)*FTEN1/3.D0

      VOLS   =   VOLS    + FACT* CCPR8(II,3)*FSO1 



      VCSS   =   VCSS    + FACT* CCPR8(II,4)*FCEN1  

      VSSS   =   VSSS    + FACT* CCPR8F(II,4)*FSIG1/3.D0

      VTSS   =   VTSS    + FACT* CCPR8F(II,4)*FTEN1/3.D0

      VOSS   =   VOSS    + FACT* CCPR8(II,4)*FSO1 



      VCDR   =   VCDR    + FACT* CCPR8(II,5)*FCEN1  

      VSDR   =   VSDR    + FACT* CCPR8F(II,5)*FSIG1/3.D0

      VTDR   =   VTDR    + FACT* CCPR8F(II,5)*FTEN1/3.D0

      VODR   =   VODR    + FACT* CCPR8(II,5)*FSO1 

80    CONTINUE

c     if(icall.eq.0.and.nschr.eq.1) call writepr(2,x,p)

c*    if(icall.eq.20.and.nschr.eq.1) call writepr(2,x,p)



      if(x.eq.0.01d0) then 

      write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1

      write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 

      write(*,*) ' ccpr8=',ccpr8(ii,1)

      endif

      ENDIF



C------------------------------------------------------------

C 9)  VECTOR (PION-A1) PAIR TERMS:

C------------------------------------------------------------

C

c     IF(IPIA1.EQ.1) THEN

c     VC    =   VC + FACT*ISFAC*GPIA1*(GPIA1*FIPA1C

c    .                 - FP*(PIM/AMN)*(2*X1*DFI+DDFI)*FIA1 )

c     VSIG  =   VSIG - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)*

c    .          ((2*X1*DFI+DDFI)*FIA1 + DFI*DFIA)*(4.D0/3.D0)

c     VTEN  =   VTEN - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)*

c    .          ((X1*DFI-DDFI)*FIA1 - DFI*DFIA)*(2.D0/3.D0)

c     ENDIF

C

CC

C----------------------------------------------------------------

C     1/M-CORRECTIONS:

      IF(INA.EQ.1.OR.IPV.EQ.1) THEN

      CALL OMPAIR(X,INA,IPV,APV)     

c*    if(icall.eq.0) write(*,*) ' WARNING: NO OMPAIR !!!!!'

      ENDIF

C----------------------------------------------------------------



c     if(x.le.0.05d0) write(*,*) ' Before call ynprexpv:'

c*    if(icall.eq.0.and.nschr.eq.1) call writepr(3,x,p)

c*    if(x.le.0.05d0) call writepr(4,x,p)

c     if(x.le.0.05d0) call writepr(8,x,p)

c     if(x.le.0.05d0) write(*,*) 'ynpairs,ipiom =2: p,x=',p,x,

c    .' vsll,vsss,vsls,vsdr,vsnn=', vsll,vsss,vsls,vsdr,vsnn

c     if(x.le.0.05d0) write(*,*) 'ynpairs,ipiom =2: p,x=',p,x,

c    .' vtll,vtss,vtls,vtdr,vtnn=', vtll,vtss,vtls,vtdr,vtnn



C     STRANGENESS-EXCHANGE SPIN-ORBIT AND BARYON MASS DIFFERENCES :

      IF(NSU3F.NE.1) THEN

      IF(IPV.EQ.1) CALL YNPREXPV(X,IPV)     

      IF(IPV.EQ.0) CALL YNPREXPS(X,IPV)     

c***  CALL YNPREX(X,INA,IPV,APV)     

      ENDIF



      ICALL=ICALL+1

      RETURN

      END

C **********************************************************************

      SUBROUTINE YNPRCC(NTYPE,NCASE,ICSB,ALFA,ALFB,P)

C **********************************************************************

C *   in this version: YNPRCC and YCCMPE give identical results!!

C **********************************************************************

C *

C *   COMPUTATION COUPLING-CONSTANT COMBINATIONS FOR THE

C *   1-PAIR AND 2-PAIR DIAGRAMS FOR THE YN-CHANNELS

C *

C     ntype = 1 : 1  -> {8}x{8}

C     ntype = 2 : 8s -> {8}x{8}

C     ntype = 3 : 8a -> {8}x{8}

C     ntype = 4 : 8  -> {8}x{1}

C     ntype = 5 : 1  -> {1}x{1}

C     ntype = 6 : 8s -> {8}x{8}

C

C     ncase: 1 -> pipi, 2 -> etc.

C

C !!  NOTICE: THIS VERSION ALL COUPLINGS ARE ORDERED AS       !!!!!

C !!          FOR THE PS-SCALARS!!                            !!!!!

C

c     exchanged mesons are treated as distinguishable particles ->

C     IN COUPLING COMBINATIONS CENLL1 ETC.:

C     (i) L+R contributions included,

C     (ii) 1 <-> 2 interchange factor included (extra diagrams).

C     note: for idendical particles factor 2 from vertex, so in effect

C           no difference with distinguishable particles in 1-pair graph

C     (iii) 1-pair graphs from (L_{meson}+L_{pair})**3/3! i.e. term

C           L_{pair}L_{meson}^{2}/2!, so this cancels 1<->2 factor: IP12

C     (iv)  2-pair graphs from L_{pair}^{2}/2!

C     note: identical particle factors for 2-pair graphs: added in YNPAI

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRCPLS/CENNN1,CENLL1,CENLS1,CENSS1,CENDR1,   

     .              CENNN2,CENLL2,CENLS2,CENSS2,CENDR2,

     .              SIGNN1,SIGLL1,SIGLS1,SIGSS1,SIGDR1, 

     .              SIGNN2,SIGLL2,SIGLS2,SIGSS2,SIGDR2

c     COMMON/PRCPLS/CENLL1,CENLS1,CENSS1,CENDR1,                       

c    .              CENLL2,CENLS2,CENSS2,CENDR2,

c    .              SIGLL1,SIGLS1,SIGSS1,SIGDR1,                       

c    .              SIGLL2,SIGLS2,SIGSS2,SIGDR2



      COMMON/CPLRIJ/FA1,FA2,FA3,FA4,FA5,FA6,FA7,FA8,FA9,FA10,FA11,

     .              FB1,FB2,FB3,FB4,FB5,FB6,FB7,FB8,FB9,FB10,FB11,

     .              PR1,PR2,PR3,PR4,PR5,PR6,PR7,PR8,PR9,PR10,PR11

      COMMON/COUCON/XX1(3),THPS,XX2(2),THV,XX3(2),THS,XX4(8),THD,XX5(4)

     .,ALPA

      DIMENSION PR(11),FA(11),FB(11)

      EQUIVALENCE (PR1,PR(1)),(FA1,FA(1)),(FB1,FB(1))



C     CHANNEL-TYPE SEQUENCES:

C     (PI= PI, RHO, ETC.; ETA = ETA, PHI, ETC.; K = KA, K*, ETC. )

C     8S: (PI1 ETA2), (K1 K2)_{1}, (PI1 K2), (ETA1 K2),

C         (PI1 PI2)_{0}, (EAT1 ETA2), (K1 K2)_{0}, (7-CASES).

C         (K1 PI2), (K1 ETA2).

C     8A: (PI1 PI2), (K1 K2)_{1}, (PI1 K2), (ETA1 K2), (K1 K2)_{0},

C         (K1 PI2), (K1 ETA2), (7-CASES).



C

      DATA SR2/1.4142136D0/,SR3/1.732051D0/

C

C     CONSTRUCTION OF THE COUPLINGS 

C

      IF(P.EQ.+1.D0) ISFAC=+1

      IF(P.EQ.-1.D0) ISFAC=-3

c*    ISFAC = +1

C     XI-COUPLINGS:

      XA12 = -FA1*(4*ALFA-1.D0)/SR3

      XA13 = +FA1

      XB12 = -FB1*(4*ALFB-1.D0)/SR3

      XB13 = +FB1

C 1)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :

C

      IF(NTYPE.EQ.1) THEN

      GOTO(11,12,13),NCASE

C     PI1-PI2(I=0):

11    GPRNN = PR(1)

      GPRLL = GPRNN

      GPRSS = GPRNN

      CENNN1 =  3*GPRNN*FA1*FB1*4

      CENLL1 =  (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2

      CENLS1 =  0.D0

      CENSS1 =  (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2) )*2

      CENDR1 =  CENSS1

      CENNN2 =  3*GPRNN*GPRNN

      CENLL2 =  3*GPRLL*GPRNN

      CENLS2 =  0.D0

      CENSS2 =  3*GPRSS*GPRNN

      CENDR2 =  CENSS2

      GOTO 14

C     ETA1-ETA2:

12    GPRNN = PR(1)

      GPRLL = GPRNN

      GPRSS = GPRNN

      CENNN1 =  GPRNN*(FA6*FB6)*4

      CENLL1 =  (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2

      CENLS1 =  0.D0

      CENSS1 =  (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2

      CENDR1 =  CENSS1

      CENNN2 =  1*GPRNN*GPRNN

      CENLL2 =  1*GPRLL*GPRNN

      CENLS2 =  0.D0

      CENSS2 =  1*GPRSS*GPRNN

      CENDR2 =  CENSS2

      GOTO 14

C     KA1-KA2(I=0):

13    GPRNN = 1*PR(1)

      GPRLL = GPRNN

      GPRSS = GPRNN

      CENNN1 =  GPRNN*(FA4*FB4+3*FA5*FB5)*4

      CENLL1 =  GPRLL*(FA4*FB4+3*FA5*FB5)*2 +

     .          GPRNN*(2*FA4*FB4+2*XA12*XB12)*2  

      CENLS1 =  0.D0

      CENSS1 =  GPRSS*(FA4*FB4+3*FA5*FB5)*2 +

     .          GPRNN*(2*FA5*FB5+2*XA13*XB13)*2

      CENDR1 =  CENSS1

      CENNN2 =  4*GPRNN*GPRNN

      CENLL2 =  4*GPRLL*GPRNN

      CENLS2 =  0.D0

      CENSS2 =  4*GPRSS*GPRNN

      CENDR2 =  CENSS2

      GOTO 14

14    RETURN

      ENDIF

C

C 2)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(NTYPE.EQ.2) THEN

      GOTO(21,22,23,24,25,26,27),NCASE

C     PI1-ETA2:

21    GPRNN = PR(1)

      GPRSS = PR(2)

      GPRLS = PR(3)

      CENNN1 = ISFAC*GPRNN*FA1*FB6*4

      CENLL1 =  0.D0

c     CENLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6)  ! CSB

      CENLS1 = -SR3*(GPRNN*FA3*FB8+GPRLS*FA1*FB6

     .              +GPRNN*FA3*FB7+GPRLS*FA1*FB6 )

      CENSS1 = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 =  ISFAC*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -SR3*GPRLS*GPRNN

      CENSS2 = -2*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 28

C     KA1-KA2(I=1)(8S):

22    GPRNN = 0.5D0*SR3*PR(1)

      GPRSS = 0.5D0*SR3*PR(2)

      GPRLS = 0.5D0*SR3*PR(3)

      CENNN1 = ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*2

      CENLL1 =  0.D0

      CENLS1 = -0.5D0*SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2 +

     .               GPRNN*(2*FA4*FB5-2*XA12*XB13) +

     .               GPRNN*(2*FA5*FB4-2*XA13*XB12) )

      CENSS1 = -1*(GPRSS*(FA4*FB4-FA5*FB5) 

     .            -GPRNN*(2*FA5*FB5-2*XA13*XB13) )*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 = ISFAC*2*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -2*SR3*GPRLS*GPRNN

      CENSS2 = -4*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 28

C     PI1-KA2(8s):

23    GPRLN = 0.5D0*SR3*PR(4)

      GPRSN = 0.5D0*SR3*PR(5)

      CENNN1 = 0.D0

      CENLL1 =  GPRLN*(3*FA1*FB4+3*FA3*FB5)*2

      CENLS1 = -SR3*(-GPRLN*FA1*FB5 + GPRSN*3*FA3*FB5)

     .         -SR3*(+GPRLN*(FA3*FB4-2*FA2*FB5)+3*GPRSN*FA1*FB4)

      CENSS1 =  +GPRSN*(+FA1*FB5-FA3*FB4+2*FA2*FB5)*2

      CENDR1 = -2*CENSS1

      CENNN2 = 0.D0

      CENLL2 =  3*GPRLN**2

      CENLS2 = -3*SR3*GPRLN*GPRSN

      CENSS2 = -3*GPRSN**2

      CENDR2 = -2*CENSS2

      GOTO 28

C     ETA1-KA2(8S):

24    GPRLN = -0.5D0*PR(4)

      GPRSN = -0.5D0*PR(5)

      CENNN1  = 0.D0

      CENLL1  = GPRLN*(FA6+FA7)*FB4*2

      CENLS1  = -SR3*(GPRLN*FA6*FB5+GPRSN*FA7*FB4) 

     .          -SR3*(GPRLN*FA8*FB5+GPRSN*FA6*FB4) 

      CENSS1  = -GPRSN*(FA6*FB5+FA8*FB5)*2

      CENNN2  = 0.D0

      CENDR1  = -2*CENSS1

      CENLL2  =  GPRLN**2

      CENLS2  = -SR3*GPRLN*GPRSN

      CENSS2  = -GPRSN**2

      CENDR2  = -2*CENSS2

      GOTO 28

C     PI1-PI2(I=0)(8S):

25    GPRNN = 0.5D0*PR(6)

      GPRLL = 0.5D0*PR(7)

      GPRSS = 0.5D0*PR(8)

      CENNN1  =  3*GPRNN*FA1*FB1*4

      CENLL1  =  (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2

      CENLS1  =  0.D0

      CENSS1  =  (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2))*2

      CENDR1  =  CENSS1

      CENNN2  =  3*GPRNN*GPRNN

      CENLL2  =  3*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  3*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 28

C     ETA-ETA(8s):

26    GPRNN = -0.5D0*PR(6)

      GPRLL = -0.5D0*PR(7)

      GPRSS = -0.5D0*PR(8)

      CENNN1  =  GPRNN*FA6*FB6*4

      CENLL1  =  (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2

      CENLS1  =  0.D0

      CENSS1  =  (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2

      CENDR1  =  CENSS1

      CENNN2  =  GPRNN*GPRNN

      CENLL2  =  1*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  1*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 28

C     KA1-KA2(I=0)(8S):

27    GPRNN = -0.5D0*PR(6)

      GPRLL = -0.5D0*PR(7)

      GPRSS = -0.5D0*PR(8)

      CENNN1  =  GPRNN*(FA4*FB4+3*FA5*FB5)*2

      CENLL1  =  (GPRLL*(FA4*FB4+3*FA5*FB5) +

     .           GPRNN*(2*FA4*FB4+2*XA12*XB12))*1

      CENLS1  =  0.D0

      CENSS1  =  (GPRSS*(FA4*FB4+3*FA5*FB5) +

     .           GPRNN*(2*FA5*FB5+2*XA13*XB13))*1

      CENDR1  =  CENSS1

      CENNN2  =  2*GPRNN*GPRNN

      CENLL2  =  2*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  2*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 28

28    RETURN

      ENDIF

C

C 3)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :

C

      IF(NTYPE.EQ.3) THEN

      GOTO(41,42,43,44,48,45,46,47,49),NCASE

C     PI1-RHO2(I=1)(AXIAL):

41    GPRNN = PR(1)

      GPRSS = PR(2)

      GPRLS = PR(3)



      SIGNN1  =  ISFAC*GPRNN*(2*FA1*FB1)*4

      SIGLL1  =  0.D0

c     SIGLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*(FA3*FB6+FA6*FB3))  ! CSB

      SIGLS1  = -SR3*(2*GPRLS*FA1*FB1+2*GPRNN*(FA3*FB2))

     .          -SR3*(2*GPRLS*FA1*FB1+2*GPRNN*(FA2*FB3))

      SIGSS1  = -2*(2*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+FA2*FB2))*2

      SIGDR1  = -0.5D0*SIGSS1

      SIGNN2  =  ISFAC*2*GPRNN*GPRNN

      SIGLL2  =  0.D0

      SIGLS2  = -2*SR3*GPRLS*GPRNN

      SIGSS2  = -4*GPRSS*GPRNN

      SIGDR2  = -0.5D0*SIGSS2

      GOTO 488

C     KA-K*(I=1)(AXIAL):

42    GPRNN = 0.5D0*PR(1)

      GPRSS = 0.5D0*PR(2)

      GPRLS = 0.5D0*PR(3)



      SIGNN1  =  ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*4

      SIGLL1  =  0.D0

      SIGLS1  = -SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2

     .                -2*GPRNN*(FA4*FB5+XA12*XB13)  

     .                -2*GPRNN*(FA5*FB4+XA13*XB12) )

      SIGSS1  = -2*GPRSS*(FA4*FB4-FA5*FB5)*2

     .          -4*GPRNN*(FA5*FB5+XA13*XB13)*2

      SIGDR1  = -0.5D0*SIGSS1

      SIGNN2  =  ISFAC*4*GPRNN*GPRNN

      SIGLL2  =  0.D0

      SIGLS2  = -4*SR3*GPRLS*GPRNN

      SIGSS2  = -8*GPRSS*GPRNN

      SIGDR2  = -0.5D0*SIGSS2

      GOTO 488

C     PI-K*(AXIAL):

43    GPRLN = -0.5D0*PR(4)

      GPRSN = -0.5D0*PR(5)



      SIGNN1  =  0.D0

      SIGLL1  =  3*GPRLN*(-FA1*FB4+FA3*FB5)*2

      SIGLS1  = -SR3*(+GPRLN*FA1*FB5+3*GPRSN*FA3*FB5)

     .          -SR3*(+GPRLN*(+FA3*FB4-2*FA2*FB5)-3*GPRSN*FA1*FB4)

      SIGSS1  =  1*GPRSN*(-FA1*FB5-FA3*FB4+2*FA2*FB5)*2

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  3*GPRLN**2

      SIGLS2  = -3*SR3*GPRLN*GPRSN

      SIGSS2  = -3*GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

C     ETA-K*(AXIAL):

44    GPRLN = -0.5D0*SR3*PR(4)*DCOS(THPS)

      GPRSN = -0.5D0*SR3*PR(5)*DCOS(THPS)



      SIGNN1  =  0.D0

      SIGLL1  =  GPRLN*(-FA6*FB4+FA7*FB4)*2

      SIGLS1  = -SR3*(-GPRLN*FA6*FB5+GPRSN*FA7*FB4)

     .          -SR3*(+GPRLN*FA8*FB5-GPRSN*FA6*FB4)

      SIGSS1  = -1*GPRSN*(-FA6*FB5+FA8*FB5)*2

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

C     ETA'-K*(AXIAL):

48    GPRLN = -0.5D0*SR3*PR(4)*DSIN(THPS)

      GPRSN = -0.5D0*SR3*PR(5)*DSIN(THPS)



      SIGNN1  =  0.D0

      SIGLL1  =  GPRLN*(-FA9*FB4+FA10*FB4)*2

      SIGLS1  = -SR3*(-GPRLN*FA9*FB5+GPRSN*FA10*FB4)

     .          -SR3*(+GPRLN*FA11*FB5-GPRSN*FA9*FB4)

      SIGSS1  = -1*GPRSN*(-FA9*FB5+FA11*FB5)*2

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

C     KA-K*(I=0)(AXIAL):

45    GPRNN = 0.5D0*SR3*PR(6)

      GPRLL = 0.5D0*SR3*PR(7)

      GPRSS = 0.5D0*SR3*PR(8)



      SIGNN1  =  GPRNN*(FA4*FB4+3*FA5*FB5)*4

      SIGLL1  =  1*(GPRLL*(FA4*FB4+3*FA5*FB5)  

     .             +GPRNN*(-2*FA4*FB4+2*XA12*XB12) )*2

      SIGLS1  =  0.D0

      SIGSS1  = +1*(GPRSS*(FA4*FB4+3*FA5*FB5)

     .             +GPRNN*(-2*FA5*FB5+2*XA13*XB13) )*2

      SIGDR1  =  SIGSS1

      SIGNN2  =  4*GPRNN*GPRNN

      SIGLL2  =  4*GPRLL*GPRNN

      SIGLS2  =  0.D0

      SIGSS2  =  4*GPRSS*GPRNN

      SIGDR2  =  SIGSS2

      GOTO 488

C     KA-RO(AXIAL):

46    GPRLN = -0.5D0*PR(4)

      GPRSN = -0.5D0*PR(5)

c     gprln = +0.5D0*PR(4)

c     gprsn = +0.5D0*PR(5)



      SIGNN1  =  0.D0

      SIGLL1  =  3*GPRLN*(FA5*FB3-FA4*FB1)*2

      SIGLS1  = -SR3*(+GPRLN*FA5*FB1+3*GPRSN*FA5*FB3)

     .          -SR3*(+GPRLN*(FA4*FB3-2*FA5*FB2)-3*GPRSN*FA4*FB1)

      SIGSS1  = -1*GPRSN*(FA4*FB3-2*FA5*FB2+FA5*FB1)*2        

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  3*GPRLN**2

      SIGLS2  = -3*SR3*GPRLN*GPRSN

      SIGSS2  = -3*GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

C     KA-PHI(AXIAL):

47    GPRLN = -0.5D0*SR3*PR(4)*DCOS(THV)

      GPRSN = -0.5D0*SR3*PR(5)*DCOS(THV)

c     gprln = +0.5D0*SR3*PR(4)*DCOS(THV)

c     gprsn = +0.5D0*SR3*PR(5)*DCOS(THV)



      SIGNN1  =  0.D0

      SIGLL1  =  1*GPRLN*(-FA4*FB6+FA4*FB7)*2

      SIGLS1  = -SR3*(GPRLN*FA5*FB8-GPRSN*FA4*FB6)

     .          -SR3*(-GPRLN*FA5*FB6+GPRSN*FA4*FB7)

      SIGSS1  = -1*GPRSN*(FA5*FB8-FA5*FB6)*2

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

C     KA-OMEGA(AXIAL):

49    GPRLN = -0.5D0*SR3*PR(4)*DSIN(THV)

      GPRSN = -0.5D0*SR3*PR(5)*DSIN(THV)

c     gprln = +0.5D0*SR3*PR(4)*DSIN(THV)

c     gprsn = +0.5D0*SR3*PR(5)*DSIN(THV)



      SIGNN1  =  0.D0

      SIGLL1  =  1*GPRLN*(-FA4*FB9+FA4*FB10)*2

      SIGLS1  = -SR3*(GPRLN*FA5*FB11-GPRSN*FA4*FB9)

     .          -SR3*(-GPRLN*FA5*FB9+GPRSN*FA4*FB10)

      SIGSS1  = -1*GPRSN*(FA5*FB11-FA5*FB9)*2

      SIGDR1  = -2*SIGSS1

      SIGNN2  =  0.D0

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 488

488   RETURN

      ENDIF

C

C 4)  PSEUDO SCALAR PAIR TERMS {8}->{8}x{1} (PION-EPSILON):

C

      IF(NTYPE.EQ.4) THEN

      if(ncase.eq.1) then

      gnn1  = 0.d0

      gnn2  = 0.d0

      gdr1  = 0.d0

      gdr2  = 0.d0

      endif

      GOTO(51,52,53,54,55,56),NCASE



C     PI-EPSILON:

51    GPRNN = PR(1)

      GPRSS = PR(2)

      GPRLS = PR(3)



      signn1  =  isfac*2*pr(1)*fa1*fb9*2

      signn2  =  isfac*pr(1)*pr(1)

      SIGLL1  =  0.D0

c     SIGLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6)  ! CSB

      SIGLS1  = -0.5D0*SR3*(2*GPRLS*FA1*FB9+GPRNN*FA3*(FB10+FB11))*2

      SIGSS1  = -2*(GPRSS*FA1*FB9+GPRNN*FA2*FB10)*2

      SIGDR1  = -0.5D0*SIGSS1

      SIGLL2  =  0.D0

      SIGLS2  = -SR3*GPRLS*GPRNN

      SIGSS2  = -2*GPRSS*GPRNN

      SIGDR2  = -0.5D0*SIGSS2

      GOTO 57

C     KA-EPSILON:

52    GPRLN = PR(4)

      GPRSN = PR(5)

C     GPRLN = PR(4)*2

C     GPRSN = PR(5)*2



      signn1  =  0.d0

      signn2  =  0.d0

      SIGLL1  =  1*GPRLN*FA4*(FB9+FB10)*2

      SIGLS1  = -0.5D0*SR3*(GPRLN*FA5*(FB9+FB11)+GPRSN*FA4*(FB9+FB10))*2

      SIGSS1  = -1*GPRSN*FA5*(FB9+FB11)*2

      SIGDR1  = -2*SIGSS1

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 57

C     ETA-EPSILON:

53    GPRNN = PR(6)

      GPRLL = PR(7)

      GPRSS = PR(8)



      signn1  =   2*pr(6)*fa6*fb9*2

      signn2  =   pr(6)*pr(6)

      SIGLL1  =   1*(GPRNN*FA7*FB10+GPRLL*FA6*FB9)*2

      SIGLS1  =   0.D0

      SIGSS1  =   1*(GPRNN*FA8*FB11+GPRSS*FA6*FB9)*2

      SIGDR1  =   SIGSS1

      SIGLL2  =   GPRLL*GPRNN

      SIGLS2  =   0.D0

      SIGSS2  =   GPRSS*GPRNN

      SIGDR2  =   SIGSS2

      GOTO 57



C     PI-SSTAR:

54    GPRNN = PR(1)

      GPRSS = PR(2)

      GPRLS = PR(3)



      signn1  =  isfac*2*pr(1)*fa1*fb6*2

      signn2  =  isfac*pr(1)*pr(1)

      SIGLL1  =  0.D0

      SIGLS1  = -0.5D0*SR3*(2*GPRLS*FA1*FB6+GPRNN*FA3*(FB7+FB8))*2

      SIGSS1  = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2

      SIGDR1  = -0.5D0*SIGSS1

      SIGLL2  =  0.D0

      SIGLS2  = -SR3*GPRLS*GPRNN

      SIGSS2  = -2*GPRSS*GPRNN

      SIGDR2  = -0.5D0*SIGSS2

      GOTO 57

C     KA-SSTAR:

55    GPRLN = PR(4)

      GPRSN = PR(5)

C     GPRLN = PR(4)*2

C     GPRSN = PR(5)*2



      signn1  =  0.d0

      signn2  =  0.d0

      SIGLL1  =  1*GPRLN*FA4*(FB6+FB7)*2

      SIGLS1  = -0.5D0*SR3*(GPRLN*FA5*(FB6+FB8)+GPRSN*FA4*(FB6+FB7))*2

      SIGSS1  = -1*GPRSN*FA5*(FB6+FB8)*2

      SIGDR1  = -2*SIGSS1

      SIGLL2  =  GPRLN**2

      SIGLS2  = -SR3*GPRLN*GPRSN

      SIGSS2  = -GPRSN**2

      SIGDR2  = -2*SIGSS2

      GOTO 57

C     ETA-SSTAR:

56    GPRNN = PR(6)

      GPRLL = PR(7)

      GPRSS = PR(8)



      signn1  =  2*pr(6)*fa6*fb6*2

      signn2  =  pr(6)*pr(6)

      SIGLL1  =  1*(GPRNN*FA7*FB7+GPRLL*FA6*FB6)*2

      SIGLS1  =  0.D0

      SIGSS1  =  1*(GPRNN*FA8*FB8+GPRSS*FA6*FB6)*2

      SIGDR1  =  SIGSS1

      SIGLL2  =  GPRLL*GPRNN

      SIGLS2  =  0.D0

      SIGSS2  =  GPRSS*GPRNN

      SIGDR2  =  SIGSS2

      GOTO 57

57    RETURN

      ENDIF

C

C D)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} (EPSILON-EPSILON):

C

C 5)  SCALAR (EPSILON-EPSILON) PAIR TERMS:

      IF(NTYPE.EQ.5) THEN

C     EPSILON-EPSILON:

      GPRNN = PR(1)

      GPRLL = PR(2)

      GPRSS = PR(3)

c     GPRLL = GPRNN

c     GPRSS = GPRNN

      CENNN1  = (GPRNN*FA9*FB9)*4

      CENLL1  = (GPRLL*FA9*FB9+GPRNN*FA10*FB10)*2

      CENLS1  = 0.D0

      CENSS1  = (GPRSS*FA9*FB9+GPRNN*FA11*FB11)*2

      CENDR1  = CENSS1

      CENNN2 =  GPRNN*GPRNN

      CENLL2 =  GPRLL*GPRNN

      CENLS2 =  0.D0

      CENSS2 =  GPRSS*GPRNN

      CENDR2 =  CENSS2

      ENDIF

C

C 6)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(NTYPE.EQ.6) THEN

      GOTO(61,611,62,63,64,65,66,67,671,68,69,691,693), NCASE

C     PI1-OMEGA:

61    GPRNN = 0.5D0*PR(1)

      GPRSS = 0.5D0*PR(2)

      GPRLS = 0.5D0*PR(3)

      CENNN1 = ISFAC*GPRNN*FA1*FB9*4

      CENLL1 =  0.D0

c     CENLL1 = -0.0271*ICSB*(GPRLS*FA1*FB6+GPRNN*FA3*FB6)  ! CSB

      CENLS1 = -SR3*(GPRNN*FA3*FB11+GPRLS*FA1*FB9

     .              +GPRNN*FA3*FB10+GPRLS*FA1*FB9 )

      CENSS1 = -2*(GPRSS*FA1*FB9+GPRNN*FA2*FB11)*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 =  ISFAC*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -SR3*GPRLS*GPRNN

      CENSS2 = -2*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 692

C     PI1-PHI2: 

611   GPRNN = 0.5D0*PR(1)

      GPRSS = 0.5D0*PR(2)

      GPRLS = 0.5D0*PR(3)

      CENNN1 = ISFAC*GPRNN*FA1*FB6*4

      CENLL1 =  0.D0

      CENLS1 = -SR3*(GPRNN*FA3*FB8+GPRLS*FA1*FB6

     .              +GPRNN*FA3*FB7+GPRLS*FA1*FB6 )

      CENSS1 = -2*(GPRSS*FA1*FB6+GPRNN*FA2*FB8)*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 =  ISFAC*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -SR3*GPRLS*GPRNN

      CENSS2 = -2*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 692

C     ETA1-RHO2:

62    GPRNN = 0.5D0*PR(1)

      GPRSS = 0.5D0*PR(2)

      GPRLS = 0.5D0*PR(3)

      CENNN1 = ISFAC*GPRNN*FA6*FB1*4

      CENLL1 =  0.D0

      CENLS1 = -SR3*(GPRNN*FA8*FB3+GPRLS*FA6*FB1

     .              +GPRNN*FA7*FB3+GPRLS*FA6*FB1 )

      CENSS1 = -2*(GPRSS*FA6*FB1+GPRNN*FA8*FB2)*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 =  ISFAC*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -SR3*GPRLS*GPRNN

      CENSS2 = -2*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 692

C     KA1-K*2(I=1)(8S):

63    GPRNN = 0.25D0*SR3*PR(1)

      GPRSS = 0.25D0*SR3*PR(2)

      GPRLS = 0.25D0*SR3*PR(3)

      CENNN1 = ISFAC*GPRNN*(FA4*FB4-FA5*FB5)*4

      CENLL1 =  0.D0

      CENLS1 = -SR3*(GPRLS*(FA4*FB4-FA5*FB5)*2 +

     .               GPRNN*(2*FA4*FB5-2*XA12*XB13) +

     .               GPRNN*(2*FA5*FB4-2*XA13*XB12) )

      CENSS1 = -2*(GPRSS*(FA4*FB4-FA5*FB5) 

     .            -GPRNN*(2*FA5*FB5-2*XA13*XB13) )*2

      CENDR1 = -0.5D0*CENSS1

      CENNN2 = ISFAC*4*GPRNN*GPRNN

      CENLL2 =  0.D0

      CENLS2 = -4*SR3*GPRLS*GPRNN

      CENSS2 = -8*GPRSS*GPRNN

      CENDR2 = -0.5D0*CENSS2

      GOTO 692

C     PI1-K*2(8s):

64    GPRLN = 0.25D0*SR3*PR(4)

      GPRSN = 0.25D0*SR3*PR(5)

      CENNN1 = 0.D0

      CENLL1 =  GPRLN*(3*FA1*FB4+3*FA3*FB5)*2

      CENLS1 = -SR3*(-GPRLN*FA1*FB5 + GPRSN*3*FA3*FB5)

     .         -SR3*(+GPRLN*(FA3*FB4-2*FA2*FB5)+3*GPRSN*FA1*FB4)

      CENSS1 =  +GPRSN*(+FA1*FB5-FA3*FB4+2*FA2*FB5)*2

      CENDR1 = -2*CENSS1

      CENNN2 = 0.D0

      CENLL2 =  3*GPRLN**2

      CENLS2 = -3*SR3*GPRLN*GPRSN

      CENSS2 = -3*GPRSN**2

      CENDR2 = -2*CENSS2

      GOTO 692

C     KA1-RHO2(8s):

65    GPRLN = 0.25D0*SR3*PR(4)

      GPRSN = 0.25D0*SR3*PR(5)

      CENNN1 = 0.D0

      CENLL1 =  GPRLN*(3*FA4*FB1+3*FA5*FB3)*2

      CENLS1 = -SR3*(-GPRLN*FA5*FB1 + GPRSN*3*FA5*FB3)

     .         -SR3*(+GPRLN*(FA4*FB3-2*FA5*FB2)+3*GPRSN*FA4*FB1)

      CENSS1 =  +GPRSN*(+FA5*FB1-FA4*FB3+2*FA5*FB2)*2

      CENDR1 = -2*CENSS1

      CENNN2 = 0.D0

      CENLL2 =  3*GPRLN**2

      CENLS2 = -3*SR3*GPRLN*GPRSN

      CENSS2 = -3*GPRSN**2

      CENDR2 = -2*CENSS2

      GOTO 692

C     ETA1-K*2(8S):

66    GPRLN = -0.25D0*PR(4)

      GPRSN = -0.25D0*PR(5)

      CENNN1  = 0.D0

      CENLL1  = GPRLN*(FA6+FA7)*FB4*2

      CENLS1  = -SR3*(GPRLN*FA6*FB5+GPRSN*FA7*FB4) 

     .          -SR3*(GPRLN*FA8*FB5+GPRSN*FA6*FB4) 

      CENSS1  = -GPRSN*(FA6*FB5+FA8*FB5)*2

      CENNN2  = 0.D0

      CENDR1  = -2*CENSS1

      CENLL2  =  GPRLN**2

      CENLS2  = -SR3*GPRLN*GPRSN

      CENSS2  = -GPRSN**2

      CENDR2  = -2*CENSS2

      GOTO 692

C     KA1-OMEGA(8S):

67    GPRLN = -0.25D0*PR(4)

      GPRSN = -0.25D0*PR(5)

      CENNN1  = 0.D0

      CENLL1  = GPRLN*(FB9+FB10)*FA4*2

      CENLS1  = -SR3*(GPRLN*FA5*FB9+GPRSN*FA4*FB10) 

     .          -SR3*(GPRLN*FA5*FB11+GPRSN*FA4*FB9) 

      CENSS1  = -GPRSN*(FA5*FB9+FA5*FB11)*2

      CENNN2  = 0.D0

      CENDR1  = -2*CENSS1

      CENLL2  =  GPRLN**2

      CENLS2  = -SR3*GPRLN*GPRSN

      CENSS2  = -GPRSN**2

      CENDR2  = -2*CENSS2

      GOTO 692

C     KA1-PHI2(8S):

671   GPRLN = -0.25D0*PR(4)

      GPRSN = -0.25D0*PR(5)

      CENNN1  = 0.D0

      CENLL1  = GPRLN*(FB6+FB7)*FA4*2

      CENLS1  = -SR3*(GPRLN*FA5*FB6+GPRSN*FA4*FB7) 

     .          -SR3*(GPRLN*FA5*FB8+GPRSN*FA4*FB6) 

      CENSS1  = -GPRSN*(FA5*FB6+FA5*FB8)*2

      CENNN2  = 0.D0

      CENDR1  = -2*CENSS1

      CENLL2  =  GPRLN**2

      CENLS2  = -SR3*GPRLN*GPRSN

      CENSS2  = -GPRSN**2

      CENDR2  = -2*CENSS2

      GOTO 692

C     PI1-RHO2(I=0)(8S):

68    GPRNN = 0.5D0*PR(6)

      GPRLL = 0.5D0*PR(7)

      GPRSS = 0.5D0*PR(8)

      CENNN1  =  3*GPRNN*FA1*FB1*4

      CENLL1  =  (3*GPRLL*FA1*FB1+3*GPRNN*FA3*FB3)*2

      CENLS1  =  0.D0

      CENSS1  =  (3*GPRSS*FA1*FB1+GPRNN*(FA3*FB3+2*FA2*FB2))*2

      CENDR1  =  CENSS1

      CENNN2  =  3*GPRNN*GPRNN

      CENLL2  =  3*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  3*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 692

C     KA1-K*2(I=0)(8S):

69    GPRNN = -0.25D0*PR(6)

      GPRLL = -0.25D0*PR(7)

      GPRSS = -0.25D0*PR(8)

      CENNN1  =  GPRNN*(FA4*FB4+3*FA5*FB5)*4

      CENLL1  =  (GPRLL*(FA4*FB4+3*FA5*FB5) +

     .           GPRNN*(2*FA4*FB4+2*XA12*XB12))*2

      CENLS1  =  0.D0

      CENSS1  =  (GPRSS*(FA4*FB4+3*FA5*FB5) +

     .           GPRNN*(2*FA5*FB5+2*XA13*XB13))*2

      CENDR1  =  CENSS1

      CENNN2  =  4*GPRNN*GPRNN

      CENLL2  =  4*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  4*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 692

C     ETA-OMEGA(8s):

691   GPRNN = -0.5D0*PR(6)

      GPRLL = -0.5D0*PR(7)

      GPRSS = -0.5D0*PR(8)

      CENNN1  =  GPRNN*FA6*FB9*4

      CENLL1  =  (GPRLL*FA6*FB9+GPRNN*FA7*FB10)*2

      CENLS1  =  0.D0

      CENSS1  =  (GPRSS*FA6*FB9+GPRNN*FA8*FB11)*2

      CENDR1  =  CENSS1

      CENNN2  =  GPRNN*GPRNN

      CENLL2  =  1*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  1*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 692

C     ETA-PHI(8s):

693   GPRNN = -0.5D0*PR(6)

      GPRLL = -0.5D0*PR(7)

      GPRSS = -0.5D0*PR(8)

      CENNN1  =  GPRNN*FA6*FB6*4

      CENLL1  =  (GPRLL*FA6*FB6+GPRNN*FA7*FB7)*2

      CENLS1  =  0.D0

      CENSS1  =  (GPRSS*FA6*FB6+GPRNN*FA8*FB8)*2

      CENDR1  =  CENSS1

      CENNN2  =  GPRNN*GPRNN

      CENLL2  =  1*GPRLL*GPRNN

      CENLS2  =  0.D0

      CENSS2  =  1*GPRSS*GPRNN

      CENDR2  =  CENSS2

      GOTO 692



692   RETURN

      ENDIF

      END

C **********************************************************************

      SUBROUTINE WRITEPR(NCASE,X,P)

C **********************************************************************

C

C     NCASE = 1,2,7 : VC ; NCASE = 3 : VC,VS,VT ; NCASE = 4,5,6 : VS,VT

C     NCASE = 8 : VS,VT

C

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRWRITE/VPR(5,3,4,4,8)

      CHARACTER *4 NTYPM(4,4)

c*    DATA N3/37/,NTYPM/

      DATA N3/27/,NTYPM/

c*    DATA N3/6/,NTYPM/

     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','PHI ','OM  ',

     .'DE  ','KAP ','S*  ','EPS ','A2  ','K** ','POMP','POM '/

C

c     selected printing:

c**   if(ncase.ne.8) return



      write(N3,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'

      if(ncase.eq.1) write(N3,101)

      if(ncase.eq.2) write(N3,102)

      if(ncase.eq.3) write(N3,103)

      if(ncase.eq.4) write(N3,104)

      if(ncase.eq.5) write(N3,105)

      if(ncase.eq.6) write(N3,106)

      if(ncase.eq.8) write(N3,108)

      if(ncase.le.3) JJ=1

      if(ncase.eq.4) JJ=2

      if(ncase.eq.5) JJ=3

      if(ncase.eq.6) JJ=4

      if(ncase.eq.8) JJ=2



      if(ncase.le.3 .OR. ncase.eq.7) then

c     if(ncase.ne.8) then

      write(N3,100) x,p

      write(N3,110) (NTYPM(KK,JJ),KK=1,4)

  110 format(10x,4(3x,a4,5x))

      write(N3,*)'-----------------------------------------------------'

      DO 111 II=1,4

  111 write(N3,1) NTYPM(II,1),(VPR(1,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 112 II=1,4

  112 write(N3,2) NTYPM(II,1),(VPR(2,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 113 II=1,4

  113 write(N3,3) NTYPM(II,1),(VPR(3,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 114 II=1,4

  114 write(N3,4) NTYPM(II,1),(VPR(4,1,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 115 II=1,4

  115 write(N3,5) NTYPM(II,1),(VPR(5,1,II,KK,NCASE),KK=1,4)

      call su3prnt(1,ncase,x,p)

      endif



      if(ncase.ge.3 .AND. ncase.ne.7) then

      write(N3,200) x,p

      write(N3,110) (NTYPM(KK,JJ),KK=1,4)

      write(N3,*)'-----------------------------------------------------'

      DO 211 II=1,4

  211 write(N3,1) NTYPM(II,1),(VPR(1,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 212 II=1,4

  212 write(N3,2) NTYPM(II,1),(VPR(2,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 213 II=1,4

  213 write(N3,3) NTYPM(II,1),(VPR(3,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 214 II=1,4

  214 write(N3,4) NTYPM(II,1),(VPR(4,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'====================================================='

      DO 215 II=1,4

  215 write(N3,5) NTYPM(II,1),(VPR(5,2,II,KK,NCASE),KK=1,4)

      write(N3,*)'*****************************************************'

      call su3prnt(2,ncase,x,p)

      endif

      return              



  101 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :',/)

  102 format(/,' SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :',/)

  103 format(/,' VECTOR SU(3)-OCTET PAIR TERMS,  {8a}->{8}x{8} :',/)

  104 format(/,' AXIAL (PION-RHO) PAIR TERMS OF THE FIRST CLASS:',/)

  105 format(/,' PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:',/)

  106 format(/,' PSEUDO SCALAR (PS-POMERON) PAIR TERMS:',/)

  107 format(/,' SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :',/)

  108 format(/,' AXIAL (PION-PHI) PAIR TERMS OF THE SECND CLASS:',/)



  100 format(55('*'),/,' YNPAIR: CENTRAL POTENTIALS: x=',f7.3,    

     .' p=',f4.1,/,55('*'))

  200 format(55('*'),/,' YNPAIR: SPIN-SPIN POTENTIALS: x=',f7.3,    

     .' p=',f4.1,/,55('*'))

    1 FORMAT(1x,'NN: ',A4,4(F10.3,2X))

    2 FORMAT(1x,'LL: ',A4,4(F10.3,2X))

    3 FORMAT(1x,'LS: ',A4,4(F10.3,2X))

    4 FORMAT(1x,'SS: ',A4,4(F10.3,2X))

    5 FORMAT(1x,'DR: ',A4,4(F10.3,2X))

      end

C **********************************************************************

      SUBROUTINE SU3PRNT(IV,NCASE,X,P)

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PRWRITE/VPR(5,3,4,4,8)

      DIMENSION VTOT(5)

      DATA N3/27/

c*    DATA N3/6/

C SUMMED CONTRIBUTIONS:                   

      DO 120 ICHAN=1,5

      VTOT(ICHAN)=0.D0

      DO 120 M=1,4

      DO 120 N=1,4

  120 VTOT(ICHAN)=VTOT(ICHAN)+VPR(ICHAN,IV,M,N,NCASE)

      if(iv.eq.1) write(N3,121) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  121 format(' VCNN=',F10.2,3x,' VCDR=',F10.2,3x,' VCLL=',F10.2,/,

     .       ' VCLS=',F10.2,3x,' VCSS=',F10.2,/)

      if(iv.eq.2) write(N3,122) VTOT(1),VTOT(5),VTOT(2),VTOT(3),VTOT(4)

  122 format(' VSNN=',F10.2,3x,' VSDR=',F10.2,3x,' VSLL=',F10.2,/,

     .       ' VSLS=',F10.2,3x,' VSSS=',F10.2,/)

C CONTRIBUTIONS TO SU(3)-POTENTIALS:                        

      if(p.eq.1.d0) then

      V27a = VTOT(1)                                                    

      V27b = VTOT(5)                                                    

c*    V27c = (9*VTOT(2)-VTOT(4))/8.D0

      V27c = (3*VTOT(2)-VTOT(3))/3.D0

c     V8Sa = 10*VTOT(2)-9*VTOT(5)

      V8Sa =    VTOT(2)+3*VTOT(3)

      V8Sb = (10*VTOT(4)-VTOT(5))/9.D0

      V8Sc = (9*VTOT(4)-VTOT(2))/8.D0

      VLSa = (-3*V27b+3*V8Sa)/10.D0

      VLSb = (-3*V27b+3*V8Sb)/10.D0

      VLSc = (-3*V27c+3*V8Sc)/10.D0

      write(N3,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc

c*    write(*,123) V27a,V27b,V27c,V8Sa,V8Sb,V8Sc,VLSa,VLSb,VLSc

  123 format(' V27a =',F10.3,3x,' V27b =',F10.3,3x,' V27c =',F10.3,/,

     .       ' V8Sa =',F10.2,3x,' V8Sb =',F10.2,3x,' V8Sc =',F10.2,/,

     .       ' VLSa =',F10.2,3x,' VLSb =',F10.2,3x,' VLSc =',F10.2)

      endif

      if(p.eq.-1.d0) then

      V10nn= VTOT(1)

      V10  = VTOT(5)

      V10sa= VTOT(2)+VTOT(3)                                            

      V10sb= VTOT(4)+VTOT(3)                                            

      V8Aa = VTOT(2)-VTOT(3)                                            

      V8Ab = VTOT(4)-VTOT(3)                                            

      write(N3,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10

c*    write(*,124) V10sa,V10sb,V10nn,V8Aa,V8Ab,V10

  124 format(' V10*a=',F10.2,3x,' V10*b=',F10.2,3x,' V10nn=',F10.2,/,

     .       ' V8Aa =',F10.2,3x,' V8Ab =',F10.2,3x,' V10  =',F10.2)

      endif

      write(N3,*)'*****************************************************'

      return

      END

C **********************************************************************

      SUBROUTINE YNPREXPV(X,IPV)

C **********************************************************************

C     USED: PREXLS_PV.C.TEX

C *

C     COMPUTATION SPIN-ORBIT, NOW USING PV_COUPLING 

C     WHICH GIVES OMEGA's AT THE VERTICES !!         

C     MASS DIFFERENCE CONTRIBUTION FOR STRANGENESS-EXCHANGE

C     TO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT POTENTIALS

C

C     NOTE: THIS ROUTINE NOT READY FOR SU3F-TEST!

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/MODEL/IXXX(8),NSU3F

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11)

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA

      COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX

      DIMENSION FUN(12),WGHTID(2)

C

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR



      COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11),

     .             PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11),

     .             PRTEN(11),PRTENF(11)



C     communication with routine YNPRCC:

C

      COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10),

     .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10)  ,CCPR7(3,10),

     .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10),

     .CCPR11(4,10),CCPR11F(4,10)                 ! MARCH 2009



      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO

     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2,FASO

C

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,

     .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA  ! MARCH 2009

      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/

      DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/,

     .     AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/,

     .     AKMAX/0000.D0/,XKMAX/2.D0/,

     .     AMLAM/1115D0/,AMSIGM/1190D0/



      DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/

      data ipipi2/0/



      COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5,

     .              VALL1,VALL2,VALL3,VALL4,VALL5               



      SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL

C

      IF(IPV.NE.1) RETURN

C     WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING

      WGHTID(1) = DSIN(THV)       

      WGHTID(2) = DCOS(THV)       



      IF(ICALL.EQ.0) THEN

        PIM = PIM0

        IF(NSU3F.EQ.1) THEN

        CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS)

        AMLAM=AMLN

        AMSIGM=AMLN

        ENDIF

        XBEGIN=X

        FACT  = PIM0

c       AMNC = DSQRT(AM(2)*AM(3))

c       AMHY = DSQRT(AMY(1)*AMY(2))

C       AMN  = DSQRT(AMNN*AMH )

        DAM  = AMH-AMNN

        AA   = DAM/PIM0

      ENDIF



      if(p.ne.pold) then

      icall=0

      pold=p

      nschr=1

      endif



c     DO 1 I=2,NMAX

c     X = XA(I)

      VOLL1 = 0D0

      VOLL2 = 0D0

      VOLL3 = 0D0

      VOLL4 = 0D0

      VOLL5 = 0D0

      VALL1 = 0D0

      VALL2 = 0D0

      VALL3 = 0D0

      VALL4 = 0D0

      VALL5 = 0D0

CC

CC

      X1   =1.D0/X

      X2   =X1*X1     

CC

      CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI)

      CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1)

      CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU)

C     ETA:

      CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA)

C     ETAP:

      CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP)

  

C     KAON:

c*    CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA)

      CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA)

CC

*     CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR)

      FIRO  = 0.D0

      DFIR  = 0.D0

      DO 410 JJ=1,2

      CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIRO = FIRO + AVEC(JJ)*FJJ

 410  DFIR = DFIR  + AVEC(JJ)*DFJJ

C     K*(892):

      CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS)

  

      CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO)

  

      CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH)

CC

*     CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1)



CC    CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP)

      FIEP  = 0.D0

      DFIEP = 0.D0

      DDFIEP= 0.D0

      DO 510 JJ=1,2

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIEP = FIEP + ASIG(JJ)*FJJ

      DFIEP= DFIEP + ASIG(JJ)*DFJJ

 510  DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ

C     S*:

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST)



C     POMERON:

c*    XPOM = X*AMPOM/PIM0

c*    FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2*

c*   .       FDEXP(-XPOM*XPOM)

c*    DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO

c*    DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0)



C------------------------------------------------------------

C

C     CONSTRUCTION OF THE POTENTIALS

C

C------------------------------------------------------------

C

C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(IPIET.NE.0) THEN

      ALM2 = ALMKA

      DO 20 II=1,3 

      GOTO(23,24,25),II



C     PI-KA(8s):

23    FACISC= 0.5d0*SR3

c     IF(APV.EQ.1.D0) THEN

      FACSO1= PIM0/(AMLAM+AMN)

      FACSO2= PIM0/(2*AMN)

      FACSO3= PIM0/(AMSIGM+AMN)

      FACSO4= PIM0/(AMSIGM+AMLAM)

      copln = +3*prpe1(4)*f(1)*f(4)

      copsn = +3*prpe1(4)*f(3)*f(5)

      ALM1 = ALMP8

      AM1 = PIM

      AM2 = AMK

      GOTO 28



C     ETA-KA(8s):

24    FACISC= -0.5D0*DCOS(THPS)

      copln = +prpe1(4)*f(6)*f(4)

      copsn = 0.d0                  

      ALM1 = ALMP8

      AM1 = AME 

      AM2 = AMK

      GOTO 28



C     ETA'-KA(8s):

25    FACISC= -0.5D0*DSIN(THPS)

      copln = +prpe1(4)*f(9)*f(4)

      copsn = 0.d0                  

      ALM1 = ALMP1

      AM1 = AMX 

      AM2 = AMK



 28   CONTINUE



C     COMPUTATION SPIN-ORBIT, NOW USING PV_COUPLING

C     WHICH GIVES OMEGA's AT THE VERTICES:           

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      FMSO1 = -X1*FUN(2)*P             ! PV-coupling

      FMSO2 = -X1*FUN(3)*P             ! PV-coupling

      FMSO3 = -X1*FUN(2)*P             ! PV-coupling

      FMSO4 = -X1*FUN(3)*P             ! PV-coupling

      fmso1=0d0       ! terms are already included vi ompair!?

      fmso2=0d0

      fmso3=0d0

      fmso4=0d0

      VOLL1= VOLL1 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1

     .                +FACSO2*FMSO2)

     .             + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1

     .                +FACSO4*FMSO2)

c     write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn,

c     write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn,

c    .' prpe1(4)=',prpe1(4)

c     write(*,*) ' piet: FMSO1=',FMSO1,' voll1=',voll1



20    CONTINUE

c     VOLL = VOLL + VOLL1

      VALL = VALL + VALL1

      ENDIF

C

C C)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :

C

      IF(IPIPI1.NE.0) THEN

      DO 30 II=1,3

c     PX = -1.D0

      PSF= -PX

      PSF= +PX

      GOTO(33,34,341),II



C     PI-KA(8a):

33    AM1 = PIM

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FMSO1 = -X1*DFI*VKU*PSF       ! PV-coupling

      FMSO2 = -X1*VKU*DFIKA*PSF     ! PV-coupling

      FACISC = 0.5D0

c     IF(APV.EQ.1.D0) THEN

      FACSO1= PIM0/(AMLAM+AMN)       

      FACSO2= PIM0/(2*AMN)       

      FACSO3= PIM0/(AMSIGM+AMN)       

      FACSO4= PIM0/(AMSIGM+AMLAM)       

      copln = +3*prppg(4)*f(1)*f(4)

      copsn = +3*prppg(4)*f(3)*f(5)

      PEX = P

      GOTO 36



C     ETA-KA(8a):

34    AM1 = AME

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FMSO1 = -X1*DFIETA*VKU*PSF    ! PV-coupling

      FMSO2 = -X1*VKU*DFIKA*PSF     ! PV-coupling

      FACISC = 0.5D0*SR3*DCOS(THPS)

      copln = +prppg(4)*f(6)*f(4)

      copsn = 0d0                   

      PEX = P



C     ETAP-KA(8a):

341   AM1 = AMX

      AM2 = AMK

      ALM1= ALMP1

      ALM2= ALMKA

      FMSO1 = -X1*DFIETP*VKU*PSF    ! PV-coupling

      FMSO2 = -X1*VKU*DFIKA*PSF     ! PV-coupling

      FACISC = 0.5D0*SR3*DSIN(THPS)

      copln = +prppg(4)*f(9)*f(4)

      copsn = 0d0                   

      PEX = P



36    CONTINUE

c     fmso1=0d0   ! terms already included via ompair!?

c     fmso2=0d0    

c36    CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

c     VOLL2 = VOLL2 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1

c    .                +FACSO2*FMSO2)

c    .              + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1

c    .                +FACSO4*FMSO2)

      VALL2 = VALL2 + 4*FACT*FACISC*COPLN*(FACSO1*FMSO1

     .                -FACSO2*FMSO2)

     .              + 4*FACT*FACISC*COPSN*(FACSO3*FMSO1

     .                +FACSO4*FMSO2)

c     write(*,*) 'YNPAIRS, pi-pi: II=',ii,' vall2=',vall2

30    CONTINUE

      VALL = VALL + VALL2

      ENDIF

C

C 3)  AXIAL PAIR TERMS OF THE FIRST CLASS:

C

      IF(IPIRO1.NE.0) THEN

      PX  = -1.d0  ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO

      PSF = -PX

      PSF = +PX

c*    ALM1 = ALMP8

      ALM2 = ALMV8

      DO 40 II=1,6

      GOTO(43,44,488,46,47,49),II



C     PI-K*(AXIAL):

43    FMSO1= (-X1*DFI*FIKS)*PSF

      FACISC = 0.5D0

      FACSO1= PIM0/AMN-PIM0/AMLAM           

      FACSO2= PIM0/AMN+PIM0/AMLAM           

      FACSO3= PIM0/AMN-PIM0/AMSIGM          

      FACSO4= PIM0/AMN+PIM0/AMSIGM          

      DIVLN = 0.5D0*PIM0/AMN

      DIVSN = 1.0D0*PIM0/(AMLAM+AMSIGM)

      copln = +3*prpr1(4)*f(1)*(fd(4)+fv(4))

      copsn = +3*prpr1(4)*f(3)*(fd(5)+fv(5))

      fesig2= dfi*dfiks

      AM1 = PIM

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      GOTO 48



C     ETA-K*(AXIAL):

44    FMSO1=  (-X1*DFIETA*FIKS)*PSF

      FACISC = 0.5D0*SR3*DCOS(THPS)

      copln = +prpr1(4)*f(6)*(fd(4)+fv(4))

      copsn = 0d0                            

      fesig2= dfieta*dfiks

      AM1 = AME

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      GOTO 48



C     ETA'-K*(AXIAL):

488   FMSO1=  (-X1*DFIETP*FIKS)*PSF

      FACISC = 0.5D0*SR3*DSIN(THPS)

      copln = +prpr1(4)*f(9)*(fd(4)+fv(4))

      copsn = 0d0                            

      fesig2= dfietp*dfiks

      AM1 = AMX

      AM2 = AMKS

      ALM1= ALMP1

      PEX = P

      GOTO 48



C     KA-RO(AXIAL):

46    FMSO1=  (-X1*FIKA*DFIR)*PSF

      FACISC = 0.5D0

      FACSO1= 0.D0

      FACSO2= 2*PIM0/AMN           

      FACSO3= PIM0/AMLAM-PIM0/AMSIGM         

      FACSO4= PIM0/AMLAM+PIM0/AMSIGM         

      DIVLN = 1.0D0*PIM0/(AMN+AMLAM)

      DIVSN = 1.0D0*PIM0/(AMN+AMSIGM)

      copln = +3*prpr1(4)*f(4)*(fd(1)+fv(1))

      copsn = +3*prpr1(4)*f(5)*(fd(3)+fv(3))

      fesig2= dfika*dfir 

      AM1 = AMK

      AM2 = AMRO

      ALM1= ALMKA

      PEX = P

      GOTO 48



C     KA-PHI(AXIAL):

47    FMSO1=  (-X1*FIKA*DFIPH)*PSF

      FACISC = 0.5D0*SR3*DCOS(THV)

      copln = +prpr1(4)*f(4)*(fd(6)+fv(6))

      copsn = 0d0                          

      fesig2= dfika*dfiph

      AM1 = AMK

      AM2 = AMFI

      ALM1= ALMKA

      ALM2= ALMV8

      PEX = P

      GOTO 48



C     KA-OMEGA(AXIAL):

49    FMSO1=  (-X1*FIKA*DFIOM)*PSF

      FACISC = 0.5D0*SR3*DSIN(THV)

      copln = +prpr1(4)*f(4)*(fd(9)+fv(9))

      copsn = 0d0                          

      fesig2= dfika*dfiom

      AM1 = AMK

      AM2 = AMOM

      ALM1= ALMKA

      ALM2= ALMV1

      PEX = P

      GOTO 48



48    CONTINUE

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      FMSO3 = -X1*FUN(2)

     .*PSF

      FMSO4 = -X1*FUN(3)

     .*PSF



c     VALS   =   VALS    - FACT*2*(CCPR4(II,2)+CCPR4F(II,2))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VALS   =   VALS    - FACT*2*(CCPR4(II,3)+CCPR4F(II,3))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VASS   =   VASS    - FACT*2*(CCPR4(II,4)+CCPR4F(II,4))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VADR   =   VADR    - FACT*2*(CCPR4(II,5)+CCPR4F(II,5))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1



C     COMPARISON WITH PRC54, paper II -> extra overall (-)-sign

C------------------------------------------------------------------

C     FOR PI-K* ETC: -(i/2) for H_AVP:

      IF(II.LE.3) THEN

c     VOLL31=       + FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN)

c    .               +(FACSO2-FACSO1)*DIVLN*FMSO4 )

c     VOLL32=       + FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN)

c    .               -(FACSO4+FACSO3)*DIVSN*FMSO4 )

c     voll3 = voll3 + voll31+voll32

cjan07VALL31=       + FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN)

      VALL31=       - FACT*FACISC*COPLN*(FACSO1*(FMSO1-FMSO3*DIVLN)

     .               +(FACSO2-FACSO1)*DIVLN*FMSO4 )



      VALL32=       - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN)

     .               -(FACSO4+FACSO3)*DIVSN*FMSO4 )

      vall3 = vall3 + vall31+vall32

c     write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3,1=',vall31,

c    .' vall3,2=',vall32

c     vsig3 =       - FACT*FACISC*COPLN*FACSO2*FESIG2/3D0

c     vsig3 =       - FACT*FACISC*COPLN*2*PIM0/AMN*FESIG2/3D0

*     if(ii.eq.1) write(*,*) 'YNEXLS: II=',ii,' vsig3,1=',vsig3  

      ENDIF

C------------------------------------------------------------------

C     FOR K-RHO ETC: +(i/2) for H_AVP:

      IF(II.GE.4) THEN

c     VOLL33=       + FACT*FACISC*COPLN*(FACSO2*FMSO4*DIVLN)

c     VOLL34=       - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN)

c    .               -(FACSO4+FACSO3)*DIVSN*FMSO4 )

c     voll3 = voll3 + voll33+voll34

      VALL33=       - FACT*FACISC*COPLN*(FACSO2*FMSO4*DIVLN)

      VALL34=       - FACT*FACISC*COPSN*(FACSO3*(FMSO1-FMSO3*DIVSN)

     .               -(FACSO4+FACSO3)*DIVSN*FMSO4 )

      vall3 = vall3 + vall33+vall34

c     write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3,3=',vall33,

c    .' vall3,4=',vall34

c     vsig3 =       - FACT*FACISC*COPLN*FACSO2*FESIG2/3D0

c     if(ii.eq.1) write(*,*) 'YNEXLS: II=',ii,' vsig3,2=',vsig3  

      ENDIF

C------------------------------------------------------------------

c     write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll3=',voll3

c     write(*,*) 'YNPAIRS, pi-rho: II=',ii,' vall3=',vall3

c     write(*,*) ' copln=',copln,' copsn=',copsn

c     write(*,*) ' fms01=',fmso1,' fmso2=',fmso2

c     write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3



40    CONTINUE

      VOLL = VOLL + VOLL3

      VALL = VALL + VALL3

      ENDIF



C

C 4)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

*     IF(IPIRO0.EQ.1) THEN

*     VSIG  =   VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2

*    .      -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) )

*

*     VTEN  =   VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2

*    .      -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) )

*     ENDIF

C

C 5)  AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :

c     IF(IPIOM.EQ.1) THEN

c     IF(HOPAIR.NE.0.D0) THEN

c     VSIG  =   VSIG  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     VTEN  =   VTEN  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     ENDIF

c     ENDIF

C------------------------------------------------------------

C

C E)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

C------------------------------------------------------------

C     HERE: ETA8 = ETA(548) (THPS IS SMALL), 

C           PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019)

C------------------------------------------------------------

      IF(IPIOM.EQ.2) THEN

      ITYPE=5

      PX  = -1.d0  ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO

c*    DO 90 II=1,5 

      DO 90 II=1,4 

      PEX = 1.D0

      GOTO(94,96,95,97,971),II



C     PI-K*(8S):

94    FMSO1=  -X1*(DVKU*FIKS+VKU*DFIKS)*P

      FMSO2= (-X1*VKU*DFIKS)*P

      FMSO3= FMSO1               

      FMSO4= FMSO1               

      FMSO5= -X1*(DVKU*FIKS-VKU*DFIKS)*P

      FACISC = +0.25D0*SR3                                     

      FACSO1= +0.5D0*(PIM0/AMN-PIM0/AMLAM)*PIM0/AMN

      FACSO2= -0.5D0*(PIM0/AMN+PIM0/AMLAM)*PIM0/AMN

      FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM)

      FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM)

     .         /2.D0

      FACSO5= -FACSO4

      CALL FOOMPR(ITYPE,X,PIM,AMKS,ALMP8,ALMV8)             

c**   copln = +3*prpo1(4)*f(1)*(fd(4)+fv(4))

c**   copsn = +3*prpo1(4)*f(3)*(fd(5)+fv(5))

      copln = +3*prpo1(4)*f(1)*fd(4)

      copsn = +3*prpo1(4)*f(3)*fd(5)

      PEX = P

      GOTO 990



C     ETA-K*:    

96    FMSO1=  (-X1*DFI*FIKS)*P

      FMSO2= (-X1*FI*DFIKS)*P

      FACISC = -0.25D0*DCOS(THPS)

      CALL FOOMPR(ITYPE,X,AME,AMKS,ALMP8,ALMV8)             

c**   copln = +prpo1(4)*f(6)*(fd(4)+fv(4))

      copln = +prpo1(4)*f(6)*fd(4)

      copsn = 0d0                            

      PEX = P

      GOTO 990



C     KA-RHO(8S)(I=1):

95    FMSO1=  (-X1*VKU*DFIKS)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIKS)*P

      FMSO4=  (-X1*VKU*DFIKS)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3

      FACSO1= +2*PIM0/AMN*PIM0/(AMN+AMSIGM)

      FACSO2= 0.D0

      FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*

     .          PIM0/(AMN+AMSIGM)

      FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*

     .          PIM0/(AMN+AMSIGM)

      FACSO5= 0.D0

      CALL FOOMPR(ITYPE,X,AMK,AMRO,ALMP8,ALMV8)             

c**   copln = +prpo1(4)*f(4)*(fd(1)+fv(1))

c**   copsn = +prpo1(4)*f(5)*(fd(3)+fv(3))

      copln = +prpo1(4)*f(4)*fd(1)

      copsn = +prpo1(4)*f(5)*fd(3)

      PEX = P

      GOTO 990



C     KA-PHI8:  

C     KA-OMEGA:

97    FMSO1=  (-X1*VKU*DFIOM)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIOM)*P

      FMSO4=  (-X1*VKU*DFIOM)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3*DSIN(THV)

      CALL FOOMPR(ITYPE,X,AMK,AMOM,ALMP8,ALMV8)             

      FASO = FASO

c**   copln = +prpo1(4)*f(4)*(fd(9)+fv(9))

      copln = +prpo1(4)*f(4)*fd(9)

      copsn =0d0

      PEX = P

      GOTO 990



C     KA-PHI:   

971   FMSO1=  (-X1*VKU*DFIPH)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIPH)*P

      FMSO4=  (-X1*VKU*DFIPH)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3*DCOS(THV)

      CALL FOOMPR(ITYPE,X,AMK,AMFI,ALMP8,ALMV8)             

      FASO = FASO

c**   copln = +prpo1(4)*f(4)*(fd(6)+fv(6))

      copln = +prpo1(4)*f(4)*fd(6)

      copsn = 0d0                            

      PEX = P



990   CONTINUE

c     !!! NOT INCLUDED VIA OMPAIR !!

c         --> DO ALSO THE OTHER EXCHANGES!!

      GOTO 5000       ! NO 1/M^2-TERMS!

      VOLL4 = VOLL4 + FACT*FACISC*

     .        COPLN*(FACSO1*FMSO1+FACSO2*FMSO2) 

c     write(*,*) 'YNPAIRS, pi-K*: II=',ii,' voll41=',voll4

      VOLL4 = VOLL4 + FACT*FACISC*COPSN*(FACSO3*FMSO3+

     .        FACSO4*FMSO4) 

      VALL4 = VALL4 + FACT*FACISC*COPSN*(FACSO5*FMSO5)

c     write(*,*) 'YNPAIRS, K-rho : II=',ii,' voll42=',voll4

c     write(*,*) 'YNPAIRS, K-rho : II=',ii,' vall42=',vall4

c     write(*,*) ' copln=',copln,' copsn=',copsn

c     write(*,*) ' fms01=',fmso1,' fmso2=',fmso2,' fmso3=',fmso3

c     write(*,*) ' fms04=',fmso4,' fmso5=',fmso5

c     write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3

c     write(*,*) ' facs04=',facso4,' facso5=',facso5

5000  CONTINUE



c     1/M-TERMS:

      VALL4 = VALL4  + PX*FACT*FACISC*FASO* 

     .     (COPLN*PIM0/AMN/2D0 - COPSN*PIM0/(AMLAM+AMSIGM))



90    CONTINUE

      VOLL = VOLL + VOLL4

      VALL = VALL + VALL4

      ENDIF

C------------------------------------------------------------

C

C 6)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:

ccc   nog te doen: 

      goto 500

      IF(IPISI.NE.0) THEN

      DO 50 II=1,2

      GOTO(52,55),II



C     KA-EPSILON:

52    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P

      AM1 = AMK

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 4

      GOTO 57



C     KA-SSTAR:

55    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P

      AM1 = AMK

      AM2 = AMSST

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 3



57    IF(II.LE.3) THEN

      FFSIG2 = 0.D0

      FFTEN2 = 0.D0

      IF(N2PRA.EQ.1) THEN

      DO 112 JJ=1,2

      AM2=AMSIG(JJ)

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN)

      FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

  112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN)

      FFSIG2 =        +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      FFTEN2 =        +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF



c     VSNN   =   VSNN    + FACT*(

c    .           CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0

c     VSLL   =   VSLL    + FACT*(

c    .           CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0

c     VSLS   =   VSLS    + FACT*(

c    .           CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0

c     VSSS   =   VSSS    + FACT*(

c    .           CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0

c     VSDR   =   VSDR    + FACT*(

c    .           CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0



c     VTNN   =   VTNN    + FACT*(

c    .           CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0

c     VTLL   =   VTLL    + FACT*(

c    .           CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0

c     VTLS   =   VTLS    + FACT*(

c    .           CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0

c     VTSS   =   VTSS    + FACT*(

c    .           CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0

c     VTDR   =   VTDR    + FACT*(

c    .           CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0



50    CONTINUE

      ENDIF

500   continue

C

C     --------------------------------------------------------------

C 8)  TENSOR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C     --------------------------------------------------------------

C     only 1-pair terms included!!

ccc   nog te doen: 

      goto 800

      IF(IPIPI2.NE.0) THEN

      DO 80 II=1,2 

      GOTO(83,84),II



C     PI-KA(8s):

83    AM1 = PIM 

      AM2 = AMK

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0

      IMES1 = 1

      IMES2 = 2

      GOTO 88



C     ETA-KA(8s):

84    AM1 = AMK 

      AM2 = AME

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0

      IMES1 = 2

      IMES2 = 3

      GOTO 88



88    IF(II.EQ.2.OR.II.EQ.5) THEN

      CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN)

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN)

      ENDIF

      FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO)

      FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO)

      FSO1  = -X2*FUN(4)*(PIM/AMPRO)



c     VCNN   =   VCNN    + ISFAC*FACT* CCPR8(II,1)*FCEN1  

c     VSNN   =   VSNN    + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0

c     VTNN   =   VTNN    + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0

c     VONN   =   VONN    + ISFAC*FACT* CCPR8(II,1)*FSO1 



c     VCLL   =   VCLL    + FACT* CCPR8(II,2)*FCEN1  

c     VSLL   =   VSLL    + FACT* CCPR8F(II,2)*FSIG1/3.D0

c     VTLL   =   VTLL    + FACT* CCPR8F(II,2)*FTEN1/3.D0

c     VOLL   =   VOLL    + FACT* CCPR8(II,2)*FSO1 



c     VCLS   =   VCLS    + FACT* CCPR8(II,3)*FCEN1  

c     VSLS   =   VSLS    + FACT* CCPR8F(II,3)*FSIG1/3.D0

c     VTLS   =   VTLS    + FACT* CCPR8F(II,3)*FTEN1/3.D0

c     VOLS   =   VOLS    + FACT* CCPR8(II,3)*FSO1 



c     VCSS   =   VCSS    + FACT* CCPR8(II,4)*FCEN1  

c     VSSS   =   VSSS    + FACT* CCPR8F(II,4)*FSIG1/3.D0

c     VTSS   =   VTSS    + FACT* CCPR8F(II,4)*FTEN1/3.D0

c     VOSS   =   VOSS    + FACT* CCPR8(II,4)*FSO1 



c     VCDR   =   VCDR    + FACT* CCPR8(II,5)*FCEN1  

c     VSDR   =   VSDR    + FACT* CCPR8F(II,5)*FSIG1/3.D0

c     VTDR   =   VTDR    + FACT* CCPR8F(II,5)*FTEN1/3.D0

c     VODR   =   VODR    + FACT* CCPR8(II,5)*FSO1 

80    CONTINUE



      if(x.eq.0.01d0) then 

      write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1

      write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 

      write(*,*) ' ccpr8=',ccpr8(ii,1)

      endif

      ENDIF

800   continue



      ICALL=ICALL+1

      RETURN

      END



C **********************************************************************

      SUBROUTINE YNPREXPS(X,IPV)

C **********************************************************************

C *

C     MASS DIFFERENCE CONTRIBUTION FOR STRANGENESS-EXCHANGE

C     TO SYMMETRIC AND ANTI-SYMMETRIC SPIN-ORBIT POTENTIALS



C     ALTERNAIVE COMPUTATION SPIN-ORBIT, NOW USING PS_COUPLING

C     WHICH GIVES MASS DIFFERENCES AT THE VERTICES !!           

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      COMMON/PIMAS/PIM0

      COMMON/MODEL/IXXX(8),NSU3F

      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS,AMNN

      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,

     .             ALMKA,ALMKS,ALMKP

      COMMON/POTESC/VCLL,VCSS,VCLS,VCDR,VSLL,VSSS,VSLS,VSDR,

     .              VTLL,VTSS,VTLS,VTDR,VOLL,VOSS,VOLS,VODR,

     .              VALL,VASS,VALS,VADR

      COMMON/ALLPS/AMPI,AME,AMX,AMK,BMK

      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI,AMKS,BMKS

      COMMON/ALLSC/ASIG(2),AMSIG(2),ASST,BSST,AMSST,AM2ST,AMD,AMSCK

      COMMON/ALLDF/AMPOM,AMF2,AMA2,AMKSS,G9D(11)

      COMMON/COUCON/ALP,GX0,FX0,THPS,ALVD,GOM,THV,ALVV,FOM,THS,GDEL,

     .GEPS,GSST,ALF,GPOM,GPOMP,GA2,PSID,THD,AHYPC,ALS,SSCAL,ALD,ALPA

      COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11),P,PX

      DIMENSION FUN(12),WGHTID(2)

C

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI,HOPAIR

     .            ,GSISI,GPIET,GPIETP,GPIPOM,GOMETA

     .            ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR



      COMMON/PRCOP/PRPP0(11),PRPE1(11),PRPPG(11),PRPPF(11),

     .             PRPR1(11),PRPO1(11),PRPSI(11),PRPPO(11),

     .             PRTEN(11),PRTENF(11)



C     communication with routine YNPRCC:

C

      COMMON/CCPR/ CCPR1(3,10),CCPR2(10,10),CCPRG(9,10),CCPRF(9,10),

     .CCPR4(9,10),CCPR4F(9,10),CCPR5(6 ,10),CCPR6(10)  ,CCPR7(3,10),

     .CCPR8(10,10),CCPR8F(10,10),CCPR10(13,10),

     .CCPR11(4,10),CCPR11F(4,10)                 ! MARCH 2009

C

      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,

     .ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IKKB0,IKKB1,IPIA1,IOMETA   ! MARCH 2009

      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB

      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX,IZTEN



      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/

      DATA FACID/1.0D0/,SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/

      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEPS/760.D0/,AMSCR/750.D0/,

     .     AMN/938.2796D0/,FACT/138.041D0/,POLD/-12345.D0/,

     .     AKMAX/0000.D0/,XKMAX/2.D0/,

     .     AMLAM/1115D0/,AMSIGM/1190D0/



      DATA ICALL/0/,NSCHR/0/,N3/27/,ISU3/0/

      data ipipi2/0/



      COMMON/EXCHSO/VOLL1,VOLL2,VOLL3,VOLL4,VOLL5,

     .              VALL1,VALL2,VALL3,VALL4,VALL5               



      SAVE PIM,XBEGIN,FACT,AMN,DAM,AA,ICALL

C

      IF(IPV.NE.0) RETURN

C     WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING

      WGHTID(1) = DSIN(THV)       

      WGHTID(2) = DCOS(THV)       



      IF(ICALL.EQ.0) THEN

        PIM = PIM0

        XBEGIN=X

        IF(NSU3F.EQ.1) CALL SU3SYM(PIM,AMN,AMPRO,AMRO,AMEPS)

        FACT  = PIM0

c       AMNC = DSQRT(AM(2)*AM(3))

c       AMHY = DSQRT(AMY(1)*AMY(2))

C       AMN  = DSQRT(AMNN*AMH )

        DAM  = AMH-AMN

        AA   = DAM/PIM0

      ENDIF



      if(p.ne.pold) then

      icall=0

      pold=p

      nschr=1

      endif



c     DO 1 I=2,NMAX

c     X = XA(I)

      VOLL1 = 0D0

      VOLL2 = 0D0

      VOLL3 = 0D0

      VOLL4 = 0D0

      VOLL5 = 0D0

      VALL1 = 0D0

      VALL2 = 0D0

      VALL3 = 0D0

      VALL4 = 0D0

      VALL5 = 0D0

CC

CC

      X1   =1.D0/X

      X2   =X1*X1     

CC

      CALL FFUN(2,X,PIM,ALMP8,FI,DFI,DDFI,D3FI)

      CALL FFUN(1,X,PIM,ALMP8,FI1,DFI1,DDFI1,D3FI1)

      CALL FFUN(0,X,PIM,ALMP8,VKU,DVKU,DDVKU,D3VKU)

C     ETA:

      CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA)

C     ETAP:

      CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP)

  

C     KAON:

c*    CALL FFUN(2,X,AMK,ALMP8,FIKA,DFIKA,DDFKA,D3FKA)

      CALL FFUN(2,X,AMK,ALMKA,FIKA,DFIKA,DDFKA,D3FKA)

CC

c     CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR)

      FIRO  = 0.D0

      DFIR  = 0.D0

      DO 410 JJ=1,2

      CALL FFUN(2,X,AMVEC(JJ),ALMV8,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIRO = FIRO + AVEC(JJ)*FJJ

 410  DFIR = DFIR  + AVEC(JJ)*DFJJ

C     K*(892):

      CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS)

  

      CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO)

  

      CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH)

CC

c     CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1)



CC    CALL FFUN(2,X,AMEPS,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP)

      FIEP  = 0.D0

      DFIEP = 0.D0

      DDFIEP= 0.D0

      DO 510 JJ=1,2

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSIG(JJ),ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSIG(JJ),AMSCR,ALMS1,FJJ,DFJJ,DDFJJ,D3FJJ)

      FIEP = FIEP + ASIG(JJ)*FJJ

      DFIEP= DFIEP + ASIG(JJ)*DFJJ

 510  DDFIEP= DDFIEP + ASIG(JJ)*DDFJJ

C     S*:

      IF(IZSC.EQ.0) CALL

     .FFUN(2,X,AMSST,ALMS8,FIST,DFIST,DDFIST,D3FIST)

      IF(IZSC.NE.0) CALL

     .FFUNZ(2,X,AMSST,AMSCR,ALMS8,FIST,DFIST,DDFIST,D3FIST)



C     POMERON:

c*    XPOM = X*AMPOM/PIM0

c*    FIPO = (4.D0/SRPI)*(AMPOM/PIM0)*(AMPOM/AMPRO)**2*

c*   .       FDEXP(-XPOM*XPOM)

c*    DFIPO = -2*(AMPOM/PIM0)*XPOM*FIPO

c*    DDFIPO= -2*(AMPOM/PIM0)*(XPOM*DFIPO + FIPO*AMPOM/PIM0)



C------------------------------------------------------------

C

C     CONSTRUCTION OF THE POTENTIALS

C

C------------------------------------------------------------

C

C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C

      IF(IPIET.NE.0) THEN

      ALM2 = ALMKA

      DO 20 II=1,3 

      GOTO(23,24,25),II



C     PI-KA(8s):

23    FMSO1 = -X1*DFI*FIKA*P

      FMSO3 = -X1*FI*DFIKA*P

      FACISC= 0.5d0*SR3

c     IF(APV.EQ.0.D0) THEN

      FACSO1= (AMLAM-AMN)/(AMLAM+AMN)

      FACSO2= -(AMSIGM-AMN)/(AMSIGM+AMN)

      FACSO3= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM)

      copln = +3*prpe1(4)*f(1)*f(4)

      copsn = +3*prpe1(4)*f(3)*f(5)

      ALM1 = ALMP8

      AM1 = PIM

      AM2 = AMK

      GOTO 28



C     ETA-KA(8s):

24    FMSO1 = -X1*DFIETA*FIKA*P

      FMSO3 = -X1*FIETA*DFIKA*P

      FACISC= -0.5D0*DCOS(THPS)

      copln = +prpe1(4)*f(6)*f(4)

      copsn = 0.d0                  

      ALM1 = ALMP8

      AM1 = AME 

      AM2 = AMK

      GOTO 28



C     ETA'-KA(8s):

25    FMSO1 = -X1*DFIETP*FIKA*P

      FMSO3 = -X1*FIETP*DFIKA*P

      FACISC= -0.5D0*DSIN(THPS)

      copln = +prpe1(4)*f(9)*f(4)

      copsn = 0.d0                  

      ALM1 = ALMP1

      AM1 = AMX 

      AM2 = AMK



 28   CONTINUE



C     ALTERNAIVE COMPUTATION SPIN-ORBIT, NOW USING PS_COUPLING

C     WHICH GIVES MASS DIFFERENCES AT THE VERTICES, INSTEAD

C     OF OMEGA's:

      VOLL1= VOLL1 + 4*FACT*FACISC*COPLN*FACSO1*FMSO1

     .             + 4*FACT*FACISC*COPSN*FACSO2*FMSO1

     .             + 4*FACT*FACISC*COPSN*FACSO3*FMSO3

      write(*,*) ' piet: FMSO1=',FMSO1,' voll1=',voll1

c     write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn,

c     write(*,*) ' ynpairs: ii=',ii,' copln=',copln,' copsn=',copsn,

c    .' prpe1(4)=',prpe1(4)



20    CONTINUE

c     VOLL = VOLL + VOLL1

      VALL = VALL + VALL1

      ENDIF

C

C C)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :

C

      IF(IPIPI1.NE.0) THEN

      DO 30 II=1,3

      GOTO(33,34,341),II



C     PI-KA(8a):

33    AM1 = PIM

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FACISC = 0.5D0

c     IF(APV.EQ.0.D0) THEN

      FACSO1= (AMLAM-AMN)/(AMLAM+AMN)       

      FACSO2= -(AMSIGM-AMN)/(AMSIGM+AMN)       

      FACSO2= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM)       

      copln = +3*prppg(4)*f(1)*f(4)

      copsn = +3*prppg(4)*f(3)*f(5)

      PEX = P

      GOTO 36



C     ETA-KA(8a):

34    AM1 = AME

      AM2 = AMK

      ALM1= ALMP8

      ALM2= ALMKA

      FACISC = 0.5D0*SR3*DCOS(THPS)

      copln = +prppg(4)*f(6)*f(4)

      copsn = 0d0                   

      PEX = P



C     ETAP-KA(8a):

341   AM1 = AMX

      AM2 = AMK

      ALM1= ALMP1

      ALM2= ALMKA

      FACISC = 0.5D0*SR3*DSIN(THPS)

      copln = +prppg(4)*f(9)*f(4)

      copsn = 0d0                   

      PEX = P



36    CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)

      FMSO1 = -X1*FUN(2)*P             ! PS-coupling

      FMSO3 = -X1*FUN(3)*P             ! PS-coupling

      VOLL2 = VOLL2 + 8*FACT*FACISC*(COPLN*FACSO1*FMSO1

     .     +COPSN*FACSO2*FMSO1+COPSN*FACSO3*FMSO3)

      write(*,*) 'YNPAIRS, pi-pi: II=',ii,' voll12=',voll2

30    CONTINUE

      VOLL = VOLL + VOLL2

      ENDIF

C

C 3)  AXIAL PAIR TERMS OF THE FIRST CLASS:

C

      IF(IPIRO1.NE.0) THEN

      PX  = -1.d0  ! BDI: P-WAVE SPACE-EXCHANGE OPERATOR FOR ASO

      copln=0d0

      copsn=0d0

c*    ALM1 = ALMP8

      ALM2 = ALMV8

      DO 40 II=1,6

      FMASO1= 0.D0

      FMASO2= 0.D0

      FACISC= 0.D0

      GOTO(43,44,488,46,47,49),II



C     PI-K*(AXIAL):

43    FMSO1= (-X1*DFI*FIKS)*P

      FMSO2= FMSO1              

      FMSO3= (-X1*FI*DFIKS)*P

      FACISC = 0.5D0

      FACSO1= PIM0/AMN-PIM0/AMLAM           

      FACSO2= PIM0/AMN-PIM0/AMSIGM          

      FACSO3= -(AMSIGM-AMLAM)/(AMSIGM+AMLAM)*

     .         (1.D0/AMN+1.D0/AMLAM)

      copln = +3*prpr1(4)*f(1)*(fd(4)+fv(4))

      copsn = +3*prpr1(4)*f(3)*(fd(5)+fv(5))

      AM1 = PIM

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      GOTO 48



C     ETA-K*(AXIAL):

44    FMSO1=  (-X1*DFIETA*FIKS)*P

      FMSO2= (-X1*FIETA*DFIKS)*P

      FACISC = 0.5D0*SR3*DCOS(THPS)

      copln = +prpr1(4)*f(6)*(fd(4)+fv(4))

      copsn = 0d0                            

      AM1 = AME

      AM2 = AMKS

      ALM1= ALMP8

      PEX = P

      GOTO 48



C     ETA'-K*(AXIAL):

488   FMSO1=  (-X1*DFIETP*FIKS)*P

      FMSO2= (-X1*FIETP*DFIKS)*P

      FACISC = 0.5D0*SR3*DSIN(THPS)

      copln = +prpr1(4)*f(9)*(fd(4)+fv(4))

      copsn = 0d0                            

      AM1 = AMX

      AM2 = AMKS

      ALM1= ALMP1

      PEX = P

      GOTO 48



C     KA-RO(AXIAL):

46    FMSO1=  (-X1*FIKA*DFIR)*P

      FMSO2=  FMSO1                

      FMSO3=  (-X1*DFIKA*FIRO)*P

      FACISC = 0.5D0

      FACSO1= -2*(AMLAM-AMN)/(AMLAM+AMN)*PIM0/AMN

      FACSO2= +(AMSIGM-AMN)/(AMSIGM+AMN)*(PIM0/AMSIGM+PIM0/AMLAM)

      FACSO3= +(PIM0/AMLAM-PIM0/AMSIGM)

      copln = +3*prpr1(4)*f(4)*(fd(1)+fv(1))

      copsn = +3*prpr1(4)*f(5)*(fd(3)+fv(3))

      AM1 = AMK

      AM2 = AMRO

      ALM1= ALMKA

      PEX = P

      GOTO 48



C     KA-PHI(AXIAL):

47    FMSO1=  (-X1*FIKA*DFIPH)*P

      FMSO2=  (-X1*DFIKA*FIPH)*P

      FACISC = 0.5D0*SR3*DCOS(THV)

      copln = +prpr1(4)*f(4)*(fd(6)+fv(6))

      copsn = 0d0                          

      AM1 = AMK

      AM2 = AMFI

      ALM1= ALMKA

      ALM2= ALMV8

      PEX = P

      GOTO 48



C     KA-OMEGA(AXIAL):

49    FMSO1=  (-X1*FIKA*DFIOM)*P

      FMSO2=  (-X1*DFIKA*FIOM)*P

      FACISC = 0.5D0*SR3*DSIN(THV)

      copln = +prpr1(4)*f(4)*(fd(9)+fv(9))

      copsn = 0d0                          

      AM1 = AMK

      AM2 = AMOM

      ALM1= ALMKA

      ALM2= ALMV1

      PEX = P

      GOTO 48



48    CONTINUE



c     VALS   =   VALS    - FACT*2*(CCPR4(II,2)+CCPR4F(II,2))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VALS   =   VALS    - FACT*2*(CCPR4(II,3)+CCPR4F(II,3))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VASS   =   VASS    - FACT*2*(CCPR4(II,4)+CCPR4F(II,4))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1

c     VADR   =   VADR    - FACT*2*(CCPR4(II,5)+CCPR4F(II,5))*

c    .              FACISC*(PIM0/AMN-PIM0/AMLAM)*FMASO1



      VOLL3 = VOLL3 + FACT*FACISC*(COPLN*FACSO1 + COPSN*FACSO2)*FMSO1 

      write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll31=',voll3

      VOLL3 = VOLL3 + FACT*FACISC*COPSN*FACSO3*FMSO3

      write(*,*) 'YNPAIRS, pi-rho: II=',ii,' voll32=',voll3

      write(*,*) ' copln=',copln,' copsn=',copsn

      write(*,*) ' fms01=',fmso1,' fmso2=',fmso2

      write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3



40    CONTINUE

      VOLL = VOLL + VOLL3

      ENDIF



C

C 4)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

c     IF(IPIRO0.EQ.1) THEN

c     VSIG  =   VSIG + FACT*(-1.5D0*GPIRO0**2*FIHS2

c    .      -2*GPIRO0*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) )

c

c     VTEN  =   VTEN + FACT*(-1.5D0*GPIRO0**2*FIHT2

c    .      -2*GPIRO0*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) )

c     ENDIF

C

C 5)  AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :

c     IF(IPIOM.EQ.1) THEN

c     IF(HOPAIR.NE.0.D0) THEN

c     VSIG  =   VSIG  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     VTEN  =   VTEN  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2

c    .      -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIOM) )

c     ENDIF

c     ENDIF

C------------------------------------------------------------

C

C E)  AXIAL PAIR TERMS OF THE SECOND CLASS:

C

C------------------------------------------------------------

C     HERE: ETA8 = ETA(548) (THPS IS SMALL), 

C           PHI8 = WGHTID(1)*OMEGA(783)+WGHTID(2)*PHI(1019)

C------------------------------------------------------------

      IF(IPIOM.EQ.2) THEN

ccc   nog te doen: 

c*    DO 90 II=1,5 

      DO 90 II=1,4 

      PEX = 1.D0

      GOTO(94,96,95,97,971),II



C     PI-K*(8S):

94    FMSO1=  -X1*(DVKU*FIKS+VKU*DFIKS)*P

      FMSO2= (-X1*VKU*DFIKS)*P

      FMSO3= FMSO1               

      FMSO4= FMSO1               

      FMSO5= -X1*(DVKU*FIKS-VKU*DFIKS)*P

      FACISC = +0.25D0*SR3                                     

      FACSO1= +0.5D0*(PIM0/AMN-PIM0/AMLAM)*PIM0/AMN

      FACSO2= -0.5D0*(PIM0/AMN+PIM0/AMLAM)*PIM0/AMN

      FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM)

      FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*PIM0/(AMSIGM+AMLAM)

     .         /2.D0

      FACSO5= -FACSO4

      copln = +3*prpo1(4)*f(1)*(fd(4)+fv(4))

      copsn = +3*prpo1(4)*f(3)*(fd(5)+fv(5))

      PEX = P

      GOTO 990



C     ETA-K*:    

96    FMSO1=  (-X1*DFI*FIKS)*P

      FMSO2= (-X1*FI*DFIKS)*P

      FACISC = -0.25D0*DCOS(THPS)

      copln = +prpo1(4)*f(6)*(fd(4)+fv(4))

      copsn = 0d0                            

      PEX = P

      GOTO 990



C     KA-RHO(8S)(I=1):

95    FMSO1=  (-X1*VKU*DFIKS)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIKS)*P

      FMSO4=  (-X1*VKU*DFIKS)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3

      FACSO1= +2*PIM0/AMN*PIM0/(AMN+AMSIGM)

      FACSO2= 0.D0

      FACSO3= -(PIM0/AMLAM-PIM0/AMSIGM)*

     .          PIM0/(AMN+AMSIGM)

      FACSO4= -(PIM0/AMLAM+PIM0/AMSIGM)*

     .          PIM0/(AMN+AMSIGM)

      FACSO5= 0.D0

      copln = +prpo1(4)*f(4)*(fd(1)+fv(1))

      copsn = +prpo1(4)*f(5)*(fd(3)+fv(3))

      PEX = P

      GOTO 990



C     KA-PHI8:  

C     KA-OMEGA:

97    FMSO1=  (-X1*VKU*DFIOM)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIOM)*P

      FMSO4=  (-X1*VKU*DFIOM)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3*DSIN(THV)

      copln = +prpo1(4)*f(4)*(fd(9)+fv(9))

      copsn =0d0

      PEX = P

      GOTO 990



C     KA-PHI:   

971   FMSO1=  (-X1*VKU*DFIPH)*P

      FMSO2=  0.D0               

      FMSO3=  (-X1*DVKU*FIPH)*P

      FMSO4=  (-X1*VKU*DFIPH)*P

      FMSO5=  0.D0               

      FACISC = +0.25D0*SR3*DCOS(THV)

      copln = +prpo1(4)*f(4)*(fd(6)+fv(6))

      copsn = 0d0                            

      PEX = P



990   CONTINUE

C-----------------------------------------------------------1yy



C     IN PS-PS THEORY: NO(!) CONTRIBUTIONS: 

      fmso1=0d0

      fmso2=0d0

      fmso3=0d0

      fmso4=0d0

      fmso5=0d0

C-----------------------------------------------------------1yy



      VOLL4 = VOLL4 + FACT*FACISC*

     .        COPLN*(FACSO1*FMSO1+FACSO2*FMSO2) 

      write(*,*) 'YNPAIRS, pi-K*: II=',ii,' voll41=',voll4

      VOLL4 = VOLL4 + FACT*FACISC*COPSN*(FACSO3*FMSO3+

     .        FACSO4*FMSO4) 

      VALL4 = VALL4 + FACT*FACISC*COPSN*(FACSO5*FMSO5)

      write(*,*) 'YNPAIRS, K-rho : II=',ii,' voll42=',voll4

      write(*,*) ' copln=',copln,' copsn=',copsn

      write(*,*) ' fms01=',fmso1,' fmso2=',fmso2,' fmso3=',fmso3

      write(*,*) ' fms04=',fmso4,' fmso5=',fmso5

      write(*,*) ' facs01=',facso1,' facso2=',facso2,' facso3=',facso3

      write(*,*) ' facs04=',facso4,' facso5=',facso5



90    CONTINUE

      VOLL = VOLL + VOLL4

      VALL = VALL + VALL4

      ENDIF

C------------------------------------------------------------

C

C 6)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:

ccc   nog te doen: 

      goto 500

      IF(IPISI.NE.0) THEN

      DO 50 II=1,2

      GOTO(52,55),II



C     KA-EPSILON:

52    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIEP -DFIKA*DFIEP )*P

      AM1 = AMK

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 4

      GOTO 57



C     KA-SSTAR:

55    FFSIG1= 0.5D0*( (2*X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST)*P

      FFTEN1= 0.5D0*( (-X1*DFIKA+DDFKA)*FIST -DFIKA*DFIST )*P

      AM1 = AMK

      AM2 = AMSST

      ALM1= ALMKA

      PEX = P

      IMES1 = 2

      IMES2 = 3



57    IF(II.LE.3) THEN

      FFSIG2 = 0.D0

      FFTEN2 = 0.D0

      IF(N2PRA.EQ.1) THEN

      DO 112 JJ=1,2

      AM2=AMSIG(JJ)

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN)

      FFSIG2 = FFSIG2+ ASIG(JJ)*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

  112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS8,0.D0,FUN)

      FFSIG2 =        +N2PRA*0.5D0*( (2*X1*FUN(2)+FUN(5))

     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      FFTEN2 =        +N2PRA*0.5D0*( (-X1*FUN(2)+FUN(5))

     .                 +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )*PEX

      ENDIF



c     VSNN   =   VSNN    + FACT*(

c    .           CCPR5(II,1)*FFSIG1 + CCPR5(II,6)*FFSIG2 )/3.D0

c     VSLL   =   VSLL    + FACT*(

c    .           CCPR5(II,2)*FFSIG1 + CCPR5(II,7)*FFSIG2 )/3.D0

c     VSLS   =   VSLS    + FACT*(

c    .           CCPR5(II,3)*FFSIG1 + CCPR5(II,8)*FFSIG2 )/3.D0

c     VSSS   =   VSSS    + FACT*(

c    .           CCPR5(II,4)*FFSIG1 + CCPR5(II,9)*FFSIG2 )/3.D0

c     VSDR   =   VSDR    + FACT*(

c    .           CCPR5(II,5)*FFSIG1 + CCPR5(II,10)*FFSIG2 )/3.D0



c     VTNN   =   VTNN    + FACT*(

c    .           CCPR5(II,1)*FFTEN1 + CCPR5(II,6)*FFTEN2 )/3.D0

c     VTLL   =   VTLL    + FACT*(

c    .           CCPR5(II,2)*FFTEN1 + CCPR5(II,7)*FFTEN2 )/3.D0

c     VTLS   =   VTLS    + FACT*(

c    .           CCPR5(II,3)*FFTEN1 + CCPR5(II,8)*FFTEN2 )/3.D0

c     VTSS   =   VTSS    + FACT*(

c    .           CCPR5(II,4)*FFTEN1 + CCPR5(II,9)*FFTEN2 )/3.D0

c     VTDR   =   VTDR    + FACT*(

c    .           CCPR5(II,5)*FFTEN1 + CCPR5(II,10)*FFTEN2 )/3.D0



50    CONTINUE

      ENDIF

500   continue

C

C     --------------------------------------------------------------

C 8)  TENSOR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :

C     --------------------------------------------------------------

C     only 1-pair terms included!!

ccc   nog te doen: 

      goto 800

      IF(IPIPI2.NE.0) THEN

      DO 80 II=1,2 

      GOTO(83,84),II



C     PI-KA(8s):

83    AM1 = PIM 

      AM2 = AMK

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFI*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*(1.D0+(AMK/PIM)**2)*DFI*DFIKA/3.D0

      IMES1 = 1

      IMES2 = 2

      GOTO 88



C     ETA-KA(8s):

84    AM1 = AMK 

      AM2 = AME

c      CALL DKFUN(X,AMK,AMK,ALMKA,ALMKA,DAM,FUN)

      FCEN1 = 0.5D0*(DFIETA*DVKU+DVKU*DFIKA)

     .       +0.5D0*(2*X2*DFIETA*DFIKA+DDFI*DDFKA)/3.D0

     .       -0.25D0*((AME/PIM)**2+(AMK/PIM)**2)*DFIETA*DFIKA/3.D0

      IMES1 = 2

      IMES2 = 3

      GOTO 88



88    IF(II.EQ.2.OR.II.EQ.5) THEN

      CALL HFUN(0,X,AM1,AM2,ALMKA,ALMKA,0.D0,FUN)

      ELSE

      CALL HFUN(0,X,AM1,AM2,ALMP8,ALMP8,0.D0,FUN)

      ENDIF

      FSIG1 = -.5D0*X1*(X1*FUN(4)+FUN(7)+FUN(8))*(PIM/AMPRO)

      FTEN1 = -.25D0*X1*(2*X1*FUN(4)-FUN(7)-FUN(8))*(PIM/AMPRO)

      FSO1  = -X2*FUN(4)*(PIM/AMPRO)



c     VCNN   =   VCNN    + ISFAC*FACT* CCPR8(II,1)*FCEN1  

c     VSNN   =   VSNN    + ISFAC*FACT* CCPR8F(II,1)*FSIG1/3.D0

c     VTNN   =   VTNN    + ISFAC*FACT* CCPR8F(II,1)*FTEN1/3.D0

c     VONN   =   VONN    + ISFAC*FACT* CCPR8(II,1)*FSO1 



c     VCLL   =   VCLL    + FACT* CCPR8(II,2)*FCEN1  

c     VSLL   =   VSLL    + FACT* CCPR8F(II,2)*FSIG1/3.D0

c     VTLL   =   VTLL    + FACT* CCPR8F(II,2)*FTEN1/3.D0

c     VOLL   =   VOLL    + FACT* CCPR8(II,2)*FSO1 



c     VCLS   =   VCLS    + FACT* CCPR8(II,3)*FCEN1  

c     VSLS   =   VSLS    + FACT* CCPR8F(II,3)*FSIG1/3.D0

c     VTLS   =   VTLS    + FACT* CCPR8F(II,3)*FTEN1/3.D0

c     VOLS   =   VOLS    + FACT* CCPR8(II,3)*FSO1 



c     VCSS   =   VCSS    + FACT* CCPR8(II,4)*FCEN1  

c     VSSS   =   VSSS    + FACT* CCPR8F(II,4)*FSIG1/3.D0

c     VTSS   =   VTSS    + FACT* CCPR8F(II,4)*FTEN1/3.D0

c     VOSS   =   VOSS    + FACT* CCPR8(II,4)*FSO1 



c     VCDR   =   VCDR    + FACT* CCPR8(II,5)*FCEN1  

c     VSDR   =   VSDR    + FACT* CCPR8F(II,5)*FSIG1/3.D0

c     VTDR   =   VTDR    + FACT* CCPR8F(II,5)*FTEN1/3.D0

c     VODR   =   VODR    + FACT* CCPR8(II,5)*FSO1 

80    CONTINUE



c     if(x.eq.0.01d0) then 

c     write(*,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1

c     write(*,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1 

c     write(*,*) ' ccpr8=',ccpr8(ii,1)

c     endif

      ENDIF

800   continue



      ICALL=ICALL+1

      RETURN

      END

C **********************************************************************

      SUBROUTINE FUNPS2(N,X,AMES,ALAM,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO)

C **********************************************************************

C

C                                                 1   

C     FOURIER TRANSFORM OF  F(OMEGA)= (4 PI) x ---------

C                                              OMEGA^{N}

C     FOR N=2;   X = DISTANCE IN PION-WAVE-LENGTH

C

C     DF = DF/DX, DDF = D^2 F/DX^2, ETC. , X = PIM*R

C

C **********************************************************************

      IMPLICIT REAL*8(A-H,O-Z)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,PIM/138.041D0/

c     SAVE PIM,PI,SRPI

C-----------------------------------------------------------------

C

C     POTENTIAL FUNTION DEFINITION

C

C-----------------------------------------------------------------

      F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)

      H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)

C-----------------------------------------------------------------

CC

      X1   = 1.D0/X

      X2   = X1*X1

      X3   = X1*X2

      X4   = X2*X2

CC

      RATP =PIM/ALAM

      XLAM =0.5D0*X*ALAM/PIM

      XLAM2=XLAM*XLAM

      VKUA  =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)

      DVKUA =-0.5D0*(ALAM/PIM)**2*X*VKUA

      DDVKUA=-0.5D0*(ALAM/PIM)**2*(X*DVKUA+VKUA)

      D3VKUA=-0.5D0*(ALAM/PIM)**2*(X*DDVKUA+2*DVKUA)

      D4VKUA=-0.5D0*(ALAM/PIM)**2*(X*D3VKUA+3*DDVKUA)



C     IF(N.EQ.0) THEN

C     F = (ALAM/PIM)**2*VKUA

C     DF = (ALAM/PIM)**2*DVKUA

C     DDF = (ALAM/PIM)**2*DDVKUA

C     D3F  = (ALAM/PIM)**2*D3VKUA

C     D4F   = (ALAM/PIM)**2*D4VKUA

C     RETURN

C     ENDIF



C     IF(N.NE.1) THEN

      XA   =X*AMES/PIM

      RATA =AMES/ALAM

      ERATA=DEXP(RATA*RATA)

      EXA  =DEXP(XA)

      EMA  =FDERFC(-XLAM +RATA)

      EPA  =FDERFC( XLAM +RATA)

      FIA  =F0(ERATA,EXA ,EMA ,EPA ,X)

      HIA  =H0(ERATA,EXA ,EMA ,EPA ,X)

      DFIA =-(FIA -2*VKUA)*X1-(AMES/PIM)*HIA

      DHIA  =-(AMES/PIM)*FIA -HIA *X1

      DDFIA =-(DFIA-2*DVKUA)*X1+(FIA-2*VKUA)*X2-(AMES/PIM)*DHIA

      DDHIA =-(AMES/PIM)*DFIA-DHIA*X1+HIA*X2

      D3FIA =-(DDFIA-2*DDVKUA)*X1+(DFIA-2*DVKUA)*X2-(AMES/PIM)*DDHIA

     .       +(DFIA-2*DVKUA)*X2-2*(FIA-2*VKUA)*X3

C     D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3

C     D4FIA =-(D3FIA-2*D3VKUA)*X1+3*(DDFIA-2*DDVKUA)*X2-(AMES/PIM) 

C    .       *D3HIA-6*(DFIA-2*DVKUA)*X3+6*(FIA-2*VKUA)*X4

C-----------------------------------------------------------------

C     F = FIA

C     DF = DFIA

C     DDF = DDFIA

C     D3F = D3FIA

C     D4F = D4FIA

C-----------------------------------------------------------------

      FC0  = FIA

      FC1  = (DDFIA+2*DFIA*X1)

      FTEN = (DDFIA-DFIA*X1)/3.D0            

      FSO  = -X1*DFIA

      DFC0 = DFIA

      DFC1  = (D3FIA+2*DDFIA*X1-2*DFIA*X2)

      DFTEN = (D3FIA-DDFIA*X1+DFIA*X2)/3.D0               

C-----------------------------------------------------------------

C     IF(N.EQ.2) RETURN

C     ENDIF

CC

      RETURN

      END



