!---------------------------------------------------------------------
! simple calling routine, just to check meson parameters etc:
!      call NNPOT16(XFM,NCHAN,JSPIN,LINT,NS),  
!      PP: NCHAN=1, NP: NCHAN=2, NN: NCHAN=3
!---------------------------------------------------------------------
c      subroutine dummy   ! example of calling program
*     IMPLICIT REAL*8(A-H,O-Z)
*     COMMON/VPOT/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,DDFI,
*    .            FISS,DFISS,DDFISS,FIT,DFIT,DDFIT,
*    .            FISO,DFISO,DDFISO

*     do 1 i=1,10
*     xfm = 0.1d0*i
*     call NNPOT16(xfm,1,0,0,0) ! pp 1s0, noprint
c     call NNPOT16(xfm,1,0,0,1) ! pp 1s0, print
cc    call NNPOT16(xfm,2,1,0,0) ! np 3s1
*   1 write(6,11) xfm,vc,vsig,vten,vso,vso2
*  11 format(' xfm=',f8.3,' vc=',d12.5,' vsig=',d12.5,
*    .' vten=',d12.5,' vso=',d12.5,' vso2=',d12.5)
       
*      stop
*      end
C *******************************************************************
C     SUBROUTINE NNPOT16(XFM,NCHAN,JSPIN,LINT,NS)
C *******************************************************************
C     VERSION : APRIL 2016   
C --------------------------------------------------------------------
C     SETTING FOR USERS: IMODEL=12,IGREEN=0 (SEE BELOW)
C --------------------------------------------------------------------
CC                                                                  CC
CC    UNITS :  X IN PIM**-1, USED PIM=138.041 MEV                   CC
CC             VC,VSIG,VTEN,VSO,VSO2 IN MEV**+1                     CC
CC             FI IN MEV**0 , DFI IN MEV**+1 , DDFI IN MEV**+2      CC
CC             (see subroutine SCALAR for details)                  CC
CC                                                                  CC
C --------------------------------------------------------------------
CC    OUTPUT POTENTIALS IN:                                         CC
CC                                                                  CC
CC    COMMON/VPOT/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,DDFI,                CC
CC   .            FIS,DFIS,DDFIS,FITEN,DFITEN,DDFITEN,              CC
CC   .            FISO,DFISO,DDFISO                                 CC
C --------------------------------------------------------------------
C
C --------------------------------------------------------------------
C
C     NUCLEON - NUCLEON POTENTIAL PROGRAM :
C
C     Model-options:
c     ******************************************************************
C     *                                                                *
C     *  ESC08: NIJMEGEN VERSION MARCH 2016                            *
C     *  IMODEL = 12: Soft-Core MODEL ESC08C      ,,                   *
C     ******************************************************************
c     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c  ?  FOR NN: CHOOSE imodel=5: NN-model with low-energy NN,
c  ?                        Deuteron etc. (NN-paper 2005)
c     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
C     ESC08-MODELS: AXIAL-VECTOR MESONS,
C                   NON-LOCAL but ENERGY INDEPENDENT PION!
C **********************************************************************
C
C     IN THIS VERSION ZERO'S IN FORM FACTORS ARE OPTIONAL !
C
C     INTRODUCED SU3SB03-ROUTINE: A LA 3P0-MODEL
C
C ----------------------------------------------------------------------
C                                   :  PHYS.REV. D17,P. 768,1978 (NN)
C     LITERATURE: SOFT-CORE MODELS  :  PHYS.REV. C54,P.2851,1996 (NN)
C                                   :  PHYS.REV. C54,P.2869,1996 (NN)
C                                   :  PHYS.REV. C73,P.????,2005 (NN)
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 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 ---------------------------------------------------------------------------------
C     extra note for users:
C  !! IN THE MODELS AVAILABLE IN THIS PROGRAM THERE ARE NO FIT,
C  !! FISO ETC., SO ONLY FINN,DFINN,DDFINN, FISNN,DFISNN,DDFISNN
C  !! ARE RELEVANT. IN THIS CASE
C  !! THE GREEN TRANSFORMATION LEADS TO RADIAL EQUATION WITH
c  !! FINN AND DFINN, FISNN AND DFISNN !!
C  !! see: PRD17, eqs. (37) and (38)
C  !! NOTICE THAT WE HAVE PUT: DDFINN,DDFISNN=0 !!!!!!
C *********************************************************************************
C
C  !! POTENTIALS FROM INDIVIDUAL MESONS CAN BE OBTAINED BY
C     CHANGING DATA OF COMMON/INMES/ IN BLOCKDATA SUBPROGRAM !!
C
C ---------------------------------------------------------------------------------
C INPUT :
C     X     = NN-DISTANCE IN PION-COMPTON WAVELENGTH, USED MASS PION= 138.041D0
C
C     NCHAN = 1 : PROTON-PROTON
C           = 2 : PROTON-NEUTRON
C           = 3 : NEUTRON-NEUTRON
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     ISPIN=0,1 [  VCNN,VSIGNN,VTENNN,VSONN,VSO2NN,FINN,DFINN,DDFINN ]
C
C
C     NS    = 3 : EXTRA PRINTING : THE PROGRAM PRINTS ALSO
C                 THE POTENTIALS ON THE ISOSPIN-BASIS PER MESON-TYPE
C
C     HERE: AKS IS PUT TO ZERO, RELEVANT IN CASE OF NADIA=1
C
C
C END INPUT DESCRIPTION. ********************************************
C
C --------------------------------------------------------------------
C OUTPUT: NIJMEGEN-SOFTCORE NUCLEON-NUCLEON POTENTIALS
C
C --------------------------------------------------------------------
C     THE POTENTIALS ON THE ISOSPIN-BASIS ARE COMMUNICATED TO THE    C
C     CALLING PROGRAM VIA:                                           C
C --------------------------------------------------------------------
C     COMMON/VPOT/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,DDFI,                 C
C    .            FIS,DFIS,DDFIS,FITEN,DFITEN,DDFITEN,               C
C    .            FISO,DFISO,DDFISO                                  C
C                                                                    C
C --------------------------------------------------------------------
C     HERE NOMENCLATURE :
C
C     VC   = CENTRAL POTENTIAL   , VSIG = SPIN-SPIN POTENTIAL ,
C     VTEN = TENSOR     ,,       , VSO  = SPIN-ORBIT   ,,     ,
C     VSO2 = QUADRATIC SPIN-ORBIT  POTENTIAL.
C     FI   = PHI  , FIS
C     DFI  = PHI',  DFIS
C     DDFI = PHI'', DDFIS
C
C     PHI , PHI', AND PHI'' ETC. 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 --------------------------------------------------------------------
C     NCHAN  LABELS CHANNELS :
C     PROTON-PROTON =1, NEUTRON-PROTON =2, NEUTRON-NEUTRON =3
C
C --------------------------------------------------------------------
C
C
C --------------------------------------------------------------------
C     NOTE THAT IN THE NSC/ESC-MODEL
C          1) FOR NN WE DO THE GREEN TRANSF. ON THE ISOSPIN BASIS
C             AND IS DONE ANALYTICALLY (SEE PRD17)
C --------------------------------------------------------------------
C     AD: JSPIN,LINT:
C          2) FOR MODELS IN THIS VERSION, FIT=FISO=0,
C             THEREFORE: FOR IGREEN=1 JSPIN/LINT ARE NEEDED!!,
C
C END OUTPUT DESCRIPTION. *******************************************
C
C     UNITS :  X IN PIM**-1, USED PIM=138.041 MEV
C              VC,VSIG,VTEN,VSO,VSO2 IN MEV**+1
C              FI IN MEV**0 , DFI IN MEV**1 , DDFI IN MEV**+2
C
C ******************************************************************
C
C     OBE-PARAMETERS :
C
C   PAR( 1,I)= XS     F1     FD1    FV1   GS1    GA2    FA1    GSPAIR
C   PAR( 2,I)= XT     ALP    ALVD   ALVV  GS*    PSID   ALFAX  GVPAIR
C   PAR( 3,I)= XP     fETAP  GOM    FOM   GEPS   GPOM   FE1    FVPAIR
C   PAR( 4,I)= XD     PIONC  AM1RO  ARO   AMD    1.0    THA    GAPAIR
C   PAR( 5,I)= FACLE  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)= ALAM   ALMP1  ALMV1  PSIS8 ALMS1  AMA2   FEFF   GEPAIR
C   PAR( 9,I)= ALM8S  ALMP0  ALMV0  THS1  ALMS0  AMPOM  ALMAX  GPIET
C   PAR(10,I)= ---    THPS   THV    THS2  AMEPS  THD    SONV   GPIETP
C   PAR(11,I)= ALM8A  THPE   THRO   THDE  GAMEP  AHYP   SONPV  ALPAPR
C   PAR(12,I)= FACNA  APV    FDNP1  FDNN1 GEPS2  FHPOM  SONSC  ALSCPR
C   PAR(13,I)= ---    HFPI   HFD1   HFV1  ALS2   GHPOM  SONVPR ALVDPR
C   PAR(14,I)= SON{1} FCHPI  HALVD  HALVV ---    AMPOMH SONPPR ALVVPR
C   PAR(15,I)= RSCAL  HFETP  HGOM   HFOM  ALS    GPOPP  SONSPR GPIPOM
C--------------------------------------------------------------------
C   PAR(16,I)= FACYN  ALMA   ALMKS  ALMKP AMSCK  AMKSS  FB1    GTENPR
C   PAR(17,I)= FACYY  FNNPI  ---    ---   ---    FALS   ALFBX  FTENPR
C   PAR(18,I)= ---    FFA1   ---    ---   GPPS2  FDEL   FB9    GPSPR
C   PAR(19,I)= ALPBPR ALFFX  GONP1  GONN1 FI51   FS*    SONVA  GPIROV
C   PAR(20,I)= AKMAX  FFE1   GSNP1  GSNN1 UPOM   FEPS   ---    GPIOMV
C
C     HERE : PHYSICAL COUPLINGS, EXCEPT FOR
C            THE SU3-SINGLET COUPLINGS GPS1 AND FD1
C
C ******************************************************************

C --------------------------------------------------------------------
C
C     ALM27 = ALAM IRREP 27 -> 1S0, 3P0, 3P1, 3P2, 1D2, etc.
C     ALM10S= ALAM IRREP 10* -> 3S1-3D1, 1P1, 3D2, 3D3, etc.
C     ALAM : FORM FACTOR MASS
C
C --------------------------------------------------------------------
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=a0(980)-,S*=f0(975)-MESON MASS
C
C --------------------------------------------------------------------

C *******************************************************************
C BEGIN MAIN PROGRAM ************************************************
C *******************************************************************
C     SUBROUTINE NNPOT16(IMODEL,XFM,NCHAN,JSPIN,LINT,IGREEN,NS)
      SUBROUTINE NNPOT16(XFM,NCHAN,JSPIN,LINT,NS)
C *******************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 MPROT,MNEUT
      COMMON/MODEL/IMODL,ICNSTR,IRET
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPS,IPIME
      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX

      COMMON/VPOT/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,DDFI,
     .            FISS,DFISS,DDFISS,FIT,DFIT,DDFIT,
     .            FISO,DFISO,DDFISO

      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,ALAMK
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEPS,ASI,BSI,AM1SI,AM2SI,AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,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

      COMMON/PIMAS/PIM00
C ------------------------------------------------------------------*

      CHARACTER AMODEL(12)*9,SYS(3)*16,TYPV(8)*16
      DATA SYS/'PROTON-PROTON','NEUTRON-PROTON','NEUTRON-NEUTRON'/
      DATA TYPV/'CENTRAL','SPIN-SPIN','TENSOR','SPIN-ORBIT',
     .          'QUADR SPIN-ORBIT','PHI-FUNCTION','DPHI-FUNCTION',
     .          'DDPHI-FUNCTION'/

      DATA HBARC/197.327053D0/,MPROT/938.2593D0/,MNEUT/939.5527D0/
c     CHARACTER * 4 INPS(4),INVCT(5),INSC(5),INDIF(4)
      DATA AMODEL/' PR-D17  ',' PR-C40  ',' NSC97f  ',' NSC97e  ',
     .            ' ESC04   ',' ESC04A  ',' ESC04B  ',' ESC04C  ',
     .            ' ESC04D  ',' ESC08A  ',' ESC08B  ',' ESC08C  '/
C ------------------------------------------------------------------*
      DATA N2/6/,ICALL/0/,NCHNH/-10/,ISPINH/-10/
      SAVE I3,NP
C-------------------------------------------------------------------------
      PARAMETER( NDIM=200, NUMTL=10)
C-------------------------------------------------------------------------
C     SETTING FOR USERS:
      IMODEl=12
      IGREEN=0

C-------------------------------------------------------------------------
C     USE GENERALIZED PAULI PRINCIPLE CONDITION FOR ISPIN:
c     MAN=MOD(ISPIN+JSPIN+LINT,2)
      MAN=MOD(JSPIN+LINT,2)
      IF(MAN.EQ.0) ISPIN=1
      IF(MAN.EQ.1) ISPIN=0
      IF(NCHAN.EQ.1) I3= 1
      IF(NCHAN.EQ.2) I3= 0
      IF(NCHAN.EQ.3) I3=-1
C-------------------------------------------------------------------------

      IF (ICALL.GT.0.and.IMODEL.EQ.IMODL.and.ISPIN.EQ.ISPINH) GOTO 100
      IMODL = IMODEL
      ISPINH= ISPIN
c*    if(ns.ne.0) open(17,file='outpot.data')

C     Defining model parameters:
      CALL MODPARS(IMODEL)

      if(ns.eq.0) goto 5
      WRITE(6,*) '======================================================
     .========'
      write(6,14) SYS(NCHAN),ISPIN, I3      
  14  FORMAT(//,1X,A16,'-POTENTIALS ON ISOSPIN-BASIS : ISPIN=',I2,
     .            ' I3=',I2,//)
      WRITE(6,*) '======================================================
     .========'
      WRITE(N2,334) AMODEL(IMODEL),IPSC,IVCT,ISCL,IDIF,IAXI,ITEN,
     .ITPS,IPAIR,IPIME,
     .IZPS,IZVC,IZSC,IZAX,
     .IPV,INA,IOFF,IRET,IGREEN
  334 FORMAT(/,' ***** MODEL INFORMATION: MODEL=',A9,' *****',//,
     .' IPSC =',I2,' IVCT =',I2,' ISCL =',I2,' IDIF =',I2,' IAXI =',I2,
     .' ITEN =',I2,//,' ITPS =',I2,' IPAIR=',I2,' IPIME=',I2,//,
     .' IZPS =',I2,' IZVC =',I2,' IZSC =',I2,' IZAX =',I2,//,
     .' IPV  =',I2,' INA  =',I2,' IOFF =',I2,//,
     .' *** IRET=',I2,' IGREEN=',I2,' ***',/)
      WRITE(6,*) '======================================================
     .========'
c-----------------------------------------------------------------
 5    CONTINUE
c-----------------------------------------------------------------
C
C     SETTING THE MESON-PARAMETERS
C
c-----------------------------------------------------------------
C     PARAMETERS: INTER, SEE CALL ESCPAR16 BELOW
c  nn-paper, nn-models esc08c:   
c     if(imodel.eq.10) open(9,file='tmp/parbbsc.BF.csb')       ! ESC08A
c     if(imodel.eq.11) open(9,file='tmp/parbbsc.definitief')   ! ESC08B
c     if(imodel.eq.12) open(9,file='tmp/parbbsc.15dec2012')    ! ESC08C
c     if(imodel.eq.12) open(9,file='tmp/parbbsc.ESC08c.best13')    ! ESC08C
c     if(imodel.eq.12) open(9,file='tmp/parbbsc.ESC08c.best14p')    ! ESC08C
c     if(imodel.eq.12) open(9,file='tmp/parbbsc.best15')    ! ESC08C
c     if(imodel.eq.12) open(9,file='tmp/parbbsc.best16')    ! ESC08C=definite
c-----------------------------------------------------------------
c     IF(NS.EQ.1) THEN
c     WRITE(6,599)
c     WRITE(N2,10) AMODEL(IMODEL)
c  10 FORMAT('0 THE PARAMETERS MODEL=',A9,/)
c     write(*,*) ' PARAMETERS: parbbsc.ESC08c.best14p'
c     ENDIF
c-----------------------------------------------------------------
C     PARAMETERS INTERNAL:
      CALL ESCPAR16(NS)
c-----------------------------------------------------------------
c     DO 20 I=1,20
c     READ(9,*) (PAR(I,J),J=1,8)
c  20 if(ns.ne.0) WRITE(N2,21) (PAR(I,J),J=1,8)
c  21 FORMAT(4(D15.8,1X))
c-----------------------------------------------------------------
      REWIND 9
c-----------------------------------------------------------------

      AKS   = 0.D0
      PIM   = 138.041D0
      PIM00 = 138.041D0
      X     = XFM
C
      PIMC  = PAR(4,2)
      PIM0  = PAR(5,2)
      AME   = PAR(6,2)
      AMX   = PAR(7,2)
      AMFI  = PAR(7,3)
      AMOM  = PAR(6,3)
      AMD   = PAR(4,5)
      AM1ST = PAR(7,5)
C
C     TWO POLE APPROXIMATION UNSTABLE MESONS
C
      ARO  =PAR(4,4)
      AM1RO=PAR(4,3)
      BRO  =PAR(5,4)
      AM2RO=PAR(5,3)
      ASI  =PAR(5,6)
      AM1SI=PAR(5,5)
      BSI  =PAR(6,6)
      AM2SI=PAR(6,5)
      AMD  =PAR(4,5)
      AMSST=PAR(7,5)
c*    AMSCK=PAR(12,5)
      AMSCK=PAR(16,5)
C
C     DIFFRACTIVE MASSES
C
      AMA2 =PAR(8,6)
      AMPOM=PAR(9,6)
      AMF2 =AMPOM
c*    AMKSS=PAR(8,6)
      AMKSS=PAR(16,6)
      IF(AMA2.EQ.0.D0) AMA2=AMPOM
c     ICALL=1

C *******************************************************************
c100    x=xfm
 100   x=xfm*pim/hbarc
      IF(NCHNH.EQ.NCHAN) GOTO 200
        NCHNH=NCHAN
C *******************************************************************
C
C     FORM FACTOR MASSES :
C
C *******************************************************************
C     MODELS HC-D, HC-F:
      IF(IMODEL.LE.2) THEN
      ALAM = 10000.D0
      ALM27= ALAM
      ALM10S=ALAM
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,201) ALAM,ALM27,ALM10S
      ENDIF
C *******************************************************************
C     MODEL  PRD17:
      IF(IMODEL.EQ.3.or.IMODEL.EQ.4) THEN
      ALAM = PAR(8,1)
      ALM27= ALAM
      ALM10S=ALAM
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,201) ALAM,ALM27,ALM10S
  201 FORMAT(/,' ALAM  =',F9.3,' ALM27 =',F9.3,' ALM10S =',F9.3,//)
C
      ENDIF
C *******************************************************************
C     SOFT-CORE 97-OBE-MODELs, and ESC-MODELs:
      IF(IMODEL.GE.2) THEN
      ALAM  = PAR(8,1)
      ALMP8 = PAR(8,2)
      ALMV8 = PAR(8,3)
      ALMS8 = PAR(8,5)
      ALMP1 = PAR(9,2)
      ALMV1 = PAR(9,3)
      ALMS1 = PAR(9,5)
      ALMAX = PAR(9,7)
      IF(ALMP1.EQ.0.D0) ALMP1=ALMP8
      IF(ALMV1.EQ.0.D0) ALMV1=ALMV8
      IF(ALMS1.EQ.0.D0) ALMS1=ALMS8
c     ALAMK = PAR(12,2)
c     IF(ALAMK.EQ.0.D0) ALAMK=ALMP8
      ALAMK = ALMP8
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,202) 
     .ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,ALAMK,ALMAX
  202 FORMAT(/,' ALMP8 =',F9.3,' ALMV8 =',F9.3,' ALMS8 =',F9.3,
     .       /,' ALMP1 =',F9.3,' ALMV1 =',F9.3,' ALMS1 =',F9.3,
     .       /,' ALAMK =',F9.3,' ALMAX =',F9.3,//)
      ENDIF
C *******************************************************************

      ICALL=1
      GOTO(1,2,3),NCHAN
   1  AMY=MPROT
      AM =MPROT
      I3 = +1
      NP = 0
      GOTO 4
   2  AMY=MNEUT
      AM =MPROT
      I3 = 0
      NP = 1
      GOTO 4
   3  AMY=MNEUT
      AM =MNEUT
      I3 = -1
      NP = 0
      GOTO 4
   4  REDM=AM*AMY/(AM+AMY)
      TEM =2*REDM/(PIM**2)
CC
C
200   CALL MESONS(ISPIN,I3,NP,NS)
C
      CALL VMATNN(X,PIM,1,ISPIN,I3,JSPIN,LINT,IGREEN,NS)

c     IF(NS.GE.2)
c    .WRITE(N2,332) X,TYPV(I),(VPRT(I,1,JJ),JJ=1,3),
c    .             (VPRT(I,2,JJ),JJ=1,3),(VPRT(I,3,JJ),JJ=1,3)
c301  CONTINUE
c332  FORMAT(/,1X,' X=',F10.4,' PIM-1 ',2X,A16,2X,3(D12.5,3X),/,
c    .      41X,3(D12.5,3X),/,41X,3(D12.5,3X))
C
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  UPOM   SONSC
     .ALSCPR',/,
     n'C   PAR(13,I)= ---    HFPS1  HFD1   HFV1  ALS2   ---    SONVPR
     .ALVDPR',/,
     o'C   PAR(14,I)= SON{1} FCHPI  HALVD  HALVV ---    ---    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)= ---    ---    ---    ---   ---    ---    ALFBX
     .FTENPR',/,
     s'C   PAR(18,I)= ---    ---    ---    ---   GPPS2  ---    FB9
     .GPSPR ',/,
     t'C   PAR(19,I)= ---    ---    ---    ---   ---    ---    SONVA
     .GPIROV',/,
     u'C   PAR(20,I)= AKMAX  ---    ---    ---   ---    ---    ---
     .GPIOMV',/,'C',/,72('-'),/ )
C-----------------------------------------------------------------
C     THE FOLLOWING IS NOT APPLIED FOR NN:
C     FACTORS FI ETC FUNCTIONS FOR HANS-JOSEF SCHULZE:
c     FI = FI/(2*REDM)
c     DFI = DFI/(2*REDM)
c     DDFI = DDFI/(2*REDM)
c     FIS = FIS/(2*REDM)
c     DFIS = DFIS/(2*REDM)
c     DDFIS = DDFIS/(2*REDM)
c     FITEN = FITEN/(2*REDM)
c     DFITEN = DFITEN/(2*REDM)
c     DDFITEN = DDFITEN/(2*REDM)
c     FISO = FISO/(2*REDM)
c     DFISO = DFISO/(2*REDM)
c     DDFISO = DDFISO/(2*REDM)
C-----------------------------------------------------------------
      RETURN
      END
C ***************************************************************
      SUBROUTINE MODPARS(IMODEL)
C ***************************************************************
C     imodel = 1:   PRD17             ! TRUE NN-model
C     imodel = 2:   PRC40             ! TRUE YN-model
C     imodel = 3,4: NSC97f/NSC97e     ! TRUE YN-model

C     imodel = 5:   NN-model ESC04        ! TRUE NN-model     OBSELETE
C     imodel = 6-9: NN+YN-models ESC04A-D ! TRUE NN+YN-model  OBSELETE

C     imodel = 10-12: NN+YN-models ESC08A-B-C ! TRUE NN+YN-model
C ***************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/MODEL/IMODL,ICNSTR,IRET
      COMMON/DIVERS/CORR,INRS,NAPION,NAOBE,ICHIR,ISATUR
     .             ,NAVEC,NASCAL,NADIF,IGERST,IFRMF
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,iometa
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IOBE(7)
      COMMON/TWOBOS/ITME(3)
      COMMON/ZEROS/IZERO(4)
      COMMON/PAROOM/ISPEC(5)
      DIMENSION INFO(19,12)
      DATA IMODL/-123456/,IRET/0/,ICNSTR/0/
c     DATA INRS/1/,NAPION/0/,NAOBE/0/,ICHIR/0/,ISATUR/0/,
c    .     NAVEC/0/,NASCAL/0/,NADIF/0/,CORR/1.D0/
C     in row 'imodel' INFO contains the model-parameters:
C     INFO: ipsc,ivct,iscl,idif,iaxi,ipsc2,iten,
C           ipair,itpe,ipime,
C           ipv,ina,ioff, nadia,igerst,
C           izps,izvc,izsc,izax
      DATA INFO/1,1,1,1,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, 1,0,0, 0,0, 0,0,0,0,
     .          1,1,1,1,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, 1,0,0, 0,0, 0,0,0,0,
     .          1,1,1,1,1,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,    ! model=5, ESC04
     .          1,1,1,1,1,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,
     .          1,1,1,1,1,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,
     .          1,1,1,1,1,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,
     .          1,1,1,1,1,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,
     .          1,1,1,3,2,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,    ! model=10,ESC08A
     .          1,1,1,3,2,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1,    ! model=11,ESC08B
     .          1,1,1,3,2,0,0, 1,1,0, 1,1,1, 0,1, 0,0,1,1/    ! model=12,ESC08C
c*   .          1,0,0,0,0,0,0, 0,0,0, 1,1,1, 0,1, 0,0,1,1/    ! model=12,ESC08C

      DO 1 KK=1,7
    1 IOBE (KK) = INFO(KK  ,IMODEL)
      DO 2 KK=1,3
    2 ITME (KK) = INFO(KK+7,IMODEL)
      DO 3 KK=1,4
    3 ISPEC(KK) = INFO(KK+10,IMODEL)
      IGERST    = INFO(15  ,IMODEL)

C     ZEROS IN FORF FACTOR:
      DO 4 KK=1,4
    4 IZERO(KK) = INFO(15+KK,IMODEL)

C     special for imodel>4:
      IF(IMODEL.GE.5) THEN
      NAPION=1
      IPIOM =2
      IPIRO0=0
      ENDIF
      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 *******************************************************************
C ***************************************************************
c     BLOCK DATA NNBLK
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 INTEN(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     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 ***************************************************************
C *****************************************************************
      SUBROUTINE VMATNN(X,PIM,I,ISPIN,I3,JSPIN,LINT,IGREEN,NS)
CC    SUBROUTINE VMATNN(I,X,ISPIN,I3,NP,NS)       
C *****************************************************************
C     AUGUST 1998 VERSION: NON-LOCAL CONTRIBUTIONS ALL MESONS
C *****************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      INCLUDE 'DIMPRS'
      COMMON/MODEL/IMODL,ICNSTR,IRET
      COMMON/DIVERS/CORR,INRS,NAPION,NAOBE,ICHIR,ISATUR
     .             ,NAVEC,NASCAL,NADIF,IGERST,IFRMF
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPE,IPIME
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/ALLSC2/IOPTSC,IALIGNX,XANG(5),GSA12,GSA62,GSA92,
     .              GSB12,GSB62,GSB92
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
      COMMON/POTF/VCAA,VSIGAA,VTENAA,VSOAA,VSO2AA,FIAA,DFIAA,
     .            FISAA,DFISAA,FITAA,DFITAA,FIOAA,DFIOAA,
     .            FIO2A,DFIO2A
      COMMON/POTDD/DDFIAA,DDFISAA,DDFITAA
      COMMON/POTTL/VTLCAA,VTLSAA,VTLTAA,FITLAA,FISTLAA,FITTLAA,
     .             DFITLA,DFISTLA,DFITTLA,VTLOAA,VTLO2A
      COMMON/NAPIONP/VSIGNA,VTENNA,FISNA,FITNA
      COMMON/VVPOT/VPSCAL(2,NDIM,2),VVEC(5,NDIM,2),VSCAL(3,NDIM,2),
     .            VDIFR(5,NDIM,2) ,VTPE(4,NDIM,2),VPAIR(4,NDIM,2),
     .            VPIHB(4,NDIM,2) ,VOPEP(2,NDIM,2), VAXI(4,NDIM,2),
     .            FFI(4,NDIM,2),DFFI(4,NDIM,2),    VPSCA2(2,NDIM,2),
     .            FFISS(2,NDIM,2),DFFISS(2,NDIM,2),VTENSR(5,NDIM,2),
     .            FFIT(2,NDIM,2),DFFIT(2,NDIM,2),
     .            VTLCEN(3,NDIM,2),VTLSIG(2,NDIM,2),VTLTEN(2,NDIM,2),
     .            FITL(3,NDIM,2),FISTL(NDIM,2),FITTL(NDIM,2),
     .            DFITL(3,NDIM,2),DFISTL(NDIM,2),DFITTL(NDIM,2),
     .            VTLSO(3,NDIM,2),FFIO(3,NDIM,2),DFFIO(3,NDIM,2),
     .            VTLO2(3,NDIM,2),FFO2(3,NDIM,2),DFFO2(3,NDIM,2)
      COMMON/VDDPOT/DDFFI(4,NDIM,2),DDFFISS(2,NDIM,2),DDFFIT(2,NDIM,2)

      CHARACTER *4 TYPM(11),TYPV(9)
      DATA TYPM/'PION','PSSC','VCTR','SCAL','DIFR','TPEP','PAIR',
     .'PIME','AXIA','PSS2','TENS'/
      DATA TYPV/' VC ','VSIG','VTEN',' VSO','VSO2',' FI ',' DFI',
     .          ' FIS','DFIS'/
c*    DATA IIMIN/2/,IIMIN1/ 9/,ZERO/0.D0/,N2/6/,NSH/0/
c*    DATA IIMIN/2/,IIMIN1/10/,ZERO/0.D0/,N2/6/,NSH/0/
      DATA IIMIN/1/,IIMIN1/ 9/,N2/6/,NSH/0/,HBARC/197.327053D0/
c***  data igreen/0/
C-------------------------------------------------------------------------

C-------------------------------------------------------------------------
C     INITIALIZATION SUMMED POTENTIALS:
      CALL INIT(1)
C-------------------------------------------------------------------------
C     CHECK GENERALIZED PAULI PRINCIPLE CONDITION:
c     MAN=MOD(ISPIN+JSPIN+LINT,2)
c     IF(MAN.EQ.0) THEN
c     WRITE(6,66) ISPIN,JSPIN,LINT
c 66  FORMAT(' INPUT DID NOT PASS TEST PAULI-CONDITION: ISPIN=',I2,
c    .' JSPIN=',I2,' LINT=',I2,' : STOP')
c     stop
c     ENDIF
C-------------------------------------------------------------------------
      II  = ISPIN + 1
      FACISO=-3.D0+4.D0*ISPIN
C-------------------------------------------------------------------------
      IF(NS.EQ.3) WRITE(N2,311) X,TYPV
 311  FORMAT(/,76('='),/,1X,' X=',F10.4,' PIM-1   ','POTENTIALS:',//,
     .       7X,7(4X,A4,7X),/)
C
C     WRITE(N2,696) IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,IAXI,IPSC2,ITEN
C696  FORMAT(/,'  in vmatnn: ipsc,ivct,iscl,idif,itpe,ipair=',6I2,
C    .'  ipime,iaxi,ipsc2,iten=',4I2,/)
C-------------------------------------------------------------------------
C
      DO 20 JJ=1,11
C     INITIALIZATION POTENTIALS:
      CALL INIT(2)
C
      GOTO(21,211,22,23,24,25,26,27,28,29,30),JJ
  21  IF(IPSC.EQ.1) THEN
C     CALL PSSCAL98(X,IPSC,NAPION,CORR,1,2)
      CALL PSSCAL98(X,NAPION,CORR,1,2)
      VOPEP (1,I,II)= VSIGAA
      VOPEP (2,I,II)= VTENAA
      FFISS(2,I,II) = FISAA
      DFFISS(2,I,II)= DFISAA
      DDFFISS(2,I,II)= DDFISAA
      FFIT(2,I,II)  = FITAA
      DFFIT(2,I,II) = DFITAA
      DDFFIT(2,I,II) = DDFITAA
      VTLSIG(2,I,II)= VTLSAA
      VTLTEN(2,I,II)= VTLTAA
      FISTL(I,II)   = FISTLAA
      DFISTL(I,II)  = DFISTLA
      FITTL(I,II)   = FITTLAA
      DFITTL(I,II)  = DFITTLA
      ENDIF
      GOTO 31
 211  IF(IPSC.NE.0) THEN
c     CALL PSSCAL98(X,IPSC,NAPION,CORR,3,4)
      CALL PSSCAL98(X,NAPION,CORR,3,4)
      VPSCAL(1,I,II)= VSIGAA
      VPSCAL(2,I,II)= VTENAA
      FFISS(2,I,II) = FFISS(2,I,II) + FISAA
      DFFISS(2,I,II)= DFFISS(2,I,II) + DFISAA
      DDFFISS(2,I,II)= DDFFISS(2,I,II) + DDFISAA
      FFIT(2,I,II)  = FFIT(2,I,II) + FITAA
      DFFIT(2,I,II) = DFFIT(2,I,II) + DFITAA
      DDFFIT(2,I,II) = DDFFIT(2,I,II) + DDFITAA
      VTLSIG(2,I,II)= VTLSIG(2,I,II) + VTLSAA
      VTLTEN(2,I,II)= VTLTEN(2,I,II) + VTLTAA
      FISTL(I,II)   = FISTL(I,II) + FISTLAA
      DFISTL(I,II)  = DFISTL(I,II) + DFISTLA
      FITTL(I,II)   = FITTL(I,II) + FITTLAA
      DFITTL(I,II)  = DFITTL(I,II) + DFITTLA
      ENDIF
      GOTO 31
  22  IF(IVCT.NE.0) THEN
CC    CALL VECTOR98(X,FACISO,NAVEC,CORR,INRS)
      CALL VECTOR98(X,FACISO,IVCT,NAVEC,CORR,INRS)
CC    IF(IVCT.EQ.2) CALL VECTR2(X,FACISO,INRS)
      IF(IVCT.EQ.2) CALL VECTR2(X,FACISO,IVCT,INRS)
      VVEC(1,I,II)  = VCAA
      VVEC(2,I,II)  = VSIGAA
      VVEC(3,I,II)  = VTENAA
      VVEC(4,I,II)  = VSOAA
      VVEC(5,I,II)  = VSO2AA

      FFI (1,I,II)  = FIAA
      DFFI(1,I,II)  = DFIAA
      DDFFI(1,I,II) = DDFIAA
      FFISS(1,I,II) = FISAA
      DFFISS(1,I,II)= DFISAA
      DDFFISS(1,I,II)= DDFISAA
      FFIT(1,I,II)  = FITAA
      DFFIT(1,I,II) = DFITAA
      DDFFIT(1,I,II) = DDFITAA
      FFIO (1,I,II) = FIOAA
      DFFIO(1,I,II) = DFIOAA
      FFO2 (1,I,II) = FIO2A
      DFFO2 (1,I,II)= DFIO2A

      VTLCEN(1,I,II)= VTLCAA
      VTLSIG(1,I,II)= VTLSAA
      VTLTEN(1,I,II)= VTLTAA
      VTLSO (1,I,II)= VTLOAA
      VTLO2 (1,I,II)= VTLO2A

      FITL  (1,I,II)= FITLAA
      DFITL (1,I,II)= DFITLA
      ENDIF
      GOTO 31
  23  IF(ISCL.NE.0) THEN
      IF(IOPTSC.EQ.1) NNONET=1
      IF(IOPTSC.GE.2) NNONET=2
      DO 230 INONET=1,NNONET
      IF(IOPTSC.NE.1 .and. INONET.EQ.1) THEN
      GS12=GSB12
      GS62=GSB62
      GS92=GSB92
      ENDIF
      IF(IOPTSC.NE.1 .and. INONET.EQ.2) THEN
      GS12=GSA12
      GS62=GSA62
      GS92=GSA92
      ENDIF
CC    CALL SCALAR98(X,FACISO,NASCAL,CORR)
      CALL SCALAR98(X,FACISO,ISCL,NASCAL,CORR)
C230  IF(ISCL.EQ.2) CALL SCALR2(X,FACISO)
 230  IF(ISCL.EQ.2) CALL SCALR2(X,FACISO,ISCL)
      VSCAL(1,I,II) = VCAA
      VSCAL(2,I,II) = VSOAA
      VSCAL(3,I,II) = VSO2AA
      FFI (2,I,II)  = FIAA
      DFFI(2,I,II)  = DFIAA
      DDFFI(2,I,II) = DDFIAA
      FFIO (2,I,II) = FIOAA
      DFFIO(2,I,II) = DFIOAA
      FFO2 (2,I,II) = FIO2A
      DFFO2 (2,I,II)= DFIO2A
      VTLCEN(2,I,II)= VTLCAA
      VTLSO (2,I,II)= VTLOAA
      VTLO2 (2,I,II)= VTLO2A
      FITL  (2,I,II)= FITLAA
      DFITL (2,I,II)= DFITLA
      ENDIF
      GOTO 31
  24  IF(IDIF.NE.0) THEN
      IF(IMODL.LE.9) CALL DIFRAC98(X,FACISO,NADIF,CORR)
      IF(IMODL.GT.9) CALL DIFRAC08(X,FACISO,NADIF,CORR)
      VDIFR(1,I,II)  = VCAA
      VDIFR(2,I,II)  = VSIGAA
      VDIFR(3,I,II)  = VTENAA
      VDIFR(4,I,II)  = VSOAA
      VDIFR(5,I,II)  = VSO2AA
      FFI (3,I,II)  = FIAA
      DFFI(3,I,II)  = DFIAA
      DDFFI(3,I,II) = DDFIAA
      FFIO (3,I,II) = FIOAA
      DFFIO(3,I,II) = DFIOAA
      FFO2 (3,I,II) = FIO2A
      DFFO2(3,I,II) = DFIO2A
      VTLCEN(3,I,II)= VTLCAA
      VTLSO (3,I,II)= VTLOAA
      VTLO2 (3,I,II)= VTLO2A
      FITL  (3,I,II)= FITLAA
      DFITL (3,I,II)= DFITLA
      ENDIF
      GOTO 31
  25  IF(ITPE.NE.0) THEN
c     IF(IIMIN1.EQ.10)
c    .CALL TPEFF(X,ISPIN,NP,ALMP1)
      IF(IIMIN1.EQ.10)
     .CALL NNPIPI(X,ISPIN,I3,ALMP1)
      CALL NNPSPS(X,ISPIN,IIMIN1,ALMP1,ALMP0)
      VTPE (1,I,II) = VCAA
      VTPE (2,I,II) = VSIGAA
      VTPE (3,I,II) = VTENAA
      VTPE (4,I,II) = VSOAA
      ENDIF
      GOTO 31
  26  IF(IPAIR.NE.0) THEN
      IF(IIMIN.EQ.2)
     .CALL PAIRS(X,ISPIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK)
      CALL PAIRSU3(X,ISPIN,IIMIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,
     .ALMS0,ALAMK)
c     IF(IMODL.LE.9) CALL PAIRSU3(X,ISPIN,IIMIN,
c    .             ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK)
c     IF(IMODL.GT.9) CALL PAIRSU309(X,ISPIN,IIMIN,
c    .             ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK)
      VPAIR(1,I,II) = VCAA
      VPAIR(2,I,II) = VSIGAA
      VPAIR(3,I,II) = VTENAA
      VPAIR(4,I,II) = VSOAA
      ENDIF
      GOTO 31
  27  IF(IPIME.NE.0) THEN
      CALL PIHBE(X,ISPIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0)
      IF(IPIME.EQ.2) THEN
      CALL EPSHBE(X,ISPIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0)
      ENDIF
      CALL NNPSBE(X,ISPIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0)
      VPIHB(1,I,II) = VCAA
      VPIHB(2,I,II) = VSIGAA
      VPIHB(3,I,II) = VTENAA
      VPIHB(4,I,II) = VSOAA
      ENDIF
      GOTO 31
  28  IF(IAXI.NE.0) THEN
      CALL AXIAL(X,FACISO)
      IF(IAXI.EQ.2) CALL AXIALU(X,FACISO)
      VAXI(1,I,II)  = VSIGAA
      VAXI(2,I,II)  = VTENAA
      VAXI(3,I,II)  = VSOAA
      VAXI(4,I,II)  = VSO2AA
      FFISS(1,I,II) = FFISS(1,I,II) + FISAA
      DFFISS(1,I,II)= DFFISS(1,I,II) + DFISAA
      DDFFISS(1,I,II)= DDFFISS(1,I,II) + DDFISAA
      FFIT(1,I,II)  = FFIT(1,I,II) + FITAA
      DFFIT(1,I,II) = DFFIT(1,I,II) + DFITAA
      DDFFIT(1,I,II) = DDFFIT(1,I,II) + DDFITAA
      ENDIF
      GOTO 31
  29  IF(IPSC2.NE.0) THEN
      CALL PSSCA2(X,FACISO)
      VPSCA2(1,I,II) =  VSIGAA
      VPSCA2(2,I,II) =  VTENAA
      FFISS(2,I,II) = FFISS(2,I,II)  + FISAA
      DFFISS(2,I,II)= DFFISS(2,I,II) + DFISAA
      DFFISS(2,I,II)= DFFISS(2,I,II) + DDFISAA
      ENDIF
      GOTO 31
  30  IF(ITEN.NE.0) THEN
      CALL TENSOR(X,FACISO,INRS)
      VTENSR(1,I,II) = VCAA
      VTENSR(2,I,II) = VSIGAA
      VTENSR(3,I,II) = VTENAA
      VTENSR(4,I,II) = VSOAA
      VTENSR(5,I,II) = VSO2AA
      FFI   (4,I,II) = FIAA
      DFFI  (4,I,II) = DFIAA
      DDFFI (4,I,II) = DDFIAA
      ENDIF
      GOTO 31
  31  IF(NSH.EQ.2) THEN
      XF = X*HBARC/PIM
      WRITE(N2,32) TYPM(JJ),XF,VCAA,VSIGAA,VTENAA,
     .             VSOAA,VSO2AA,FIAA,DFIAA
  32  FORMAT(1X,A4,2X,'X=',D10.3,'fm',4(D10.3,2X),/,17X,3(D10.3,2X),/)
      ENDIF
C
  20  CONTINUE

      CALL POTMAT(X,I,ISPIN,IGREEN,NS)

      RETURN
      END
c-------------------------------------------------------------------------
      SUBROUTINE POTMAT(X,I,ISPIN,IGREEN,NS)
c-------------------------------------------------------------------------
      implicit real*8(a-h,o-z)
      include 'DIMPRS'
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/VPOT/VCNN,VSIGNN,VTENNN,VSONN,VSO2NN,
     .            FI,DFI,DDFI,FISS,DFISS,DDFISS,
     .            FIT,DFIT,DDFIT,FISO,DFISO,DDFISO
      COMMON/VVPOT/VPSCAL(2,NDIM,2),VVEC(5,NDIM,2),VSCAL(3,NDIM,2),
     .            VDIFR(5,NDIM,2) ,VTPE(4,NDIM,2),VPAIR(4,NDIM,2),
     .            VPIHB(4,NDIM,2) ,VOPEP(2,NDIM,2), VAXI(4,NDIM,2),
     .            FFI(4,NDIM,2),DFFI(4,NDIM,2),    VPSCA2(2,NDIM,2),
     .            FFISS(2,NDIM,2),DFFISS(2,NDIM,2),VTENSR(5,NDIM,2),
     .            FFIT(2,NDIM,2),DFFIT(2,NDIM,2),
     .            VTLCEN(3,NDIM,2),VTLSIG(2,NDIM,2),VTLTEN(2,NDIM,2),
     .            FITL(3,NDIM,2),FISTL(NDIM,2),FITTL(NDIM,2),
     .            DFITL(3,NDIM,2),DFISTL(NDIM,2),DFITTL(NDIM,2),
     .            VTLSO(3,NDIM,2),FFIO(3,NDIM,2),DFFIO(3,NDIM,2),
     .            VTLO2(3,NDIM,2),FFO2(3,NDIM,2),DFFO2(3,NDIM,2)
      COMMON/VDDPOT/DDFFI(4,NDIM,2),DDFFISS(2,NDIM,2),DDFFIT(2,NDIM,2)

c     data phil/-0.4d0/,phih/+2.d0/,dphil/-10.d0/,dphih/+10.d0/
      data phil/ 0.0d0/,phih/+2.d0/,dphil/-10.d0/,dphih/+10.d0/
      data amoe/1.d0/,hbarc/197.327053d0/
      data jspin/0/

      data n3/17/,icall/0/,icalls/0/,icallt/0/

C*    for Leidemann:
      ifilim= 0
c
      ii = ispin+1
c     aks in units pim**2:
      tlab   = 2*aks/tem
      vcnn   = vvec(1,i,ii)   + vscal(1,i,ii) + vdifr(1,i,ii) +
     .         vtpe(1,i,ii)   + vpair(1,i,ii) + vpihb(1,i,ii) +
     .         vtensr(1,i,ii) +
     .         (vtlcen(1,i,ii)+vtlcen(2,i,ii)+vtlcen(3,i,ii))*tlab
      vsignn = vpscal(1,i,ii) + vvec(2,i,ii)  + vopep(1,i,ii)*amoe+
     .         vdifr(2,i,ii)  +
     .         vtpe(2,i,ii)   + vpair(2,i,ii) + vpihb(2,i,ii) +
     .         vaxi(1,i,ii)   + vpsca2(1,i,ii)*amoe + vtensr(2,i,ii)
     .       + (vtlsig(1,i,ii)+vtlsig(2,i,ii))*tlab
c    .       + vpsna(1,i,ii)*(aks*pim/amn)
      vtennn = vpscal(2,i,ii) + vvec(3,i,ii)  + vopep(2,i,ii)*amoe+
     .         vdifr(3,i,ii)  +
     .         vtpe (3,i,ii)  + vpair(3,i,ii) + vpihb(3,i,ii) +
     .         vaxi(2,i,ii)   + vpsca2(2,i,ii)*amoe + vtensr(3,i,ii)
     .       + (vtlten(1,i,ii)+vtlten(2,i,ii))*tlab
c    .       + vpsna(2,i,ii)*(aks*pim/amn)
      vsonn  = vvec(4,i,ii)   + vscal(2,i,ii) + vdifr(4,i,ii) +
     .         vtpe(4,i,ii)   + vpair(4,i,ii) + vpihb(4,i,ii) +
     .         vaxi(3,i,ii)   + vtensr(4,i,ii)
      vso2nn = vvec(5,i,ii)   + vscal(3,i,ii) + vdifr(5,i,ii) +
     .         vaxi(4,i,ii)   + vtensr(5,i,ii)

      fi     = ffi(1,i,ii) + ffi(2,i,ii) + ffi(3,i,ii) + ffi(4,i,ii)
     .       + (fitl(1,i,ii) + fitl(2,i,ii) + fitl(3,i,ii) )*tlab
      dfi    = dffi(1,i,ii)+dffi(2,i,ii)+dffi(3,i,ii)+dffi(4,i,ii)
     .       + (dfitl(1,i,ii)+ dfitl(2,i,ii)+ dfitl(3,i,ii) )*tlab
      ddfi   = ddffi(1,i,ii) + ddffi(2,i,ii) + ddffi(3,i,ii) 
     .       + ddffi(4,i,ii)
      fiss   = ffiss(1,i,ii) + ffiss(2,i,ii) + fistl(i,ii)*tlab
      dfiss  = dffiss(1,i,ii)+ dffiss(2,i,ii)+ dfistl(i,ii)*tlab
      ddfiss = ddffiss(1,i,ii)+ ddffiss(2,i,ii)
      fit    = ffit(1,i,ii) + ffit(2,i,ii) + fittl(i,ii)*tlab
      dfit   = dffit(1,i,ii)+ dffit(2,i,ii)+ dfittl(i,ii)*tlab
      ddfit  = ddffit(1,i,ii)+ ddffit(2,i,ii)

c----------------------------------------------------------------
c     printing potentials:
c----------------------------------------------------------------
      if(ns.eq.1) then
c     if(icall.eq.0) then
      if((icalls.eq.0.and.ispin.eq.1).or.(icallt.eq.0.and.ispin.eq.0))
     .then
      write(n3,*)
     .'*********************************************************'
      write(n3,*) 'ispin=',ispin,'jspin=',jspin
      write(n3,*)
     .'*********************************************************'
c     printing obe-potentials:
      xf=hbarc*x/pim
      vcobe= vvec(1,i,ii)   + vscal(1,i,ii) + vdifr(1,i,ii) +
     .       vtensr(1,i,ii)
      vsobe= vpscal(1,i,ii) + vvec(2,i,ii)  + vopep(1,i,ii)*amoe +
     .       vdifr(2,i,ii)  + vaxi(1,i,ii)   + vtensr(2,i,ii)
      write(n3,*) ' i=',i,' ii=',ii,' vdifr(2,i,ii)=',vdifr(2,i,ii)
      vtobe= vpscal(2,i,ii) + vvec(3,i,ii)  + vopep(2,i,ii)*amoe +
     .       vdifr(3,i,ii)  + vaxi(2,i,ii)   + vtensr(3,i,ii)
      vswv = vcobe + (4*jspin-3)*vsobe
      phic = ffi(1,i,ii) + ffi(2,i,ii) + ffi(3,i,ii) + ffi(4,i,ii)
      phis = ffiss(1,i,ii) + ffiss(2,i,ii)
      fswv = phic  + (4*jspin-3)*phis
      write(n3,122) xf,vcobe,vsobe,vtobe,vswv
c     write(n3,122) xf,vswv,phic,phis,fswv
 122  format(' obe : xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
c     printing tpe-potentials:
      xf=hbarc*x/pim
      write(n3,1123) xf,vtpe(1,i,ii),vtpe(2,i,ii),vtpe(3,i,ii)
1123  format(' tpe : xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
c     printing pair-potentials:
      xf=hbarc*x/pim
      write(n3,2123) xf,vpair(1,i,ii),vpair(2,i,ii),vpair(3,i,ii)
2123  format(' pair: xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
c     printing pshbe-potentials:
      xf=hbarc*x/pim
      write(n3,3123) xf,vpihb(1,i,ii),vpihb(2,i,ii),vpihb(3,i,ii)
3123  format(' pihb: xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
c     printing total escmat-potentials:
      xf=hbarc*x/pim
      vcesc= vtpe(1,i,ii)   + vpair(1,i,ii) + vpihb(1,i,ii)
      vsesc= vtpe(2,i,ii)   + vpair(2,i,ii) + vpihb(2,i,ii)
      vtesc= vtpe(3,i,ii)   + vpair(3,i,ii) + vpihb(3,i,ii)
      vswv = vcesc + (4*jspin-3)*vsesc
      write(n3,123) xf,vcesc,vsesc,vtesc,vswv
 123  format(' esc : xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
c     printing total potentials:
      xf=hbarc*x/pim
      vctot= vvec(1,i,ii)   + vscal(1,i,ii) + vdifr(1,i,ii)
     .     + vtpe(1,i,ii)   + vpair(1,i,ii) + vpihb(1,i,ii)
     .     + vtensr(1,i,ii)
      vstot= vpscal(1,i,ii) + vvec(2,i,ii)  + vopep(1,i,ii)*amoe
     .     + vtpe(2,i,ii)   + vpair(2,i,ii) + vpihb(2,i,ii)
     .     + vdifr(2,i,ii)  + vaxi(1,i,ii)   + vtensr(2,i,ii)
      vttot= vpscal(2,i,ii) + vvec(3,i,ii)  + vopep(2,i,ii)*amoe
     .     + vtpe (3,i,ii)  + vpair(3,i,ii) + vpihb(3,i,ii)
     .     + vdifr(3,i,ii)  + vaxi(2,i,ii)   + vtensr(3,i,ii)
      vswv = vctot + (4*jspin-3)*vstot
      write(n3,124) xf,vctot,vstot,vttot,vswv
 124  format(' tot : xf=',f7.3,' fm ',3(d10.3,2x),f12.3)
      write(n3,*)
     .'*********************************************************'
      if(icalls.eq.0.and.ispin.eq.1) icalls=1
      if(icallt.eq.0.and.ispin.eq.0) icallt=1
      icall=1
      endif
      endif

c----------------------------------------------------------------
c     fit  = 0.d0
c     dfit = 0.d0
c     fiso  =0.d0
c     dfiso =0.d0

c     ddfi = 0.d0
c     ddfiss=0.d0
      ddfit =0.d0
      ddfiso=0.d0

c----------------------------------------------------------------
c  check this division:
c     dfi    = dfi/pim
c     dfiss  = dfiss/pim
c     ddfiss = ddfiss/pim
c     dfit   = dfit/pim
c     ddfit  = ddfit/pim

c----------------------------------------------------------------
c  bounds on phi-functions:
      if(ifilim.eq.1) then
      if(fi.lt.phil) fi = phil
c     if(fi.gt.phih) fi = phih
      if(dfi.lt.dphil) dfi = dphil
      if(dfi.gt.dphih) dfi = dphih
      if(fiss.lt.phil) fiss = phil
      if(fiss.gt.phih) fiss = phih
      if(dfiss.lt.dphil) dfiss = dphil
      if(dfiss.gt.dphih) dfiss = dphih
      if(fit.lt.phil) fit = phil
      if(fit.gt.phih) fit = phih
      if(dfit.lt.dphil) dfit = dphil
      if(dfit.gt.dphih) dfit = dphih
      endif

c----------------------------------------------------------------
c----------------------------------------------------------------
c     green transformation:
c     here it is assumed: no tensor non-locality, i.e. fit=dfit=0
c     also it is assumed: aks=0.d0
      if(igreen.eq.1) then
      fit  = 0.d0
      dfit = 0.d0
      finn   = fi + (4*jspin-3)*fiss
      dfinn  =dfi + (4*jspin-3)*dfiss
      ddfinn =ddfi + (4*jspin-3)*ddfiss
      facnl = 1.d0/(1.d0+2*finn)
      facnlk= 2*finn*facnl
      vcnn  = vcnn*facnl -(dfinn*facnl)**2
      vsignn  = vsignn*facnl
      vtennn  = vtennn*facnl
      vsonn   = vsonn*facnl
      vso2nn  = vso2nn*facnl
      endif

c --------------------------------------------------------------------
c     write(6,*) 'potmat: vc,vsig,vten,vso,vso2=',
c    .vcnn,vsignn,vtennn,vsonn,vso2nn
c     write(6,*) 'potmat: fi,dfi,ddfi=',fi,dfi,ddfi
c     write(6,*) 'potmat: fiss,dfiss,fit,dfit=',fiss,dfiss,fit,dfit
c----------------------------------------------------------------
      return
      end

C**********************************************************************
C
      SUBROUTINE INIT(ICASE)
C
C**********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/POTX/VX(198)
      COMMON/POTF/V(15)
      COMMON/POTDD/VDD(3)     ! JANUARY 2013
      COMMON/POTTL/VTL(11)
      DATA ZERO/0.D0/
C
      IF(ICASE.EQ.1) THEN
      DO 22 IP=1,190
  22  VX(IP) = ZERO
      ENDIF

      IF(ICASE.EQ.2) THEN
      DO 24 IP=1,15
      IF(IP.LE.3) VDD(IP)=0D0     ! JANUARY 2013
  24  V(IP) = ZERO
      DO 26 IP=1,11
  26  VTL(IP) = ZERO
      ENDIF
      RETURN
      END

C*********************************************************************
      SUBROUTINE HPSSCAL98(X,NAPION,CORR,INMN,INMX)
C
C**********************************************************************
C
C     PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
C     AUGUST 1998-VERSION !! REORGANIZATION FC1, FTEN ETC.
C**********************************************************************
C
C     AUGUST 98: PROGRAM FOR R-SPACE NON-ADIABATIC PION-EXCHANGE
C     INCLUSION OF NON-LOCAL GRAZ (NAGELS ET AL)
C     INCLUSION OF NON-LOCAL TERMS FROM:
C     1/(OMEGA+A) APPROX 1/OMEGA - A/OMEGA^2
C
C     Note: the combination PIONNA + ITMO.NE.0 is WRONG!!!
C----------------------------------------------------------------------
C
C                    fp^2   m^2
C     V(PS-SCALAR) = ----  ----- m [(sig1.sig2)/3 phic^1 + S12 phit^0]
C                    4pi   mup^2

C                    fp^2  mu^2  ( d^2   2  d  ) ----
C     e.g. V_sig   = ----  ----- (---- + -  -- ) phi0 . mu
C                    4pi   mup^2 (dx^2   x  dx )

C                                       ----
C     m= ps-meson mass, x = mu.r, mu=pim,  mup=pimc, phi0=f0(......)
C
C**********************************************************************

      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/PSCOP/ALP,APV,FP,F62,F92,F120,F12C,FCHPI
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      DIMENSION AMPS(4)
      DATA SRPI/1.772454D0/
      COMMON/NAPIONP/VSIGNA,VTENNA,FISNA,FITNA
C-----------------------------------------------------------------
C
C   NOTE : PION0(IN=1),PIONC(IN=2),ETA (IN=3),ETAP(IN=4)
C-----------------------------------------------------------------
C
C   THE POTENTIAL FUNCTIONS
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
C-----------------------------------------------------------------
c     write(6,*) 'psscal98: IPSC,NAPION,CORR,INMN,INMX=',
c    .                      IPSC,NAPION,CORR,INMN,INMX
c     write(6,*) 'psscal98: x,pim,almp1,alp0=',x,pim,almp1,almp0
c     write(6,*) 'psscal98: am,amy,pim0,pimc,ame,amx=',
c    .am,amy,pim0,pimc,ame,amx
C-----------------------------------------------------------------
CC
      VSIG = 0.D0
      VTEN = 0.D0
      FISS = 0D0            ! JANUARY 2013
      FITEN= 0D0            ! JANUARY 2013
      DFISS = 0D0           ! JANUARY 2013
      DFITEN= 0D0           ! JANUARY 2013
      DDFISS = 0D0          ! JANUARY 2013
      DDFITEN= 0D0          ! JANUARY 2013
C-----------------------------------------------------------------

      X1  = 1.D0/X
      X2  = X1*X1
      X3  = X1*X2
      DIV = 1.D0/(AM*AMY)

      DO 1040 IN=INMN,INMX
      GOTO(1051,1052,1053,1054),IN
1051  FPNN= F120
      AMPS(1)=PIM0
c     AMPS(1)=pim
      ALM1=ALMP1
      GOTO 1055
1052  FPNN= F12C
      AMPS(2)=PIMC
c     amps(2)=pim
      ALM1=ALMP1
      GOTO 1055
1053  FPNN=  F62
      AMPS(3)=AME
      ALM1=ALMP1
      GOTO 1055
1054  FPNN=  F92
      AMPS(4)=AMX
      ALM1=ALMP0
C
1055  AMES = AMPS(IN)
      AMU = AMES/PIM
c     FPNN=FPNN*(PIM/PIMC)**2
CC
      RATP =PIM/ALM1
      XLAM =0.5D0*X*ALM1/PIM
      XLAM2=XLAM*XLAM
      VKUA =(ALM1/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKUA=-0.5D0*(ALM1/PIM)**2*X*VKUA
      DDVKUA=-0.5D0*(ALM1/PIM)**2*(X*DVKUA+VKUA)
      D3VKUA=-0.5D0*(ALM1/PIM)**2*(X*DDVKUA+2*DVKUA)

      XA   =X*AMES/PIM
      RATA =AMES/ALM1
      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-----------------------------------------------------------------
C
C     LOCAL TERMS PSEUDOSCALAR MESONS:
C
C-----------------------------------------------------------------
      FC1  = (DDFIA+2*DFIA*X1)
      FTEN = (DDFIA-DFIA*X1)/3.D0
C
      VSIG       = VSIG  + PIM*FPNN*FC1/3.D0
      VTEN       = VTEN  + PIM*FPNN*FTEN
C-----------------------------------------------------------------
C
C     NONLOCAL TERMS PSEUDOSCALAR MESONS:
C
C-----------------------------------------------------------------
      IF(NAPION.EQ.1) THEN
C-----------------------------------------------------------------
C     GRAZ 1978:
c     corr= 0.d0
      DFC1  = (D3FIA+2*DDFIA*X1-2*DFIA*X2)
      DFTEN = (D3FIA-DDFIA*X1+DFIA*X2)/3.D0
      FISS  = FISS   -corr*0.5D0*REDM*FPNN*FC1*DIV*PIM/3.D0
      FITEN = FITEN  -corr*0.5D0*REDM*FPNN*FTEN*DIV*PIM
      DFISS = DFISS  -corr*0.5D0*REDM*FPNN*DFC1*DIV*PIM**2/3.D0
      DFITEN= DFITEN -corr*0.5D0*REDM*FPNN*DFTEN*DIV*PIM**2
C-----------------------------------------------------------------------------
C     JANUARY 2013:
      FC0  = FIA
      FC1  = (DDFIA+2*DFIA*X1)
      FTEN = (DDFIA-DFIA*X1)/3.D0
      FSO  =-(DFIA*X1)
      DFC0 = -FSO*AMPS(IN)**2*X/PIM                ! JANUARY 2013
      DFC1 = DFC0 + ALM1*XLAM*VKUA*AMPS(IN)/PIM    ! JANUARY 2013
C     DDFC0= (3*FT-FSO)*AMVC(IN)**2                ! JANUARY 2013
      DDFC0= (FC1+2*FSO)*AMPS(IN)**2               ! JANUARY 2013
      DDFC1 = DDFC0 - (ALM1*XLAM)**2*VKUA*AMPS(IN) ! JAN 2013
     .              + 0.5D0*ALM1**2*VKUA*AMPS(IN)
      DDFTEN= 0D0
C-----------------------------------------------------------------------------
      DDFISS = DDFISS  -corr*0.5D0*REDM*FPNN*DDFC1*DIV*PIM**2/3.D0
      DDFITEN= DDFITEN -corr*0.5D0*REDM*FPNN*DDFTEN*DIV*PIM**2
C-----------------------------------------------------------------------------
c     write(6,*) 'psscal98: fiss,fiten,dfiss,dfiten=',
c    .fiss,fiten,dfiss,dfiten
      ENDIF
C     END GRAZ 1978.
C-----------------------------------------------------------------
      IF(NAPION.EQ.2) THEN
C-----------------------------------------------------------------
C     AUGUST 1998 ADDITIONS: 1/[OMEGA*(OMEGA+A)]:
      CALL FNFUN(3,X,AMES,ALM1,VAFI,DVAFI,D2VAFI,D3VAFI,D4VAFI)
      VAFI1 = CORR*(D2VAFI+2*DVAFI*X1)
      VATEN = CORR*(D2VAFI-DVAFI*X1)/3.D0
      DVAF1 = CORR*(D3VAFI+2*D2VAFI*X1-2*DVAFI*X2)
      DVATN = CORR*(D3VAFI-D2VAFI*X1+DVAFI*X2)/3.D0

      VTLS   = VTLS   + 0.5D0*FPNN*VAFI1/3.D0
      VTLT   = VTLT   + 0.5D0*FPNN*VATEN
c     VSIG   = VSIG   + 0.5D0*FPNN*TLAB*VAFI1/3.D0
c     VTEN   = VTEN   + 0.5D0*FPNN*TLAB*VATEN
      FISS   = FISS   - REDM*FPNN*VAFI1*DSQRT(DIV)/3.D0
      FITEN  = FITEN  - REDM*FPNN*VATEN*DSQRT(DIV)
      DFISS  = DFISS  - REDM*FPNN*DVAF1*DSQRT(DIV)*PIM/3.D0
      DFITEN = DFITEN - REDM*FPNN*DVATN*DSQRT(DIV)*PIM

      FISTL  = FISTL  - .25D0*REDM*FPNN*VAFI1*DIV/3.D0
      FITTL  = FITTL  - .25D0*REDM*FPNN*VATEN*DIV
      DFISTL = DFISTL - .25D0*REDM*FPNN*DVAF1*DIV*PIM/3.D0
      DFITTL = DFITTL - .25D0*REDM*FPNN*DVATN*DIV*PIM
      ENDIF
C     END AUGUST 1998.
C-----------------------------------------------------------------
      if(x.lt.0.0d0) then
c     if(mod(in,2).eq.0.and.mod(icall,20).eq.2) then
      write(6,*) 'pppppppppppppppppppppppppppppppppppppppppppppp'
      write(6,*) 'psscal98, 1: in,ames=',in,ames,' x=',x,
     .' corr=',corr
      write(6,*) ' vsig ,vten  =',vsig,vten
      write(6,*) ' vtls ,vtlt  =',vtls,vtlt
      write(6,*) ' fiss ,dfiss =',fiss,dfiss
      write(6,*) ' fiten,dfiten=',fiten,dfiten
      write(6,*) ' fistl,dfistl=',fistl,dfistl
      write(6,*) ' fittl,dfittl=',fittl,dfittl
      endif
c     check:
c     call pionna(x,1.d0)
c     write(6,*) 'pionna,  ames=',ames,' x=',x,
c    .'fisna,fitna=',fisna,fitna
C-----------------------------------------------------------------

 1040 CONTINUE
C
      RETURN
      END
C***********************************************************
C
      SUBROUTINE HPIONNA(X,FACISO)
C
C     PROGRAM FOR THE R-SPACE NON-ADIABATIC PION-EXCHANGE
C     POTENTIALS IN MOST SIMPLE EXPANSION:
C     1/(OMEGA+A) APPROX 1/OMEGA - A/OMEGA^2
C
C     Note: the combination PIONNA + ITMO.NE.0 is WRONG!!!
C
C***********************************************************
      IMPLICIT REAL*8(A-H,O-Y)
      COMMON/NAPIONP/VSIGNA,VTENNA,FISNA,FITNA
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/PSCOP/ALP,APV,FP,F62,F92,F120,F12C,FCHPI
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      DIMENSION XX(20),WW(20),XKMAX(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
      DATA XKMAX/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/
      SAVE XX,WW,PIM,AMN,AMES,ANUC,AMU
C
C   THE POTENTIAL FUNCTIONS
C
      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*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
        PIM=135.D0
        AMN=938.259D0
        AMES=PIM
        ANUC=AMN/PIM
        AMU =AMES/PIM
        CALL GAUSS(NPNT,XX,WW,1)
        ICALL = 1
      ENDIF

      FPNN=FP*FP*FACISO
      ALAM=ALMP1
C     AK=DSQRT(AMN*TLAB/2.D0)/PIM
C
C     COMPUTATION ADIABATIC POTENTIAL FUNCTIONS:
C
      XLAM=0.5D0*X*ALAM/PIM
      EX=FDEXP(X)
      VKUNN=(ALAM/PIM)**3*FDEXP(-XLAM*XLAM)/(2.D0*SRPI)
C
      RATP =PIM/ALAM
      RATM =AMES/ALAM
      EXPM=DEXP(RATM *RATM )
      ELAM=FDEXP(-XLAM *XLAM )
      DERFCM=FDERFC(-XLAM +RATM )
      DERFCP=FDERFC( XLAM +RATM )
      FC0  = FF0(EXPM,EX,X,DERFCM,DERFCP)
      FTEN = FF3(EXPM,EX,X,XLAM,DERFCM,DERFCP,ELAM)
      FC1  = FC0  - VKUNN
C     END ADIABATIC FUNCTION COMPUTATION

      VSIGNA = 0.D0
      VTENNA = 0.D0

      DO 100 INT=1,NINT
      ABM=0.5D0*(XKMAX(INT+1)-XKMAX(INT))
      ABP=0.5D0*(XKMAX(INT+1)+XKMAX(INT))
      DO 110 IY=1,NPNT
      Y=ABM*XX(IY)+ABP
      GEW=WW(IY)*ABM*2.D0/PI
      Y2 =1.D0/Y**2
C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :
      FDISP=FDEXP(-Y*Y*RATP*RATP)
C
      AMI   =DSQRT(AMU*AMU+Y*Y)
      XMI   =AMI*X
      RATMI =RATP*AMI
      ERATMI=FDEXP(RATMI*RATMI)
      EXMI  =FDEXP(XMI)
      EMMI  =FDERFC(-XLAM+RATMI)
      EPMI  =FDERFC( XLAM+RATMI)
C
      FC0I  = FF0(ERATMI,EXMI,XMI,EMMI,EPMI)
      FTENI = FF3(ERATMI,EXMI,XMI,XLAM,EMMI,EPMI,ELAM)*AMI**3*FDISP
      FC1I  = (FC0I*AMI**3 - VKUNN)*FDISP

      VSIGNA = VSIGNA + GEW * (FC1 - FC1I)*Y2
      VTENNA = VTENNA + GEW * (FTEN - FTENI)*Y2
110   CONTINUE
100   CONTINUE

      FISNA  = -0.5D0*FPNN*VSIGNA/3.D0
      FITNA  = -0.5D0*FPNN*VTENNA
      VSIGNA = +FPNN*VSIGNA*PIM/3.D0
      VTENNA = +FPNN*VTENNA*PIM

      RETURN
      END

C**********************************************************************
C
      SUBROUTINE PSSCA2(XA,FACISO)
C
C**********************************************************************

C
C     PSEUDO-SCALAR MESONS2: CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLPS2/FPS21,FPS26,FPS29
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB
      DIMENSION AMPS(3)
      DATA SRPI/1.7724538509D0/,IPV/1/
      DATA AMP2,AME2,AMX2/1300.D0,1280.D0,1430.D0/
C
C   NOTE : PION2(IN=1),ETA2 (IN=2),ETAP2(IN=3)
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
      FITEN  = 0.D0
      DFITEN = 0.D0
      DIV1=1.D0/(AM*AMY)
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  DIV=AMP2*AMP2/(PIM*PIM)
      GPNN= FACISO*FPS21*DIV
      AMPS(1)=AMP2
      ALM1=ALMP1
      GOTO 1054
1052  DIV=AME2*AME2/(PIM*PIM)
      GPNN=  FPS26*DIV
      AMPS(2)=AME2
      ALM1=ALMP1
      GOTO 1054
1053  DIV=AMX2*AMX2/(PIM*PIM)
      GPNN=  FPS29*DIV
      AMPS(3)=AMX2
      ALM1=ALMP0
C
1054  RATM1=AMPS(IN)/ALM1
      FAC1=AMPS(IN)*AMPS(IN)/(AM*AMY)
C
      XLAM1=0.5D0*XA*ALM1/PIM
      X =(AMPS(IN)/PIM)*XA
      EX=FDEXP(X)
      VKUNN=(ALM1/AMPS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMPS(IN)
      FT0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN)
      FSO0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMPS(IN)
      FC1  = FC0  - VKUNN*AMPS(IN)
      DFC0 = -X*FSO0
      DFC1 =  DFC0 + ALM1*XLAM1*VKUNN
      DFT0 =  DFC1/3.D0-3*FT0/X
C
        VSIG       = VSIG      + GPNN*FC1/3.D0
        VTEN       = VTEN      + GPNN*FT0

        FISS       = FISS   - corsps*GPNN*REDM*FC1 *DIV1/6.D0
        DFISS      = DFISS  - corsps*GPNN*REDM*DFC1*DIV1/6.D0
        FITEN      = FITEN  - cortps*GPNN*REDM*FT0 *DIV1/2.D0
        DFITEN     = DFITEN - cortps*GPNN*REDM*DFT0*DIV1/2.D0
C
C     GAUSSIAN CONTRIBUTION (ANN.PHYS. 208, EQN. (7.16)):
C
      IF(IPV.EQ.1) THEN
      UPSC0 =   VKUNN*AMPS(IN)
      UPSC1 =  -(1.5D0-XLAM1**2)*UPSC0
      UPST0 =  + XLAM1**2*UPSC0/3.D0
      DUPSC0=  -ALM1*XLAM1*UPSC0/PIM
      FIC1  = -VKUNN*AMPS(IN)
      FIT0  = ( 1.D0-FDERFC(XLAM1)-2*XLAM1*(1.D0+2*XLAM1**2/3.D0)
     .        *FDEXP(-XLAM1**2)/SRPI)/X**3*AMPS(IN)
      DFIC1 = -ALM1*XLAM1*FIC1/PIM
      DFIT0 = (-3*FIT0 + (8/3.D0)*ALM1*XLAM1**4*VKUNN/X**2)/XA

      VSIG     = VSIG + GPNN*UPSC1*ALM1**2*DIV1/6.D0
      VTEN     = VTEN - GPNN*UPST0*ALM1**2*DIV1/4.D0
      VSO2     = VSO2 + GPNN*(3/X**2)*FIT0*FAC1

      FISS     = FISS   - GPNN*REDM*(UPSC0-FIC1/3.D0)*DIV1
      DFISS    = DFISS  - GPNN*REDM*(DUPSC0-DFIC1/3.D0)*DIV1
      FITEN    = FITEN  + GPNN*REDM*FIT0 *DIV1
      DFITEN   = DFITEN + GPNN*REDM*DFIT0*DIV1
      ENDIF
C
 1040 CONTINUE
C
      RETURN
      END

C**********************************************************************
      SUBROUTINE VECTOR98(X,FACISO,IVCT,NAOBE,CORR,INRS)
C**********************************************************************
C
C     VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     VERSION SEPTEMBER 1998: RETARDATION IN OBE, SEE NON-LOCAL
C     FUNCTIONS FROM 1/OMEGA(OMEGA+A)-PROPAGATOR,
C     INCLUDING SPIN-SPIN AND TENSOR POTENTIALS, LIKE GRAZ-PION
C
C
C     VECTOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     UPDATED 6/9/95: INRS =1: PRD17; INRS =0: STOKS APPR.
C
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB
      DIMENSION AMVC(4),FVC(4)
c     DATA SRPI/1.772454D0/,AMPRO/938.27231D0/
      DATA SRPI/1.772454D0/,AMPRO/938.25931D0/
C
C   NOTE : RHO1(IN=1),RHO2(IN=2),OME(IN=3),PHI(IN=4)
C
C-----------------------------------------------------------------
C
C   THE POTENTIAL FUNCTIONS
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
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.D00+XH)-EXH*EP*(1.D00-XH)-4.D00*XLAMH*EXLAM/ERATH/SRPI)
c    .  /(2.D00*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/SRPI)
c    .  /(2.D00*XH*XH*XH)
C-----------------------------------------------------------------
C
      XM1=AM
      XM2=AMY
CC
      X1  = 1.D0/X
      X2  = X1*X1
      X3  = X1*X2
      X4  = X2*X2
      DIV = 1.D0/(XM1*XM2)

C-----------------------------------------------------------------
      DO 1040 IN=1,4
      GOTO(1051,1051,1053,1054),IN
1051  GDNN = FACISO*FD12
      GDFNN= FACISO*FDV1
      GFDNN= FACISO*FDV1
      GFNN = FACISO*FV12
      ALM1=ALMV1
      IF(IN.EQ.1) THEN
      FVC(1)=ARO
      AMVC(1)=AM1RO
      ELSE
      FVC(2)=BRO
      AMVC(2)=AM2RO
      ENDIF
      GOTO 1055
1053  GDNN =  FD62
      GDFNN=  FDV6
      GFDNN=  FDV6
      GFNN =  FV62
      FVC(3)=1.D0
      AMVC(3)=AMOM
      ALM1=ALMV0
      GOTO 1055
1054  GDNN =  FD92
      GDFNN=  FDV9
      GFDNN=  FDV9
      GFNN =  FV92
      FVC(4)=1.D0
      AMVC(4)=AMFI
c     ALM1=ALMV0
      ALM1=ALMV1       ! 15 NOV 2012
C-----------------------------------------------------------------
C
1055  AMES = AMVC(IN)
      AMU  = AMES/PIM
      FAC0=AMES*AMES/AMPRO/AMPRO
      FAC1=AMES*AMES/(XM1*XM2)
      FAC2=DSQRT(FAC0*FAC1)
C
      CCNN1= 0.5D0*GDNN*FAC1+(GFDNN/XM1+GDFNN/XM2)*AMES**2
     .       /(4*AMPRO)
      CCNN2= GFNN*FAC0*FAC1/16.D0
      CSNN1= GDNN+(GFDNN*XM1+GDFNN*XM2+GFNN*XM1*XM2/AMPRO)
     .       /AMPRO
      CSNN2= GFNN*AMES**2/(8*XM1*XM2)
      CTNN0= CSNN1
      CTNN1= CSNN2
      CONN0= 1.5D0*GDNN+(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO
      CONN1= 3*GFNN*FAC0/8.D0
      CO2NN= GDNN+4*(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO +
     +       8*GFNN*XM1*XM2/AMPRO/AMPRO
C
      XLAM =0.5D0*X*ALM1/PIM
      XLAM2=XLAM*XLAM
      VKUA =(ALM1/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKUA=-0.5D0*(ALM1/PIM)**2*X*VKUA
      DDVKUA=-0.5D0*(ALM1/PIM)**2*(X*DVKUA+VKUA)
      D3VKUA=-0.5D0*(ALM1/PIM)**2*(X*DDVKUA+2*DVKUA)
C-----------------------------------------------------------------

      XA   =X*AMES/PIM
      RATA =AMES/ALM1
      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
      D4FIA=-(D3FIA-2*D3VKUA)*X1+3*(DDFIA-2*DDVKUA)*X2
     .      -6*(DFIA-2*DVKUA)*X3+6*(FIA-2*VKUA)*X4-(AMES/PIM)*D3HIA
C-----------------------------------------------------------------

      FC0  = PIM*FVC(IN)*FIA
      FC1  = PIM*FVC(IN)*(DDFIA+2*DFIA*X1)/AMU**2
      FTEN = PIM*FVC(IN)*(DDFIA-DFIA*X1)/3.D0/AMU**2
      FSO  =-PIM*FVC(IN)*(DFIA*X1)/AMU**2
      FSO2 = 3*FTEN/(XA*XA)
C
      FC2  = FC1  + FVC(IN)*(1.5D0-XLAM2)*VKUA*PIM/RATA**4
      FT1  = FTEN - FVC(IN)*XLAM2*VKUA*PIM/(3*RATA**4)
      FO1  = FSO  - FVC(IN)*VKUA*PIM/(2*RATA**4)
C-----------------------------------------------------------------------------
      DFC0 = -FSO*AMVC(IN)**2*X/PIM                    ! JANUARY 2013
      DFC1 = DFC0 + FVC(IN)*ALM1*XLAM*VKUA*AMVC(IN)    ! JANUARY 2013
C     DDFC0= (3*FT-FSO)*AMVC(IN)**2                    ! JANUARY 2013
      DDFC0= (FC1+2*FSO)*AMVC(IN)**2                   ! JANUARY 2013
      DDFC1 = DDFC0 - FVC(IN)*(ALM1*XLAM)**2*VKUA*AMVC(IN) ! JAN 2013
C-----------------------------------------------------------------------------
C-----------------------------------------------------------------
c     if(in.eq.2.and.x.eq.0.01d0) write(6,*) 'x=',x,
c    .' fc0,fc1,fc2,=',fc0,fc1,fc2
c     if(in.eq.2.and.x.eq.0.01d0) write(6,*) 'x=',x,
c    .' ften,ft1,fso,fo1=',ften,ft1,fso,fo1
C-----------------------------------------------------------------

C-----------------------------------------------------------------
C
      VC       = VC    + GDNN*FC0 + CCNN1*FC1 +
     .                   GFNN*FAC0*FAC1*FC2/16.D0
     .                 + (1-INRS)*FAC1*(GDNN*FAC1/64.D0 +
     .                   GDFNN*FAC2/8.D0)*FC2
      VSIG     = VSIG  + (CSNN1*FC1 + INRS*GFNN*FAC0*FC2/8.D0)
     .                   * FAC1/6.D0
      VTEN     = VTEN  - (CTNN0*FTEN + INRS*GFNN*FAC0*FT1/8.D0)
     .                   * FAC1/4.D0
      VSO      = VSO   - FAC1*(CONN0*FSO + GFNN*FAC0*FO1*3/8.D0
     .                 + (1-INRS)*(GDNN*FAC1/16.D0 +
     .                   GDFNN*FAC2/2.D0)*FO1 )
      VSO2     = VSO2  + CO2NN*FSO2*FAC1*FAC1/16.D0

      FI    = FI    + 1.5D0*REDM*GDNN*FC0/(XM1*XM2)
C     DFI    = DFI   - 1.5D0*REDM*GDNN*FSO*XA*FAC1/AMES
C----------------------------------------------------------------------------
      DFI     = DFI    + 1.5D0*REDM*GDNN*DFC0/(XM1*XM2)      !JAN 2013
      DDFI     = DDFI    + 1.5D0*REDM*GDNN*DDFC0/(XM1*XM2)      !JAN 2013
C----------------------------------------------------------------------------

c     if(in.eq.2.and.x.eq.0.01d0) then
c     if(x.eq.0.01d0) then
c     write(6,*) '----------------------------------------------'
c     write(6,*) 'vc98,at1: x,xa=',x,xa,' ames=',ames,
c    .' fd1=',dsqrt(fd12)
c     write(6,*) 'fso,redm,gdnn=',fso,redm,gdnn
c     write(6,*) ' fi,dfi,fiss,fiten=',fi,dfi,fiss,fiten
c     write(6,*) ' vc,vsig,vten,vso,vso2=',
c    .vc,vsig,vten,vso,vso2
c    endif
C
C-----------------------------------------------------------------
C     AUGUST 1998 ADDITIONS: 1/[OMEGA*(OMEGA+A)]:
      IF(NAOBE.EQ.1) THEN
      FAC1  = FAC1 /AMU**2
      CCNN1 = CCNN1/AMU**2
      CCNN2 = CCNN2/AMU**4
      CSNN2 = CSNN2/AMU**2
      CTNN1 = CTNN1/AMU**2
      CONN1 = CONN1/AMU**2
      CALL FNFUN(3,X,AMES,ALM1,VAFI,DVAFI,D2VAFI,D3VAFI,D4VAFI)
      VAFI  = CORR*FVC(IN)*VAFI
      DVAFI = CORR*FVC(IN)*DVAFI
      D2VAFI= CORR*FVC(IN)*D2VAFI
      D3VAFI= CORR*FVC(IN)*D3VAFI

      VAFI1 = (D2VAFI+2*DVAFI*X1)
      VATEN = (D2VAFI-  DVAFI*X1)/3.D0
      VASO0 = -X1*DVAFI
      DVAF1 = (D3VAFI+2*D2VAFI*X1-2*DVAFI*X2)
      DVATN = (D3VAFI-D2VAFI*X1+DVAFI*X2)/3.D0
      DVASO0= -X1*(D2VAFI+VASO0)

C----------------------------------------------------------------
      CALL FNFUN(1,X,AMES,ALM1,VBFI,DVBFI,D2VBFI,D3VBFI,D4VBFI)
      CALL FNFUN(0,X,AMES,ALM1,VCFI,DVCFI,D2VCFI,D3VCFI,D4VCFI)
      VBFI  = CORR*FVC(IN)*(VBFI+2*(PIM/ALM1)*VCFI/SRPI)
      DVBFI = CORR*FVC(IN)*(DVBFI+2*(PIM/ALM1)*DVCFI/SRPI)
      D2VBFI= CORR*FVC(IN)*(D2VBFI+2*(PIM/ALM1)*D2VCFI/SRPI)
      D3VBFI= CORR*FVC(IN)*(D3VBFI+2*(PIM/ALM1)*D3VCFI/SRPI)
c     VBFI  = CORR*FVC(IN)DVBFI
c     DVBFI = CORR*FVC(IN)*DVBFI
c     D2VBFI= CORR*FVC(IN)*D2VBFI
c     D3VBFI= CORR*FVC(IN)*D3VBFI

      VBFI1 = (D2VBFI+2*DVBFI*X1)
      VBTEN = (D2VBFI-  DVBFI*X1)/3.D0
      VBSO0 = -X1*DVBFI
      DVBF1 = (D3VBFI+2*D2VBFI*X1-2*DVBFI*X2)
      DVBTN = (D3VBFI-D2VBFI*X1+DVBFI*X2)/3.D0
      DVBSO0= -X1*(D2VBFI+VBSO0)

      VAFI1H= AMU**2*VAFI-VBFI
      VAFI2H= AMU**2*VAFI1H-VBFI1
      VAFI2 = AMU**2*VAFI1-VBFI1
      VATEN1= AMU**2*VATEN-VBTEN
      VASO1 = AMU**2*VASO0-VBSO0
      DVAF2 = AMU**2*DVAF1-DVBF1
      DVATN1= AMU**2*DVATN-DVBTN
      DVASO1= AMU**2*DVASO0-DVBSO0

C----------------------------------------------------------------
      if(x.lt.0.d0) then
c     if(in.eq.4.and.mod(icall,20).eq.2) then
      write(6,*) '-----------------------------------------------'
      write(6,*) 'vector98: in=',in,' x=',x
      write(6,*) 'fvc   ,amu^2 =',fvc(in),amu**2
      write(6,*) 'vafi  ,dvafi =',vafi  ,dvafi
      write(6,*) 'd2vafi,d3vafi=',d2vafi,d3vafi
      write(6,*) 'vafi1 ,vafi2 =',vafi1 ,vafi2
      write(6,*) 'vafi1h,vafi2h=',vafi1h,vafi2h
      write(6,*) 'vaten ,vaten1=',vaten,vaten1
      write(6,*) 'vaso0 ,vaso1 =',vaso0,vaso1
      write(6,*) 'vbfi  ,dvbfi =',vbfi,dvbfi
      write(6,*) 'd2vbfi,d3vbfi=',d2vbfi,d3vbfi
      write(6,*) 'vbfi1        =',vbfi1
      write(6,*) 'vbten ,vbso0 =',vbten,vbso0
      endif
C----------------------------------------------------------------

      VTLC  = VTLC + 0.5D0*(GDNN*VAFI+CCNN1*VAFI1
     .                +INRS*CCNN2*VAFI2)
      VTLS  = VTLS + 0.5D0*(CSNN1*VAFI1+CSNN2*VAFI2)
     .                *FAC1/6.D0
      VTLT  = VTLT - 0.5D0*(CTNN0*VATEN+CTNN1*VATEN1)*FAC1/4.D0
      VTLO  = VTLO - 0.5D0*(CONN0*VASO0+CONN1*VASO1)*FAC1
      VTLO2 = VTLO2+ 0.5D0*CO2NN*3*VATEN*X2*FAC1**2/16.D0

      FITL  = FITL + 3*REDM*GDNN*VAFI*DIV/4.D0
      DFITL = DFITL+ 3*REDM*GDNN*DVAFI*DIV*PIM/4.D0

      FI    = FI   - REDM*(GDNN*VAFI+CCNN1*VAFI1
     .                +INRS*CCNN2*VAFI2)*DSQRT(DIV)
      FISS  = FISS - REDM*(CSNN1*VAFI1+CSNN2*VAFI2)
     .                *(FAC1/6.D0)*DSQRT(DIV)
      FITEN = FITEN+ REDM*(CTNN0*VATEN+CTNN1*VATEN1)
     .                *(FAC1/4.D0)*DSQRT(DIV)
      FISO  = FISO + REDM*(CONN0*VASO0+CONN1*VASO1)*FAC1*DSQRT(DIV)
      FISO2 = FISO2- REDM*CO2NN*3*VATEN*X2*DSQRT(DIV)*FAC1**2/16.D0

      DFI   = DFI  - REDM*(GDNN*DVAFI+CCNN1*DVAF1
     .                +INRS*CCNN2*DVAF2)*DSQRT(DIV)*PIM
      DFISS = DFISS- REDM*(CSNN1*DVAF1+CSNN2*DVAF2)
     .                *(FAC1/6.D0)*DSQRT(DIV)*PIM
      DFITEN= DFITEN+REDM*(CTNN0*DVATN+CTNN1*DVATN1)
     .                *(FAC1/4.D0)*DSQRT(DIV)*PIM
      DFISO = DFISO+ REDM*(CONN0*DVASO0+CONN1*DVASO1)*FAC1*
     .                DSQRT(DIV)*PIM
      DFISO2= DFISO2-REDM*CO2NN*3*X2*(DVATN-2*X1*VATEN)*FAC1**2*
     .               DSQRT(DIV)*PIM/16.D0
      ENDIF
C     END AUGUST 1998.

c     if(in.eq.2.and.x.eq.0.01d0) then
      if(x.lt.0.d0) then
c     if(in.eq.4.and.mod(icall,20).eq.2) then
      write(6,*) 'vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv'
      write(6,*) 'vector98, in,ames=',in,ames,' x=',x
      write(6,*) ' corr=',corr,' faciso=',faciso
      write(6,*) ' vc   ,vsig  =',vc,vsig
      write(6,*) ' vten ,vso   =',vten,vso
      write(6,*) ' vso2        =',vso2
      write(6,*) ' vtlc ,vtls  =',vtlc,vtls
      write(6,*) ' vtlt ,vtlo  =',vtlt,vtlo
      write(6,*) ' vtlo2       =',vtlo2
      write(6,*) ' fi   ,dfi   =',fi,dfi
      write(6,*) ' fiss ,dfiss =',fiss,dfiss
      write(6,*) ' fiten,dfiten=',fiten,dfiten
      write(6,*) ' fiso ,dfiso =',fiso,dfiso
      write(6,*) ' fiso2,dfiso2=',fiso2,dfiso2
      write(6,*) ' fitl ,dfitl =',fitl,dfitl
      endif
C-----------------------------------------------------------------
 1040 CONTINUE
C
      RETURN
      END
C**********************************************************************
      SUBROUTINE VECTR2(XA,FACISO,IVCT,INRS)
C
C**********************************************************************

C
C     VECTOR MESONS : HEAVY VECTOR-MESONS
C                   : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     UPDATED 6/9/95: INRS =1: PRD17; INRS =0: STOKS APPR.
C
      IMPLICIT REAL *8(A-H,O-Z)
c     COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/VECCP2/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      DIMENSION AMVC(4),FVC(4)
      DATA AMRO2/1450.D0/,AMOM2/1420.D0/,AMFI2/1680.D0/
      DATA SRPI/1.772454D0/,AMPRO/938.27231D0/
      DATA FVC/4*1.D0/
C
C   NOTE : RHO2(IN=1),OME2(IN=2),PHI2(IN=3)
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
      XM1=AM
      XM2=AMY
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  GDNN = FACISO*FD12
      GDFNN= FACISO*FDV1
      GFDNN= FACISO*FDV1
      GFNN = FACISO*FV12
      AMVC(1)=AMRO2
      ALM1=ALMV1
      GOTO 1055
1052  GDNN =  FD62
      GDFNN=  FDV6
      GFDNN=  FDV6
      GFNN =  FV62
      AMVC(2)=AMOM2
      ALM1=ALMV0
      GOTO 1055
1053  GDNN =  FD92
      GDFNN=  FDV9
      GFDNN=  FDV9
      GFNN =  FV92
      FVC(4)=1.D0
      AMVC(3)=AMFI2
      ALM1=ALMV0
C
1055  RATM1=AMVC(IN)/ALM1
      FAC0=AMVC(IN)*AMVC(IN)/AMPRO/AMPRO
      FAC1=AMVC(IN)*AMVC(IN)/(XM1*XM2)
      FAC2=DSQRT(FAC0*FAC1)
C
      CCNN1=0.5D0*GDNN*FAC1+(GFDNN/XM1+GDFNN/XM2)*AMVC(IN)**2
     .      /(4*AMPRO)
      CSNN1= GDNN+(GFDNN*XM1+GDFNN*XM2+GFNN*XM1*XM2/AMPRO)
     .       /AMPRO
      CTNN0= CSNN1
      CONN0= 1.5D0*GDNN+(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO
      CO2NN= GDNN+4*(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO +
     +       8*GFNN*XM1*XM2/AMPRO/AMPRO
C
      XLAM1=0.5D0*XA*ALM1/PIM
      X =(AMVC(IN)/PIM)*XA
      EX=FDEXP(X)
      VKUNN=(ALM1/AMVC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FVC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMVC(IN)
      FTEN = FVC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)
      FSO  = FVC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMVC(IN)
      FSO2 = 3*FTEN/(X*X)
C
      FC1  = FC0  - FVC(IN)*VKUNN*AMVC(IN)
      FC2  = FC1  + FVC(IN)*(1.5D0-XLAM1*XLAM1)
     .            * VKUNN*AMVC(IN)/RATM1/RATM1
      FT1  = FTEN - FVC(IN)*XLAM1*XLAM1*VKUNN*AMVC(IN)
     .                / (3*RATM1*RATM1)
      FO1  = FSO  - FVC(IN)*VKUNN*AMVC(IN)
     .                / (2*RATM1*RATM1)
C
      VC       = VC        + GDNN*FC0 + CCNN1*FC1 +
     .                       GFNN*FAC0*FAC1*FC2/16.D0
     .                     + (1-INRS)*FAC1*(GDNN*FAC1/64.D0 +
     .                             GDFNN*FAC2/8.D0)*FC2
      VSIG     = VSIG      + (CSNN1*FC1 + INRS*GFNN*FAC0*FC2/8.D0)
     .                     * FAC1/6.D0
      VTEN     = VTEN      - (CTNN0*FTEN + INRS*GFNN*FAC0*FT1/8.D0)
     .                     * FAC1/4.D0
      VSO      = VSO       - FAC1*(CONN0*FSO + GFNN*FAC0*FO1*3/8.D0
     .                     + (1-INRS)*(GDNN*FAC1/16.D0 +
     .                             GDFNN*FAC2/2.D0)*FO1 )
      VSO2     = VSO2      + CO2NN*FSO2*FAC1*FAC1/16.D0
      FI       = FI        + 1.5D0*REDM*GDNN*FC0/(XM1*XM2)
      DFI      = DFI       - 1.5D0*REDM*GDNN*FSO*X*FAC1/AMVC(IN)
C
 1040 CONTINUE
C
      RETURN
      END

C**********************************************************************
C
      SUBROUTINE SCALAR98(XA,FACISO,ISCL,NAOBE,CORR)
C
C**********************************************************************
C
C     SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     VERSION NOVEMBER 2012: ALMS1 FOR F_0(990)
C----------------------------------------------------------------------
C     VERSION AUGUST 1998: RETARDATION IN OBE, SEE NON-LOCAL
C     FUNCTIONS FROM 1/OMEGA(OMEGA+A)-PROPAGATOR:
C     A = E(p')+E(p)-W \approx (q^{2}+k^{2}/4-p_{i}^{2})/M_{N}
C     CORRECTION TERM \approx -A/\OMEGA^{3} ---> EXTRA POTENTIAL:
C
C      1
C     --- (\Nabla^2\PHI3+\PHI3\Nabla^3) + TLAB \PHI3,  p_{i}^{2}=M TLAB/2
C     2M
C           \PHI3 = Fourier Transform 1/\OMEGA^{3} ETC.
C----------------------------------------------------------------------
C     XA = R/(HBAR/PIM*C) (MEV)^0
C------------------------------------------------------------------------------
C     DIMENSIONS: REDM (MEV)^1, FI (MEV)^0, DFI (MEV)^1, DDFI (MEV)^2
C******************************************************************************
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLSC/AMEPS,GAMEPS,ASI,BSI,AM1SI,AM2SI,AMSST,AMD,THS
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAXI
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN
      DIMENSION AMSC(4),FSC(4)
c*    DATA AMEPSH/760.D0/,GAMEPSH/640.D0/,AMSAV/760.D0/
      DATA SRPI/1.7724538509D0/,AMCRS/750.D0/
C
C
C   METHOD : NAGELS & RIJKEN  FIT TO BROAD MESON PROPAGATOR
C
C   NOTE : DELTA(IN=1),EPS1(IN=2),EPS2(IN=3),SSTAR(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/SRPI)
     .  /(2.D00*XH*XH*XH)
C
C
      X1 = 1.D0/XA
      X2 = X1*X1
      X3 = X1*X2
      DIV =1.D0/(AM*AMY)
C
      DO 1040 IN=1,4
      GOTO(1051,1052,1053,1054),IN
1051  GSNN= FACISO*GS12
      FSC(1)=1.D0
      AMSC(1)=AMD
      ALM1 = ALMS1
      GOTO 1055
1052  GSNN=  GS62
      FSC(2)=ASI
      AMSC(2)=AM1SI
      ALM1 = ALMS0
      GOTO 1055
1053  GSNN=  GS62
      FSC(3)=BSI
      AMSC(3)=AM2SI
      ALM1 = ALMS0
      GOTO 1055
1054  GSNN=  GS92
      FSC(4)=1.D0
      AMSC(4)=AMSST
c     ALM1 = ALMS0
      ALM1 = ALMS1      ! 15 NOV 2012
      GOTO 1055
1055  CONTINUE
C-----------------------------------------------------------------
C     NORMALIZATION POTENTIAL TAIL:
c     IF(IZSC.EQ.1) THEN
c     FSC(IN) = FSC(IN)/(1.D0+(AMSAV/AMCRS)**2)
c     ENDIF
C-----------------------------------------------------------------
C     IN THIS ROUTINE: FC0 = AMSC * PHI_C^0, FC1 = AMSC * PHI_C^1,
C     ETC. THE SAME FOR FSO AND FSO2
C-----------------------------------------------------------------
C     PRD17 (1978) 768: R=XA/PIM and
C     DFC0 = -AMSC**2*(XA/PIM)*FSO0, DDFC0= (3*FT0-FSO0)*AMSC**2
C-----------------------------------------------------------------
      XLAM1=0.5D0*XA*ALM1/PIM
      VKUNN=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
      RATM1=AMSC(IN)/ALM1
      AMSC2=AMSC(IN)*AMSC(IN)
      AMSC3=AMSC(IN)*AMSC2
      AMSC5=AMSC2*AMSC3
      FAC1=AMSC2*DIV
      FAC2=FAC1*FAC1
C
      X =(AMSC(IN)/PIM)*XA
      EX=FDEXP(X)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)
      FSO  = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC(IN)
      FSO2 = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)
     .       *AMSC(IN)/(X*X)
      FC1  = FC0  - FSC(IN)*VKUNN*AMSC(IN)
      FDFI = FSO  * X *FAC1/AMSC(IN)
C-----------------------------------------------------------------------------
      DFC0 = -FSO*AMSC(IN)**2*XA/PIM                ! JANUARY 2013
      DFC1 = DFC0 + FSC(IN)*ALM1*XLAM1*VKUNN*AMSC(IN)  ! JANUARY 2013
C     DDFC0= (3*FT-FSO)*AMSC(IN)**2                    ! JANUARY 2013
      DDFC0= (FC1+2*FSO)*AMSC(IN)**2                   ! JANUARY 2013
      DDFC1 = DDFC0 - FSC(IN)*(ALM1*XLAM1)**2*VKUNN*AMSC(IN) ! JAN 2013
C-----------------------------------------------------------------------------
C

      VC       = VC        - GSNN*(FC0-0.25D0*FAC1*FC1)
      VSO      = VSO       - 0.5D0*GSNN*FSO*FAC1
      VSO2     = VSO2      - GSNN*FSO2*FAC2/16.D0
      FI       = FI        + 0.5D0*REDM*GSNN*FC0*DIV
C     DFI      = DFI       - 0.5D0*REDM*GSNN*FDFI
      DFI      = DFI       + 0.5D0*REDM*GSNN*DFC0*DIV
      DDFI     = DDFI      + 0.5D0*REDM*GSNN*DDFC0*DIV

C-----------------------------------------------------------------
C     SEPTEMBER 2002, ZERO IN FORM FACTOR:
      IF(IZSC.NE.0) THEN
      FZERO= (AMSC(IN)/AMCRS)**2
      FC2  = FC1  + FSC(IN)*(1.5D0-XLAM1*XLAM1)
     .            * VKUNN*AMSC(IN)/RATM1/RATM1
      FO1  = FSO  - FSC(IN)*(VKUNN/(2*RATM1*RATM1))*AMSC(IN)
      FO21 = FSO2 - FSC(IN)*(VKUNN/(4*RATM1**4))*AMSC(IN)
      VC       = VC  -FZERO* GSNN*(FC1-0.25D0*FAC1*FC2)
      VSO      = VSO -FZERO* 0.5D0*GSNN*FO1*FAC1
      VSO2     = VSO2-FZERO* GSNN*FO21*FAC2/16
       IF(IZSC.EQ.2) THEN
      FI       = FI  +FZERO* 0.5D0*REDM*GSNN*FC1*DIV
C     DFI      = DFI -FZERO* 0.5*REDM*GSNN*FO1*X*FAC1/AMSC(IN)
      DFI      = DFI +FZERO* 0.5D0*REDM*GSNN*DFC1*DIV
      DDFI     = DDFI +FZERO* 0.5D0*REDM*GSNN*DDFC1*DIV
       ENDIF
      ENDIF
C-----------------------------------------------------------------
C     AUGUST 1998 ADDITIONS:
c     CALL FNFUN(3,XA,AMSC(IN),ALM1,VARFI0,VARFI1,VARFI2,VARFI3)

c     VTLC     = VTLC      - 0.5D0*GSNN*VARFI0
c     VC       = VC        - 0.5D0*GSNN*TLAB*VARFI0
c     FI       = FI        + REDM*GSNN*VARFI0*DSQRT(DIV)
c     DFI      = DFI       + REDM*GSNN*VARFI1*DSQRT(DIV)*PIM
C
C-----------------------------------------------------------------
C     AUGUST 1998 ADDITIONS: 1/[OMEGA*(OMEGA+A)]:
      IF(NAOBE.EQ.1) THEN
      CALL FNFUN(3,XA,AMSC(IN),ALM1,VAFI,DVAFI,D2VAFI,D3VAFI,D4VAFI)
      FAC1 = FAC1*(PIM/AMSC(IN))**2
      VAFI  = CORR*FSC(IN)*VAFI
      DVAFI = CORR*FSC(IN)*DVAFI
      D2VAFI= CORR*FSC(IN)*D2VAFI
      D3VAFI= CORR*FSC(IN)*D3VAFI
      VAFI1 = (D2VAFI+2*DVAFI*X1)
      DVAF1 = (D3VAFI+2*D2VAFI*X1-2*DVAFI*X2)
      VATEN = (D2VAFI-DVAFI*X1)/3.D0
      DVATN = (D3VAFI-D2VAFI*X1+DVAFI*X2)/3.d0
      VASO0 = -X1*DVAFI
      DVASO0= -X1*(D2VAFI-X1*DVAFI)

      VTLC  = VTLC - 0.5D0*GSNN*(VAFI-FAC1*VAFI1/4D0)
      VTLO  = VTLO - 0.25D0*GSNN*FAC1*VASO0
      VTLO2 = VTLO2- 0.5D0*GSNN*FAC1**2*3*X2*VATEN/16.D0

      FI    = FI   + REDM*GSNN*(VAFI-FAC1*VAFI1/4D0)*DSQRT(DIV)
      DFI   = DFI  + REDM*GSNN*(DVAFI-FAC1*DVAF1/4D0)*DSQRT(DIV)*PIM
      FISO  = FISO + 0.5D0*REDM*GSNN*FAC1*VASO0*DSQRT(DIV)
      DFISO = DFISO+ 0.5D0*REDM*GSNN*FAC1*DVASO0*DSQRT(DIV)*PIM
      FISO2 = FISO2+ REDM*GSNN*FAC1**2*3*X2*VATEN*DSQRT(DIV)/16.D0
      DFISO2= DFISO2+REDM*GSNN*FAC1**2*3*X2*(DVATN-2*X1*VATEN)*
     .               DSQRT(DIV)*PIM/16.D0

      FITL  = FITL + .25D0*REDM*GSNN*VAFI*DIV
      DFITL = DFITL+ .25D0*REDM*GSNN*DVAFI*DIV*PIM
      ENDIF
C     END AUGUST 1998.
C-----------------------------------------------------------------
C
      if(xa.lt.0.d0) then
c     if(in.eq.4.and.mod(icall,20).eq.2) then
      write(6,*) 'ssssssssssssssssssssssssssssssssssssssssssssssss'
      write(6,*) 'scalar98: in,ames=',in,amsc(in),' x=',xa,
     .' corr=',corr
      write(6,*) ' vafi ,dvafi =',vafi,dvafi
      write(6,*) 'd2vafi,d3vafi=',d2vafi,d3vafi
      write(6,*) ' vafi1,dvaf1 =',vafi1,dvaf1
      write(6,*) ' vaten,dvatn =',vaten,dvatn
      write(6,*) ' vaso0,dvaso0=',vaso0,dvaso0
      write(6,*) ' vc   ,vtlc  =',vc,vtlc
      write(6,*) ' vso  ,vso2  =',vso ,vso2
      write(6,*) ' vtlo ,vtlo2 =',vtlo,vtlo2
      write(6,*) ' fi   ,dfi   =',fi,dfi
      write(6,*) ' fitl ,dfitl =',fitl,dfitl
      write(6,*) ' fiso ,dfiso =',fiso ,dfiso
      write(6,*) ' fiso2,dfiso2=',fiso2,dfiso2
      endif
 1040 CONTINUE
C
      RETURN
      END
C**********************************************************************
C
      SUBROUTINE SCALR2(XA,FACISO,ISCL)
C
C**********************************************************************
C
C     HEAVY SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/SCCOP2/GDEL2,GEPS2,GSST2
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,TLAB
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      DIMENSION AMSC(4),FSC(4)
      DATA SRPI/1.7724538509D0/
      DATA AMEP2/1370.D0/,AMST2/1515.D0/,AMDEL2/1450.D0/
c*   .,AMKSC2/1430.D0/
C
C   NOTE : EPS2(IN=1)
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     ALM1 = ALMS0
c     alm1 = 1500.d0
      DIV =1.D0/(AM*AMY)
C
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  GSNN= FACISO*GDEL2
      FSC(1)=1.D0
      AMSC(1)=AMDEL2
      ALM1 = ALMS1
      GOTO 1055
1052  GSNN= GEPS2
      FSC(2)=1.D0
      AMSC(2)=AMEP2
      ALM1 = ALMS0
      GOTO 1055
1053  GSNN= GSST2
      FSC(3)=1.D0
      AMSC(3)=AMST2
      ALM1 = ALMS1
      GOTO 1055
1055  XLAM1=0.5D0*XA*ALM1/PIM
      VKUNN=(ALM1/AMSC(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
      FAC1=AMSC(IN)**2*DIV
      RATM1=AMSC(IN)/ALM1
      AMSC2=AMSC(IN)*AMSC(IN)
      AMSC3=AMSC(IN)*AMSC2
      AMSC5=AMSC2*AMSC3
C
      X =(AMSC(IN)/PIM)*XA
      EX=FDEXP(X)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FSC(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMSC(IN)
      FSO  = FSC(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC3*DIV
      FSO2 = 3*FSC(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMSC5*
     .       DIV*DIV/(X*X)
      FC1  = FC0  - FSC(IN)*VKUNN*AMSC(IN)
      FDFI = FSO  * X /AMSC(IN)
C
      VC       = VC        - GSNN*(FC0-0.25D0*FAC1*FC1)
      VSO      = VSO       - 0.5D0*GSNN*FSO
      VSO2     = VSO2      - GSNN*FSO2/16.D0
      FI       = FI        + 0.5D0*REDM*GSNN*FC0*DIV
      DFI      = DFI       - 0.5D0*REDM*GSNN*FDFI
C
C-------------------------------------------------------------------
      if(xa.le.-1.d0) then
c     if(xa.ge.0.5d0.and.xa.lt.1.d0) then
c     if(in.eq.4.and.mod(icall,20).eq.2) then
      write(6,*) 'ssssssssssssssssssssssssssssssssssssssssssssssss'
      if(in.eq.1)write(6,*) ' gdel2,geps2,gsst2=',gdel2,geps2,gsst2
      write(6,*) 'scalr2: in,ames=',in,amsc(in),' x=',xa
      write(6,*) ' vc ,vso  ,vso2  =',vc,vso ,vso2
      write(6,*) ' fi   ,dfi   =',fi,dfi
      endif
C-------------------------------------------------------------------
 1040 CONTINUE
C
      RETURN
      END


C**********************************************************************
C
      SUBROUTINE DIFRAC08(X,FACISO,NAOBE,CORR)
C
C**********************************************************************
C     VERSION 2004: POMERON(=SINGLET) + J=0 DIFFRACTIVE NONET: A2,F2,FP2
C**********************************************************************
C
C     DIFFRACTIVES  : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     VERSION AUGUST 1998: RETARDATION IN OBE, SEE NON-LOCAL 
C     FUNCTIONS FROM 1/OMEGA(OMEGA+A)-PROPAGATOR.
C
C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
      COMMON/DIFCOP/GPOM2,GA22,GF22,GF2P2
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN     ! JAN 2013
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      COMMON/PRMTRS/PAR(20,8)
      DIMENSION AMDF(5),FDC(5)
      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2796D0/
C
C   NOTE : POM(IN=1),A2(IN=2),F2(IN=3),F2P(IN=4)           
C
      DIV=1.D0/(AM*AMY)
      FI51 = PAR(19,5)
      AMFI51=PAR(17,5)
      IF(AMFI51.EQ.0D0) AMFI51=AMPOM
C
      DO 1040 IN=1,5
      GOTO(1050,1051,1052,1053,1054),IN
c                                  ! NEW TREATMENT FI51 MARIUS
1050  GDNN=  GPOM2
      FDC(IN)=1.D0
      AMDF(IN)=AMFI51
      GDNN= FI51*GDNN
      GOTO 1056
1051  GDNN=  GPOM2
      FDC(IN)=1.D0
      AMDF(IN)=AMPOM
      GDNN= (1.0D0-FI51)*GDNN
      GOTO 1056
1052  GDNN= FACISO*GA22
      FDC(IN)=1.D0
      AMDF(IN)=AMA2
      GOTO 1056
1053  GDNN=  GF22  
      FDC(IN)=1.D0
      AMDF(IN)=AMPOM
      GOTO 1056
1054  GDNN=  GF2P2
      FDC(IN)=1.D0
      AMDF(IN)=AMPOM
C
1056  AMDF2=AMDF(IN)*AMDF(IN)
      FAC1=AMDF2/(AM*AMY)
      FAC12=FAC1*FAC1
c*    FNNDF=4*GDNN*AMDF2/(SRPI*AM*AMY)
      FNNDF=4*GDNN*AMDF2/(SRPI*AMPRO*AMPRO)
      AMU = AMDF(IN)/PIM
C
      XA =(AMDF(IN)/PIM)*X
      XA2=XA*XA
      VGSSX=AMDF(IN)*FDEXP(-XA2)
      FC=1.D0+AMDF2*(3.D0-2*XA2)/(2*AM*AMY)
C
      VC       = VC        + FNNDF*FC*VGSSX
C
      VSO      = VSO       + FAC1*FNNDF*VGSSX
C
      VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
      FI       = FI        - 0.5D0*REDM*FNNDF*VGSSX/(AM*AMY)
C
      DFI      = DFI       + 1.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
     .                       /(AM*AMY)
      DDFI     = DDFI      - 0.5D0*REDM*FNNDF*VGSSX*         ! JAN 2013
     .           (4*(AMDF(IN)*XA)**2-2*AMDF(IN)**2)/(AM*AMY)

C     AUGUST 1998 ADDITIONS:
      IF(NAOBE.EQ.1) THEN
      X1   = 1.d0/X
      X2   = X1*X1
      FAC1 = FAC1*(PIM/AMDF(IN))**2
      FAC12= FAC1*FAC1
      VARFI0 = CORR*FDEXP(-XA2)/SRPI
      VARFI1 = -2*XA*VARFI0*AMU          
      VARFI2 = -2*(AMU*VARFI0+XA*VARFI1)*AMU          
      VARFI3 = -2*(2*AMU*VARFI1+XA*VARFI2)*AMU          

      VACEN1 = (VARFI2+2*X1*VARFI1)
      VATEN  = (VARFI2-X1*VARFI1)/3.D0
      DVACN1 = (VARFI3+2*X1*VARFI2-2*X2*VARFI1)
      DVATN  = (VARFI3-X1*VARFI2+X2*VARFI1)/3.D0
      VASO0  = -X1*VARFI1
      DVASO0 = -X1*(VARFI2+VASO0)

      VTLC   = VTLC  + 0.5D0*FNNDF*(VARFI0-FAC1*VACEN1/4D0)
      VTLO   = VTLO  + 0.25D0*FNNDF*FAC1*VASO0     
      VTLO2  = VTLO2 + 0.5D0*FNNDF*FAC12*3*X2*VATEN/16D0

      FI     = FI    - REDM*FNNDF*(VARFI0-FAC1*VACEN1/4D0)
     .                 *DSQRT(DIV)
      DFI    = DFI   - REDM*FNNDF*(VARFI1-FAC1*DVACN1/4D0)
     .                 *DSQRT(DIV)*PIM
      FISO   = FISO  - 0.5D0*REDM*FNNDF*FAC1*VASO0*DSQRT(DIV)
      DFISO  = DFISO - 0.5D0*REDM*FNNDF*FAC1*DVASO0*DSQRT(DIV)*PIM   
      FISO2  = FISO2 - REDM*FNNDF*FAC12*X2*3*VATEN*DSQRT(DIV)/16D0
      DFISO2 = DFISO2- REDM*FNNDF*FAC12*X2*3*(DVATN-2*X1*VATEN)*
     .                 DSQRT(DIV)*PIM/16.D0

      FITL   = FITL  - .25D0*REDM*FNNDF*VARFI0*DIV
      DFITL  = DFITL - .25D0*REDM*FNNDF*VARFI1*DIV*PIM
      ENDIF

      if(xa.lt.0.d0) then
c     if(in.eq.3.and.mod(icall,20).eq.2) then
      write(*,*) 'dddddddddddddddddddddddddddddddddddddddddd'
      write(*,*) ' difrac98: in,ames=',in,amdf(in),' x=',x,
     .' corr=',corr     
      write(*,*) 'varfi0,varfi1=',varfi0,varfi1
      write(*,*) 'varfi2,varfi3=',varfi2,varfi3
      write(*,*) 'fac1  ,vacen1=',fac1,vacen1
      write(*,*) ' vc   ,vtlc  =',vc,vtlc 
      write(*,*) ' vtlo ,vtlo2 =',vtlo,vtlo2 
      write(*,*) ' fi   ,dfi   =',fi,dfi
      write(*,*) ' fiso ,dfiso =',fiso,dfiso
      write(*,*) ' fiso2,dfiso2=',fiso2,dfiso2
      write(*,*) ' fitl ,dfitl =',fitl,dfitl
      endif

C
C     ASSUMING S/S0-FACTOR -> 1 + P**2/M**2
C
C     FC=1.D0+AMDF2*(3.D0-2*XA2)/(4*AM*AMY)
C
C     VC       = VC        + FNNDF*FC*VGSSX
C
C     VSO      = VSO       + FAC1*FNNDF*VGSSX
C
C     VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
C     FI       = FI        + 1.D00*REDM*FNNDF*VGSSX/(AM*AMY)
C
C     DFI      = DFI       - 2.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
C    .                       /(AM*AMY)
 1040 CONTINUE
C
C     HEAVY(HARD) POMERON:
      CALL HDIFRAC(X,FACISO,NAOBE,CORR)
      RETURN
      END

C**********************************************************************
      SUBROUTINE HDIFRAC(X,FACISO,NAOBE,CORR)
C**********************************************************************
C     VERSION 2009: HEAVY(HARD) POMERON(=SINGLET) 
C**********************************************************************
C
C     DIFFRACTIVES  : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL*8(A-H,O-Z)
c*    COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
c*    COMMON/DIFCOP/GPOM2,GA22,GF22,GF2P2
      COMMON/PRMTRS/PAR(20,8)
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,IXXX(6)
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPE,IPIME
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN     ! JAN 2013
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      DIMENSION AMDF(4),FDC(4)
      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AKAPP/0D0/
      DATA ITYPH/3/,AMPOMH/600D0/,AMPRO/938.2796D0/
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   NOTE : HPOM(IN=1),HA2(IN=2),HF2(IN=3),HF2P(IN=4)           
C
      RATAMY= DSQRT(AM*AMY)/AMPRO
      AMPOMH = PAR(14,6)
      GPOMH = PAR(13,6)
      FPOMH = PAR(12,6)
      IF(FPOMH.EQ.0D0) FPOMH = -GPOMH
      IF(GPOMH.NE.0D0) AKAPP = FPOMH/GPOMH
      DIV=1.D0/(AM*AMY)
      DO 1040 IN=1,1
      GOTO(1051,1052,1053,1054),IN
1051  GDNN= GPOMH*GPOMH
      IF(PAR(13,6).LT.0D0) GDNN = -GDNN   
      IF(IDIF.EQ.3) THEN
      CNNDC= 1D0              
      CNNDS= (1D0+AKAPP*RATAMY)**2
      CNNDT= CNNDS        
      CNNDO= 3D0+2*AKAPP*RATAMY                 
      CNNDQ= 1D0+8*AKAPP*RATAMY+8*(AKAPP*RATAMY)**2
      ENDIF
      FDC(1)=1.D0
      AMDF(1)=AMPOMH
      GOTO 1056
1052  RETURN    
1053  RETURN    
1054  RETURN    
C
1056  AMDF2=AMDF(IN)*AMDF(IN)
      FAC1=AMDF2/(AM*AMY)
      FAC12=FAC1*FAC1
c*    FNNDF=4*GDNN*AMDF2/(SRPI*AM*AMY)
      FNNDF=4*GDNN*AMDF2/(SRPI*AMPRO**2)
      AMU = AMDF(IN)/PIM
      FAC0= AMDF2/(AMPRO*AMPRO)
C
      XA =(AMDF(IN)/PIM)*X
      XA2=XA*XA
      VGSSX=AMDF(IN)*FDEXP(-XA2)
C--------------------------------------------------------------
C     POMERON: P=C=+1
C--------------------------------------------------------------
      IF(IDIF.EQ.1) THEN
      FC=1.D0+AMDF2*(3.D0-2*XA2)/(2*AM*AMY)
C
      VC       = VC        + FNNDF*FC*VGSSX
C
      VSO      = VSO       + FAC1*FNNDF*VGSSX
C
      VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
      FI       = FI        - 0.5D0*REDM*FNNDF*VGSSX/(AM*AMY)
C
      DFI      = DFI       + 1.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
     .                       /(AM*AMY)
      DDFI     = DDFI      - 0.5D0*REDM*FNNDF*VGSSX*         ! JAN 2013
     .           (4*(AMDF(IN)*XA)**2-2*AMDF(IN)**2)/(AM*AMY)
      ENDIF
C--------------------------------------------------------------
C     ODDERON: P=C=-1
C--------------------------------------------------------------
      IF(IDIF.EQ.2) THEN
      FC1= FAC1*(3.D0-2*XA2)
      VC = VC + FNNDF*FC1*VGSSX
      ENDIF     
C--------------------------------------------------------------
C     ADDITIONS AUGUST 29, 2007:
C--------------------------------------------------------------
      IF(IDIF.EQ.3) THEN
      FC1   = FAC0*(3.D0-2*XA2)
      FC2   = FAC0*(15D0-20*XA2+4*XA2*XA2)
      FC2 = 0D0         ! NO K^4-TERMS, APR2009
C     FC2   = FAC0*(15D0-20*XA2+4*XA2*XA2)
      FTNN1 = FAC0*XA2*(7D0-2*XA2)
      FONN1 = FAC0*(5D0-2*XA2)
      FO2NN1= FAC0*(7D0-2*XA2)
      DFC1  = -2*XA*AMDF(IN)*FAC0*(5D0-2*XA2)  ! ADDED FEB2009
      DDFC1 = -2*AMDF(IN)**2*FAC0*(5D0-16*XA2+4*XA2*XA2) ! JAN 2013
C     POTENTIALS:
      VC    = VC   + FNNDF*CNNDC*FC1*VGSSX*2D0
     .             - FNNDF*CNNDC*FC2*VGSSX*FAC1*2D0    ! ADDED FEB2009
      VSIG  = VSIG - FNNDF*CNNDS*FC2*VGSSX*FAC1*2/3D0 
      VTEN  = VTEN - FNNDF*CNNDT*FTNN1*VGSSX*FAC1*2/3D0
      VSO   = VSO  - FNNDF*CNNDO*FONN1*VGSSX*FAC1*2D0
      VSO2  = VSO2 + FNNDF*CNNDQ*FO2NN1*VGSSX*FAC1**2/2
C     NON-LOCAL POTENTIALS:      ADDED FEB2009
      FI    = FI   + 4*0.75D0*FNNDF*REDM*FC1*VGSSX/(AM*AMY)
      DFI   = DFI  + 4*0.75D0*FNNDF*REDM*DFC1*VGSSX/(AM*AMY)
      DDFI  = DDFI + 4*0.75D0*FNNDF*REDM*DDFC1*VGSSX/(AM*AMY) ! JAN 2013
      ENDIF

 1040 CONTINUE
C
      RETURN
      END



C**********************************************************************
C
      SUBROUTINE TENSOR(XA,FACISO,INRS)
C
C**********************************************************************

C
C     TENSOR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     VERSION: 8 NOVEMBER 1995
C
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/TENCOP/GT12,GT62,GT92,FT12,FT62,FT92,GFT1,GFT6,GFT9
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      DIMENSION AMTS(3),FTS(3)
      DATA SRPI/1.772454D0/,AMPRO/938.2592D0/
      DATA AMTS/1310.4D0,1272.9D0,1520.4D0/
C
C   NOTE : A2(IN=1),F(IN=2),FP(IN=3)
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
      XM1=AM
      XM2=AMY
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  GDNN = FACISO*GT12
      GDFNN= FACISO*GFT1
      GFDNN= FACISO*GFT1
      GFNN = FACISO*FT12
      ALM1 = ALMV1
      FTS(1)=1.D0
      GOTO 1055
1052  GDNN =  GT62
      GDFNN=  GFT6
      GFDNN=  GFT6
      GFNN =  FT62
      ALM1 = ALMV0
      FTS(2)=1.D0
      GOTO 1055
1053  GDNN =  GT92
      GDFNN=  GFT9
      GFDNN=  GFT9
      GFNN =  FT92
      ALM1 = ALMV0
      FTS(3)=1.D0
C
1055  RATM1=AMTS(IN)/ALM1
      FAC0=AMTS(IN)*AMTS(IN)/AMPRO/AMPRO
      FAC1=AMTS(IN)*AMTS(IN)/(XM1*XM2)
C
      CCNN1=-FAC1*(5*GDNN/6.D0+(GFDNN+GDFNN)*DSQRT(XM1*XM2)
     .       /6.D0/AMPRO)
      CSNN1=-FAC1*(GDNN*AMPRO+GFDNN*XM1+GDFNN*XM2+GFNN*XM1*XM2/AMPRO)
     .       /AMPRO/12.D0
      CTNN0=-1.50D0*CSNN1
      CONN0= FAC1*(5*GDNN/3.D0+(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO )
      CO2NN=-FAC1**2*(7*GDNN/6.D0+2*(GDFNN+GFDNN)*DSQRT(XM1*XM2)/AMPRO
     +      +3*GFNN*XM1*XM2/AMPRO/AMPRO)/4.D0
      FINN0=-(11*GDNN/3.D0)
C
      XLAM1=0.5D0*XA*ALM1/PIM
      X =(AMTS(IN)/PIM)*XA
      EX=FDEXP(X)
      VKUNN=(ALM1/AMTS(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FTS(IN)*FF0(EXPM,EX,X,DERFCM,DERFCP)*AMTS(IN)
      FTEN = FTS(IN)*FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN)
      FSO  = FTS(IN)*FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMTS(IN)
      FSO2 = 3*FTEN/(X*X)
C
      FC1  = FC0  - FTS(IN)*VKUNN*AMTS(IN)
      FC2  = FC1  + FTS(IN)*(1.5D0-XLAM1*XLAM1)
     .            * VKUNN*AMTS(IN)/RATM1/RATM1
      FT1  = FTEN - FTS(IN)*XLAM1*XLAM1*VKUNN*AMTS(IN)
     .                / (3*RATM1*RATM1)
      FO1  = FSO  - FTS(IN)*VKUNN*AMTS(IN)
     .                / (2*RATM1*RATM1)
C
      VC       = VC    -  2*GDNN*FC0/3.D0 + CCNN1*FC1
     .                    -GFNN*FAC0*FAC1*FC2/32.D0
     .                    +GFNN*FAC0*FAC1*FC2/48.D0
      VSIG     = VSIG  +  CSNN1*FC1
     .                    -INRS*GFNN*FAC0*FC2/8.D0*FAC1/12.D0
      VTEN     = VTEN  +  CTNN0*FTEN
     .                    +INRS*GFNN*FAC0*FT1/8.D0*FAC1/8.D0
      VSO      = VSO   +  CONN0*FSO
     .                    +3*GFNN*FAC0*FO1*FAC1/16.D0
      VSO2     = VSO2  +  CO2NN*FSO2

      FI       = FI    +  REDM*FINN0*FC0/(XM1*XM1)
      DFI      = DFI   -  REDM*FINN0*FSO*X*FAC1/AMTS(IN)
C
 1040 CONTINUE
C
      RETURN
      END

C **********************************************************************
      SUBROUTINE TPEFF(X,ISPIN,ALAM)
C **********************************************************************
C *
C *   BASED ON SCHWINGER-WEINBERG INTERACTIONS (CHIRAL-SYMMETRY)
C *
c     UPDATED 28/6/95, 11/9/95, 4/10/95

c     IPV = 1 : PV-THEORY,  = 0 : PS-THEORY.
c     INA = 1 : NON-ADIABATIC 1/M-TERMS: YES
c     IOFF= 1 : OF-ENERGY-SHELL 1/M-TERMS: YES
c
c     IVIN= 1 : Vincent's choice
c
c     IBW = 0 , BW-POTENTIAL : NO
c         = 1 ,     ,,       : ADIABATIC
c         = 2 ,     ,,       : NON-ADIABATIC +1/AMN
c         = 3 ,     ,,       : TOTAL= ADIABATIC + NON-ADIABATIC
c
c    ITMO = 0 , TMO-POTENTIAL : NO
c         = 1 ,      ,,       : NON-ADIABATIC 1/AMN
c         = 2 ,      ,,       : NON-ADIABATIC 1/AMN**2
c         = 3 ,      ,,       : TOTAL= ADIABATIC + NON-ADIABATIC
c
c    NUMERICAL INTEGRATION METHOD: IMETH=0 -> FINITE INTERVALS
c                                       =1 -> HYPERBOLIC MAP
c
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 ISFAC,ISFPA,ISFCR
      COMMON/TWOMES/IBW,ITMO,IDAM
      COMMON/PSCOP/ALP,APV,FPI,F62,F92,F120,F12C,FCHPI
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FUI,DFUI,FUISS,DFUISS,
     .FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
      COMMON/ALLIN/ PIM,AMP,AMY,ALLX(6)
      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      DIMENSION XX(20),WW(20),YB(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,PIMC/139.57D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      DATA IMETH/1/,YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,NT/1/
c*    DATA IBW/3/,ITMO/0/,ICALL/0/,NSCHR/0/
c*    DATA IBW/3/,ITMO/3/,ICALL/0/,NSCHR/0/
      DATA ICALL/0/,NSCHR/0/
      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
      AMN=DSQRT(AMP*AMY)
      ALAMP=ALAM
      FP = FPI*(PIM/PIMC)
      FP2=FP*FP
      FP4=FP2*FP2
      IF(ICALL.EQ.0) THEN
        YLH=YB(2)
        CALL GAUSS(NPNT,XX,WW,NT)
        IF(NSCHR.NE.0) write(6,51) IBW,ITMO,INA,IPV,IOFF,IVINC,FPI,APV
 51     FORMAT(//,' TWO-PION-EXCHANGE PARAMETERS : IBW=',I2,
     .  '  ITMO=',I2,' INA=',I2,' IPV=',I2,' IOFF=',I2,' IVINC=',I2,/,
     .  31X,' FPI=',F10.3,'  APV=',F10.3,//)
        IF(IMETH.EQ.1) NINT=1
c       ICALL=1
      ENDIF
      IISFAC=4*ISPIN-3
      ISFAC =4*ISPIN-3
      ISFPA =3-2*ISFAC
      ISFCR =3+2*ISFAC
CC
CC    CHARGE SYMMETRY BREAKING : ( THIS HAS TO BE CHECKED !)
C     I3=1-NP
C     I32=I3*I3
C     FP0 = GP0*PIM/(2*AMN)
C     FPC = GPC*PIM/(2*AMN)
C     FP02= FP0*FP0/FP2
C     FPC2= FPC*FPC/FP2
C     FP04 =FP02*FP02
C     FPC4 =FPC2*FPC2
C     ISFPA=I32*FP04+(1-I32)*(4*FPC4+FP04)-2*(IISFAC+1-2*I32)*FP02*FPC2
C     ISFCR=I32*(FP04+4*FPC4)+(1-I32)*FP04+2*(IISFAC+1-2*I32)*FP02*FPC2
C     ISFAC=( - ISFPA + ISFCR )/4
CC
      X1   =1.D0/X
      X2   =X1*X1
      X3   =X1*X2
      X4   =X1*X3
CC
      RATP =PIM/ALAM
      RATA2=ALAM*ALAM/PIM/PIM
      ERATP=DEXP(RATP*RATP)
      XLAM =0.5D0*X/RATP
      EXPI =DEXP(X)
      EMPI =FDERFC(-XLAM+RATP)
      EPPI =FDERFC( XLAM+RATP)
      XLAM2=XLAM*XLAM
      VKU  =(ALAM/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKU =-0.5D0*RATA2*X*VKU
      DDVKU=-0.5D0*RATA2*(VKU+X*DVKU)
      D3VKU=-0.5D0*RATA2*(2*DVKU+X*DDVKU)
C     DDVKU=-0.5D0*RATA2*(1.D0-0.5D0*RATA2*X*X)*VKU
C     D3VKU=-0.5D0*RATA2*((1.D0-0.5D0*RATA2*X*X)*DVKU-RATA2*X*VKU)
C
C
      FI   =F0(ERATP,EXPI,EMPI,EPPI,X)
      HI   =H0(ERATP,EXPI,EMPI,EPPI,X)
      DFI  =-(FI-2*VKU)*X1-HI
      DHI  =-FI-HI*X1
      DDFI =-(DFI-2*DVKU)*X1+(FI-2*VKU)*X2-DHI
      DDHI =-DFI-DHI*X1+HI*X2
      D3FI =+( DFI-2* DVKU)*X2-2*( FI-2* VKU)*X3-DDHI
     .      -(DDFI-2*DDVKU)*X1+  (DFI-2*DVKU)*X2
      D3HI =-DDFI-DDHI*X1+2*DHI*X2-2*HI*X3
      D4FI =+3*(DDFI-2*DDVKU)*X2-6*(DFI-2*DVKU)*X3-D3HI
     .      -(D3FI-2*D3VKU)*X1  +6*( FI-2* VKU)*X4
C
C     DMDF =-( (0.D0-2*RATP*RATP)* DFI +  HI +X* DHI )
C     DMDDF=-( (0.D0-2*RATP*RATP)*DDFI+2*DHI +X*DDHI )
C     DMD3F=-( (0.D0-2*RATP*RATP)*D3FI+3*DDHI+X*D3HI )
C
C     FINT41= -0.5D0*DMDF+RATP*RATP*DFI
C     FINT42= -0.5D0*DMDDF+RATP*RATP*DDFI
C     FINT43= -0.5D0*DMD3F+RATP*RATP*D3FI
      FINT41= -0.5D0*X*FI
      FINT42= +0.5D0*X*HI-VKU
      FINT43= -0.5D0*X*FI+XLAM*VKU/RATP
C
C
C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION
C
C     GAUSSIAN-INTEGRATION :
      FIBW1 =0.D0
      FIBW2 =0.D0
      FIBW31=0.D0
      FIBW32=0.D0
      FIBW41=0.D0
      FIBW42=0.D0
      FINT31=0.D0
      FINT32=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. :
      FDISP=FDEXP(-Y*Y*RATP*RATP)
      Y2  = 1.D0/Y/Y
C
      AM=PIM*DSQRT(1.D0+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*VKU )*X1-(AM/PIM)*HIM
      DHIM  =-(AM/PIM)*FIM-HIM*X1
      DDFIM =-(DFIM-2*DVKU )*X1+(FIM-2*VKU )*X2-(AM/PIM)*DHIM
      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2
      D3FIM =+(DFIM-2* DVKU)*X2-2*(FIM-2* VKU)*X3-(AM/PIM)*DDHIM
     .       -(DDFIM-2*DDVKU)*X1+  (DFIM-2*DVKU)*X2
      D3HIM =-(AM/PIM)*DDFIM-DDHIM*X1+2*DHIM*X2-2*HIM*X3
      D4FIM =+3*(DDFIM-2*DDVKU)*X2-6*(DFIM-2*DVKU)*X3-(AM/PIM)*D3HIM
     .       -(D3FIM-2*D3VKU)*X1  +6*(FIM-2* VKU)*X4
C
C
      DF    = DFI - DFIM  *FDISP
      DDF   = DDFI- DDFIM *FDISP
      DG    = DFI
      DDG   = DDFI
C
      FIBW1 = FIBW1  + GEW*(2*DF*DG*X2 + DDF*DDG)*Y2
C
      FIBW41= FIBW41 + GEW*DF*DG*Y2
      FIBW42= FIBW42 + GEW*((DF*X1-DDF)*DG+DF*(DG*X1-DDG))*Y2
C
      FINT31= FINT31 + GEW* DF*Y2
      FINT32= FINT32 + GEW*DDF*Y2
C
      DG    = DFIM   *FDISP
      DDG   = DDFIM  *FDISP
      FIBW2 = FIBW2  + GEW*(2*DF*DG*X2 + DDF*DDG)*Y2
C
      FIBW31= FIBW31 + GEW*DF*DG*Y2
      FIBW32= FIBW32 + GEW*((DF*X1-DDF)*DG+DF*(DG*X1-DDG))*Y2
110   CONTINUE
100   CONTINUE
C
      FACT   = FP4*PIM
      VCA   =0.D0
      VSIGA =0.D0
      VTENA =0.D0
      VSOA  =0.D0
      VSO2A =0.D0
      VCN   =0.D0
      VSIGN =0.D0
      VTENN =0.D0
      VSON  =0.D0
      VSO2N =0.D0
C
C     BRUECKNER-WATSON GRAPHS POTENTIALS WITH FORM FACTOR :
C
C 1)  ADIABATIC CONTRIBUTIONS:
C
      IF(IBW.EQ.1.OR.IBW.EQ.3) THEN
      VCA   = - FACT*( 3*FIBW1 + 2*ISFAC*FIBW2)
      VSIGA = - FACT*( 6*FIBW31*X1 - 2*FIBW32
     .        + 4*ISFAC*(FIBW41*X1 - FIBW42/3.D0) )*X1
      VTENA = - FACT*( FIBW32  + 2*ISFAC*FIBW42/3.D0)*X1
      ENDIF
C
C 2)  ADIABATIC 1/AMN CONTRIBUTIONS (PV-THEORY ONLY):
C
      IF(IPV.EQ.1.AND.(IBW.EQ.2.OR.IBW.EQ.3)) THEN
      VCN   =   VCN+ APV*FACT*ISFCR*(PIM/AMN)*
     .          (DFI - RATA2*DVKU)*DFI
      VSON  =   VSON+ APV*2*FACT*ISFCR*(PIM/AMN)*
     .          ( DFI*X1+DDFI)*DFI*X1
      ENDIF
C
C 3)  NON-ADIABATIC CONTRIBUTIONS:
C
      IF(INA.EQ.1.AND.(IBW.EQ.2.OR.IBW.EQ.3)) THEN
      VCN   =   VCN+ FACT*ISFCR*(PIM/AMN)*
     .          ( 6*X2*( X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .           D3FI*FINT43 )
      VSIGN =   VSIGN -FACT*ISFCR*(2*PIM/AMN/3)*
     .          ( X2*( X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .            X1*( X1*DFI-DDFI)*FINT43 +
     .            X1*( X1*FINT41-FINT42)*D3FI )
      VTENN =   VTENN +FACT*ISFCR*(PIM/AMN/3)*
     .          ( 4*X2*( X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .            X1*( X1*DFI-DDFI)*FINT43 +
     .            X1*( X1*FINT41-FINT42)*D3FI )
C     VSON  =   VSON + FACT*ISFPA*(PIM/AMN)*X2*(X1*FINT31-FINT32)**2
      ENDIF
C
C     T.M.O. GRAPHS POTENTIALS WITH FORM FACTOR :
C
C 1)  ADIABATIC CONTRIBUTIONS:
C
      IF(ITMO.EQ.1.OR.ITMO.EQ.3) THEN
      VCA   = VCA  + FACT*ISFPA*(2*X2*DFI*FINT31+DDFI*FINT32)
      VSIGA = VSIGA- FACT*ISFPA*(X1*DFI*FINT31+DDFI*FINT31+
     .                           DFI*FINT32)*X1*(2.D0/3.D0)
      VTENA = VTENA- FACT*ISFPA*(X1*DFI*(X1*FINT31-FINT32)+
     .                    X1*FINT31*(X1*DFI-DDFI) )/3.D0
      ENDIF
C
C 2)  OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS (28/6/95):
C
      IF(IVINC.NE.1) THEN
      IF(IOFF.EQ.1.AND.(ITMO.EQ.2.OR.ITMO.EQ.3)) THEN
      VCN   = VCN  + (2*APV-1)*FACT*ISFPA*(PIM/AMN/2)*
     .               ( DFI-RATA2*DVKU)*DFI
      VSON  = VSON - (2*APV-1)*FACT*ISFPA*(PIM/AMN)*
     .               X1*DFI*( X1*DFI-DDFI)
      ENDIF
      ENDIF
C
C 3)  NON-ADIABATIC 1/AMN CONTRIBUTIONS:
C
      IF(INA.EQ.1.AND.(ITMO.EQ.2.OR.ITMO.EQ.3)) THEN
      VCN   = VCN  - FACT*ISFPA*(PIM/AMN/2)*
     .               ( 6*X2*(X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .                D3FI*FINT43 )
      VSIGN = VSIGN- FACT*ISFPA*(PIM/AMN/2)*
     .               ( X2*(X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .                (X1*DFI-DDFI)*X1*FINT43+
     .                X1*D3FI*(X1*FINT41-FINT42) )*(2.D0/3.D0)
      VTENN = VTENN+ FACT*ISFPA*(PIM/AMN/2)*
     .               ( 4*X2*(X1*DFI-DDFI)*(X1*FINT41-FINT42)+
     .                (X1*DFI-DDFI)*X1*FINT43+
     .                X1*D3FI*(X1*FINT41-FINT42) )/3.D0
      IF(IVINC.NE.1) THEN
      VSON  =   VSON- 2*FACT*ISFPA*(PIM/AMN)*X2*
     .                (X1*DFI-DDFI)*(X1*FINT41-FINT42)
      ENDIF
      ENDIF

      VC   = VCA   + VCN
      VSIG = VSIGA + VSIGN
      VTEN = VTENA + VTENN
      VSO  = VSOA  + VSON
C
C     THE B.W. POTENTIAL SEE: PHYS. REV. 92, P. 1023 (1953)
C
C     THE T.M.O POTENTIAL SEE: PROGR.THEOR.PHYS. 7,P.45 (1952)
C
C     FOR LITERATURE ON THE TWO-PION AND RESUME SEE :
C     MORAVCIK & NOYES, ANN.REV.NUCL.SCI. 11,P.95 (1961) !!!
C
c1000  CONTINUE
      if(icall.eq.0.and.nschr.eq.1) then
      write(6,*) '****************************************************'
      write(6,1001) x,ispin
1001  format(' TPEFF: TWO-PION EXCHANGE POTENTIALS: x=',f7.3,
     .' ISPIN=',i2,/)
      write(6,1002) vca,vsiga,vcn,vsign
1002  format(' ADIABATIC: VC=',F10.3,' VSIG=',F10.3,/
     .' 1/M-TERMS: VC=',F10.3,' VSIG=',F10.3)
      write(6,*) '****************************************************'
      endif
      ICALL=1
      RETURN
      END

C **********************************************************************
      SUBROUTINE NNPIPI(X,ISPIN,I3,ALMP8)
C **********************************************************************
C     VERSION FOR INCLUSION CHARGE INDEPENDENCE ETC. BREAKING
C     CHECKED FOR AMPS1=PIM, AMPS2=PIM-> RESULTS FOR PAR(5,1)=0.d0
C **********************************************************************
C     VERSION WITH OPTIONAL "TMO" (AUGUST 1998)
C
C     ITMO = 0 : NO TMO, ITMO > 0 : YES TMO
C *
C *   DATE: VERSION: APRIL 2000
C     INCLUDED: 1) PI0-PI0, PI0-PC, PC-PC (C= +/-)
C
C     IPV = 1 : PV-THEORY,  IPV = 0 : PS-THEORY!
C     INA = 1 : NON-ADIABATIC 1/AMN CONTRIBUTIONS INCLUDED
C     IOFF= 1 : PIONIC OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS INCLUDED

C **********************************************************************
C     CALL PHBFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN): TMO + BW
C     CALL BWFUN (KIND,X,AM1,AM2,ALM1,ALM2,FUN): NO TMO, ONLY BW
C
C     KIND=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     FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 FUN(10)= OPAEMO2
C     FUN(11)= OCREES  FUN(12)= OCREET
C     KIND=2, PION-SCALAR EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C     KIND=4, PION-DIFFRACTIVE EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C **********************************************************************
C
C     (i) Included in ENERGY-DENOMINATORS:
C         L+R contributions included, 1/4 -> 1/2, the latter is
C         put in PHBFUN
C     (ii) Included in OPERATOR DEFINITIONS of PHBFUN:
C          1 <-> 2 interchange effects for non-identical mesons.
C     (iii) Included in CPANN etc.:
C           for IDENTICAL particles 1/2
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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPE,IPIME
      COMMON/PSCOP/ALP,APV,FPI,FP62,FP92,F12DUM(2),FCHPI

      COMMON/ALLPS/PIM0,PIMC,AME,AMX

      COMMON/TWOMES/IBW,ITMO,IDAM
      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/BWOMS/BNONC,BNONS,BNONT,BNONO,BPVC,BPVS,BPVT,BPVO
     .            ,BOFFC,BOFFS,BOFFT,BOFFO,BOFFS2,BOFFT2
C
      DIMENSION FUNP(12),FUNX(12)
C
c*    DATA ITMO/0/,NSCHR/1/,ICALL/0/
c*    DATA ITMO/1/,NSCHR/1/,ICALL/0/
      DATA NSCHR/0/,ICALL/0/

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      SAVE AMN,FACT
C
      AMN = DSQRT(AMP*AMY)/PIM
      FP  = FPI*(PIM/PIMC)
      FCHP= FCHPI*(PIM/PIMC)
      F12N =FP*FP
      F12C =FCHP*FCHP
C
      IF(ICALL.EQ.0) THEN
        FACT = PIM/2.D0
        IF(NSCHR.NE.0) write(6,52) INA,IPV,IOFF,IVINC,ITMO
  52    FORMAT(//,' IN NNPIPI: INA  =',I2,' IPV  =',I2,' IOFF =',I2,
     .  ' IVINC=',I2,' ITMO =',I2,/)
        IF(NSCHR.NE.0) write(6,53) PIM0,PIMC,ALMP8,FP,FCHP
  53    FORMAT(/,' IN NNPIPI: PIM0=',F10.3,' PIMC=',F10.3,
     .  ' ALMP8=',D10.3,/,11X,' FP=',F12.5,' FCHP=',F12.5,/)
        ICALL=1
      ENDIF
CC
      BPV = 2*APV-1.D0
c     ISFAC=4*ISPIN-3
c     ISFPA=3-2*ISFAC
c     ISFCR=3+2*ISFAC
C-----------------------------------------------------------------------
C
C     CONSTRUCTION OF THE PI-PI POTENTIALS
C
C-----------------------------------------------------------------------
      VCPIPI = 0.D0
      VSPIPI = 0.D0
      VTPIPI = 0.D0
      VOPIPI = 0.D0
C-----------------------------------------------------------------------
C
      DO 60 II=1,3
C     PI0-PI0 CONTRIBUTION:
      IF(II.EQ.1) THEN
      AMPS1= PIM0
      AMPS2= PIM0
      CPANN  = ISPIN*F12N*F12N
      CCRNN  = CPANN
       IF(ISPIN.EQ.0.AND.I3.EQ.0) THEN
       CPANN  = F12N*F12N
       CCRNN  = CPANN
       ENDIF
      ENDIF
C     PI0-PI(CHARGED) CONTRIBUTION:
      IF(II.EQ.2) THEN
      AMPS1= PIM0
      AMPS2= PIMC
      CPANN  = 0.D0
      CCRNN  = 0.D0
       IF(I3.EQ.0) THEN
       CPANN  = -4*(2*ISPIN-1)*F12N*F12C
       CCRNN  = -CPANN
       ENDIF
      ENDIF
C     PI(CHARGED)-PI(CHARGED) CONTRIBUTION:
      IF(II.EQ.3) THEN
      AMPS1= PIMC
      AMPS2= PIMC
      CPANN  = 0.D0
      CCRNN  = 4.D0*ISPIN*F12C*F12C
       IF(I3.EQ.0) THEN
       CPANN  = 4.D0*F12C*F12C
       CCRNN  = 0.D0
       ENDIF
      ENDIF
C-----------------------------------------------------------------------
c     amps1 = pim
c     amps2 = pim

      CALL PHBFUN(3,X,AMPS1,AMPS2,ALMP8,ALMP8,FUNX)
****  CALL PHBFUN(3,X,PIM  ,PIM  ,ALMP8,ALMP8,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(3,X,AMPS1,AMPS2,ALMP8,ALMP8,FUNP)
      ELSE
      DO 61 KK=1,12
   61 FUNP(KK) = FUNX(KK)
      ENDIF

      VCPIPI =  VCPIPI + FACT*( CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSPIPI =  VSPIPI - FACT*( CPANN*FUNP(2)+CCRNN*FUNX(2))
      VTPIPI =  VTPIPI - FACT*( CPANN*FUNP(3)+CCRNN*FUNX(3))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(1,X,AMPS1,AMPS2,ALMP8,ALMP8)
c**** CALL FOOM(1,X,PIM  ,PIM  ,ALMP8,ALMP8)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(1,X,AMPS1,AMPS2,ALMP8,ALMP8)
c**** CALL BWOM(1,X,PIM  ,PIM  ,ALMP8,ALMP8)
      ELSE
      BNONC = FNONC
      BNONS = FNONS
      BNONT = FNONT
      BNONO = FNONO
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VCPIPI =  VCPIPI - FACT*( CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VSPIPI =  VSPIPI + FACT*( CPANN*BNONS+2*CCRNN*FNONS)/AMN
      VTPIPI =  VTPIPI + FACT*( CPANN*BNONT+2*CCRNN*FNONT)/AMN
      IF(IVINC.NE.1)
     .VOPIPI =  VOPIPI + FACT*( CPANN )*BNONO/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VCPIPI =  VCPIPI + APV*FACT*CCRNN *FPVC/AMN
      VOPIPI =  VOPIPI + APV*FACT*CCRNN *FPVO/AMN
      ENDIF
      IF(IVINC.NE.1) THEN
      IF(IOFF.EQ.1.AND.ITMO.NE.0) THEN
      VCPIPI =  VCPIPI + BPV*FACT*CPANN *FOFFC/AMN
      VOPIPI =  VOPIPI + BPV*FACT*CPANN *FOFFO/AMN
      ENDIF
      ENDIF
   60 CONTINUE

      VCNN  = VCNN   + VCPIPI
      VSIGNN= VSIGNN + VSPIPI
      VTENNN= VTENNN + VTPIPI
      VSONN = VSONN  + VOPIPI

C END PI-PI CONTRIBUTIONS

      RETURN
C END NNPIPI ROUTINE ***************************************************
      END

C **********************************************************************
      SUBROUTINE NNPSPS(X,ISPIN,IIMIN1,ALMP8,ALMP1)
C **********************************************************************
C     VERSION WITH OPTIONAL "TMO" (AUGUST 1998)
C
C     ITMO = 0 : NO TMO, ITMO > 0 : YES TMO
C *
C *   DATE: VERSION: JUNE , 1996
C     INCLUDED: 1) PI-ETA,PI-ETA;
C               2) ETA-ETA, ETC. + KK
C *
C *   THIS IS A FAST VERSION, BASED ON PAPER I.
C
C     PS-SCAL: ALMP1 = SU(3)-SINGLET, ALMP8 = SU(3)-OCTET
C *
C     IPV = 1 : PV-THEORY,  IPV = 0 : PS-THEORY!
C     INA = 1 : NON-ADIABATIC 1/AMN CONTRIBUTIONS INCLUDED
C     IOFF= 1 : PIONIC OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS INCLUDED

C **********************************************************************
C     CALL PHBFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN): TMO + BW
C     CALL BWFUN (KIND,X,AM1,AM2,ALM1,ALM2,FUN): NO TMO, ONLY BW
C
C     KIND=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     FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 FUN(10)= OPAEMO2
C     FUN(11)= OCREES  FUN(12)= OCREET
C     KIND=2, PION-SCALAR EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C     KIND=4, PION-DIFFRACTIVE EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C **********************************************************************
C
C     (i) Included in ENERGY-DENOMINATORS:
C         L+R contributions included, 1/4 -> 1/2, the latter is
C         put in PHBFUN
C     (ii) Included in OPERATOR DEFINITIONS of PHBFUN:
C          1 <-> 2 interchange effects for non-identical mesons.
C     (iii) Included in CPANN etc.:
C           for IDENTICAL particles 1/2
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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,         
c    .             IAXI,IPSC2,ITEN     
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPE,IPIME
      COMMON/PSCOP/ALP,APV,FPI,FP62,FP92,F120,F12C,FCHPI

      COMMON/ALLPS/PIM0,PIMC,AME,AMX

      COMMON/TWOMES/IBW,ITMO,IDAM
      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/BWOMS/BNONC,BNONS,BNONT,BNONO,BPVC,BPVS,BPVT,BPVO
     .            ,BOFFC,BOFFS,BOFFT,BOFFO,BOFFS2,BOFFT2
      COMMON/PSBE/ VPSPS0(1,4,4,4),VPSVC0(1,4,4,4),
     .             VPSSC0(1,4,4,4),VPSDF0(1,4,4,4)
      COMMON/OMPSBE/ VPSPS1(4,4,4),VPSVC1(4,4,4),
     .               VPSSC1(4,4,4),VPSDF1(4,4,4),
     .               VSCSC1(4,4,4),VSCDF1(4,4,4),VDFDF1(4,4,4)
C
C STORAGE:
C         DFM(1)  : PION, DFM(2): RHO , DFM(3): OME ETC.
C
      DIMENSION FUNP(12),FUNX(12)
C
c*    DATA ITMO/0/,NSCHR/1/,ICALL/0/
c*    DATA ITMO/1/,NSCHR/1/,ICALL/0/
      DATA NSCHR/0/,ICALL/0/
      DATA IPIET/1/,IETET/1/

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      DATA AMK/495.6D0/,AMYL/1115.D0/,AMYS/1195.D0/,DAM/230.D0/
c     SAVE AMM,AMN,FACT
      save amn,fact
C
      AMN = DSQRT(AMP*AMY)/PIM
        FP  = FPI*(PIM/PIMC)
        F12 =FP*FP
        F42 =(1.D0+2*ALP)**2*F12*(PIM/PIMC)**2/3.D0
        F52 =(1.D0-2*ALP)**2*F12*(PIM/PIMC)**2
        F62 =FP62*(PIM/PIMC)**2
        F92 =FP92*(PIM/PIMC)**2
C
      IF(ICALL.EQ.0) THEN
        FACT = PIM/2.D0
        DAM  = IDAM*0.5D0*(AMYL+AMYS-AMP-AMY)
        IF(NSCHR.NE.0) write(6,52) INA,IPV,IOFF,IVINC,IDAM,INEG, ITMO, IPIET,IETET
  52    FORMAT(//,' IN NNPSPS: INA  =',I2,' IPV  =',I2,' IOFF =',I2,
     .  ' IVINC=',I2,' IDAM=',I2,' INEG =',I2,/,11X,
     .  ' ITMO =',I2,' IPIET =',I2,' IETET =',I2)
        IF(NSCHR.NE.0) write(6,53) ALMP8,ALMP1
  53    FORMAT(/,' IN NNPSPS: ALMP8=',D10.3,' ALMP1=',D10.3,/)
c       ICALL=1
      ENDIF
CC
      BPV = 2*APV-1.D0
      ISFAC=4*ISPIN-3
      ISFPA=3-2*ISFAC
      ISFCR=3+2*ISFAC
C
C     CONSTRUCTION OF THE POTENTIALS
C
      DO 250 ITYPV=1,4
      DO 250 M=1,4
      DO 250 N=1,4
      VPSPS0(1,ITYPV,M,N)=0.D0
      VPSVC0(1,ITYPV,M,N)=0.D0
      VPSSC0(1,ITYPV,M,N)=0.D0
      VPSDF0(1,ITYPV,M,N)=0.D0
      VPSPS1(ITYPV,M,N)=0.D0
      VPSVC1(ITYPV,M,N)=0.D0
      VPSSC1(ITYPV,M,N)=0.D0
  250 VPSDF1(ITYPV,M,N)=0.D0
C
C    BEGIN PSEUDO-SCALAR CONTRIBUTIONS *******************
C
C A) PI-ETA, PI-ETA' POTENTIALS *******************
C
C    (CHECK WxHETHER THESE ARE NOT INCLUDED IN PIHBE-ROUTINE!)
      IF(IPIET.NE.0) THEN
      VCPIPS = 0.D0
      VSPIPS = 0.D0
      VTPIPS = 0.D0
      VOPIPS = 0.D0

c     DO 60 II=10,11
      DO 60 II=IIMIN1,11
      IF(II.EQ.9) THEN
      AMPS = PIM
      ALM2 = ALMP8
      CPANN  = 1*ISFPA*F12*F12
      CCRNN  = 1*ISFCR*F12*F12
      M = 1
      N = 1
      ENDIF
      IF(II.EQ.10) THEN
      AMPS = AME
      ALM2 = ALMP8
      CPANN  = 2*ISFAC*F62*F12
      CCRNN  = 2*ISFAC*F62*F12
      M = 1
      N = 3
      ENDIF
      IF(II.EQ.11) THEN
      AMPS = AMX
      ALM2 = ALMP1
      CPANN  = 2*ISFAC*F92*F12
      CCRNN  = 2*ISFAC*F92*F12
      M = 1
      N = 4
      ENDIF

      CALL PHBFUN(3,X,PIM,AMPS,ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(3,X,PIM,AMPS,ALMP8,ALM2,FUNP)
      ELSE
      DO 61 KK=1,12
   61 FUNP(KK) = FUNX(KK)
      ENDIF

      VCPIPS =  VCPIPS + FACT*( CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSPIPS =  VSPIPS - FACT*( CPANN*FUNP(2)+CCRNN*FUNX(2))
      VTPIPS =  VTPIPS - FACT*( CPANN*FUNP(3)+CCRNN*FUNX(3))
      VPSPS0(1,1,M,N)=VPSPS0(1,1,M,N)+
     .                FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VPSPS0(1,2,M,N)=VPSPS0(1,2,M,N)-
     .                FACT*(CPANN*FUNP(2)+CCRNN*FUNX(2))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(1,X,PIM,AMPS,ALMP8,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(1,X,PIM,AMPS,ALMP8,ALM2)
      ELSE
      BNONC = FNONC
      BNONS = FNONS
      BNONT = FNONT
      BNONO = FNONO
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VCPIPS =  VCPIPS - FACT*( CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VSPIPS =  VSPIPS + FACT*( CPANN*BNONS+2*CCRNN*FNONS)/AMN
      VTPIPS =  VTPIPS + FACT*( CPANN*BNONT+2*CCRNN*FNONT)/AMN
      VPSPS1(1,M,N)=VPSPS1(1,M,N)-
     .              FACT*(CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VPSPS1(2,M,N)=VPSPS1(2,M,N)+
     .              FACT*(CPANN*BNONS+2*CCRNN*FNONS)/AMN
      IF(IVINC.NE.1)
     .VOPIPS =  VOPIPS + FACT*( CPANN )*BNONO/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VCPIPS =  VCPIPS + APV*FACT*CCRNN *FPVC/AMN
      VOPIPS =  VOPIPS + APV*FACT*CCRNN *FPVO/AMN
      VPSPS1(1,M,N)=VPSPS1(1,M,N)+APV*FACT*CCRNN *FPVC/AMN
      ENDIF
      IF(IVINC.NE.1) THEN
      IF(IOFF.EQ.1.AND.ITMO.NE.0) THEN
      VCPIPS =  VCPIPS + BPV*FACT*CPANN *FOFFC/AMN
      VOPIPS =  VOPIPS + BPV*FACT*CPANN *FOFFO/AMN
      ENDIF
      ENDIF

c     IF(IPV.EQ.1.AND.INEG.NE.0) THEN
c     CALL FOMNEG(1,X,PIM,AMPS,ALMP8,ALM2,FNEGC)
c     VCPIPS =  VCPIPS + APV*FACT*(CPANN+CCRNN)*FNEGC/AMN
c     VPSPS1(1,M,N)=VPSPS1(1,M,N)+APV*FACT*(CPANN+CCRNN)*FNEGC/AMN
c     ENDIF

   60 CONTINUE

      VCNN  = VCNN   + VCPIPS
      VSIGNN= VSIGNN + VSPIPS
      VTENNN= VTENNN + VTPIPS
      VSONN = VSONN  + VOPIPS
      ENDIF

C B)  ETA-ETA, ETA-ETA', ETA'-ETA', AND KK- POTENTIALS:

      IF(IETET.NE.0) THEN
      VCPSPS = 0.D0
      VSPSPS = 0.D0
      VTPSPS = 0.D0
      VOPSPS = 0.D0

      DO 65 II=1,4
      IF(II.EQ.1) THEN
      CPANN = F62*F62
      AMPS1 = AME
      AMPS2 = AME
      ALM1  = ALMP8
      ALM2  = ALMP8
      M = 3
      N = 3
      ENDIF
      IF(II.EQ.2) THEN
      CPANN = F62*F92*2
      AMPS1 = AME
      AMPS2 = AMX
      ALM1  = ALMP8
      ALM2  = ALMP1
      M = 3
      N = 4
      ENDIF
      IF(II.EQ.3) THEN
      CPANN = F92*F92
      AMPS1 = AMX
      AMPS2 = AMX
      ALM1  = ALMP1
      ALM2  = ALMP1
      M = 4
      N = 4
      ENDIF
      CCRNN = CPANN
      IF(II.EQ.4) THEN
      CCRNN = 0.5D0*( (1+ISFAC)*F42**2 + 2*(3-ISFAC)*F42*F52
     .                +(9+ISFAC)*F52**2 )
      CPANN = 0.D0
      AMPS1 = AMK
      AMPS2 = AMK
      ALM1  = ALMP8
      ALM2  = ALMP8
      M = 2
      N = 2
      ENDIF
      IF(II.LE.3) CALL PHBFUN(3,X,AMPS1,AMPS2,ALM1,ALM2,FUNX)
      IF(II.EQ.4) THEN
      IF(IDAM.EQ.0) CALL PHBFUN(3,X,AMPS1,AMPS2,ALM1,ALM2,FUNX)
      IF(IDAM.EQ.1) CALL DKBFUN(3,X,AMPS1,AMPS2,ALM1,ALM2,DAM,FUNX)
      ENDIF
      IF(ITMO.EQ.0.AND.II.NE.4) THEN
      CALL BWFUN(3,X,AMPS1,AMPS,ALM1,ALM2,FUNP)
      ELSE
      DO 66 KK=1,12
   66 FUNP(KK) = FUNX(KK)
      ENDIF

      VCPSPS =  VCPSPS + FACT*( CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSPSPS =  VSPSPS - FACT*( CPANN*FUNP(2)+CCRNN*FUNX(2))
      VTPSPS =  VTPSPS - FACT*( CPANN*FUNP(3)+CCRNN*FUNX(3))
      VPSPS0(1,1,M,N)=VPSPS0(1,1,M,N) +
     .                FACT*( CPANN*FUNP(1)-CCRNN*FUNX(1))
      VPSPS0(1,2,M,N)=VPSPS0(1,2,M,N) -
     .                FACT*( CPANN*FUNP(2)+CCRNN*FUNX(2))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      IF(II.LE.3) CALL FOOM(1,X,AMPS1,AMPS2,ALM1,ALM2)
      IF(II.EQ.4) THEN
      IF(IDAM.EQ.0) CALL FOOM(1,X,AMPS1,AMPS2,ALM1,ALM2)
      IF(IDAM.EQ.1) CALL DKBOOM(1,X,AMPS1,AMPS2,ALM1,ALM2,DAM)
      ENDIF
      IF(ITMO.EQ.0.AND.II.NE.4) THEN
      CALL BWOM(1,X,AMPS1,AMPS2,ALM1,ALM2)
      ELSE
      BNONC = FNONC
      BNONS = FNONS
      BNONT = FNONT
      BNONO = FNONO
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VCPSPS =  VCPSPS - FACT*( CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VSPSPS =  VSPSPS + FACT*( CPANN*BNONS+2*CCRNN*FNONS)/AMN
      VTPSPS =  VTPSPS + FACT*( CPANN*BNONT+2*CCRNN*FNONT)/AMN
      VPSPS1(1,M,N)=VPSPS1(1,M,N)-
     .              FACT*(CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VPSPS1(2,M,N)=VPSPS1(2,M,N)+
     .              FACT*(CPANN*BNONS+2*CCRNN*FNONS)/AMN
      IF(IVINC.NE.1)
     .VOPSPS =  VOPSPS + FACT*( CPANN )*BNONO/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VCPSPS =  VCPSPS + APV*FACT*CCRNN *FPVC/AMN
      VOPSPS =  VOPSPS + APV*FACT*CCRNN *FPVO/AMN
      VPSPS1(1,M,N)=VPSPS1(1,M,N)+APV*FACT*CCRNN *FPVC/AMN
      ENDIF
      IF(IVINC.NE.1) THEN
      IF(IOFF.EQ.1 .AND. II.NE.4 .AND. ITMO.NE.0) THEN
      VCPSPS =  VCPSPS + BPV*FACT*CPANN *FOFFC/AMN
      VOPSPS =  VOPSPS + BPV*FACT*CPANN *FOFFO/AMN
      ENDIF
      ENDIF

c     IF(IPV.EQ.1.AND.INEG.NE.0) THEN
c     CALL FOMNEG(1,X,AMPS1,AMPS2,ALM1,ALM2,FNEGC)
c     VCPIPS =  VCPIPS + APV*FACT*(CPANN+CCRNN)*FNEGC/AMN
c     VPSPS1(1,M,N)=VPSPS1(1,M,N)+APV*FACT*(CPANN+CCRNN)*FNEGC/AMN
c     ENDIF

   65 CONTINUE

      VCNN  = VCNN   + VCPSPS
      VSIGNN= VSIGNN + VSPSPS
      VTENNN= VTENNN + VTPSPS
      VSONN = VSONN  + VOPSPS
      ENDIF
      if(icall.eq.0.and.nschr.eq.1) call writetm(1,x)
      if(icall.eq.0.and.nschr.eq.1) call wromtm(1,x)
C END PSEUDO-SCALAR CONTRIBUTIONS

c1000  CONTINUE
      ICALL=1
      RETURN
C END NNPSPS ROUTINE ***************************************************
      END

C **********************************************************************
      SUBROUTINE WRITETM(NCASE,X)
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(1,4,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
      write(17,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
      write(17,*)'*****************************************************'
      if(ncase.eq.1) write(17,*) ' NNPSPS: CENTRAL POTENTIALS: x=',x
      if(ncase.ge.2) write(17,*) ' NNPSBE: CENTRAL POTENTIALS: x=',x
      write(17,*)'*****************************************************'
      write(17,110) (NTYPM(KK,NCASE),KK=1,4)
  110 format(10x,4(3x,a4,5x))
      write(17,*)'-----------------------------------------------------'
      DO 111 II=1,4
  111 write(17,112) NTYPM(II,1),(VPSBE(1,1,II,KK,NCASE),KK=1,4)
      write(17,*)'====================================================='
      write(17,*)'*****************************************************'
      if(ncase.eq.1) write(17,*) ' NNPSPS: SPIN-SPIN POTENTIALS: x=',x
      if(ncase.ge.2) write(17,*) ' NNPSBE: SPIN-SPIN POTENTIALS: x=',x
      write(17,*)'*****************************************************'
      write(17,115) (NTYPM(KK,NCASE),KK=1,4)
  115 format(10x,4(3x,a4,5x))
      write(17,*)'-----------------------------------------------------'
      DO 116 II=1,4
  116 write(17,112) NTYPM(II,1),(VPSBE(1,2,II,KK,NCASE),KK=1,4)
      write(17,*)'====================================================='
      write(17,*)'*****************************************************'
      RETURN
  112 FORMAT(1x,'NN: ',A4,4(F10.2,2X))
c 114 FORMAT(1x,'DR: ',A4,4(F10.2,2X))
c 124 FORMAT(1x,'LL: ',A4,4(F10.2,2X))
c 126 FORMAT(1x,'LS: ',A4,4(F10.2,2X))
c 128 FORMAT(1x,'SS: ',A4,4(F10.2,2X))
C END WRITETM ROUTINE **************************************************
      END
C **********************************************************************
      SUBROUTINE WROMTM(NCASE,X)
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/OMPSBE/ VPSBE(4,4,4,7)
      CHARACTER*4 NTYPM(4,4)
      DATA 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(17,*)'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
C     write(17,*)'*****************************************************'
      if(ncase.eq.1) write(17,*) ' OMPSPS: CENTRAL POTENTIALS: x=',x
      if(ncase.ge.2.and.ncase.le.4)
     .write(17,*) ' OMPSBE: CENTRAL POTENTIALS: x=',x
      if(ncase.eq.5) write(17,*) ' OMSCSC: CENTRAL POTENTIALS: x=',x
      if(ncase.eq.6) write(17,*) ' OMSCDF: CENTRAL POTENTIALS: x=',x
      if(ncase.eq.7) write(17,*) ' OMDFDF: CENTRAL POTENTIALS: x=',x
      write(17,*)'*****************************************************'
      write(17,110) (NTYPM(KK,I2),KK=1,4)
  110 format(10x,4(3x,a4,5x))
      write(17,*)'-----------------------------------------------------'
      DO 111 II=1,4
  111 write(17,112) NTYPM(II,I1),(VPSBE(1,II,KK,NCASE),KK=1,4)
      write(17,*)'====================================================='
      write(17,*)'*****************************************************'
      if(ncase.ge.5) return
      if(ncase.eq.1) write(17,*) ' OMPSPS: SPIN-SPIN POTENTIALS: x=',x
      if(ncase.ge.2.and.ncase.le.4)
     .write(17,*) ' OMPSBE: SPIN-SPIN POTENTIALS: x=',x
      if(ncase.eq.5) write(17,*) ' OMSCSC: SPIN-SPIN POTENTIALS: x=',x
      if(ncase.eq.6) write(17,*) ' OMSCDF: SPIN-SPIN POTENTIALS: x=',x
      if(ncase.eq.7) write(17,*) ' OMDFDF: SPIN-SPIN POTENTIALS: x=',x
      write(17,*)'*****************************************************'
      write(17,115) (NTYPM(KK,I2),KK=1,4)
  115 format(10x,4(3x,a4,5x))
      write(17,*)'-----------------------------------------------------'
      DO 116 II=1,4
  116 write(17,112) NTYPM(II,I1),(VPSBE(2,II,KK,NCASE),KK=1,4)
      write(17,*)'====================================================='
      write(17,*)'*****************************************************'
      RETURN
  112 FORMAT(1x,'NN: ',A4,4(F10.2,2X))
C 114 FORMAT(1x,'DR: ',A4,4(F10.2,2X))
C 124 FORMAT(1x,'LL: ',A4,4(F10.2,2X))
C 126 FORMAT(1x,'LS: ',A4,4(F10.2,2X))
C 128 FORMAT(1x,'SS: ',A4,4(F10.2,2X))
C END WROMTM ROUTINE **************************************************
      END
C **********************************************************************
      SUBROUTINE OMSCDF(X,INA,ISPIN,ALMS8,ALMS1)
C **********************************************************************
C *
C *   DATE: DECEMBER 1996
C
C     THIS ROUTINE: THE DOUBLE SCALAR/DIFFRACTIVE NN-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 CPANN  ETC.:
C     (ii) 1 <-> 2 interchange effects for non-identical mesons.
C
C **********************************************************************
C
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2

      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLSC/AMEPS,GAMEPS,ASIG(2),AMSIG(2),AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      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
      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/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/OMPSBE/
     .VPSPS(4,4,4),VPSVC(4,4,4),VPSSC(4,4,4),VPSDF(4,4,4),
     .VSCSC(4,4,4),VSCDF(4,4,4),VDFDF(4,4,4)

      DATA IEPEP/1/,ICALL/0/,NSCHR/0/
C
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      DATA AMPRO/938.2796D0/,AMEPS/760.D0/,AMSCK/1100.D0/
      SAVE AMN,FACT
C
      ISFAC = 4*ISPIN-3
      ISFLL = (1+ISFAC)/2
      ISFLS = (3-ISFAC)
      ISFSS = (9+ISFAC)/2
      IF(ICALL.EQ.0) THEN
        AMN = AMPRO
        FACT = PIMC/2.D0
c       FACT = PIMC
        FACT = FACT*(PIMC/AMPRO)
        DO 250 ITYPV=1,4
        DO 250 M=1,4
        DO 250 N=1,4
        VSCSC(ITYPV,M,N)=0.D0
        VSCDF(ITYPV,M,N)=0.D0
  250   VDFDF(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,7
      GOTO(1,2,3,4,5,6,7), II
C
C DELTA-DELTA EXCHANGE POTENTIALS:
    1 M = 1
      N = 1
      CPANN  =  1*(3.D0-2.D0*ISFAC)*GS1**2*GS1**2
      CCRNN  =  1*(3.D0+2.D0*ISFAC)*GS1**2*GS1**2
      CALL FOOM(5,X,AMD,AMD,ALMS8,ALMS8)
      GOTO 150
C
C KAPPA-KAPPA EXCHANGE POTENTIALS:
    2 M = 2
      N = 2
      CPANN  =  0.D0
      CCRNN  =  1*(ISFLL*GS4**2*GS4**2+ISFLS*GS4**2*GS5**2+
     .             ISFSS*GS5**2*GS5**2)
      CALL FOOM(5,X,AMSCK,AMSCK,ALMS8,ALMS8)
      GOTO 150
C
C S*-DELTA EXCHANGE POTENTIALS:
    3 M = 1
      N = 4
      CPANN  =  2*ISFAC*GS1**2*GS9**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMSST,AMD,ALMS8,ALMS8)
      GOTO 150
C
C S*-S* EXCHANGE POTENTIALS:
    4 M = 4
      N = 4
      CPANN  =  GS9**2*GS9**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMSST,AMSST,ALMS8,ALMS8)
      GOTO 150
C
C EPSILON-DELTA EXCHANGE POTENTIALS:
    5 M = 1
      N = 3
      CPANN  =  2*ISFAC*GS1**2*GS6**2
      CCRNN  =  CPANN
      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
C EPSILON-S* EXCHANGE POTENTIALS:
    6 M = 3
      N = 4
      CPANN  =  2*GS6**2*GS9**2
      CCRNN  =  CPANN
      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:
    7 M = 3
      N = 3
      CPANN  =  GS6**2*GS6**2
      CCRNN  =  CPANN
      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 VCNN  =   VCNN - FACT*( CPANN-2*CCRNN )*FNONC

      VSCSC(1,M,N)=VSCSC(1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC
  100 CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call wromtm(5,x)
C
C **************************************************************
C     DOUBLE SCALAR/DIFFRACTIVE CONTRIBUTIONS:
C **************************************************************
C
      DO 300 II=1,7
      GOTO(31,32,33,34,35,36,37),II
C DELTA-A2 EXCHANGE POTENTIALS:
   31 PEX = -1.D0
      M = 1
      N = 1
      CPANN  =  2*(3.D0-2.D0*ISFAC)*GS1**2*GD1**2
      CCRNN  =  2*(3.D0+2.D0*ISFAC)*GS1**2*GD1**2
      CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM)
      GOTO 350
C DELTA-POMERON EXCHANGE POTENTIALS:
   32 PEX = -1.D0
      M = 1
      N = 3
      CPANN  =  2*ISFAC*GS1**2*GD6**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMD,AMPOM,ALMS8,AMPOM)
      GOTO 350
C KAPPA-K** EXCHANGE POTENTIALS:
   33 PEX = -1.D0
      M = 2
      N = 2
      CPANN  =  0.D0
      CCRNN  =  2*(ISFLL*GS4**2*GD4**2+ISFLS*GS4*GS5*GD4*GD5+
     .             ISFSS*GS5**2*GD5**2)
      CALL FOOM(5,X,AMSCK,AMPOM,ALMS8,AMPOM)
      GOTO 350
C S*-A2 EXCHANGE POTENTIALS:
   34 PEX = -1.D0
      M = 4
      N = 1
      CPANN  =  2*ISFAC*GD1**2*GS9**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM)
      GOTO 350
C S*-POMERON EXCHANGE POTENTIALS:
   35 PEX = -1.D0
      M = 4
      N = 3
      CPANN  =  2*GS9**2*GD6**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMSST,AMPOM,ALMS8,AMPOM)
      GOTO 350
C EPSILON-POMERON EXCHANGE POTENTIALS:
   36 PEX = -1.D0
      M = 3
      N = 3
      CPANN  =  2*GS6**2*GD6**2
      CCRNN  =  CPANN
      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:
   37 PEX = -1.D0
      M = 3
      N = 1
      CPANN  =  2*ISFAC*GD1**2*GS6**2
      CCRNN  =  CPANN
      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
  350 VCNN  =   VCNN - FACT*( CPANN-2*CCRNN )*FNONC*PEX

      VSCDF(1,M,N)=VSCDF(1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX
  300 CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call wromtm(6,x)
C
C **************************************************************
C     DOUBLE DIFFRACTIVE CONTRIBUTIONS:
C **************************************************************
C
      DO 400 II=1,4
      GOTO(44,54,64,74), II
C POMERON-POMERON EXCHANGE POTENTIALS:
   44 PEX = +1.D0
      M = 3
      N = 3
      CPANN  =  GD6**2*GD6**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      GOTO 450
C POMERON-A2 EXCHANGE POTENTIALS:
   54 PEX = +1.D0
      M = 1
      N = 3
      CPANN  =  2*ISFAC*GD1**2*GD6**2
      CCRNN  =  CPANN
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      GOTO 450
C A2-A2 EXCHANGE POTENTIALS:
   64 PEX = +1.D0
      M = 1
      N = 1
      CPANN  =  1*(3.D0-2.D0*ISFAC)*GD1**2*GD1**2
      CCRNN  =  1*(3.D0+2.D0*ISFAC)*GD1**2*GD1**2
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      GOTO 450
C K**-K** EXCHANGE POTENTIALS:
   74 PEX = +1.D0
      M = 2
      N = 2
      CPANN  =  0.D0
      CCRNN  =  1*(ISFLL*GD4**2*GD4**2+ISFLS*GD4**2*GD5**2+
     .             ISFSS*GD5**2*GD5**2)
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      GOTO 450

  450 VCNN  =   VCNN - FACT*( CPANN-2*CCRNN )*FNONC*PEX

      VDFDF(1,M,N)=VDFDF(1,M,N)-FACT*(CPANN-2*CCRNN)*FNONC*PEX
  400 CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call wromtm(7,x)
      ENDIF
C     END DOUBLE SCALAR/DIFFRACTIVE EXCHANGE

c1000  CONTINUE
      ICALL = 1
      RETURN
C END OMSCDF ROUTINE ***************************************************
      END

C FOR ROUTINE PIHBE:  ***********************************************
C     BLOCK DATA
C     IMPLICIT REAL*8(A-H,O-Z)
C     COMMON/TREATV/IPIRO,IPIOM,IPIPH
C     COMMON/TREATS/IPIDE,IPIEP,IPIST
C     COMMON/TREATD/IPIA2,IPIPOM
C     COMMON/TREATA/IPIA1,IPID1,IPIE1
C     DATA IPIRO/1/,IPIOM/1/,IPIPH/1/
C     DATA IPIDE/1/,IPIEP/1/,IPIST/1/
C     DATA IPIA2/1/,IPIPOM/1/
C     DATA IPIA1/0/,IPID1/0/,IPIE1/0/
C     END

C **********************************************************************
      SUBROUTINE PIHBE(X,ISPIN,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1)
C **********************************************************************
C     VERSION WITH OPTIONAL "TMO": ITMO=0, NO TMO; ITMO=1, YES TMO.
C-----------------------------------------------------------------------
C *
C *   DATE: VERSION: APRIL, 1996     (PI-A1 ETC. INCLUDED)
C *
C *   THIS IS A FAST VERSION, BASED ON PAPER I.
C
C *   PION-MESON EXCHANGE NN-POTENTIALS (MESON= VECTOR, SCALAR, DIFFR.)
C *
C * THIS ROUTINE: NO MASS-DIFFERENCES BETWEEN NUCCLEONS ACCOUNTED FOR
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     IPV = 1 : PV-THEORY,  IPV = 0 : PS-THEORY!
C     INA = 1 : NON-ADIABATIC 1/AMN CONTRIBUTIONS INCLUDED
C     IOFF= 1 : PIONIC OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS INCLUDED

C **********************************************************************
C     CALL PHBFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN):
C
C     KIND=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     FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 FUN(10)= OPAEMO2
C     FUN(11)= OCREES  FUN(12)= OCREET
C     KIND=2, PION-SCALAR EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C     KIND=4, PION-DIFFRACTIVE EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C **********************************************************************
C
C     (i) Included in ENERGY-DENOMINATORS:
C         L+R contributions included, 1/4 -> 1/2, the latter is
C         put in PHBFUN
C     (ii) Included in OPERATOR DEFINITIONS of PHBFUN:
C          1 <-> 2 interchange effects for non-identical mesons.
C     (iii) Included in CPANN etc.:
C           for IDENTICAL particles 1/2
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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
C     COMMON/TREATV/IPIRO,IPIOM,IPIPH
C     COMMON/TREATS/IPIDE,IPIEP,IPIST
C     COMMON/TREATD/IPIA2,IPIPOM
C     COMMON/TREATA/IPIA1,IPID1,IPIE1
C     COMMON/ALLHBE/VCPIRO,VCPIOM,VCPIFI,VSPIRO,VSPIOM,VSPIFI,
C    .              VTPIRO,VTPIOM,VTPIFI,VOPIRO,VOPIOM,VOPIFI,
C    .              VSPIDE,VSPIEP,VSPIST,
C    .              VTPIDE,VTPIEP,VTPIST,VOPIDE,VOPIEP,VOPIST,
C    .              VCPIET,VCPETP,VSPIET,VSPETP,VTPIET,VTPETP,
C    .              VOPIET,VOPETP
      COMMON/PSCOP/ALP,APV,FPI,FP62,FP92,F120,F12C,FCHPI
      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
c*    COMMON/DIFCOP/GD62,GD12,GD92
      COMMON/DIFCOP/GPOM2,GA22,GF22,GFP22
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,ALMAX

      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEPS,ASI,BSI,AM1SI,AM2SI,AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/BWOMS/BNONC,BNONS,BNONT,BNONO,BPVC,BPVS,BPVT,BPVO
     .            ,BOFFC,BOFFS,BOFFT,BOFFO,BOFFS2,BOFFT2
      COMMON/PSBE/
     .VPSPS(1,4,4,4),VPSVC(1,4,4,4),VPSSC(1,4,4,4),VPSDF(1,4,4,4)
      COMMON/OMPSBE/
     .OPSPS(4,4,4),OPSVC(4,4,4),OPSSC(4,4,4),OPSDF(4,4,4),
     .OSCSC(4,4,4),OSCDF(4,4,4),ODFDF(4,4,4)
C
      COMMON/AMMES/AMM(14),AFM(14)
C STORAGE:
C         AMM(1)=PIM, AMM(2)=AMRO1, AMM(3)=AMRO2, AMM(4)=AMOM,
C         DFM(1)  : PION, DFM(2): RHO , DFM(3): OME ETC.
C
      DIMENSION FUNP(12),FUNX(12)
      REAL*8 KAPPA(4)
C
      DATA ITMO/0/,ICALL/0/
      DATA IPSC/0/,IVCT/1/,ISCL/1/,IDIF/1/,IAXI/0/,IPSC2/0/,ITEN/0/
c     DATA IEPEP/1/,IEPPO/0/,IPOA2/0/,IA2A2/0/
      DATA IEPEP/0/,IEPPO/0/,IPOA2/0/,IA2A2/0/

c     DATA AFM/14*1.D0/

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      DATA AMA1/1270.D0/,AMD1/1285.D0/,AME1/1420.D0/
c     SAVE AMM,AMN,FACT
      save amn,fact
C
      AMN = DSQRT(AMP*AMY)/PIM
        FP  = FPI*(PIM/PIMC)
        F12 =FP*FP
        F62 =FP62*(PIM/PIMC)**2
        F92 =FP92*(PIM/PIMC)**2
        KAPPA(1)=0.D0
        KAPPA(2)=0.D0
        KAPPA(3)=0.D0
        KAPPA(4)=0.D0
        IF(FD12.NE.0.D0) KAPPA(1)=FDV1/FD12
        KAPPA(2)=KAPPA(1)
        IF(FD62.NE.0.D0) KAPPA(3)=FDV6/FD62
        IF(FD92.NE.0.D0) KAPPA(4)=FDV9/FD92
        GD12 = GA22
        GD62 = GPOM2
C
      IF(ICALL.EQ.0) THEN
        FACT = PIM
        AMM(1) =PIM
        AMM(2) =AM1RO
        AMM(3) =AM2RO
        AMM(4) =AMOM
        AMM(5) =AMFI
        AMM(6) =AMD
        AMM(7) =AM1SI
        AMM(8) =AM2SI
        AMM(9) =AMSST
        AMM(10)=AME
        AMM(11)=AMX
        AMM(12)=AMA1
        AMM(13)=AMD1
        AMM(14)=AME1
        DO 13 KK=1,14
   13   AFM(KK)=1.D0
        AFM(2) = ARO
        AFM(3) = BRO
        AFM(7) = ASI
        AFM(8) = BSI
        IF(NSCHR.NE.0) write(6,52) INA,IPV,IOFF,IVINC,ITMO, IPSC,IVCT,
     .  ISCL,IDIF,IAXI,IPSC2,ITEN,IEPEP,IEPPO,IPOA2,IA2A2
 52     FORMAT(//,'  IN PIHBE: INA  =',I2,' IPV  =',I2,' IOFF =',I2,
     .  ' IVINC=',I2,' ITMO =',I2,/,11X,
     .  ' IPSC =',I2,' IVCT =',I2,' ISCL =',I2,' IDIF =',I2,
     .  ' IAXI =',I2,' IPSC2=',I2,' ITEN =',I2,/,11X,
     .  ' IEPEP=',I2,' IEPPO=',I2,' IPOA2=',I2,' IA2A2=',I2)
        write(6,53) ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1
 53     FORMAT(/,'  IN PIHBE: ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',
     .  D10.3,/,11X,' ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=',D10.3,/)
c       ICALL=1
      ENDIF
CC
      ISFAC=4*ISPIN-3
      ISFPA=3-2*ISFAC
      ISFCR=3+2*ISFAC
C
c     already done in NNPSPS.F!
c     DO 250 ITYPV=1,4
c     DO 250 M=1,4
c     DO 250 N=1,4
c     VPSPS(1,ITYPV,M,N)=0.D0
c     VPSVC(1,ITYPV,M,N)=0.D0
c     VPSSC(1,ITYPV,M,N)=0.D0
c 250 VPSDF(1,ITYPV,M,N)=0.D0
      M = 1
C
C     CONSTRUCTION OF THE POTENTIALS
C
C A)  PION-VECTOR-MESON POTENTIALS: ******************************
C
      IF(IVCT.NE.0) THEN
      VCPIVC = 0.D0
      VSPIVC = 0.D0
      VTPIVC = 0.D0
      VOPIVC = 0.D0

      DO 30 II=2,5
      IF(II.LE.3) THEN
      ALM2=ALMV8
      N = 1
C     EE-CONTRIBUTION:
      CPAEE  = ISFPA*FD12*F12
      CCREE  = ISFCR*FD12*F12
C     MM-CONTRIBUTION:
      CPAMM  = ISFPA*FD12*F12*((1.D0+KAPPA(1))/AMN)**2
      CCRMM  = ISFCR*FD12*F12*((1.D0+KAPPA(1))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = ISFPA*FD12*F12*(1.D0+KAPPA(1))/AMN**2
      CCREM1 = ISFCR*FD12*F12*(1.D0+KAPPA(1))/AMN**2
      CPAEM2 = ISFPA*FD12*F12*(1.D0+2*KAPPA(1))/AMN**2
      CCREM2 = ISFCR*FD12*F12*(1.D0+2*KAPPA(1))/AMN**2
      ENDIF
      IF(II.EQ.4) THEN
      ALM2=ALMV1
      N = 3
C     EE-CONTRIBUTION:
      CPAEE  = ISFAC*FD62*F12
      CCREE  = ISFAC*FD62*F12
C     MM-CONTRIBUTION:
      CPAMM  = ISFAC*FD62*F12*((1.D0+KAPPA(3))/AMN)**2
      CCRMM  = ISFAC*FD62*F12*((1.D0+KAPPA(3))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = ISFAC*FD62*F12*(1.D0+KAPPA(3))/AMN**2
      CCREM1 = ISFAC*FD62*F12*(1.D0+KAPPA(3))/AMN**2
      CPAEM2 = ISFAC*FD62*F12*(1.D0+2*KAPPA(3))/AMN**2
      CCREM2 = ISFAC*FD62*F12*(1.D0+2*KAPPA(3))/AMN**2
      ENDIF
      IF(II.EQ.5) THEN
      ALM2=ALMV8
      N = 4
C     EE-CONTRIBUTION:
      CPAEE  = ISFAC*FD92*F12
      CCREE  = ISFAC*FD92*F12
C     MM-CONTRIBUTION:
      CPAMM  = ISFAC*FD92*F12*((1.D0+KAPPA(4))/AMN)**2
      CCRMM  = ISFAC*FD92*F12*((1.D0+KAPPA(4))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = ISFAC*FD92*F12*(1.D0+KAPPA(4))/AMN**2
      CCREM1 = ISFAC*FD92*F12*(1.D0+KAPPA(4))/AMN**2
      CPAEM2 = ISFAC*FD92*F12*(1.D0+2*KAPPA(4))/AMN**2
      CCREM2 = ISFAC*FD92*F12*(1.D0+2*KAPPA(4))/AMN**2
      ENDIF

      CALL PHBFUN(1,X,PIM,AMM(II),ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(1,X,PIM,AMM(II),ALMP8,ALM2,FUNP)
      ELSE
      DO 31 KK=1,12
   31 FUNP(KK) = FUNX(KK)
      ENDIF

C     EE-CONTRIBUTION:
      VSPIVC=  VSPIVC + AFM(II)*FACT*(CPAEE*FUNP(1)-CCREE*FUNX(11))
      VTPIVC=  VTPIVC + AFM(II)*FACT*(CPAEE*FUNP(2)-CCREE*FUNX(12))
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               AFM(II)*FACT*(CPAEE*FUNP(1)-CCREE*FUNX(11))

C     1/M^2-TERMS:
C     EM-CONTRIBUTION:
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAEM1*FUNP(3)+CCREM1*FUNX(3))/2.D0
      VOPIVC=VOPIVC+AFM(II)*FACT*(CPAEM1*FUNP(4)-CCREM1*FUNX(4))/2.D0

      VSPIVC=VSPIVC+AFM(II)*FACT*(CPAEM2*FUNP(8)-CCREM2*FUNX(8))/2.D0
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAEM2*FUNP(9)-CCREM2*FUNX(9))/2.D0
      VOPIVC=VOPIVC+AFM(II)*FACT*(CPAEM2*FUNP(10)-CCREM2*FUNX(10))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               AFM(II)*FACT*(CPAEM2*FUNP(8)-CCREM2*FUNX(8))/2.D0

C     MM-CONTRIBUTION:
      VCPIVC=VCPIVC+AFM(II)*FACT*(CPAMM*FUNP(5)-CCRMM*FUNX(5))/2.D0
      VSPIVC=VSPIVC+AFM(II)*FACT*(CPAMM*FUNP(6)+CCRMM*FUNX(6))/2.D0
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAMM*FUNP(7)+CCRMM*FUNX(7))/2.D0
      VPSVC(1,1,M,N)=VPSVC(1,1,M,N) +
     .              AFM(II)*FACT*(CPAMM*FUNP(5)-CCRMM*FUNX(5))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .              AFM(II)*FACT*(CPAMM*FUNP(6)+CCRMM*FUNX(6))/2.D0

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(2,X,PIM,AMM(II),ALMP8,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(2,X,PIM,AMM(II),ALMP8,ALM2)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPIVC=VSPIVC-AFM(II)*FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      VTPIVC=VTPIVC-AFM(II)*FACT*(CPAEE*BNONT-2*CCREE*FNONT)/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) -
     .             AFM(II)*FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPIVC =  VSPIVC + APV*AFM(II)*FACT*CCREE *FPVS/AMN
      VTPIVC =  VTPIVC + APV*AFM(II)*FACT*CCREE *FPVT/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) +
     .             APV*AFM(II)*FACT*CCREE *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPIVC =  VSPIVC + AFM(II)*FACT*CPAEE *(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPIVC =  VTPIVC + AFM(II)*FACT*CPAEE *(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   30 CONTINUE

      VCNN  = VCNN   + VCPIVC
      VSIGNN= VSIGNN + VSPIVC
      VTENNN= VTENNN + VTPIVC
      VSONN = VSONN  + VOPIVC
      ENDIF
C END PION-VECTOR EXCHANGE
C
C B) PION-SCALAR MESONS: *****************************************
C
      IF(ISCL.NE.0) THEN
      VCPISC = 0.D0
      VSPISC = 0.D0
      VTPISC = 0.D0
      VOPISC = 0.D0

      DO 40 II=6,9
      IF(II.EQ.6) THEN
      ALM2=ALMS8
      N = 1
      CPANN  = ISFPA*GS12*F12
      CCRNN  = ISFCR*GS12*F12
      ENDIF
      IF(II.EQ.7.OR.II.EQ.8) THEN
      ALM2=ALMS1
      CPANN  = ISFAC*GS62*F12
      CCRNN  = ISFAC*GS62*F12
      N = 3
      ENDIF
      IF(II.EQ.9) THEN
      ALM2=ALMS1
      CPANN  = ISFAC*GS92*F12
      CCRNN  = ISFAC*GS92*F12
      N = 4
      ENDIF

      CALL PHBFUN(2,X,PIM,AMM(II),ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(2,X,PIM,AMM(II),ALMP8,ALM2,FUNP)
      ELSE
      DO 41 KK=1,12
   41 FUNP(KK) = FUNX(KK)
      ENDIF

      VSPISC=VSPISC+AFM(II)*FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VTPISC=VTPISC+AFM(II)*FACT*(CPANN*FUNP(2)-CCRNN*FUNX(2))
      VOPISC=VOPISC+AFM(II)*FACT*(CPANN*FUNP(3)-CCRNN*FUNX(3))
      VPSSC(1,2,M,N)=VPSSC(1,2,M,N) +
     .               AFM(II)*FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(3,X,PIM,AMM(II),ALMP8,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(3,X,PIM,AMM(II),ALMP8,ALM2)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPISC=VSPISC+AFM(II)*FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTPISC=VTPISC+AFM(II)*FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N) +
     .             AFM(II)*FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPISC =  VSPISC - APV*AFM(II)*FACT*CCRNN *FPVS/AMN
      VTPISC =  VTPISC - APV*AFM(II)*FACT*CCRNN *FPVT/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N) -
     .             APV*AFM(II)*FACT*CCRNN *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPISC =  VSPISC - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPISC =  VTPISC - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   40 CONTINUE

      VCNN  = VCNN   + VCPISC
      VSIGNN= VSIGNN + VSPISC
      VTENNN= VTENNN + VTPISC
      VSONN = VSONN  + VOPISC
      ENDIF
C END SCALAR MESONS
C
C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************
C
      IF(IDIF.NE.0) THEN
      VCPIDF = 0.D0
      VSPIDF = 0.D0
      VTPIDF = 0.D0
      VOPIDF = 0.D0

      DO 50 II=1,2
      IF(II.EQ.1) THEN
      N = 1
      CPANN  = ISFPA*GD12*F12
      CCRNN  = ISFCR*GD12*F12
      ENDIF
      IF(II.EQ.2) THEN
      N = 3
      CPANN  = ISFAC*GD62*F12
      CCRNN  = ISFAC*GD62*F12
      ENDIF

      CALL PHBFUN(4,X,PIM,AMPOM,ALMP8,2*AMPOM,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(4,X,PIM,AMPOM,ALMP8,2*AMPOM,FUNP)
      ELSE
      DO 51 KK=1,12
   51 FUNP(KK) = FUNX(KK)
      ENDIF

      VSPIDF=VSPIDF-FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VTPIDF=VTPIDF-FACT*(CPANN*FUNP(2)-CCRNN*FUNX(2))
      VOPIDF=VOPIDF-FACT*(CPANN*FUNP(3)-CCRNN*FUNX(3))
      VPSDF(1,2,1,1)=VPSDF(1,2,1,1) -
     .               FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(4,X,PIM,AMPOM,ALMP8,AMPOM)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(4,X,PIM,AMPOM,ALMP8,AMPOM)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPIDF=VSPIDF-FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTPIDF=VTPIDF-FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSDF(2,1,N)=OPSDF(2,1,N) -
     .             FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPIDF =  VSPIDF + APV*FACT*CCRNN *FPVS/AMN
      VTPIDF =  VTPIDF + APV*FACT*CCRNN *FPVT/AMN
      OPSDF(2,1,N)=OPSDF(2,1,N) +
     .             APV*FACT*CCRNN *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPIDF =  VSPIDF + FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPIDF =  VTPIDF + FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   50 CONTINUE

      VCNN  = VCNN   + VCPIDF
      VSIGNN= VSIGNN + VSPIDF
      VTENNN= VTENNN + VTPIDF
      VSONN = VSONN  + VOPIDF
      ENDIF
C END DIFFRACTIVE CONTRIBUTIONS
C
C E) BEGIN PSEUDO-SCALAR CONTRIBUTIONS *******************
C
      IF(IPSC.NE.0) THEN
      VCPIPS = 0.D0
      VSPIPS = 0.D0
      VTPIPS = 0.D0
      VOPIPS = 0.D0

      DO 60 II=10,11
      IF(II.EQ.10) THEN
      ALM2 = ALMP8
      CPANN  = ISFAC*F62*F12
      CCRNN  = ISFAC*F62*F12
      ENDIF
      IF(II.EQ.11) THEN
      ALM2 = ALMP1
      CPANN  = ISFAC*F92*F12
      CCRNN  = ISFAC*F92*F12
      ENDIF

      CALL PHBFUN(3,X,PIM,AMM(II),ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(3,X,PIM,AMM(II),ALMP8,ALM2,FUNP)
      ELSE
      DO 61 KK=1,12
   61 FUNP(KK) = FUNX(KK)
      ENDIF

      VCPIPS=VCPIPS+FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSPIPS=VSPIPS-FACT*(CPANN*FUNP(2)+CCRNN*FUNX(2))
      VTPIPS=VTPIPS-FACT*(CPANN*FUNP(3)+CCRNN*FUNX(3))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(1,X,PIM,AMM(II),ALMP8,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(1,X,PIM,AMM(II),ALMP8,ALM2)
      ELSE
      BNONC = FNONC
      BNONS = FNONS
      BNONT = FNONT
      BNONO = FNONO
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VCPIPS=VCPIPS-FACT*(CPANN*BNONC-2*CCRNN*FNONC)/AMN
      VSPIPS=VSPIPS+FACT*(CPANN*BNONS+2*CCRNN*FNONS)/AMN
      VTPIPS=VTPIPS+FACT*(CPANN*BNONT+2*CCRNN*FNONT)/AMN
      IF(IVINC.NE.1)
     .VOPIPS =  VOPIPS + FACT*( CPANN )*BNONO/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VCPIPS =  VCPIPS + APV*FACT*CCRNN *FPVC/AMN
      VOPIPS =  VOPIPS + APV*FACT*CCRNN *FPVO/AMN
      ENDIF
      IF(IVINC.NE.1) THEN
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VCPIPS =  VCPIPS + FACT*CPANN *FOFFC/AMN
      VOPIPS =  VOPIPS + FACT*CPANN *FOFFO/AMN
      ENDIF
      ENDIF
   60 CONTINUE

      VCNN  = VCNN   + VCPIPS
      VSIGNN= VSIGNN + VSPIPS
      VTENNN= VTENNN + VTPIPS
      VSONN = VSONN  + VOPIPS
      ENDIF
C END PSEUDO-SCALAR CONTRIBUTIONS
C
C F) PION-AXIAL MESONS: *****************************************
C
      IF(IAXI.NE.0) THEN
      VCPIAX = 0.D0
      VSPIAX = 0.D0
      VTPIAX = 0.D0

      DO 70 II=12,14
      IF(II.EQ.12) THEN
      ALM2=ALMP8
      CPANN  = ISFPA*FA12*F12
      CCRNN  = ISFCR*FA12*F12
      ENDIF
      IF(II.EQ.13) THEN
      ALM2=ALMP1
      CPANN  = ISFAC*FA62*F12
      CCRNN  = ISFAC*FA62*F12
      ENDIF
      IF(II.EQ.14) THEN
      ALM2=ALMP1
      CPANN  = ISFAC*FA92*F12
      CCRNN  = ISFAC*FA92*F12
      ENDIF

C     FIRST  TERM AXIAL PROPAGATOR:
      CALL PHBFUN(6,X,PIM,AMM(II),ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(6,X,PIM,AMM(II),ALMP8,ALM2,FUNP)
      ELSE
      DO 71 KK=1,12
   71 FUNP(KK) = FUNX(KK)
      ENDIF
      VCPIAX=VCPIAX+FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSPIAX=VSPIAX+FACT*(CPANN*FUNP(2)+CCRNN*FUNX(2))
      VTPIAX=VTPIAX+FACT*(CPANN*FUNP(3)+CCRNN*FUNX(3))

C     SECOND TERM AXIAL PROPAGATOR:
      CALL PHBFUN(3,X,PIM,AMM(II),ALMP8,ALM2,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(3,X,PIM,AMM(II),ALMP8,ALM2,FUNP)
      ELSE
      DO 72 KK=1,12
   72 FUNP(KK) = FUNX(KK)
      ENDIF
      VCPIAX=VCPIAX+FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
     .        *(PIM/AMM(II))**2
      VSPIAX=VSPIAX+FACT*(CPANN*FUNP(2)+CCRNN*FUNX(2))
     .        *(PIM/AMM(II))**2
      VTPIAX=VTPIAX+FACT*(CPANN*FUNP(3)+CCRNN*FUNX(3))
     .        *(PIM/AMM(II))**2
   70 CONTINUE

      VCNN  = VCNN   + VCPIAX
      VSIGNN= VSIGNN + VSPIAX
      VTENNN= VTENNN + VTPIAX
      ENDIF
C END AXIAL MESONS
C
C BEGIN DOUBLE SCALAR/DIFFRACTIVE POTENTIALS:
C
C warning!!: in case of ITMO=0 there are more contributions, since
C       no cancellations between (//) and (X)! (later to be added)

      IF(IA2A2.EQ.1) THEN
      CPANN  = ISFPA*GD12**2
      CCRNN  = ISFCR*GD12**2
      CALL PHBFUN(5,X,AMPOM,AMPOM,2*AMPOM,2*AMPOM,FUNX)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(5,X,AMPOM,AMPOM,2*AMPOM,2*AMPOM,FUNP)
      ELSE
      DO 81 KK=1,12
   81 FUNP(KK) = FUNX(KK)
      ENDIF

      VCNN =VCNN +0.5D0*FACT*(CPANN*FUNP(1)-CCRNN*FUNX(1))
      VSONN=VSONN+0.5D0*FACT*(CPANN*FUNP(2)-CCRNN*FUNX(2))
      ENDIF

C     NON-ADIABATIC CONTRIBUTIONS:

      IF(INA.EQ.1) THEN
      IF(IEPEP.EQ.1) CALL OMSCDF(X,INA,ISPIN,ALMS8,ALMS1)
c     IF(IEPEP.EQ.1) THEN
c     DO 21 JJ=7,8
c     DO 21 KK=7,8
c     CALL FOOM(5,X,AMM(JJ),AMM(KK),ALMS1,ALMS1)
c  21 VCNN  = VCNN +0.5D0*FACT*AFM(JJ)*AFM(KK)*GS62**2*FNONC/AMN
c     ENDIF
c     IF(IEPPO.EQ.1) THEN
c     DO 22 KK=7,8
c     CALL FOOM(5,X,AMM(KK),AMPOM,ALMS1,AMPOM)
c  22 VCNN  = VCNN -FACT*AFM(KK)*GS62*(GD62+ISFAC*GD12)*
c    .                    FNONC/AMN
c     ENDIF
c     IF(IPOA2.EQ.1) THEN
c     CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
c     VCNN  = VCNN + FACT*GD62*(0.5D0*GD62+ISFAC*GD12)*
c    .                  FNONC/AMN
c     ENDIF
c     IF(IA2A2.EQ.1) THEN
c     CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
c     VCNN  = VCNN -0.5D0*FACT*GD12**2*(ISFPA-2*ISFCR)*
c    .                  FNONC/AMN
c     ENDIF
C END DOUBLE SCALAR/DIFFRACTIVE POTENTIALS
      ENDIF

c1000  CONTINUE
        ICALL=1
      RETURN
C END PIHBE ROUTINE ***************************************************
      END
C **********************************************************************
      SUBROUTINE PHBFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN)
C **********************************************************************
C
C     version: april 1996  ( 1/M^2-terms from ioff=1 included)
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     D^(0)(//)= ------------- [ --- + --- - ----------- ]  --->
C                2 om1^2 om2^2 [ om1   om2   (om1 + om2) ]
C
C     PHBFUN  = (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/ALLIN/PIM,AMP,AMY,ALLX(6)

      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     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)
     .+0d0*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*( (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)  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
      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
      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
      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 PHBFUN: KIND=',I2,' X=',F10.3,/,
C    .'  AM1,AM2=',2(F10.3,3X),'  ALM1,ALM2=',2(F10.3,3X),/,
C    .       /,' IN PHBFUN: FUN(II)=',/,5(D10.3,3X),/)
CC
c1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE FOOM(ITYP,X,AM1,AM2,ALM1,ALM2)
C **********************************************************************
C
C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO-MESON EXCHANGE
C
C     ITYP = 1 : PS-PS,  ITYP = 2 : PS-VCT, ITYP = 3 : PS-SCA,
C     ITYP = 4 : PS-DIF, ITYP = 5 : SC-DIF
C
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

      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
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*(AMES/PIM)*X*HIA
      DF4A  = -0.5D0*X*FIA
      DDF4A = -0.5D0*(X*DFIA+FIA)
      D3F4A = -0.5D0*(X*DDFIA+2*DFIA)
      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:
      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:
      G2 = FIA
      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 ))
      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 = + DF2*DG2/6.D0
      FOFFT = FOFFS
      FOFFS2= +(2*DF2*X1+DDF2)*G2/6.D0
      FOFFT2= +( -DF2*X1+DDF2)*G2/6.D0
      RETURN
  500 FNONC = 0.5D0*( DF2*DG4 + DF4*DG2 )
      RETURN
CC
c1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE EPSHBE(X,ISPIN,ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1)
C **********************************************************************
C *
C *   DATE: OCTOBER, 1995
C *
C *   THIS IS A FAST VERSION, BASED ON PAPER I.
C
C *   EPSILON-MESON EXCHANGE NN-POTENTIALS
C     ( MESON= PSEUDO-SCALAR, VECTOR, SCALAR, DIFFR.)
C *   POMERON-MESON EXCHANGE NN-POTENTIALS
C     ( MESON= PSEUDO-SCALAR, VECTOR.)
C *   VECTOR-MESON EXCHANGE NN-POTENTIALS
C     ( MESON= PSEUDO-SCALAR, VECTOR.)
C     HERE: PSEUDO-SC. = ETA,ETA'
C *
C * THIS ROUTINE: NO MASS-DIFFERENCES BETWEEN NUCCLEONS ACCOUNTED FOR
C *
C     INA = 1 : NON-ADIABATIC 1/AMN CONTRIBUTIONS INCLUDED
C     IOFF= 1 : PIONIC OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS INCLUDED

C **********************************************************************
C
C     (i) Included in ENERGY-DENOMINATORS:
C         L+R contributions included, 1/4 -> 1/2, the latter is
C         PUT IN PHBFUN, FOOM
C     (ii) Included in OPERATOR DEFINITIONS of PHBFUN:
C          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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/ITPE,IPAIR,IPIME
      COMMON/PSCOP/ALP,APV,FPI,FP62,FP92,F120,F12C,FCHPI
      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
c*    COMMON/DIFCOP/GD62,GD12,GD92
      COMMON/DIFCOP/GPOM2,GA22,GF22,GFP22
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,ALMAX

      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEPS,ASI,BSI,AM1SI,AM2SI,AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/AMMES/AMM(14),AFM(14)
C
      DIMENSION FUN(12)
C
      DATA ICALL/0/,IDOUBL/0/,NS/0/
C     DATA IPSC/1/,IVCT/1/,ISCL/1/,IDIF/1/,IAXI/1/

      DATA AMA1,AMD1,AME1/1270.D0,1285.D0,1420.D0/
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
c     SAVE AMM,AMN,FACT
      save amn,fact
C
      AMN = DSQRT(AMP*AMY)/PIM
      ALMAX=ALMP1
C
      IF(ICALL.EQ.0) THEN
        FACT = PIM
        IF(NS.EQ.1) write(6,52) INA,IPV,IOFF,IDOUBL
 52     FORMAT(//,'  IN EPSHBE:  INA=',I2,' IPV=',I2,' IOFF=',I2,
     .  ' IDOUBL=',I2,//)
        IF(NS.NE.0) write(6,53) ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1
 53     FORMAT(/,'  IN PIHBE: ALMP8=',D10.3,' ALMV8=',D10.3,' ALMS8=',
     .  D10.3,/,11X,' ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=',D10.3,/)
        ICALL=1
      ENDIF
CC
      ISFAC=4*ISPIN-3
      ISFPA=3-2*ISFAC
      ISFCR=3+2*ISFAC
C
C     CONSTRUCTION OF THE POTENTIALS ********************************
C
C BEGIN EPSILON-PSEUDO-SCALAR MESONS:
C
      IF(IPSC.EQ.1.AND.ISCL.EQ.1) THEN
      DO 40 II=7,8
      DO 40 JJ=10,11
      IF(JJ.EQ.10) THEN
      CPANN  = GS62*FP62
      CCRNN  = GS62*FP62
      ALM2   = ALMP8
      ENDIF
      IF(JJ.EQ.11) THEN
      CPANN  = GS62*FP92
      CCRNN  = GS62*FP92
      ALM2   = ALMP1
      ENDIF

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)
     .CALL FOOM(3,X,AMM(JJ),AMM(II),ALM2,ALMS1)
      IF(INA.EQ.1) THEN
      VSIGNN =  VSIGNN + AFM(II)*FACT*( CPANN-2*CCRNN )*FNONS/AMN
      VTENNN =  VTENNN + AFM(II)*FACT*( CPANN-2*CCRNN )*FNONT/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSIGNN =  VSIGNN - APV*AFM(II)*FACT*CCRNN *FPVS/AMN
      VTENNN =  VTENNN - APV*AFM(II)*FACT*CCRNN *FPVT/AMN
      ENDIF
      IF(IOFF.EQ.1) THEN
      VSIGNN =  VSIGNN - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTENNN =  VTENNN - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   40 CONTINUE
      ENDIF
C END EPSILON-PSEUDO-SCALAR MESONS:
C
C BEGIN EPSILON-VECTOR POTENTIALS:
C
      IF(ISCL.EQ.1.AND.IVCT.EQ.1) THEN
C     NON-ADIABATIC CONTRIBUTIONS:
      IF(INA.EQ.1) THEN
      DO 1 JJ=7,8
      DO 1 KK=2,3
      CALL FOOM(5,X,AMM(JJ),AMM(KK),ALMS1,ALMV8)
    1 VCNN  = VCNN - FACT*ISFAC*AFM(JJ)*AFM(KK)*
     .               GS62*FD12*FNONC/AMN
      DO 2 JJ=7,8
      CALL FOOM(5,X,AMM(JJ),AMOM,ALMS1,ALMV1)
      VCNN  = VCNN - FACT*AFM(JJ)*GS62*FD62*FNONC/AMN
      CALL FOOM(5,X,AMM(JJ),AMFI,ALMS1,ALMV1)
      VCNN  = VCNN - FACT*AFM(JJ)*GS62*FD92*FNONC/AMN
    2 CONTINUE
      ENDIF
      ENDIF
C END EPSILON-VECTOR POTENTIALS.
C
C BEGIN EPSILON-AXIAL POTENTIALS:
C
      IF(ISCL.EQ.1.AND.IAXI.EQ.1) THEN
C     NON-ADIABATIC CONTRIBUTIONS:
       IF(INA.EQ.1) THEN
      DO 3 JJ=7,8
      CALL FOOM(5,X,AMM(JJ),AMA1,ALMS1,ALMAX)
      VSIGNN  = VSIGNN + FACT*ISFAC*AFM(JJ)*GS62*FA12*FNONC/AMN
      CALL FOOM(5,X,AMM(JJ),AMD1,ALMS1,ALMAX)
      VSIGNN  = VSIGNN + FACT*AFM(JJ)*GS62*FA62*FNONC/AMN
      CALL FOOM(5,X,AMM(JJ),AME1,ALMS1,ALMAX)
      VSIGNN  = VSIGNN + FACT*AFM(JJ)*GS62*FA92*FNONC/AMN
    3 CONTINUE
       ENDIF
      ENDIF
C END EPSILON-AXIAL POTENTIALS.
C
C BEGIN POMERON-PSEUDO-SCALAR POTENTIALS:
C
      IF(IDIF.EQ.1.AND.IPSC.EQ.1) THEN
        GD62 = GPOM2
      DO 50 JJ=10,11
      IF(JJ.EQ.10) THEN
      CPANN  = GD62*FP62
      CCRNN  = GD62*FP62
      ALM2   = ALMP8
      ENDIF
      IF(JJ.EQ.11) THEN
      CPANN  = GD62*FP92
      CCRNN  = GD62*FP92
      ALM2   = ALMP1
      ENDIF

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)
     .CALL FOOM(4,X,AMM(JJ),AMPOM,ALM2,AMPOM)
      IF(INA.EQ.1) THEN
      VSIGNN =  VSIGNN - FACT*( CPANN-2*CCRNN )*FNONS/AMN
      VTENNN =  VTENNN - FACT*( CPANN-2*CCRNN )*FNONT/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSIGNN =  VSIGNN + APV*FACT*CCRNN *FPVS/AMN
      VTENNN =  VTENNN + APV*FACT*CCRNN *FPVT/AMN
      ENDIF
      IF(IOFF.EQ.1) THEN
      VSIGNN =  VSIGNN + FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTENNN =  VTENNN + FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   50 CONTINUE
      ENDIF
C
C BEGIN POMERON-VECTOR POTENTIALS:
C
      IF(IDIF.EQ.1.AND.IVCT.EQ.1) THEN
C     NON-ADIABATIC CONTRIBUTIONS:
       IF(INA.EQ.1) THEN
      DO 4 KK=2,3
      CALL FOOM(5,X,AMPOM,AMM(KK),AMPOM,ALMV8)
      VCNN  = VCNN + FACT*ISFAC*AFM(KK)*GD62*FD12*FNONC/AMN
      CALL FOOM(5,X,AMPOM,AMOM,AMPOM,ALMV1)
      VCNN  = VCNN + FACT*GD62*FD62*FNONC/AMN
      CALL FOOM(5,X,AMPOM,AMFI,AMPOM,ALMV1)
      VCNN  = VCNN + FACT*AFM(KK)*GD62*FD92*FNONC/AMN
    4 CONTINUE
       ENDIF
      ENDIF
C END POMERON-VECTOR POTENTIALS.
C
C BEGIN POMERON-AXIAL POTENTIALS:
C
      IF(IDIF.EQ.1.AND.IAXI.EQ.1) THEN
      GD62 = GPOM2
C     NON-ADIABATIC CONTRIBUTIONS:
       IF(INA.EQ.1) THEN
      CALL FOOM(5,X,AMPOM,AMA1,AMPOM,ALMAX)
      VSIGNN  = VSIGNN - FACT*ISFAC*GD62*FA12*FNONC/AMN
      CALL FOOM(5,X,AMPOM,AMD1,AMPOM,ALMAX)
      VSIGNN  = VSIGNN - FACT*GD62*FA62*FNONC/AMN
      CALL FOOM(5,X,AMPOM,AME1,AMPOM,ALMAX)
      VSIGNN  = VSIGNN - FACT*GD62*FA92*FNONC/AMN
       ENDIF
      ENDIF
C END POMERON-AXIAL POTENTIALS.
C
C BEGIN VECTOR-PSEUDO-PSEUDO-SCALAR POTENTIALS:
C
      IF(IVCT.EQ.1.AND.IPSC.EQ.1) THEN
C     ONLY EE-CONTRIBUTIONS INCLUDED, NO 1/M**2-TERMS:
      DO 30 JJ=10,11
      IF(JJ.EQ.10) FPS2 = FP62
      IF(JJ.EQ.11) FPS2 = FP92

      DO 30 II=2,5
      IF(II.LE.3) THEN
      ALM2=ALMV8
      CPAEE  = ISFAC*FD12*FPS2
      CCREE  = ISFAC*FD12*FPS2
      ENDIF
      IF(II.EQ.4) THEN
      ALM2=ALMV1
      CPAEE  = FD62*FPS2
      CCREE  = FD62*FPS2
      ENDIF
      IF(II.EQ.5) THEN
      ALM2=ALMV1
      CPAEE  = FD92*FPS2
      CCREE  = FD92*FPS2
      ENDIF
      CALL PHBFUN(1,X,AMM(JJ),AMM(II),ALMP1,ALM2,FUN)
C     EE-CONTRIBUTION:
      VSIGNN=  VSIGNN + AFM(II)*FACT*(CPAEE*FUN(1)-CCREE*FUN(11))
      VTENNN=  VTENNN + AFM(II)*FACT*(CPAEE*FUN(2)-CCREE*FUN(12))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1)
     .CALL FOOM(2,X,AMM(JJ),AMM(II),ALMP1,ALM2)
      IF(INA.EQ.1) THEN
      VSIGNN =  VSIGNN - AFM(II)*FACT*( CPAEE-2*CCREE )*FNONS/AMN
      VTENNN =  VTENNN - AFM(II)*FACT*( CPAEE-2*CCREE )*FNONT/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSIGNN =  VSIGNN + APV*AFM(II)*FACT*CCREE *FPVS/AMN
      VTENNN =  VTENNN + APV*AFM(II)*FACT*CCREE *FPVT/AMN
      ENDIF
      IF(IOFF.EQ.1) THEN
      VSIGNN =  VSIGNN + AFM(II)*FACT*CPAEE*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTENNN =  VTENNN + AFM(II)*FACT*CPAEE*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   30 CONTINUE
      ENDIF
C END VECTOR-PSEUDO-SCALAR EXCHANGE
C
C BEGIN VECTOR-VECTOR POTENTIALS:
C
      IF(IVCT.EQ.1) THEN
C     ADIABATIC CONTRIBUTIONS: (RHO-RHO ONLY)
      DO 5 KK=2,3
      DO 5 JJ=2,3
      CALL PHBFUN(7,X,AMM(KK),AMM(JJ),ALMV8,ALMV8,FUN)
    5 VCNN  = VCNN - FACT*2*ISFAC*AFM(KK)*AFM(JJ)*FD12**2*FUN(1)

C     NON-ADIABATIC CONTRIBUTIONS:
       IF(INA.EQ.1) THEN
C     RHO-OMEGA, RHO-PHI, OMEGA-OMEGA ETC. CONTRIBUTIONS:
      DO 6 KK=2,3
      CALL FOOM(5,X,AMM(KK),AMOM,ALMV8,ALMV1)
      VSIGNN  = VSIGNN + FACT*ISFAC*AFM(KK)*FD12*FD62*FNONC/AMN
      CALL FOOM(5,X,AMM(KK),AMFI,ALMV8,ALMV1)
      VSIGNN  = VSIGNN + FACT*ISFAC*AFM(KK)*FD12*FD92*FNONC/AMN
    6 CONTINUE
      CALL FOOM(5,X,AMOM,AMOM,ALMV1,ALMV1)
      VSIGNN  = VSIGNN + 0.5D0*FACT*FD62**2*FNONC/AMN
      CALL FOOM(5,X,AMOM,AMFI,ALMV1,ALMV1)
      VSIGNN  = VSIGNN + FACT*FD62*FD92*FNONC/AMN
      CALL FOOM(5,X,AMFI,AMFI,ALMV1,ALMV1)
      VSIGNN  = VSIGNN + 0.5D0*FACT*FD92**2*FNONC/AMN
       ENDIF
      ENDIF
C END VECTOR-VECTOR POTENTIALS.
C
C BEGIN VECTOR-AXIAL POTENTIALS:
C
      IF(IVCT.EQ.1.AND.IAXI.EQ.1) THEN
C     NON-ADIABATIC CONTRIBUTIONS:
       IF(INA.EQ.1) THEN
C     OMEGA CONTRIBUTIONS:
      CALL FOOM(5,X,AMOM,AMA1,ALMV1,ALMAX)
      VSIGNN  = VSIGNN - FACT*ISFAC*FD62*FA12*FNONC/AMN
      CALL FOOM(5,X,AMOM,AMD1,ALMV1,ALMAX)
      VSIGNN  = VSIGNN - FACT*FD62*FA62*FNONC/AMN
      CALL FOOM(5,X,AMOM,AME1,ALMV1,ALMAX)
      VSIGNN  = VSIGNN - FACT*FD62*FA92*FNONC/AMN
       ENDIF
      ENDIF
C END VECTOR-AXIAL POTENTIALS.
      IF(IDOUBL.EQ.0) RETURN
      IF(IDOUBL.EQ.1) THEN
C
C BEGIN DOUBLE SCALAR/DIFFRACTIVE POTENTIALS:
C
      IF(IDIF.EQ.1) THEN
      GD12 = GA22
      CPANN  = ISFPA*GD12**2
      CCRNN  = ISFCR*GD12**2
      CALL PHBFUN(5,X,AMPOM,AMPOM,2*AMPOM,2*AMPOM,FUN)
      VCNN  =  VCNN  + 0.5D0*FACT*( CPANN-CCRNN )*FUN(1)
      VSONN =  VSONN + 0.5D0*FACT*( CPANN-CCRNN )*FUN(2)
      ENDIF

C     NON-ADIABATIC CONTRIBUTIONS:
      IF(INA.EQ.1) THEN
       IF(ISCL.EQ.1) THEN
      DO 21 JJ=7,8
      DO 21 KK=7,8
      CALL FOOM(5,X,AMM(JJ),AMM(KK),ALMS1,ALMS1)
   21 VCNN  = VCNN +0.5D0*FACT*AFM(JJ)*AFM(KK)*GS62**2*FNONC/AMN
       ENDIF
       IF(ISCL.EQ.1.AND.IDIF.EQ.1) THEN
      DO 22 KK=7,8
      CALL FOOM(5,X,AMM(KK),AMPOM,ALMS1,AMPOM)
   22 VCNN  = VCNN -FACT*AFM(KK)*GS62*(GD62+ISFAC*GD12)*
     .                    FNONC/AMN
       ENDIF
       IF(IDIF.EQ.1) THEN
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      VCNN  = VCNN + FACT*GD62*(0.5D0*GD62+ISFAC*GD12)*
     .                  FNONC/AMN
      CALL FOOM(5,X,AMPOM,AMPOM,AMPOM,AMPOM)
      VCNN  = VCNN -0.5D0*FACT*GD12**2*(ISFPA-2*ISFCR)*
     .                  FNONC/AMN
       ENDIF
      ENDIF
C END DOUBLE SCALAR/DIFFRACTIVE POTENTIALS
      ENDIF

c1000  CONTINUE
      RETURN
C END EPSHBE ROUTINE ***************************************************
      END

C **********************************************************************
      SUBROUTINE NNPSBE(X,ISPIN,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0)
C **********************************************************************
C     VERSION WITH OPTIONAL "TMO" (AUGUST 1998)
C     ITMO = 0 : NO TMO, ITMO = 1 : YES TMO
C-----------------------------------------------------------------------
C *
C *   DATE: JUNE 1996 , NNPSBE = COMPLEMENT PIHBE
C *
C *   THIS IS A FAST VERSION, BASED ON PAPER I.
C
C *   1) (ETA,ETA')-MESON EXCHANGE NN-POTENTIALS,
C        MESON= VECTOR, SCALAR, DIFFR.
C *   2)  KAON-MESON EXCHANGE NN-POTENTIALS,
C        MESON= K*, KAPPA, K** (DOUBLE STRANGENESS EXCHANGE)
C *
C     PS-SCAL: ALMP0 = SU(3)-SINGLET, ALMP1 = SU(3)-OCTET
C     VECTOR : ALMV0 = SU(3)-SINGLET, ALMV1 = SU(3)-OCTET
C     SCALAR : ALMS0 = SU(3)-SINGLET, ALMS1 = SU(3)-OCTET
C *
C     IPV = 1 : PV-THEORY,  IPV = 0 : PS-THEORY!
C     INA = 1 : NON-ADIABATIC 1/AMN CONTRIBUTIONS INCLUDED
C     IOFF= 1 : PIONIC OFF-ENERGY-SHELL 1/AMN CONTRIBUTIONS INCLUDED

C **********************************************************************
C     CALL PHBFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN):
C
C     KIND=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     FUN(8) = OPAEMS2 FUN(9) = OPAEMT2 FUN(10)= OPAEMO2
C     FUN(11)= OCREES  FUN(12)= OCREET
C     KIND=2, PION-SCALAR EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C     KIND=4, PION-DIFFRACTIVE EXCHANGE:
C     FUN(1) = OSCS    FUN(2) = OSCT    FUN(3) = OSCO
C **********************************************************************
C
C     (i) Included in ENERGY-DENOMINATORS:
C         L+R contributions included, 1/4 -> 1/2, the latter is
C         put in PHBFUN,FOOM, DKBFUN,DKBOOM.
C     (ii) Included in OPERATOR DEFINITIONS of PHBFUN,DKBFUN, factor 2:
C          1 <-> 2 interchange effects for non-identical mesons.
C     (iii) Included in CPANN etc.: factor 1/2: for IDENTICAL PARTICLES
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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VCENNN,VSIGNN,VTENNN,VSONN,VSO2,FUI,DFUI,
     .       FUISS,DFUISS,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
c     COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/PSCOP/ALP,APV,FPI,FP62,FP92,FPS20,F12C,FCHPI

      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
c*    COMMON/DIFCOP/GD62,GD12,GD92
      COMMON/DIFCOP/GPOM2,GA22,GF22,GFP22
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,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

      COMMON/ALLPS/PIM0,PIMP,AME,AMX
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEPS,ASI,BSI,AM1SI,AM2SI,AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      COMMON/BWOMS/BNONC,BNONS,BNONT,BNONO,BPVC,BPVS,BPVT,BPVO
     .            ,BOFFC,BOFFS,BOFFT,BOFFO,BOFFS2,BOFFT2
      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/PSBE/
     .VPSPS(1,4,4,4),VPSVC(1,4,4,4),VPSSC(1,4,4,4),VPSDF(1,4,4,4)
      COMMON/OMPSBE/
     .OPSPS(4,4,4),OPSVC(4,4,4),OPSSC(4,4,4),OPSDF(4,4,4)
     .,OPSXX(4,4,4,3)
C
      COMMON/AMMES/AMM(14),AFM(14)
C STORAGE:
C         AMM(1)=PIM, AMM(2)=AMRO1, AMM(3)=AMRO2, AMM(4)=AMOM,
C         DFM(1)  : PION, DFM(2): RHO , DFM(3): OME ETC.
C
      DIMENSION FUN(12),FUNP(12)
      REAL*8 KAPPA(4)
C
      DATA ITMO/0/,NSCHR/0/,ICALL/0/
      DATA IPSC/1/,IVCT/1/,ISCL/1/,IDIF/1/,IAXI/0/,IPSC2/0/,ITEN/0/
      DATA IKAKS/1/,IKAKSC/1/,IKAKSS/1/
c     DATA AFM/14*1.D0/

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/,
     . SR2/1.41421356D0/,SR6/2.44948974D0/,SR3/1.732051D0/
      DATA AMA1/1270.D0/,AMD1/1285.D0/,AME1/1420.D0/,DAM/230.D0/
      DATA AMK/495.86D0/,AMKS/892.6D0/,AMSCK/890.D0/,
     .     AMYL/1115.D0/,AMYS/1195.D0/,PIMC/139.D0/
c     SAVE AMM,AMN,FACT
      save amn,fact
C
      AMN = DSQRT(AMP*AMY)/PIM
        FP  = FPI*(PIM/PIMC)
        F12 =FP*FP
        F42 =(1.D0+2*ALP)**2*F12*(PIM/PIMC)**2/3.D0
        F52 =(1.D0-2*ALP)**2*F12*(PIM/PIMC)**2
        F62 =FP62*(PIM/PIMC)**2
        F92 =FP92*(PIM/PIMC)**2
        KAPPA(1)=0.D0
        KAPPA(2)=0.D0
        KAPPA(3)=0.D0
        KAPPA(4)=0.D0
        IF(FD12.NE.0.D0) KAPPA(1)=FDV1/FD12
        KAPPA(2)=KAPPA(1)
        IF(FD62.NE.0.D0) KAPPA(3)=FDV6/FD62
        IF(FD92.NE.0.D0) KAPPA(4)=FDV9/FD92
C
      IF(ICALL.EQ.0) THEN
        AMN  = AMPRO/PIM
c       DAM  = 0.5D0*(AMYL+AMYS-AMP-AMY)
        FACT = PIM

        AMM(1) =PIM
        AMM(2) =AM1RO
        AMM(3) =AM2RO
        AMM(4) =AMOM
        AMM(5) =AMFI
        AMM(6) =AMD
        AMM(7) =AM1SI
        AMM(8) =AM2SI
        AMM(9) =AMSST
        AMM(10)=AME
        AMM(11)=AMX
        AMM(12)=AMA1
        AMM(13)=AMD1
        AMM(14)=AME1
        DO 13 KK=1,14
   13   AFM(KK)=1.D0
        AFM(2) = ARO
        AFM(3) = BRO
        AFM(7) = ASI
        AFM(8) = BSI
        if(nschr.ne.0) write(6,52) INA,IPV,IOFF,IVINC,ITMO, IPSC,IVCT,
     .            ISCL,IDIF,IAXI,IPSC2,ITEN
 52     FORMAT(//,' IN NNPSBE: INA  =',I2,' IPV  =',I2,' IOFF=',I2,
     .  ' IVINC=',I2,' ITMO =',I2,/,11X,
     .  ' IPSC =',I2,' IVCT =',I2,' ISCL =',I2,' IDIF =',I2,
     .  ' IAXI =',I2, ' IPSC2=',I2,' ITEN =',I2)
        if(nschr.ne.0) write(6,53) ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0
 53     FORMAT(/,' IN NNPSBE: ALMP1=',D10.3,' ALMV1=',D10.3,' ALMS1=',
     .  D10.3,/,11X,' ALMP0=',D10.3,' ALMV0=',D10.3,' ALMS0=',D10.3,/)
c       ICALL=1
      ENDIF
CC
      ISFAC=4*ISPIN-3
C
C     CONSTRUCTION OF THE POTENTIALS
C
C     BEGIN (ETA,ETA')-MESON POTENTIALS:

      DO 10 JJ=10,11
      IF(JJ.EQ.10) THEN
      FPS2=F62
      ALMPS = ALMP1
      M = 3
      ENDIF
      IF(JJ.EQ.11) THEN
      FPS2=F92
      ALMPS = ALMP0
      M = 4
      ENDIF
      AMPS=AMM(JJ)

C B)  BEGIN ETA-VECTOR-MESON POTENTIALS: ******************
C
      IF(IVCT.NE.0) THEN
      VCPIVC = 0.D0
      VSPIVC = 0.D0
      VTPIVC = 0.D0
      VOPIVC = 0.D0

      DO 30 II=2,5
      IF(II.LE.3) THEN
      N = 1
      ALM2=ALMV1
C     EE-CONTRIBUTION:
      CPAEE  = ISFAC*FD12*FPS2
      CCREE  = ISFAC*FD12*FPS2
C     MM-CONTRIBUTION:
      CPAMM  = ISFAC*FD12*FPS2*((1.D0+KAPPA(II-1))/AMN)**2
      CCRMM  = ISFAC*FD12*FPS2*((1.D0+KAPPA(II-1))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = ISFAC*FD12*FPS2*(1.D0+KAPPA(II-1))/AMN**2
      CCREM1 = ISFAC*FD12*FPS2*(1.D0+KAPPA(II-1))/AMN**2
      CPAEM2 = ISFAC*FD12*FPS2*(1.D0+2*KAPPA(II-1))/AMN**2
      CCREM2 = ISFAC*FD12*FPS2*(1.D0+2*KAPPA(II-1))/AMN**2
      ENDIF
      IF(II.EQ.4) THEN
      N = 3
      ALM2=ALMV0
C     EE-CONTRIBUTION:
      CPAEE  = FD62*FPS2
      CCREE  = FD62*FPS2
C     MM-CONTRIBUTION:
      CPAMM  = FD62*FPS2*((1.D0+KAPPA(3))/AMN)**2
      CCRMM  = FD62*FPS2*((1.D0+KAPPA(3))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = FD62*FPS2*(1.D0+KAPPA(3))/AMN**2
      CCREM1 = FD62*FPS2*(1.D0+KAPPA(3))/AMN**2
      CPAEM2 = FD62*FPS2*(1.D0+2*KAPPA(3))/AMN**2
      CCREM2 = FD62*FPS2*(1.D0+2*KAPPA(3))/AMN**2
      ENDIF
      IF(II.EQ.5) THEN
      N = 4
      ALM2=ALMV0
C     EE-CONTRIBUTION:
      CPAEE  = FD92*FPS2
      CCREE  = FD92*FPS2
C     MM-CONTRIBUTION:
      CPAMM  = FD92*FPS2*((1.D0+KAPPA(4))/AMN)**2
      CCRMM  = FD92*FPS2*((1.D0+KAPPA(4))/AMN)**2
C     EM-CONTRIBUTION:
      CPAEM1 = FD92*FPS2*(1.D0+KAPPA(4))/AMN**2
      CCREM1 = FD92*FPS2*(1.D0+KAPPA(4))/AMN**2
      CPAEM2 = FD92*FPS2*(1.D0+2*KAPPA(4))/AMN**2
      CCREM2 = FD92*FPS2*(1.D0+2*KAPPA(4))/AMN**2
      ENDIF

      CALL PHBFUN(1,X,AMPS,AMM(II),ALMPS,ALM2,FUN)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(1,X,AMPS,AMM(II),ALMPS,ALM2,FUNP)
      ELSE
      DO 31 KK=1,12
   31 FUNP(KK) = FUN(KK)
      ENDIF

C     EE-CONTRIBUTION:
      VSPIVC=VSPIVC + AFM(II)*FACT*(CPAEE*FUNP(1)-CCREE*FUN(11))
      VTPIVC=VTPIVC + AFM(II)*FACT*(CPAEE*FUNP(2)-CCREE*FUN(12))
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               AFM(II)*FACT*(CPAEE*FUNP(1)-CCREE*FUN(11))

C     1/M^2-TERMS:
C     EM-CONTRIBUTION:
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAEM1*FUNP(3)+CCREM1*FUN(3))/2.D0
      VOPIVC=VOPIVC+AFM(II)*FACT*(CPAEM1*FUNP(4)-CCREM1*FUN(4))/2.D0

      VSPIVC=VSPIVC+AFM(II)*FACT*(CPAEM2*FUNP(8)-CCREM2*FUN(8))/2.D0
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAEM2*FUNP(9)-CCREM2*FUN(9))/2.D0
      VOPIVC=VOPIVC+AFM(II)*FACT*(CPAEM2*FUNP(10)-CCREM2*FUN(10))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               AFM(II)*FACT *(CPAEM2*FUNP(8)-CCREM2*FUN(8))/2.D0

C     MM-CONTRIBUTION:
      VCPIVC=VCPIVC+AFM(II)*FACT*(CPAMM*FUNP(5)-CCRMM*FUN(5))/2.D0
      VSPIVC=VSPIVC+AFM(II)*FACT*(CPAMM*FUNP(6)+CCRMM*FUN(6))/2.D0
      VTPIVC=VTPIVC+AFM(II)*FACT*(CPAMM*FUNP(7)+CCRMM*FUN(7))/2.D0
      VPSVC(1,1,M,N)=VPSVC(1,1,M,N) +
     .               AFM(II)*FACT*(CPAMM*FUNP(5)-CCRMM*FUN(5))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               AFM(II)*FACT*(CPAMM*FUNP(6)+CCRMM*FUN(6))/2.D0

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(2,X,AMPS,AMM(II),ALMPS,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(2,X,AMPS,AMM(II),ALMPS,ALM2)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPIVC=VSPIVC-AFM(II)*FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      VTPIVC=VTPIVC-AFM(II)*FACT*(CPAEE*BNONT-2*CCREE*FNONT)/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) -
     .               AFM(II)*FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPIVC =  VSPIVC + APV*AFM(II)*FACT*CCREE *FPVS/AMN
      VTPIVC =  VTPIVC + APV*AFM(II)*FACT*CCREE *FPVT/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) +
     .               APV*AFM(II)*FACT*CCREE *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPIVC =  VSPIVC + AFM(II)*FACT*CPAEE *(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPIVC =  VTPIVC + AFM(II)*FACT*CPAEE *(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   30 CONTINUE

      VCENNN = VCENNN + VCPIVC
      VSIGNN = VSIGNN + VSPIVC
      VTENNN = VTENNN + VTPIVC
      VSONN  = VSONN  + VOPIVC
      ENDIF
C END ETA-VECTOR EXCHANGE
C
C C) BEGIN ETA-SCALAR MESONS: ********************************
C
      IF(ISCL.NE.0) THEN
      VCPISC = 0.D0
      VSPISC = 0.D0
      VTPISC = 0.D0
      VOPISC = 0.D0

      DO 40 II=6,9
      IF(II.EQ.6) THEN
      N = 1
      ALM2=ALMS1
      CPANN  = ISFAC*GS12*FPS2
      CCRNN  = ISFAC*GS12*FPS2
      ENDIF
      IF(II.EQ.7.OR.II.EQ.8) THEN
      N = 3
      ALM2=ALMS0
      CPANN  = GS62*FPS2
      CCRNN  = GS62*FPS2
      ENDIF
      IF(II.EQ.9) THEN
      N = 4
      ALM2=ALMS0
      CPANN  = GS92*FPS2
      CCRNN  = GS92*FPS2
      ENDIF

      CALL PHBFUN(2,X,AMPS,AMM(II),ALMPS,ALM2,FUN)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(2,X,AMPS,AMM(II),ALMPS,ALM2,FUNP)
      ELSE
      DO 41 KK=1,12
   41 FUNP(KK) = FUN(KK)
      ENDIF
      VSPISC=VSPISC+AFM(II)*FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
      VTPISC=VTPISC+AFM(II)*FACT*(CPANN*FUNP(2)-CCRNN*FUN(2))
      VOPISC=VOPISC+AFM(II)*FACT*(CPANN*FUNP(3)-CCRNN*FUN(3))
      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+
     .               AFM(II)*FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(3,X,AMPS,AMM(II),ALMPS,ALM2)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(3,X,AMPS,AMM(II),ALMPS,ALM2)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPISC=VSPISC+AFM(II)*FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTPISC=VTPISC+AFM(II)*FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N)+
     .             AFM(II)*FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPISC =  VSPISC - APV*AFM(II)*FACT*CCRNN *FPVS/AMN
      VTPISC =  VTPISC - APV*AFM(II)*FACT*CCRNN *FPVT/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N)-
     .             APV*AFM(II)*FACT*CCRNN *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPISC =  VSPISC - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPISC =  VTPISC - AFM(II)*FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   40 CONTINUE

      VCENNN = VCENNN + VCPISC
      VSIGNN = VSIGNN + VSPISC
      VTENNN = VTENNN + VTPISC
      VSONN  = VSONN  + VOPISC
      ENDIF
C END SCALAR MESONS
C
C D) BEGIN DIFFRACTIVE CONTRIBUTIONS *******************
C
      IF(IDIF.NE.0) THEN
      GD12 = GA22
      GD62 = GPOM2
      VCPIDF = 0.D0
      VSPIDF = 0.D0
      VTPIDF = 0.D0
      VOPIDF = 0.D0

      DO 50 II=1,2
      IF(II.EQ.1) THEN
      N = 1
      CPANN  = ISFAC*GD12*FPS2
      CCRNN  = ISFAC*GD12*FPS2
      ENDIF
      IF(II.EQ.2) THEN
      N = 3
      CPANN  = GD62*FPS2
      CCRNN  = GD62*FPS2
      ENDIF

      CALL PHBFUN(4,X,AMPS,AMPOM,ALMPS,2*AMPOM,FUN)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(4,X,AMPS,AMPOM,ALMPS,2*AMPOM,FUNP)
      ELSE
      DO 51 KK=1,12
   51 FUNP(KK) = FUN(KK)
      ENDIF
      VSPIDF=VSPIDF-FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
      VTPIDF=VTPIDF-FACT*(CPANN*FUNP(2)-CCRNN*FUN(2))
      VOPIDF=VOPIDF-FACT*(CPANN*FUNP(3)-CCRNN*FUN(3))
      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-
     .               FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1.OR.IOFF.EQ.1) THEN
      CALL FOOM(4,X,AMPS,AMPOM,ALMPS,AMPOM)
      IF(ITMO.EQ.0) THEN
      CALL BWOM(4,X,AMPS,AMPOM,ALMPS,AMPOM)
      ELSE
      BNONS = FNONS
      BNONT = FNONT
      ENDIF
      ENDIF
      IF(INA.EQ.1) THEN
      VSPIDF=VSPIDF-FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTPIDF=VTPIDF-FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSDF(2,M,N)=OPSDF(2,M,N)-
     .             FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSPIDF =  VSPIDF + APV*FACT*CCRNN *FPVS/AMN
      VTPIDF =  VTPIDF + APV*FACT*CCRNN *FPVT/AMN
      OPSDF(2,M,N)=OPSDF(2,M,N)+
     .             APV*FACT*CCRNN *FPVS/AMN
      ENDIF
      IF(IOFF.EQ.1.AND.ITMO.EQ.1) THEN
      VSPIDF =  VSPIDF + FACT*CPANN*(
     . (2*IPV-1)*FOFFS-FOFFS2)/AMN
      VTPIDF =  VTPIDF + FACT*CPANN*(
     . (2*IPV-1)*FOFFT-FOFFT2)/AMN
      ENDIF
   50 CONTINUE

      VCENNN = VCENNN + VCPIDF
      VSIGNN = VSIGNN + VSPIDF
      VTENNN = VTENNN + VTPIDF
      VSONN  = VSONN  + VOPIDF
      ENDIF
C END DIFFRACTIVE CONTRIBUTIONS
C
C
C F) BEGIN ETA-AXIAL MESONS: **********************************
C
      IF(IAXI.NE.0) THEN
      VCPIAX = 0.D0
      VSPIAX = 0.D0
      VTPIAX = 0.D0

      DO 70 II=12,14
      IF(II.EQ.12) THEN
      ALM2=ALMP1
      CPANN  = ISFAC*FA12*FPS2
      CCRNN  = ISFAC*FA12*FPS2
      ENDIF
      IF(II.EQ.13) THEN
      ALM2=ALMP0
      CPANN  = FA62*FPS2
      CCRNN  = FA62*FPS2
      ENDIF
      IF(II.EQ.14) THEN
      ALM2=ALMP0
      CPANN  = FA92*FPS2
      CCRNN  = FA92*FPS2
      ENDIF
C     FIRST  TERM AXIAL PROPAGATOR:
      CALL PHBFUN(6,X,AMPS,AMM(II),ALMPS,ALM2,FUN)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(6,X,AMPS,AMM(II),ALMPS,ALM2,FUNP)
      ELSE
      DO 71 KK=1,12
   71 FUNP(KK) = FUN(KK)
      ENDIF
      VCPIAX=VCPIAX+FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
      VSPIAX=VSPIAX+FACT*(CPANN*FUNP(2)+CCRNN*FUN(2))
      VTPIAX=VTPIAX+FACT*(CPANN*FUNP(3)+CCRNN*FUN(3))
C     SECOND TERM AXIAL PROPAGATOR:
      CALL PHBFUN(3,X,AMPS,AMM(II),ALMPS,ALM2,FUN)
      IF(ITMO.EQ.0) THEN
      CALL BWFUN(3,X,AMPS,AMM(II),ALMPS,ALM2,FUNP)
      ELSE
      DO 72 KK=1,12
   72 FUNP(KK) = FUN(KK)
      ENDIF
      VCPIAX=VCPIAX+FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
     .        *(PIM/AMM(II))**2
      VSPIAX=VSPIAX+FACT*(CPANN*FUNP(2)+CCRNN*FUN(2))
     .        *(PIM/AMM(II))**2
      VTPIAX=VTPIAX+FACT*(CPANN*FUNP(3)+CCRNN*FUN(3))
     .        *(PIM/AMM(II))**2
   70 CONTINUE

      VCENNN = VCENNN + VCPIAX
      VSIGNN = VSIGNN + VSPIAX
      VTENNN = VTENNN + VTPIAX
      ENDIF
C END AXIAL MESONS
C
   10 CONTINUE
C
C END (ETA,ETA')-MESON POTENTIALS.

C *******************************************************
C
C     BEGIN DOUBLE-STRANGENESS EXCHANGE
C
C *******************************************************
      ISFLL = (1+ISFAC)/2
      ISFLS = (3-ISFAC)
      ISFSS = (9+ISFAC)/2
      ALMKA = ALMP1
      ALMKS = ALMV1
      VCNN  = 0.D0
      VSNN  = 0.D0
      VTNN  = 0.D0
      VONN  = 0.D0
C
C G)  BEGIN KAON-KSTAR POTENTIALS: ******************
      IF(IKAKS.NE.0) THEN
      M = 2
      N = 2
      ALM2=ALMV1
C     EE-CONTRIBUTION:
      CPAEE  = 0.D0
      CCREE =  (ISFLL*FD4**2*F4**2+ISFLS*FD4*F4*FD5*F5+
     .             ISFSS*FD5**2*F5**2)
      FVE4  = FD4+FV4
      FVE5  = FD5+FV5
C     MM-CONTRIBUTION:
      CPAMM  = 0.D0
      CCRMM =  (ISFLL*FVE4**2*F4**2+ISFLS*FVE4*F4*FVE5*F5+
     .             ISFSS*FVE5**2*F5**2)/AMN**2
C     EM-CONTRIBUTION:
      CPAEM1 = 0.D0
      CCREM1=  (2*ISFLL*FVE4*FD4*F4**2+ISFLS*(FVE4*FD5+
     .         FD4*FVE5)*F4*F5+2*ISFSS*FVE5*FD5*F5**2)/AMN**2
      FVE4  = FD4+2*FV4
      FVE5  = FD5+2*FV5
      CPAEM2 = 0.D0
      CCREM2=  (2*ISFLL*FVE4*FD4*F4**2+ISFLS*(FVE4*FD5+
     .         FD4*FVE5)*F4*F5+2*ISFSS*FVE5*FD5*F5**2)/AMN**2

c     CALL PHBFUN(1,X,AMK,AMKS,ALMKA,ALMKS,FUN)
C     PRINT 1003, X,(FUN(KK),KK=1,12)
C1003 FORMAT(' PHBFUN VT: X=',F7.3,'FUN=',4(D10.3,2X),/,
C    .  25X,4(D10.3,2X),/,25X,4(D10.3,2X),//)
      CALL DKBFUN(1,X,AMK,AMKS,ALMKA,ALMKS,DAM,FUN)
C     PRINT 1004, X,(FUN(KK),KK=1,12)
C1004 FORMAT(' DKBFUN VT: X=',F7.3,'FUN=',4(D10.3,2X),/,
C    .  25X,4(D10.3,2X),/,25X,4(D10.3,2X),//)
      DO 32 KK=1,12
   32 FUNP(KK) = 0.D0

C     EE-CONTRIBUTION:
      VSNN=  VSNN + FACT*(CPAEE*FUNP(1)-CCREE*FUN(11))
      VTNN=  VTNN + FACT*(CPAEE*FUNP(2)-CCREE*FUN(12))
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               FACT*(CPAEE*FUNP(1)-CCREE*FUN(11))

C     1/M^2-TERMS:
C     EM-CONTRIBUTION:
      VTNN=VTNN+FACT*(CPAEM1*FUNP(3)+CCREM1*FUN(3))/2.D0
      VONN=VONN+FACT*(CPAEM1*FUNP(4)-CCREM1*FUN(4))/2.D0

      VSNN=VSNN+FACT*(CPAEM2*FUNP(8)-CCREM2*FUN(8))/2.D0
      VTNN=VTNN+FACT*(CPAEM2*FUNP(9)-CCREM2*FUN(9))/2.D0
      VONN=VONN+FACT*(CPAEM2*FUNP(10)-CCREM2*FUN(10))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               FACT*(CPAEM2*FUNP(8)-CCREM2*FUN(8))/2.D0

C     MM-CONTRIBUTION:
      VCNN=VCNN+FACT*(CPAMM*FUNP(5)-CCRMM*FUN(5))/2.D0
      VSNN=VSNN+FACT*(CPAMM*FUNP(6)+CCRMM*FUN(6))/2.D0
      VTNN=VTNN+FACT*(CPAMM*FUNP(7)+CCRMM*FUN(7))/2.D0
      VPSVC(1,1,M,N)=VPSVC(1,1,M,N) +
     .               FACT*(CPAMM*FUNP(5)-CCRMM*FUN(5))/2.D0
      VPSVC(1,2,M,N)=VPSVC(1,2,M,N) +
     .               FACT *( CPAMM*FUNP(6)+CCRMM*FUN(6))/2.D0

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1) THEN
c     CALL FOOM(2,X,AMK,AMKS,ALMKA,ALMKS)
C     PRINT 1001, X,FNONC,FNONS,FPVC,FPVS,FOFFC,FOFFS
C1001 FORMAT(' FOOM   VT: X=',D10.3,'FNONC,FNONS=',2(D10.3,2X),/,
C    .                        24X  ,'FPVC ,FPVS =',2(D10.3,2X),/,
C    .                        24X  ,'FOFFC,FOFFS=',2(D10.3,2X),/)

      CALL DKBOOM(2,X,AMK,AMKS,ALMKA,ALMKS,DAM)
C     PRINT 1002, X,FNONC,FNONS,FPVC,FPVS,FOFFC,FOFFS
C1002 FORMAT(' DKBOOM VT: X=',D10.3,'FNONC,FNONS=',2(D10.3,2X),/,
C    . 24X                         ,'FPVC ,FPVS =',2(D10.3,2X),/,
C    . 24X                         ,'FOFFC,FOFFS=',2(D10.3,2X),/)
      BNONS = 0.D0
      BNONT = 0.D0
      ENDIF

      IF(INA.EQ.1) THEN
      VSNN=VSNN-FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      VTNN=VTNN-FACT*(CPAEE*BNONT-2*CCREE*FNONT)/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) -
     .             FACT*(CPAEE*BNONS-2*CCREE*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSNN  =  VSNN + APV*FACT*CCREE *FPVS/AMN
      VTNN  =  VTNN + APV*FACT*CCREE *FPVT/AMN
      OPSVC(2,M,N)=OPSVC(2,M,N) +
     .             APV*FACT*CCREE *FPVS/AMN
      ENDIF
      ENDIF
C END KAON-KSTAR

C H) BEGIN KAON-KAPPA EXCHANGE POTENTIALS:
      IF(IKAKSC.EQ.1) THEN
      M = 2
      N = 2
      CPANN = 0.D0
      CCRNN =  (ISFLL*GS4**2*F4**2+ISFLS*GS4*F4*GS5*F5+
     .         ISFSS*GS5**2*F5**2)
c     CALL PHBFUN(2,X,AMK,AMSCK,ALMKA,ALMS1,FUN)
      CALL DKBFUN(2,X,AMK,AMSCK,ALMKA,ALMS1,DAM,FUN)
      DO 42 KK=1,12
   42 FUNP(KK) = 0.D0

      VSNN=VSNN+FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
      VTNN=VTNN+FACT*(CPANN*FUNP(2)-CCRNN*FUN(2))
      VPSSC(1,2,M,N)=VPSSC(1,2,M,N)+
     .               FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1) THEN
C     CALL FOOM(3,X,AMK,AMSCK,ALMKA,ALMS1)
      CALL DKBOOM(3,X,AMK,AMSCK,ALMKA,ALMS1,DAM)
      BNONS = 0.D0
      BNONT = 0.D0
      ENDIF

      IF(INA.EQ.1) THEN
      VSNN=VSNN+FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTNN=VTNN+FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N)+
     .             FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSNN  =  VSNN - APV*FACT*CCRNN *FPVS/AMN
      VTNN  =  VTNN - APV*FACT*CCRNN *FPVT/AMN
      OPSSC(2,M,N)=OPSSC(2,M,N)-
     .             APV*FACT*CCRNN *FPVS/AMN
      ENDIF
      ENDIF
C END KAON-KAPPA

C I) BEGIN KAON-K** EXCHANGE POTENTIALS:
      IF(IKAKSS.EQ.1) THEN
      M = 2
      N = 2
      CPANN = 0.D0
      CCRNN =  (ISFLL*GD4**2*F4**2+ISFLS*GD4*F4*GD5*F5+
     .         ISFSS*GD5**2*F5**2)
c     CALL PHBFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,FUN)
      CALL DKBFUN(4,X,AMK,AMPOM,ALMKA,AMPRO,DAM,FUN)
      DO 54 KK=1,12
   54 FUNP(KK) = 0.D0

      VSNN=VSNN-FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))
      VTNN=VTNN-FACT*(CPANN*FUNP(2)-CCRNN*FUN(2))
      VPSDF(1,2,M,N)=VPSDF(1,2,M,N)-
     .               FACT*(CPANN*FUNP(1)-CCRNN*FUN(1))

C     1/M-CORRECTIONS:
      IF(INA.EQ.1.OR.IPV.EQ.1) THEN
C     CALL FOOM(4,X,AMK,AMPOM,ALMKA,AMPOM)
      CALL DKBOOM(4,X,AMK,AMPOM,ALMKA,AMPOM,DAM)
      BNONS = 0.D0
      BNONT = 0.D0
      ENDIF

      IF(INA.EQ.1) THEN
      VSNN=VSNN-FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      VTNN=VTNN-FACT*(CPANN*BNONT-2*CCRNN*FNONT)/AMN
      OPSDF(2,M,N)=OPSDF(2,M,N)-
     .             FACT*(CPANN*BNONS-2*CCRNN*FNONS)/AMN
      ENDIF
      IF(IPV.EQ.1) THEN
      VSNN  =  VSNN + APV*FACT*CCRNN *FPVS/AMN
      VTNN  =  VTNN + APV*FACT*CCRNN *FPVT/AMN
      OPSDF(2,M,N)=OPSDF(2,M,N)+
     .             APV*FACT*CCRNN *FPVS/AMN
      ENDIF
      ENDIF
C END KAON-K**

      VCENNN=  VCENNN + VCNN
      VSIGNN=  VSIGNN + VSNN
      VTENNN=  VTENNN + VTNN
      VSONN =  VSONN  + VONN

c  1  CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writetm(2,x)
      if(icall.eq.0.and.nschr.eq.1) call writetm(3,x)
      if(icall.eq.0.and.nschr.eq.1) call writetm(4,x)
      if(icall.eq.0.and.nschr.eq.1) call wromtm(2,x)
      if(icall.eq.0.and.nschr.eq.1) call wromtm(3,x)
      if(icall.eq.0.and.nschr.eq.1) call wromtm(4,x)
      icall=1

c1000  CONTINUE
      RETURN
C END NNPSBE ROUTINE ***************************************************
      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/ALLIN/PIM,AMP,AMY,ALLX(6)

      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)
     .+0d0*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
      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
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
c1000  CONTINUE
      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/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      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
        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
c10000 CONTINUE
      RETURN
      END

C **********************************************************************
c*************************************************************
      subroutine gauleg(x1,x2,x,w,n,nt)
c*************************************************************
c     Given the lower and upper limits of integration x1 and x2,
c     and given n, this routine returns arrays x(1:n) and w(1:n)
c     of length n, containing the abscissas and weights of the
c     Gaussian-Legendre n-point quadrature formula
c
c     int_{x1}^{x2} f(x) dx => \sum_{j=1}^{n} w_j f(x_j)
c
c     if interval is splitted in two: a1-a2, a2-a3 then
c     mapping (-1,+1) onto these two intervals 12 and 23:
c     p12(i) = 0.5(a2-a1) x(i) + 0.5(a2+a1), w12(i)=0.5(a2-a1);
c     p23(i) = 0.5(a3-a2) x(i) + 0.5(a3+a2), w23(i)=0.5(a3-a2);

c     this routine:
c     nt=1: interval (x1-x2)
c     nt=2; intervals (x1-xmp) and (xmp-x2), xmp= (x1+x2)/2

c     eps: relative precision
c-------------------------------------------------------------
      implicit real*8(a-h,o-z)
      dimension x(*),w(*)
      data nprnt/0/
      parameter (eps=3.d-14)

      pi=dacos(-1.d0)
c     roots are symmetric in the interval:
      m=(n+1)/2
      if(nt.eq.1) then
      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      endif
      if(nt.eq.2) then
      xmp=0.5d0*(x2+x1)
      xm=0.5d0*(xmp+x1)
      xl=0.5d0*(xmp-x1)
      endif
c     loop over desired roots:
      do 12 i=1,m
      z=dcos(pi*(i-0.25d0)/(n+0.5d0))
c     Starting with appoximation z for the root, the main
c     Refinement by Newton-method is entered:
    1 continue
      p1=1.d0
      p2=0.d0
c     Loop up the recurrence relation to get the Legendre
c     polynomial evaluated at z:
      do 11 j=1,n
      p3=p2
      p2=p1
      p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
   11 continue
c     p1: desired Legendre polynomial,
c     pp: derivative of p1, using p2, the polynomial of lower order:

      pp=n*(z*p1-p2)/(z*z-1.d0)

c     Newton's method:
      z1=z
      z=z1-p1/pp
      if(dabs(z-z1).gt.eps) goto 1
c     Scale root to the desired interval:
      x(i)=xm-xl*z
c     Symmetric counterpart:
      x(n+1-i)=xm+xl*z
      w(i)=2*xl/((1.d0-z*z)*pp*pp)
      w(n+1-i)=w(i)
   12 continue

      if(nt.eq.2) then
      do 14 i=1,n
        x(n+i) = x(i)+0.5d0*(x2-x1)
        w(n+i) = w(i)
   14 continue
      endif

      if(nprnt.eq.1) then
      npnt=nt*n
      write(6,9) (x(k),k=1,npnt)
    9 format(' gauleg: x=',/, 4(d22.15,2x),/)
      write(6,8) (w(k),k=1,npnt)
    8 format(' gauleg: w=',/, 4(d22.15,2x),/)
      endif

      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*************************************************************
* 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

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 FNFUN(N,X,AMES,ALAM,F,DF,DDF,D3F,D4F)
C **********************************************************************
C
C                                                 1
C     FOURIER TRANSFORM OF  F(OMEGA)= (4 PI) x ---------
C                                              OMEGA^{N}
C     FOR N=0,1,2,3,4;   X = DISTANCE IN PION-WAVE-LENGTH
C
C     DF = DF/DX, DDF = D^2 F/DX^2, ETC. , X = PIM*R
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)
c     COMMON/PIMAS/PIM
      COMMON/ALLIN/PIM,XXXX(8)

      DIMENSION XX(20),WW(20),YB(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
c     DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/
      DATA YB/0.D0,10.D0,50.D0/,NINT/2/,NPNT/16/,IMETH/0/
      SAVE PI,SRPI,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
        PI = DACOS(-1.D0)
        SRPI= DSQRT(PI)
        CALL GAUSS(NPNT,XX,WW,1)
        IF(IMETH.EQ.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
      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)
      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
      D4F   = (ALAM/PIM)**2*D4VKUA
      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
      D3HIA =-(AMES/PIM)*DDFIA-DDHIA*X1+2*DHIA*X2-2*HIA*X3
      D4FIA =-(D3FIA-2*D3VKUA)*X1+3*(DDFIA-2*DDVKUA)*X2-(AMES/PIM)
     .       *D3HIA-6*(DFIA-2*DVKUA)*X3+6*(FIA-2*VKUA)*X4
      F = FIA
      DF = DFIA
      DDF = DDFIA
      D3F = D3FIA
      D4F = D4FIA
      IF(N.EQ.2) RETURN
      ENDIF
      IF(N.EQ.4) THEN
      D4HIA =-(AMES/PIM)*D3FIA-D3HIA*X1+3*DDHIA*X2-6*DHIA*X3
     .       +6*HIA*X4
      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)
      D4F  = 0.5D0*(AMES/PIM)*(4*D3HIA+X*D4HIA)
      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
      D3GG =0.D0
      D4GG =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
      DDHIM  =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2
      D3FIM =-(DDFIM-2*DDVKUA)*X1+(DFIM-2*DVKUA)*X2-(AM/PIM)*DDHIM
     .       +(DFIM-2*DVKUA)*X2-2*(FIM-2*VKUA)*X3
      D3HIM =-(AM/PIM)*DDFIM-DDHIM*X1+2*DHIM*X2-2*HIM*X3
      D4FIM =-(D3FIM-2*D3VKUA)*X1+3*(DDFIM-2*DDVKUA)*X2-(AMES/PIM)
     .       *D3HIM-6*(DFIM-2*DVKUA)*X3+6*(FIM-2*VKUA)*X4

      IF(N.EQ.1) THEN
      GG    = GG   + GEW*FIM* FDISP
      DGG   = DGG  + GEW*DFIM* FDISP
      DDGG  = DDGG + GEW*DDFIM* FDISP
      D3GG  = D3GG + GEW*D3FIM* FDISP
      D4GG  = D4GG + GEW*D4FIM* 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)
      D3GG  = D3GG + GEW*(D3FIA-D3FIM* FDISP)
      D4GG  = D4GG + GEW*(D4FIA-D4FIM* FDISP)
      ENDIF
C
110   CONTINUE
100   CONTINUE
C
      F = GG
      DF = DGG
      DDF = DDGG
      D3F = D3GG
      D4F = D4GG
      ENDIF
CC
      RETURN
      END

C **********************************************************************
      SUBROUTINE BWFUN(KIND,X,AM1,AM2,ALM1,ALM2,FUN)
C **********************************************************************
C
C     COMPUTATION FUNCTIONS FOR THE BRUCKNER-WATSON_{//} DENOMINATORS
C-----------------------------------------------------------------------
C     version: april 1996  ( 1/M^2-terms from ioff=1 included)
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      ]
C     D^(0)_{BW}(//)= - ------------- [ ----------- ]  --->
C                       2 om1^2 om2^2 [ (om1 + om2) ]
C
C     BWFUN  = (-1/PI) INT_{0}^{\INFTY} (D LAM/ LAM**2)
C
C              [    1              1         ]
C            X [ -------  - ---------------- ]
C              [ OM1^{2}   (OM1^{2}+LAM^{2}) ]
C
C              [    1              1         ]
C            X [ -------  - ---------------- ]
C              [ OM2^{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/ALLIN/PIM,AMP,AMY,ALLX(6)

      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     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)
     .+0d0*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*( (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)  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
      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
      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
      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
C     PLANAR BW-FUNCTIONS:

      GI1   = FI1-FDISP1*FIM1
      DGI1  = DFI1-FDISP1*DFIM1
      DDGI1 = DDFI1-FDISP1*DDFIM1
      D3GI1 = D3FI1-FDISP1*D3FIM1
      D4GI1 = D4FI1-FDISP1*D4FIM1

      GI2   = FI2-FDISP2*FIM2
      DGI2  = DFI2-FDISP2*DFIM2
      DDGI2 = DDFI2-FDISP2*DDFIM2
C
      IF(KIND.EQ.1) THEN
      FUN(1)  = FUN(1)  - GEW*
     .  OPAEES(GI2,DGI2,DDGI2,DGI1,DDGI1,D3GI1,X)
      FUN(2)  = FUN(2)  - GEW*
     .   OPAEET(GI2,DGI2,DDGI2,DGI1,DDGI1,D3GI1,X)
c     FUN(11) = FUN(11) + GEW*(
c    .   OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP*
c    .   OCREES(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X))
c     FUN(12) = FUN(12) + GEW*(
c    .   OCREET(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FI1,X)-FDISP*
c    .   OCREET(FIM2,DFIM2,DDFIM2,DFIM1,DDFIM1,D3FIM1,D4FIM1,X))
      FUN(3)  = FUN(3)  - GEW*OPAEMT(DGI2,DGI1,DDGI1,X)
      FUN(4)  = FUN(4)  - GEW*OPAEMO(DGI2,DGI1,X)
      FUN(5)  = FUN(5)  - GEW*OPAMMC(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(6)  = FUN(6)  - GEW*OPAMMS(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(7)  = FUN(7)  - GEW*OPAMMT(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(8)  = FUN(8)  - GEW*OPEMS2(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(9)  = FUN(9)  - GEW*OPEMT2(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(10) = FUN(10) - GEW*OPEMO2(DGI2,DGI1,X)
      ENDIF
C
      IF(KIND.EQ.2.OR.KIND.EQ.4) THEN
      FUN(1)  = FUN(1)  - GEW*OSCS(GI2,DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(2)  = FUN(2)  - GEW*OSCT(GI2,DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(3)  = FUN(3)  - GEW*OSCO(DGI2,DGI1,X)
      ENDIF
C
      IF(KIND.EQ.3) THEN
      FUN(1)  = FUN(1)  - GEW*OPSC(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(2)  = FUN(2)  - GEW*OPSS(DGI2,DDGI2,DGI1,DDGI1,X)
      FUN(3)  = FUN(3)  - GEW*OPST(DGI2,DDGI2,DGI1,DDGI1,X)
      ENDIF
C
      IF(KIND.EQ.5) THEN
      FUN(1)  = FUN(1)  - GEW*ODFC(GI2,DGI2,DDGI2,GI1,DGI1,DDGI1,X)
      FUN(2)  = FUN(2)  - GEW*ODFO(GI2,DGI2,GI1,DGI1,X)
      ENDIF
C
      IF(KIND.EQ.6) THEN
      FUN(1)  = FUN(1)  - GEW*OAXC(GI2,DGI1,DDGI1,X)
      FUN(2)  = FUN(2)  - GEW*OAXS(GI2,DGI1,DDGI1,X)
      FUN(3)  = FUN(3)  - GEW*OAXT(GI2,DGI1,DDGI1,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
c     FUN(11)= FUN(11)+(1.D0/PI)*
c    .OCREES(FI2,DFI2,DDFI2,DFI1,DDFI1,D3FI1,D4FIM1,X)/YMAX
c     FUN(12)= FUN(12)+(1.D0/PI)*
c    .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 BWFUN: KIND=',I2,' X=',F10.3,/,
C    .'  AM1,AM2=',2(F10.3,3X),'  ALM1,ALM2=',2(F10.3,3X),/,
C    .       /,' IN BWFUN: FUN(II)=',/,5(D10.3,3X),/)
CC
c1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE BWOM(ITYP,X,AM1,AM2,ALM1,ALM2)
C **********************************************************************
C     COMPUTATION FUNCTIONS FOR THE BRUCKNER-WATSON_{//} DENOMINATORS
C-----------------------------------------------------------------------
C
C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO-MESON EXCHANGE
C
C     ITYP = 1 : PS-PS,  ITYP = 2 : PS-VCT, ITYP = 3 : PS-SCA,
C     ITYP = 4 : PS-DIF, ITYP = 5 : SC-DIF
C
C-----------------------------------------------------------------------
C
C     COMPUTES THE FOURIER TRANSFORMS OF
C
C                             1
C     D^(1)_{BW}(//)= - -------------
C                       2 om1^3 om2^3
C
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLIN/PIM,AMP,AMY,ALLX(6)
      COMMON/BWOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2

      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
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
      CALL FFUN(3,X,AMES,ALAM,FIA,DFIA,DDFIA,D3FIA)
      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
      F3A  = FIA*RATD*2/SRPI
      DF3A = DFIA*RATD*2/SRPI
      DDF3A= DDFIA*RATD*2/SRPI
      D3F3A= D3FIA*RATD*2/SRPI
      DF4A = -0.5D0*X*FIA
      ENDIF
      IF(IMES.EQ.1) THEN
C     N=3:
      F3 = FIA
      DF3 = DFIA
      DDF3 = DDFIA
      D3F3 = D3FIA
      ENDIF
      IF(IMES.EQ.2) THEN
C     N=3:
      G3 = FIA
      DG3 = DFIA
      DDG3 = DDFIA
      D3G3 = D3FIA
      DG4  = -0.5D0*X*FIA
      ENDIF
    1 CONTINUE
C
C     CONSTRUCTION BASE FUNCTIONS
C
      GOTO(100,200,200,200,500), ITYP

  100 FNONC = -0.5D0*(
     .         6*X2*(DDF3-X1*DF3)*(DDG3-X1*DG3)+D3F3*D3G3 )
      FNONS = +(1.D0/3.D0)*(
     .  X2*(DDF3-X1*DF3-X*D3F3)*(DDG3-X1*DG3-X*D3G3)-D3F3*D3G3 )
      FNONT = -(1.D0/6.D0)*(
     .        4*X2*(DDF3-X1*DF3-X*D3F3/4)*(DDG3-X1*DG3-X*D3G3/4)
     .       -D3F3*D3G3/4    )
      FNONO = +2*X2*( (DDF3-X1*DF3)*(DDG3-X1*DG3) )

      FPVC  = 0.D0
      FPVO  = 0.D0

      FOFFC = 0.D0
      FOFFO = 0.D0
      RETURN
  200 FNONS = -0.5D0*( (D3F3+2*X1*DDF3-2*X2*DF3)*DG3 )/3.D0
      FNONT = -0.5D0*( (D3F3-  X1*DDF3+  X2*DF3)*DG3 )/3.D0
      FPVS  = 0.D0
      FPVT  = 0.D0
      FOFFS = 0.D0
      FOFFT = 0.D0
      FOFFS2= 0.D0
      FOFFT2= 0.D0
      RETURN
c????? check: DG4 = ??????????????????
  500 FNONC = -0.5D0*( DF3*DG4 )
      RETURN
CC
*000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE BMNFUN(M,N,X,AM1,AM2,ALM1,ALM2,FUN)
C **********************************************************************
C
C     NOTE: B_{M,N} = H_{M-1,N)(A=0,OM1,OM2)
C
C     FOURIER TRANSFORM OF
C                                 1              1
C     B_{M,N}(OM1,OM2) = ------------------ -----------
C                          OM1^{M} OM2^{N}  (OM1 + OM2)
C
C     FOR (M,N) = (-1,-1),(-1,1),(1,-1),(0,0),(1,1),(2,2)
C     FOR (M,N) = (12,12): SPECIAL NA, B^NA-FUNCTIONS
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/ALLIN/PIM,ALLX(8)
      DIMENSION XX(20),WW(20),YB(3),FUN(10)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
c*    DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/
      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/
      SAVE XX,WW
C ----------------------------------------------------------------------
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 ----------------------------------------------------------------------
C
      IF(ICALL.EQ.0) THEN
        CALL GAUSS(NPNT,XX,WW,1)
        IF(IMETH.LE.1) NINT=1
C       PRINT 52, IMETH,NPNT
C52     FORMAT(//,'  IN BMNFUN: 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)
      D3VKU1 =-0.5D0*(ALM1/PIM)**2*(2*DVKU1+X*DDVKU1)
      FI10   =(ALM1/PIM)**2*VKU1
      DFI10  =(ALM1/PIM)**2*DVKU1
      DDFI10 =(ALM1/PIM)**2*DDVKU1
      D3FI10 =(ALM1/PIM)**2*D3VKU1

      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)
      D3VKU2 =-0.5D0*(ALM2/PIM)**2*(2*DVKU2+X*DDVKU2)
      FI20   =(ALM2/PIM)**2*VKU2
      DFI20  =(ALM2/PIM)**2*DVKU2
      DDFI20 =(ALM2/PIM)**2*DDVKU2
      D3FI20 =(ALM2/PIM)**2*D3VKU2

      IF(M.EQ.2.OR.N.EQ.2.OR.(M.EQ.12.AND.N.EQ.12)) 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+(DFIA-2*DVKU1)*X2-(AM1/PIM)*DDHIA
     .       +(DFIA-2*DVKU1)*X2-2*(FIA-2*VKU1)*X3
      FI1= FIA
      DFI1= DFIA
      DDFI1= DDFIA
      D3FI1= D3FIA

      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
      DDHIA =-(AM2/PIM)*DFIA-DHIA*X1+HIA*X2
      D3FIA =-(DDFIA-2*DDVKU2)*X1+(DFIA-2*DVKU2)*X2-(AM2/PIM)*DDHIA
     .       +(DFIA-2*DVKU2)*X2-2*(FIA-2*VKU2)*X3
      FI2= FIA
      DFI2= DFIA
      DDFI2= DDFIA
      D3FI2= D3FIA
      ENDIF
C
C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION
C
      DO 105 IFUN=1,10
  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*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
      Y2 = Y*Y
C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :
      FDISP1=FDEXP(-Y2*RATP1*RATP1)
      FDISP2=FDEXP(-Y2*RATP2*RATP2)
C
      AM=PIM*DSQRT((AM1/PIM)**2+Y2)
      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
      IF(M.EQ.12) THEN
      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
      D3FIM1  = D3FIM
      ENDIF
C
      AM=PIM*DSQRT((AM2/PIM)**2+Y2)
      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
      IF(N.EQ.12) THEN
      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2
      D3FIM =-(DDFIM-2*DDVKU2)*X1+(DFIM-2*DVKU2)*X2-(AM/PIM)*DDHIM
     .       +(DFIM-2*DVKU2)*X2-2*(FIM-2*VKU2)*X3
      D3FIM2  = D3FIM
      ENDIF
C
      IF(M.EQ.1.AND.N.EQ.1) THEN
      WGHTH= GEW * 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
C
      IF(M.EQ.0.AND.N.EQ.0) THEN
      WGHTH= GEW*Y2 * 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
C
      IF(M.EQ.-1.AND.N.EQ.1) THEN
      WGHTH= GEW * FDISP1*FDISP2
      FUN(1)  = FUN(1)  + WGHTH*(FI10-Y2*FIM1)*FIM2
      FUN(2)  = FUN(2)  + WGHTH*(DFI10-Y2*DFIM1)*FIM2
      FUN(3)  = FUN(3)  + WGHTH*(FI10-Y2*FIM1)*DFIM2
      FUN(4)  = FUN(4)  + WGHTH*(DFI10-Y2*DFIM1)*DFIM2
      FUN(5)  = FUN(5)  + WGHTH*(DDFI10-Y2*DDFIM1)*FIM2
      FUN(6)  = FUN(6)  + WGHTH*(FI10-Y2*FIM1)*DDFIM2
      FUN(7)  = FUN(7)  + WGHTH*(DDFI10-Y2*DDFIM1)*DFIM2
      FUN(8)  = FUN(8)  + WGHTH*(DFI10-Y2*DFIM1)*DDFIM2
      FUN(9)  = FUN(9)  + WGHTH*(DDFI10-Y2*DDFIM1)*DDFIM2
      ENDIF
C
      IF(M.EQ.1.AND.N.EQ.-1) THEN
      WGHTH= GEW * FDISP1*FDISP2
      FUN(1)  = FUN(1)  + WGHTH*FIM1*(FI20-Y2*FIM2)
      FUN(2)  = FUN(2)  + WGHTH*DFIM1*(FI20-Y2*FIM2)
      FUN(3)  = FUN(3)  + WGHTH*FIM1*(DFI20-Y2*DFIM2)
      FUN(4)  = FUN(4)  + WGHTH*DFIM1*(DFI20-Y2*DFIM2)
      FUN(5)  = FUN(5)  + WGHTH*DDFIM1*(FI20-Y2*FIM2)
      FUN(6)  = FUN(6)  + WGHTH*FIM1*(DDFI20-Y2*DDFIM2)
      FUN(7)  = FUN(7)  + WGHTH*DDFIM1*(DFI20-Y2*DFIM2)
      FUN(8)  = FUN(8)  + WGHTH*DFIM1*(DDFI20-Y2*DDFIM2)
      FUN(9)  = FUN(9)  + WGHTH*DDFIM1*(DDFI20-Y2*DDFIM2)
      ENDIF
C
      IF(M.EQ.-1.AND.N.EQ.-1) THEN
      WGHTH= GEW * FDISP1*FDISP2
      FUN(1)  = FUN(1)  + WGHTH*(FI10-Y2*FIM1)*(FI20-Y2*FIM2)
      FUN(2)  = FUN(2)  + WGHTH*(DFI10-Y2*DFIM1)*(FI20-Y2*FIM2)
      FUN(3)  = FUN(3)  + WGHTH*(FI10-Y2*FIM1)*(DFI20-Y2*DFIM2)
      FUN(4)  = FUN(4)  + WGHTH*(DFI10-Y2*DFIM1)*(DFI20-Y2*DFIM2)
      FUN(5)  = FUN(5)  + WGHTH*(DDFI10-Y2*DDFIM1)*(FI20-Y2*FIM2)
      FUN(6)  = FUN(6)  + WGHTH*(FI10-Y2*FIM1)*(DDFI20-Y2*DDFIM2)
      FUN(7)  = FUN(7)  + WGHTH*(DDFI10-Y2*DDFIM1)*(DFI20-Y2*DFIM2)
      FUN(8)  = FUN(8)  + WGHTH*(DFI10-Y2*DFIM1)*(DDFI20-Y2*DDFIM2)
      FUN(9)  = FUN(9)  + WGHTH*(DDFI10-Y2*DDFIM1)*(DDFI20-Y2*DDFIM2)
      ENDIF
C
      IF(M.EQ.2.AND.N.EQ.2) THEN
      WGHTH= (GEW/Y2) * FDISP1*FDISP2
      FUN(1)  = FUN(1)  + WGHTH*(FI1-FIM1)*(FI2-FIM2)
      FUN(2)  = FUN(2)  + WGHTH*(DFI1-DFIM1)*(FI2-FIM2)
      FUN(3)  = FUN(3)  + WGHTH*(FI1-FIM1)*(DFI2-DFIM2)
      FUN(4)  = FUN(4)  + WGHTH*(DFI1-DFIM1)*(DFI2-DFIM2)
      FUN(5)  = FUN(5)  + WGHTH*(DDFI1-DDFIM1)*(FI2-FIM2)
      FUN(6)  = FUN(6)  + WGHTH*(FI1-FIM1)*(DDFI2-DDFIM2)
      FUN(7)  = FUN(7)  + WGHTH*(DDFI1-DDFIM1)*(DFI2-DFIM2)
      FUN(8)  = FUN(8)  + WGHTH*(DFI1-DFIM1)*(DDFI2-DDFIM2)
      FUN(9)  = FUN(9)  + WGHTH*(DDFI1-DDFIM1)*(DDFI2-DDFIM2)
      ENDIF
C
      IF(M.EQ.12.AND.N.EQ.12) THEN
      WGHTH= (GEW/Y2) * FDISP1*FDISP2
      FUN(1)  = FUN(1)  + WGHTH*(FI1*FI2-FIM1*FIM2)
      FUN(2)  = FUN(2)  + WGHTH*(DFI1*FI2-DFIM1*FIM2)
      FUN(3)  = FUN(3)  + WGHTH*(FI1*DFI2-FIM1*DFIM2)
      FUN(4)  = FUN(4)  + WGHTH*(DFI1*DFI2-DFIM1*DFIM2)
      FUN(5)  = FUN(5)  + WGHTH*(DDFI1*FI2-DDFIM1*FIM2)
      FUN(6)  = FUN(6)  + WGHTH*(FI1*DDFI2-FIM1*DDFIM2)
      FUN(7)  = FUN(7)  + WGHTH*(DDFI1*DFI2-DDFIM1*DFIM2)
      FUN(8)  = FUN(8)  + WGHTH*(DFI1*DDFI2-DFIM1*DDFIM2)
      FUN(9)  = FUN(9)  + WGHTH*(DDFI1*DDFI2-DDFIM1*DDFIM2)
      FUN(10) = FUN(10) + WGHTH*(D3FI1*D3FI2-D3FIM1*D3FIM2)
      ENDIF
C
110   CONTINUE
100   CONTINUE

      RETURN
      END


C*****                  ************************************************
      SUBROUTINE INVERP(A,B,N)
C*****                  ************************************************
C  INVERP 1
      IMPLICIT REAL*8 (A-H,O-Z)
c     DIMENSION A(N,N),B(N,N)
      DIMENSION A(2,2),B(2,2)
      DO 4 K=1,N
      DIV=B(K,K)
      DO 1 J=1,N
      B(K,J)=B(K,J)/DIV
    1 A(K,J)=A(K,J)/DIV
      DO 4 I=1,N
      IF(I.EQ.K) GO TO 4
      DET=B(I,K)
      DO 3 J=1,N
      B(I,J)=B(I,J)-DET*B(K,J)
    3 A(I,J)=A(I,J)-DET*A(K,J)
    4 CONTINUE
      RETURN
      END

C***********************************************************************
      SUBROUTINE INVER4(A,B,N)
C*****                  ************************************************
C  INVERP 1
      IMPLICIT REAL*8 (A-H,O-Z)
c     DIMENSION A(N,N),B(N,N)
      DIMENSION A(4,4),B(4,4)
      DO 4 K=1,N
      DIV=B(K,K)
      DO 1 J=1,N
      B(K,J)=B(K,J)/DIV
    1 A(K,J)=A(K,J)/DIV
      DO 4 I=1,N
      IF(I.EQ.K) GO TO 4
      DET=B(I,K)
      DO 3 J=1,N
      B(I,J)=B(I,J)-DET*B(K,J)
    3 A(I,J)=A(I,J)-DET*A(K,J)
    4 CONTINUE
      RETURN
      END






C ******************************************************************
C     FOR ROUTINE MESONS:
C     CONTROL PARAMETERS OBE-, TME-, AND PAIR-EXCHANGES
C ******************************************************************
      BLOCK DATA MES
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/TWOMES/IBW,ITMO,IDAM
      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/PAIROM/IDAMPR,IPVPR,INAPR,IOFFPR
      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,IOMETA        ! MARCH 2009
      COMMON/DIVERS/CORR,INRS,NAPION,NAOBE,ICHIR,ISATUR
     .             ,NAVEC,NASCAL,NADIF,IGERST,IFRMF
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB
      COMMON/EXDEG /IEXD,IEXDB,IEXDT

C     CONTROL PARAMETERS:
      DATA CORR/1.D0/
cccc  DATA IGERST/0/,IFRMF/1/
****  DATA IGERST/0/,IFRMF/0/

cc    SET FOR 'NORMAL OBE' (I.E. NO RETARDATION):
c**   DATA INRS/1/,NAPION/0/,NAOBE/0/,ICHIR/0/,ISATUR/0/
      DATA INRS/1/,NAPION/1/,NAOBE/0/,ICHIR/0/,ISATUR/0/
      DATA NAVEC/0/,NASCAL/0/,NADIF/0/
      DATA CORSPS/1/,CORSV/0/,CORSA/0/,CORSB/1/
     .    ,CORTPS/1/,CORTV/0/,CORTA/0/,CORTB/1/
ccc   DATA IPV/1/,INA/1/,IOFF/1/,IVINC/0/,INEG/1/
      DATA IPV/1/,INA/1/,IOFF/1/,IVINC/0/,INEG/0/
c**   DATA IPV/1/,INA/1/,IOFF/0/,IVINC/0/,INEG/0/
      DATA IBW/3/,ITMO/3/,IDAM/0/
c**   DATA IBW/3/,ITMO/3/,IDAM/1/

cc    SET FOR 'ABNORMAL OBE' (I.E. WITH RETARDATION):
c     DATA INRS/1/,NAPION/0/,NAOBE/1/,ICHIR/0/,ISATUR/0/
c     DATA NAVEC/1/,NASCAL/1/,NADIF/1/
c     DATA IPV/1/,INA/1/,IOFF/1/,IVINC/0/
**    DATA IBW/3/,ITMO/0/,IDAM/1/
c     DATA IBW/3/,ITMO/3/,IDAM/1/

c**   DATA IDAMPR/1/,IPVPR/1/,INAPR/1/,IOFFPR/1/
      DATA IDAMPR/0/,IPVPR/1/,INAPR/1/,IOFFPR/1/
ccc   DATA IDAMPR/0/,IPVPR/0/,INAPR/0/,IOFFPR/0/
      DATA IEXD/0/,IEXDB/0/,IEXDT/0/
c*    DATA N2PR0/1/,N2PR1/1/,N2PRV/1/,N2PRA/1/,N2PRB/1/
      DATA N2PR0/0/,N2PR1/0/,N2PRV/0/,N2PRA/0/,N2PRB/0/

c*    DATA IPIPI0/0/,IPIPI1/0/,IPIRO1/0/,IPIRO0/0/,IPIOM/2/,IPISI/0/
c*   .,ISISI/0/,IPIET/0/,IPIETP/0/,IPIPOM/0/,IPIROV/0/,IPIOMV/0/
c*   .,IPIPI2/0/,IKKB0/0/,IKKB1/0/,IPSPR/0/

      DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/2/,IPISI/1/
     .,ISISI/1/,IPIET/1/,IPIETP/0/,IPIPOM/1/,IPIROV/1/,IPIOMV/1/
     .,IPIPI2/0/,IKKB0/0/,IKKB1/0/,IPSPR/0/,IOMETA/1/
c**  .,IPIPI2/1/,IKKB0/0/,IKKB1/0/,IPSPR/0/
c**  .,IPIPI2/0/,IKKB0/0/,IKKB1/0/,IPSPR/1/
      END
C ******************************************************************

C THIS MESON12.F ROUTINE IS EQUAL TO MESON02.F:
C THE DIFFERENCE IS THAT FACISO HAS BEEN REMOVED,
C SINCE IT HAS NO FUNCTION: ISOSOIN FASCTOR IS SUPPLIED
C IN MESON-ECHANGE POTENTIAL ROUTINES
C ******************************************************************
CC    SUBROUTINE MESONS(ISPIN,I3)
      SUBROUTINE MESONS(ISPIN,I3,NP,NS)
C ******************************************************************
C     CALCULATION RATIONALIZED COUPLING CONSTANTS
C ******************************************************************
C
C     OBE-PARAMETERS :
C
C   PAR( 1,I)= XS     F1     FD1    FV1   GS1    GA2    FA1    GSPAIR
C   PAR( 2,I)= XT     ALP    ALVD   ALVV  GS*    PSID   ALFAX  GVPAIR
C   PAR( 3,I)= XP     fETAP  GOM    FOM   GEPS   GPOM   FE1    FVPAIR
C   PAR( 4,I)= XD     PIONC  AM1RO  ARO   AMD    1.0    THA    GAPAIR
C   PAR( 5,I)= FACLE  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)= ALAM   ALMP1  ALMV1  PSIS8 ALMS1  AMA2   FEFF   GEPAIR
C   PAR( 9,I)= ---    ALMP0  ALMV0  THS2  ALMS0  AMPOM  ALMAX  GPIET
C   PAR(10,I)= ---    THPS   THV    THS1  AMEPS  THD    SONV   GPIETP
C   PAR(11,I)= ---    THPE   THRO   THDE  GAMEP  AHYP   SONPV  ALPAPR
C   PAR(12,I)= FACNA  APV    FDNP1  FDPP1 GEPS2  FPOMH  SONSC  ALSCPR    ! 08 FEB 2011
C   PAR(13,I)= ---    HFPI   HFD1   HFV1  ---    GPOMH  SONVPR ALVDPR
C   PAR(14,I)= ---    FCHPI  HALVD  HALVV ---    AMPOMH SONPPR ALVVPR
C   PAR(15,I)= ---    HFETP  HGOM   HFOM  ALS    GPOPP  SONSPR GPIPOM

C   PAR(16,I)= ---    ---    ---    ---   ---    ---    FB1    GTENPR
C   PAR(17,I)= ---    FFA1   ---    ---   ---    ---    ALFBX  FTENPR
C   PAR(18,I)= ---    ALFFX  GOMETA ---   GPPS2  ---    FB9    GPSPR
C   PAR(19,I)= ---    FFE1   ---    ---   ---    ---    SONVA  GPIROV
C   PAR(20,I)= AKMAX  ---    ---    ---   UPOM   ---    ALTV   GPIOMV
C
C     HERE : PHYSICAL COUPLINGS, EXCEPT FOR
C            THE SU3-SINGLET COUPLINGS GPS1 AND FD1
C ******************************************************************
C     VERSION SEPT. 2004: MODIFICATION DIFFRCTIVE COUPLINGS:
C                       POMERON(=SINGLT) + J=0 NONET: A2,f2,FP2
C ******************************************************************
C

      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/ PIM,AMPRO,AMNEU,REDM,PLAB,AK,AKS,TEM,FCTR
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,ITPE,IPAIR,IPIME,
c    .             IAXI,IPSC2,ITEN
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPS,IPIME
      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB

      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/PSCOP/ALP,APV,FP,F62,F92,F120,F12C,FCHPI
      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/VECCP2/HFD12,HFD62,HFD92,HFV12,HFV62,HFV92,
     .              HFDV1,HFDV6,HFDV9
      COMMON/SCCOP/GS12,GS62,GS92,GEPS22
      COMMON/SCCOP2/GSA12,GSA62,GSA92
      COMMON/DIFCOP/GPOM2,GA22,GF22,GFP22
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,ALMAX
      COMMON/TENCOP/GT12,GT62,GT92,FT12,FT62,FT92,GFT1,GFT6,GFT9
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLPS2/FPS21,FPS26,FPS29
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEP,ASI,BSI,AM1SI,AM2SI,AM1ST,AMD,THS
      COMMON/KAPPA/AMSCK,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK
      COMMON/ALLSC2/IOPTSC,IALGNX,ELPHI,PSIS1,PSIS8,THSD1,THSD2,
     .              GSX12,GSX62,GSX92,GSB12,GSB62,GSB92
      COMMON/ALLSC3/FS(11)
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GPIRO1,GPIRO0,GPISI ,HOPAIR
     .,GSISI ,GPIET,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA           ! MARCH 2009
      COMMON/ALFPR/ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM
     .,IPISI,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,IOMETA            ! MARCH 2009
      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB
      COMMON/PINUC/PINA0,PINB0,PINA1,PINB1
      COMMON/SU3PAR/GETA,GX0,GOMPH,GFIPH,AMV,FOM0,AS,GEPS0
      COMMON/COUPL/F(11),G(11),FD(11),FV(11),GS(11),GD(11)
      COMMON/ALLAX/FA(11),FFA(11),FB(11)
      COMMON/ALTEN/GT(11),FT(11)

      COMMON/PAROOM/IPV,INA,IOFF,IVINC,INEG
      COMMON/DIVERS/CORR,INRS,NAPION,NAOBE,ICHIR,ISATUR
     .             ,NAVEC,NASCAL,NADIF,IGERST,IFRMF
      COMMON/EXDEG /IEXD,IEXDB,IEXDT
      DIMENSION GSA(11),GSB(11),G9D(11),HFD(11),HFV(11),HFPS(11)
      DATA GSA/11*0.D0/,GSB/11*0.D0/,G9D/11*0D0/,HFD/11*0.D0/,
     .     HFV/11*0.D0/,HFPS/11*0.D0/
      DATA SR3/1.732051D0/,CONV/1.745329252D-02/,AMRO/768.D0/,
     .I3P0/1/,ICALL/0/,N2/6/,GAMOM2/4.6D0/,GAMFI2/3.6D0/,
     .AMA1/1270.D0/,IHVCT/0/

      CONV = DACOS(-1.D0)/180.D0

      RSCAL = DSQRT(PAR(15,1))
      SONV  = PAR(10,7)
      SONPV = PAR(11,7)
      SONSC = PAR(12,7)
      SONVA = PAR(19,7)
      IF(SONPV.EQ.0.D0) SONPV=1.D0
      IF(SONV .EQ.0.D0) SONV =1.D0
      IF(SONSC.EQ.0.D0) SONSC=1.D0
      IF(SONVA.EQ.0.D0) SONVA=1.D0
c*    IF(I3P0.EQ.1) THEN
c*    SONPV = SONV
c*    SONSC = SONV
c*    SONVA = SONV
c*    ENDIF
      IF(ICALL.EQ.0.and.NS.NE.0) THEN
c     WRITE(6,*)
      WRITE(6,*) ' I3P0=',I3P0,' SONPV.NE.SONV=SONSC=SONVA'
c     WRITE(6,*)
      WRITE(6,*) ' NON-LOCAL TENSOR/SPIN-SPIN PARAMETERS:'
      WRITE(6,91) CORSPS,CORSV,CORSA,CORSB,CORTPS,CORTV,CORTA,CORTB    
 91   FORMAT( ' CORSPS,CORSV,CORSA,CORSB=', 4(F4.1,2X),/,            
     .' CORTPS,CORTV,CORTA,CORTB=',4(F4.1,2X),/,72('-'))                
      WRITE(*,*)                                                    
      ENDIF
C
C     TWO POLE APPROXIMATION UNSTABLE MESONS
C
      ARO  =PAR(4,4)
      AM1RO=PAR(4,3)
      BRO  =PAR(5,4)
      AM2RO=PAR(5,3)
      ASI  =PAR(5,6)
      AM1SI=PAR(5,5)
      BSI  =PAR(6,6)
      AM2SI=PAR(6,5)
C
      FACNA=PAR(12,1)
      APV  =PAR(12,2)
c**   if(apv.eq.0.d0) apv  = 1.d0
c*    apv = 1.d0
c     G(1) =PAR(1,2)
      F(1) =PAR(1,2)*RSCAL
      ALP  =PAR(2,2)
c     GPX0 =PAR(3,2)*RSCAL
      FPX0 =PAR(3,2)*RSCAL
      THPS =PAR(10,2)
      PIMC =PAR(4,2)
      PIM0 =PAR(5,2)
      AME  =PAR(6,2)
      AMX  =PAR(7,2)
      FD(1)=PAR(1,3)*RSCAL
      ALVD =PAR(2,3)
      GOM  =PAR(3,3)*RSCAL
      THV  =PAR(10,3)
      FV(1)=PAR(1,4)*RSCAL
c     FV(9)=PAR(2,4)*RSCAL
      ALVV =par(2,4)
c     FV(6)=PAR(3,4)*RSCAL
      FOM  =par(3,4)*RSCAL
      AMOM =PAR(6,3)
      AMFI =PAR(7,3)
      GDEL =PAR(1,5)*RSCAL
      GSST =PAR(2,5)*RSCAL
      GEPS =PAR(3,5)*RSCAL
      ELPHI=PAR(6,4)
      PSIS1=PAR(7,4)
      PSIS8=PAR(8,4)
      THSD2=PAR(9,4)
      THS  =PAR(10,4)
      AMEPS=PAR(10,5)
      GAMEP=PAR(11,5)
      AMSCK=PAR(16,5)                     ! 13 AUGUSTUS 2010
      GAMSCK=PAR(17,1)                    ! 13 AUGUSTUS 2010
      ALS  =PAR(15,5)
      AMD  =PAR(4,5)
      AM1ST=PAR(7,5)
      GA2  =PAR(1,6)*RSCAL
      GPOM =PAR(3,6)*RSCAL
c     GPOMP=PAR(2,6)*RSCAL
      PSID =PAR(2,6)
      AMPOM=PAR(9,6)
      AMA2 =PAR(8,6)
      THD  =PAR(10,6)*CONV
      THPS =THPS*CONV
      THV  =THV *CONV
      THS  =THS *CONV
      THS2 =THSD2*CONV
      PSID =PSID*CONV
c*    GEPS2=PAR(12,5)*RSCAL
      HFD(1)=PAR(13,3)*RSCAL
      HALVD=PAR(14,3)
      HGOM =PAR(15,3)*RSCAL
      HFV(1)=PAR(13,4)*RSCAL
      HALVV=PAR(14,4)
      HFOM =PAR(15,4)*RSCAL

C     BRYAN-GERSTEN TWO-POLE PARAMETRIZATION BROAD EPSILON:
      IF(IGERST.EQ.1) THEN
      CALL GERSTPAR(0)           ! 13 AUGUSTUS 2010
      PAR(5,6) = ASI
      PAR(5,5) = AM1SI
      PAR(6,6) = BSI
      PAR(6,5) = AM2SI
      CALL GERSTPAR(1)           ! 13 AUGUSTUS 2010
      PAR(17,3) = ASCK             ! 13 AUGUSTUS 2010
      PAR(18,1) = AM1SCK          ! 13 AUGUSTUS 2010
      PAR(17,4) = BSCK            ! 13 AUGUSTUS 2010
      PAR(18,4) = AM2SCK          ! 13 AUGUSTUS 2010
C     CALL PARPNS               ! 2 juli 2010
      ENDIF

C     CHARGE INDEPENDENCE ETC. BREAKING PION:
      FCHPI = PAR(14,2)*RSCAL
      IF(FCHPI.EQ.0.D0) FCHPI=F(1)
C     CHARGE INDEPENDENCE ETC. BREAKING RHO:
C      FDPP1=PAR(1,3)                               ! 19 NOV 2010
      FDPP1=PAR(12,4)*RSCAL                         ! 08 FEB 2011
      FDNP1=PAR(12,3)*RSCAL
C      FDNN1=PAR(12,4)*RSCAL
      FDNN1=PAR(1,3)*RSCAL                          ! 08 FEB 2011
C      IF(FDNN1.NE.0.0D0) FD(1)=FDNN1               ! 19 NOV 2010
      IF(FDNP1.EQ.0.D0) FDNP1=FD(1)
C      IF(FDNN1.EQ.0.D0) FDNN1=FD(1)
      IF(FDPP1.EQ.0.D0) FDPP1=FD(1)                 ! 08 FEB 2011
C     CHARGE INDEPENDENCE ETC. BREAKING OMEGA:
      GOMNP = PAR(19,3)*RSCAL
      GOMNN = PAR(19,4)*RSCAL
      IF(GOMNP.EQ.0.D0) GOMNP=GOM
      IF(GOMNN.EQ.0.D0) GOMNN=GOM
      IF(I3.EQ.0) GOM=GOMNP
      IF(I3.EQ.-1) GOM=GOMNN
C     CHARGE INDEPENDENCE ETC. BREAKING A0:
      GSNP1=PAR(20,3)*RSCAL
      GSNN1=PAR(20,4)*RSCAL
      IF(GSNP1.EQ.0.D0) GSNP1=PAR(1,5)*RSCAL
      IF(GSNN1.EQ.0.D0) GSNN1=PAR(1,5)*RSCAL
C
C     CUTOFF'S
C
      IF(AMA2.EQ.0.D0) AMA2=AMPOM
      UPOM =PAR(20,5)
      IF(UPOM.EQ.0D0) UPOM=939.D0
      ALAM =PAR(8,1)
      ALMP1=PAR(8,2)
      ALMV1=PAR(8,3)
      ALMS1=PAR(8,5)
      ALMP0=PAR(9,2)
      ALMV0=PAR(9,3)
      ALMS0=PAR(9,5)
      IF(ALMP0.EQ.0.D0) ALMP0=ALMP1
      IF(ALMV0.EQ.0.D0) ALMV0=ALMV1
      IF(ALMS0.EQ.0.D0) ALMS0=ALMS1

      IF(IFRMF.EQ.1) CALL FRMF
      ALAMK=PAR(16,2)
      IF(ALAMK.EQ.0.D0) ALAMK=ALMP1
C
      FACISO= 1.D0
      IF(ICALL.EQ.0.and.NS.NE.0) THEN
      WRITE(6,*)
     .' ISOSPIN FACTOR SUPPLIED IN MESON-EXCHANGE ROUTINES:'
      WRITE(6,*) ' IN MESONS02: FACISO=',FACISO
      WRITE(6,*)
      ENDIF
C ******************************************************************
C
C  PSEUDOSCALAR COUPLING CONSTANTS
C
c     F(1) =0.5D0*G(1)*PIM/AMPRO
c     FPS0 =0.5D0*GPS0*PIM/AMPRO
      G(1) =2*AMPRO*F(1)/PIM
      GPX0 =2*AMPRO*FPX0/PIM
C
C     ETA - X0 MIXING
C
      COST =DCOS(THPS)
      SINT =DSIN(THPS)
      FP   = F(1)
c     F(9) = COST*FPX0-SINT*(4*ALP-1.D0)*F(1)/SR3
c     G(9) = COST*GPX0-SINT*(4*ALP-1.D0)*G(1)/SR3
      F(9) = (FPX0-SINT*(4*ALP-1.D0)*F(1)/SR3)/COST
      G(9) = (GPX0-SINT*(4*ALP-1.D0)*G(1)/SR3)/COST
      CALL SU3(F,ALP)
      CALL SU3(G,ALP)
      THPSD=THPS/CONV
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,300) G(9),F(9),NAPION,
     .  ALP,THPSD,SONPV,CORR,ALAMK
  300 FORMAT(72('*'),/,'PS-SCALAR MESONS SU3{1}: G9=',F9.5,
     .' F9  =',F9.5,' NAPION=',I2,/,24X,' ALP=',F9.3,' THPS=',F9.3,
     .' SONPV=',F9.3,/,24X,' CORR=',F6.2,' ALAMK=',F9.3,/)
      IF(SONPV.NE.1.D0) THEN
c*    CALL SU3SB(F,SONPV,1)
c*    CALL SU3SB(G,SONPV,1)
      CALL SU3SB03(F,ALP,SONPV)
      CALL SU3SB03(G,ALP,SONPV)
      ENDIF
      DO 3 JO=6,8
      JS=JO+3
      WOP=G(JO)
      WSP=G(JS)
      G(JS)= COST*WSP+SINT*WOP
      G(JO)=-SINT*WSP+COST*WOP
      WOV=F(JO)
      WSV=F(JS)
      F(JS)= COST*WSV+SINT*WOV
    3 F(JO)=-SINT*WSV+COST*WOV
c     F6H  =F(6)
c     F(9) = COST*FPS0+SINT*F6H
c     F(6) =-SINT*FPS0+COST*F6H
c     FETA =F(6)
c     FX0  =F(9)
C
      F12  =F(1)*F(1)
      F62  =F(6)*F(6)
      F92  =F(9)*F(9)
C ------------------------------------------------------------------
C     CHARGE SYMMETRY BREAKING ETC.:
      FNNPI = PAR(17,2)
      IF(FNNPI.EQ.0D0) FNNPI=F(1)
C     PP:
c*    IF(I3.EQ.1.OR.I3.EQ.-1) THEN
      IF(I3.EQ.1) THEN
      F120 = F(1)*F(1)
      F12C = 0.D0
      ENDIF
C     NN:
      IF(I3.EQ.-1) THEN
      F120 = FNNPI**2
      F12C = 0.D0
      ENDIF
C     NP:
      IF(I3.EQ.0) THEN
c**   F120 =-F(1)*F(1)
      F120 =-F(1)*FNNPI
       IF(ISPIN.EQ.1) THEN
c**    F12C = 2*F(1)*F(1)
       F12C = 2*FCHPI*FCHPI
       ELSE
c**    F12C =-2*F(1)*F(1)
       F12C =-2*FCHPI*FCHPI
       ENDIF
      ENDIF
C ******************************************************************
C
C  VECTOR COUPLING CONSTANTS
C
      SINT=DSIN(THV)
      COST=DCOS(THV)
c     FD(9) =COST*GOM-SINT*(4*ALVD-1.D0)*FD(1)/SR3
c     FV(9) =COST*FOM-SINT*(4*ALVV-1.D0)*FV(1)/SR3
      FD(9) =(GOM-SINT*(4*ALVD-1.D0)*FD(1)/SR3)/COST
      FV(9) =(FOM-SINT*(4*ALVV-1.D0)*FV(1)/SR3)/COST
      CALL SU3(FD,ALVD)
      CALL SU3(FV,ALVV)

      IF(SONV.NE.1.D0) THEN
cc    CALL SU3SB(FD,SONV,0)
cc    CALL SU3SB(FV,SONV,0)
      CALL SU3SB03(FD,ALVD,SONV)
      CALL SU3SB03(FV,ALVV,SONV)
      ENDIF

      THVD=THV/CONV
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,400) FD(9),FV(9),INRS,NAVEC
     .,ALVD,ALVV,THVD,SONV
     .,CORR, FDNP1,FDNN1,GOMNP,GOMNN
  400 FORMAT(72('*'),/,' VECTOR MESONS SU3{1}: FD9 =',F9.5,' FV9 ='
     .,F9.5,' INRS=',I3,' NAVEC=',I3/
     .,22X,' ALVD=',F9.3,' ALVV=',F9.3,' THVD=',F9.3,/
     .,22X,' SONV=',F9.3,' CORR=',F6.2,/
     .,22X,' CIB: FDNP1=',F9.5,' FDNN1=',F9.5,
     .' GOMNP=',F9.5,' GOMNN=',F9.5,/)
C
      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
    5 FD(JS)=-SINT*WSD+COST*WOD
C     ELECTROMAGNETC FORM-FACTOR SATURATION:
      FS10=0.5D0*(FD(6)/DSQRT(GAMOM2)+FD(9)/DSQRT(GAMFI2))
      FS20=0.5D0*(FV(6)/DSQRT(GAMOM2)+FV(9)/DSQRT(GAMFI2))
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,410) FS10,FS20
  410 FORMAT(' EMFF SATURATION: FS10=',F7.3,', FS10(exp)= 1/2',/,
     .17X,' FS20=',F7.3,', FS20(exp)=-0.06',/)
C
c     FD(9)=GOM
c     FD6H =FD(6)
c     FD(6)= COST*FD(9)+SINT*FD6H
c     FD(9)=-SINT*FD(9)+COST*FD6H
c     GOMPH=FD(6)
c     GFIPH=FD(9)
C     FOM0 =COST*FV(6)-SINT*FV(9)
C     AMV  =(1.+SR3*(SINT*(FD(6)+FV(6))+COST*(FD(9)+FV(9)))
C    ./(FD1+FV1))/4.
c     fv(9)=fom
c     fv6h =fv(6)
c     fv(6)= cost*fv(9)+sint*fv6h
c     fv(9)=-sint*fv(9)+cost*fv6h
c     fomph=fv(6)
c     ffiph=fv(9)
c     print 969, gomph,fomph,gfiph,ffiph
c969  format(/,' in mesons: gomph,fomph,gfiph,ffiph=',4(d12.5,2x),/)

c     with tensor compensation:
c     fd(1) = 0.75d0
c     fv(1) = 3.25d0

      FD12 =FD(1)*FD(1)
      FD62 =FD(6)*FD(6)
      FD92 =FD(9)*FD(9)
      FV12 =FV(1)*FV(1)
      FV62 =FV(6)*FV(6)
      FV92 =FV(9)*FV(9)
      FDV1 =FD(1)*FV(1)
      FDV6 =FD(6)*FV(6)
      FDV9 =FD(9)*FV(9)
C-------------------------------------------------------------------
C     CHARGE INDEPENDENCE ETC. BREAKING:
c     IF(PAR(5,1).NE.0.D0) THEN
      IF(I3.EQ.0) THEN
C      FD12 = -FDNN1*FD(1)+(4*ISPIN-2)*FDNP1**2
C      FD12 = FD12/(4.D0*ISPIN-3.D0)
C      FDV1 = (-0.5D0*(FD(1)+FDNN1)+(4*ISPIN-2)*FDNP1)*FV(1)
C    .       /(4.D0*ISPIN-3.D0)
      FD12 = -FDNN1*FDPP1+(4*ISPIN-2)*FDNP1**2                       ! 19 NOV 2010
      FD12 = FD12/(4.D0*ISPIN-3.D0)                                  ! 19 NOV 2010
      FDV1 = (-0.5D0*(FDPP1+FDNN1)+(4*ISPIN-2)*FDNP1)*FV(1)
     .       /(4.D0*ISPIN-3.D0)                                      ! 19 NOV 2010
      ENDIF
      IF(I3.EQ.-1) THEN
      FD12 = FDNN1**2
      FDV1 = FDNN1*FV(1)
      ENDIF
      IF(I3.EQ.1) THEN                          ! 19 NOV 2010
      FD12 = FDPP1**2                           ! 19 NOV 2010
      FDV1 = FDPP1*FV(1)                        ! 19 NOV 2010
      ENDIF                                     ! 19 NOV 2010
c     ENDIF
C ******************************************************************
C
C     SCALAR COUPLING CONSTANTS
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
C     FOR OBE-model: 2 nonets are posible:
c     IOPTSC=3
C     FOR ESC-model: only 1 nonet is assumed!!
c     IF(ITPE.EQ.1.OR.IPAIR.EQ.1.OR.IPIME.EQ.1) IOPTSC=1
      IF(ISCL.EQ.1) IOPTSC=1
      IF(ISCL.EQ.2) IOPTSC=2

C ------------------------------------------------------------------
C     WITH ONE SCALAR NONET:
C     REDEFINITION EPSILON AND S* NN-COUPLINGS:
      GEPSI = GEPS
      GSSTI = GSST
c     IF(ELPHI.LT.0.D0) ELPHI=360.D0+ELPHI
      CALL CNSTR97(ELPHI,GEPSI,GSSTI,GEPS,GSST,1)
C ------------------------------------------------------------------
C     WITH TWO SCALAR NONETS:
      IF(IOPTSC.EQ.2) THEN
      GDEL2=0.D0
      GEPS2=0.D0
      geps2= par(12,5)
      gdel2= par(14,5)
c     GDEL2=PAR(8,4)
c     GEPS2=PAR(7,4)
C 1)  SEPARATION TWO NONETS: DEL(962) AND DEL(1450) NN-COUPLINGS:
c     GDELI = GDEL
c     GDELI2= 0.D0
c     CALL CNSTR97(PSIS8,GDELI,GDELI2,GDEL,GDEL2,2)
C 2)  SEPARATION TWO NONETS: EPS(760) AND EPS(1370) NN-COUPLINGS:
c     GEPSI = GEPS
c     GEPSI2= 0.D0
c     CALL CNSTR97(PSIS1,GEPSI,GEPSI2,GEPS,GEPS2,5)
      ENDIF
C ------------------------------------------------------------------
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,502)
 502  FORMAT(72('-'))
C     WITH ONE SCALAR NONET (A LA PR D17, PRC40):
C     NONET1:
      GS(1)=GDEL
      COST =DCOS(THS)
      SINT =DSIN(THS)
      GS(9)=COST*GEPS-SINT*GSST
      GS(6)=SINT*GEPS+COST*GSST
      ALS = PAR(15,5)
C     ABANDONING 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.0D0.AND.GS(1).NE.0D0)
     .ALS  = 0.25D0*(SR3*GS(6)/GS(1)+1.D0)
      IF(ALS.EQ.0.D0.AND.DABS(GS(1)).LT.1.D-04) ALS=0.25D0
C
      CALL SU3(GS,ALS)

      IF(SONSC.NE.1.D0) THEN
c*    CALL SU3SB(GS,SONSC,1)
      CALL SU3SB03(GS,ALS,SONSC)
      ENDIF
C ------------------------------------------------------------------
C     DERIVATIVE COUPLING:
      FALS = PAR(17,6)
      IF(FALS.EQ.0D0) FALS=ALS
      FS(1) = PAR(18,6)*RSCAL
      fs(1) = 0d0
      FSST  = PAR(19,6)*RSCAL
      FEPS  = PAR(20,6)*RSCAL
      FS(9)=COST*FEPS-SINT*FSST
      FS(6)=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,GS(9),GS(6),GDEL,GEPS,GSST,
     .ALS,THSD,SONSC,NASCAL,CORR,GSNP1,GSNN1,
     .FS(9),FS(6),FS(1),FEPS,FSST,FALS
 500  FORMAT(' 1ST 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,/,
     .22X,' NASCAL=',I3,' CORR=',F6.2,/,
     .22X,' CIB: GSNP1=',F9.5,' GSNN1=',F9.5,/,
     .' DERIVATIVE COUPLINGS: FS9 =',F9.5,' FS6=',F9.5,/,22X,
     .' FDEL=',F9.5,' FEPS=',F9.5,' FSST=',F9.5,' FALS=',F9.3,/)
      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
      GS12 =GS(1)*GS(1)
      GS62 =GS(6)*GS(6)
      GS92 =GS(9)*GS(9)
      DO 56 KK=1,11
   56 GSB(KK) = GS(KK)
C     RESTORATION INPUT NN-COUPLINGS:
      GDEL = GDELLD
      GEPS = GEPSLD
      GSST = GSSTLD
C-------------------------------------------------------------------
C     CHARGE INDEPENDENCE ETC. BREAKING:
c     IF(PAR(5,1).NE.0.D0) THEN
      IF(I3.EQ.0) THEN
      GS12 = -GSNN1*GS(1)+(4*ISPIN-2)*GSNP1**2
      GS12 = GS12/(4.D0*ISPIN-3.D0)
      ENDIF
      IF(I3.EQ.-1) THEN
      GS12 = GSNN1**2
      ENDIF
c     ENDIF
C ------------------------------------------------------------------
C     NONET2:
      IF(IOPTSC.EQ.2) THEN
      GSA(1)=GDEL2
c*    ALS2 = 1.D0
      ALS2 = ALS
      IF(PAR(13,5).NE.0D0) ALS2=PAR(13,5)
      THS2 = THS
      IF(PAR(9,4).NE.0D0) THS2 = PAR(9,4)*CONV
      THSD2= THS2/CONV

      COST =DCOS(THS2)
      SINT =DSIN(THS2)
      GSA(9)  = (GEPS2-SINT*(4*ALS2-1.D0)*GDEL2/SR3)/COST
      CALL SU3(GSA,ALS2)
      IF(ICALL.EQ.0.and.NS.NE.0) THEN
      WRITE(N2,511) IOPTSC,GSA(9),GSA(6),GDEL2,GEPS2,ALS2,THSD2
 511  FORMAT(' 2ST SCALAR NONET SU3{1}: IOPTSC=',I2,' GSA(9) =',F9.5,
     .' GSA(6) =',F9.5,/,22X,' GDEL2=',F9.5,' GEPS2=',F9.5,/,22X,
     .' ALS2 =',F9.3,' THS2 =',F9.3,/)
      ENDIF

      DO 57 JO=6,8
      JS=JO+3
      WOS=GSA(JO)
      WSS=GSA(JO+3)
      GSA(JO)= COST*WSS+SINT*WOS
   57 GSA(JS)=-SINT*WSS+COST*WOS
      GSA12 =GSA(1)*GSA(1)
      GSA62 =GSA(6)*GSA(6)
      GSA92 =GSA(9)*GSA(9)
      ENDIF
C ------------------------------------------------------------------
      IF(ICALL.EQ.0.and.NS.NE.0)
     .WRITE(N2,512) IGERST,AMEPS,GAMEP,ASI,AM1SI,BSI,AM2SI
 512  FORMAT(72('-'),/,' TREATMENT BROAD EPSILON: IGERST=',I2,
     .' AMEPS=',F9.5,' GAMEP=',F9.5,//,2X,' ASI=',F9.5,' AM1SI=',F12.5,
     .' BSI=',F9.5,' AM2SI=',F12.5,/)

C ******************************************************************
C
C     COUPLING CONSTANTS DIFFRACTIVE CONTIBUTIONS
C
C ******************************************************************
C
c     ahypc = par(11,6)
c     gpom = gpom*(1D0+ahypc*(amy/am-1D0))
      GPOM2=GPOM*GPOM
      GA22 =GA2*GA2
      GF22 =0.D0
      GFP22=0.D0
      IF(GA2.EQ.0D0) PSID=0D0
      GPOM1= GPOM*DCOS(PSID)
      GPOMP= GPOM*DSIN(PSID)

      GD(1)=0D0
      GD(9)=GPOM1
      CALL SU3(GD,ALVD)
C ------------------------------------------------------------------
C     ODDERON PARAMETERS:
      GPOMH = PAR(13,6)*RSCAL
      FPOMH = PAR(12,6)*RSCAL
      AMPOMH=PAR(14,6)
C ------------------------------------------------------------------

      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,710) GPOM,GPOM1,PSID/CONV
     .,GPOMH,FPOMH,AMPOMH,PAR(19,5),PAR(17,5)
  710 FORMAT(72('*'),/,' POMERON SINGLET SU3{1}: GPOM =',F9.5,
     .' GPOM1=',F9.5,' PSID=',F9.3,/,
     .' ODDERON SINGLET SU{3}: GPOMH=',F9.5,' FPOMH=',F9.3,
     .' AMPOMH=',F9.3,/,
     .' PAULI-CORE PARAMETERS: FI51=',F9.3,' AMFI51=',F9.3,/)

      IF(GA2.NE.0D0) THEN
      G9D(1)= GA2
      ALD  = ALVD
      THD  = THV
      SOND = SONV
      SINT =DSIN(THD)
      COST =DCOS(THD)
      G9D(9) =(GPOMP-SINT*(4*ALD-1.D0)*G9D(1)/SR3)/COST
      CALL SU3(G9D,ALD)
      IF(SOND.NE.1.D0) CALL SU3SB03(G9D,ALD,SOND)
      THDD =THD/CONV
      PSIDD=PSID/CONV
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,700) G9D(1),G9D(9),NADIF,
     .  ALD,THDD,PSIDD,SOND,CORR
  700 FORMAT(72('*'),/,' DIFFRACTIVE NONET: G9D1=',F9.5,' G9D9 =',F9.5,
     .' NADIF=',I3,/,19X,' ALD =',F9.3,' THD =',F9.3,' PSID=',F9.3,/,
     .19X,' SOND=',F9.3,' CORR=',F6.2,/)
      DO 75 JO=6,8
      JS=JO+3
      WOD=G9D(JO)
      WSD=G9D(JS)
      G9D(JO)= COST*WSD+SINT*WOD
   75 G9D(JS)=-SINT*WSD+COST*WOD
      GF22 = G9D(6)**2
      GFP22= G9D(9)**2
      GPOM2= GPOM1**2
      ENDIF
C ******************************************************************
C     AXIAL COUPLING CONSTANTS
C
      FA(1)= PAR(1,7)*RSCAL
      FE1  = PAR(3,7)*RSCAL
      ALFAX= PAR(2,7)
      ALMAX= PAR(9,7)
      IF(ALMAX.EQ.0.D0) ALMAX=ALMP1
      IF(ALFAX.EQ.0.D0) ALFAX= ALP
      THA  = PAR(4,7)*CONV
      SINT=DSIN(THA)
      COST=DCOS(THA)
      FA(9) =(FE1-SINT*(4*ALFAX-1.D0)*FA(1)/SR3)/COST
      CALL SU3(FA,ALFAX)

      IF(SONVA.NE.1.D0) THEN
c*    CALL SU3SB(FA,SONVA,1)
      CALL SU3SB03(FA,ALFAX,SONVA)
      ENDIF

      THAD=THA/CONV
      ZPI = 1.D0
      IF(FA(1).NE.0.D0) THEN
      AA  = (AMA1/PIM)*F(1)/FA(1)
      ZPI = AA**2/(1.D0+AA**2)
      ENDIF
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,800) FA(1),FA(9),
     .ZPI,ALFAX,SONVA,THAD
  800 FORMAT(72('*'),/,' AXIAL MESONS: FA1=',F9.5,' FA9  =',F9.5,
     .' ZPI  =',F9.3,/,22X,'ALFAX=',F9.3,
     .' SONVA=',F9.3,' THA =',F9.3,/)
C
      DO 85 JO=6,8
      JS=JO+3
      WOA=FA(JO)
      WSA=FA(JS)
      FA(JO)= COST*WSA+SINT*WOA
   85 FA(JS)=-SINT*WSA+COST*WOA

      FA12 = FA(1)*FA(1)
      FA62 = FA(6)*FA(6)
      FA92 = FA(9)*FA(9)
C ******************************************************************
C     AXIAL DERIVATIVE COUPLING CONSTANTS
      FFA(1)= PAR(18,2)*RSCAL
      FFE1  = PAR(20,2)*RSCAL
      ALFFX = PAR(19,2)
      IF(ALFFX.EQ.0D0) ALFFX=ALFAX
      SINT=DSIN(THA)
      COST=DCOS(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) WRITE(N2,803) FFA(1),FFA(9),
     .ALFFX,SONVA,THAD
  803 FORMAT(72('*'),/,' AXIAL MESONS SU3{1}: FFA1 =',F9.3,
     .' FFA9 =',F9.3,/,22X,'ALFFX=',F9.3,
     .' SONVA=',F9.3,' THA =',F9.3,/)
      DO 89 JO=6,8
      JS=JO+3
      WOA=FFA(JO)
      WSA=FFA(JS)
      FFA(JO)= COST*WSA+SINT*WOA
   89 FFA(JS)=-SINT*WSA+COST*WOA
C ******************************************************************
      IF(IAXI.NE.2) THEN
c     FB(1)  = PAR(13,7)*RSCAL
c     FB9    = PAR(14,7)*RSCAL
      FB(1)  = 0.D0
      FB9    = 0.D0
      FEXD   = 0.D0
      ENDIF
      IF(IAXI.EQ.2.AND.IEXDB.EQ.1) THEN
      SRB  = 10.D0*AMPRO**2
      FEXD= 1.D0/DSQRT(SRB/AMPRO**2)
c     FEXD = FB(1)/G(1)
      FB(1)  = FEXD* F(1)*2*AMPRO/PIM
      FB9    = FEXD* FPX0*2*AMPRO/PIM
      PAR(16,7) = FB(1)
      PAR(18,7) = FB(9)
      ENDIF
c     IF(IAXI.EQ.2.AND.IEXDB.EQ.0) THEN
      FB(1) = PAR(16,7)*RSCAL
      ALFBX = PAR(17,7)
      FB9   = PAR(18,7)*RSCAL
c     ENDIF
      IF(ALFBX.EQ.0D0) ALFBX= ALP
C      THB  = PAR(10,2)*CONV
C     THB  = PAR(4,7)*CONV
      THB  = PAR(10,6)*CONV
      IF(THB.EQ.0D0) THB=35.26D0*CONV
      SINT=DSIN(THB)
      COST=DCOS(THB)
      FB(9) =(FB9-SINT*(4*ALFBX-1.D0)*FB(1)/SR3)/COST
      CALL SU3(FB,ALFBX)

c     IF(SONVA.NE.1.D0) THEN
c     CALL SU3SB03(FB,ALFBX,SONVA)
c     ENDIF
      THBD=THB/CONV
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,801) FB(1),FB(9),
     .IEXDB,ALFBX,THBD,SONVA
  801 FORMAT(72('*'),/,' AXIAL MESONS SU3{1}: FB1  =',F9.5,' FB9='
     .,F9.5,' IEXDB=',I3,/,22X,'ALFBX=',F9.3,' THB =',F9.3,
     .' SONVB=',F6.2,/)
C
      DO 86 JO=6,8
      JS=JO+3
      WOA=FB(JO)
      WSA=FB(JS)
      FB(JO)= COST*WSA+SINT*WOA
   86 FB(JS)=-SINT*WSA+COST*WOA
C ******************************************************************
C
C     HEAVY PSEUDO-SCALARS
C
      IF(IEXDB.EQ.0) THEN
      HFPS(1) = PAR(13,2)*RSCAL
      HFETP   = PAR(15,2)*RSCAL
c     HFPS(1) = 0.D0
c     HFETP   = 0.D0
      FEXD = 0.D0
      ENDIF
      IF(IPSC2.EQ.1.AND.IEXDB.EQ.1) THEN
      SRB  = 10.D0*AMPRO**2
      FEXD = 1.D0/DSQRT(SRB/AMPRO**2)
c     FEXD  = PAR(3,7)/F(1)
      HFPS(1) = FEXD* F(1)
      HFETP   = FEXD* FPX0
c     PAR(13,2) = HFPS(1)
c     PAR(15,2) = HFETP
      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)
      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
      FPS21 = HFPS(1)*HFPS(1)
      FPS26 = HFPS(6)*HFPS(6)
      FPS29 = HFPS(9)*HFPS(9)
C ******************************************************************
C
C  HEAVY VECTOR COUPLING CONSTANTS
C
C     INDEPENDENT OMEGA COUPLING
C
      HFD(1) = PAR(13,3)*RSCAL
      HFV(1) = PAR(13,4)*RSCAL
      HGOM   = PAR(15,3)*RSCAL
      HFOM   = PAR(15,4)*RSCAL
c     HFD(1) = 0.D0
c     HFV(1) = 0.D0
c     HGOM   = 0.D0
c     HFOM   = 0.D0
      RTOV   = 0.D0
      THHV = THV
      IF(IHVCT.EQ.1.AND.IEXD.EQ.1) THEN
C     Exchange Degeneracy ( Rijken, Thesis 1975):
      SRB  = 10.D0*AMPRO**2
      RTOV = 1.D0/DSQRT(SRB/AMPRO**2)
c     RTOV = PAR(13,3)/FD(1)
      THHV = THV
      HFD(1) = FD(1)*RTOV
      HGOM   = GOM*RTOV
      HFV(1) = FV(1)*RTOV
      HFOM   = FOM*RTOV
      ENDIF
      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)
      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
      HFD12 =HFD(1)**2
      HFD62 =HFD(6)**2
      HFD92 =HFD(9)**2
      HFV12 =HFV(1)**2
      HFV62 =HFV(6)**2
      HFV92 =HFV(9)**2
      HFDV1 =HFD(1)*HFV(1)
      HFDV6 =HFD(6)*HFV(6)
      HFDV9 =HFD(9)*HFV(9)
      IF(IEXD.EQ.1) THEN
      PAR(13,3)= HFD(1)
      PAR(14,3)= HALVD
      PAR(15,3)= HFD(6)
      PAR(13,4)= HFV(1)
      PAR(14,4)= HALVV
      PAR(15,4)= HFV(6)
      ENDIF
C ******************************************************************
C
C     TENSOR COUPLING CONSTANTS
C
c     IF(IEXD.EQ.1) PRINT 10, IEXD
c 10  FORMAT(/,' IN MESONS: TENSOR MESONS IEXD=',I2,/)
C ******************************************************************
      IF(IEXDT.EQ.0) THEN
      RTOV = 0.D0
      THT  = THV
c     THT  = 0.d0
      GT(1)= PAR(5,7)*RSCAL
      GEFF = PAR(6,7)*RSCAL
      FT(1)= PAR(7,7)*RSCAL
      FEFF = PAR(8,7)*RSCAL
cc    ALTD = ALVD
cc    ALTV = ALVV
      ALTD = 1.00D0
      ALTD = 0.00D0             ! AUGUST 2011
      ALTV = 0.275D0             ! AUGUST 2011
cc    ALTD = ALVD
cc    ALTV = ALVV
      ENDIF

      IF(ITEN.EQ.1.AND.IEXDT.EQ.1) THEN
C     Exchange Degeneracy ( Rijken, Thesis 1975):
      SRB  = 10.D0*AMPRO**2
      RTOV = 1.D0/DSQRT(SRB/AMPRO**2)
c     RTOV = PAR(5,7)/FD(1)
      rtov = 1.d0
      THT  = THV
      ALTD = ALVD
      ALTV = ALVV
      GT(1)= FD(1)*RTOV
      GEFF = GOM*RTOV
      FT(1)= FV(1)*RTOV
      FEFF = FOM*RTOV
      ENDIF
      SINT=DSIN(THT)
      COST=DCOS(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)
      THTD=THT/CONV
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,900) GT(9),FT(9),
     .INRS,ALTD,ALTV,THTD,RTOV,IEXDT
  900 FORMAT(72('*'),/,' TENSOR MESONS SU3{1}: GT9 =',F9.5,' FT9 ='
     .,F9.5,' INRS=',I3,/,22X,' ALTD=',F9.3,' ALTV=',F9.3,' THT ='
     .,F9.3,/,22X,' RTOV=',F9.3,' IEXDT=',I3,/)
C
      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
   95 GT(JS)=-SINT*WSD+COST*WOD
C
C ******************************************************************
      IF(IEXDT.EQ.1) THEN
      PAR(5,7) = FD(1)*RTOV
      PAR(6,7) = FD(6)*RTOV
      PAR(7,7) = FV(1)*RTOV
      PAR(8,7) = FV(6)*RTOV
      ENDIF
C
      GT12 =GT(1)*GT(1)
      GT62 =GT(6)*GT(6)
      GT92 =GT(9)*GT(9)
      FT12 =FT(1)*FT(1)
      FT62 =FT(6)*FT(6)
      FT92 =FT(9)*FT(9)
      GFT1 =GT(1)*FT(1)
      GFT6 =GT(6)*FT(6)
      GFT9 =GT(9)*FT(9)
C ******************************************************************

      if(icall.eq.0.and.ns.ne.0) then
      write(n2,93) g,f,fd,fv,gsb,gsa,fs,gd,g9d,fa,ffa,fb,
     .             gt,ft,hfps,hfd,hfv
      endif
   93 format(/,72('*'),/,' Coupling Constants:',/,72('-'),/,
     .'       ','  nnp  ','  ssp  ','  lsp  ','  lnk  ','  snk  ',/,
     .'       ','  nne  ','  lle  ','  sse  ','  nnx  ','  llx  ',
     .'  ssx  ',/,72('-'),/,
     .'  gps =',5f7.4,/,7x,6f7.4,//,'  fps =',5f7.4,/,7x,6f7.4,//,
     .'   fd =',5f7.4,/,7x,6f7.4,//,'   fv =',5f7.4,/,7x,6f7.4,//,
     .'   gsb=',5f7.4,/,7x,6f7.4,//,'  gsa =',5f7.4,/,7x,6f7.4,//,
     .'   fs =',5f7.4,/,7x,6f7.4,//,
     .'   gd =',5f7.4,/,7x,6f7.4,//,'  g9d =',5f7.4,/,7x,6f7.4,//,
     .'   fa =',5f7.4,/,7x,6f7.4,//,'  ffa =',5f7.4,/,7x,6f7.4,//,
     .'   fb =',5f7.4,/,7x,6f7.4,//,
     .'   gt =',5f7.4,/,7x,6f7.4,//,'   ft =',5f7.4,/,7x,6f7.4,//,
     .'  hfps=',5f7.4,/,7x,6f7.4,//,
     .'  hfd =',5f7.4,/,7x,6f7.4,//,'  hfv =',5f7.4,/,7x,6f7.4,/,
     .72('*'),//)
C ******************************************************************
C
C     PAIR COUPLINGS
C
C ------------------------------------------------------------------
C     see BLOCK DATA subprogram!!
      IF(IPAIR.EQ.1) THEN
C ------------------------------------------------------------------
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(N2,211) 
     .N2PR0,N2PR1,N2PRV,N2PRA,N2PRB,IPV,INA,IOFF
211   FORMAT(//,' IN MESONS: N2PR0,N2PR1,N2PRV,N2PRA,N2PRB=',5I2,//,
     .      11X,' IPV, INA, IOFF=',3I2,//)
C WITH CHIRAL CONSTRAINTS:
      if(icall.eq.0.and.ns.ne.0) 
     .write(6,*) 'IN MESONS: APV=',APV,' ICHIR=',ICHIR,' ISATUR=',ISATUR
      IF(ICHIR.EQ.1) CALL CHIRAL(FD(1),FV(1),GS(6))
      IF(ICHIR.EQ.1) CALL CHIR97(FP,FD(1),FV(1),GS(6))

c*    SCAL1 = PIM/PIMC
c*    SCAL2 = (PIM/PIMC)**2
      scal1 = 1.d0
      scal2 = 1.d0

c     IF(ICHIR.NE.1) THEN
      GSPAIR = PAR(1,8)*RSCAL *SCAL1
      GVPAIR = PAR(2,8)*RSCAL *SCAL2
      FVPAIR = PAR(3,8)*RSCAL *SCAL2
      GPIRO1 = PAR(4,8)*RSCAL *SCAL1
      GPIRO0 = PAR(5,8)*RSCAL *SCAL2
      GPISI  = PAR(6,8)*RSCAL *SCAL2
      HOPAIR = PAR(7,8)*RSCAL *SCAL2
      GSISI  = PAR(8,8)*RSCAL *SCAL1
      GPIET  = PAR(9,8)*RSCAL *SCAL1
      GPIETP = PAR(10,8)*RSCAL*SCAL1
c     ENDIF
C NOT SET IN ROUTINE CHIRAL:
      ALPVPR = ALP
      ALPAPR = PAR(11,8)
      ALSCPR = PAR(12,8)
      ALVDPR = PAR(13,8)
      ALVVPR = PAR(14,8)
      ALPBPR = PAR(19,1)
      IF(ALPBPR.EQ.0D0) ALPBPR=ALP
c**   ALPBPR = ALP

      GPIPOM = PAR(15,8)*RSCAL*SCAL2
      GTENPR = PAR(16,8)*RSCAL*SCAL2
      FTENPR = PAR(17,8)*RSCAL*SCAL2
      GPPS2  = PAR(18,5)*RSCAL*SCAL2
      GPSPR  = PAR(18,8)*RSCAL*SCAL2
      GOMETA = PAR(18,3)*RSCAL*SCAL2                ! MARCH 2009

c     GPIROV = PAR(19,8)*RSCAL*SCAL2
c     GPIOMV = PAR(20,8)*RSCAL*SCAL2
c     GKKB0  = PAR(11,8)*RSCAL*SCAL1
c     GKKB1  = PAR(12,8)*RSCAL*SCAL1

c     PINA0  = PAR(9,7)*RSCAL
c     PINB0  = PAR(10,7)*RSCAL
c     PINA1  = PAR(11,7)*RSCAL
c     PINB1  = PAR(12,7)*RSCAL
C ******************************************************************
C
      CALL NNPRCOP(NS)
      IF(ICALL.EQ.0.and.NS.NE.0) WRITE(6,*)
     .'*************************************************************'
      ENDIF
C
C     END OF PROGRAM COUPLING CONSTANTS
C
c     GPOPP  = PAR(15,6)
c     IF(ICALL.EQ.0.and.NS.NE.0) CALL C1C3(GEPS,GSST,GPOM,GSPAIR,GPIET,GPOPP,1)
C
      ICALL = 1
      RETURN
      END
C *********************************************************************
      SUBROUTINE CHIRAL(GRO,FRO,GEP)
C*    Imposes theoretical constraints on the pair coupling constants
C*    based on chiral Langrangians ( see paper II and notes V. Stoks)
C *********************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
C     COMMON/MESONM/AMPI,AMETA,AMETP, AMRO,AMOM,AMFI, AMA0,AMEP,AMF0,
C    .              AMPIC,AMROC,AMA0C,AWPIC,AWROC,AWA0C, AVSC
C     COMMON/MEANM/ PIM,ROM,A0M
C     COMMON/SCALIN/AMT,AMPV,AMT24
C     COMMON/COPLNG/ALPV,THPV,PV1, FPI,FETA,FETP,FPI2,FETA2,FETP2,
C    .              ALVE,THV ,GV1, GRO,GOM,GFI,  GRO2,GOM2,GFI2,
C    .              ALVM,     FV1, FRO,FOM,FFI,  FRO2,FOM2,FFI2,
C    .              ALGS,THGS,GS1, GA0,GEP,GF0,  GA02,GEP2,GF02,
C    .              GFPRO,GFPOM,GFPFI, GFMRO,GFMOM,GFMFI,
C    .              FPIC2,GROC2,FROC2,GFPROC,GFMROC,GA0C2
C     COMMON/AXPARS/AMA1,ALAMA1,GPIA1,FPIA1,AMF1,ALAMA0,SU3AX
C     COMMON/GPAIR/ GPIETA,GPIETP,GSISI, GPISIG,GPIPOM,FVPV,
C    .              GPIPI0,GPIPI1,FPIPI1,GPIRO0,GPIRO1,GPIOM
C     COMMON/PARAMS/PAR(8,5)
C *********************************************************************
      COMMON/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/PIMH,AMT,AMY,REDM,PLAB,AK,AKS,TEM,TLAB
      COMMON/ALLPR/GPIP0,GPIPI1,FPIPI1,GPIRO1,GPIRO0,GPISIG,
     .GPIOM,GSISI,GPIETA,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA  ! MARCH 2009

      DATA FPIDEC/92.4D0/, GAXI/1.2573D0/, iw/0/
      DATA PI4/12.5663706143592D0/, SQ4PI/3.54490770181103D0/
      DATA AMH1/1170D0/, AMB1/1235D0/
      DATA ROM/768.10D0/,AMA1/1230.D0/,PIM/139.5679D0/,AMOM/783.D0/

      DATA ICALL/0/, SQ2/1.4142135623731D0/, SQ6/2.4494897427832D0/
      DATA IC/-1/,NS/0/
      SAVE PIM2,ROM2,A1M2,ZM1,CHIRPAR,GROCHIR

      IF(ICALL.EQ.0) THEN
        ICALL=1
        PIM2=PIM*PIM
        ROM2=ROM*ROM
        A1M2=AMA1*AMA1
        ZM1 =ROM2/A1M2
        CHIRPAR = ZM1*(GAXI-IC*ZM1)/(2D0*FPIDEC**2)
        GROCHIR = DSQRT(1D0-ZM1)*ROM/(2D0*FPIDEC)
      ENDIF
      if(iw.eq.0.and.ns.ne.0) write(6,*) ' In Chiral:'
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' axial:',gaxi/(2d0*fpidec*sq4pi)
      if(iw.eq.0.and.ns.ne.0) write(6,*) 'vector:',grochir/sq4pi,gro
      grochir=gro*sq4pi

      GPIPI1 =-IC*PIM2*CHIRPAR/PI4
      FPIPI1 = GPIPI1 * FRO/GRO
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' pipi1:',gpipi1,' fpipi1=',fpipi1

      GPISIG = (A1M2/ROM2-2D0)*AMA1/ROM*PIM2*CHIRPAR/PI4
      if(iw.eq.0) write(6,*) ' pisig:',gpisig

      GPIRO1 = GROCHIR*PIM/FPIDEC*(GAXI-IC)/PI4
      if(iw.eq.0) write(6,*) ' piro1:',gpiro1

      GPIA1  =-GROCHIR*PIM/FPIDEC*(GAXI-IC*ZM1)/PI4
      FPIA1  = GPIA1 * FRO/GRO
      if(iw.eq.0) write(6,*) ' piA1: ',gpia1,' fpia1=',fpia1

      GPIPI0 =-(AMT/FPIDEC/PI4-GEP/SQ4PI*AMA1/ROM)*PIM/(2D0*FPIDEC)
      GSISI  = 3D0*ZM1*GPIPI0
      GPIETA = 2D0*ROM/AMA1*GPIPI0
      if(iw.eq.0) write(6,*) ' pipi0:',gpipi0,' gsisi=',gsisi,
     .            ' gpieta=',gpieta
      GORPI  = 5.D0*(PIM/AMT)
      GRO    = PAR(1,3)
      GOM    = PAR(3,3)
      GPIOMV = GORPI*GRO*(PIM/ROM)**2
      GPIROV = GORPI*GOM*(PIM/AMOM)**2
      if(iw.eq.0) write(6,*) ' gpirov=',gpirov,' gpiomv=',gpiomv
      iw=1

C*    Store the pair couplings back into the parameter matrix
      SCAL1 = PIMH/PIM
      SCAL2 = SCAL1**2
      PAR(1,8)  = GPIPI0/SCAL1
      PAR(2,8)  = GPIPI1/SCAL2
      PAR(3,8)  = FPIPI1/SCAL2
      PAR(4,8)  = GPIRO1/SCAL1
      PAR(5,8)  = GPIRO0/SCAL2
      PAR(6,8)  = GPISIG/SCAL2
      PAR(7,8)  = GPIOM /SCAL2
      PAR(8,8)  = GSISI /SCAL1
      PAR(9,8)  = GPIETA/SCAL1
      PAR(10,8) = GPIETP/SCAL1

c     PAR(11,8) = KBBB0
c     PAR(12,8) = KBBB1
      PAR(13,8) = GPIROV/SCAL2
      PAR(14,8) = GPIOMV/SCAL2
c     PAR(15,8) = GPIPOM/SCAL2

      RETURN
      END
C *********************************************************************
      SUBROUTINE CHIR97(FP,GRO,FRO,GEP)
C*    Imposes theoretical constraints on the pair coupling constants
C*    based on chiral Langrangians , see paper
C*    Nucl.Phys. A 613 (1997) 311-341, Stoks & Rijken.
C *********************************************************************
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/PIMH,AMT,AMY,REDM,PLAB,AK,AKS,TEM,TLAB
      COMMON/ALLPR/GPIP0,GPIPI1,FPIPI1,GPIRO1,GPIRO0,GPISIG,
     .GPIOM,GSISI,GPIETA,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA    ! MARCH 2009

      DATA FPIDEC/92.4D0/, GAXI/1.2573D0/,
     .AM0/653.D0/,C/-0.131D0/,EF1/222.D0/,EF2/290D0/,
     .ZPI/0.173/,ZKA/0.225D0/,ZETA8/0.236D0/
      DATA PI4/12.5663706143592D0/, SQ4PI/3.54490770181103D0/
      DATA AMH1/1170D0/, AMB1/1235D0/
      DATA ROM/768.10D0/,AMA1/1230.D0/,PIM/139.5679D0/,AMOM/783.D0/

      DATA ICALL/0/, SQ2/1.4142135623731D0/, SQ6/2.4494897427832D0/
      DATA IC/-1/,iw/0/,NS/0/
c     SAVE PIM2,ROM2,A1M2,ZM1,CHIRPAR,GROCHIR
      SAVE PIM2,ROM2,A1M2

      IF(ICALL.EQ.0) THEN
        ICALL=1
        PIM2=PIM*PIM
        ROM2=ROM*ROM
        A1M2=AMA1*AMA1
      ENDIF
      if(iw.eq.0.and.ns.ne.0) write(6,*) ' In Chir97:'

      GNNA1  = (AMA1/PIM)*FP*DSQRT((1.D0-ZPI)/ZPI)/SQ4PI
      if(iw.eq.0.and.ns.ne.0) write(6,*) ' gnna1:',gnna1

      GPIPI1 =0.25D0*(PIM/EF1)**2*(2*ZPI-1.D0)/ZPI/PI4
      FPIPI1 = GPIPI1 * FRO/GRO
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' gpipi1:',gpipi1,' fpipi1=',fpipi1

      GPISIG = 0.D0
      if(iw.eq.0.and.ns.ne.0) write(6,*) ' gpisig:',gpisig

      GPIRO1 = 2*GRO*FP/PI4
      if(iw.eq.0.and.ns.ne.0) write(6,*) ' gpiro1:',gpiro1

      GPIA1  = PIM/DSQRT(ZPI)/EF1*GRO/PI4
      FPIA1  = GPIA1 * FRO/GRO
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' gpiA1: ',gpia1,' fpia1=',fpia1

      GPIPI0 = 0.D0
      GSISI  = 0.D0
      GPIETA = 0.D0
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' gpipi0:',gpipi0,' gsisi=',gsisi,' gpieta=',gpieta
      GORPI  = 5.D0*(PIM/AMT)
      GRO    = PAR(1,3)
      GOM    = PAR(3,3)
      GPIOMV = GORPI*GRO*(PIM/ROM)**2
      GPIROV = GORPI*GOM*(PIM/AMOM)**2
      if(iw.eq.0.and.ns.ne.0) 
     .write(6,*) ' gpirov=',gpirov,' gpiomv=',gpiomv
      iw=1

C*    Store the pair couplings back into the parameter matrix
      SCAL1 = PIMH/PIM
      SCAL2 = SCAL1**2
      PAR(1,8)  = GPIPI0/SCAL1
      PAR(2,8)  = GPIPI1/SCAL2
      PAR(3,8)  = FPIPI1/SCAL2
      PAR(4,8)  = GPIRO1/SCAL1
      PAR(5,8)  = GPIRO0/SCAL2
      PAR(6,8)  = GPISIG/SCAL2
      PAR(7,8)  = GPIOM /SCAL2
      PAR(8,8)  = GSISI /SCAL1
      PAR(9,8)  = GPIETA/SCAL1
      PAR(10,8) = GPIETP/SCAL1

c     PAR(11,8) = KBBB0
c     PAR(12,8) = KBBB1
      PAR(13,8) = GPIROV/SCAL2
      PAR(14,8) = GPIOMV/SCAL2
c     PAR(15,8) = GPIPOM/SCAL2

      RETURN
      END

C *************************************************************
      SUBROUTINE CNSTR97(ELPHID,GEPS,GSST,GEPSNW,GSSTNW,NCASE)
C *************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLSC/AMEPS,GAMEP,ASI,BSI,AM1SI,AM2SI,AM1ST,AMD,THS
      DATA AMEPS2/1370.D0/,AMST2/1515.D0/,AMD2/1450.D0/
      DATA SR2/1.4142136D0/,SR3/1.732051D0/,PIM/138.041D0/
      DATA ICALL/0/,NS/0/
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/AM1ST)**2
      ENDIF
      IF(NCASE.EQ.2) THEN
      BMSI =(PIM/AMD)**2
      BMSST=(PIM/AMD2)**2
      ENDIF
      IF(NCASE.EQ.5) THEN
      BMSI =(ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2)
      BMSST=(PIM/AMEPS2)**2
      ENDIF

      CF   = DSQRT(BMSI*GEPS**2 + BMSST*GSST**2)

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

c     IF(NS.EQ.1) THEN
      IF(ICALL.LE.3) 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(ICALL.EQ.0.and.NS.NE.0) THEN
      IF(NCASE.EQ.1)
     .write(6,111) ELPHID,GEPSNW,GSSTNW,ELPHI0
c    .          ,CF,AA,BB,EPSI2
  111 FORMAT(' IN CNSTR97: ELPHID=',F8.3,' GEPSNW=',D12.5,
     .' GSSTNW=',D12.5,/,12X,' ELPHI0=',D15.8)
c    .,/,12X,' ELLIPSE PARS: CF,AA,BB,EPSI2=',4(F8.3,1X),/)
      IF(NCASE.EQ.2)
     .write(6,112) ELPHID,GEPSNW,GSSTNW,ELPHI0
  112 FORMAT(' IN CNSTR97: PSIS8D=',F8.3,' GDELNW=',D12.5,
     .' GDEL2NW=',D12.5,/,12X,' PSI80=',D15.8)
      IF(NCASE.EQ.5)
     .write(6,115) ELPHID,GEPSNW,GSSTNW,ELPHI0
  115 FORMAT(' IN CNSTR97: PSIS1D=',F8.3,' GEPSNW=',D12.5,
     .' GEPS2NW=',D12.5,/,12X,' PSI10=',D15.8)
      ENDIF
      ENDIF
      ICALL = ICALL+1
      RETURN
      END
C *************************************************************
      SUBROUTINE C1C3(GEPS,GSST,GPOM,GSPAIR,GPIET,GPOPP,NPRNT)
C *************************************************************
C     COMPUTATION 'NEXT TO LEADING ORDER' PION-NUCLEON
C     'CHIRAL' PERTURBATION CONSTANTS C1 AND C3 IN ESC-MODEL
C     IN ESC: CONTRIBUTIONS FROM EPSILON-, POMERON-, AND
C             (PIPI)_0-EXCHANGE
C -------------------------------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/CHCNST/CIEXP(2),DCIEXP(2),CITHE(2),CH2CH(2)
      COMMON/ALLSC/AMEPS,GAMEP,ASI,BSI,AM1SI,AM2SI,AM1ST,AMD,THS
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/ALFPR/ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR
      COMMON/PSCOP/ALP,APV,FP,PSDUM(5)
      DATA PIM/138.041D0/,CFPI/185.D0/,PIMC/139.57D0/
      DATA AMEP/760.D0/,GMEP/640.D0/,GMST/41.6D0/
      DATA ALMSIG/500.D0/,AMN/938.256D0/,AMPOM/307.D0/
      DATA AM33/1236.D0/,GAM33/120.D0/
      DATA AMCRS/750.D0/
      DATA ICALL/0/,IDETAIL/1/

      PI   = DACOS(-1.D0)
      PCM  = 0.5D0*DSQRT(AMEP**2-4*PIM**2)
      GSIPP= DSQRT(2*GMEP/PCM)*AMEP/PIM
      PCM  = 0.5D0*DSQRT(AM1ST**2-4*PIM**2)
      GSTPP= DSQRT(2*GMST/PCM)*AM1ST/PIM
c*    GPOPP= DSQRT(2.D0)
      IF(GPOPP.EQ.0.D0) GPOPP= 2.7D0
C     PIET CONTRIBUTION:
      GPP8S= 0.5D0*(4*ALSCPR-1.D0)*GPIET/DSQRT(3.D0)

      BMSI2=(ASI*(PIM/AM1SI)**2 + BSI*(PIM/AM2SI)**2)
      BMSI4=(ASI*(PIM/AM1SI)**4 + BSI*(PIM/AM2SI)**4)
      BMST2=(PIM/AM1ST)**2
      BMST4=(PIM/AM1ST)**4
      BMPO = (PIM/AMN)**2
C     POMERON-PIPI-VERTEX HAS EXTRA FACTOR AMN:
      BMPO = BMPO*AMN/PIM

      AA0 = (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSIPP*GEPS*BMSI2-GSTPP*GSST*BMST2
     .       +GPOPP*GPOM*BMPO
     .       +2*GSPAIR+2*GPP8S  )*4*PI
      AA1 = (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSIPP*GEPS*(BMSI4+BMSI2*(PIM/ALMSIG)**2)
     .       -GSTPP*GSST*(BMST4+BMST2*(PIM/ALMSIG)**2)
     .       +0.25D0*GPOPP*GPOM*BMPO*(PIM/AMPOM)**2
     .       +2*GSPAIR*(PIM/ALMP1)**2
     .       +2*GPP8S *(PIM/ALMP1)**2)*4*PI
      IF(AMCRS.NE.0.D0) THEN
      AA1 = AA1 + (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSIPP*GEPS*BMSI2*(PIM/AMCRS)**2
     .       -GSTPP*GSST*BMST2*(PIM/AMCRS)**2)*4*PI
      ENDIF

      C1 = (AA0+2*AA1)/16.D0
      C3 =  AA1/4.D0

C------------------------------------------------------------------
C     NUCLEON PS-COUPLING: C1=C3=0
C     NUCLEON PV-COUPLING:
C     FPV = DSQRT(4*PI)*DSQRT(0.075D0)
      FPV = DSQRT(4*PI)*FP
      GNNP= (2*AMN/PIMC)*FPV
C     NUCLEON-POLE PV-COUPLING:
      AMPLS= +APV*(2.D0-3*APV)*GNNP**2*(PIM/AMN/2.D0)
      C1NS = +(CFPI/PIMC)**2*AMPLS/16.D0
      C3NS = 0.D0
C     NUCLEON-EXCHANGE PV-COUPLING:
      AMPLU= -APV*(2.D0-1*APV)*GNNP**2*(PIM/AMN/2.D0)
      C1NU = +(CFPI/PIMC)**2*AMPLU/16.D0
      C3NU = 0.D0
C------------------------------------------------------------------
C     DEL33-RESONANCE:
      PDEL  = DSQRT((AM33**2-AMN**2-PIM**2)**2-4*AMN**2*PIM**2)
     ./(2*AM33)
C     DUMBRAISJ ET AL:
      GDNPI = DSQRT(4*PI)*(AM33/PDEL)*DSQRT(GAM33/PDEL)
C     PILKUHN:
      GDNPI = DSQRT(4*PI)*(AM33/PDEL)*DSQRT(GAM33/PDEL)
     .      * DSQRT(6.D0)*PIM/DSQRT((AMN+AM33)**2-PIM**2)
      STHRH = (AMN+PIM)**2
      AMND33= AMN+AM33

C     S-CHANNEL, DEL33-POLE CONTRIBUTION:
      AMNPI1= 1*AMN+PIM
      AMNPI2= 2*AMN+PIM
      FACM0 = 1.D0-(2/3.D0)*(AMNPI1/AM33)**2-(AMNPI2/PIM)*
     .        AM33/AMND33/3.D0+ (AMNPI2-AMNPI1*AM33/PIM)*
     .        AMN/AM33/AMND33/3.D0
      AMPL0 = -PIM*(2/3.D0)*GDNPI**2*FACM0*AMND33/(STHRH-AM33**2)
      AMPL1 = +PIM*(1/3.D0)*GDNPI**2*AMND33/(STHRH-AM33**2)
C     NOTE THAT IN DEFINITION PION-AMPl.'S FACTOR PIM RESP. PIM**3
      C1DELS= (CFPI/PIMC)**2*(AMPL0/16.D0+AMPL1/8.D0)
      C3DELS= (CFPI/PIMC)**2* AMPL1/4.D0

C     U-CHANNEL, DEL33-EXCHANGE CONTRIBUTION:
      AMNPI1= 1*AMN-PIM
      AMNPI2= 2*AMN-PIM
      DEN   = AM33**2-AMNPI1**2
      FACM0 = 1.D0-(2/3.D0)*(AMNPI1/AM33)**2+(AMNPI2/PIM/3.D0)
     .        +(2/3.D0)*(AMN/AM33)*AMNPI1/AMND33
      FACM1 = 1.D0+4*AMNPI1*PIM/AM33**2-2*PIM*AMNPI2/AMND33/AM33
      AMPL0 = +PIM*GDNPI**2*FACM0*AMND33/DEN
      AMPL1 = -(PIM**2/DEN)*AMPL0-PIM*(1/6.D0)*GDNPI**2*FACM1*
     .AMND33/DEN
      C1DELU= (CFPI/PIMC)**2*(AMPL0/16.D0+AMPL1/8.D0)
      C3DELU= (CFPI/PIMC)**2* AMPL1/4.D0
C------------------------------------------------------------------
      C1 = C1 + C1DELS + C1DELU
      C3 = C3 + C3DELS + C3DELU
C------------------------------------------------------------------

      IF(NPRNT.EQ.1) THEN
      IF(IDETAIL.EQ.0) THEN
      write(6,111) C1,C3
  111 FORMAT(//,72('-'),/,
     .' NLO CHIRAL-PT-MODEL PION-NUCLEON CONSTANTS:',/,
     .' IN C1C3: C1=',F8.3,' GEV**-1',
     .' C3=',F8.3,' GEV**-1',/,72('-'),//)
      ENDIF

      IF(IDETAIL.EQ.1) THEN
      AA01= (AMN/PIM)*(CFPI/PIM)**2*(-GSIPP*GEPS*BMSI2)*4*PI
      AA02= (AMN/PIM)*(CFPI/PIM)**2*(+GPOPP*GPOM*BMPO )*4*PI
      AA03= (AMN/PIM)*(CFPI/PIM)**2*(+2*GSPAIR)*4*PI
      AA04= (AMN/PIM)*(CFPI/PIM)**2*(+2*GPP8S )*4*PI
      AA05= (AMN/PIM)*(CFPI/PIM)**2*(-GSTPP*GSST*BMST2)*4*PI

      AA11= (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSIPP*GEPS*(BMSI4+BMSI2*(PIM/ALMSIG)**2))*4*PI
      IF(AMCRS.NE.0.D0) THEN
      AA11= AA11+ (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSIPP*GEPS*BMSI2*(PIM/AMCRS)**2)*4*PI
      ENDIF
      AA12= (AMN/PIM)*(CFPI/PIM)**2*(
     .       +0.25D0*GPOPP*GPOM*BMPO*(PIM/AMPOM)**2)*4*PI
      AA13= (AMN/PIM)*(CFPI/PIM)**2*(
     .       +2*GSPAIR*(PIM/ALMP1)**2)*4*PI
      AA14= (AMN/PIM)*(CFPI/PIM)**2*(
     .       +2*GPP8S *(PIM/ALMP1)**2)*4*PI
      AA15= (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSTPP*GSST*(BMST4+BMST2*(PIM/ALMSIG)**2))*4*PI
      IF(AMCRS.NE.0.D0) THEN
      AA15= AA15+ (AMN/PIM)*(CFPI/PIM)**2*(
     .       -GSTPP*GSST*BMST2*(PIM/AMCRS)**2)*4*PI
      ENDIF

      C11= (AA01+2*AA11)/16.D0
      C31=  AA11/4.D0
      C12= (AA02+2*AA12)/16.D0
      C32=  AA12/4.D0
      C13= (AA03+2*AA13)/16.D0
      C33=  AA13/4.D0
      C14= (AA04+2*AA14)/16.D0
      C34=  AA14/4.D0
      C15= (AA05+2*AA15)/16.D0
      C35=  AA15/4.D0

      write(6,112) C11,C31,C15,C35,C12,C32,C13,C33,C14,C34
     .         , C1DELS,C3DELS,C1DELU,C3DELU,C1,C3
     .         , GPOPP,GSIPP,GSTPP,GPP8S
  112 FORMAT(//,72('-'),/,
     .12X,' NLO CHIRAL-PT-MODEL PION-NUCLEON CONSTANTS:',
     ./,72('-'),/
     .12X,' C1(EPS) =',F8.3,' GEV**-1',' C3(EPS) =',F8.3,' GEV**-1',/,
     .12X,' C1(SST) =',F8.3,' GEV**-1',' C3(SST) =',F8.3,' GEV**-1',/,
     .12X,' C1(POM) =',F8.3,' GEV**-1',' C3(POM) =',F8.3,' GEV**-1',/,
     .12X,' C1(PP0) =',F8.3,' GEV**-1',' C3(PP0) =',F8.3,' GEV**-1',/,
     .12X,' C1(PET) =',F8.3,' GEV**-1',' C3(PET) =',F8.3,' GEV**-1',/,
     .12X,' C1(DELS)=',F8.3,' GEV**-1',' C3(DELS)=',F8.3,' GEV**-1',/,
     .12X,' C1(DELU)=',F8.3,' GEV**-1',' C3(DELU)=',F8.3,' GEV**-1',/,
     .72('+'),/,
     .12X,' C1(TOT) =',F8.3,' GEV**-1',' C3(TOT) =',F8.3,' GEV**-1',/,
     .72('-'),//,' GPOPP,GSIPP,GSTPP,GPP8S=',4(F8.3,2X),/,
     .72('-'),//)

c     PRINT 113, C1NS,C3NS, C1NU,C3NU, C1DELS,C3DELS, C1DELU,C3DELU
c    .         , FP,APV,GNNP,GDNPI,PDEL
c 113 FORMAT(72('-'),/,
c    .12X,' C1(NUCS)=',F8.3,' GEV**-1',' C3(NUCS)=',F8.3,' GEV**-1',/,
c    .12X,' C1(NUCU)=',F8.3,' GEV**-1',' C3(NUCU)=',F8.3,' GEV**-1',/,
c    .12X,' C1(DELS)=',F8.3,' GEV**-1',' C3(DELS)=',F8.3,' GEV**-1',/,
c    .12X,' C1(DELU)=',F8.3,' GEV**-1',' C3(DELU)=',F8.3,' GEV**-1',/,
c    .72('-'),/,' FP,APV,GNNP,GDNPI,PDEL=',5(F8.3,2X),/,72('-'),//)
      ENDIF

      ENDIF

      ICALL = 1
      CITHE(1) = C1
      CITHE(2) = C3
      RETURN
      END

C **********************************************************************
      SUBROUTINE FRMF
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/PRMTRS/ PAR(20,8)

C     A SIGLE PS, VC, AND SC FOR FACTOR:
      ALMP0 = ALMP1
      ALMV0 = ALMV1
      ALMS0 = ALMS1

      PAR(8,2) = ALMP1
      PAR(8,3) = ALMV1
      PAR(8,5) = ALMS1
      PAR(9,2) = ALMP0
      PAR(9,3) = ALMV0
      PAR(9,5) = ALMS0

      RETURN
      END

C **********************************************************************
c     SUBROUTINE SU3SB(F,SON)
C **********************************************************************
c     IMPLICIT REAL*8(A-H,O-Z)
c     DIMENSION F(11)
c     F(4) = F(4) - F(4)*(1.D0-SON)
c     F(5) = F(5) - F(5)*(1.D0-SON)
c     F(7) = F(7)
c     F(8) = F(8) - F(8)*(1.D0-SON*SON)/3.D0
c     F(10)= F(10)- F(9)*(1.D0-SON*SON)
c     F(11)= F(11)+ F(9)*(1.D0-SON*SON)/3.D0
c     RETURN
c     END

C **********************************************************************
      SUBROUTINE SU3SB(F,SON,IW)
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION F(11)
      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
c     F(10)= F(10)- F(1)*(1.D0-SON*SON)*DSQRT(2.D0/3.D0)
c     F(11)= F(11)- F(1)*(1.D0-SON*SON)*DSQRT(2.D0/3.D0)
      ENDIF
      RETURN
      END
C **********************************************************************
       SUBROUTINE GERSTPAR(IS)                ! 13 AUGUSTUS 2010
C **********************************************************************
C     COMPUTES TWO-POLE APPRXIMATION PARAMETERS FOR EPSILON-MESON,
C     USING THE Bryan-Gersten FORMULAS, PHYS.REV. D6 (1972) 341
C     Adapted for broad kappa  12-07-2010
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLSC/AME,GAME,ASI,BSI,AM1SI,AM2SI,AM1ST,AMD,THS
      COMMON/KAPPA/AMSCK,GAMSCK,ASCK,BSCK,AM1SCK,AM2SCK
      COMMON/ALLIN/ PIM,XXX(8)
C      data icall/0/
C      PIM = 138.041D0
      AMK = 495.8D0
C      AME = 760.0
C      GAME = 640.0
C      AMSCK = 856.0
C      GAMSCK = 464.0
      IF(IS.EQ.1) GO TO 10
      THRES = PIM+PIM
      THRES2 = THRES*THRES
c      PIM2 = PIM*PIM
      AME2 = AME*AME
c      AM32 = AME2*(DSQRT(AME2+4*PIM2)-2*PIM)
      AM32 = AME2*(DSQRT(AME2+THRES2)-THRES)
c      AM32 = 4*PIM*AM32/(AME2+8*PIM2-4*PIM*DSQRT(AME2+4*PIM2))
      AM32 = 2*THRES*AM32/(AME2+2*THRES2-2*THRES*DSQRT(AME2+THRES2))
c      GAM  = GAME*AME/DSQRT(AME2-4*PIM2)
      GAM  = GAME*AME/DSQRT(AME2-THRES2)
C
C      X = (AME2+2*PIM*GAM)*AM32
C      Y = AME2+AM32*(1.D0+0.25D0*GAM/PIM)+2*PIM*GAM
      X = (AME2+THRES*GAM)*AM32
      Y = AME2+AM32*(1.D0+0.5D0*GAM/THRES)+THRES*GAM
      Y = 0.5D0*Y
      AM12 = Y-DSQRT(Y*Y-X)
      AM22 = Y+DSQRT(Y*Y-X)
c
      ASI  = (AM12-AM32)/(AM12-AM22)
      BSI  = 1.D0-ASI
      AM1SI= DSQRT(AM12)
      AM2SI= DSQRT(AM22)
C      if(icall.eq.0) then
C      write(6,*) 'input: pim,ame,game=',pim,ame,game
C      write(6,*) 'output: asi,bsi,am1si,am2si=',asi,bsi,am1si,am2si
C     icall=1
C      endif
      GO TO 20
C
10    THRES = AMK+PIM
      THRES2 = THRES*THRES
      AMSCK2 = AMSCK*AMSCK
      AM32 = AMSCK2*(DSQRT(AMSCK2+THRES2)-THRES)
      AM32 = 2*THRES*AM32/(AMSCK2+2*THRES2-2*THRES*DSQRT(AMSCK2+THRES2))
      GAM  = GAMSCK*AMSCK/DSQRT(AMSCK2-THRES2)
C
      X = (AMSCK2+THRES*GAM)*AM32
      Y = AMSCK2+AM32*(1.D0+0.5D0*GAM/THRES)+THRES*GAM
      Y = 0.5D0*Y
      AM12 = Y-DSQRT(Y*Y-X)
      AM22 = Y+DSQRT(Y*Y-X)
c
      ASCK  = (AM12-AM32)/(AM12-AM22)
      BSCK  = 1.D0-ASCK
      AM1SCK= DSQRT(AM12)
      AM2SCK= DSQRT(AM22)
C      if(icall.eq.0) then
C      write(6,*) 'input: pim,amsck,gamsck=',pim,amsck,gamsck
C      write(6,*) 'output: asck,bsck,am1sck,am2sck=',
C     .          asck,bsck,am1sck,am2sck
C      icall=1
C      endif
20    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***********************************************************************
      SUBROUTINE SU3(F,ALP)
C***********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      DATA SR3/ 0.1732050D 01/
      DIMENSION F(11)
      SR3  = DSQRT(3D0)
      FF   = F(1)
      F(2) = 2.D0*FF*ALP
      F(3) = 2.D0*FF*(1.D0-ALP)/SR3
      F(4) =-FF*(1.D0+2.D0*ALP)/SR3
      F(5) = FF*(1.D0-2.D0*ALP)
      F(6) = FF*(4.D0*ALP-1.D0)/SR3
      F(7) =-F(3)
      F(8) = F(3)
      F(10)= F(9)
      F(11)= F(9)
      RETURN
      END
C **********************************************************************
      SUBROUTINE PSSCAL98(X,NAPION,CORR,INMN,INMX)
C
C**********************************************************************
C
C     PSEUDO-SCALAR MESONS : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
C     AUGUST 1998-VERSION !! REORGANIZATION FC1, FTEN ETC.
C**********************************************************************
C
C     VERSION: MARCH 2015
C     AUGUST 98: PROGRAM FOR R-SPACE NON-ADIABATIC PION-EXCHANGE
C     INCLUSION OF NON-LOCAL GRAZ (NAGELS ET AL)
C     INCLUSION OF NON-LOCAL TERMS FROM:              
C     1/(OMEGA+A) APPROX 1/OMEGA - A/OMEGA^2
C
C     Note: the combination PIONNA + ITMO.NE.0 is WRONG!!!
C----------------------------------------------------------------------
C
C                    fp^2   m^2
C     V(PS-SCALAR) = ----  ----- m [(sig1.sig2)/3 phic^1 + S12 phit^0]
C                    4pi   mup^2

C                    fp^2  mu^2  ( d^2   2  d  ) ----
C     e.g. V_sig   = ----  ----- (---- + -  -- ) phi0 . mu      
C                    4pi   mup^2 (dx^2   x  dx )

C                                       ----
C     m= ps-meson mass, x = mu.r, mu=pim,  mup=pimc, phi0=f0(......)
C
C**********************************************************************
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/PSCOP/ALP,APV,FP,F62,F92,F120,F12C,FCHPI
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      DIMENSION AMPS(4)
      DATA SR3/1.732051D0/,SRPI/1.772454D0/
      COMMON/NAPIONP/VSIGNA,VTENNA,FISNA,FITNA
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB
      DATA PIMNEU/134.9764D0/,PIMCH/139.56995D0/,HBARC/197.326960D0/
      data icall/0/
C-----------------------------------------------------------------
C
C   NOTE : PION0(IN=1),PIONC(IN=2),ETA (IN=3),ETAP(IN=4)
C-----------------------------------------------------------------
C
C   THE POTENTIAL FUNCTIONS
C
c     F0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH-EPH*EXH )/(2*XH)
c     H0(ERATH,EXH,EMH,EPH,XH)=ERATH*( EMH/EXH+EPH*EXH )/(2*XH)
C
c     FF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH
c    .  *(1.D0+XH+XH*XH/3D0)-EXH*EP*(1D0-XH+XH*XH/3D0)
c    .  -8D0*XLAMH*(0.5D0+XLAMH*XLAMH/3D0)*EXLAM/ERATH/
c    .  1.7724538509D0)/(2D0*XH*XH*XH)
C-----------------------------------------------------------------
CC
      VSIG = 0.D0
      VTEN = 0.D0
      FISS = 0D0
      FITEN= 0D0
      DFISS = 0D0
      DFITEN= 0D0

      X1  = 1.D0/X
      X2  = X1*X1
      X3  = X1*X2
      DIV = 1.D0/(AM*AMY)

      DO 1040 IN=INMN,INMX
      GOTO(1051,1052,1053,1054),IN
1051  FPNN= F120
      AMPS(1)=PIM0
*     AMPS(1)=pim   
      ALM1=ALMP1
      GOTO 1055
1052  FPNN= F12C
      AMPS(2)=PIMC
*     amps(2)=pim   
      ALM1=ALMP1
      GOTO 1055
1053  FPNN=  F62
      AMPS(3)=AME
      ALM1=ALMP1
      GOTO 1055
1054  FPNN=  F92
      AMPS(4)=AMX
      ALM1=ALMP0
C
1055  AMES = AMPS(IN)
*     FPNN=FPNN*(PIM/PIMC)**2
CC
      CALL FUNPS2(2,X,AMES,ALM1,FC0,DFC0,FC1,DFC1,FTEN,DFTEN,FSO)
C-----------------------------------------------------------------
C
C     LOCAL TERMS PSEUDOSCALAR MESONS:
C
C-----------------------------------------------------------------
c     FC1  = (DDFIA+2*DFIA*X1)
c     FTEN = (DDFIA-DFIA*X1)/3.D0            
C
C-----------------------------------------------------------------
c     if(x.le.0.02d0) then
c     write(*,*) '=============================================='
c     write(*,*) ' PS: IN=',IN,' X=',X,' FTEN=',FTEN
c     call fseries(in,x,xa,rata,erata,ftnexp,fso2exp)
c     ften=ftnexp*(ames/pim)**3
c     write(*,*) ' ps: in=',in,' x=',x,' ften=',ften
c     endif
C-----------------------------------------------------------------
 
C-----------------------------------------------------------------
      VSIG       = VSIG  + PIM*FPNN*FC1/3.D0
      VTEN       = VTEN  + PIM*FPNN*FTEN
C-----------------------------------------------------------------
C
C     NONLOCAL TERMS PSEUDOSCALAR MESONS:
C
C-----------------------------------------------------------------
      IF(NAPION.GE.1) THEN
C-----------------------------------------------------------------
C     GRAZ 1978:
c     corrps=1d0
      FISS  = FISS   -corsps*REDM*FPNN*FC1*DIV*PIM/6.D0         
      FITEN = FITEN  -cortps*REDM*FPNN*FTEN*DIV*PIM/2D0
      DFISS = DFISS  -corsps*REDM*FPNN*DFC1*DIV*PIM**2/6.D0
      DFITEN= DFITEN -cortps*REDM*FPNN*DFTEN*DIV*PIM**2/2D0
C     END GRAZ 1978.
      ENDIF
C-----------------------------------------------------------------
c     if(x.le.0.02d0) then
c     write(*,*) '=============================================='
c     write(*,*) 'psscal98, 1: in,ames=',in,ames,' x=',x,
c    .' corsps=',corsps,' cortps=',cortps
c     write(*,*) ' fiss ,dfiss =',fiss,dfiss 
c     write(*,*) ' fiten,dfiten=',fiten,dfiten
c     endif
C-----------------------------------------------------------------
      IF(NAPION.EQ.2) THEN
C-----------------------------------------------------------------
C     AUGUST 1998 ADDITIONS: 1/[OMEGA*(OMEGA+A)]:
      CALL FNFUN(3,X,AMES,ALM1,VAFI,DVAFI,D2VAFI,D3VAFI,D4VAFI)
      VAFI1 = CORR*(D2VAFI+2*DVAFI*X1)
      VATEN = CORR*(D2VAFI-DVAFI*X1)/3.D0
      DVAF1 = CORR*(D3VAFI+2*D2VAFI*X1-2*DVAFI*X2)    
      DVATN = CORR*(D3VAFI-D2VAFI*X1+DVAFI*X2)/3.D0

      VTLS   = VTLS   + 0.5D0*FPNN*VAFI1/3.D0
      VTLT   = VTLT   + 0.5D0*FPNN*VATEN
*     VSIG   = VSIG   + 0.5D0*FPNN*TLAB*VAFI1/3.D0
*     VTEN   = VTEN   + 0.5D0*FPNN*TLAB*VATEN
      FISS   = FISS   - REDM*FPNN*VAFI1*DSQRT(DIV)/3.D0
      FITEN  = FITEN  - REDM*FPNN*VATEN*DSQRT(DIV)
      DFISS  = DFISS  - REDM*FPNN*DVAF1*DSQRT(DIV)*PIM/3.D0
      DFITEN = DFITEN - REDM*FPNN*DVATN*DSQRT(DIV)*PIM

      FISTL  = FISTL  - .25D0*REDM*FPNN*VAFI1*DIV/3.D0
      FITTL  = FITTL  - .25D0*REDM*FPNN*VATEN*DIV
      DFISTL = DFISTL - .25D0*REDM*FPNN*DVAF1*DIV*PIM/3.D0
      DFITTL = DFITTL - .25D0*REDM*FPNN*DVATN*DIV*PIM
C     END AUGUST 1998.
      ENDIF
C-----------------------------------------------------------------
*     if(x.lt.0.02d0) then
      if(x.lt.0.0d0) then
*     if(mod(in,2).eq.0.and.mod(icall,20).eq.2) then
      write(*,*) 'pppppppppppppppppppppppppppppppppppppppppppppp'
      write(*,*) 'psscal98, 1: in,ames=',in,ames,' x=',x,
     .' corr=',corr
      write(*,*) ' vsig ,vten  =',vsig,vten 
      write(*,*) ' vtls ,vtlt  =',vtls,vtlt 
      write(*,*) ' fiss ,dfiss =',fiss,dfiss 
      write(*,*) ' fiten,dfiten=',fiten,dfiten
      write(*,*) ' fistl,dfistl=',fistl,dfistl
      write(*,*) ' fittl,dfittl=',fittl,dfittl
      endif
c     check:
*     call pionna(x,1.d0)
*     write(*,*) 'pionna,  ames=',ames,' x=',x,
*    .'fisna,fitna=',fisna,fitna   
C-----------------------------------------------------------------

 1040 CONTINUE
C
      RETURN
      END
C***********************************************************
C
      SUBROUTINE PIONNA(X,FACISO)
C
C     PROGRAM FOR THE R-SPACE NON-ADIABATIC PION-EXCHANGE
C     POTENTIALS IN MOST SIMPLE EXPANSION:
C     1/(OMEGA+A) APPROX 1/OMEGA - A/OMEGA^2
C
C     Note: the combination PIONNA + ITMO.NE.0 is WRONG!!!
C
C***********************************************************
      IMPLICIT REAL*8(A-H,O-Y)
      COMMON/NAPIONP/VSIGNA,VTENNA,FISNA,FITNA
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/PSCOP/ALP,APV,FP,F62,F92,F120,F12C,FCHPI
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      DIMENSION XX(20),WW(20),XKMAX(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
      DATA XKMAX/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/
      SAVE XX,WW,PIM,AMN,AMES,ANUC,AMU
C
C   THE POTENTIAL FUNCTIONS
C
      FF0(ERATH,EXH,XH,EM,EP)=ERATH*(EM/EXH-EXH*EP)/(2.0D00*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
        PIM=135.D0
        AMN=938.259D0
        AMES=PIM
        ANUC=AMN/PIM
        AMU =AMES/PIM
        CALL GAUSS(NPNT,XX,WW,1)
        ICALL = 1
      ENDIF

      FPNN=FP*FP*FACISO
      ALAM=ALMP1
C     AK=DSQRT(AMN*TLAB/2.D0)/PIM
C
C     COMPUTATION ADIABATIC POTENTIAL FUNCTIONS:
C
      XLAM=0.5D0*X*ALAM/PIM
      EX=FDEXP(X)
      VKUNN=(ALAM/PIM)**3*FDEXP(-XLAM*XLAM)/(2.D0*SRPI)
C
      RATP =PIM/ALAM
      RATM =AMES/ALAM
      EXPM=DEXP(RATM *RATM )
      ELAM=FDEXP(-XLAM *XLAM )
      DERFCM=FDERFC(-XLAM +RATM )
      DERFCP=FDERFC( XLAM +RATM )
      FC0  = FF0(EXPM,EX,X,DERFCM,DERFCP)
      FTEN = FF3(EXPM,EX,X,XLAM,DERFCM,DERFCP,ELAM)
      FC1  = FC0  - VKUNN
C     END ADIABATIC FUNCTION COMPUTATION

      VSIGNA = 0.D0
      VTENNA = 0.D0

      DO 100 INT=1,NINT
      ABM=0.5D0*(XKMAX(INT+1)-XKMAX(INT))
      ABP=0.5D0*(XKMAX(INT+1)+XKMAX(INT))
      DO 110 IY=1,NPNT
      Y=ABM*XX(IY)+ABP
      GEW=WW(IY)*ABM*2.D0/PI
      Y2 =1.D0/Y**2
C     FACTOR FROM FORM FACTOR EFFECTS THROUGH DISP. REL. :
      FDISP=FDEXP(-Y*Y*RATP*RATP)
C
      AMI   =DSQRT(AMU*AMU+Y*Y)
      XMI   =AMI*X
      RATMI =RATP*AMI
      ERATMI=FDEXP(RATMI*RATMI)
      EXMI  =FDEXP(XMI)
      EMMI  =FDERFC(-XLAM+RATMI)
      EPMI  =FDERFC( XLAM+RATMI)
C
      FC0I  = FF0(ERATMI,EXMI,XMI,EMMI,EPMI)
      FTENI = FF3(ERATMI,EXMI,XMI,XLAM,EMMI,EPMI,ELAM)*AMI**3*FDISP
      FC1I  = (FC0I*AMI**3 - VKUNN)*FDISP

      VSIGNA = VSIGNA + GEW * (FC1 - FC1I)*Y2
      VTENNA = VTENNA + GEW * (FTEN - FTENI)*Y2
110   CONTINUE
100   CONTINUE

      FISNA  = -0.5D0*FPNN*VSIGNA/3.D0
      FITNA  = -0.5D0*FPNN*VTENNA
      VSIGNA = +FPNN*VSIGNA*PIM/3.D0
      VTENNA = +FPNN*VTENNA*PIM

      RETURN
      END

C***********************************************************
      subroutine fseries(in,x,xa,rata,erata,ftnexp,fso2exp)
c     comutation of ften and fso2 function for small distances,
c     method: series expansion 
C***********************************************************
      implicit real*8(a-h,o-z)
      pi=dacos(-1d0) 
      term5= -2*erata*fderfc(rata)/45d0
     . +(4d0/rata-2d0/rata**3+3d0/rata**5)/dsqrt(pi)/90d0
      term7= -erata*fderfc(rata)/315d0 +(8d0/rata
     . -4d0/rata**3+6d0/rata**5-15d0/rata)/dsqrt(pi)/2520d0
      ftnexp=(term5 + term7*xa**2)*xa**2/2d0
      fso2exp=3*(term5 + term7*xa**2)/2d0
      write(*,*) '----------------------------------------------'
      write(*,*) 'fseries: in=',in,' x=',x,' xa=',xa
      write(*,*) ' rata=',rata,' erata=',erata
      write(*,*) ' ftnexp=',ftnexp,' fso2exp=',fso2exp 
      write(*,*) ' term5=',term5,' term7=',term7
      write(*,*) '----------------------------------------------'
      return
      end
C***********************************************************

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
C***********************************************************
C
C**********************************************************************
      SUBROUTINE AXIAL(XA,FACISO)
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
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**********************************************************************
C
C   THE POTENTIAL FUNCTIONS
C
      IMPLICIT REAL *8(A-H,O-Z)
      common/prmtrs/par(20,8)
      COMMON/ALLAX/FA(11),FFA(11),FB(11)
      COMMON/AXCOP/ALPA,FA12,FA62,FA92,ALMAX
      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN
      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2592D0/
      DATA AMA1,AMD1,AME1/1270.D0,1285.D0,1420.D0/
      DATA IBFLD/3/,ICALL/0/,NS/0/,IGRAZ/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
      HF3(ERATH,EXH,XH,XLAMH,EM,EP,EXLAM)=ERATH*(EM/EXH
     . *(1.D00+XH)-EXH*EP*(1.D00-XH)-4*XLAMH*EXLAM/ERATH/SRPI)
     .  /(6.D00*XH)
C
      IF(ICALL.EQ.0.and.NS.NE.0) THEN
      IF(IBFLD.EQ.1)
     .WRITE(6,*) ' AXIALNN.NLT: LTA-TREATMENT, IBFLD=',IBFLD
      IF(IBFLD.EQ.2)
     .WRITE(6,*) ' AXIALNN.NLT: OM-TREATMENT, IBFLD=',IBFLD
      IF(IBFLD.EQ.3)
     .WRITE(6,*) ' AXIALNN.NLT: NLT-TREATMENT, IBFLD=',IBFLD
c     WRITE(6,*) ' AXIALNN.NLT: IGRAZ=',IGRAZ
      ICALL=1
      ENDIF
      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
      DIV = 1.D0/(AM*AMY)
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  GAX2= FACISO*FA12
      FFAX2= FACISO*FFA(1)**2
      GFAX2= FACISO*(FA(1)*FFA(1)+FFA(1)*FA(1))
      AMAX=AMA1
      ALM1=ALMAX
      GOTO 1054
1052  GAX2=  FA62
      FFAX2= FFA(6)**2
      GFAX2= FA(6)*FFA(6)+FFA(6)*FA(6)
      AMAX=AMD1
      ALM1=ALMAX
      GOTO 1054
1053  GAX2=  FA92
      FFAX2= FFA(9)**2
      GFAX2= FA(9)*FFA(9)+FFA(9)*FA(9)
      AMAX=AME1
      ALM1=ALMAX
C
1054  IF(IZAX.NE.0) FZERO= (AMAX/AMCRA)**2
      RATM1=AMAX/ALM1
      FAC1 =AMAX*AMAX/(AM*AMY)

C     FOR DERIVATIVE TERMS:
      FFAC1 = AMAX**4/(4*AM*AMY*AMPRO**2)
      GFAC1 = AMAX**2/(2*DSQRT(AM*AMY)*AMPRO)
C
      XLAM1=0.5D0*XA*ALM1/PIM
      X =(AMAX/PIM)*XA
      EX=FDEXP(X)
c**   VKUNN=(ALM1/AMAX)**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
      FGAUSS= FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
      VKUNN=(ALM1/AMAX)**3*FGAUSS
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX
      FT0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX
      HT0  = HF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX
      FSO0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX
      FSO2 = 3*FT0/(X*X)
      HSO2 = 3*HT0/(X*X)

      FC1  = FC0 - VKUNN*AMAX
      FT1  = FT0 - VKUNN*(XLAM1*ALM1/AMAX)**2*AMAX/3D0
      FO21 = 3*FT1/(X*X)

      DFC0 = -XA*(AMAX**2/PIM)*FSO0
      DFC1 =  DFC0 + ALM1*XLAM1*VKUNN*AMAX
      DFT0 =  DFC1/3.D0-3*FT0*PIM/XA
C-----------------------------------------------------------------------------
      DFC0 = -FSO0*AMAX**2*XA/PIM                ! JANUARY 2013
      DFC1 = DFC0 + ALM1*XLAM1*VKUNN*AMAX        ! JANUARY 2013
C     DDFC0= (3*FT-FSO0)*AMAX**2                 ! JANUARY 2013
      DDFC0= (FC1+2*FSO0)*AMAX**2                ! JANUARY 2013
      DDFC1 = DDFC0 - (XLAM1**2-0.5D0)*ALM1**2*VKUNN*AMAX ! JAN 2013
C-----------------------------------------------------------------------------

      FC2  = FC1 + (ALM1/AMAX)**2*(1.5D0-XLAM1**2)*VKUNN*AMAX

C     QUADRATIC-SPIN-ORBIT TERM:
      IF(IBFLD.EQ.3) THEN
      FSO2 = FSO0-HSO2
      FO21 = 0.D0     ! FSO2 = 0 -> FO21 = 0 !!
      ENDIF

      IF(IZAX.NE.0) THEN
      FC2  = FC1 + (1.5D0-XLAM1*XLAM1)
     .           * VKUNN*AMAX/RATM1/RATM1
      DFC2 = DFC1- ALM1*XLAM1*(2.5D0-XLAM1*XLAM1)
     .           * VKUNN*AMAX/RATM1/RATM1
      FT1  = FT0 - XLAM1*XLAM1*VKUNN*AMAX/(3*RATM1*RATM1)
      DFT1 = DFT0- ALM1*XLAM1*(1.D0-XLAM1*XLAM1)
     .           * VKUNN*AMAX/(3*RATM1*RATM1)
      FSO1 = FSO0 - 0.5D0*(ALM1/AMAX)**2*VKUNN*AMAX
c     FO21 = -3*FT0/(X*X)       ! CHECK
      fo21 = 0.d0
C--------------------------------------------------------------
C*    NO K^4-TERMS:
      FC2  = 0D0
      DFC2  = 0D0
      DDFC2  = 0D0
      FT1  = 0D0
      DFT1  = 0D0
C*    NO FITEN!
      ENDIF
C--------------------------------------------------------------
C     NO Quadratic spin-orbit:
c     IF(IBFLD.LE.3) THEN
      FSO2=0.D0
      FO21=0.D0
c     ENDIF
C--------------------------------------------------------------
C
C     FIRST TERM AXIAL PROPAGATOR:
C
      VSIG     = VSIG   - GAX2*(FC0+FAC1*FC1*CFSIG/6D0)
      VTEN     = VTEN   + CFTEN*GAX2*FAC1*FT0
      VSO      = VSO    - 0.50D0*GAX2*FAC1*FSO0
      VSO2     = VSO2   + 2.00D0*GAX2*FAC1*FSO2

      FISS     = FISS   - GAX2*DIV*REDM*FC0*CFFIS/6.D0
      DFISS    = DFISS  - GAX2*DIV*REDM*DFC0*CFFIS/6.D0
      DDFISS   = DDFISS - GAX2*DIV*REDM*DDFC0*CFFIS/6.D0
c    .            *PIM**1

      IF(IZAX.NE.0) THEN
      VSIG     = VSIG   - FZERO*GAX2*(FC1 + FAC1*FC2*CFSIG/6D0)
      VTEN     = VTEN   + FZERO*CFTEN*GAX2*FAC1*FT1
      VSO      = VSO    - FZERO*0.50D0*GAX2*FAC1*FSO1
      VSO2     = VSO2   + FZERO*2.00D0*GAX2*FAC1*FO21

      FISS     = FISS   - FZERO*GAX2*DIV*REDM*FC1*CFFIS/6.D0
      DFISS    = DFISS  - FZERO*GAX2*DIV*REDM*DFC1*CFFIS/6.D0
      DDFISS   = DDFISS - FZERO*GAX2*DIV*REDM*DDFC1*CFFIS/6.D0
c    .            *PIM**1
      ENDIF

C--------------------------------------------------------------
C
C     SECOND TERM AXIAL PROPAGATOR:
C
C--------------------------------------------------------------
      IF(IBFLD.EQ.0) THEN
C--------------------------------------------------------------
      VSIG     = VSIG + GAX2*FC1/3
      VTEN     = VTEN + GAX2*FT0

      FISS     = FISS   - GAX2*REDM*FC1 *DIV/6.D0
      DFISS    = DFISS  - GAX2*REDM*DFC1*DIV/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
      VSIG     = VSIG + FZERO*GAX2*FC2/3
      VTEN     = VTEN + FZERO*GAX2*FT1
       IF(IZAX.EQ.2) THEN
      FISS     = FISS   - FZERO*GAX2*REDM*FC2 *DIV/6.D0
      DFISS    = DFISS  - FZERO*GAX2*REDM*DFC2*DIV/6.D0
       ENDIF
      ENDIF
      ENDIF
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
C--------------------------------------------------------------
      VSIG     = VSIG + GAX2*FC2B1/3
      VTEN     = VTEN + GAX2*FT2B0
      FISS     = FISS   - GAX2*REDM*FC2B1 *DIV/6.D0
      DFISS    = DFISS  - GAX2*REDM*DFC2B1*DIV/6.D0
      IF(IZAX.NE.0) THEN
      VSIG     = VSIG + FZERO*GAX2*FC2B2/3
      VTEN     = VTEN + FZERO*GAX2*FT2B1
       IF(IZAX.EQ.2) THEN
      FISS     = FISS   - FZERO*GAX2*REDM*FC2B2 *DIV/6.D0
      DFISS    = DFISS  - FZERO*GAX2*REDM*DFC2B2*DIV/6.D0
       ENDIF
      ENDIF
      ENDIF
C--------------------------------------------------------------
C
C     DERIVATIVE COUPLINGS: -> GAUSSIAN CONTRIBUTIONS:
C
C---------------------------------------------------------------
C     GAUSSIAN CONTRIBUTIONS:
      IF(IBFLD.EQ.0) THEN
      UPSS0 = VKUNN*AMAX
      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

      VSIG= VSIG + FFAC1*FFAX2*UPSS2 + GFAC1*GFAX2*UPSS1
      VTEN= VTEN - FFAC1*FFAX2*UPST1 - GFAC1*GFAX2*UPST0
      ENDIF
C---------------------------------------------------------------
C     FEYNMAN-GAUGE: ALPHA_R=1 -> m_A'=m_A:
      IF(IBFLD.GE.1) THEN
      VSIG= VSIG - (FFAC1*FFAX2*FC2 + 1*GFAC1*GFAX2*FC1)/3.D0
      VTEN= VTEN - (FFAC1*FFAX2*FT1 + 1*GFAC1*GFAX2*FT0)
      ENDIF
C---------------------------------------------------------------
C
 1040 CONTINUE
C
      RETURN
      END
C**********************************************************************
C
      SUBROUTINE AXIALU(XA,FACISO)
C
C**********************************************************************
C     axial.04z.f: VERSION SEPT 2004!!
C**********************************************************************

C
C     AXIAL MESONS (UNNATURAL PARITY) POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL *8(A-H,O-Z)
      COMMON/ALLAX/FA(11),FFA(11),FB(11)
      COMMON/PARNLT/CORSPS,CORSV,CORSA,CORSB
     .             ,CORTPS,CORTV,CORTA,CORTB
      COMMON/ALLIN/PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/FORMF/ALAM,ALMP1,ALMV1,ALMS1,ALMP0,ALMV0,ALMS0,ALAMK
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTDD/DDFI,DDFISS,DDFITEN
      DIMENSION AMAX(3)
      DATA ICALL/0/,NS/0/,SR3/1.732051D0/,SRPI/1.7724538509D0/,IPV/1/
      DATA AMB1,AMH1,AMH2/1235.D0,1170.D0,1380.D0/
      DATA NLOC/1/
C
C   NOTE : B1(IN=1),H11 (IN=3),H11'(IN=2)
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
      DIV1=1.D0/(AM*AMY)
      DO 1040 IN=1,3
      GOTO(1051,1052,1053),IN
1051  GAX2= FACISO*FB(1)*FB(1)
      AMAX(1)=AMB1
      ALM1=ALMP1
      GOTO 1054
1052  GAX2=  FB(6)*FB(6)
      AMAX(2)=AMH1
      ALM1=ALMP1
      GOTO 1054
1053  GAX2=  FB(9)*FB(9)
      AMAX(3)=AMH2
      ALM1=ALMP0
C
1054  RATM1=AMAX(IN)/ALM1
c     FAC1=AMAX(IN)*AMAX(IN)/(AM*AMY)
C     SCALING WITH PIM:
      FAC1=(AMAX(IN)/PIM)**2
C     SCALING WITH AMB1:
c     FAC1=(AMAX(IN)/AMB1)**2
      IF(ICALL.EQ.0.and.NS.NE.0) THEN
      WRITE(6,*) ' IN AXIALU: SCALING COUPLINGS WITH PIM '
**    WRITE(6,*) ' IN AXIALU: SCALING COUPLINGS WITH AMB1'
      ICALL=1
      ENDIF
C
      XLAM1=0.5D0*XA*ALM1/PIM
      X =(AMAX(IN)/PIM)*XA
      EX=FDEXP(X)
      VKUNN=(ALM1/AMAX(IN))**3*FDEXP(-XLAM1*XLAM1)/(2.D0*SRPI)
C
      EXPM=DEXP(RATM1*RATM1)
      ELAM=FDEXP(-XLAM1*XLAM1)
      DERFCM=FDERFC(-XLAM1+RATM1)
      DERFCP=FDERFC( XLAM1+RATM1)
      FC0  = FF0(EXPM,EX,X,DERFCM,DERFCP)*AMAX(IN)
      FT0  = FF3(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)
      FSO0 = FF1(EXPM,EX,X,XLAM1,DERFCM,DERFCP,ELAM)*AMAX(IN)
      FC1  = FC0  - VKUNN*AMAX(IN)

      DFC0 = -XA*(AMAX(IN)**2/PIM)*FSO0
      DFC1 =  DFC0 + ALM1*XLAM1*VKUNN*AMAX(IN)
      DFT0 =  DFC1/3.D0-3*FT0*PIM/XA
      DDFC0= (FC1+2*FSO0)*AMAX(IN)**2                ! JANUARY 2013
      DDFC1 = DDFC0 - (ALM1*XLAM1)**2*VKUNN*AMAX(IN) ! JAN 2013
     .              + 0.5D0*ALM1**2*VKUNN*AMAX(IN)
      DDFTEN= 0D0
C
        VSIG     = VSIG   - FAC1*GAX2*FC1/3.D0
        VTEN     = VTEN   - FAC1*GAX2*FT0

        IF(NLOC.NE.0) THEN
        FISS     = FISS   - corsb*FAC1*GAX2*REDM*FC1 *DIV1/2.D0
        DFISS    = DFISS  - corsb*FAC1*GAX2*REDM*DFC1*DIV1/2.D0
        DDFISS   = DDFISS - corsb*FAC1*GAX2*REDM*DDFC1*DIV1/2.D0
c    .  *PIM**1
        FITEN    = FITEN  - cortb*FAC1*GAX2*REDM*FT0 *DIV1*1.5D0
        DFITEN   = DFITEN - cortb*FAC1*GAX2*REDM*DFT0*DIV1*1.5D0
        DDFITEN  = DDFITEN -cortb*FAC1*GAX2*REDM*DDFTEN*DIV1*1.5D0
c    .  *PIM**1
        ENDIF
C
 1040 CONTINUE
C
      RETURN
      END


C **********************************************************************
      SUBROUTINE PAIRS(X,ISPIN,ALAMP,ALMV1,ALMS1,ALMP0,ALMV0,ALAMS,
     .ALAMK)
C **********************************************************************
C *
C     CONVENTIONS A LA PAPER II (SEE (PIRO)_{1} AND (PI-EPSILON) )
C
C     CORRECTED VERSION DD DECEMBER 1993 !!!!!!!!!!!
C     UPDATED 1 APRIL 1994! + 5 APRIL: PI-ETA, PI-ETAP PAIRS!
C                           + 17 AUG.: K-KBAR PAIRS!
C     CORRECTED: 23 SEPTEMBER 1994
C     UPDATED  : 15 SEPTEMBER 1995, BROAD EPSILON- AND RHO-VERSION!
C     UPDATED  : 25 MAY/JUNE  1995, 1/M-CORRECTIONS PI-SIGMA, SIGMA-SIGM
C                                   INCLUSION PI-POMERON PAIRS
C     UPDATED  : 8  OCTOBER   1995, PI-RO AND PI-OMEGA PAIRS VECTOR TYPE
C
C *   PHENOMENOLOGICAL PION-MESON PAIR POTENTIALS
C *
C     FOR THE SCALAR AND VECTOR PAIR TERMS SEE
C     OKUBO AND SUGAWARA, PHYS.REV. 117, P.605 AND P. 611 (1960).
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/ALLIN/ PIM,AMP,AMY,ALLX(6)
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FUI,DFUI,FUISS,DFUISS
     .,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2
c     COMMON/POT2P/VC2P,VSIG2P,VTEN2P,VSO2P,VC1P,VSIG1P,VTEN1P,VSO1P
      COMMON/ALLPR/GSPAIR,GVPAIR,FVPAIR,GAPAIR,HAPAIR,GPISIG,HOPAIR
     .,GEPAIR,GPIET,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,gometa
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,iometa
      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB

      COMMON/PSCOP/ALP,APV,FPI,F62,F92,F120,F12C,FCHPI
      COMMON/VECCOP/FD12,FD62,FD92,FV12,FV62,FV92,FDV1,FDV6,FDV9
      COMMON/SCCOP/GS12,GS62,GS92,GEPS2
      COMMON/DIFCOP/GD62,GD12,GD92,gfp22
      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEP,ASIG(2),AMSIG(2),AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
      COMMON/PAIROM/IDAM,IPV,INA,IOFF

      DIMENSION BFUN(10),XX(20),WW(20),YB(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/,NSCHR/0/
C     DATA GRNN/0.89147D0/,FRNN/3.76255D0/,AMRO/760.D0/
C     DATA GONN/2.56892D0/,FONN/0.61139D0/,AMOM/783.D0/
C     DATA FP2/0.075D0/,FP/0.273861D0/,GEPNN/4.5D0/
C     DATA ALAMK/800.D0/,AMK/495.D0/,AMYL/1115.D0/,AMYS/1195.D0/
      DATA AMK/495.D0/,AMYL/1115.D0/,AMYS/1195.D0/
      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/
C     DATA INA/1/,IPV/1/,N2PR0/0/,N2PR1/0/,N2PRA/1/,N2PRB/1/
c     DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/0/,IPIEP/1/,
c    .IEPEP/1/,IPIET/0/,IPIETP/0/,IKKB0/0/,IKKB1/0/,IPIPOM/1/,
c    .IPIROV/0/,IPIOMV/0/
      SAVE AMN,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
c     CALL ERRSET(208,256,-1,1)
      IF(ICALL.EQ.0) THEN
        CALL GAUSS(NPNT,XX,WW,1)
        IF(IMETH.EQ.1) NINT=1
        if(nschr.ne.0) write(6,52) IMETH,NPNT,INA,IPV,
     .  N2PR0,N2PR1,N2PRA,N2PRB,
     .  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV,
     .  IPISI,ISISI,IPIET,IPIETP,IKKB0,IKKB1,IPIPOM,IPIPI2
c    . ,gspair,gvpair,fvpair,gapair,hapair,gpisig,gepair,
c    .  HOPAIR,GPIET,GPIETP,GPIPOM,GPIROV,GPIOMV,GKKB0,GKKB1,
c    .  GTENPR,FTENPR,GPPS2
 52     FORMAT(//,'  IN PAIRS: IMETH=',I2,' NPNT=',I2,
     .  ' INA=',I2,' IPV=',I2,' N2PR0,N2PR1,N2PRA,N2PRB=',4I2,
     .  //,11X,' IPIPI0,IPIPI1,PIRO1,IPIRO0,IPIROV,IPIOM,IPIOMV=',7I2,
     .  //,11X,' IPISI ,ISISI ,IPIET,IPIETP,IKKB0 ,IKKB1,IPIPOM=',7I2,
     .  //,11X,' IPIPI2=',I2,//)
c    .  //,11x,' GSPAIR,GVPAIR,FVPAIR=',3(F10.5,2x),
c    .  //,11x,' GPIRO1,GPIRO0,GPISIG=',3(F10.5,2x),
c    .  //,11x,' GSISI ,HOPAIR       =',2(F10.5,2X),
c    .  //,11X,' GPIET ,GPIETP       =',2(F10.5,2x),
c    .  //,11X,' GPIPOM,GPIROV,GPIOMV=',3(F10.5,2X),
c    .  //,11X,' GKKB0,GKKB1         =',2(F10.5,2X),
c    .  //,11X,' GTENPR,FTENPR       =',2(F10.5,2X),
c    .  //,11X,' GPPS2               =',2(F10.5,2X),//)
c       ICALL=1
      ENDIF
      AMN  = DSQRT(AMP*AMY)
      ISFAC =4*ISPIN-3

      FP   = FPI*(PIM/PIMC)
c     FP   = FPI
      FP2  = FP*FP
      GRNN = DSQRT(FD12)
      FRNN = FDV1/GRNN
      GONN = DSQRT(FD62)
      FONN = FDV6/GONN
      GEPNN= DSQRT(GS62)
      FETA = DSQRT(F62)*(PIM/PIMC)
      FETAP= DSQRT(F92)*(PIM/PIMC)
      FNLK2= FP2*(1.D0+2*0.355D0)**2/3.D0
      FNSK2= FP2*(1.D0-2*0.355D0)**2
      GPOM  = DSQRT(GD62)
CC
      X1   =1.D0/X
      X2   =X1*X1
      X3   =X1*X2
CC
      RATP =PIM/ALAMP
      RATA2=ALAMP*ALAMP/PIM/PIM
      ERATP=DEXP(RATP*RATP)
      XLAM =0.5D0*X/RATP
      EXPI =DEXP(X)
      EMPI =FDERFC(-XLAM+RATP)
      EPPI =FDERFC( XLAM+RATP)
      XLAM2=XLAM*XLAM
      VKU  =(ALAMP/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKU =-0.5D0*RATA2*X*VKU
      DDVKU=-0.5D0*RATA2*(VKU+X*DVKU)
C
      FI   =F0(ERATP,EXPI,EMPI,EPPI,X)
      HI   =H0(ERATP,EXPI,EMPI,EPPI,X)
      DFI  =-(FI-2*VKU)*X1-HI
      DHI  =-FI-HI*X1
      DDFI =-(DFI-2*DVKU)*X1+(FI-2*VKU)*X2-DHI
      DDHI =-DFI-DHI*X1+HI*X2
      D3FI =-(DDFI-2*DDVKU)*X1+2*(DFI-2*DVKU)*X2
     .      -2*(FI-2*VKU)*X3-DDHI
CC
      RATV1=PIM/ALMV1
      RATV21=ALMV1*ALMV1/PIM/PIM
      XLMV1=0.5D0*X*ALMV1/PIM
      XLAM2=XLMV1*XLMV1
      VKUR =(ALMV1/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKUR=-0.5D0*RATV21*X*VKUR
      FIRO  = 0.D0
      DFIR  = 0.D0
      DDFIR = 0.D0
      DO 5 JJ=1,2
      XRO  =X*AMVEC(JJ)/PIM
      RATR =AMVEC(JJ)/ALMV1
      ERATR=DEXP(RATR*RATR)
      EXRO =DEXP(XRO)
      EMRO =FDERFC(-XLMV1+RATR)
      EPRO =FDERFC( XLMV1+RATR)
      FIEV =F0(ERATR,EXRO,EMRO,EPRO,X)
      HIRO =H0(ERATR,EXRO,EMRO,EPRO,X)
      DFIEV=-(FIEV-2*VKUR)*X1-(AMVEC(JJ)/PIM)*HIRO
      DHIRO =-(AMVEC(JJ)/PIM)*FIEV-HIRO*X1
      DDFIEV=-(DFIEV-2*DVKUR)*X1-(AMVEC(JJ)/PIM)*DHIRO
     .       +(FIEV-2*VKUR)*X2
      FIRO = FIRO + AVEC(JJ)*FIEV
      DFIR = DFIR + AVEC(JJ)*DFIEV
    5 DDFIR= DDFIR+ AVEC(JJ)*DDFIEV
CC
      XOM  =X*AMOM/PIM
      RATV0=PIM/ALMV0
      RATO =AMOM/ALMV0
      RATV20=ALMV0*ALMV0/PIM/PIM
      ERATO=DEXP(RATO*RATO)
      XLMV0=0.5D0*X*ALMV0/PIM
      XLAM2=XLMV0*XLMV0
      VKUO =(ALMV0/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKUO=-0.5D0*RATV20*X*VKUO
      EXOM =DEXP(XOM)
      EMOM =FDERFC(-XLMV0+RATO)
      EPOM =FDERFC( XLMV0+RATO)
      FIOM =F0(ERATO,EXOM,EMOM,EPOM,X)
      HIOM =H0(ERATO,EXOM,EMOM,EPOM,X)
      DFIO =-(FIOM-2*VKUO)*X1-(AMOM/PIM)*HIOM
      DHIOM =-(AMOM/PIM)*FIOM-HIOM*X1
      DDFIO =-(DFIO-2*DVKUO)*X1-(AMOM/PIM)*DHIOM
     .       +(FIOM-2*VKUO)*X2
CC
      RATS = PIM/ALAMS
      RATS2=ALAMS*ALAMS/PIM/PIM
      XLAMS=0.5D0*X*ALAMS/PIM
      XLAM2=XLAMS*XLAMS
      VKUE =(ALAMS/PIM)*FDEXP(-XLAM2)/(2*SRPI)
      DVKUE=-0.5D0*RATS2*X*VKUE
      FIEP  = 0.D0
      DFIEP = 0.D0
      DDFIEP= 0.D0
      DO 10 JJ=1,2
      XEPS =X*AMSIG(JJ)/PIM
      RATEP=AMSIG(JJ)/ALAMS
      ERATE=DEXP(RATEP*RATEP)
      EXEPS=DEXP(XEPS)
      EMEPS=FDERFC(-XLAMS+RATEP)
      EPEPS=FDERFC( XLAMS+RATEP)
      FIES =F0(ERATE,EXEPS,EMEPS,EPEPS,X)
      HIEP =H0(ERATE,EXEPS,EMEPS,EPEPS,X)
      DFIES=-(FIES-2*VKUE)*X1-(AMSIG(JJ)/PIM)*HIEP
      DHIEP =-(AMSIG(JJ)/PIM)*FIES-HIEP*X1
      DDFIES=-(DFIES-2*DVKUE)*X1-(AMSIG(JJ)/PIM)*DHIEP
     .       +(FIES-2*VKUE)*X2
      FIEP = FIEP + ASIG(JJ)*FIES
      DFIEP = DFIEP + ASIG(JJ)*DFIES
10    DDFIEP = DDFIEP + ASIG(JJ)*DDFIES
CC
      ALMPS = ALAMP
      RATPS =PIM/ALMPS
      RATPS2=ALMPS*ALMPS/PIM/PIM
      XLMPS =0.5D0*X*ALMPS/PIM
      XLAM2 =XLMPS*XLMPS
      VKUPS =(ALMPS/PIM)*FDEXP(-XLAM2)/(2*SRPI)
C     ETA:
      XETA  =X*AME/PIM
      RATET =AME/ALMPS
      ERATET=DEXP(RATET*RATET)
      EXETA =DEXP(XETA)
      EMETA =FDERFC(-XLMPS+RATET)
      EPETA =FDERFC( XLMPS+RATET)
      FIETA =F0(ERATET,EXETA,EMETA,EPETA,X)
      HIETA =H0(ERATET,EXETA,EMETA,EPETA,X)
      DFIETA=-(FIETA-2*VKUPS)*X1-(AME/PIM)*HIETA
C     ETAP:
      XETA  =X*AMX/PIM
      RATET =AMX/ALMPS
      ERATET=DEXP(RATET*RATET)
      EXETA =DEXP(XETA)
      EMETA =FDERFC(-XLMPS+RATET)
      EPETA =FDERFC( XLMPS+RATET)
      FIETP =F0(ERATET,EXETA,EMETA,EPETA,X)
      HIETA =H0(ERATET,EXETA,EMETA,EPETA,X)
      DFIETP=-(FIETP-2*VKUPS)*X1-(AMX/PIM)*HIETA
C     KAON:
C     XKAON =X*AMK/PIM
      XLAMK = 0.5D0*X*ALAMK/PIM
      VKUKA = (ALAMK/PIM)*FDEXP(-XLAMK*XLAMK)/(2*SRPI)
C     DVKUKA=-0.5D0*(ALAMK/PIM)**2*X*VKUKA
      RATK  =PIM/ALAMK
C     RATKN =AMK/ALAMK
C     ERATKN=DEXP(RATKN*RATKN)
C     EXKAON=DEXP(XKAON)
C     EMKAON =FDERFC(-XLAMK+RATKN)
C     EPKAON =FDERFC( XLAMK+RATKN)
C     FIKAON =F0(ERATKN,EXKAON,EMKAON,EPKAON,X)
C     HIKAON =H0(ERATKN,EXKAON,EMKAON,EPKAON,X)
C     DFIKAN =-(FIKAON-2*VKUKA)*X1-(AMK/PIM)*HIKAON

C POMERON:
C     IF(IDIF.EQ.1) THEN
      RATD  = 0.5D0*PIM/AMPOM
      XPOM  = X*AMPOM/PIM
      FIPO  = (4.D0/SRPI)*(AMPOM/PIM)*(AMPOM/AMN)**2*
     .        FDEXP(-XPOM*XPOM)
      DFIPO = -2*(AMPOM/PIM)*XPOM*FIPO
      DDFIPO= -2*(AMPOM/PIM)*(XPOM*DFIPO + FIPO*AMPOM/PIM)
C     ENDIF

      AYLN = (AMYL-AMN)/PIM
      AYSN = (AMYS-AMN)/PIM
C
C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION
C
      FISC2 =0.D0
      FISNA1=0.D0
      FISNA4=0.D0
      FISNA2=0.D0
      FISNA3=0.D0
      FIVC1 =0.D0
      FIVC2 =0.D0
      FIVS2 =0.D0
      FIVT2 =0.D0
      FIAS2 =0.D0
      FIHS2 =0.D0
      FIHT2 =0.D0
      FIHC2 =0.D0
      FIAOS2 =0.D0
      FIHOS2 =0.D0
      FIHOT2 =0.D0
      FIHOC2 =0.D0
      FIPS2  =0.D0
      FIPT2  =0.D0
      FIEPC2 =0.D0
      FIPET2 =0.D0
      FIPEP2 =0.D0
      FIMKA2 =0.D0
C     FISOKA =0.D0
C     FISOKL =0.D0
C     FISOKS =0.D0
      DH11YL =0.D0
      DH11YS =0.D0
      FEPNA1 =0.D0
      FEPNA2 =0.D0
      FEPPV1 =0.D0
      FEPPV2 =0.D0
      FEPNA3 =0.D0
      FPIPOS =0.D0
      FPIPOT =0.D0
      FPONA1 =0.D0
      FPONA2 =0.D0
      FPOPV1 =0.D0
      FPOPV2 =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. :
      FDISP =FDEXP(-Y*Y*RATP*RATP)
      FDISP0=FDEXP(-Y*Y*RATPS*RATPS)
      FDISV =FDEXP(-Y*Y*RATV1*RATV1)
      FDISV0=FDEXP(-Y*Y*RATV0*RATV0)
      FDISS =FDEXP(-Y*Y*RATS *RATS )
      FDISD =FDEXP(-Y*Y*RATD *RATD )
C
      AM=PIM*DSQRT(1.D0+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALAMP
      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*VKU )*X1-(AM/PIM)*HIM
      DHIM  =-(AM/PIM)*FIM-HIM*X1
      DDFIM =-(DFIM-2*DVKU )*X1+(FIM-2*VKU )*X2-(AM/PIM)*DHIM
      DDHIM =-(AM/PIM)*DFIM-DHIM*X1+HIM*X2
      D3FIM =-(DDFIM-2*DDVKU)*X1+2*(DFIM-2*DVKU)*X2
     .       -2*(FIM-2*VKU)*X3-(AM/PIM)*DDHIM
C
      FIVC1 = FIVC1 + GEW*DFIM*DFIM *FDISP**2
        IF(N2PR0.EQ.1)
     .FISC2 = FISC2 + GEW*FIM*FIM *FDISP**2
        IF(N2PR1.EQ.1) THEN
      FIVC2 = FIVC2 + GEW*(RATA2*VKU-2*Y*Y*FIM*FDISP)*FIM *FDISP
      FIVS2 = FIVS2 + GEW*(X1*DFIM+2*DDFIM)*DFIM*X1 *FDISP**2
      FIVT2 = FIVT2 + GEW*(X1*DFIM-DDFIM)*DFIM*X1 *FDISP**2
        ENDIF
C
      FISNA1= FISNA1+ GEW*(2*X2*(DFI**2-DFIM**2*FDISP**2)
     .                      +(DDFI**2-DDFIM**2*FDISP**2) )/Y**2
      FISNA4= FISNA4+ GEW*(2*X2*(DFI**2-DFIM**2*FDISP**2))/Y**2
C     FISNA2= FISNA2+ GEW*(VKU/RATP**2-(1.D0+Y*Y)*FIM*FDISP)*FIM*FDISP
      FISNA2= FISNA2+ GEW*(2*X1*DFIM+DDFIM)*FIM*FDISP**2
      FISNA3= FISNA3+ GEW*(2*X1*FIM*DFIM*FDISP**2)
C
      FIMR = 0.D0
      DFIMR = 0.D0
      DDFIMR = 0.D0
      DO 6 JJ=1,2
      AM=PIM*DSQRT((AMVEC(JJ)/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALMV1
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLMV1+RATM)
      EPM  =FDERFC( XLMV1+RATM)
C
      FIMV  = F0(ERATM,EXM,EMM,EPM,X )
      HIMV  = H0(ERATM,EXM,EMM,EPM,X )
      DFIMV =-(FIMV-2*VKUR)*X1-(AM/PIM)*HIMV
      DHIMV =-(AM/PIM)*FIMV-HIMV*X1
      DDFIMV=-(DFIMV-2*DVKUR)*X1+(FIMV-2*VKUR)*X2-(AM/PIM)*DHIMV
      FIMR = FIMR + AVEC(JJ)*FIMV
      DFIMR = DFIMR + AVEC(JJ)*DFIMV
      DDFIMR = DDFIMR + AVEC(JJ)*DDFIMV
    6 CONTINUE
        IF(N2PRA.EQ.1) THEN
      FIAS2 = FIAS2 + GEW*FIM*FIMR *FDISP*FDISV

      FIHS2 = FIHS2 + GEW*((2*X1*DFIM+DDFIM)*FIMR+2*DFIM*DFIMR
     .                +FIM*(2*X1*DFIMR+DDFIMR))*FDISP*FDISV/3
      FIHS2 = FIHS2 + GEW*( RATA2*VKU*FIMR*FDISV
     .                     +RATV21*VKUR*FIM*FDISP)

      FIHT2 = FIHT2 + GEW*(( -X1*DFIM+DDFIM)*FIMR+2*DFIM*DFIMR
     .                +FIM*( -X1*DFIMR+DDFIMR))*FDISP*FDISV/3

      FIHC2 = FIHC2 + GEW*(X1*DFIM*DFIMR+DDFIM*DFIMR+DFIM*DDFIMR)
     .                     *FDISP*FDISV
        ENDIF
C
      AM=PIM*DSQRT((AMOM/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALMV0
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLMV0+RATM)
      EPM  =FDERFC( XLMV0+RATM)
C
      FIMO  = F0(ERATM,EXM,EMM,EPM,X )
      HIMO  = H0(ERATM,EXM,EMM,EPM,X )
      DFIMO =-(FIMO-2*VKUO)*X1-(AM/PIM)*HIMO
      DHIMO =-(AM/PIM)*FIMO-HIMO*X1
      DDFIMO=-(DFIMO-2*DVKUO)*X1+(FIMO-2*VKUO)*X2-(AM/PIM)*DHIMO

        IF(N2PRB.EQ.1) THEN
      FIAOS2 = FIAOS2 + GEW*FIM*FIMO *FDISP*FDISV0

      FIHOS2 = FIHOS2 + GEW*((2*X1*DFIM+DDFIM)*FIMO+2*DFIM*DFIMO
     .                  +FIM*(2*X1*DFIMO+DDFIMO))*FDISP*FDISV0/3
      FIHOS2 = FIHOS2 + GEW*( RATA2*VKU*FIMO*FDISV0
     .                     +RATV20*VKUO*FIM*FDISP)

      FIHOT2 = FIHOT2 + GEW*(( -X1*DFIM+DDFIM)*FIMO+2*DFIM*DFIMO
     .                +FIM*( -X1*DFIMO+DDFIMO))*FDISP*FDISV0/3

      FIHOC2 = FIHOC2 + GEW*(X1*DFIM*DFIMO+DDFIM*DFIMO+DFIM*DDFIMO)
     .                      *FDISP*FDISV0
        ENDIF
C
C     PI-EPSILON:
      FIMS   = 0.D0
      DFIMS  = 0.D0
      DDFIMS = 0.D0
      DO 11 JJ=1,2
      AM=PIM*DSQRT((AMSIG(JJ)/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALAMS
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLAMS+RATM)
      EPM  =FDERFC( XLAMS+RATM)
C
      FIME  = F0(ERATM,EXM,EMM,EPM,X )
      HIME  = H0(ERATM,EXM,EMM,EPM,X )
      DFIME =-(FIME-2*VKUE)*X1-(AM/PIM)*HIME
      DHIME =-(AM/PIM)*FIME-HIME*X1
      DDFIME=-(DFIME-2*DVKUE)*X1+(FIME-2*VKUE)*X2-(AM/PIM)*DHIME
      FIMS  = FIMS + ASIG(JJ)*FIME
      DFIMS  = DFIMS + ASIG(JJ)*DFIME
      DDFIMS  = DDFIMS + ASIG(JJ)*DDFIME
11    CONTINUE

        IF(N2PRA.EQ.1) THEN
      FIPS2 = FIPS2 + GEW*((2*X1*DFIM+DDFIM)*FIMS
     . -2*DFIM*DFIMS +FIM*(2*X1*DFIMS+DDFIMS))*FDISP*FDISS/6

      FIPT2 = FIPT2 + GEW*(( -X1*DFIM+DDFIM)*FIMS
     . -2*DFIM*DFIMS +FIM*( -X1*DFIMS+DDFIMS))*FDISP*FDISS/6
        ENDIF

        IF(N2PR0.EQ.1) THEN
      FIEPC2= FIEPC2 + GEW*FIMS*FIMS* FDISS**2
        ENDIF

      FEPNA1= FEPNA1+ GEW*(
     .(-4*X2*DFI+2*X1*DDFI+D3FI)*DFIEP-DDFI*DDFIEP -(
     .(-4*X2*DFIM+2*X1*DDFIM+D3FIM)*DFIMS-DDFIM*DDFIMS)*FDISP*FDISS)
     ./Y**2

      FEPNA2= FEPNA2+ GEW*(
     .(2*X2*DFI-X1*DDFI+D3FI)*DFIEP-DDFI*DDFIEP -(
     .(2*X2*DFIM-X1*DDFIM+D3FIM)*DFIMS-DDFIM*DDFIMS)*FDISP*FDISS)
     ./Y**2

      FEPNA3= FEPNA3+ GEW*(DFIEP**2-DFIMS**2*FDISS**2)/Y**2

      FEPPV1= FEPPV1+ GEW*((2*X1*DFIMS+DDFIMS)*FIM-DFIMS*DFIM)
     .*FDISP*FDISS
      FEPPV2= FEPPV2+ GEW*((-X1*DFIMS+DDFIMS)*FIM-DFIMS*DFIM)
     .*FDISP*FDISS

C
C     PI-POMERON:

        IF(N2PRA.EQ.1) THEN
      FPIPOS = FPIPOS + GEW*((2*X1*DFIM+DDFIM)*FIPO
     . -2*DFIM*DFIPO +FIM*(2*X1*DFIPO+DDFIPO))*FDISP*FDISD/6

      FPIPOT = FPIPOT + GEW*(( -X1*DFIM+DDFIM)*FIPO
     . -2*DFIM*DFIPO +FIM*( -X1*DFIPO+DDFIPO))*FDISP*FDISD/6
        ENDIF

      FPONA1= FPONA1+ GEW*(
     .(-4*X2*DFI+2*X1*DDFI+D3FI)*DFIPO-DDFI*DDFIPO -(
     .(-4*X2*DFIM+2*X1*DDFIM+D3FIM)*DFIPO-DDFIM*DDFIPO)*FDISP*FDISD)
     ./Y**2

      FPONA2= FPONA2+ GEW*(
     .(2*X2*DFI-X1*DDFI+D3FI)*DFIPO-DDFI*DDFIPO -(
     .(2*X2*DFIM-X1*DDFIM+D3FIM)*DFIPO-DDFIM*DDFIPO)*FDISP*FDISD)
     ./Y**2

      FPOPV1= FPOPV1+ GEW*((2*X1*DFIPO+DDFIPO)*FIM-DFIPO*DFIM)
     .*FDISP*FDISD
      FPOPV2= FPOPV2+ GEW*((-X1*DFIPO+DDFIPO)*FIM-DFIPO*DFIM)
     .*FDISP*FDISD

        IF(N2PRB.EQ.1) THEN
C     PI-ETA:
      AM=PIM*DSQRT((AME/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALMPS
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLMPS+RATM)
      EPM  =FDERFC( XLMPS+RATM)
C
      FIMET = F0(ERATM,EXM,EMM,EPM,X )
      FIPET2= FIPET2+ GEW*FIM*FIMET *FDISP*FDISP0

C     PI-ETAP:
      AM=PIM*DSQRT((AMX/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALMPS
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLMPS+RATM)
      EPM  =FDERFC( XLMPS+RATM)
C
      FIMET = F0(ERATM,EXM,EMM,EPM,X )
      FIPEP2= FIPEP2+ GEW*FIM*FIMET *FDISP*FDISP0
        ENDIF

C     K-KBAR:
        IF(N2PR0.EQ.1) THEN
      AM=PIM*DSQRT((AMK/PIM)**2+Y*Y)
      XM=AM*X/PIM
      RATM =AM/ALAMK
      ERATM=FDEXP(RATM*RATM)
      EXM  =FDEXP(XM)
      EMM  =FDERFC(-XLAMK+RATM)
      EPM  =FDERFC( XLAMK+RATM)
C
      FIMKA = F0(ERATM,EXM,EMM,EPM,X )
      HIMKA = H0(ERATM,EXM,EMM,EPM,X )
      DFIMKA=-(FIMKA-2*VKUKA)*X1-(AM/PIM)*HIMKA
C     DHIMK =-(AM/PIM)*FIMKA-HIMKA*X1
C     DDFIMK=-(DFIMKA-2*DVKUKA)*X1+(FIMKA-2*VKUKA)*X2-(AM/PIM)*DHIMK
      FDISPK=FDEXP(-Y*Y*RATK*RATK)
      FIMKA2 = FIMKA2 + GEW*FIMKA*FIMKA *FDISPK**2
C     FISOKA = FISOKA + GEW*DFIMKA*FIMKA *FDISPK**2
C     FISOKL = FISOKL + GEW*(Y*Y/(AYLN**2+Y*Y))*DFIMKA*FIMKA*FDISPK**2
C     FISOKS = FISOKS + GEW*(Y*Y/(AYSN**2+Y*Y))*DFIMKA*FIMKA*FDISPK**2
      DH11YL = DH11YL + GEW*(AYLN/(AYLN**2+Y*Y))*DFIMKA**2 * FDISPK**2
      DH11YS = DH11YS + GEW*(AYSN/(AYSN**2+Y*Y))*DFIMKA**2 * FDISPK**2
        ENDIF
C
110   CONTINUE
100   CONTINUE

C----------------------------------------------------------------------
C     FEBR. 2001: FUNCTIONS FOR DERIVATIVE-SCALAR EXCHANGE:
      BFUN1 = (2*DFI*DFI/X/X+DDFI*DDFI)
      CALL BMNFUN(-1,-1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      BFUN2 = BFUN(1)
      CALL BMNFUN( 0, 0,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      BFUN2 = BFUN2+2*BFUN(4)
      CALL BMNFUN(+1,+1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      BFUN2 = BFUN2+2*BFUN(4)/X/X+BFUN(9)

      IF(INA.NE.0) THEN
      CALL BMNFUN( 1, 1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNNA= 2*BFUN(4)/X/X+BFUN(9)
      OFUNNA= BFUN(4)
      CALL BMNFUN(12,12,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNNA= CFUNNA
     .       -6*(BFUN(9)-BFUN(7)/X-BFUN(8)/X+BFUN(4)/X/X)/X/X
     .       -BFUN(10)
      OFUNNA= OFUNNA-2*(BFUN(9)-BFUN(7)/X-BFUN(8)/X+BFUN(4)/X/X)
      OFUNNA= 2*OFUNNA/X/X
      ENDIF

      IF(IPV.EQ.1) THEN
      CALL BMNFUN( 1, 1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNPV= -2*BFUN(4)
      OFUNPV= -1*(BFUN(7)+BFUN(8))
      CALL BMNFUN(-1,+1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNPV= CFUNPV+BFUN(1)+BFUN(4)
      OFUNPV= OFUNPV+BFUN(2)+BFUN(3)
      CALL BMNFUN(+1,-1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNPV= CFUNPV+BFUN(1)+BFUN(4)
      OFUNPV= OFUNPV+BFUN(2)+BFUN(3)
      CALL BMNFUN(-1,-1,X,PIM,PIM,ALAMP,ALAMP,BFUN)
      CFUNPV= CFUNPV-2*BFUN(1)
      OFUNPV= 2*OFUNPV/X
      ENDIF
C----------------------------------------------------------------------
C
      FACT  = PIM
      VC    =0.D0
      VSIG  =0.D0
      VTEN  =0.D0
      VSO   =0.D0
      VSO2  =0.D0
      FUI   =0.D0
      DFUI  =0.D0

C
C 1)  SCALAR PAIR TERMS:
C
C     PI-PI(I=0):
      IF(IPIPI0.EQ.1) THEN
      VC    =   VC + FACT*( 6*GSPAIR*FP2*DFI*DFI-3*GSPAIR**2*FISC2)
      VC    =   VC - FACT*(12*GPPS2 *FP2*BFUN1  +6*GPPS2**2 *BFUN2)
c     write(6,*) ' gpps2=',gpps2,' x,bfun1,bfun2=',x,bfun1,bfun2
c     write(6,*) 'pairs: x=',x,' vcad =',vc
       IF(INA.NE.0) THEN
C     (1/M)-CORRECTIONS NON-ADIABATIC:
      VC    =   VC - 3*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA1
      VSO   =   VSO- 3*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA4
      VC    =   VC - 6*FACT*GPPS2 *FP2*(PIM/AMN)* CFUNNA
      VSO   =   VSO- 6*FACT*GPPS2 *FP2*(PIM/AMN)* OFUNNA
c     write(6,*) 'pairs: x=',x,' +vcnad=',vc,'vso=',vso
       ENDIF
       IF(IPV.EQ.1) THEN
C     (1/M)-PION-VERTEX CORRECTIONS:
      VC    =   VC - APV*6*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA2
      VSO   =   VSO- APV*6*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA3
      VC    =   VC - APV*6*FACT*GPPS2 *FP2*(PIM/AMN)* CFUNPV
      VSO   =   VSO- APV*6*FACT*GPPS2 *FP2*(PIM/AMN)* OFUNPV
c     write(6,*) 'pairs: x=',x,' +vcpv =',vc,'vso=',vso
       ENDIF
      ENDIF

C     PI-ETA AND PI-ETA':
      IF(IPIET.EQ.1) THEN
      VC    =   VC + FACT*ISFAC*GPIET*(
     .          2*FP*FETA*DFI*DFIETA-0.5D0*GPIET*FIPET2)
C     (1/M)-CORRECTIONS NON-ADIABATIC: NOT IMPLEMENTED
C     (1/M)-PION-VERTEX CORRECTIONS: NOT IMPLEMENTED
      ENDIF
      IF(IPIETP.EQ.1) THEN
      VC    =   VC + FACT*ISFAC*GPIETP*(
     .          2*FP*FETAP*DFI*DFIETP-0.5D0*GPIETP*FIPEP2)
C     (1/M)-CORRECTIONS NON-ADIABATIC: NOT IMPLEMENTED
C     (1/M)-PION-VERTEX CORRECTIONS: NOT IMPLEMENTED
      ENDIF
C
C 2)  VECTOR PAIR TERMS:
C
      IF(IPIPI1.EQ.1) THEN
C     PI-PI(I=1):
      VC    =   VC   + 4*FACT*ISFAC*(GVPAIR*FP2*FIVC1
     .                          -0.25D0*GVPAIR**2*FIVC2)
c  a la pentium versie:
c     VSIG  =   VSIG + 2*FACT*ISFAC*(-2*(GVPAIR+FVPAIR)*
c    .          FP2*(X1*DFI+2*DDFI)*DFI*X1*PIM/AMN)/3.D0
c     VTEN  =   VTEN + 2*FACT*ISFAC*(-2*(GVPAIR+FVPAIR)*
c    .          FP2*(X1*DFI-DDFI)*DFI*X1*PIM/AMN)/3.D0

c  a la photon versie:
      VSIG  =   VSIG + 2*FACT*ISFAC*(-2*(FVPAIR)*
     .          FP2*(X1*DFI+2*DDFI)*DFI*X1*PIM/AMN)/3.D0
      VTEN  =   VTEN + 2*FACT*ISFAC*(-2*(FVPAIR)*
     .          FP2*(X1*DFI-DDFI)*DFI*X1*PIM/AMN)/3.D0

c     VSIG  =   VSIG-0.5D0*FACT*ISFAC*(FVPAIR*PIM/AMN)**2*FIVS2/3.D0
c     VTEN  =   VTEN-0.5D0*FACT*ISFAC*(FVPAIR*PIM/AMN)**2*FIVT2/3.D0

C     (1/M)-PAIR-VERTEX CORRECTIONS:
      VSIG  =   VSIG - (4/3.D0)*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                (X1*DFI+2*DDFI)*DFI*X1
      VTEN  =   VTEN - (4/3.D0)*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                (X1*DFI-DDFI)*DFI*X1
      VSO   =   VSO  - 4*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*(X1*DFI)**2

       IF(INA.NE.0) THEN
C     (1/M)-CORRECTIONS NON-ADIABATIC:
      VC    =   VC - 2*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                (2*X2*DFI**2+DDFI**2)
      VSO   =   VSO- 2*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*2*X2*DFI**2
       ENDIF
       IF(IPV.NE.0) THEN
C     (1/M)-PION-VERTEX CORRECTIONS:
      VC    =   VC   - APV*2*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                 VKU/RATP**2*(DDFI+2*X1*DFI)
      VSO   =   VSO  - APV*4*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                 VKU/RATP**2*X1*DFI
       ENDIF
      ENDIF

C
C 3)  AXIAL PAIR TERMS OF THE FIRST CLASS:
C
      IF(IPIRO1.EQ.1) THEN
      VSIG  = VSIG - FACT*ISFAC*(4*GAPAIR*GRNN*FP*(PIM/AMN/6)*(
     .        (2*X1*DFI+DDFI)*FIRO-2*(1.D0+FRNN/GRNN)*DFI*DFIR))
c**  .         +GAPAIR**2*FIAS2 )

      VTEN  = VTEN - FACT*ISFAC*(4*GAPAIR*GRNN*FP*(PIM/AMN/6)*(
     .         (-X1*DFI+DDFI)*FIRO+(1.D0+FRNN/GRNN)*DFI*DFIR ))
      ENDIF
C
C 4)  AXIAL PAIR TERMS OF THE SECOND CLASS:
C
C  A) AXIAL QUANTUM NUMBERS:
      IF(IPIRO0.EQ.1) THEN
      VSIG  =   VSIG + FACT*(-1.5D0*HAPAIR**2*FIHS2
     .      -2*HAPAIR*GRNN*FP*( (2*X1*DFI+DDFI)*FIRO+DFI*DFIR) )
      VTEN  =   VTEN + FACT*(-1.5D0*HAPAIR**2*FIHT2
     .      -2*HAPAIR*GRNN*FP*( (-X1*DFI+DDFI)*FIRO+DFI*DFIR) )
      ENDIF
C
C 5)  AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :

C  A) AXIAL QUANTUM NUMBERS:
      IF(IPIOM.EQ.1) THEN
      VSIG  =   VSIG  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2
     .      -(2/3.D0)*HOPAIR*GONN*FP*( (2*X1*DFI+DDFI)*FIOM+DFI*DFIO) )
      VTEN  =   VTEN  + FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2
     .      -(2/3.D0)*HOPAIR*GONN*FP*( (-X1*DFI+DDFI)*FIOM+DFI*DFIO) )
      ENDIF
C
C 6)  VECTOR-MESON QUANTUM NUMBERS:
C
      IF(IPIROV.NE.0) THEN
      VC   =  VC   - 3*FACT*GPIROV*FP*GRNN*(1.D0+FRNN)*(PIM/AMN)
     .               *2*X1*(DDFI*DFIR+DFI*DDFIR+X1*DFI*DFIR)
c    .             - FACT*GPIROV**2*X1*FIHOC2
      VSIG =  VSIG - 2*FACT*GPIROV*FP*GRNN*(1.D0+FONN)*(PIM/AMN)
     .               *X1*(DDFI*DFIR+DFI*DDFIR+X1*DFI*DFIR)
      VTEN =  VTEN - 1*FACT*GPIROV*FP*GRNN*(1.D0+FONN)*(PIM/AMN)
     .               *X1*((X1*DFI-DDFI)*DFIR+DFI*(X1*DFIR-DDFIR))
      VSO  =  VSO  - 3*FACT*GPIROV*FP*GRNN*(PIM/AMN)
     .               *4*X2*DFI*DFIR
      ENDIF
      IF(IPIOMV.NE.0) THEN
      VC   =  VC   - FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FONN)*(PIM/AMN)
     .               *2*X1*(DDFI*DFIO+DFI*DDFIO+X1*DFI*DFIO)
c    .             - FACT*ISFAC*GPIOMV**2*X1*FIHOC2
      VSIG =  VSIG - 2*FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FRNN)*(PIM/AMN)
     .               *X1*(DDFI*DFIO+DFI*DDFIO+X1*DFI*DFIO)/3D0
      VTEN =  VTEN - 1*FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FRNN)*(PIM/AMN)
     .               *X1*((X1*DFI-DDFI)*DFIO+DFI*(X1*DFIO-DDFIO))/3D0
      VSO  =  VSO  - FACT*ISFAC*GPIOMV*FP*GONN*(PIM/AMN)
     .               *4*X2*DFI*DFIO
      ENDIF
C
C 7)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:
      IF(IPISI.EQ.1) THEN
C  1) PI-EPSILON CONTRIBUTION:
      gpisi = gpisig*dcos(ths)
      VSIG  =   VSIG  + FACT*ISFAC*( GPISI**2*FIPS2
     .     +2*GPISI*GEPNN*FP*( (2*X1*DFI+DDFI)*FIEP-DFI*DFIEP)/3 )
      VTEN  =   VTEN  + FACT*ISFAC*( GPISI**2*FIPT2
     .     +2*GPISI*GEPNN*FP*( ( -X1*DFI+DDFI)*FIEP-DFI*DFIEP)/3 )

       IF(INA.NE.0) THEN
C     (1/M)-CORRECTIONS NON-ADIABATIC:
      VSIG  =  VSIG - FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPNA1/3.D0
      VTEN  =  VTEN - FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPNA2/3.D0
       ENDIF
C     (1/M)-PION-VERTEX CORRECTIONS:
       IF(IPV.EQ.1) THEN
      VSIG = VSIG + APV*FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPPV1/3.D0
      VTEN = VTEN + APV*FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPPV2/3.D0
       ENDIF
      ENDIF
C
C 8)  PSEUDO SCALAR (PION-POMERON) PAIR TERMS:
      IF(IPIPOM.EQ.1) THEN
      VSIG  =   VSIG  - FACT*ISFAC*( GPIPOM**2*FPIPOS
     .     +2*GPIPOM*GPOM*FP*( (2*X1*DFI+DDFI)*FIPO-DFI*DFIPO)/3 )
      VTEN  =   VTEN  - FACT*ISFAC*( GPIPOM**2*FPIPOT
     .     +2*GPIPOM*GPOM*FP*( ( -X1*DFI+DDFI)*FIPO-DFI*DFIPO)/3 )

       IF(INA.NE.0) THEN
C     (1/M)-CORRECTIONS NON-ADIABATIC:
      VSIG  =  VSIG + FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPONA1/3.D0
      VTEN  =  VTEN + FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPONA2/3.D0
       ENDIF
C     (1/M)-PION-VERTEX CORRECTIONS:
       IF(IPV.EQ.1) THEN
      VSIG = VSIG - APV*FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPOPV1/3.D0
      VTEN = VTEN - APV*FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPOPV2/3.D0
       ENDIF
      ENDIF
C
C 9)  SCALAR (EPSILON-EPSILON) PAIR TERMS:
      IF(ISISI.EQ.1) THEN
      VC    =   VC    - FACT*( GEPAIR**2*FIEPC2
     .        - 2*GEPAIR*GEPNN**2*FIEP**2)
       IF(INA.NE.0) THEN
C     (1/M)-CORRECTIONS NON-ADIABATIC:
      VC    =  VC - FACT*GEPAIR*GEPNN**2*(PIM/AMN)*FEPNA3
       ENDIF
      ENDIF
C
C10)  K-KBAR(I=0) SCALAR PAIR TERMS:
      IF(IKKB0.EQ.1) THEN
      VC    =   VC + FACT*GKKB0*( - GKKB0*FIMKA2 +
     .                     FNLK2*DH11YL + 3*FNSK2*DH11YS)
C     VSO   =  VSO - FACT*GKKB0*(PIM/DSQRT(AMN))*2D0*X1*
C    .         (3D0*FNSK2/DSQRT(AMYS)*FISOKS+FNLK2/DSQRT(AMYL)*FISOKL)
C     VSO   =  VSO + FACT*GKKB0**2*(PIM/AMN)**2*X1*FISOKA
      ENDIF
C     K-KBAR(I=1) SCALAR PAIR TERMS:
      IF(IKKB1.EQ.1) THEN
      VC    =   VC - FACT*ISFAC*GKKB1*(
     .                     FNSK2*DH11YS + GKKB1*FIMKA2)
C     VSO   =  VSO + FACT*ISFAC*GKKB1*(PIM/DSQRT(AMN))*2D0*X1*
C    .                    FNSK2/DSQRT(AMYS)*FISOKS
C     VSO   =  VSO + FACT*ISFAC*GKKB1**2*(PIM/AMN)**2*X1*FISOKA
      ENDIF

C     TWO-PAIR CONTRIBUTIONS:
C     VC2P  =0.D0
C     VSIG2P=0.D0
C     VTEN2P=0.D0
C     VSO2P =0.D0
C     VC2P  =   VC2P+FACT*( -3*GSPAIR**2*FISC2)
C     VC2P  =   VC2P+FACT*ISFAC*GPIET*(-0.5D0*GPIET*FIPET2)
C     VC2P  =   VC2P+FACT*ISFAC*GPIETP*(-0.5D0*GPIETP*FIPEP2)
C     VC2P  =   VC2P + 4*FACT*ISFAC*( -0.25D0*GVPAIR**2*FIVC2)
c     VSIG2P=   VSIG2P-0.5D0*FACT*ISFAC*(FVPAIR*PIM/AMN)**2*FIVS2/3.D0
c     VTEN2P=   VTEN2P-0.5D0*FACT*ISFAC*(FVPAIR*PIM/AMN)**2*FIVT2/3.D0
C     VSIG2P=   VSIG2P - FACT*ISFAC*(+GAPAIR**2*FIAS2 )
C     VSIG2P=   VSIG2P + FACT*(-1.5D0*HAPAIR**2*FIHS2)
C     VTEN2P=   VTEN2P + FACT*(-1.5D0*HAPAIR**2*FIHT2)
C     VC2P  =   VC2P - FACT*GPIROV**2*X1*FIHC2
C     VSIG2P=   VSIG2P+ FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOS2)
C     VTEN2P=   VTEN2P+ FACT*ISFAC*(-0.5D0*HOPAIR**2*FIHOT2)
C     VC2P =  VC2P - FACT*ISFAC*GPIOMV**2*X1*FIHOC2
C     VSIG2P=   VSIG2P+ FACT*ISFAC*( GPISIG**2*FIPS2)
C     VTEN2P=   VTEN2P+ FACT*ISFAC*( GPISIG**2*FIPT2)
C     VSIG2P=   VSIG2P- FACT*ISFAC*( GPIPOM**2*FPIPOS)
C     VTEN2P=   VTEN2P- FACT*ISFAC*( GPIPOM**2*FPIPOT)
C     VC2P  =   VC2P  - FACT*( GEPAIR**2*FIEPC2)
C     ONE-PAIR CONTRIBUTIONS:
C     VC1P = VC-VC2P
C     VSIG1P=VSIG-VSIG2P
C     VTEN1P=VTEN-VTEN2P
C     VSO1P=VSO-VSO2P
CC
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      if(icall.eq.0.and.nschr.eq.1) then
      vca   =      + FACT*( 6*GSPAIR*FP2*DFI*DFI-3*GSPAIR**2*FISC2)
      vsa   = 0.d0
      vca1  =      - 3*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA1
      write(6,*) 'vca1=',vca1
      vca1  = vca1 - APV*6*FACT*GSPAIR*FP2*(PIM/AMN)* FISNA2
      write(6,*) 'vca1=',vca1
      vsa1  = 0.d0
      vcb   =      + FACT*ISFAC*GPIET*(
     .          2*FP*FETA*DFI*DFIETA-0.5D0*GPIET*FIPET2)
      vsb   = 0.d0
      vcb1  = 0.d0
      vsb1  = 0.d0
      vcc   =        + 4*FACT*ISFAC*(GVPAIR*FP2*FIVC1
     .                          -0.25D0*GVPAIR**2*FIVC2)
      vsc   =        + 2*FACT*ISFAC*(
     .          -2*FVPAIR*FP2*(X1*DFI+2*DDFI)*DFI*X1*PIM/AMN)/3.D0
      vsc   = vsc    - (4/3.D0)*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                (X1*DFI+2*DDFI)*DFI*X1
      vcc1  =      - 2*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                (2*X2*DFI**2+DDFI**2)
      vcc1  =   vcc1 - APV*2*ISFAC*FACT*GVPAIR*FP2*(PIM/AMN)*
     .                 VKU/RATP**2*(DDFI+2*X1*DFI)
      vsc1  = 0.d0
      vcd   = 0.d0
      vsd   =        - FACT*ISFAC*(4*GAPAIR*GRNN*FP*(PIM/AMN/6)*(
     .          (2*X1*DFI+DDFI)*FIRO-2*(1.D0+FRNN/GRNN)*DFI*DFIR)
     .           +GAPAIR**2*FIAS2 )
      vcd1 = 0.d0
      vsd1 = 0.d0
      vce  = 0.d0
      vse   =         + FACT*ISFAC*( GPISI**2*FIPS2
     .     +2*GPISI*GEPNN*FP*( (2*X1*DFI+DDFI)*FIEP-DFI*DFIEP)/3 )
      vce1 = 0.d0
      vse1  =       - FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPNA1/3.D0
      vse1 = vse1 + APV*FACT*ISFAC*GPISI*GEPNN*FP*(PIM/AMN)*FEPPV1/3.D0
      vcf = 0.d0
      vsf   =         - FACT*ISFAC*( GPIPOM**2*FPIPOS
     .     +2*GPIPOM*GPOM*FP*( (2*X1*DFI+DDFI)*FIPO-DFI*DFIPO)/3 )
      vcf1 = 0.d0
      vsf1  =       + FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPONA1/3.D0
      vsf1 = vsf1 - APV*FACT*ISFAC*GPIPOM*GPOM*FP*(PIM/AMN)*FPOPV1/3.D0
      vcg   =         - FACT*( GEPAIR**2*FIEPC2
     .        - 2*GEPAIR*GEPNN**2*FIEP**2)
      vsg = 0.d0
      vcg1  =     - FACT*GEPAIR*GEPNN**2*(PIM/AMN)*FEPNA3
      vsg1= 0.d0
      write(6,1001) x,vca,vsa,vcb,vsb,vcc,vsc,vcd,vsd,
     .                vce,vse,vcf,vsf,vcg,vsg
      write(6,*) '*****************************************************'
 1001 format(/,
     .' IN PAIRS: x=',f7.3,',ADIABATIC POTENTIALS:',/,52('-'),/,
     .'  VCA=',F10.2,'  VSA=',F10.2,/,'  VCB=',F10.2,'  VSB=',F10.2,/,
     .'  VCC=',F10.2,'  VSC=',F10.2,/,'  VCD=',F10.2,'  VSD=',F10.2,/,
     .'  VCE=',F10.2,'  VSE=',F10.2,/,'  VCF=',F10.2,'  VSF=',F10.2,/,
     .'  VCG=',F10.2,'  VSG=',F10.2,/)
      write(6,*) '*****************************************************'
      write(6,1002) x,vca1,vsa1,vcb1,vsb1,vcc1,vsc1,vcd1,vsd1,
     .                vce1,vse1,vcf1,vsf1,vcg1,vsg1
 1002 format(/,
     .' IN PAIRS: x=',f7.3,',NON-ADIABATIC TERMS :',/,52('-'),/,
     .' VCA1=',F10.2,' VSA1=',F10.2,/,' VCB1=',F10.2,' VSB1=',F10.2,/,
     .' VCC1=',F10.2,' VSC1=',F10.2,/,' VCD1=',F10.2,' VSD1=',F10.2,/,
     .' VCE1=',F10.2,' VSE1=',F10.2,/,' VCF1=',F10.2,' VSF1=',F10.2,/,
     .' VCG1=',F10.2,' VSG1=',F10.2,/)
      write(6,*) '*****************************************************'
      endif
      ICALL=1
      RETURN
      END


C **********************************************************************
      SUBROUTINE PAIRSU3(X,ISPIN,IIMIN,
     .           ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,ALAMK)
C **********************************************************************
C     NNPAIRS09: 1. 1/M-CORRECTIONS FOR PIOM INCLUDED!!   (SEE OMPAIR!!)
C                2. OMITTED THE 1/M^2-TERMS for IPIOM.EQ.2, KEPT FOR IPIRO1.EQ.1
C                3. INCLUDED ARE THE AXIAL 1^{++} SU3-SINGLET PAIR TERMS
C *   NNPAIRS.AUG04.F : AUGUST 2004  VERSION: SU3-BREAKING IN PAIRS!!
C*    DIFFERENCE FEB -VERSION: IDAM, printing, and SCALAR-DER. EXPRESSIONS
C*    DIFFERENCE OCTa-VERSION: OCTET AXIAL SECOND KIND
C *   I.E. WITH SCALAR-DERIVATIVE AND TENSOR-PAIR COUPLING INCLUDED!!!
C
C*    PROGRAM SHOULD BE CALLED WITH IPIOM=2 !!!!
C **********************************************************************
C *   SU3: PI-PI-, ETA-ETA-, KK- ETC. PAIR NN-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 CENNN1 ETC.:
C     (i) NNCCPR: L+R CONTRIBUTIONS INCLUDED,
C     (ii) NNCCPR: 1 <-> 2 INTERCHANGE FACTOR INCLUDED (EXTRA DIAGRAMS)
C     (iii) FFUN1: identical particle factor already included in
C                  NNPRCC by factor IP12!
C     (iv)  FFUN2: identical particle factor included (2 contractions),
C                  facip=2.
C     note: for KK there is never an FACIP=2, everything
C           is accounted for by the isospin factor
C
C     ALTERNATIVE NOMENCLATURE PAIR COUPLINGS:
C     GAPAIR=GPIRO1, HAPAIR=GPIRO0, GPPAIR=GPISI, GEPAIR=GSISI
C     DOUBLE PAIR-VERTEX CONTRIBUTION, REGULATION PARAMETERS:
C     PIPI(I=0): N2PR0;  PIPI(I=1): N2PR1; PIRO(I=1), PISI: NRPRA
C     PIOM     : NRPRB;
C
C     CONVENTIONS A LA PAPER II (SEE (PI-RO)_{1} AND (PI-EPSILON)!
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/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/ PIM,AMP,AMY,ALLX(6)

      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FUI,DFUI,FUISS,DFUISS
     .           ,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2

      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/AVEC(2),AMVEC(2),AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEP,ASIG(2),AMSIG(2),AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/ALLPR/GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIRO0,GPISI,GPIOM
     .,GSISI,GPIET,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA         ! MARCH 2009
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,IOMETA          ! MARCH 2009
      COMMON/TWOPR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB
      COMMON/PAIROM/IDAM,IPV,INA,IOFF
      COMMON/ZEROS/IZPS,IZVC,IZSC,IZAX

      COMMON/PSCOP/ALP,APV,FP ,F62,F92,F120,F12C,FCHPI
      COMMON/COUPL/ F(11),G(11),FD(11),FV(11),GS(11),GD(11)
C
      DIMENSION FUN(9),BFUN(10),WGHTID(4)

C     communication with routine NNPRCC:
      COMMON/PRCPLS/CENPR(2),SIGPR(2)
      COMMON/CPLRIJ/FA(11),FB(11),PR(11)
      COMMON/US3/CCPR1(3,2),CCPR2(5,2),CCPRG(3,2),CCPRF(3,2),
     .CCPR4(3,2),CCPR4F(3,2),CCPR5(4,2),CCPR6(2),CCPR7(2,2),
     .CCPR8(5,2),CCPR8F(5,2),CCPR9(3,2),CCPR10(8,2),
     .CCPR11(3,2),CCPR11F(3,2),CCPR12(5,2),
     .CCPR13(4,2),CCPR13F(4,2)                  ! MARCH 2009

C     communication with routine WRITEPR:
      COMMON/PRWRITE/VPRA(1,3,4,4),VPRB(1,3,4,4),VPRC(1,3,4,4)
     .              ,VPRD(1,3,4,4),VPRE(1,3,4,4),VPRF(1,3,4,4)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/,NSCHR/0/
      DATA SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/
      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEP/760.D0/,
     .     AMN/938.2796D0/,FACT/138.041D0/
      DATA AMK/495.6D0/,AMKS/890.2D0/,AMSCK/890.D0/,
     .     AMYL/1115.D0/,AMYS/1195.D0/,DAM/230.D0/
c     DATA ALPVPR/0.355D0/,ALVDPR/1.D0/,ALVVPR/0.275D0/,
c    .     ALSCPR/1.D0/,ALPAPR/0.355D0/
c     DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/0/,IPISI/1/,
c    .ISISI/1/,IPIET/0/,IPIETP/0/,IKKB0/0/,IKKB1/0/,IPIPOM/1/,
c    .IPIROV/0/,IPIOMV/0/
C     DATA N2PR0/0/,N2PR1/0/,N2PRA/1/,N2PRB/1/
c     DATA IIMIN/1/
c     data iimin/2/
      DATA IBROAD/1/
!!!      data icall/0/
      DATA AMSCR/750.D0/

      SAVE FACT,AMN,DAM,AA
C     SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7
C
      IF(ICALL.EQ.0) THEN
c       XBEGIN = X
        FACT = PIM
        AMN  = DSQRT(AMP*AMY)
        DAM  = IDAM*(AMYL+AMYS-AMP-AMY)/2.D0
        AA   = DAM/PIM
        if(nschr.ne.0) write(6,199) IZSC,IBROAD,IDAM,INA,IPV,IOFF,
     .  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,
     .  ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,IPIPI2,IOMETA,  ! MARCH 2009
     .  GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIET,GPISI,
     .  GSISI,GPIRO0,GPIOM,GPIETP,GPIPOM,GOMETA,                ! MARCH 2009
     .  N2PR0,N2PR1,N2PRA,N2PRB,IIMIN
199     FORMAT(//,'  IN SU3PAIR.NOV02: IZSC,IBROAD=',2I2,' IDAMPR=',I2,
     .  ' INA=',I2,' IPV=',I2,' IOFF=',I2,//,
     .  11X,'  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI=',6I2,//,
     .  11X,'  ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV=',6I2,//,
     .  11X,'  IPIPI2,IOMETA=',2I2,//,
     .  11X,'  GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIET,GPISI=',/,6(F10.5),//,
     .  11X,'  GSISI,GPIRO0,GPIOM,GPIETP,GPIPOM,GOMETA=',/,6(F10.5),//,
     .  11X,'  N2PR0,N2PR1,N2PRA,N2PRB=',4I2,//,
     .  11X,'  IIMIN=',I2,//)
c       ICALL=1
      ENDIF
C
C     WEIGHTS OMEGA AND PHI in PHI8, ACCORDING TO MIXING:
c      THV = 37.5D0*DACOS(-1.D0)/180.D0
c      THPS= -23.0D0*DACOS(-1.D0)/180.D0
      THV = PAR(10,3)*DACOS(-1.D0)/180.D0
      THPS= PAR(10,2)*DACOS(-1.D0)/180.D0
      WGHTID(1) = DSIN(THV)
      WGHTID(2) = DCOS(THV)
      WGHTID(3) = DCOS(THV)
      WGHTID(4) =-DSIN(THV)

c     DO 1 I=2,NMAX
c     X = XA(I)
      VCNN  =0.D0
      VSNN  =0.D0
      VTNN  =0.D0
      VONN  =0.D0
      DO 250 ITYPV=1,3
      DO 250 M=1,4
      DO 250 N=1,4
      VPRA(1,ITYPV,M,N)=0.D0
      VPRB(1,ITYPV,M,N)=0.D0
      VPRC(1,ITYPV,M,N)=0.D0
      VPRD(1,ITYPV,M,N)=0.D0
      VPRE(1,ITYPV,M,N)=0.D0
  250 VPRF(1,ITYPV,M,N)=0.D0
CC
      X1   =1.D0/X
      X2   = X1*X1
CC
C     PION:
      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)
CC
C     ETA:
      CALL FFUN(2,X,AME,ALMP8,FIETA,DFIETA,DDFETA,D3FETA)
C     ETAP:
      CALL FFUN(2,X,AMX,ALMP1,FIETP,DFIETP,DDFETP,D3FETP)
CC
C     KAON:
      CALL FFUN(2,X,AMK,ALAMK,FIKA,DFIKA,DDFKA,D3FKA)
C     K*(892):
      CALL FFUN(2,X,AMKS,ALMV8,FIKS,DFIKS,DDFKS,D3FKS)
CC
      IF(IBROAD.EQ.0) THEN
      CALL FFUN(2,X,AMRO,ALMV8,FIRO,DFIR,DDFIR,D3FIR)
      ELSE
      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
      ENDIF
CC
      CALL FFUN(2,X,AMOM,ALMV1,FIOM,DFIOM,DDFIO,D3FIO)
CC
      CALL FFUN(2,X,AMFI,ALMV8,FIPH,DFIPH,DDFIPH,D3FIPH)
CC
      IF(IBROAD.EQ.0) THEN
      IF(IZSC.EQ.0) CALL
     .FFUN(2,X,AMEP,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP)
      IF(IZSC.NE.0) CALL
     .FFUNZ(2,X,AMEP,AMSCR,ALMS1,FIEP,DFIEP,DDFIEP,D3FIEP)
      ELSE
      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
      ENDIF
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/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)

C     A1:
c     CALL FFUN(2,X,AMA1,ALMA1,FIA1,DFIA1,DDFIA1,D3FIA1)

C     ****************************************************
C     ****************************************************
C     **                                                **
C     **       CONSTRUCTION OF THE POTENTIALS           **
C     **                                                **
C     ****************************************************
C     ****************************************************
C A)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :
C
      IF(IPIPI0.NE.0) THEN
      DO 10 II=IIMIN,3
      GOTO(11,12,13),II

C     PI-PI(I=0):
11    FFUN1 = 0.5D0*DFI*DFI
      CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)*FACIP
c     VCNN     =   VCNN    + FACT*( 6*GPIPI0*F(1)**2*FFUN1 +
c    .             N2PR0*3*GPIPI0**2*FFUN2 )*FACIP
      BFUN1 = (2*DFI*DFI/X/X+DDFI*DDFI)
      AMPS  = PIM
      FACIPP= FACIP
      M = 1
      N = 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
      BFUN1 = (2*DFIETA*DFIETA/X/X+DDFETA*DDFETA)
      AMPS  = AME
      FACIPP= FACIP
      M = 3
      N = 3
      GOTO 14

C     KA-KA(I=0):
 13   IF(IDAM.EQ.0) THEN
      FFUN1 = 0.5D0*DFIKA*DFIKA
      ELSE
      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,DAM,FUN)
      FFUN1 =  0.5D0*FUN(4)
      ENDIF
      CALL HFUN(0,X,AMK,AMK,ALAMK,ALAMK,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)
      BFUN1 = (2*DFIKA*DFIKA/X/X+DDFKA*DDFKA)
      AMPS  = AMK
      FACIPP= 1.D0
      M = 2
      N = 2
      GOTO 14

14    IF(II.NE.3) THEN
      CALL BMNFUN(-1,-1,X,AMPS,AMPS,ALMP8,ALMP8,BFUN)
      BFUN2 = BFUN(1)
      CALL BMNFUN( 0, 0,X,AMPS,AMPS,ALMP8,ALMP8,BFUN)
      BFUN2 = BFUN2+2*BFUN(4)
      CALL BMNFUN(+1,+1,X,AMPS,AMPS,ALMP8,ALMP8,BFUN)
      ENDIF
      IF(II.EQ.3) THEN
      CALL BMNFUN(-1,-1,X,AMPS,AMPS,ALAMK,ALAMK,BFUN)
      BFUN2 = BFUN(1)
      CALL BMNFUN( 0, 0,X,AMPS,AMPS,ALAMK,ALAMK,BFUN)
      BFUN2 = BFUN2+2*BFUN(4)
      CALL BMNFUN(+1,+1,X,AMPS,AMPS,ALAMK,ALAMK,BFUN)
      ENDIF
      BFUN2 = BFUN2+2*BFUN(4)/X/X+BFUN(9)
      BFUN2 = BFUN2*FACIPP

      VCNN     =   VCNN    + FACT*( CCPR1(II,1)*FFUN1 +
     .                       N2PR0*CCPR1(II,2)*FFUN2 )
      VPRA(1,1,M,N)=VPRA(1,1,M,N)  + FACT*( CCPR1(II,1)*FFUN1 +
     .                               N2PR0*CCPR1(II,2)*FFUN2 )
      VCNN     =   VCNN    - FACT*( 2*CCPR9(II,1)*BFUN1 +
     .                       0.5D0*N2PR0*CCPR9(II,2)*BFUN2 )
10    CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(1,x,ispin)
      ENDIF
C------------------------------------------------------------
C
C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :
C
C------------------------------------------------------------
      IF(IPIET.NE.0) THEN
      DO 20 II=IIMIN,5
      GOTO(21,22,25,26,27),II
C     PI-ETA:
21    FFUN1 = 0.5D0*DFI*DFIETA
      CALL HFUN(0,X,PIM,AME,ALMP8,ALMP8,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)
      ISFAC = -3+4*ISPIN
      M = 1
      N = 3
      GOTO 28

C     KA-KA(8S)(I=1):
 22   IF(IDAM.EQ.0) THEN
      FFUN1 = 0.5D0*DFIKA*DFIKA
      ELSE
      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,DAM,FUN)
      FFUN1 =  0.5D0*FUN(4)
      ENDIF
      CALL HFUN(0,X,AMK,AMK,ALAMK,ALAMK,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)
      ISFAC = -3+4*ISPIN
      M = 2
      N = 2
      GOTO 28

C     PI-PI(8S)(I=0):
25    FFUN1 = 0.5D0*DFI*DFI
      CALL HFUN(0,X,PIM,PIM,ALMP8,ALMP8,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)*FACIP
      ISFAC = 1
      M = 1
      N = 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
      ISFAC = 1
      M = 3
      N = 3
      GOTO 28

C     KA-KA(8S)(I=0):
 27   IF(IDAM.EQ.0) THEN
      FFUN1 = 0.5D0*DFIKA*DFIKA
      ELSE
      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,DAM,FUN)
      FFUN1 =  0.5D0*FUN(4)
      ENDIf
      CALL HFUN(0,X,AMK,AMK,ALAMK,ALAMK,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)
      ISFAC = 1
      M = 2
      N = 2
      GOTO 28

28    VCNN   =   VCNN    + ISFAC*FACT*(
     .           CCPR2(II,1)*FFUN1 + N2PRB*CCPR2(II,2)*FFUN2 )
      VPRB(1,1,M,N)=VPRB(1,1,M,N) + ISFAC*FACT*(
     .           CCPR2(II,1)*FFUN1 + N2PRB*CCPR2(II,2)*FFUN2 )
20    CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(2,x,ispin)
      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 C)  VECTOR SU(3)-OCTET PAIR TERMS, {8a}->{8}x{8} :
C
C------------------------------------------------------------
C CHECK CALCULATION FUNCTIONS!
      IF(IPIPI1.NE.0) THEN
      DO 30 II=IIMIN,3
      GOTO(31,32,35),II
C     PI-PI(I=1):
31    AM1 = PIM
      AM2 = PIM
      DAMH  = 0.D0
      FFSIG1 = 0.5D0*X1*(X1*DFI*DFI+2*DFI*DDFI)*(PIM/AMPRO)
      FFTEN1 = 0.5D0*X1*(X1*DFI*DFI-1*DFI*DDFI)*(PIM/AMPRO)
      FFSO1 =  X2*DFI*DFI*PIM/AMN/2.D0
      ISFAC  = -3+4*ISPIN
      ALM1 = ALMP8
      ALM2 = ALMP8
      M = 1
      N = 1
      GOTO 36

C     KA-KA(8A)(I=1):
32    AM1 = AMK
      AM2 = AMK
      DAMH  = DAM
c     DAMH  = 0.D0
      IF(IDAM.EQ.0) THEN
      FFSIG1 = 0.5D0*X1*(X1*DFIKA*DFIKA+2*DFIKA*DDFKA)*(PIM/AMPRO)
      FFTEN1 = 0.5D0*X1*(X1*DFIKA*DFIKA-DFIKA*DDFKA)*(PIM/AMPRO)
      ELSE
      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,DAMH,FUN)
      FFSIG1 = 0.5D0*X1*(  X1*FUN(4)+2*FUN(8))*(PIM/AMPRO)
      FFTEN1 = 0.5D0*X1*(  X1*FUN(4)-1*FUN(8))*(PIM/AMPRO)
      ENDIF
      FFSO1 =  X2*DFIKA*DFIKA*PIM/AMN/2.D0
      ISFAC  = -3+4*ISPIN
      ALM1 = ALAMK
      ALM2 = ALAMK
      M = 2
      N = 2
      GOTO 36

C     KA-KA(8A)(I=0):
35    AM1 = AMK
      AM2 = AMK
      DAMH  = DAM
c     DAMH  = 0.D0
      IF(IDAM.EQ.0) THEN
      FFSIG1 = 0.5D0*X1*(X1*DFIKA*DFIKA+2*DFIKA*DDFKA)*(PIM/AMPRO)
      FFTEN1 = 0.5D0*X1*(X1*DFIKA*DFIKA-DFIKA*DDFKA)*(PIM/AMPRO)
      ELSE
      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,DAMH,FUN)
      FFSIG1 = 0.5D0*X1*(  X1*FUN(4)+2*FUN(8))*(PIM/AMPRO)
      FFTEN1 = 0.5D0*X1*(  X1*FUN(4)-1*FUN(8))*(PIM/AMPRO)
      ENDIF
      FFSO1 =  X2*DFIKA*DFIKA*PIM/AMN/2.D0
      ISFAC  = 1
      ALM1 = ALAMK
      ALM2 = ALAMK
      M = 2
      N = 2
      GOTO 36

36    CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,DAMH,FUN)
      FGCEN1 = FUN(4)/2.D0
      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,DAMH,FUN)
      HFUN0 = FUN(1)

c*    photon/src/rspace:
c**   FGCEN2 = -.5D0*(FI11*FI20+FI10*FI21-4*HFUN0)
c*    pentiumII/tokyo/nnprogs:
      FGCEN2 = -.25D0*(FI11*FI20+FI10*FI21-4*HFUN0)

      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,DAMH,FUN)
      DA11 = FUN(4)
      DA12 = FUN(8)
      FFSIG2 = -.5D0*X1*(X1*DA11+2*DA12)*(PIM/AMPRO)**2
      FFTEN2 = -.5D0*X1*(2*X1*DA11-2*DA12)*(PIM/AMPRO)**2

      VCNN  =   VCNN  + ISFAC*FACT*( CCPRG(II,1)*FGCEN1
     .                      + N2PR1*CCPRG(II,2)*FGCEN2 )

      VSNN  =   VSNN  - ISFAC*FACT*( CCPRF(II,1)*FFSIG1/3.D0)
c    .                  + N2PR1*CCPRF(II,2)*FFSIG2/3.D0 )

      VTNN  =   VTNN  - ISFAC*FACT*( CCPRF(II,1)*FFTEN1/3.D0)
c    .                  + N2PR1*CCPRF(II,2)*FFTEN2/3.D0 )
      VONN  =   VONN  - ISFAC*FACT*CCPRG(II,1)*FFSO1

      VPRC(1,1,M,N)=VPRC(1,1,M,N)+ISFAC*FACT*( CCPRG(II,1)*FGCEN1
     .                        + N2PR1*CCPRG(II,2)*FGCEN2 )
      VPRC(1,2,M,N)=VPRC(1,2,M,N)-ISFAC*FACT*(CCPRF(II,1)*FFSIG1/3.D0)
c    .                    + N2PR1*CCPRF(II,2)*FFSIG2/3.D0 )
30    CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(3,x,ispin)
      ENDIF
C------------------------------------------------------------
C
C D)  AXIAL PAIR TERMS OF THE FIRST CLASS:
C
C------------------------------------------------------------
      IF(IPIRO1.NE.0) THEN
      DO 40 II=IIMIN,3
      GOTO(41,42,45),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*    CALL HFUN(0,X,AM1,AM2,ALMP8,ALMV8,0.D0,FUN)
c*    photon/src/rspace:
c*    FFSIG2 = -.5D0*FUN(1)
      IF(IBROAD.EQ.0) THEN
      CALL HFUN(0,X,PIM,AMRO,ALMP8,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      ELSE
      FFSIG2 = 0.D0
      DO 411 JJ=1,2
      CALL HFUN(0,X,PIM,AMVEC(JJ),ALMP8,ALMV8,0.D0,FUN)
411   FFSIG2 = FFSIG2-.5D0*AVEC(JJ)*FUN(1)
      ENDIF
      ISFAC  = -3+4*ISPIN
      M = 1
      N = 1
      GOTO 48

C     KA-K*(AXIAL)(I=1):
 42   IF(IDAM.EQ.0) THEN
      FMSIG1 = 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS
      FESIG1 = 0.5D0* DFIKA*DFIKS
      FMTEN1 = 0.5D0* (-X1*DFIKA+DDFKA)*FIKS
      ELSE
      CALL DKFUN(X,AMK,AMKS,ALAMK,ALMV8,DAM,FUN)
      FMSIG1 = 0.5D0* (2*X1*FUN(2)+FUN(5))
      FESIG1 = 0.5D0* FUN(3)
      FMTEN1 = 0.5D0* ( -X1*FUN(2)+FUN(5))
      ENDIF
      CALL HFUN(0,X,AMK,AMKS,ALAMK,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      ISFAC  = -3+4*ISPIN
      M = 2
      N = 2
      GOTO 48

C     KA-K*(AXIAL)(I=0):
 45   IF(IDAM.EQ.0) THEN
      FMSIG1 = 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS
      FESIG1 = 0.5D0* DFIKA*DFIKS
      FMTEN1 = 0.5D0* (-X1*DFIKA+DDFKA)*FIKS
      ELSE
      CALL DKFUN(X,AMK,AMKS,ALAMK,ALMV8,DAM,FUN)
      FMSIG1 = 0.5D0* (2*X1*FUN(2)+FUN(5))
      FESIG1 = 0.5D0* FUN(3)
      FMTEN1 = 0.5D0* ( -X1*FUN(2)+FUN(5))
      ENDIF
      CALL HFUN(0,X,AMK,AMKS,ALAMK,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      ISFAC  = 1
      M = 2
      N = 2
      GOTO 48

48    FFSIG1 = FMSIG1
      FFTEN1 = FMTEN1
      FETEN1 = FESIG1

      VSNN   =   VSNN  - ISFAC*FACT*(
     .            (PIM/AMN/6.D0)*( CCPR4(II,1)*FFSIG1
     .           -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 )
     .           - N2PRA*CCPR4(II,2)*FFSIG2 )

      VTNN   =   VTNN  - ISFAC*FACT*(PIM/AMN/6.D0)*(
     .           CCPR4(II,1)*FFTEN1
     .           + (CCPR4(II,1)+CCPR4F(II,1))*FETEN1 )
      VPRD(1,2,M,N)=VPRD(1,2,M,N) - ISFAC*FACT*(
     .            (PIM/AMN/6.D0)*( CCPR4(II,1)*FFSIG1
     .           -2*(CCPR4(II,1)+CCPR4F(II,1))*FESIG1 )
     .           - N2PRA*CCPR4(II,2)*FFSIG2 )
40    CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(4,x,ispin)
      ENDIF

C------------------------------------------------------------
C
C Dp)  AXIAL PAIR TERMS OF THE FIRST CLASS, SU3-SINGLET:
C
C------------------------------------------------------------
      IF(IPIRO0.EQ.2) THEN
      DO 140 II=1,4
      III = II
      IF(II.GE.3) III=II-1
      GOTO(141,142,143,144),II

C     PI-RHO(I=0):
141   FMSIG1 = 0.5D0* (2*X1*DFI+DDFI)*FIRO
      FESIG1 = 0.5D0* DFI*DFIR
      FMTEN1 = 0.5D0* (-X1*DFI+DDFI)*FIRO
      IF(IBROAD.EQ.0) THEN
      CALL HFUN(0,X,PIM,AMRO,ALMP8,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      ELSE
      FFSIG2 = 0.D0
      DO 1411 JJ=1,2
      CALL HFUN(0,X,PIM,AMVEC(JJ),ALMP8,ALMV8,0.D0,FUN)
1411  FFSIG2 = FFSIG2-.5D0*AVEC(JJ)*FUN(1)
      ENDIF
      FACII = 1.D0
      GOTO 148

C     ETA-OMEGA({8}):
142   FMSIG1 = 0.5D0* (2*X1*DFIETA+DDFETA)*FIOM
      FESIG1 = 0.5D0* DFIETA*DFIOM
      FMTEN1 = 0.5D0* (-X1*DFIETA+DDFETA)*FIOM
      CALL HFUN(0,X,AME,AMOM,ALMP8,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      FACII = WGHTID(1)
      GOTO 148

C     ETA-PHI({8}):
143   FMSIG1 = 0.5D0* (2*X1*DFIETA+DDFETA)*FIPH
      FESIG1 = 0.5D0* DFIETA*DFIPH
      FMTEN1 = 0.5D0* (-X1*DFIETA+DDFETA)*FIPH
      CALL HFUN(0,X,AME,AMFI,ALMP8,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      FACII = WGHTID(2)
      GOTO 148

C     KA-K*(AXIAL)(I=0):
144   IF(IDAM.EQ.0) THEN
      FMSIG1 = 0.5D0* (2*X1*DFIKA+DDFKA)*FIKS
      FESIG1 = 0.5D0* DFIKA*DFIKS
      FMTEN1 = 0.5D0* (-X1*DFIKA+DDFKA)*FIKS
      ELSE
      CALL DKFUN(X,AMK,AMKS,ALAMK,ALMV8,DAM,FUN)
      FMSIG1 = 0.5D0* (2*X1*FUN(2)+FUN(5))
      FESIG1 = 0.5D0* FUN(3)
      FMTEN1 = 0.5D0* ( -X1*FUN(2)+FUN(5))
      ENDIF
      CALL HFUN(0,X,AMK,AMKS,ALAMK,ALMV8,0.D0,FUN)
      FFSIG2 = -.5D0*FUN(1)
      FACII = 1.D0
      GOTO 148

148   FFSIG1 = FMSIG1
      FFTEN1 = FMTEN1
      FETEN1 = FESIG1

      VSNN   =   VSNN  - FACII*FACT*(
     .            (PIM/AMN/6.D0)*( CCPR11(III,1)*FFSIG1
     .           -2*(CCPR11(III,1)+CCPR11F(III,1))*FESIG1 )
     .           - N2PRA*CCPR11(III,2)*FFSIG2 )

      VTNN   =   VTNN  - FACII*FACT*(PIM/AMN/6.D0)*(
     .           CCPR11(II,1)*FFTEN1
     .           + (CCPR11(II,1)+CCPR11F(II,1))*FETEN1 )
140   CONTINUE
      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,8
      DO 90 II=1,8
      GOTO(91,92,93,94,95,96,97,98),II

C     PI-OMEGA:
91    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIOM+DFI*DFIOM)
      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIOM+DFI*DFIOM)
      CALL HFUN(0,X,PIM,AMOM,ALMP8,ALMV1,0.D0,FUN)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*WGHTID(1)
      GOTO 99

C     PI-PHI:
92    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIPH+DFI*DFIPH)
      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIPH+DFI*DFIPH)
      CALL HFUN(0,X,PIM,AMFI,ALMP8,ALMV8,0.D0,FUN)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*WGHTID(2)
      GOTO 99

C     ETA-RHO:
93    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)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*1.D0
      GOTO 99

C     KA-K*(8S)(I=1):
94    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,ALAMK,ALMV8,0.D0,FUN)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*1.D0
      GOTO 99

C     PI-RHO(8S)(I=0):
95    FFSIG1= -0.5D0*((2*X1*DFI+DDFI)*FIRO+DFI*DFIR )
      FFTEN1= -0.5D0*(( -X1*DFI+DDFI)*FIRO+DFI*DFIR )
      CALL HFUN(0,X,PIM,AMRO,ALMP8,ALMV8,0.D0,FUN)
      FACII = 1.D0
      GOTO 99

C     KA-K*(8S)(I=0):
96    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,ALAMK,ALMV8,0.D0,FUN)
      FACII = 1.D0
      GOTO 99

C     ETA-OMEGA(8s):
97    FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM )
      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIOM+DFIETA*DFIOM )
      CALL HFUN(0,X,AME,AMOM,ALMP8,ALMV1,0.D0,FUN)
      FACII = WGHTID(1)
      GOTO 99

C     ETA-PHI(8s):
98    FFSIG1= -0.5D0*((2*X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH)
      FFTEN1= -0.5D0*(( -X1*DFIETA+DDFETA)*FIPH+DFIETA*DFIPH)
      CALL HFUN(0,X,AME,AMFI,ALMP8,ALMV8,0.D0,FUN)
      FACII = WGHTID(2)
      GOTO 99

99    FFSIG2 = -0.5D0*( (2*X1*FUN(2)+FUN(5))
     .                 +(2*X1*FUN(3)+FUN(6)) +2*FUN(4) )
      FFTEN2 = -0.5D0*( (-X1*FUN(2)+FUN(5))
     .                  +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )

c     factor 4?!
      VSIG =   VSIG    + FACII*FACT*( 4*CCPR10(II,1)*FFSIG1
     .                   + N2PRB*CCPR10(II,2)*FFSIG2 )/3.D0
      VTEN =   VTEN    + FACII*FACT*( 4*CCPR10(II,1)*FFTEN1
     .                   + N2PRB*CCPR10(II,2)*FFSIG2 )/3.D0
c     VSIG =   VSIG    + FACII*FACT*( 1*CCPR10(II,1)*FFSIG1
c    .                   + N2PRB*CCPR10(II,2)*FFSIG2 )/3.D0
c     VTEN =   VTEN    + FACII*FACT*( 1*CCPR10(II,1)*FFTEN1
c    .                   + N2PRB*CCPR10(II,2)*FFSIG2 )/3.D0
90    CONTINUE
      ENDIF
C------------------------------------------------------------
C
C F)  AXIAL VECTOR (PION-EPSILON) PAIR TERMS:
C
C------------------------------------------------------------
      IF(IPISI.NE.0) THEN
      DO 50 II=IIMIN,4
c**   DO 50 ii=1,1
      GOTO(51,53,54,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 )
      ISFAC = -3+4*ISPIN
      AM1 = PIM
      ALM1 = ALMP8
      M = 1
      N = 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 )
      ISFAC = 1
      AM1 = AME
      ALM1 = ALMP8
      M = 3
      N = 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 )
      ISFAC = -3+4*ISPIN
      AM1 = PIM
      ALM1 = ALMP8
      AM2 = AMSST
      ALM2 = ALMS8
      M = 1
      N = 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 )
      ISFAC = 1
      AM1 = AME
      ALM1 = ALMP8
      AM2 = AMSST
      ALM2 = ALMS8
      M = 3
      N = 3
      GOTO 57

57    IF(II.LE.2) THEN
       IF(IBROAD.EQ.0) THEN
      AM2 = AMEP
      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN)
      FFSIG2 = 0.5D0*( (2*X1*FUN(2)+FUN(5))
     .                 +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )
      FFTEN2 = 0.5D0*( (-X1*FUN(2)+FUN(5))
     .                  +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )
       ELSE
      FFSIG2 = 0.D0
      FFTEN2 = 0.D0
      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) )
  112 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5))
     .                  +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )
       ENDIF
      ENDIF
      IF(II.GT.2) THEN
      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)
      FFSIG2 = 0.5D0*( (2*X1*FUN(2)+FUN(5))
     .               +(2*X1*FUN(3)+FUN(6)) -2*FUN(4) )
      FFTEN2 = 0.5D0*( (-X1*FUN(2)+FUN(5))
     .               +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )
      ENDIF

c     VSNN   =   VSNN  + ISFAC*FACT*( 4*CCPR5(II,1)*FFSIG1
c    .                     + N2PRA*CCPR5(II,2)*FFSIG2 )/3.D0

c     VTNN   =   VTNN  + ISFAC*FACT*( 4*CCPR5(II,1)*FFTEN1
c    .                     + N2PRA*CCPR5(II,2)*FFTEN2 )/3.D0

      VSNN   =   VSNN  + ISFAC*FACT*( 1*CCPR5(II,1)*FFSIG1
     .                     + N2PRA*CCPR5(II,2)*FFSIG2 )/3.D0

      VTNN   =   VTNN  + ISFAC*FACT*( 1*CCPR5(II,1)*FFTEN1
     .                     + N2PRA*CCPR5(II,2)*FFTEN2 )/3.D0
      VPRE(1,2,M,N)=VPRE(1,2,M,N) + ISFAC*FACT*( 4*CCPR5(II,1)*FFSIG1
     .                     + N2PRA*CCPR5(II,2)*FFSIG2 )/3.D0
50    CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(5,x,ispin)
      ENDIF
C------------------------------------------------------------
C
C G)  AXIAL VECTOR  (PS-POMERON) PAIR TERMS:
C
C------------------------------------------------------------
      IF(IPIPOM.NE.0) THEN
      DO 70 II=IIMIN,2
      GOTO(71,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 )
      ISFAC = -3+4*ISPIN
      AM1 = PIM
      ALM1 = ALMP8
      M = 1
      N = 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 )
      ISFAC = 1
      AM1 = AME
      ALM1 = ALMP8
      M = 3
      N = 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) )
      FFTEN2 =     0.5D0*( (-X1*FUN(2)+FUN(5))
     .             +(-X1*FUN(3)+FUN(6)) -2*FUN(4) )

c     VSNN   =   VSNN  - ISFAC*FACT*( 4*CCPR7(II,1)*FFSIG1
c    .                     + N2PRA*CCPR7(II,2)*FFSIG2 )/3.D0

c     VTNN   =   VTNN  - ISFAC*FACT*( 4*CCPR7(II,1)*FFTEN1
c    .                     + N2PRA*CCPR7(II,2)*FFTEN2 )/3.D0

      VSNN   =   VSNN  - ISFAC*FACT*( 1*CCPR7(II,1)*FFSIG1
     .                     + N2PRA*CCPR7(II,2)*FFSIG2 )/3.D0

      VTNN   =   VTNN  - ISFAC*FACT*( 1*CCPR7(II,1)*FFTEN1
     .                     + N2PRA*CCPR7(II,2)*FFTEN2 )/3.D0
      VPRF(1,2,M,N)=VPRF(1,2,M,N) - ISFAC*FACT*( 1*CCPR7(II,1)*FFSIG1
     .                     + N2PRA*CCPR7(II,2)*FFSIG2 )/3.D0
 70   CONTINUE
      if(icall.eq.0.and.nschr.eq.1) call writepr(6,x,ispin)
      ENDIF
C------------------------------------------------------------
C
C H)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :
C
C------------------------------------------------------------

C 7)  SCALAR (EPSILON-EPSILON) PAIR TERMS:
      IF(ISISI.NE.0.AND.IIMIN.EQ.1) THEN
C     EPSILON-EPSILON:
      FFUN1 = 0.5D0*FIEP*FIEP
      CALL HFUN(0,X,AMEP,AMEP,ALMS1,ALMS1,0.D0,FUN)
      FFUN2 = -0.5D0*FUN(1)*FACIP

      VPRGC =      +FACT*(N2PR0*CCPR6(2)*FFUN2+CCPR6(1)*FFUN1)

      if(icall.eq.0.and.nschr.eq.1) then
      write(6,*) ' NNPAIRS: EPSILON-EPSILON POTENTIAL:'
      write(6,*) ' x=',x,'  VCNN=',vprgc
      write(6,*) '**************************************************'
      endif
      VCNN = VCNN + VPRGC
      ENDIF

C     --------------------------------------------------------------
C
C I)  TENSOR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :
C
C     --------------------------------------------------------------
C     only 1-pair terms included!!
      IF(IPIPI2.NE.0) THEN
      DO 80 II=1,5
      GOTO(81,82,85,86,87),II
C     PI-ETA:
81    AM1 = PIM
      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
      ISFAC = -3+4*ISPIN
      GOTO 88

C     KA-KA(8S)(I=1):
82    AM1 = AMK
      AM2 = AMK
c      CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,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
      ISFAC = -3+4*ISPIN
      GOTO 88

C     PI-PI(8S)(I=0):
85    AM1 = PIM
      AM2 = PIM
      FCEN1 = 0.5D0*(DFI*DVKU+DVKU*DFI)
     .       +0.5D0*(2*X2*DFI*DFI+DDFI*DDFI)/3.D0
     .       -0.5D0*DFI*DFI/3.D0
      ISFAC = 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
      ISFAC = 1
      GOTO 88

C     KA-KA(8S)(I=0):
87    AM1 = AMK
      AM2 = AMK
c87    CALL DKFUN(X,AMK,AMK,ALAMK,ALAMK,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
      ISFAC = 1
      GOTO 88

88    IF(II.EQ.2.OR.II.EQ.5) THEN
      CALL HFUN(0,X,AM1,AM2,ALAMK,ALAMK,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 )
c     if(x.eq.0.01d0) then
c     write(6,*) 'at 80: ii=',ii,' x=',x,' fcen1=',fcen1
c     write(6,*) ' fsig1,ften1,fso1=',fsig1,ften1,fso1
c     write(6,*) ' ccpr8,ccpr8f=',ccpr8(ii,1),ccpr8f(ii,1)
c     endif
80    CONTINUE
      ENDIF

C     --------------------------------------------------------------
C
C J)  VECTOR (PION-A1) PAIR TERMS:
C
c     IF(IPIA1.EQ.1) THEN
c     VCNN  =   VCNN + FACT*ISFAC*GPIA1*(GPIA1*FIPA1C
c    .                 - FP*(PIM/AMN)*(2*X1*DFI+DDFI)*FIA1 )
c     VSNN  =   VSNN - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)*
c    .          ((2*X1*DFI+DDFI)*FIA1 + DFI*DFIA)*(4.D0/3.D0)
c     VTNN  =   VTNN - FACT*ISFAC*GPIA1*FA1*FP*(PIM/AMN)*
c    .          ((X1*DFI-DDFI)*FIA1 - DFI*DFIA)*(2.D0/3.D0)
c     ENDIF
C------------------------------------------------------------
C
C K)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:
C
C------------------------------------------------------------
      IF(IPSPR.NE.0) THEN
      DO 150 II=IIMIN,4
      GOTO(151,153,154,156),II

C     PI-EPSILON:
151   FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIEP +DFI*DFIEP)
      FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIEP +DFI*DFIEP )
      ISFAC = -3+4*ISPIN
      AM1 = PIM
      ALM1 = ALMP8
c     M = 1
c     N = 4
      GOTO 157

C     ETA-EPSILON:
153   FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIEP +DFIETA*DFIEP)
      FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIEP +DFIETA*DFIEP )
      ISFAC = 1
      AM1 = AME
      ALM1 = ALMP8
c     M = 3
c     N = 4
      GOTO 157

C     PI-SSTAR:
154   FFSIG1= 0.5D0*( (2*X1*DFI+DDFI)*FIST +DFI*DFIST)
      FFTEN1= 0.5D0*( (-X1*DFI+DDFI)*FIST +DFI*DFIST )
      ISFAC = -3+4*ISPIN
      AM1 = PIM
      ALM1 = ALMP8
      AM2 = AMSST
      ALM2 = ALMS8
c     M = 1
c     N = 3
      GOTO 157

C     ETA-SSTAR:
156   FFSIG1= 0.5D0*( (2*X1*DFIETA+DDFETA)*FIST +DFIETA*DFIST)
      FFTEN1= 0.5D0*( (-X1*DFIETA+DDFETA)*FIST +DFIETA*DFIST )
      ISFAC = 1
      AM1 = AME
      ALM1 = ALMP8
      AM2 = AMSST
      ALM2 = ALMS8
c     M = 3
c     N = 3
      GOTO 157

157   IF(II.LE.2) THEN
       IF(IBROAD.EQ.0) THEN
      AM2 = AMEP
      CALL HFUN(0,X,AM1,AM2,ALM1,ALMS1,0.D0,FUN)
      FFSIG2 = 0.5D0*( (2*X1*FUN(2)+FUN(5))
     .                 +(2*X1*FUN(3)+FUN(6)) +2*FUN(4) )
      FFTEN2 = 0.5D0*( (-X1*FUN(2)+FUN(5))
     .                  +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )
       ELSE
      FFSIG2 = 0.D0
      FFTEN2 = 0.D0
      DO 118 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) )
  118 FFTEN2 = FFTEN2+ ASIG(JJ)*0.5D0*( (-X1*FUN(2)+FUN(5))
     .                  +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )
       ENDIF
      ENDIF
      IF(II.GT.2) THEN
      CALL HFUN(0,X,AM1,AM2,ALM1,ALM2,0.D0,FUN)
      FFSIG2 = 0.5D0*( (2*X1*FUN(2)+FUN(5))
     .               +(2*X1*FUN(3)+FUN(6)) +2*FUN(4) )
      FFTEN2 = 0.5D0*( (-X1*FUN(2)+FUN(5))
     .               +(-X1*FUN(3)+FUN(6)) +2*FUN(4) )
      ENDIF

      VSNN   =   VSNN  + ISFAC*FACT*( 4*CCPR12(II,1)*FFSIG1
     .         + N2PRA*CCPR12(II,2)*FFSIG2 )/3.D0

      VTNN   =   VTNN  + ISFAC*FACT*( 4*CCPR12(II,1)*FFTEN1
     .         + N2PRA*CCPR12(II,2)*FFTEN2 )/3.D0

c     VPRE(1,2,M,N)=VPRE(1,2,M,N) + ISFAC*FACT*( 4*CCPR12(II,1)*FFSIG1
c    .              + N2PRA*CCPR12(II,2)*FFSIG2*PIM/AMN )*PIM/AMN/3.D0
150   CONTINUE
c**   if(icall.eq.0.and.nschr.eq.1) call writepr(5,x,ispin)
      ENDIF
C------------------------------------------------------------
C------------------------------------------------------------
C
C L)  VECTOR-MESON QUANTUM NUMBERS:
C
      IF(IPIROV.NE.0) THEN
      GRNN =  0.78D0
      FRNN =  3.7D0
      FIHOC2= 0D0
      VC   =  VC   - 3*FACT*GPIROV*FP*GRNN*(1.D0+FRNN)*(PIM/AMN)
     .               *2*X1*(DDFI*DFIR+DFI*DDFIR+X1*DFI*DFIR)
     .             - N2PRV*FACT*GPIROV**2*X1*FIHOC2
      VSIG =  VSIG - 2*FACT*GPIROV*FP*GRNN*(1.D0+FRNN)*(PIM/AMN)
     .               *X1*(DDFI*DFIR+DFI*DDFIR+X1*DFI*DFIR)
      VTEN =  VTEN - 1*FACT*GPIROV*FP*GRNN*(1.D0+FRNN)*(PIM/AMN)
     .               *X1*((X1*DFI-DDFI)*DFIR+DFI*(X1*DFIR-DDFIR))
      VSO  =  VSO  - 3*FACT*GPIROV*FP*GRNN*(PIM/AMN)
     .               *4*X2*DFI*DFIR
      ENDIF

      IF(IPIOMV.NE.0) THEN
      GONN =  3.1D0
      FONN = -0.D0
      FIHOC2= 0D0
      VC   =  VC   - FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FONN)*(PIM/AMN)
     .               *2*X1*(DDFI*DFIOM+DFI*DDFIO+X1*DFI*DFIOM)
     .             - N2PRV*FACT*ISFAC*GPIOMV**2*X1*FIHOC2
      VSIG =  VSIG - 2*FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FONN)*(PIM/AMN)
     .               *X1*(DDFI*DFIOM+DFI*DDFIO+X1*DFI*DFIOM)/3D0
      VTEN =  VTEN - 1*FACT*ISFAC*GPIOMV*FP*GONN*(1.D0+FONN)*(PIM/AMN)
     .               *X1*((X1*DFI-DDFI)*DFIOM+DFI*(X1*DFIOM-DDFIO))/3D0
      VSO  =  VSO  - FACT*ISFAC*GPIOMV*FP*GONN*(PIM/AMN)
     .               *4*X2*DFI*DFIOM
      ENDIF
C------------------------------------------------------------
C
C N)  AXIAL 1^{++} SU3-SINGLET PAIR TERMS:
C
C------------------------------------------------------------
      IF(IOMETA.NE.0) THEN
      ISFAC  = 1
      DO 240 II=1,4
      GOTO(241,242,243,244),II

C     ETA-PHI:
241   FMSIG1 = 0.5D0* (2*X1*DFIETA+DDFETA)*FIPH
      FESIG1 = 0.5D0* DFIETA*DFIPH
      FMTEN1 = 0.5D0* (-X1*DFIETA+DDFETA)*FIPH
      WGHT   = DSIN(THPS)*DSIN(THV)
c*    CALL HFUN(0,X,AM1,AM2,ALMP8,ALMV8,0.D0,FUN)
c*    FFSIG2 = -.5D0*FUN(1)
      FFSIG2 = 0.D0
      GOTO 248
C     ETA-OMEGA:
242   FMSIG1 = 0.5D0* (2*X1*DFIETA+DDFETA)*FIOM
      FESIG1 = 0.5D0* DFIETA*DFIOM
      FMTEN1 = 0.5D0* (-X1*DFIETA+DDFETA)*FIOM
      WGHT   = -DSIN(THPS)*DCOS(THV)
      GOTO 248
C     ETA'-PHI:
243   FMSIG1 = 0.5D0* (2*X1*DFIETP+DDFETP)*FIPH
      FESIG1 = 0.5D0* DFIETP*DFIPH
      FMTEN1 = 0.5D0* (-X1*DFIETP+DDFETP)*FIPH
      WGHT   = -DCOS(THPS)*DSIN(THV)
      GOTO 248
C     ETA'-OMEGA:
244   FMSIG1 = 0.5D0* (2*X1*DFIETP+DDFETP)*FIOM
      FESIG1 = 0.5D0* DFIETP*DFIOM
      FMTEN1 = 0.5D0* (-X1*DFIETP+DDFETP)*FIOM
      WGHT   = DCOS(THPS)*DCOS(THV)

248   FFSIG1 = FMSIG1
      FFTEN1 = FMTEN1
      FETEN1 = FESIG1
c*    WGHT = 1.D0        ! HOW TO TREAT THIS?

      VSNN   =   VSNN  - ISFAC*WGHT*FACT*(
     .            (PIM/AMN/6.D0)*( CCPR13(II,1)*FFSIG1
     .           -2*(CCPR13(II,1)+CCPR13F(II,1))*FESIG1 )
     .           - N2PRA*CCPR13(II,2)*FFSIG2 )

      VTNN   =   VTNN  - ISFAC*WGHT*FACT*(PIM/AMN/6.D0)*(
     .           CCPR13(II,1)*FFTEN1
     .           + (CCPR13(II,1)+CCPR13F(II,1))*FETEN1 )
240   CONTINUE
c*    if(icall.eq.0.and.nschr.eq.1) call writepr(4,x,ispin)
      ENDIF

C------------------------------------------------------------
C
C------------------------------------------------------------
C
C
      VC   = VC + VCNN
      VSIG =  VSIG + VSNN
      VTEN =   VTEN + VTNN
      VSO  =    VSO  + VONN

C     1/M-CORRECTIONS:
      IF(INA.EQ.1 .OR. IPV.EQ.1)
     .CALL OMPAIR(X,ISPIN,IIMIN,IBROAD,
     .ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,ALAMK)
CC
      ICALL=1
1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE OMPAIR(X,ISPIN,IIMIN,IBROAD,
     .ALMP8,ALMV8,ALMS8,ALMP1,ALMV1,ALMS1,ALAMK)
C **********************************************************************
C *
C *   DATE JUNI 1996, UPDATED FEBR. 2001
C
C *   PHENOMENOLOGICAL PION-MESON PAIR NN-POTENTIALS
C     CALLED BY SUBROUTINE NNPAIR.FORTRAN
C *
C *   1/M-CONTRIBUTIONS: 1) NON-ADIABATIC, 2) FROM THE PV-VERTEX
C
C     IN COUPLING COMBINATIONS CENLL1 ETC.:
C     (i) NNPRCC: L+R contributions included,
C     (ii) NNPRCC: 1 <-> 2 interchange factor included (extra diagrams)
C     (iii) FFUN1: identical particle factor already included in
C                  NNPRCC by factor IP12!
C     (iv)  FFUN2: identical particle factor included (2 contractions),
C                  facip=2.
C     note: for KK there is never an FACIP=2, everything
C           is accounted for by the isospin factor
C
C     CONVENTIONS A LA PAPER II (SEE (PI-RO)_{1} AND (PI-EPSILON) !)
C
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/PRMTRS/ PAR(20,8)
      COMMON/ALLIN/ PIM,AMP,AMY,ALLX(6)

      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FUI,DFUI,FUISS,DFUISS
     .           ,FITEN,DFITEN,FISO,DFISO,FISO2,DFISO2

      COMMON/ALLPS/PIM0,PIMC,AME,AMX
      COMMON/ALLVC/ARO,BRO,AM1RO,AM2RO,AMOM,AMFI
      COMMON/ALLSC/AMEPS,GAMEP,ASIG(2),AMSIG(2),AMSST,AMD,THS
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM

      COMMON/ALLPR/GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIRO0,GPISI,GPIOM
     .,GSISI,GPIET,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA       ! MARCH 2009
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,IOMETA        ! MARCH 2009
      COMMON/TWOPAIR/N2PR0,N2PR1,N2PRV,N2PRA,N2PRB
      COMMON/PAIROM/IDAM,IPV,INA,IOFF
      DIMENSION WGHTID(2)

      COMMON/PSCOP/ALP,APV,FP ,F62,F92,F120,F12C,FCHPI
      COMMON/COUPL/ F(11),G(11),FD(11),FV(11),GS(11),GD(11)

      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
C
c     DIMENSION AMSIG(2),ASIG(2),AMVEC(2),AVEC(2)
      DIMENSION BFUN(10)
C
C     communication with routine NNPRCC:
      COMMON/US3/CCPR1(3,2),CCPR2(5,2),CCPRG(3,2),CCPRF(3,2),
     .CCPR4(3,2),CCPR4F(3,2),CCPR5(4,2),CCPR6(2),CCPR7(2,2),
     .CCPR8(5,2),CCPR8F(5,2),CCPR9(3,2),CCPR10(8,2),
     .CCPR11(3,2),CCPR11F(3,2),CCPR12(5,2),
     .CCPR13(4,2),CCPR13F(4,2)              ! MARCH 2009

C     communication with routine WROMPR:
      COMMON/PROMPR/VPRA(3,4,4),VPRB(3,4,4),VPRC(3,4,4)
     .              ,VPRD(3,4,4),VPRE(3,4,4),VPRF(3,4,4)

      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/,NSCHR/0/
      DATA SR2/1.4142136D0/,SR3/1.732051D0/,FACIP/2.D0/
      DATA AMPRO/938.2796D0/,AMRO/760.D0/,AMEP/760.D0/,
     .     AMN/938.2796D0/,FACT/138.041D0/
      DATA AMK/495.6D0/,AMKS/890.2D0/,AMSCK/890.D0/,
     .     AMYL/1115.D0/,AMYS/1195.D0/,DAM/230.D0/
c     DATA ALPVPR/0.355D0/,ALVDPR/1.D0/,ALVVPR/0.275D0/,
c    .     ALSCPR/1.D0/,ALPAPR/0.355D0/

c     DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/0/,IPISI/1/,
c    .ISISI/1/,IPIET/0/,IPIETP/0/,IKKB0/0/,IKKB1/0/,IPIPOM/1/,
c    .IPIROV/0/,IPIOMV/0/
c     DATA N2PR0/1/,N2PR1/1/,N2PRA/1/,N2PRB/1/
c     DATA IIMIN/1/
c*    data iimin/2/

      SAVE FACT,AMN
C     SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7
C
      ISFAC = 4*ISPIN-3

      IF(ICALL.EQ.0) THEN
        AMN  = DSQRT(AMP*AMY)
c       DAM  = 0.5D0*(AMP+AMY-AMYL-AMYS)
        DAM  = IDAM*DAM
        FACT = PIM
        FACT = FACT*(PIM/AMN)/4.D0
        if(nschr.ne.0) write(6,199) INA,IPV,IDAM,
     .  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,
     .  IPISI,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
C    . ,GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIET,GPISI,
C    .  GSISI,GPIRO0,GPIOM,GPIETP,GPIPOM
199     FORMAT(//,'  IN OMPAIR: INA=',I2,' IPV=',I2,' IDAMPR=',I2,//,
     .  11X,'  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI=',6I2,//,
     .  11X,'  ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV=',6I2,//)
C    .  11X,'  GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIET,GPISI=',/,6(F10.5),//,
C    .  11X,'  GSISI,GPIRO0,GPIOM,GPIETP,GPIPOM=',/,5(F10.5),//,
c       ICALL=1
      ENDIF
C
C     WEIGHTS OMEGA AND PHI:
C      THV = 37.5D0*PI/180.D0
      THV = PAR(10,3)*PI/180.D0
      WGHTID(1) = DSIN(THV)
      WGHTID(2) = DCOS(THV)

      VCNN = 0.D0
      VSNN = 0.D0
      VTNN = 0.D0
      VONN = 0.D0
      DO 250 ITYPV=1,3
      DO 250 M=1,4
      DO 250 N=1,4
      VPRA(ITYPV,M,N)=0.D0
      VPRB(ITYPV,M,N)=0.D0
      VPRC(ITYPV,M,N)=0.D0
      VPRD(ITYPV,M,N)=0.D0
      VPRE(ITYPV,M,N)=0.D0
  250 VPRF(ITYPV,M,N)=0.D0
C
C     CONSTRUCTION 1/M-CORRECTIONS TO THE POTENTIALS:
C----------------------------------------------------------
C
C A)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{8}x{8} :
C
C----------------------------------------------------------
      IF(IPIPI0.NE.0) THEN
      ITYPE=1
      DO 10 II=IIMIN,3
      FACIPP = 1.D0
      GOTO(11,12,13),II

C     PI-PI(I=0):
11    CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8)
      AMPS= PIM
      ALMPX=ALMP8
      M = 1
      GOTO 14

C     ETA-ETA:
12    CALL FOOMPR(ITYPE,X,AME,AME,ALMP8,ALMP8)
      AMPS= AME
      ALMPX=ALMP8
      M = 3
      GOTO 14

C     KA-KA(I=0):
 13   IF(IDAM.EQ.0) THEN
      CALL FOOMPR(ITYPE,X,AMK,AMK,ALAMK,ALAMK)
      ELSE
      CALL FOOMKK(ITYPE,X,AMK,AMK,ALAMK,ALAMK,DAM)
      ENDIF
      ALMPX=ALAMK

      M = 2
      GOTO 14

14    IF(INA.EQ.1) THEN
      VCNN  =  VCNN   - FACT*CCPR1(II,1)*FNONC*FACIPP
      VONN  =  VONN   - FACT*CCPR1(II,1)*FNONO*FACIPP
      VPRA(1,M,M)=VPRA(1,M,M)-FACT*CCPR1(II,1)*FNONC*FACIPP

      CALL BMNFUN(1,1,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = 2*BFUN(4)/X/X+BFUN(9)
      BFUNO = BFUN(4)
      CALL BMNFUN(12,12,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = BFUNC
     .       -6*(BFUN(9)-BFUN(7)/X-BFUN(8)/X+BFUN(4)/X/X)/X/X
     .       -BFUN(10)
      BFUNO = BFUNO-2*(BFUN(9)+BFUN(7)/X+BFUN(8)/X-BFUN(4)/X/X)
      BFUNO = 2*BFUNO/X/X
      VCNN  =  VCNN   - 2*FACT*CCPR9(II,1)*BFUNC*FACIPP
      VONN  =  VONN   - 2*FACT*CCPR9(II,1)*BFUNO*FACIPP
      ENDIF

      IF(IPV.EQ.1) THEN
      VCNN  =  VCNN   - APV*FACT*CCPR1(II,1)*FPVC*FACIPP
      VONN  =  VONN   - APV*FACT*CCPR1(II,1)*FPVO*FACIPP
      VPRA(1,M,M)=VPRA(1,M,M)-APV*FACT*CCPR1(II,1)*FPVC*FACIPP

      CALL BMNFUN(1,1,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = -2*BFUN(4)
      BFUNO = -1*(BFUN(7)+BFUN(8))
      CALL BMNFUN(-1,+1,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = BFUNC+BFUN(1)+BFUN(4)
      BFUNO = BFUNO+BFUN(2)+BFUN(3)
      CALL BMNFUN(+1,-1,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = BFUNC+BFUN(1)+BFUN(4)
      BFUNO = BFUNO+BFUN(2)+BFUN(3)
      CALL BMNFUN(-1,-1,X,AMPS,AMPS,ALMPX,ALMPX,BFUN)
      BFUNC = BFUNC-2*BFUN(1)
      BFUNO = 2*BFUNO/X
      VCNN  =  VCNN   - APV*FACT*CCPR9(II,1)*BFUNC*FACIPP
      VONN  =  VONN   - APV*FACT*CCPR9(II,1)*BFUNO*FACIPP
      ENDIF
10    CONTINUE
      ENDIF
C-----------------------------------------------------------------
C
C B)  SCALAR SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :
C
C-----------------------------------------------------------------
      IF(IPIET.NE.0) THEN
c*    ITYPE = 5
      ITYPE = 1       ! A LA YN and XN
c*    DO 20 II=IIMIN,5
      DO 20 II=1,5
      FACIPP = 1.D0
      GOTO(21,22,25,26,27),II
C     PI-ETA:
21    CALL FOOMPR(ITYPE,X,PIM,AME,ALMP8,ALMP8)
      FACIPP = DFLOAT(ISFAC)
      M = 1
      N = 3
      GOTO 28

C     KA-KA(8S)(I=1):
 22   IF(IDAM.EQ.0) THEN
      CALL FOOMPR(ITYPE,X,AMK,AMK,ALAMK,ALAMK)
      ELSE
      CALL FOOMKK(ITYPE,X,AMK,AMK,ALAMK,ALAMK,DAM)
      ENDIF
      FACIPP = DFLOAT(ISFAC)
      M = 2
      N = 2
      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   IF(IDAM.EQ.0) THEN
      CALL FOOMPR(ITYPE,X,AMK,AMK,ALAMK,ALAMK)
      ELSE
      CALL FOOMKK(ITYPE,X,AMK,AMK,ALAMK,ALAMK,DAM)
      ENDIF
      M = 2
      N = 2
      GOTO 28

28    IF(INA.EQ.1) THEN
      VCNN  =  VCNN   - FACT*CCPR2(II,1)*FNONC*FACIPP
      VONN  =  VONN   - FACT*CCPR2(II,1)*FNONO*FACIPP
      VPRB(1,M,N)=VPRB(1,M,N)-FACT*CCPR2(II,1)*FNONC*FACIPP
      ENDIF
      IF(IPV.EQ.1) THEN
      VCNN  =  VCNN   - APV*FACT*CCPR2(II,1)*FPVC*FACIPP
      VONN  =  VONN   - APV*FACT*CCPR2(II,1)*FPVO*FACIPP
      VPRB(1,M,N)=VPRB(1,M,N)-FACT*CCPR2(II,1)*FPVC*FACIPP
      ENDIF
20    CONTINUE
      ENDIF

C     PI-ETA':
c     IF(IPIETP.EQ.1) THEN
c     VCNN  =   VCNN + 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
      IF(IPIPI1.NE.0) THEN
      ITYPE = 2
      DO 30 II=IIMIN,3
      FACIPP = 0.5D0
     .*2                  ! A LA YN and XN
      GOTO(31,32,35),II
C     PI-PI(I=1):
31    CALL FOOMPR(ITYPE,X,PIM,PIM,ALMP8,ALMP8)
      FACIPP = DFLOAT(ISFAC)/2.D0
     .*2                  ! A LA YN and XN
      M = 1
      N = 1
      GOTO 36

C     KA-KA(8A)(I=1):
 32   IF(IDAM.EQ.0) THEN
      CALL FOOMPR(ITYPE,X,AMK,AMK,ALAMK,ALAMK)
      ELSE
      CALL FOOMKK(ITYPE,X,AMK,AMK,ALAMK,ALAMK,DAM)
      ENDIF
      FACIPP = DFLOAT(ISFAC)/2.D0
     .*2                  ! A LA YN and XN
      M = 2
      N = 2
      GOTO 36

C     KA-KA(8A)(I=0):
 35   IF(IDAM.EQ.0) THEN
      CALL FOOMPR(ITYPE,X,AMK,AMK,ALAMK,ALAMK)
      ELSE
      CALL FOOMKK(ITYPE,X,AMK,AMK,ALAMK,ALAMK,DAM)
      ENDIF
      M = 2
      N = 2
      GOTO 36

36    IF(INA.EQ.1) THEN
      VCNN  =  VCNN   - FACT*CCPRG(II,1)*FNONC*FACIPP
      VONN  =  VONN   - FACT*CCPRG(II,1)*FNONO*FACIPP
      VPRC(1,M,N)=VPRC(1,M,N)-FACT*CCPRG(II,1)*FNONC*FACIPP
      ENDIF
      IF(IPV.EQ.1) THEN
      VCNN  =  VCNN   - APV*FACT*CCPRG(II,1)*FPVC*FACIPP
      VONN  =  VONN   - APV*FACT*CCPRG(II,1)*FPVO*FACIPP
      VPRC(1,M,N)=VPRC(1,M,N)-APV*FACT*CCPRG(II,1)*FPVC*FACIPP
      ENDIF
30    CONTINUE
      ENDIF
C-----------------------------------------------------------------
C
C  D  AXIAL PAIR TERMS OF THE FIRST CLASS:
C
C-----------------------------------------------------------------
c     ITYPE=3
c     NO EXTRA 1/M-CORRECTIONS (ADIABATIC TERMS ARE 1/M!)
c     IF(IPIRO1.NE.0) THEN
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=9
***   DO 90 II=IIMIN,8
      DO 90 II=1,8
      GOTO(91,92,93,94,95,96,97,98),II

C     PI-OMEGA:
91    CALL FOOMPR(ITYPE,X,PIM,AMOM,ALMP8,ALMV1)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*WGHTID(1)
      GOTO 99

C     PI-PHI:
92    CALL FOOMPR(ITYPE,X,PIM,AMFI,ALMP8,ALMV8)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*WGHTID(2)
      GOTO 99

C     ETA-RHO:
93    CALL FOOMPR(ITYPE,X,AME,AMRO,ALMP8,ALMV8)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*1.D0
      GOTO 99

C     KA-K*(8S)(I=1):
94    CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8)
      ISFAC = -3+4*ISPIN
      FACII = ISFAC*1.D0
      GOTO 99

C     PI-RHO(8S)(I=0):
95    CALL FOOMPR(ITYPE,X,PIM,AMRO,ALMP8,ALMV8)
      FACII = 1.D0
      GOTO 99

C     KA-K*(8S)(I=0):
96    CALL FOOMPR(ITYPE,X,AMK,AMKS,ALMP8,ALMV8)
      FACII = 1.D0
      GOTO 99

C     ETA-OMEGA(8s):
97    CALL FOOMPR(ITYPE,X,AME,AMOM,ALMP8,ALMV1)
      FACII = WGHTID(1)
      GOTO 99

C     ETA-PHI(8s):
98    CALL FOOMPR(ITYPE,X,AME,AMFI,ALMP8,ALMV8)
      FACII = WGHTID(2)
      GOTO 99

99    IF(INA.EQ.1) THEN
c     facii=facii/2d0    ! factor 1/2 because of denominators
      VSIG =   VSIG + 4*APV*FACII*FACT*CCPR10(II,1)*FPVS/3.D0
      VTEN =   VTEN + 4*APV*FACII*FACT*CCPR10(II,1)*FPVT/3.D0
cc    VSO  =   VSO  - 4*APV*FACII*FACT*CCPR10(II,1)*FPVO       ! NO 1/M^2-terms
cc   .                 *(PIM/AMN)  ! 1/M^2-terms in pairs!?
c     opmerking: ccpr10 bevat alleen g_V, en niet G_V=g_V+f_V, dus:
c     ccpr10 correct voor vsig en vten, maar niet goed voor vso!

c     VSIG =   VSIG + 1*APV*FACII*FACT*CCPR10(II,1)*FPVS/3.D0
c     VTEN =   VTEN + 1*APV*FACII*FACT*CCPR10(II,1)*FPVT/3.D0
c     VSO  =   VSO  - 1*APV*FACII*FACT*CCPR10(II,1)*FPVO
c    .                 *(PIM/AMN)
      ENDIF
90    CONTINUE
      ENDIF
C------------------------------------------------------------
C-----------------------------------------------------------------
C
C E)  AXIAL PAIR TERMS OF THE SECOND CLASS:
C
C-----------------------------------------------------------------
c     ITYPE=4
c     NOT INCLUDED IN PAIRS
c     IF(IPIRO0.EQ.1) THEN
c     ENDIF
C
C     AXIAL SECOND CLASS PAIR TERMS (I=1, PION-OMEGA) :
c     ITYPE=5
c     NOT INCLUDED IN PAIRS
c     IF(IPIOM.EQ.1) THEN
c     ENDIF

C-----------------------------------------------------------------
C F)  PSEUDO SCALAR (PION-EPSILON) PAIR TERMS:
C-----------------------------------------------------------------
      IF(IPISI.NE.0) THEN
      ITYPE = 6
      DO 50 II=IIMIN,4
      FACIPP = 1.D0
      GOTO(51,51,54,56),II

C     PI-EPSILON:
C     ETA-EPSILON:

51    IF(IBROAD.EQ.0) THEN
       IF(II.EQ.1) THEN
        CALL FOOMPR(ITYPE,X,PIM,AMEP,ALMP8,ALMS1)
         M=1
          ENDIF
       IF(II.EQ.2) THEN
        CALL FOOMPR(ITYPE,X,AME,AMEP,ALMP8,ALMS1)
         M=3
          ENDIF
      ELSE
      HNONS = 0.D0
      HNONT = 0.D0
      HPVS  = 0.D0
      HPVT  = 0.D0
      N = 4
      DO 510 JJ=1,2
       IF(II.EQ.1) THEN
        CALL FOOMPR(ITYPE,X,PIM,AMSIG(JJ),ALMP8,ALMS1)
         M = 1
       ENDIF
       IF(II.EQ.2) THEN
        CALL FOOMPR(ITYPE,X,AME,AMSIG(JJ),ALMP8,ALMS1)
         M = 3
       ENDIF
      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
      ENDIF
      IF(II.EQ.1) FACIPP = DFLOAT(ISFAC)
      N = 4
      GOTO 57

C     PI-SSTAR:
54    CALL FOOMPR(ITYPE,X,PIM,AMSST,ALMP8,ALMS8)
      FACIPP = DFLOAT(ISFAC)
      M = 1
      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
      VSNN  =  VSNN  - FACIPP*FACT*CCPR5(II,1)*FNONS/3.D0
      VTNN  =  VTNN  - FACIPP*FACT*CCPR5(II,1)*FNONT/3.D0
      VPRE(2,M,N)=VPRE(2,M,N)-FACIPP*FACT*CCPR5(II,1)*FNONS/3.D0
      ENDIF
      IF(IPV.EQ.1) THEN
      VSNN  =  VSNN  + APV*FACIPP*FACT*CCPR5(II,1)*FPVS/3.D0
      VTNN  =  VTNN  + APV*FACIPP*FACT*CCPR5(II,1)*FPVT/3.D0
      VPRE(2,M,N)=VPRE(2,M,N)+APV*FACIPP*FACT*CCPR5(II,1)*FPVS/3.D0
      ENDIF
50    CONTINUE
      ENDIF
C-----------------------------------------------------------------
C
C G)  PSEUDO SCALAR (PS-POMERON) PAIR TERMS:
C
C-----------------------------------------------------------------
      IF(IPIPOM.NE.0) THEN
      ITYPE = 7
      DO 70 II=IIMIN,2
      FACIPP = 1.D0
      GOTO(71,73),II

C     PI-POMERON:
71    CALL FOOMPR(ITYPE,X,PIM,AMPOM,ALMP8,AMPOM)
      FACIPP = DFLOAT(ISFAC)
      M = 1
      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
      VSNN  =  VSNN  + FACIPP*FACT*CCPR7(II,1)*FNONS/3.D0
      VTNN  =  VTNN  + FACIPP*FACT*CCPR7(II,1)*FNONT/3.D0
      VPRF(2,M,N)=VPRF(2,M,N)+FACIPP*FACT*CCPR7(II,1)*FNONS/3.D0
      ENDIF
      IF(IPV.EQ.1) THEN
      VSNN  =  VSNN  - APV*FACIPP*FACT*CCPR7(II,1)*FPVS/3.D0
      VTNN  =  VTNN  - APV*FACIPP*FACT*CCPR7(II,1)*FPVT/3.D0
      VPRF(2,M,N)=VPRF(2,M,N)-APV*FACIPP*FACT*CCPR7(II,1)*FPVS/3.D0
      ENDIF
70    CONTINUE
      ENDIF
C-----------------------------------------------------------------
C
C  H  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} :
C
C-----------------------------------------------------------------

C 7)  SCALAR (EPSILON-EPSILON) PAIR TERMS:
      IF(ISISI.NE.0.AND.IIMIN.EQ.1) THEN
      ITYPE = 8
C     EPSILON-EPSILON:
C     CALL FOOMPR(ITYPE,X,AMEPS,AMEPS,ALMS1,ALMS1)
      OMPRG = 0.D0
      DO 710 JJ=1,2
      DO 710 KK=1,2
      CALL FOOMPR(8,X,AMSIG(JJ),AMSIG(KK),ALMS1,ALMS1)

710   IF(INA.EQ.1)
     .OMPRG = OMPRG - ASIG(JJ)*ASIG(KK)*FACT*CCPR6(1)*FNONC
      VCNN  = VCNN + OMPRG
      ENDIF
C-----------------------------------------------------------------
C
C I)  VECTOR (PION-A1) PAIR TERMS:
C
C-----------------------------------------------------------------
c     IF(IPIA1.EQ.1) THEN
c     ENDIF
C
CC
      VC    = VC   + VCNN
      VSIG  = VSIG + VSNN
      VTEN  = VTEN + VTNN
      VSO   = VSO  + VONN

      if(icall.eq.0.and.nschr.eq.1) call wrompr(1,x,ispin)
      if(icall.eq.0.and.nschr.eq.1) call wrompr(2,x,ispin)
      if(icall.eq.0.and.nschr.eq.1) call wrompr(3,x,ispin)
      if(icall.eq.0.and.nschr.eq.1) call wrompr(5,x,ispin)
      if(icall.eq.0.and.nschr.eq.1) call wrompr(6,x,ispin)

      if(icall.eq.0.and.nschr.eq.1) then
      write(6,*) '**************************************************'
      write(6,*) ' OMPAIRS: EPSILON-EPSILON CONTRIBUTION:'
      write(6,*) ' x=',x,'  VCNN=',omprg
      write(6,*) '**************************************************'
      endif
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      ICALL=1
      RETURN
      END
C **********************************************************************
      SUBROUTINE NNPRCOP(NS)
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/PRMTRS/PAR(20,8)
      COMMON/ALLSC/AMEPS,GAMEP,ASIG(2),AMSIG(2),AMSST,AMD,THS
      COMMON/ALLPR/GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIRO0,GPISI,GPIOM
     .,GSISI,GPIET,GPIETP,GKKB0,GKKB1,GPIPOM,GPIROV,GPIOMV
     .,GTENPR,FTENPR,GPPS2,GPSPR,GOMETA       ! MARCH 2009
      COMMON/ALFPR/ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR
      COMMON/PAIRON/IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI
     .,ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV
     .,IPIPI2,IKKB0,IKKB1,IPSPR,IOMETA       ! MARCH 2009

      COMMON/PSCOP/ALP,APV,FPI,F62,F92,F120,F12C,FCHPI
      COMMON/AXCOP/ALFAX,FA12,FA62,FA92,ALMAX
      COMMON/COUPL/ F(11),G(11),FD(11),FV(11),GS(11),GD(11)
C
      DIMENSION PRF(11)

C     communication with routine NNPRCC:
      COMMON/PRCPLS/CENPR(2),SIGPR(2)
      COMMON/CPLRIJ/FA(11),FB(11),PR(11)

      COMMON/US3/CCPR1(3,2),CCPR2(5,2),CCPRG(3,2),CCPRF(3,2),
     .CCPR4(3,2),CCPR4F(3,2),CCPR5(4,2),CCPR6(2),CCPR7(2,2),
     .CCPR8(5,2),CCPR8F(5,2),CCPR9(3,2),CCPR10(8,2),
     .CCPR11(3,2),CCPR11F(3,2),CCPR12(5,2),
     .CCPR13(4,2),CCPR13F(4,2)                ! MARCH 2009
      dimension    prpe1(11),prppg(11),prppf(11),prpr1(11),
     .             prpo1(11),prpsi(11),prppo(11),prpp0(11)

c     DATA ALPVPR/0.355D0/,ALVDPR/1.D0/,ALVVPR/0.275D0/,
c    .     ALSCPR/1.D0/,ALPAPR/0.355D0/,ALP8PR/0.355D0/
c     DATA IPIPI0/1/,IPIPI1/1/,IPIRO1/1/,IPIRO0/0/,IPIOM/0/,IPISI/1/,
c    .ISISI/1/,IPIET/0/,IPIETP/0/,IKKB0/0/,IKKB1/0/,IPIPOM/1/,
c    .IPIROV/0/,IPIOMV/0/
      DATA IALFPR/0/,ICALL/0/,I3P0/1/
c***  DATA IALFPR/1/,ICALL/0/

C     SAVE CCPR1,CCPR2,CCPRG,CCPRF,CCPR4,CCPR4F,CCPR5,CCPR6,CCPR7
C
        ALVD = 0.5D0*FD(2)/FD(1)
        ALVV = 0.5D0*FV(2)/FV(1)
        ALS  = 0.5D0*GS(2)/GS(1)
        ALD  = 0.5D0*GD(2)/GD(1)
        ALP9PR=ALP
C
C     SU3-BREAKING IN PAIR COUPLINGS:   (AUGUST 2004 VERSION)
      SONPV = PAR(11,7)
      SONV  = PAR(10,7)
      SONSC = PAR(12,7)
      SONVA = SONV
      SON1  = SONV
      IF(I3P0.EQ.1) THEN
      SONSC = SONV
      SONVA = SONV
      SON1  = SONV
      ENDIF
C
C     CONSTRUCTION OF COUPLING COMBINATIONS
C
C a)  scalar SU(3)-singlet pair terms, {1}->{8}x{8} :
C
      IF(IPIPI0.NE.0) THEN
      PR(1) = GPIPI0
c     PR(1) = GPIPI0*DCOS(THS)
      DO 110 KK=1,11
      FA(KK) = F(KK)
 110  FB(KK) = F(KK)
      DO 111 II=1,3
      CALL NNPRCC(1,II)
      DO 111 KK=1,2
 111  CCPR1(II,KK) = CENPR(KK)

      PR(1) = GPPS2
      DO 112 KK=1,11
      FA(KK) = F(KK)
 112  FB(KK) = F(KK)
      DO 114 II=1,3
      CALL NNPRCC(1,II)
      DO 114 KK=1,2
 114  CCPR9(II,KK) = CENPR(KK)
      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
c*    ALSCPR=ALS
      IF(IALFPR.EQ.1)
     .ALSCPR=(5*ALP+5*ALP-10*ALP*ALP)/(8*ALP+8*ALP-4*ALP*ALP-3.D0)
      CALL SU3(PR,ALSCPR)
      IF(SONSC.NE.1D0) CALL SU3SB03(PR,ALSCPR,SONSC) ! aug. 2004
c     PR(1) = GPIPI0*DSIN(THS)
c     CALL SU3(PR,ALS)
      DO 120 KK=1,11
      FA(KK) = F(KK)
 120  FB(KK) = F(KK)
      DO 121 II=1,5
      CALL NNPRCC(2,II)
      DO 121 KK=1,2
 121  CCPR2(II,KK) = CENPR(KK)
      ENDIF
C
C c)  vector SU(3)-octet pair terms, {8a}->{8}x{8} :
C
      IF(IPIPI1.NE.0) THEN
      PR(1) = GPIPI1
      PR(9) = 0.D0
c*    ALVDPR=ALVD
      IF(IALFPR.EQ.1)
     .ALVDPR=(5.D0-10*ALP+14*ALP**2)/(5.D0+8*ALP-4*ALP**2)
      CALL SU3(PR,ALVDPR)
      IF(SONV.NE.1D0) CALL SU3SB03(PR,ALVDPR,SONV) ! aug. 2004
      DO 130 KK=1,11
      FA(KK) = F(KK)
 130  FB(KK) = F(KK)
      DO 131 II=1,3
      CALL NNPRCC(3,II)
      DO 131 KK=1,2
 131  CCPRG(II,KK) = SIGPR(KK)
      PRF(1) = FPIPI1
      PRF(9) = 0.D0
      IF(IALFPR.EQ.1)
     .ALVVPR = ALVV
      CALL SU3(PRF,ALVVPR)
      IF(SONV.NE.1D0) CALL SU3SB03(PR,ALVVPR,SONV) ! aug. 2004
      DO 135 KK=1,11
 135  PR(KK)=PR(KK)+PRF(KK)
      DO 136 II=1,3
      CALL NNPRCC(3,II)
      DO 136 KK=1,2
 136  CCPRF(II,KK) = SIGPR(KK)
      ENDIF
C
C d)  axial pair terms, {8}->{8}x{8} :
C
      IF(IPIRO1.NE.0) THEN
      PR(1) = GPIRO1
      PR(9) = 0.D0
c     ALPAPR= ALP
c*    ALPAPR= ALFAX
      IF(IALFPR.EQ.1)
     .ALPAPR=(5.D0-5*ALP-5*ALVD+14*ALP*ALVD)/
     .       (5.D0+4*ALP+4*ALVD- 4*ALP*ALVD)
      CALL SU3(PR,ALPAPR)
      IF(SONPV.NE.1D0) CALL SU3SB03(PR,ALPAPR,SONPV) ! aug. 2004
      DO 140 KK=1,11
      FA(KK) = F(KK)
 140  FB(KK) = FD(KK)
      DO 141 II=1,3
      CALL NNPRCC(3,II)
      DO 141 KK=1,2
 141  CCPR4(II,KK) = SIGPR(KK)
      DO 145 KK=1,11
      FA(KK) = F(KK)
 145  FB(KK) = FV(KK)
      DO 146 II=1,3
      CALL NNPRCC(3,II)
      DO 146 KK=1,2
 146  CCPR4F(II,KK) = SIGPR(KK)
      ENDIF
C
C dp) axial pair terms, {1}->{8}x{8} :
C
      IF(IPIRO0.EQ.2) THEN
      PR(1) = GPIRO0
      DO 1140 KK=1,11
      FA(KK) = F(KK)
1140  FB(KK) = FD(KK)
      DO 1141 II=1,3
      CALL NNPRCC(1,II)
      DO 1141 KK=1,2
1141  CCPR11(II,KK) = CENPR(KK)
      DO 1145 KK=1,11
      FA(KK) = F(KK)
1145  FB(KK) = FV(KK)
      DO 1146 II=1,3
      CALL NNPRCC(1,II)
      DO 1146 KK=1,2
1146  CCPR11F(II,KK) = CENPR(KK)
      ENDIF
C
C e)  axial pair terms, {8}->{8}x{1} :
C
C     note: {1}= cos(ths) |epsilon> - sin(ths)|S*>
      IF(IPISI.NE.0) THEN
C     PS-EPSILON CONTRIBUTIONS:
      ALP8PR= ALFAX
      alp8pr= alpapr     ! for making the same as in bbprogs.03
      PR(1) = GPISI
      PR(1) = GPISI*DCOS(THS)
      PR(9) = 0.D0
      CALL SU3(PR,ALP8PR)
      DO 150 KK=1,11
      FA(KK) = F(KK)
 150  FB(KK) = GS(KK)
      DO 151 II=1,2
      CALL NNPRCC(4,II)
      DO 151 KK=1,2
 151  CCPR5(II,KK) = SIGPR(KK)
C     PS-SSTAR CONTRIBUTIONS:
c     PR(1) = 0.D0
      PR(1) =-GPISI*DSIN(THS)
      PR(9) = 0.D0
      CALL SU3(PR,ALP8PR)
      DO 155 KK=1,11
      FA(KK) = F(KK)
 155  FB(KK) = GS(KK)
      DO 156 II=3,4
      CALL NNPRCC(4,II)
      DO 156 KK=1,2
 156  CCPR5(II,KK) = SIGPR(KK)
      ENDIF

      IF(IPIPOM.NE.0) THEN
C     PS-POMERON CONTRIBUTIONS:
      ALP8PR= ALFAX
      alp8pr= alpapr     ! for making the same as in bbprogs.03
      PR(1) = GPIPOM
      PR(9) = 0.D0
      CALL SU3(PR,ALP8PR)
      DO 170 KK=1,11
      FA(KK) = F(KK)
 170  FB(KK) = GD(KK)
      DO 171 II=1,2
      CALL NNPRCC(4,II)
      DO 171 KK=1,2
 171  CCPR7(II,KK) = SIGPR(KK)
      ENDIF
C
C f)  SU(3)-singlet pair terms, {1}->{1}x{1} :
C
      IF(ISISI.NE.0) THEN
      PR(1) = GSISI
c     PR(1) = GSISI*DCOS(THS)
      DO 160 KK=1,11
      FA(KK) = GS(KK)
 160  FB(KK) = GS(KK)
      DO 161 II=1,1
      CALL NNPRCC(5,II)
      DO 161 KK=1,2
 161  CCPR6(KK) = CENPR(KK)
      ENDIF
C
C g)  tensor SU(3)-octet pair terms, {8s}->{8}x{8} :
C
      IF(IPIPI2.NE.0) THEN
      PR(1) = GTENPR
      PR(9) = 0.D0
c*    ALTNPR=ALVD
      ALTNPR=ALVDPR
      CALL SU3(PR,ALTNPR)
      DO 180 KK=1,11
      FA(KK) = F(KK)
 180  FB(KK) = F(KK)
      DO 181 II=1,5
      CALL NNPRCC(2,II)
      DO 181 KK=1,2
 181  CCPR8(II,KK) = CENPR(KK)
      PRF(1) = FTENPR
c*    ALTNPR = ALVV
      ALTNPR = ALVVPR
      CALL SU3(PRF,ALTNPR)
      DO 182 KK=1,11
 182  PR(KK)=PR(KK)+PRF(KK)
      DO 183 II=1,5
      CALL NNPRCC(2,II)
      DO 183 KK=1,2
 183  CCPR8F(II,KK) = CENPR(KK)
      ENDIF
C
C h)  second-class axial SU(3)-octet pair terms, {8s}->{8}x{8} :
C
      IF(IPIOM.EQ.2) THEN
      PR(1) = GPIOM
      PR(9) = 0.D0
      ALPBPR= PAR(19,1)
      IF(ALPBPR.EQ.0.D0) ALPBPR=ALP
      IF(IALFPR.EQ.1)
     .ALPBPR=(5*ALVD+5*ALP-10*ALVD*ALP)/(8*ALVD+8*ALP-4*ALVD*ALP-3.D0)
      CALL SU3(PR,ALPBPR)
      DO 190 KK=1,11
      FA(KK) = F(KK)
 190  FB(KK) = FD(KK)
      DO 191 II=1,8
      CALL NNPRCC(6,II)
      DO 191 KK=1,2
 191  CCPR10(II,KK) = CENPR(KK)
      ENDIF
C
C i)  pseudo-scalar pair terms, {8}->{8}x{1} :
C
C     note: {1}= cos(ths) |epsilon> - sin(ths)|S*>
      IF(IPSPR.NE.0) THEN
C     PS-EPSILON CONTRIBUTIONS:
      ALP9PR= ALP
c     PR(1) = GPSPR
      PR(1) = GPSPR*DCOS(THS)
      PR(9) = 0.D0
      CALL SU3(PR,ALP9PR)
      DO 250 KK=1,11
      FA(KK) = F(KK)
 250  FB(KK) = GS(KK)
      DO 251 II=1,2
      CALL NNPRCC(4,II)
      DO 251 KK=1,2
 251  CCPR12(II,KK) = SIGPR(KK)
C     PS-SSTAR CONTRIBUTIONS:
c     PR(1) = 0.D0
      PR(1) =-GPSPR*DSIN(THS)
      PR(9) = 0.D0
      CALL SU3(PR,ALP9PR)
      DO 255 KK=1,11
      FA(KK) = F(KK)
 255  FB(KK) = GS(KK)
      DO 256 II=3,4
      CALL NNPRCC(4,II)
      DO 256 KK=1,2
 256  CCPR12(II,KK) = SIGPR(KK)
      ENDIF
C----------------------------------------------------------------------
C j)  axial 1^{++} SU(3)-singlet pair terms, {1}->{1}x{1} :
C
      IF(IOMETA.NE.0) THEN
      PR(1) = GOMETA
      DO 240 KK=1,11
      FA(KK) = F(KK)
 240  FB(KK) = FD(KK)
      DO 241 II=1,4
      CALL NNPRCC(5,II)
      DO 241 KK=1,2
 241  CCPR13(II,KK) = CENPR(KK)

      DO 242 KK=1,11
      FA(KK) = F(KK)
 242  FB(KK) = FV(KK)
      DO 244 II=1,4
      CALL NNPRCC(5,II)
      DO 244 KK=1,2
 244  CCPR13F(II,KK) = CENPR(KK)
      ENDIF
C----------------------------------------------------------------------


      IF(ICALL.EQ.0.and.NS.NE.0) THEN
        write(6,99) IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI,
     .  ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV,
     .  GPIPI0,GPIPI1,FPIPI1,GPIRO1,GPIET,GPISI,GSISI,
     .  GPIRO0,GPIOM,GPIETP,GPIPOM,GPPS2,GTENPR,FTENPR,GPSPR,
     .  GPIROV,GPIOMV,GOMETA
     . ,ALPVPR,ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALP8PR,ALPBPR,ALP9PR
     . ,ALP,ALVD,ALVV,ALS
     . ,SONPV,SONV,SONSC,SONVA,SON1
c    . ,N2PR0,N2PR1,N2PRA,N2PRB
 99     FORMAT(//,'  IN NNPRCOP:',//,
     .  11X,'  IPIPI0,IPIPI1,IPIRO1,IPIRO0,IPIOM,IPISI=',6I2,//,
     .  11X,'  ISISI,IPIET,IPIETP,IPIPOM,IPIROV,IPIOMV=',6I2,//,
     .  11X,'  GPIPI0=',F10.5,' GPIPI1=',F10.5,' FPIPI1=',F10.5,//,
     .  11X,'  GPIRO1=',F10.5,' GPIET =',F10.5,' GPISI =',F10.5,//,
     .  11X,'  GSISI =',F10.5,' GPIRO0=',F10.5,' GPIOM =',F10.5,//,
     .  11X,'  GPIETP=',F10.5,' GPIPOM=',F10.5,' GPPS2 =',F10.5,//,
     .  11X,'  GTENPR=',F10.5,' FTENPR=',F10.5,' GPSPR =',F10.5,//,
     .  11X,'  GPIROV=',F10.5,' GPIOMV=',F10.5,' GOMETA=',F10.5,//,
     .  11X,'  ALPVPR=',F10.5,' ALVDPR=',F10.5,' ALVVPR=',F10.5,//,
     .  11X,'  ALSCPR=',F10.5,' ALPAPR=',F10.5,' ALP8PR=',F10.5,//,
     .  11X,'  ALPBPR=',F10.5,' ALP9PR=',F10.5,//,
     .  11X,'  ALPV  =',F10.5,' ALVD  =',F10.5,' ALVV  =',F10.5,//,
     .  11X,'  ALS   =',F10.5,//,
     .  11X,'  SONPV =',F10.5,' SONV  =',F10.5,' SONSC =',F10.5,//,
     .  11X,'  SONVA =',F10.5,' SON1  =',F10.5,//)
c    .  11X,'  N2PR0,N2PR1,N2PRA,N2PRB=',4I2,//)
        IF(IALFPR.EQ.0) write(6,199)
        IF(IALFPR.EQ.1) write(6,299)
 199    FORMAT(12X,' PAR -> ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR ',/)
 299    FORMAT(12X,' FORMULAS -> ALVDPR,ALVVPR,ALSCPR,ALPAPR,ALPBPR',/)
c*      ICALL=1

      if(icall.eq.0) then
c*    IF(ALPBPR.EQ.0D0) ALPBPR = ALP
      PRPP0(1) = 0D0
      PRPE1(1) = GPIET
      PRPPG(1) = GPIPI1
      PRPPF(1) = FPIPI1
      PRPR1(1) = GPIRO1
      PRPO1(1) = GPIOM
      PRPSI(1) = GPISI
      PRPPO(1) = GPIPOM
      PRPP0(9) = GPIPI0
      PRPE1(9) = 0D0
      PRPPG(9) = 0D0
      PRPPF(9) = 0D0
      PRPR1(9) = 0D0
      PRPO1(9) = 0D0
      PRPSI(9) = 0D0
      PRPPO(9) = 0D0
      CALL SU3(PRPP0,0.D0)
      CALL SU3(PRPE1,ALSCPR)
      CALL SU3(PRPPG,ALVDPR)
      CALL SU3(PRPPF,ALVVPR)
      CALL SU3(PRPR1,ALPAPR)
      CALL SU3(PRPO1,ALPBPR)
      CALL SU3(PRPSI,ALPAPR)
      CALL SU3(PRPPO,ALPAPR)

      IF(SONSC.NE.1.D0) CALL SU3SB03(PRPE1,ALSCPR,SONSC)
      IF(SONV .NE.1.D0) CALL SU3SB03(PRPPG,ALVDPR,SONV )
      IF(SONV .NE.1.D0) CALL SU3SB03(PRPPF,ALVVPR,SONV )
      IF(SONPV.NE.1.D0) CALL SU3SB03(PRPR1,ALPAPR,SONPV)

      if(ns.ne.0) write(6,94) prpe1,prppg,prppf,prpr1,prpo1,prpsi,
     .  prppo,prpp0
      endif
   94 format(/,72('*'),/,
     .' NNPRCOP: 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,//,' gpp0 =',5f8.5,/,7x,6f8.5,//)
C ******************************************************************
C     END OF PROGRAM COUPLING CONSTANTS
C
      ICALL=1
      ENDIF
C

      RETURN
      END
C **********************************************************************
      SUBROUTINE NNPRCC(NTYPE,NCASE)
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 !!  Exchanged mesons are treated as distinguishable particles ->
C
C     IN COUPLING COMBINATIONS CENNN1 ETC.:
C     (i)  L+R contributions included,
C     (ii) 1 <-> 2 interchange factor included (extra diagrams).
C     (iii) 1-pair gragh's from term L_{pair}L_{meson}^{2}/2!, this
C           compensates 1<->2 factor: IP12=1
C
C     note: idendical particle factors are added in
C           ROUTINES PAIRSU3, OMPAIR
C
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/PRCPLS/CENNN1,CENNN2,SIGNN1,SIGNN2

      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
      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
C     ISOSPIN FACTOR ISFAC IS ADDED IN PAIRSU3-ROUTINE!

C
      DATA SR2/1.4142136D0/,SR3/1.732051D0/,PI/3.14159265D0/
C*    photon/src/rspace:
c*    DATA ILR/2/,IP12/1/
C*    a la paper II: pentiumII/tokyo/nnprogs:
      DATA ILR/2/,IP12/2/
      save gnn1,gnn2
C
C     CONSTRUCTION OF THE POTENTIALS
C
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)
      CENNN1 = 3*GPRNN*FA1*FB1*ILR*IP12
      CENNN2 = 3*GPRNN*GPRNN
      GOTO 14
C     ETA1-ETA2:
12    GPRNN = PR(1)
      CENNN1 = (GPRNN*FA6*FB6)*ILR*IP12
      CENNN2 = 1*GPRNN*GPRNN
      GOTO 14
C     KA1-KA2(I=0):
13    GPRNN = PR(1)
      CENNN1 = GPRNN*(FA4*FB4+3*FA5*FB5)*ILR*IP12
      CENNN2 = 4*GPRNN*GPRNN
      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,25,26,27),NCASE
C     PI1-ETA2:
21    GPRNN = PR(1)
      CENNN1 = +(GPRNN*FA1*FB6)*ILR*IP12
      CENNN2 = +GPRNN*GPRNN
      GOTO 28
C     KA1-KA2(8S)(I=1):
22    GPRNN = 0.5D0*SR3*PR(1)
      CENNN1 = +1*GPRNN*(FA4*FB4-FA5*FB5)*ILR
      CENNN2 = +2*GPRNN*GPRNN
      GOTO 28
C     PI1-PI2(8S)(I=0):
25    GPRNN = 0.5D0*PR(6)
      CENNN1 =  (3*GPRNN*FA1*FB1)*ILR*IP12
      CENNN2 =  3*GPRNN*GPRNN
      GOTO 28
C     ETA-ETA(8s):
26    GPRNN = -0.5D0*PR(6)
      CENNN1 = (GPRNN*FA6*FB6)*ILR*IP12
      CENNN2 =  GPRNN*GPRNN
      GOTO 28
C     KA1-KA2(8S)(I=0):
27    GPRNN = -0.5D0*PR(6)
      CENNN1 =  GPRNN*(FA4*FB4+3*FA5*FB5)*ILR
      CENNN2 =  2*GPRNN*GPRNN
      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,45),NCASE
C     PI1-RHO2(I=1):
41    GPRNN = PR(1)
      SIGNN1 = 2*(GPRNN*FA1*FB1)*ILR*IP12
      SIGNN2 = 2*GPRNN*GPRNN
      GOTO 48
C     KA-K*(AXIAL)(I=1):
42    GPRNN = 0.5D0*PR(1)
      SIGNN1 = +1*GPRNN*(FA4*FB4-FA5*FB5)*ILR*IP12
      SIGNN2 = +4*GPRNN*GPRNN
      GOTO 48
C     KA-K*(AXIAL)(I=0):
45    GPRNN = 0.5D0*SR3*PR(6)
      SIGNN1 =  (GPRNN*(FA4*FB4+3*FA5*FB5) )*ILR*IP12
      SIGNN2 =  4*GPRNN*GPRNN
      GOTO 48
48    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
      endif
      GOTO(51,53,54,56),NCASE

C     PI-EPSILON:
51    GPRNN = PR(1)
      SIGNN1 = (GPRNN*FA1*FB6)*ILR*IP12
      SIGNN2 =  GPRNN*GPRNN
      GOTO 57
C     ETA-EPSILON:
53    GPRNN = PR(6)
      SIGNN1 = (GPRNN*FA6*FB6)*ILR*IP12
      SIGNN2 =  GPRNN*GPRNN
      GOTO 57

C     PI-SSTAR:
54    GPRNN =  PR(1)
      SIGNN1 = (GPRNN*FA1*FB9)*ILR*IP12
      SIGNN2 =  GPRNN*GPRNN
      GOTO 57
C     ETA-SSTAR:
56    GPRNN =  PR(6)
      SIGNN1 = (GPRNN*FA9*FB9)*ILR*IP12
      SIGNN2 =  GPRNN*GPRNN
      GOTO 57
57    RETURN
      ENDIF
C
C 5)  SCALAR SU(3)-SINGLET PAIR TERMS, {1}->{1}x{1} (EPSILON-EPSILON):
C
C     SCALAR (EPSILON-EPSILON) PAIR TERMS:
      IF(NTYPE.EQ.5) THEN
C     EPSILON-EPSILON:
      GPRNN = PR(1)
      CENNN1 = (GPRNN*FA6*FB6)*ILR*IP12
      CENNN2 =  GPRNN*GPRNN
      ENDIF
C
C 6)  AXIAL SECOND KIND SU(3)-OCTET PAIR TERMS,  {8s}->{8}x{8} :
C
      IF(NTYPE.EQ.6) THEN
      GOTO(91,92,93,94,95,96,97,98),NCASE
C     PI-OMEGA:
 91   GPRNN = 0.5D0*PR(1)
      CENNN1 = +(GPRNN*FA1*FB6)*ILR*IP12
      CENNN2 = +GPRNN*GPRNN
      GOTO 99
C     PI-PHI:
 92   GPRNN = 0.5D0*PR(1)
      CENNN1 = +(GPRNN*FA1*FB9)*ILR*IP12
      CENNN2 = +GPRNN*GPRNN
      GOTO 99
C     ETA8-RHO:
 93   GPRNN = 0.5D0*PR(1)
      CENNN1 = +(GPRNN*FA6*FB1)*ILR*IP12
      CENNN2 = +GPRNN*GPRNN
      GOTO 99
C     KA-K*(8S)(I=1):
 94   GPRNN = 0.25D0*SR3*PR(1)
      CENNN1 = +1*GPRNN*(FA4*FB4-FA5*FB5)*ILR*IP12
      CENNN2 = +4*GPRNN*GPRNN
      GOTO 99
C     PI-RHO(8S)(I=0):
 95   GPRNN = 0.5D0*PR(6)
      CENNN1 =  (3*GPRNN*FA1*FB1)*ILR*IP12
      CENNN2 =  3*GPRNN*GPRNN
      GOTO 99
C     KA-K*(8S)(I=0):
 96   GPRNN = -0.25D0*PR(6)
      CENNN1 =  GPRNN*(FA4*FB4+3*FA5*FB5)*ILR*IP12
      CENNN2 =  4*GPRNN*GPRNN
      GOTO 99
C     ETA8-OMEGA:
 97   GPRNN = -0.5D0*PR(6)
      CENNN1 = (GPRNN*FA6*FB6)*ILR*IP12
      CENNN2 =  GPRNN*GPRNN
      GOTO 99
C     ETA8-PHI(8s):
 98   GPRNN = -0.5D0*PR(6)
      CENNN1 = (GPRNN*FA6*FB9)*ILR*IP12
      CENNN2 =  GPRNN*GPRNN
      GOTO 99
99    RETURN
      ENDIF
C
C
      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=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/ALLIN/PIM,ALLX(8)

      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       write(6,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)
      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.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)
      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
      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/ALLIN/PIM,ALLX(8)

      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/ALLIN/PIM,ALLX(8)
      DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(9)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
c*    DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/
      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/
      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
c     CALL ERRSET(208,256,-1,1)
        AA   =DAM/PIM
        AA2  =AA*AA
      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 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
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      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/ALLIN/PIM,ALLX(8)
      DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(9)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/
      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
c     CALL ERRSET(208,256,-1,1)
        AA   =DAM/PIM
        AA2  =AA*AA
      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
      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
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
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE DKFUN(X,AM1,AM2,ALM1,ALM2,DAM,FUN)
C **********************************************************************
C
C     FOURIER TRANSFORM OF
C                                 1               1
C     D_{(1P)}(ADIABATC) = --------------- ---------------
C                          OM1^{N} OM2^{N} (OM1+A) (OM2+A)

C                                [        2A     ]
C                              X [ 1 + --------- ]
C                                [     (OM1+OM2) ]
C     FOR N = 1
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/ALLIN/PIM,ALLX(8)
      DIMENSION XX(20),WW(20),YB(3),HH(9),FUN(9)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,ICALL/0/
      DATA YB/0.D0,10.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/0/,N/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
c     CALL ERRSET(208,256,-1,1)
        AA   =DAM/PIM
        AA2  =AA*AA
      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 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
      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)
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.AND.AA.NE.0.D0) THEN
      WGHTH= GEW*FDISP1*FDISP2*AA/(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
      ENDIF
C
110   CONTINUE
100   CONTINUE
CC
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE FOOMPR(ITYP,X,AM1,AM2,ALM1,ALM2)
C **********************************************************************
C
C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS TWO PS-EXCHANGE
C
C     NO DOUBLE KAON-LIKE EXCHANGES ALLOWED!
C
C     ITYP = 1 : (PIPI)_0  ITYP = 2 : (PIPI)_1,
C     ITYP = 3 : (PIRHO)_0 ITYP = 4 : (PIRHO)_1,
C     ITYP = 5 : (PI-PS)   ITYP = 6 : (PISIG)
C     ITYP = 7 : (PIPOM)   ITYP = 8 : (SI SI_)
C     ITYP = 9 : (PI-OM)
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     FUN(10)= D3F*G
C ----------------------------------------------------------------------
C     NON-ADIABATIC CORRECTIONS: (SEE PAPER II)
C
C                       1        [  1     1       1   ]
C     D_{0}(N.A.) = ------------ [ --- + --- - -------]
C                   (OM1.OM2)**2 [ OM1   OM2   OM1+OM2]

C                       2
C     D_{1}(N.A.) = ------------
C                   (OM1.OM2)**2

C (\PI\PI)_{0}: F.T. [(K1.K2)^2+ I Q.(K1-K2) S.(K1XK2) ] D_{0}(N.A.)

C (\PI\PI)_{1}: F.T. [(K1.K2)^2+ I Q.(K1-K2) S.(K1XK2) ] D_{1}(N.A.)

C (\SI\SI)    : F.T. -[(K1.K2) ] D_{1}(N.A.)

C (\PI\SI)_{1}: F.T.  (K1.K2)[SIG1.K1 SIG2.K1 - (1/2){
C                     SIG1.K1 SIG2.K2 + SIG1.K2 SIG2.K1}] D_{0}(N.A.)

C ----------------------------------------------------------------------
C
C     PV-VERTEX CORRECTIONS: (SEE PAPER II)
C
C                           1
C     D_{0}(P.V.) = -----------------
C                   OM1.OM2 (OM1+OM2)

C (\PI\PI)_{0}: F.T. -[K1^2+K2^2 - 2I S.(K1+K2)XQ ] D_{0}(P.V.)

C (\PI\SI)_{1}: F.T.  -[SIG1.K2 SIG2.K2 - (1/2){
C                     SIG1.K1 SIG2.K2 + SIG1.K2 SIG2.K1}] D_{0}(P.V.)

C                    [(K1^2    K2^2 )       ( K1      K2  )     ]
C (\PI\PI)_{1}: F.T.-[(----- + -----) -2I S.(----- + -----) X Q ]
C                    [(OM1^2   OM2^2)       (OM1^2   OM2^2)     ]

C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLIN/ PIM,AMP,AMY,ALLX(6)
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      DIMENSION XX(96),WW(96),YB(4),FUN(10),FUNPV(10)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/
cold  DATA YB/0.D0,10.D0,20.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/,ICALL/0/
c*    DATA YB/0.D0,5.D0,10.D0,20.D0/,NINT/3/,NPNT/40/,IMETH/0/
      DATA YB/0.D0,5.D0,10.D0,20.D0/,NINT/3/,NPNT/40/,IMETH/1/
      DATA ICALL/0/
      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
c**     CALL GAUSS(NPNT,XX,WW,1)
        call gauleg(-1.d0,+1.d0,xx,ww,npnt,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:
      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:
      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

c     test1 = 0.d0
c     test2 = 0.d0
c     test3 = 0.d0
c     const1= 1.d0
c     const2= 2.d0
c     const3= 5.d0
c     exact1= 2*dsqrt(const1)/srpi
c     exact2= 2*dsqrt(const2)/srpi
c     exact3= 2*dsqrt(const3)/srpi

      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)
      FDISP  = FDISP1*FDISP2
C
c     test1 = test1 + gew*(1.d0-fdexp(-const1*y*y))/y/y
c     test2 = test2 + gew*(1.d0-fdexp(-const2*y*y))/y/y
c     test3 = test3 + gew*(1.d0-fdexp(-const3*y*y))/y/y
c     dtest1 = gew*(1.d0-fdexp(-const1*y*y))/y/y
c     ftest1 = (1.d0-fdexp(-const1*y*y))/y/y
c     if(icall.eq.0) write(6,*) ' y=',y,' ftest1=',ftest1,
c    .' dtest1=',dtest1

      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

      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
      ENDIF
      IF(ITYP.EQ.7) THEN
      FIM = FI2
      DFIM = DFI2
      DDFIM = DDFI2
      ENDIF
      FIM2  = FIM
      DFIM2  = DFIM
      DDFIM2  = DDFIM
C
C     IF(IK2EX.EQ.0) THEN
      GEWNA = GEW/Y/Y
      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)

c     if(icall.eq.0) then
c     dfun4  =  ( DFI1* DFI2- DFIM1* DFIM2*FDISP)/Y**2
c     dfun9   = (DDFI1*DDFI2-DDFIM1*DDFIM2*FDISP)/Y**2
c     write(6,*) ' y=',y,' dfun9=',dfun9,' fun(9)=',fun(9)
c     endif

      GEWPV = GEW
      FUNPV(1) = FUNPV(1) + GEWPV*(  FIM1*  FIM2*FDISP)
      FUNPV(2) = FUNPV(2) + GEWPV*( DFIM1*  FIM2*FDISP)
      FUNPV(3) = FUNPV(3) + GEWPV*(  FIM1* DFIM2*FDISP)
      FUNPV(4) = FUNPV(4) + GEWPV*( DFIM1* DFIM2*FDISP)
      FUNPV(5) = FUNPV(5) + GEWPV*(DDFIM1*  FIM2*FDISP)
      FUNPV(6) = FUNPV(6) + GEWPV*(  FIM1*DDFIM2*FDISP)
      FUNPV(7) = FUNPV(7) + GEWPV*(DDFIM1* DFIM2*FDISP)
      FUNPV(8) = FUNPV(8) + GEWPV*( DFIM1*DDFIM2*FDISP)
      FUNPV(9) = FUNPV(9) + GEWPV*(DDFIM1*DDFIM2*FDISP)
      FUNPV(10)= FUNPV(10)+ GEWPV*(D3FIM1* DFIM2*FDISP)
C     ENDIF
C
110   CONTINUE
100   CONTINUE

C     ENDPOINT CONTRIBUTIONS:
      IF(IMETH.EQ.0) THEN
      FUN(1) = FUN(1) + 2/PI*  FI1*  FI2/YB(NINT+1)
      FUN(2) = FUN(2) + 2/PI* DFI1*  FI2/YB(NINT+1)
      FUN(3) = FUN(3) + 2/PI*  FI1* DFI2/YB(NINT+1)
      FUN(4) = FUN(4) + 2/PI* DFI1* DFI2/YB(NINT+1)
      FUN(5) = FUN(5) + 2/PI*DDFI1*  FI2/YB(NINT+1)
      FUN(6) = FUN(6) + 2/PI*  FI1*DDFI2/YB(NINT+1)
      FUN(7) = FUN(7) + 2/PI*DDFI1* DFI2/YB(NINT+1)
      FUN(8) = FUN(8) + 2/PI* DFI1*DDFI2/YB(NINT+1)
      FUN(9) = FUN(9) + 2/PI*DDFI1*DDFI2/YB(NINT+1)
      FUN(10)= FUN(10)+ 2/PI*D3FI1* DFI2/YB(NINT+1)
      ENDIF

c     print result tests:
c     if(icall.eq.0) then
c     endpoint contributions:
c     test1 = test1 + 1.d0/yb(nint+1)
c     test2 = test2 + 1.d0/yb(nint+1)
c     test3 = test3 + 1.d0/yb(nint+1)
c     write(6,*)
c     write(6,*) ' foompr:'
c     write(6,*) ' const1=',const1,' test1=',test1,' exact1=',exact1
c     write(6,*) ' const2=',const2,' test2=',test2,' exact2=',exact2
c     write(6,*) ' const3=',const3,' test3=',test3,' exact3=',exact3
c     write(6,*)
c     endif
c       ICALL=1
C
C     CONSTRUCTION BASE FUNCTIONS
C
C     (PIPI)_{0}:
      IF(ITYP.EQ.1.OR.ITYP.EQ.5) 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
C      IF(IK2EX.EQ.0) 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)
C      ENDIF
      RETURN
      ENDIF

c     (PIOM)_{1}:
      IF(ITYP.EQ.9) THEN
      FPVS = 2*X1*FUNPV(3)+FUNPV(4)+FUNPV(6)
      FPVT =  -X1*FUNPV(3)+FUNPV(4)+FUNPV(6)
c     FPVO = 0.D0 ! NAMELY O(1/M^2)
      FPVO = -X1*DFI2*VKU1/RATP1**2
      RETURN
      ENDIF

      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
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE FOOMKK(ITYP,X,AM1,AM2,ALM1,ALM2,DAM)
C **********************************************************************
C
C     COMPUTATION FUNTIONS FOR 1/M-CONTRIBUTIONS DOUBLE 'KAON' EXCHANGE
C
C     IK2EX=0: NO KAON-EXCHAGE,  IK2EX=1: DOUBLE KAON-EXCHANGE
C
C     ITYP = 1 : (PIPI)_0  ITYP = 2 : (PIPI)_1,
C     ITYP = 3 : (PIRHO)_0 ITYP = 4 : (PIRHO)_1,
C     ITYP = 5 : (PI-PS)   ITYP = 6 : (PISIG)
C     ITYP = 7 : (PIPOM)   ITYP = 8 : (SI SI_)
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     FUN(10)= D3F*G
C ----------------------------------------------------------------------

C     NON-ADIABATIC CORRECTIONS: (SEE PAPER II)
C
C                       1   D   [        1       (        A   ) ]
C     D_{0}(N.A.) = ------- --  [ -------------- ( 1 + -------) ]
C                   OM1.OM2 DA  [ (OM1+A)(OM2+A) (     OM1+OM2) ]

C                   D   [        1           1     ]
C     D_{1}(N.A.) = --  [ --------------  -------) ]
C                   DA  [ (OM1+A)(OM2+A)  OM1+OM2) ]

C (\PI\PI)_{0}: F.T. [(K1.K2)^2+ I Q.(K1-K2) S.(K1XK2) ] D_{0}(N.A.)

C (\PI\PI)_{1}: F.T. [(K1.K2)^2+ I Q.(K1-K2) S.(K1XK2) ] D_{1}(N.A.)

C (\SI\SI)    : F.T. -[(K1.K2) ] D_{1}(N.A.)

C (\PI\SI)_{1}: F.T.  (K1.K2)[SIG1.K1 SIG2.K1 - (1/2){
C                     SIG1.K1 SIG2.K2 + SIG1.K2 SIG2.K1}] D_{0}(N.A.)

C ----------------------------------------------------------------------
C
C     PV-VERTEX CORRECTIONS: (SEE PAPER II)
C
C                           1              1
C     D_{0}(P.V.) = -----------------  ---------
C                   (OM1 + A)(OM2 + A) OM1 + OM2

C (\PI\PI)_{0}: F.T. -[K1^2+K2^2 - 2I S.(K1+K2)XQ ] D_{0}(P.V.)

C (\PI\SI)_{1}: F.T. -[SIG1.K2 SIG2.K2 - (1/2){
C                     SIG1.K1 SIG2.K2 + SIG1.K2 SIG2.K1}] D_{0}(P.V.)

C (\PI\PI)_{1}: F.T.:

C     OM1.OM2     [  (K1^2    K2^2 )       ( K1      K2  )     ]
C - ------------- [  (----- + -----) -2I S.(----- + -----) X Q ] -
C  (OM1+A)(OM2+A) [  (OM1^2   OM2^2)       (OM1^2   OM2^2)     ]

C            A            OM2 - OM1 [
C  ---------------------- --------- [(OM2 K1^2-OM1 K1^2)
C  OM1 OM2 (OM1+A)(OM2+A) OM1 + OM2 [                            ]
C                                     -2I S. QX(OM2 K1 - OM1 K2) ]
C                                                                ]
C **********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLIN/ PIM,AMP,AMY,ALLX(6)
      COMMON/FOOMS/FNONC,FNONS,FNONT,FNONO,FPVC,FPVS,FPVT,FPVO
     .            ,FOFFC,FOFFS,FOFFT,FOFFO,FOFFS2,FOFFT2
      DIMENSION XX(96),WW(96),YB(4),FUN(10),FUNPV(10),
     .          GA01(3),GA11(3),GB01(3),GB11(3)
      DATA PI/3.14159265D0/,SRPI/1.7724538509D0/,AMPRO/938.2796D0/
cold  DATA YB/0.D0,10.D0,20.D0,50.D0/,NINT/1/,NPNT/16/,IMETH/1/
      DATA YB/0.D0,5.D0,10.D0,20.D0/,NINT/3/,NPNT/40/,IMETH/0/
      DATA ICALL/0/
      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
c     CALL ERRSET(208,256,-1,1)
C
      IF(ICALL.EQ.0) THEN
c**     CALL GAUSS(NPNT,XX,WW,1)
        call gauleg(-1.d0,+1.d0,xx,ww,npnt,1)
        IF(IMETH.EQ.1) NINT=1
        ICALL=1
      ENDIF
CC
      X1   = 1.D0/X
      X2   = X1*X1
      X3   = X1*X2
      AA   = DAM/PIM
      AA2  = AA*AA
CC
      DO 1 IMES=1,2
      IF(IMES.EQ.1) THEN
      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)
      ENDIF

C     DIFFRACTIVE CASE:
      IF(ITYP.EQ.7) 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)
      FI2  = FIPO
      DFI2 = DFIPO
      DDFI2= DDFIPO
      D3FI2= D3FIPO
      VKU2 = FIPO
      DVKU2= DFIPO
      DDVKU2= DDFIPO
      ENDIF

      IF(IMES.EQ.1) THEN
C     N=2:
      XLM1 = XLAM
      VKU1  = VKUA
      DVKU1 = DVKUA
      DDVKU1= DDVKUA
      ENDIF
      IF(IMES.EQ.2) THEN
C     N=2:
      XLM2 = XLAM
      VKU2  = VKUA
      DVKU2 = DVKUA
      ENDIF
    1 CONTINUE
C
C     CONSTRUCTION BASE FUNCTIONS BY INTEGRATION
C
      DO 105 II=1,10
      FUN(II) = 0.D0
  105 FUNPV(II) = 0.D0
      IF(ITYP.EQ.2) THEN
      DO 106 II=1,3
      GA01(II) = 0.D0
      GA11(II) = 0.D0
      GB01(II) = 0.D0
      GB11(II) = 0.D0
  106 CONTINUE
      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*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
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

      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
      ENDIF
      IF(ITYP.EQ.7) THEN
      FIM = FI2
      DFIM = DFI2
      DDFIM = DDFI2
      ENDIF
      FIM2  = FIM
      DFIM2  = DFIM
      DDFIM2  = DDFIM
C
C     IF(IK2EX.EQ.1) THEN
      IF(ITYP.NE.2) GEWNA = GEW*(Y*Y-AA2)/(Y*Y+AA2)**2
      IF(ITYP.EQ.2) GEWNA = GEW*2*AA*Y*Y/(Y*Y+AA2)**2
      FUN(1) = FUN(1) + GEWNA*(  FIM1*  FIM2*FDISP)
      FUN(2) = FUN(2) + GEWNA*( DFIM1*  FIM2*FDISP)
      FUN(3) = FUN(3) + GEWNA*(  FIM1* DFIM2*FDISP)
      FUN(4) = FUN(4) + GEWNA*( DFIM1* DFIM2*FDISP)
      FUN(5) = FUN(5) + GEWNA*(DDFIM1*  FIM2*FDISP)
      FUN(6) = FUN(6) + GEWNA*(  FIM1*DDFIM2*FDISP)
      FUN(7) = FUN(7) + GEWNA*(DDFIM1* DFIM2*FDISP)
      FUN(8) = FUN(8) + GEWNA*( DFIM1*DDFIM2*FDISP)
      FUN(9) = FUN(9) + GEWNA*(DDFIM1*DDFIM2*FDISP)
      FUN(10)= FUN(10)+ GEWNA*(D3FIM1* DFIM2*FDISP)

      GEWPV = GEW*Y*Y/(AA2+Y*Y)
      FUNPV(1) = FUNPV(1) + GEWPV*(  FIM1*  FIM2*FDISP)
      FUNPV(2) = FUNPV(2) + GEWPV*( DFIM1*  FIM2*FDISP)
      FUNPV(3) = FUNPV(3) + GEWPV*(  FIM1* DFIM2*FDISP)
      FUNPV(4) = FUNPV(4) + GEWPV*( DFIM1* DFIM2*FDISP)
      FUNPV(5) = FUNPV(5) + GEWPV*(DDFIM1*  FIM2*FDISP)
      FUNPV(6) = FUNPV(6) + GEWPV*(  FIM1*DDFIM2*FDISP)
      FUNPV(7) = FUNPV(7) + GEWPV*(DDFIM1* DFIM2*FDISP)
      FUNPV(8) = FUNPV(8) + GEWPV*( DFIM1*DDFIM2*FDISP)
      FUNPV(9) = FUNPV(9) + GEWPV*(DDFIM1*DDFIM2*FDISP)
      FUNPV(10)= FUNPV(10)+ GEWPV*(D3FIM1* DFIM2*FDISP)

      GEW01 = GEW*Y**2/(AA2+Y**2)
      GEW11 = GEW*AA  /(AA2+Y**2)
      GA01(1) = GA01(1) + GEW01*(  FIM1*FDISP1)
      GA01(2) = GA01(2) + GEW01*( DFIM1*FDISP1)
      GA01(3) = GA01(3) + GEW01*(DDFIM1*FDISP1)

      GA11(1) = GA11(1) + GEW11*(  FIM1*FDISP1)
      GA11(2) = GA11(2) + GEW11*( DFIM1*FDISP1)
      GA11(3) = GA11(3) + GEW11*(DDFIM1*FDISP1)

      GB01(1) = GB01(1) + GEW01*(  FIM2*FDISP2)
      GB01(2) = GB01(2) + GEW01*( DFIM2*FDISP2)
      GB01(3) = GB01(3) + GEW01*(DDFIM2*FDISP2)

      GB11(1) = GB11(1) + GEW11*(  FIM2*FDISP2)
      GB11(2) = GB11(2) + GEW11*( DFIM2*FDISP2)
      GB11(3) = GB11(3) + GEW11*(DDFIM2*FDISP2)

C     ENDIF
110   CONTINUE
100   CONTINUE
C
C     CONSTRUCTION BASE FUNCTIONS
C
C     (PIPI)_{0}:
      IF(ITYP.EQ.1.OR.ITYP.EQ.5) 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*( FUNPV(2) + FUNPV(3) )
      RETURN
      ENDIF

C     (PIPI)_{1}:
200   IF(ITYP.EQ.2) THEN
C      IF(IK2EX.EQ.1) THEN
C     AA**(0)-TERMS:
      FNONC = FUN(9) + 2*X2*FUN(4)
      FNONO = 2*X2*FUN(4)

      FPVC  = (GA11(3)+2*X1*GA11(2))*(VKU2/RATP2**2-AA*GB01(1))
     .      + (GB11(3)+2*X1*GB11(2))*(VKU1/RATP1**2-AA*GA01(1))
      FPVO  = 2*X1*( GA11(2)*(VKU2/RATP2**2-AA*GB01(1))
     .              +GB11(2)*(VKU1/RATP1**2-AA*GA01(1)) )
C     AA**(1)-TERMS:
      FPVC  = FPVC + AA*( -2*(2*X1*FUNPV(2)+FUNPV(5))
     .                    +(2*X1*GA11(2)+GA11(3))*GB01(1)
     .                    -2*(2*X1*FUNPV(3)+FUNPV(6))
     .                    +(2*X1*GB11(2)+GB11(3))*GA01(1))
      FPVO  = FPVO + X1*AA*(
     .-2*FUNPV(2)+GA11(2)*GB01(1)-2*FUNPV(3)+GB11(2)*GA01(1))
C      ENDIF
      RETURN
      ENDIF

      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
c1000  CALL ERRSET(208,256,1,1)
1000  CONTINUE
      RETURN
      END
C **********************************************************************
      SUBROUTINE WRITEPR(NCASE,X,ISPIN)
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/PRWRITE/VPR(1,3,4,4,6)
      CHARACTER *4 NTYPM(4,4)
      DATA NTYPM/
     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','PHI ','OM  ',
     .'DE  ','KAP ','S*  ','EPS ','A2  ','K** ','POMP','POM '/
C
      write(6,*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
      if(ncase.eq.1) write(6,101)
      if(ncase.eq.2) write(6,102)
      if(ncase.eq.3) write(6,103)
      if(ncase.eq.4) write(6,104)
      if(ncase.eq.5) write(6,105)
      if(ncase.eq.6) write(6,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(6,100) x,ispin
      write(6,110) (NTYPM(KK,JJ),KK=1,4)
  110 format(10x,4(3x,a4,5x))
      write(6,*) '-----------------------------------------------------'
      DO 111 II=1,4
  111 write(6,1) NTYPM(II,1),(VPR(1,1,II,KK,NCASE),KK=1,4)
      write(6,*) '====================================================='
c     endif

      if(ncase.ge.3 .AND. ncase.ne.7) then
      write(6,200) x,ispin
      write(6,110) (NTYPM(KK,JJ),KK=1,4)
      write(6,*) '-----------------------------------------------------'
      DO 211 II=1,4
  211 write(6,1) NTYPM(II,1),(VPR(1,2,II,KK,NCASE),KK=1,4)
      write(6,*) '====================================================='
      write(6,*) '*****************************************************'
      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('*'),/,'NNPAIRS: CENTRAL POTENTIALS: x=',f7.3,
     .' ISPIN=',i2,/,55('*'))
  200 format(55('*'),/,'NNPAIRS: SPIN-SPIN POTENTIALS: x=',f7.3,
     .' ISPIN=',i2,/,55('*'))
    1 FORMAT(1x,'NN: ',A4,4(F10.2,2X))
c   2 FORMAT(1x,'LL: ',A4,4(F10.2,2X))
c   3 FORMAT(1x,'LS: ',A4,4(F10.2,2X))
c   4 FORMAT(1x,'SS: ',A4,4(F10.2,2X))
c   5 FORMAT(1x,'DR: ',A4,4(F10.2,2X))
      end

C **********************************************************************
      SUBROUTINE WROMPR(NCASE,X,ISPIN)
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(3,4,4,6)
      CHARACTER *4 NTYPM(4,4)
      DATA NTYPM/
     .'PI  ','KA  ','ETA ','ETAP','RHO ','K*  ','PHI ','OM  ',
     .'DE  ','KAP ','S*  ','EPS ','A2  ','K** ','POMP','POM '/
C
      write(6,*) 'CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC'
      if(ncase.eq.1) write(6,101)
      if(ncase.eq.2) write(6,102)
      if(ncase.eq.3) write(6,103)
      if(ncase.eq.4) write(6,104)
      if(ncase.eq.5) write(6,105)
      if(ncase.eq.6) write(6,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(6,100) x,ispin
      write(6,110) (NTYPM(KK,JJ),KK=1,4)
  110 format(10x,4(3x,a4,5x))
      write(6,*) '-----------------------------------------------------'
      DO 111 II=1,4
  111 write(6,1) NTYPM(II,1),(VPR(1,II,KK,NCASE),KK=1,4)
      write(6,*) '====================================================='
c     endif

      if(ncase.ge.3 .AND. ncase.ne.7) then
      write(6,200) x,ispin
      write(6,110) (NTYPM(KK,JJ),KK=1,4)
      write(6,*) '-----------------------------------------------------'
      DO 211 II=1,4
  211 write(6,1) NTYPM(II,1),(VPR(2,II,KK,NCASE),KK=1,4)
      write(6,*) '====================================================='
      write(6,*) '*****************************************************'
      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,
     .' ISPIN=',i2,/,55('*'))
  200 format(55('*'),/,' OMPAIR: SPIN-SPIN POTENTIALS: x=',f7.3,
     .' ISPIN=',i2,/,55('*'))
c   1 FORMAT(1x,'NN: ',A4,4(F10.2,2X))
    1 FORMAT(1x,'NN: ',A4,4(F10.3,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 DIFRAC98(X,FACISO,NAOBE,CORR)
C
C**********************************************************************
C     VERSION 2004: POMERON(=SINGLET) + J=0 DIFFRACTIVE NONET: A2,F2,FP2
C**********************************************************************
C
C     DIFFRACTIVES  : CALCULATION POTENTIALS ON ISOSPIN BASIS
C     VERSION AUGUST 1998: RETARDATION IN OBE, SEE NON-LOCAL 
C     FUNCTIONS FROM 1/OMEGA(OMEGA+A)-PROPAGATOR.
C
C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
      COMMON/DIFCOP/GPOM2,GA22,GF22,GF2P2
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      DIMENSION AMDF(4),FDC(4)
      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AMPRO/938.2796D0/
C
C   NOTE : POM(IN=1),A2(IN=2),F2(IN=3),F2P(IN=4)           
C
      DIV=1.D0/(AM*AMY)
      DO 1040 IN=1,4
      GOTO(1051,1052,1053,1054),IN
1051  GDNN=  GPOM2
      FDC(1)=1.D0
      AMDF(1)=AMPOM
      GOTO 1056
1052  GDNN= FACISO*GA22
      FDC(2)=1.D0
      AMDF(2)=AMA2
      GOTO 1056
1053  GDNN=  GF22  
      FDC(3)=1.D0
      AMDF(3)=AMPOM
      GOTO 1056
1054  GDNN=  GF2P2
      FDC(4)=1.D0
      AMDF(4)=AMPOM
C
1056  AMDF2=AMDF(IN)*AMDF(IN)
      FAC1=AMDF2/(AM*AMY)
      FAC12=FAC1*FAC1
c*    FNNDF=4*GDNN*AMDF2/(SRPI*AM*AMY)
      FNNDF=4*GDNN*AMDF2/(SRPI*AMPRO*AMPRO)
      AMU = AMDF(IN)/PIM
C
      XA =(AMDF(IN)/PIM)*X
      XA2=XA*XA
      VGSSX=AMDF(IN)*FDEXP(-XA2)
      FC=1.D0+AMDF2*(3.D0-2*XA2)/(2*AM*AMY)
C
      VC       = VC        + FNNDF*FC*VGSSX
C
      VSO      = VSO       + FAC1*FNNDF*VGSSX
C
      VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
      FI       = FI        - 0.5D0*REDM*FNNDF*VGSSX/(AM*AMY)
C
      DFI      = DFI       + 1.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
     .                       /(AM*AMY)

C     AUGUST 1998 ADDITIONS:
      IF(NAOBE.EQ.1) THEN
      X1   = 1.d0/X
      X2   = X1*X1
      FAC1 = FAC1*(PIM/AMDF(IN))**2
      FAC12= FAC1*FAC1
      VARFI0 = CORR*FDEXP(-XA2)/SRPI
      VARFI1 = -2*XA*VARFI0*AMU          
      VARFI2 = -2*(AMU*VARFI0+XA*VARFI1)*AMU          
      VARFI3 = -2*(2*AMU*VARFI1+XA*VARFI2)*AMU          

      VACEN1 = (VARFI2+2*X1*VARFI1)
      VATEN  = (VARFI2-X1*VARFI1)/3.D0
      DVACN1 = (VARFI3+2*X1*VARFI2-2*X2*VARFI1)
      DVATN  = (VARFI3-X1*VARFI2+X2*VARFI1)/3.D0
      VASO0  = -X1*VARFI1
      DVASO0 = -X1*(VARFI2+VASO0)

      VTLC   = VTLC  + 0.5D0*FNNDF*(VARFI0-FAC1*VACEN1/4D0)
      VTLO   = VTLO  + 0.25D0*FNNDF*FAC1*VASO0     
      VTLO2  = VTLO2 + 0.5D0*FNNDF*FAC12*3*X2*VATEN/16D0

      FI     = FI    - REDM*FNNDF*(VARFI0-FAC1*VACEN1/4D0)
     .                 *DSQRT(DIV)
      DFI    = DFI   - REDM*FNNDF*(VARFI1-FAC1*DVACN1/4D0)
     .                 *DSQRT(DIV)*PIM
      FISO   = FISO  - 0.5D0*REDM*FNNDF*FAC1*VASO0*DSQRT(DIV)
      DFISO  = DFISO - 0.5D0*REDM*FNNDF*FAC1*DVASO0*DSQRT(DIV)*PIM   
      FISO2  = FISO2 - REDM*FNNDF*FAC12*X2*3*VATEN*DSQRT(DIV)/16D0
      DFISO2 = DFISO2- REDM*FNNDF*FAC12*X2*3*(DVATN-2*X1*VATEN)*
     .                 DSQRT(DIV)*PIM/16.D0

      FITL   = FITL  - .25D0*REDM*FNNDF*VARFI0*DIV
      DFITL  = DFITL - .25D0*REDM*FNNDF*VARFI1*DIV*PIM
      ENDIF

      if(xa.lt.0.d0) then
c     if(in.eq.3.and.mod(icall,20).eq.2) then
      write(*,*) 'dddddddddddddddddddddddddddddddddddddddddd'
      write(*,*) ' difrac98: in,ames=',in,amdf(in),' x=',x,
     .' corr=',corr     
      write(*,*) 'varfi0,varfi1=',varfi0,varfi1
      write(*,*) 'varfi2,varfi3=',varfi2,varfi3
      write(*,*) 'fac1  ,vacen1=',fac1,vacen1
      write(*,*) ' vc   ,vtlc  =',vc,vtlc 
      write(*,*) ' vtlo ,vtlo2 =',vtlo,vtlo2 
      write(*,*) ' fi   ,dfi   =',fi,dfi
      write(*,*) ' fiso ,dfiso =',fiso,dfiso
      write(*,*) ' fiso2,dfiso2=',fiso2,dfiso2
      write(*,*) ' fitl ,dfitl =',fitl,dfitl
      endif

C
C     ASSUMING S/S0-FACTOR -> 1 + P**2/M**2
C
C     FC=1.D0+AMDF2*(3.D0-2*XA2)/(4*AM*AMY)
C
C     VC       = VC        + FNNDF*FC*VGSSX
C
C     VSO      = VSO       + FAC1*FNNDF*VGSSX
C
C     VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
C     FI       = FI        + 1.D00*REDM*FNNDF*VGSSX/(AM*AMY)
C
C     DFI      = DFI       - 2.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
C    .                       /(AM*AMY)
 1040 CONTINUE
C
C     HEAVY(HARD) POMERON:
      CALL HDIFRAC98(X,FACISO,NAOBE,CORR)
      RETURN
      END

C**********************************************************************
      SUBROUTINE HDIFRAC98(X,FACISO,NAOBE,CORR)
C**********************************************************************
C     VERSION 2007: HEAVY(HARD) POMERON(=SINGLET) 
C**********************************************************************
C
C     DIFFRACTIVES  : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
C     "DIFFRACTIVE MESONS" : CALCULATION POTENTIALS ON ISOSPIN BASIS
C
      IMPLICIT REAL*8(A-H,O-Z)
c*    COMMON/ALLDF/AMPOM,AMF2,AMA2,UPOM
c*    COMMON/DIFCOP/GPOM2,GA22,GF22,GF2P2
      COMMON/PRMTRS/PAR(20,8)
c     COMMON/TREAT/IPSC,IVCT,ISCL,IDIF,IXXX(6)
      COMMON/ONEBOS/IPSC,IVCT,ISCL,IDIF,IAXI,IPSC2,ITEN
      COMMON/TWOBOS/IPAIR,ITPS,IPIME
      COMMON/ALLIN/ PIM,AM,AMY,REDM,PLAB,AK,AKS,TEM,FCTR
      COMMON/DYNMAS/REDMM,AMLN,AMSN,AMH,AMSS,AMLS
      COMMON/POTF/VC,VSIG,VTEN,VSO,VSO2,FI,DFI,FISS,DFISS,FITEN,DFITEN
     .,FISO,DFISO,FISO2,DFISO2
      COMMON/POTTL/VTLC,VTLS,VTLT,FITL,FISTL,FITTL,DFITL,DFISTL,DFITTL
     .,VTLO,VTLO2
      DIMENSION AMDF(4),FDC(4)
      DATA SR3/1.732051D0/,SRPI/1.772454D0/,AKAPP/0D0/
      DATA ITYPH/3/,AMPOMH/600D0/,AMPRO/938.2796D0/
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   NOTE : HPOM(IN=1),HA2(IN=2),HF2(IN=3),HF2P(IN=4)           
C
      RATAMY= DSQRT(AM*AMY)/AMPRO
      AMPOMH = PAR(14,6)
      GPOMH = PAR(13,6)
      FPOMH = PAR(12,6)
      IF(FPOMH.EQ.0D0) FPOMH = -GPOMH
      IF(GPOMH.NE.0D0) AKAPP = FPOMH/GPOMH
      DIV=1.D0/(AM*AMY)
      DO 1040 IN=1,1
      GOTO(1051,1052,1053,1054),IN
1051  GDNN= GPOMH*GPOMH
      IF(PAR(13,6).LT.0D0) GDNN = -GDNN   
      IF(IDIF.EQ.3) THEN
      CNNDC= 1D0              
      CNNDS= (1D0+AKAPP*RATAMY)**2
      CNNDT= CNNDS        
      CNNDO= 3D0+2*AKAPP*RATAMY                 
      CNNDQ= 1D0+4*AKAPP*RATAMY+8*(AKAPP*RATAMY)**2
      ENDIF
      FDC(1)=1.D0
      AMDF(1)=AMPOMH
      GOTO 1056
1052  RETURN    
1053  RETURN    
1054  RETURN    
C
1056  AMDF2=AMDF(IN)*AMDF(IN)
      FAC1=AMDF2/(AM*AMY)
      FAC12=FAC1*FAC1
c*    FNNDF=4*GDNN*AMDF2/(SRPI*AM*AMY)
      FNNDF=4*GDNN*AMDF2/(SRPI*AMPRO**2)
      AMU = AMDF(IN)/PIM
      FAC0= AMDF2/(AMPRO*AMPRO)
C
      XA =(AMDF(IN)/PIM)*X
      XA2=XA*XA
      VGSSX=AMDF(IN)*FDEXP(-XA2)
C--------------------------------------------------------------
C     POMERON: P=C=+1
C--------------------------------------------------------------
      IF(IDIF.EQ.1) THEN
      return  ! MARCH 2009
      FC=1.D0+AMDF2*(3.D0-2*XA2)/(2*AM*AMY)
C
      VC       = VC        + FNNDF*FC*VGSSX
C
      VSO      = VSO       + FAC1*FNNDF*VGSSX
C
      VSO2     = VSO2      + FAC12*FNNDF*VGSSX/4
C
      FI       = FI        - 0.5D0*REDM*FNNDF*VGSSX/(AM*AMY)
C
      DFI      = DFI       + 1.0D0*REDM*FNNDF*AMDF(IN)*XA*VGSSX
     .                       /(AM*AMY)
      ENDIF
C--------------------------------------------------------------
C     ODDERON: P=C=-1
C--------------------------------------------------------------
      IF(IDIF.EQ.2) THEN
      FC1= FAC1*(3.D0-2*XA2)
      VC = VC + FNNDF*FC1*VGSSX
      ENDIF     
C--------------------------------------------------------------
C     ADDITIONS AUGUST 29, 2007:
C--------------------------------------------------------------
      IF(IDIF.EQ.3) THEN
      FC1   = FAC0*(3.D0-2*XA2)
      FC2   = FAC0*(15D0-20*XA2+4*XA2*XA2)
c*    FTNN  = FAC0*XA2
      FTNN1 = FAC0*XA2*(7D0-2*XA2)
c*    FONN  = FAC0
      FONN1 = FAC0*(5D0-2*XA2)
      FO2NN1= FAC0*(7D0-2*XA2)
C     POTENTIALS:
      VC    = VC   + FNNDF*CNNDC*FC1*VGSSX*2D0
      VSIG  = VSIG - FNNDF*CNNDS*FC2*VGSSX*FAC1*2/3D0 
      VTEN  = VTEN - FNNDF*CNNDT*FTNN1*VGSSX*FAC1*2/3D0
      VSO   = VSO  - FNNDF*CNNDO*FONN1*VGSSX*FAC1*2D0
      VSO2  = VSO2 + FNNDF*CNNDQ*FO2NN1*VGSSX*FAC1**2/2D0
      ENDIF

 1040 CONTINUE
C
      RETURN
      END



