
c***********************************************************************
      SUBROUTINE FNLOC(U1,U2,V1,V2,W,VB,space,LTR,BKIN
     1          ,FNRNG,KT,IJ,AKIN,nlev)
c
c     Calculates non-local and finite range correction for distorted waves
c
c     U1,2  = Optical     potentials for distorted waves
c     V1,2  = Spin orbit  potentials for distorted waves
c     W     = Form factor
c     VB    = Bound State potential
c     Space = Scratch storage
c     LTR   = Angular momentum transfer ( of bound state)
c     BKIN  = Kinematic quantities stored in blank common
c     FNRNG = Finite range parameter
c     KT    = Number of points
c     IJ    = Level index for distorted wave channels
c     AKIN  = Kinematic  quantities for bound state
c     nlev  = Number of levels for dimensioning of BKIN
c
c***********************************************************************
c
c
      complex U1(*),U2(*),V1(*),V2(*),W(*),space(*),CTEMP
      logical istr
c
       DIMENSION VB(*)
     1,BKIN(nlev,32),AKIN(18),IJ(2),RT(8,7),FM(3),FMA(3),ETA(3)
     2,PNLOC(3),DR(3),FMU(3),FK2(3),RC(3),FK(3)
c
      DATA  RT/  0.0   ,  4.4934,  7.7253, 10.9041, 14.0662, 17.2208,
     1 20.3713, 23.5195,  2.0816,  5.9404,  9.2058, 12.4044, 15.5792,
     2 18.7426, 21.8997, 25.0528,  3.3421,  7.2899, 10.6139, 13.8461,
     3 17.0429, 20.2219, 23.3905, 26.5526,  4.5141,  8.5838, 11.9727,
     4 15.2445, 18.4681, 21.6666, 24.8501, 28.0239,  5.6467,  9.8404,
     5 13.2956, 16.6093, 19.8624, 23.0828, 26.2833, 29.4706,  6.7565,
     6 11.0702, 14.5906, 17.9472, 21.2311, 24.4748, 27.6937, 30.8960,
     7  7.8511, 12.2793, 15.8632, 19.2627, 22.5781, 25.8461, 29.0843,
     8 32.3025/
C
C     FINITE RANGE CORRECTION
C
C     POSITIVE FR PARAMETER CALCULATES A HULTHEN TYPE FR CORRECTION
C     NEGATIVE FR PARAMETER CALCULATES A EXPONENTIAL TYPE FR CORRECTION
C
      K=KT
      DO 20 I=1,2
      J=IJ(I)
      FM(I)   =BKIN(J,2)
      FMA(I)  =BKIN(J,4)
      FMU(I)  =BKIN(J,9)
      RC(I)   =BKIN(J,10)
      FK2(I)  =BKIN(J,11)
      FK(I)   =BKIN(J,12)
      ETA(I)  =BKIN(J,13)
      DR(I)   =BKIN(J,16)
      PNLOC(I)=BKIN(J,18)
   20 CONTINUE
      FM(3)   =AKIN(2)
      FMA(3)  =AKIN(4)
      FMU(3)  =AKIN(9)
      RC(3)   =AKIN(10)
      FK2(3)  =AKIN(11)
      FK(3)   =AKIN(12)
      ETA(3)  =AKIN(13)
      DR(3)   =AKIN(16)
      PNLOC(3)=AKIN(18)
      IF(FNRNG.EQ.0.0)   GO TO 400
      IF(FM(1).EQ.FM(2)) GO TO 400
      IF(FM(1).GT.FM(2)) THEN
        istr = .true.
        I1=1
        I2=2
        fmfact  = fm(2) /fm(1)
        fmafact = fma(1)/fma(2)
      ELSE
        istr = .false.
        I1=2
        I2=1
        fmfact  = fm(1) /fm(2)
        fmafact = fma(2)/fma(1)
      ENDIF
C
C     I1 IS FOR LARGER MASS , I2 IS FOR SMALLER MASS
C
  144 CONTINUE
      TEMP=fmfact*FNRNG**2
      FACT=TEMP*fmafact
      FMX=abs(FM(1)-FM(2))
      TEMP=TEMP*FMX
      IF(FMX.LT.1.9) GO TO 350
