      SUBROUTINE VABS (K,KP,K0,REVL,IMVL,NLS)
C *** SEE R H LANDAU, PROGRAM LPOTT, 1981
C     SUB TO CALC PARTIAL WAVE DECOMP OF ABSORTIVE CONTRIB TO OPT POT
C       NIFTY(7)=3, THE OLD CASE, I.E.
C     USE SPULLER-MEASDAY PARAMS FOR PID-PP FOR E-DEPENDENCE
C       NOW EXTENTED(6-77) TO GO BEYOND RESONANCE
C     USE EMPIRICAL(ATOMIC)VALUES FOR ZERO ENERGY (READ IN VIA /ABSP/)
C     NIFTY(7)=4        USE ISOBAR MODEL WITH DIFFERENT RHON,RHOP POSSIB
C     FOR HE3 H3 SPECIAL TREATMENT WITH SPIN ETC POSSIBLE
C     THEN,FIRST 3 PARAMS IN SEC4 ARE FOR MAGNETIC, AND LAST 3 FOR RHO2
C     NB THESE  ARE A(MCCARTHY DEF)-P,B(MC CARTH DEF)-P, A(MCC)-N
C       THE A S DIFFER BY FACTOPR OF 2 FROM  H.O. PARAM
C     , FOR GIVEN VALUE OF K0,THE PARAMS ARE FIXED
      IMPLICIT REAL*8 (A-H,I,K,M,O-Z)
      REAL*8 XCOS(48),WT(48),REVL(30,2),IMVL(30,2),PL(30)
      DIMENSION NIFTY(20), BNUC(20), BNUCF(20), BN(16), BNF(16), RETIJ
     1(14), IMTIJ(14), FF(4), TOFTH(8), REVOFQ(2), IMVOFQ(2)
      COMMON /SEC2/ BNUC,BN,BNUCF,BNF,RETIJ,IMTIJ,HBARC,PI,MPI,MN,NZ,NES
     1,NWAVES,NIFTY,NA
      COMMON /SEC4/ ACHP,ACMP,WSP,AMCCP,BMCCP,AMCCN/ABSP/B0R,B0I,C0R,C0I
C
C     STATEMENT FUNCTIONS
C
      DATA KOLD,MD/0.,1875.63/
      KCM2(SS) = (SS-(MPI+MN)**2)*(SS-(MPI-MN)**2)/4./SS
      EINT(P1,P2) = SQRT(MN2+(RHL1**2)*P1*P1*0.25+(RHL2**2)*P2*P2*0.25-0
     1.5*RHL1*RHL2*P1*P2*X)
      SOFTH(P1,P2) = MPI2+MN2+RHL1*P1*P1-RHL2*P1*P2*X+2.*SQRT(MPI2+P1*P1
     1)*EINT(P1,P2)
      GS(P) = 776./(42.E04+P*P)
      GP(P) = 6.6E04*P/(8.18E04+P*P)**2
      RHO2F(A2,ALPHA) = EXP(-Q2*A2/8.)*(1.+ALPHA*A2*(12.-Q2*A2)/8.+(
     1(ALPHA*A2)**2)*(15.-2.5*Q2*A2+0.0625*(Q2*A2)**2)/16.)
      IF (ABS(1.-KOLD/K0).LT.1.E-03) GO TO 80
C     FIRST CAL,SET UP CONSTANTS AND PTS WTS
C     ABSAP ONLY FOR PIONS
      IF (MPI.GT.140.) STOP
      RHL1 = (NA+1.)/NA
      RHL2 = (NA-1.)/NA
      RHL = NA*(NA-1.)
      RHL5 = NA*NA
      MPI2 = MPI*MPI
      MN2 = MN*MN
      DO 10 N=1,30
         DO 10 J=1,2
            REVL(N,J) = 0.
            IMVL(N,J) = 0.
 10   CONTINUE
      PPTH = SQRT(0.25*(MPI2+MD*MD)+0.5*MD*MPI-MN2)/MPI
C     SET UP PTS FOR COSTHETA PROJECTION
      NCOSS = 16
      KOLD = K0
      CALL GAUSS (NCOSS,011,-1.d0,1.d0,XCOS,WT)
      B = .6*(1.1/HBARC)*(NA**(.33333))
      IF (NIFTY(16).NE.2) B = (ACHP+AMCCP)/2./HBARC
