
      subroutine antipot(h,meshm,inf,is,it,kbb,icode,fact,u,RM)
c
	parameter (kmax = 300)
C
C     INF=0 N(BAR)N		   KBB=0 Ueda Parameters
C				   KBB=1 Haidenbauer et al. parameters
C				   KBB=2 Machleidt   et al. parameters
C     INF=1 HYPERON(BAR)HYPERON    KBB=0 Weise,        LAMBDA(BAR)LAMBDA
C                                  KBB=1 Haidenbauer,  LAMBDA(BAR)LAMBDA
C                                  KBB=2 Weise,        LAMBDA(BAR)SIGMA(0)
C
C     IS = SPIN (0 OR 1), IT = ISOSPIN (0 OR 1)
c
c      icode = 1  Vr      icode = 2  Wi
c      icode = 3  VT      icode = 4  VSO     icode = 5 WSO
C
C        REAL CENTRAL --> VD,    IMAGINARY CENTRAL --> WI
C        REAL TENSOR  --> VT,    REAL SPIN-ORBIT   --> VSO
C      ( IMAGINARY SPIN-ORBIT --> WSOI = 0. )
C
      logical iyuky	
      DIMENSION GG(7),AM(7),CM(7),FGR(7),TSPIN(7,2,2),Vx(-2:2)
     1	  ,u(*), v(kmax)
     2    ,AMDT(7,0:2), CMDT(7,0:2), GGDT(7,0:2), FGRDT(7,0:2)
     3    ,AMLAM(7,0:2),CMLAM(7,0:2),GGLAM(7,0:2),FFLAM(7,0:2)
     4    ,BMLAM(2),BM(2),GTF(7)
     5    ,F1(7),F2(7),G1(7),G2(7),W1(2,2,2),WLS(2,2), c(-2:2)
c
      common/yukyuk/HM
      DATA AMASS,HC/4.759, 197.3/
c     DATA W0,A0/13.85, 4.9/
c     Masses of mesons  from Ueda, Machleidt
c               pi    eta    rho   omega  delta S*    sigma 
      DATA AMDT/0.703,2.781, 3.867,3.968, 5.150,5.423,2.109
     1         ,0.700,2.781, 3.897,3.966, 4.982,5.423,2.788
     2         ,0.700,2.781, 3.897,3.966, 4.982,5.423,2.782/
c     Cutoff masses
      DATA CMDT/12.835,6*6.003
     1         , 8.870, 7.600, 7.600, 7.476, 3*10.100
     2         , 6.588, 7.602, 6.588, 7.602, 3*10.136/
c     coupling constants for N-N_bar interaction
      DATA GGDT/-14.28,2.73, 0.778,- 8.0, -4.090,4.44,1.96
     1         ,-14.40,5.00, 0.860,-20.0, -3.628,0.00,7.964
     2         ,-14.90,3.00, 0.950,-20.0, -2.670,0.00,7.78/
c     f/g ratios
      DATA FGRDT/2*0.0,4.76,4*0.0
     1          ,2*0.0,6.10,4*0.0
     1          ,2*0.0,6.10,4*0.0/
c
c     Lambda and Sigma masses
      DATA BMLAM/5.654,6.044/
c     Masses of mesons  from Weise, Haidenbauer
c	kbb = 0  Weise Lambda
c	kbb = 1  Haidenbauer Lambda
c	kbb = 2  Weise Sigma
c                eta'  eta    phi   omega  S*??  delta sigma 
      DATA AMLAM/4.853,2.781, 5.167,3.973, 5.150,5.290,2.577
     1          ,4.853,2.781, 5.167,3.966, 5.150,5.290,2.787
     2          ,4.853,2.781, 5.167,3.973, 5.150,5.290,2.577/
c     Cutoff masses
      DATA CMLAM/12.835,6*6.003
     1         , 8.870, 7.600, 7.600,10.10 , 2*10.100, 8.62
     2         , 6.588, 7.602, 6.588, 7.602, 3*10.136/