C
C     FORM FACTOR PART BY ROST-KUNZ METHOD
C     THIS OPTION CALCULATES AN EXPONENTIAL TYPE FR CORRECTION
C     FOR MULTI-NUCLEON TRANSFER REACTIONS
C
      DR2=DR(3)**2
      FLF=LTR*(LTR+1)
      R3=DR(3)*FLOAT(K+1)
      D3=0.0
      A3=0.0
      KM=K+1
      R2=R3-DR(3)
      D2=-FLF/R3
      A2=W (KM-2)*R2
      DO 220 M=1,K
      KM=KM-1
      R1=R2-DR(3)
      A1=W (KM-2)*R1
      D1=-FLF/R2**2
      IF(A3.EQ.0.0) GO TO 215
      D1=D1+(A3-2.0*A2+A1)/(A2*DR2)
      W (KM+1)=W (KM+1)*EXP(D2*FACT)
      DX2=(D3*A3-2.0*D2*A2+D1*A1)/(R2*DR2)-A2*D2**2/R2
      W (KM+1)=W (KM+1)+0.5*DX2*FACT**2
  215 CONTINUE
      IF(ABS(W (KM-1)).LT.ABS(real(W (KM  )))) GO TO 225
      R3=R2
      R2=R1
      D3=D2
      D2=D1
      A3=A2
      A2=A1
  220 CONTINUE
  225 CONTINUE
c      KM=KM/2+1
      DO 227 M=1,KM
      MK=M+M-1
      space(M)=W(M)
      W(M)=0.0
  227 CONTINUE
      RKM=FLOAT(KM)*DR(3)
      LL=MIN0(LTR,6)
      FLF=LL*(LL+1)
      DR12=DR(3)**2/12.0
      DO 250 N=1,8
      FKX=(RT(N,LL+1)/RKM)**2
      A1=0.0
      D1=0.0
      R=DR(3)
      A2=DR(3)
      D2=(1.0+DR12*(FKX-FLF/R**2))*A2
      FNORM=0.0
      AN=0.0
      DO 230 M=1,KM
      AN=AN+VB(M)*A2*R
      FNORM=FNORM+A2**2
      space(M+400)=A2/R
      R=R+DR(3)
      D3=1.0+DR12*(FKX-FLF/R**2)
      A3=(12.0*A2-10.0*D2-D1)/D3
      D1=D2
      D2=D3*A3
      A1=A2
      A2=A3
  230 CONTINUE
      AN=AN-0.5*space(KM)*A1*(R-DR(3))
      FNORM=FNORM-0.5*A1**2
      FNORM=AN*EXP(-FACT*FKX)/FNORM
      DO 240 M=1,KM
      MK=M+M-1
      W (MK)=W (MK)+space(M+400)*FNORM
  240 CONTINUE
  250 CONTINUE
  340 CONTINUE
C
C     DISTORTED WAVE PART, GAUSSIAN FACTOR
C
      DO 345 M=1,K
      if(istr) then
        CTEMP = TEMP*(U2(M)/FMU(2)-U1(M)/FMU(1))
      else
        CTEMP = TEMP*(U1(M)/FMU(1)-U2(M)/FMU(2))
      endif
      W(M)= exp(ctemp)*W(M)
  345 CONTINUE
  348 CONTINUE
      GO TO 400
  350 CONTINUE
      IF(FNRNG.GT.0.0) GO TO 360
C
C     SINGLE PARTICLE PART, GAUSSIAN FACTOR
C
      DO 355 M=1,K
      FACT=EXP(-TEMP*VB(M)/FMU(3))
      W(M)=W(M)*FACT
  355 CONTINUE
      GO TO 340
  360 CONTINUE
C
C     HULTHEN TYPE
C
      DO 365 M=1,K
      if(istr) then
        CTEMP =     (U2(M)/FMU(2)-U1(M)/FMU(1))
      else
        CTEMP =     (U1(M)/FMU(1)-U2(M)/FMU(2))
      endif
      W(M) = W(M)/(1.0+TEMP*(CTEMP+VB(M)/FMU(3)))
  365 CONTINUE
  400 CONTINUE
C
C     NON LOCALITY CORRECTION FACTOR FOR DISTORTED WAVES
C
      CALL FNLOC5(U1,V1,W,PNLOC(1),FK2(1),FK(1),ETA(1),RC(1),DR(1),KT)
      CALL FNLOC5(U2,V2,W,PNLOC(2),FK2(2),FK(2),ETA(2),RC(2),DR(2),KT)
C
      RETURN
      END