C       THE RHO**2 PARAM ARE P AND N AVERAGE
      IF ((NA.EQ.4).OR.(NA.EQ.3)) B = 1.362/HBARC
      IF (NA.GE.100) B = 3./HBARC
      B2 = B*B
      ALPH = (NA-4.)/6./B2
      IF (ALPH.LT.0.) ALPH = 0.
C     NORMALIZATION FOR RHO2 WHEN RHO(R) NORNMALIZED TO ONE
      ANRHO2 = 0.5/(PI**(1.5))/(B2*B)/(1.+1.5*ALPH*B2)**2/SQRT(2.)
      EPI = SQRT(MPI2+K0*K0)
      ENUC = SQRT(MN*MN*NA*NA+K0*K0)
C     FTOT IF THE REDUCED MASS FACTOR,NEED PI2 IN LPT NORM
C     THE NUMBER OF PAIRS IS NOW SEPERATE AND MULT LATTER
      FTOT = EPI*ENUC/(EPI+ENUC)
      ANLPT = -4.*PI*PI*PI/2./FTOT/(2.*PI)**3
      IF (NA.EQ.13) RHL = RHL*12./13.
C     SPECIAL CALC FOR WOOD-SAXON,DO RHO2 NUMERICALLY
      IF (NIFTY(16).EQ.2) ANRHO2 = 1.
      ANORM = ANRHO2*ANLPT*RHL
      JMAX = 1
      IF (NIFTY(6).EQ.3) JMAX = 2
C     BLOCK TO CALC ENERGY DEPENDCE OF B0 C0
C
C     CALC PI D COM MOMENTUM KPID,AND P P COM MOMENTUM PP
      IF (NIFTY(7).EQ.4) GO TO 70
      KSAVE = K0
      IF (K0.LT.200.) GO TO 20
C     KO GT LOW E EXPANSION RANGE,EVAL AT KCUT THEN SCALE
      K0 = 200.
 20   KO = K0
      ED = SQRT(MD*MD+(2.*K0/NA)**2)
      EPI = SQRT(MPI2+K0*KO)
      FTOT = EPI*ED/(EPI+ED)
      S = (EPI+ED)**2-(K0*(1.-2./NA))**2
      KPID2 = (S-(MPI+MD)**2)*(S-(MPI-MD)**2)/4./S/MPI2
      KPID = SQRT(KPID2)
      PP = SQRT(0.25*S-MN2)/MPI
C     S WAVE ENERGY DEPEPNDCE
      FTOTP = MPI*MD/(MPI+MD)/FTOT
      IMB = ((B0I)/(MPI**4))*((PP/PPTH)**2)*FTOTP
      IMB = IMB*(1.-.81*KPID+0.31*KPID2*(1.-KPID2)+0.505*KPID**3)
      REB = B0R*IMB/(B0I+1.E-08)
C     PWAVE,,, NR=NON RESONANT CONTRIBUTION
      IMC = (C0I/MPI**6)*FTOTP*((PP/PPTH)**2)*(1.+1.67*KPID-KPID2)
      REC = C0R*IMC/(C0I+1.E-08)
      IF (KSAVE.LT.200.) GO TO 60
C      K0 GT KCUT, USE REESONACE FORM FOR RE IM P,POLYNML FOR S
      DO 50 N=1,2
         IF (N.EQ.1) GO TO 30
C     2ND TIME THRU, REDEFINE AND SCALE
         K0 = KSAVE
         KO = K0
         ED = SQRT(MD*MD+(2.*K0/NA)**2)
         EPI = SQRT(MPI2+K0*K0)
         FTOT = EPI*ED/(EPI+ED)
         S = (EPI+ED)**2-(K0*(1.-2./NA))**2
         KPID2 = (S-(MPI+MD)**2)*(S-(MPI-MD)**2)/4./S/MPI2
         KPID = SQRT(KPID2)
         PP = SQRT(0.25*S-MN2)/MPI
C     FIRST TIME THRU OR SECOND
 30      GAMEL = 0.6*((KPID)**3/(1.+KPID2))
         GAMR = 0.05*0.92*PP
         GAMT = 0.92*(GAMEL/0.6+0.05*PP)
         RHL5 = (5./3.)*PI*((MPI*KPID)**(-2))*GAMEL*GAMR/(((SQRT(S)-2179
     1   .)/MPI)**2+GAMT*GAMT/4.)
         RHL5 = RHL5*10.*HBARC**2