c     G parities
      DATA GTF  /1.   ,1.   ,-1    ,-1   , 0.   ,1.   ,1./
c     coupling constants for Hyperon-Hyperon_bar interaction
      DATA GGLAM/4.65,-1.45, -1.96,2.78, 0.00,3.74,2.25
     1          ,0.0,  0.0,   0.0, 2.98, 0.0, 0.0, 2.31
     2          ,3.84, 2.56, -1.96,2.78, 0.00,3.74,2.25/
c    f/g ratios
      DATA FFLAM/0.,0.,-4.3 ,-0.34,0.,0.,0.
     1          ,0.,0., 0.0 ,-2.80,0.,0.,0.
     2          ,0.,0., 1.75, 3.94,0.,0.,0./
c     isospin ratios
      DATA TSPIN/-3.,1.,-3.,1.,-3.,1.,1.,7*1.,7*1.,7*1./
c          R_match  WS radius  WS factor  WS diffuse.
      DATA ROT,     AW1,       BW1,      CW1/1.,0.55,1.,0.2/
      DATA W1/4*-1200.,4*-700./
      DATA WLS/4*0./
c
c     Hankel functions, l = 0 and l = 2
      FH0(X) = EXP(-X)/X
      FH2(X) = (1.+ 3./X + 3./X**2)*EXP(-X)/X
C     Make way for no smoothing (eventually have it as input to antipot)
      RCT = ROT
      IPOT=3
C
c      if(fact.eq.0.0) fact = 1.0
      IT1=IT+1
      SIGMA=-3.+4.*IS
      ATS=-3.+4.*IT
      if(inf.eq.0) then
c       p_pbar parameters
	iyuky = .true.
	j = kbb
	HM = AMASS
        DO 40 I=1,7
        GG(I)=GGDT(I,j)
        FGR(I)=FGRDT(I,j)
        AM(I)=AMDT(I,j)
        CM(I)=CMDT(I,j)
	if(j .eq. 1 .or. j .eq. 2) then
	  GG(I) = GG(I)*((CM(I)**2-AM(I)**2)/CM(I)**2)**2
	endif
   40   CONTINUE
	if(j .eq. 1 .or. j .eq. 2) then
	RCT = RM
	endif
	if(j .eq. 1 .and. it .eq. 0) then
	  AM(7)  =  3.751
	  GG(7)  = 18.874
	endif
      else
c       lambda_lambdabar parameters
	j = kbb
        IF(j .eq. 0) then
	iyuky = .false.
	HM = AMASS
	RCT = ROT
        K1 = j+1
        K2 = j+1
        BM(1)=BMLAM(K1)
        BM(2)=BMLAM(K2)
        DO 60 I=1,7
        AM(I)=AMLAM(I,j)
        G1(I)=GGLAM(I,j)
        G2(I)=GGLAM(I,j)
        F1(I)=FFLAM(I,j)
        F2(I)=FFLAM(I,j)
   60   CONTINUE
        ELSEIF(j .eq. 1) then
c
	iyuky = .true.
	HM = BMLAM(1)
	RCT = RM
	do 80 I=1,7
        AM(I)=AMLAM(I,j)
	CM(I)=CMLAM(I,j)
	if(GGLAM(I,j) .ne. 0.0) then
	FGR(I)=FFLAM(I,j)/GGLAM(I,j)
	endif
	GG(I)=GTF(I)*GGLAM(I,j)**2
	if(j .eq. 1) then
	  GG(I) = GG(I)*((CM(I)**2-AM(I)**2)/CM(I)**2)**2
	endif
   80	continue
	ELSE
	  stop 'Kbb error in ANTIPOT'
	ENDIF
      endif
C
      go to (100, 200, 300, 400, 500) icode
      stop 'Icode error in ANTIPOT'
C
c			V    Central Real
  100 continue
c
      DO 180 J=1,MESHM
      R=H*float(J)
c
      VPS=0.
      VS=0.
      VV=0.
      VEL=0.
      VELD=0.
      if(iyuky) then
C
c     interactions between nucleons
C
      DO 110 I=1,2
      VPS=VPS+GG(I)*YUKY(2,R,AM(I),CM(I))/6.*SIGMA*TSPIN(I,IT1,INF+1)
  110 CONTINUE
      DO 120 I=3,4
      VV=VV+GG(I)*(YUKY(0,R,AM(I),CM(I))+(1.+FGR(I)+(1.+FGR(I))**2
     1   *SIGMA/3.)*YUKY(2,R,AM(I),CM(I)))*TSPIN(I,IT1,INF+1)
  120 CONTINUE
      DO 130 I=5,7
      VS=VS+GG(I)*(-YUKY(0,R,AM(I),CM(I))+0.5*YUKY(2,R,AM(I),CM(I)))
     1     *TSPIN(I,IT1,INF+1)
  130 CONTINUE
      if(ipot .eq. 0) then
	DO 140 I=3,7
	VEL =VEL +0.5/HM**2*GG(I)*YUKY(0,R,AM(I),CM(I))
     1	 *TSPIN(I,IT1,INF+1)
	VELD=VELD+GG(I)*R*YUKY(1,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)
  140	CONTINUE
	VELD=2.*HM*VELD
	VEL=2.*HM*VEL
      else
	VEL =0.
	VELD=0.
      endif
      else
C
c     interactions between hyperons
C
      DO 150 I=1,2
      A=GTF(I)*G1(I)*G2(I)*AM(I)**3/(12.*BM(1)*BM(2))
      VPS=VPS+A*SIGMA*FH0(AM(I)*R)
  150 CONTINUE
      DO 160 I=3,4
      t0 = G1(I)*G2(I)*(1.+AM(I)**2/(8.*BM(1)*BM(2)))
      t1 = (G1(I)*F2(I)/BM(2)+G2(I)*F1(I)/BM(1))*AM(I)**2/(4.*HM)
      t2 = F1(I)*F2(I)*AM(I)**4/(16.*HM**2*BM(1)*BM(2))
      t3 = AM(I)**2/(6.*BM(1)*BM(2))
      t4 =(G1(I)*F2(I)*BM(2)+G2(I)*F1(I)*BM(1))/HM
      t5 =(AM(I)**2/8.+BM(1)*BM(2))/HM**2
      VV=VV+GTF(I)*AM(I)*(t0 + t1 + t2 
     1  + t3*(G1(I)*G2(I) + t4 + F1(I)*F2(I)*t5)*SIGMA)*FH0(AM(I)*R)
  160 CONTINUE
      DO 170 I=5,7
      A=-GTF(I)*G1(I)*G2(I)*AM(I)*FH0(AM(I)*R)
      VS=VS+A*(1.-AM(I)**2/(8.*BM(1)*BM(2)))
  170 CONTINUE
C
      endif
c
      v(j)=(VPS+VS+VV)*hc/(1.+VEL)-0.25/4.759*(VELD/(1.+VEL))**2
  180 CONTINUE
      go to 1100
c			W   Central Imaginary
  200 continue
      IT2=IT+1
      IF(IT.GT.1) IT2=1
      do 280 j=1,meshm
      v(j)=W1(IS+1,IT2,INF+1)/(1.+EXP((H*J-AW1)/CW1))
  280 continue
      go to 1100
c			VT  Tensor
  300 continue
C
      DO 380 J=1,MESHM
      R=H*J
c
      VTPS=0.
      VTV=0.
      VEL=0.
      VELD=0.
      if(iyuky) then