C     SCALE S WAVE UP
         RHL5 = RHL5*4
         RHL6 = KPID*RHL5/4.+(2./3.)*PP*PP*(.26-.4*KPID+.08*KPID2)
         IF (RHL6.LT.0.) RHL6 = 0.
         IF ((K.EQ.KP).AND.(K.EQ.K0)) WRITE (6,200) N,RHL5,RHL6
         IF (N.EQ.2) GO TO 40
C     1ST TIME THRU
         IMC = IMC/(RHL5*FTOT/KPID)
         IMB = IMB/(RHL6*FTOT)
         GO TO 50
C     2ND TYME THRU
 40      IMC = IMC*FTOT*RHL5/KPID
         IMB = IMB*FTOT*RHL6
         REB = IMB*B0R/(B0I+1.E-08)
         REC = IMC*C0R/(C0I+1.E-08)
 50   CONTINUE
 60   CONTINUE
      GO TO 80
C     ISOBAR CALCULATION
C       CAN PUT PARTIAL WAVE DECOMP HERE,INSTEAD US
C     IT AS A FUNCTION OF THETA,IE CALL TNUC FOR ANGLE TF
C     INTIALIZE
C     NO PAIRS FOR ABSP HERE, RELATED TO DEF OF B0,C0,NB 1/4
 70   NN = NA-NZ
      PAIRPP = 0.
      PAIRNN = 0.
      PAIRPN = NZ*NN
      IF (NIFTY(1).EQ.1) PAIRPP = NZ*(NZ-1)/2.
      IF (NIFTY(1).EQ.0) PAIRNN = NN*(NN-1)/2.
      IF (NA.NE.3) GO TO 80
C     SPECIAL HE3/H3 DENSITY PART ( B REFERS TO HO PARAM)
      BP = AMCCP*2
      BP2 = BP*BP
      BMCCP2 = BMCCP*BMCCP/BP2
      ALPHP = (BMCCP2*4.)/(1.-6.*BMCCP2)
      ARHOPP = 0.5/(PI**(1.5))/(BP2*BP)/(1.+1.5*ALPHP*BP2)**2/SQRT(2.)
      ALPHN = 0.
      BBN = AMCCN*2.
      BBN2 = BBN*BBN
      BPN2 = BBN2*BP2/(BBN2+BP2)
      ARHONN = 0.5/(PI**(1.5))/(BBN2*BBN)/SQRT(2.)
      ARHOPN = 1./(BBN2*BBN)/(1.+1.5*ALPHP*BP2)/(2.*PI*(BP2+BBN2)/2./
     1BBN2)**1.5
C     PUT LPT NORM AND NO PAIRS AND RHO2 NORM TOGERTHER
      ARHOPP = ARHOPP*PAIRPP*ANLPT
      ARHONN = ARHONN*PAIRNN*ANLPT
      ARHOPN = ARHOPN*PAIRPN*ANLPT
C     PARAMS FOR VABS ALL STORED FOR THIS K0, NOW CALC VABS
C
 80   DO 90 N=1,NLS
         DO 90 J=1,JMAX
            REVL(N,J) = 0.
            IMVL(N,J) = 0.
 90   CONTINUE
      RHL3 = KP*KP+K*K
      RHL4 = 2.*KP*K
C     PARTIAL WAVE PROJECTION
      DO 190 NCOS=1,NCOSS
         X = XCOS(NCOS)
         Q2 = ABS(RHL3-RHL4*X)
C     CHECK FOR RHO**2
         IF (NIFTY(16).EQ.2) GO TO 100
         IF (NA.EQ.3.AND.NIFTY(7).EQ.4) GO TO 130
         IF ((Q2*B2/8.).GE.150.) GO TO 190
         RHO2 = RHO2F(B2,ALPH)
         GO TO 110
C      SPECIAL CALC FOR CA OR OTHER EHERE DO RHO**2 NUMERCLLLY
 100     NFF = 4
         CALL FFACT (Q2,FF,NFF)
         RHO2 = FF(3)