C
c     interactions between nucleons
C
      DO 310 I=1,2
      VTPS=VTPS+GG(I)*0.25/HM**2*(1./R**2+AM(I)/R+AM(I)**2/3.)
     1      *YUKY(0,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)*IS
  310 CONTINUE
      DO 320 I=3,4
      VTV=VTV-GG(I)*(1.+FGR(I))**2*0.25/HM**2*(1./R**2+AM(I)/R
     1 +AM(I)**2/3.)*YUKY(0,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)*IS
  320 CONTINUE
      DO 330 I=5,7
  330 CONTINUE
      if(ipot .eq. 0) then
	DO 340 I=3,7
	VEL =VEL +0.5/HM**2*GG(I)*YUKY(0,R,AM(I),CM(I))
     1	 *TSPIN(I,IT1,INF+1)
	VELD=VELD+GG(I)*R*YUKY(1,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)
  340	CONTINUE
	VELD=2.*HM*VELD
	VEL=2.*HM*VEL
      else
	VEL =0.
	VELD=0.
      endif
      else
C
c     interactions between hyperons
C
      DO 350 I=1,2
      A=GTF(I)*G1(I)*G2(I)*AM(I)**3/(12.*BM(1)*BM(2))
      VTPS=VTPS+A*FH2(AM(I)*R)*IS
  350 CONTINUE
      DO 360 I=3,4
      VTV=VTV-GTF(I)*AM(I)**3/(12.*BM(1)*BM(2))*(G1(I)*G2(I)
     4	+(G1(I)*F2(I)*BM(2)+G2(I)*F1(I)*BM(1))/HM+F1(I)*F2(I)
     5  *(AM(I)**2/8.+BM(1)*BM(2))/HM**2)*FH2(AM(I)*R)*IS
  360 CONTINUE
      DO 370 I=5,7
      A=-GTF(I)*G1(I)*G2(I)*AM(I)*FH0(AM(I)*R)
      VLSS=VLSS+A/(2.*BM(1)*BM(2))*(AM(I)/R+1./R**2)*IS
  370 CONTINUE
C
      endif
c
      v(j)=(VTPS+VTV)/(1.+VEL)*HC
  380 CONTINUE
c
      go to 1100
c			VLS Spin Orbit
  400 continue
c
C
      DO 480 J=1,MESHM
      R=H*J
c
      VLSV=0.
      VLSS=0.
      VEL=0.
      VELD=0.
      if(iyuky) then
C
c     interactions between nucleons
C
      DO 410 I=1,2
  410 CONTINUE
      DO 420 I=3,4
      VLSV=VLSV+GG(I)*(3.+4.*FGR(I))*YUKY(1,R,AM(I),CM(I))
     1    *TSPIN(I,IT1,INF+1)*IS
  420 CONTINUE
      DO 430 I=5,7
      VLSS=VLSS+GG(I)*YUKY(1,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)*IS
  430 CONTINUE
      if(ipot .eq. 0) then
	DO 440 I=3,7
	VEL =VEL +0.5/HM**2*GG(I)*YUKY(0,R,AM(I),CM(I))
     1	 *TSPIN(I,IT1,INF+1)
	VELD=VELD+GG(I)*R*YUKY(1,R,AM(I),CM(I))*TSPIN(I,IT1,INF+1)
  440	CONTINUE
	VELD=2.*HM*VELD
	VEL=2.*HM*VEL
      else
	VEL =0.
	VELD=0.
      endif
      else
C
c     interactions between hyperons
C
      DO 450 I=1,2
  450 CONTINUE
      DO 460 I=3,4
      VLSV=VLSV-AM(I)/(BM(1)*BM(2))*(1.5*G1(I)*G2(I)+(G1(I)*F2(I)
     1   +G2(I)*F1(I))*SQRT(BM(1)*BM(2))/HM+3.*F1(I)*F2(I)*AM(I)**2
     2   /(8.*HM**2))*(AM(I)/R+1./R**2)*FH0(AM(I)*R)*IS
  460 CONTINUE
      DO 470 I=5,7
      A=-GTF(I)*G1(I)*G2(I)*AM(I)*FH0(AM(I)*R)
      VLSS=VLSS+A/(2.*BM(1)*BM(2))*(AM(I)/R+1./R**2)*IS
  470 CONTINUE
C
      endif
c
      v(j)=(VLSV+VLSS)/(1.+VEL)*HC
  480 CONTINUE
      go to 1100
c
  500 continue
      IT2=IT+1
      IF(IT.GT.1) IT2=1
      do 580 j=1,meshm
      if(is .ne. 0) then
      v(j)=IS*WLS(IT2,INF+1)/(1.+EXP((H*J-AW1)/CW1))
      endif
  580 continue
c
 1100 continue
c
      IF(RCT .ne. 0.0) then
      if(icode .eq. 1 .or. 
     1  ((icode .eq. 3 .or. icode .eq. 4) .and. is .eq. 1)) then
c
c      Step size independent interpolation region for matching
c
      I=INT((RCT+0.0001)/H)
      I = max(i,5)
      p=RCT/H - float(I)
c
c     Lagrangian interpolation coefficients
      do 1102 j=-2,2
      c(j) = 1.
      do 1102 k=-2,2
      if(k .ne. j) then
        c(j) = c(j)*(p - float(k))/float(j-k)
      endif
 1102 continue
c     Get a set of evenly spaced points
      do 1105 j=-2,2
      k=j+I
      Vx(j) = c(-2)*v(k-2) + c(-1)*v(k-1) + c(0)*v(k) 
     1      + c(1)*v(k+1)  + c(2)*v(k+2)
 1105 continue
c
c     Get value and slope for matching to Woods-Saxon shape
      A = Vx(0)*(1.+BW1)
      B =-(Vx(-2)-Vx(2)+6.*(Vx(1)-Vx(-1)))*(1.+BW1)/(BW1*12.0*H*Vx(0))
c      Aw= v(I)*(1.+BW1)
c      Bw= LOG((A/v(I+1)-1.)/BW1)/H
c	write(21,'(a,i4,1p10e12.4)')' I, p, R0, R1, R2  '
c     1 , I, p, (i-2)*H, (I-1)*H, (I  )*H, (I+1)*H, (I+2)*H
c	write(21,'(a,i4,1p10e12.4)')' I, p, V0, V1, V2  '
c     1 , I, p, Vx
c	write(21,'(a,i4,1p10e12.4)')' I, A, B, Aw, Bw   '
c     1 , I, A, B, Aw, Bw
c
      DO 2150 J=1,I
      v(J)=A/(1.+BW1*EXP(B*(H*J-RCT)))
 2150 CONTINUE
      endif
      ENDIF
c
      do 3000 j=1,meshm
      jj=2*j-1
      u(jj)=u(jj)-fact*v(j)
 3000 continue
c	write(20,'(1p10e12.4)')(v(n),n=1,meshm)
c	write(20,'(1h )')
c
	return
c
      END
c
      FUNCTION YUKY(n,R,AM,CM)
      common/yukyuk/HM
c
      E0 = exp(-AM*R)
      E1 = exp(-CM*R)
      f1 = CM**2/(CM**2-AM**2)
      if    (n .eq. 0) then
        YUKY = f1**2*(E0 -E1 - 0.5*CM*R*E1/f1)/R
        RETURN
      elseif(n .eq. 1) then
        A=(-AM*E0 + CM*E1)/R - (E0 - E1)/R**2
        YUKY = f1**2*(A + 0.5*CM**2*E1/f1)*0.5/HM**2/R
        RETURN
      elseif(n .eq.2) then
        A=(AM**2*E0 - CM**2*E1)
        B=(2.-CM*R)*E1
        YUKY = f1**2*(A  + 0.5*CM**2*B/f1)*0.5/HM**2/R
        RETURN
      else
	YUKY = 0.0
        write(6,'(/a,i3)')' Error in Yuky, wrong n =',n
      endif
c
      END