C     CALC PIN COM MOMENTUN
 110     IF (NIFTY(7).EQ.4) GO TO 120
         SON = SOFTH(K0,K0)
         SIN = SOFTH(K,KP)
         SOUT = SOFTH(KP,K)
         KAP02 = KCM2(SON)
         KAPP2 = KCM2(SOUT)
         KAP2 = KCM2(SIN)
         KAP0 = SQRT(KAP02)
         KAP = SQRT(KAP2)
         KAPP = SQRT(KAPP2)
         FACTS = GS(KAPP)*GS(KAP)/GS(KAP0)**2
         FACTP = GP(KAPP)*GP(KAP)*K0*K0*X/GP(KAP0)**2
         REVOFQ(1) = (REB*FACTS+REC*FACTP)*RHO2*ANORM
         IMVOFQ(1) = (IMB*FACTS+IMC*FACTP)*RHO2*ANORM
         REVOFQ(2) = 0.
         IMVOFQ(2) = 0.
         GO TO 160
C     ISOBAR CALC OF ABSP FOR NON HE3 NUCLEUS
C     NON-A=3 NUCLEUS
C
C     CODE FOR TOFTH(J) FOR ABSP AMPLITUDES
C               1,2...PP NOFLIP RE,IM    3,4...PN NOFLIP RE,IM
C               5,6...PP FLIP RE,IM      7,8...PN FLIP RE,IM
 120     RHL6 = RHO2*ANORM/RHL5
         RHOPP = PAIRPP*RHL6/2.
         RHONN = PAIRNN*RHL6/2.
         RHOPN = PAIRPN*RHL6
         GO TO 140
C     SPECIAL 3HE CALC WITH ISOBAR ABSP
 130     RHOPP = 0.
         RHONN = 0.
         RHOPN = 0.
         KBYPP = Q2*BP2/8.
         KBYNN = Q2*BBN2/8.
         KBYPN = Q2*BP2*BBN2/(BP2+BBN2)/4.
         IF (KBYPP.LT.150.) RHOPP = ARHOPP*RHO2F(BP2,ALPHP)
         IF (KBYNN.LT.150.) RHONN = ARHONN*RHO2F(BBN2,ALPHN)
         IF (KBYPN.LT.150.) RHOPN = ARHOPN*EXP(-KBYPN)*(1.+0.25*ALPHP*(6
     1   .*BPN2-BPN2*BPN2*Q2))
 140     CALL TNUCTH (KP,K,K0,X,TOFTH,MD)
         DO 150 J=1,JMAX
            J4 = 4*(J-1)
            REVOFQ(J) = (TOFTH(1+J4)*(RHOPP+RHONN)+TOFTH(3+J4)*RHOPN)
            IMVOFQ(J) = (TOFTH(2+J4)*(RHOPP+RHONN)+TOFTH(4+J4)*RHOPN)
 150     CONTINUE
 160     PL(1) = WT(NCOS)
         PL(2) = X*WT(NCOS)
         DO 180 J=1,JMAX
            REVL(1,J) = REVL(1,J)+PL(1)*REVOFQ(J)
            IMVL(1,J) = IMVL(1,J)+PL(1)*IMVOFQ(J)
            REVL(2,J) = REVL(2,J)+PL(2)*REVOFQ(J)
            IMVL(2,J) = IMVL(2,J)+PL(2)*IMVOFQ(J)
            NN = NLS-1
            IF (NN.LT.2) GO TO 180
            DO 170 N=2,NN
               G = X*PL(N)
               PL(N+1) = G-PL(N-1)+G-(G-PL(N-1))/N
               REVL(N+1,J) = REVL(N+1,J)+PL(N+1)*REVOFQ(J)
               IMVL(N+1,J) = IMVL(N+1,J)+PL(N+1)*IMVOFQ(J)
 170        CONTINUE
 180     CONTINUE
 190  CONTINUE
      IF ((K.EQ.KP).AND.(K.EQ.K0)) WRITE (6,210) K,IMB,REB,IMC,REC,(REVL
     1(N,1),IMVL(N,1),REVL(N,2),IMVL(N,2),N=1,NLS)
      RETURN
C
 200  FORMAT (17H N,SIG(MB)P,SIGS=,I5,2E15.3)
 210  FORMAT (43H TRUE 2N ANNIHILATION PARAMS FOR K(=KP=K0):,
     1 50H IMB,REB,IMC,REC/ THEN, RE, IM VABS(L) FLIP+NOFLIP,/,
     2 F10.3,4E15.5,/,30(4E15.5/))
      END
