
c***********************************************************************
      SUBROUTINE ACHCK3
c
c     Subroutine read input lines and to control calculation of diagonal
c     potentials and off diagonal coupling potentials.
c     
c***********************************************************************
c
c
c     KMAX  = Number of integration points
c     NCHAN = Number of sub channels in INTEG2
c     ispc  = Labeled common sizes
c     nlev  = Number of levels
c
      parameter (kmax = 300, nchan= 64, ispc0= 16384, ispc1= 3*16384
     1, ispc4= 8192,nlkmax= ispc1/2/kmax, nlev = 12)
      parameter (nlsj=9)
c
      complex space(4*kmax), xc1(kmax,nlkmax)
     1      , W(kmax,nlev), V(kmax,nlev)       
      character*3 Tstr, Gstr(2)
      logical ippbar, ifnloc
c
      COMMON ALPHA(15),HBARC,AMU,CHGSQ,DRT,RMAX
     1,ICON(20),LMAX,KT,MAXD,IOUT,JOUT,NLTR,IDAT(6)
     2,KLAM(nlev),LTRT(nlev),JTRT(nlev),NADD(nlev)
      COMMON EN(nlev),FM(nlev),Z(nlev),FMA(nlev),ZA(nlev),RY(nlev)
     1,FS(nlev),ECM(nlev),FMU(nlev),RC(nlev),FK2(nlev),FK(nlev)
     2,ETA(nlev),AFACT(nlev),PFACT(nlev),DRF(nlev),FN(nlev)
     3,PNLOC(nlev),DUM(nlev),TSIG(nlev)
     4,IS(nlev),NS(nlev),NLI(nlev),IN(nlev),INN(nlev,nlev)
     5,LAM(nlkmax),ISP(nlkmax),JSP(nlkmax),ILK(nlkmax)
     6,LKTAB(2*nlkmax),ICUP(2*nlkmax),JCUP(2*nlkmax)
c
      COMMON /label0/Space0(ispc0)
      COMMON /label1/Space1(ispc1)
      COMMON /label4/Space4(ispc4)
      common /xsectc/thetan,theta1,dtheta,angdat(40)
	common/ch3files/input, ioutp
c
      DIMENSION AKIN(32),BKIN(nlev,32),IJ(2),LDFRM(4),ABETA(3)
     1,gf(2*kmax),IPAR(8),FNRNG(nlkmax)
     2,amass(nlev),lsj(3)

      EQUIVALENCE (Space0(   1),W(1,1)),(Space0( nlev*2*kmax+ 1),V(1,1))
     1,           (Space1(   1),XC1(1,1))
     2,           (Space4(   1),space(1)),(Space4(8*kmax+1),gf(1))
     3,(EN(1),BKIN(1,1)),(dum(1),amass(1))
C
      DATA LCORE,NBKIN/800,20/
      DATA Gstr/'/2 ','   '/
      data nthmax/40/
      data lsj/1,0,2/
C
      SF(I)=SQRT(FLOAT(I+1))
C
      nstmax = nlev
    1 CONTINUE
      KMAX2=KMAX+KMAX
      IOUT=0
      JOUT=0
      AMFACT=2.0*AMU/HBARC**2
C
C     READ IN CARD SET 2
C
c     Icon(1) = 0  Read in data  for angles
c		1  Read in data  for cos(angles)
c		4  Read in table for angles
c		5  Read in table for cos(angles)
c		6  Read in data  for angles,       output to For020.dat
c		7  Read in data  for cos(angles),  output to For020.dat
c
      READ (input,9008)THETAN,THETA1,DTHETA
      if(icon(19).eq.0) then
      WRITE(ioutp,9010)THETAN,THETA1,DTHETA
      endif
      if(icon(1).eq.4.or.icon(1).eq.5) then
        ntheta=thetan
        if(ntheta.le.nthmax) then
          read (input,9008)(angdat(nth),nth=1,ntheta)
        else
          read (input,9008)(angdat(nth),nth=1,nthmax)
          thetan=nthmax
          do 5 nth=nthmax,ntheta,10
          read (input,9008)
    5     continue
        endif
      endif
C
C     READ IN CARD SET 3
C
      READ (input,9004)LMAX,NLTR,(LTRT(I),I=1,NLTR),(KLAM(I),I=1,NLTR)
     1,(IPAR(I),I=1,NLTR)
      if(icon(19).eq.0) then
      WRITE(ioutp,9026)LMAX,(LTRT(I),I=1,NLTR)
      WRITE(ioutp,9027)NLTR,(KLAM(I),I=1,NLTR)
      endif
      IF(NLTR.GT.NSTMAX) THEN
      WRITE(ioutp,9060)
      JOUT=1
      ENDIF
      DO 20 I=1,NLTR
      JTRT(I)=IABS(LTRT(I))
      LTRT(I)=ISIGN(1,LTRT(I))
      IF(IPAR(I).NE.0) LTRT(I)=IPAR(I)
   20 CONTINUE
      if(icon(19).eq.0) then
      WRITE(ioutp,9029)(LTRT(I),I=1,NLTR)
      endif
      LMAX=MIN0(iabs(LMAX)+1,LCORE/NLTR)
C
C     READ IN CARD SET 4
C
      READ (input,9008)DRT,RMAX,(amass(i),i=1,nltr)
      if(icon(19).eq.0) then
      WRITE(ioutp,9028)DRT,RMAX
      endif
      KT=ABS(RMAX)/DRT+1.0E-02
      KTMIN=KT
C
C     READ IN DIAGONAL CHANNEL CARD SETS
C
      DO 200 I=1,NLTR
      IF(PHASEF(JTRT(I)).gt.0.0) then
        LTEMP=LTEMP/2
        Tstr=Gstr(2)
      else
        LTEMP=JTRT(I)
        Tstr=Gstr(1)
      endif
c
      if(icon(19).eq.0) then
      WRITE(ioutp,9011)I,LTEMP,Tstr
      endif
C
C
      akin(19)=amass(i)
      CALL KINEX(AKIN,W(1,I),ECM(1),DRT,I,KMAX,ICON(10),icon(19),HBARC)
      DO 140 M=1,NBKIN
      BKIN(I,M)=AKIN(M)
  140 CONTINUE
      IS(I)=FS(I)
      FS(I)=FS(I)/2.0
      NS(I)=IS(I)+1
C
C
      READ (input,9018)JJ,II,LAMBDA,ISPIN,JSPIN,ICODE,LDFRM(1),ICOUEX
     1   ,ABETA
      LAMBDA=0
      DO 148 J=1,3
      LDFRM(J+1)=LDFRM(J)+2
      IF(ABETA(J).NE.0.0) then 
      if(icon(19).eq.0) then
      if(abeta(j).lt.-1000.) then
        WRITE(ioutp,9006)LAMBDA,ABETA(J),LDFRM(J)
      else
        WRITE(ioutp,9007)LAMBDA,ABETA(J),LDFRM(J)
      endif
      endif
      endif
  148 CONTINUE
      DO 150 M=1,KMAX
      V(M,I)=0.0
  150 CONTINUE
      ICODE=ICODE+1024
      CALL POTENT(AKIN,W(1,I),V(1,I),KT,KMAX,ICODE,LAMBDA,LDFRM,ABETA
     1,JOUT,icon(19))
      IF(ICON(11).ne.0 .and. icon(19).eq.0) then
C
C     WRITE OUT     Diagonal K(I,I)**2 ELEMENTS
C
c     central
      WRITE(ioutp,9901)' Central   ',I
      KT2=KT+KT
      idel = icon(11)
      mdel = 5*idel
      IND  = idel-1
      DO 180 M=1,KT,mdel
      INC=IND+1
      IND=MIN0(INC+mdel-1,KT)
      R=DRF(I)*float(inc)
      WRITE(ioutp,9900)R,(W(J,I),J=INC,IND,idel)
  180 CONTINUE
      if(is(i).ne.0.and.REAL(v(1,i)).ne.0.0) then
c     Spin-orbit
      KT2=KT+KT
      WRITE(ioutp,9901)' Spin orbit',I
      IND  = idel-1
      DO 190 M=1,KT,mdel
      INC=IND+1
      IND=MIN0(INC+mdel-1,KT)
      R=DRF(I)*float(inc)
      WRITE(ioutp,9900)R,(V(J,I),J=INC,IND,idel)
  190 CONTINUE
      endif
      endif
  200 CONTINUE
C
C      READ IN CHANNEL COUPLINGS
C
      if(icon(19).eq.0) then
      WRITE(ioutp,9019)1,ALPHA,(IDAT(I),I=1,3)
      endif
      DO 210 I=1,8
      DO 210 J=1,8
      INN(I,J)=0
  210 CONTINUE
      LK=0
      NCUP=0
  220 CONTINUE
      ECMT=0.0
      ifnloc = .true.
      READ (input,9018)JJ,II,LAMBDA,ISPIN,JSPIN,ICODE,LDFRM(1),ICOUEX
     1  ,ABETA,RCX,FNRNG(nlkmax)
c      exit on a channel number = 0
      if(jj .eq. 0 .or. ii .eq. 0) go to 8990
      I=IABS(II)
      J=IABS(JJ)
      if(icon(19).eq.0) then
      if(jj .gt. 0) then
        WRITE(ioutp,9016)JJ,II,ICOUEX
      else
        WRITE(ioutp,9017)JJ,II,ICOUEX
      endif
      endif
      LK=LK+1
      IF(LK.gt.NLKMAX) then
c
      WRITE(ioutp,9054)
      stop 'Error in Achck3'
      endif
c
      FNRNG(LK)=FNRNG(nlkmax)
      NCUP=NCUP+1
      ICUP(NCUP)=I
      JCUP(NCUP)=J
      LKTAB(NCUP)=LK
      INN(J,I)=1
      IF(J.NE.I.AND.JJ.GT.0) then
        NCUP=NCUP+1
        ICUP(NCUP)=J
        JCUP(NCUP)=I
        LKTAB(NCUP)=LK
        INN(I,J)=1
C
      ENDIF
      LAM(LK)=LAMBDA
      ISP(LK)=ISPIN
      IF(ISPIN.EQ.0) JSPIN=LAMBDA+LAMBDA
      JSP(LK)=JSPIN
      if(icon(19).eq.0) then
      WRITE(ioutp,9037)LAM(LK),ISP(LK),JSP(LK),ICODE,RCX,FNRNG(LK)
      endif
      DO 265 K=1,3
      LDFRM(K+1)=LDFRM(K)+2
      IF(ABETA(K).NE.0.0.or.k.eq.1) then
      if(icon(19).eq.0) then
      if(abeta(k).lt.-1000.) then
        WRITE(ioutp,9006)LAM(LK),ABETA(K),LDFRM(K)
      else
        WRITE(ioutp,9007)LAM(LK),ABETA(K),LDFRM(K)
      endif
      endif
      endif
  265 CONTINUE
C
C     CHECK COUPLING FOR CONSISTENCY
C
      IF(PHASEF(IS(I)+IS(J)+ISPIN).LT.0.0) THEN
        JOUT=1
	write(*,'(5i14)')i,j,is(i),is(j),ispin
        WRITE(ioutp,9051)IS(I),IS(J),ISPIN
      ENDIF
      IF(PHASEF(JTRT(I)+JTRT(J)+JSPIN).LT.0.0) THEN
        JOUT=1
        WRITE(ioutp,9052)JTRT(I),JTRT(J),JSPIN
      ENDIF
      IF(FLOAT(LTRT(I)*LTRT(J))*PHASEF(LAMBDA).LT.0.0
     1  .and.icode.le.8) THEN
        JOUT=1
        WRITE(ioutp,9053)LTRT(I),LTRT(J),LAMBDA
      ENDIF
      IF(I.GT.NLTR) THEN
        JOUT=1
        WRITE(ioutp,9055)
      ENDIF
      IF(J.GT.NLTR) THEN
        JOUT=1
        WRITE(ioutp,9055)
      ENDIF
C     CHECK TRIANGULAR RELATIONS
      IF(DELR(JTRT(J),JTRT(I),JSPIN).EQ.0.0) THEN
        WRITE(ioutp,9052)JTRT(J),JTRT(I),JSPIN
        JOUT=1
      ENDIF
C
C
C
C     Option  0  Collective
C     Option  1  Single particle, stripping-pick up
C     Option  2  Microscopic, inelastic and TNT
C     Option  3  Weak coupling collective
C     Option  4  E = 0 form factor, particle transfer
C     Option  5  Rescale previous form factor
C     Option  6  Collective, strong coupling
C     Option  7  sigma * I and tensor force
C     Option  8  sigma * I and tensor force, particle-hole cases
C     Option 10  Off-shell correction for Two Nucleon Transfer 
C     Option 11  Off-shell correction for stripping, zero   range
C     Option 12  Off-shell correction for stripping, finite range
c     Option 13  Spin orbit  L*IS      (projectile)
c     Option 14  Spin orbit  L*JT      (target)
c     Option 15  Spin orbit  L*(IS+JT) (projectile + target)
c     Option 16  (p,gamma), electric multipole
C     Option 17  Collective model, deformed spin orbit (symmetric)
C     Option 20  Sigma*I, P-P_bar model
C     Option 21  Derivative couplings,  P-P_bar model
C     Option 47  hyperon-hyperon_bar potentials in routine antipot
C     Option 48     ""
C     Option 57     ""
C     Option 58     ""
C
      if(    (fm(i) .eq. 0.0 .and. is(i) .eq. 2)
     1 .or.  (fm(j) .eq. 0.0 .and. is(j) .eq. 2)) then
        bfact=-abeta(1)*sqrt(chgsq)
      else
        bfact=-abeta(1)*amfact
      endif
c
c      Check for particle-antiparticle coupling
c
      izz = sign(abs(z (i))*10000.+1.e-2 ,z (i))
      izza= sign(abs(za(i))*10000.+1.e-2 ,za(i))
      jzz = sign(abs(z (j))*10000.+1.e-2 ,z (j))
      jzza= sign(abs(za(j))*10000.+1.e-2 ,za(j))
      if(fm(i).eq.fma(i) .and. izz.eq.-izza .or.
     1   fm(j).eq.fma(j) .and. jzz.eq.-jzza) then
        ippbar = .true.
      else
        ippbar = .false.
      endif
c
      ilk(lk)=icode
C    icode =   0    1    2    3    4    5    6    7    8    9
       goto( 300, 320, 340, 300, 360, 380, 400, 420, 420, 290),icode+ 1
       goto( 340,1100,1200,1300,1400,1500,1600, 300, 290, 290),icode- 9
       goto(2100,2100),icode-19
       goto( 290, 290, 290, 290, 290, 290, 290, 420, 420, 290),icode-39
       goto( 290, 290, 290, 290, 290, 290, 290, 420, 420, 290),icode-49
  290 continue
      WRITE(ioutp,9056)ICODE
      stop 'Error in Achck3'
zC
C     COLLECTIVE FORM FACTOR  OPTIONS 0, 3 and 17
C
  300 CONTINUE
      IF(RCX.GT.0.0) RCX=    RCX * AFACT(J)
      IF(RCX.LT.0.0) RCX=ABS(RCX)*(AFACT(J)+PFACT(J))
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 310 M=1,KMAX
      space(M)=0.0
  310 CONTINUE
C
      if(icode .eq. 0 .or. icode .eq. 17) then
        Icod = 0
      else
        Icod = 3
      endif
      CALL POTENT(AKIN,space(1), space(kmax+1),KT,KMAX,Icod
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
      IF(ICOUEX.ne.0) then
C
C       CALCULATE COULOMB EXCITATION
C
        ETAK= 6.0*ETA(I)*FK(I)*RCX**LAMBDA
     1  /(FMU(I)*FLOAT(LAMBDA+LAMBDA+1))
        R=0.0
        DO 312 M=1,KMAX
        R=R+DRF(I)
        IF(R.ge.RCX) then
        space(M)=space(M)+ETAK/R**(LAMBDA+1)
      endif
  312 CONTINUE      
      endif
      bfact = -abeta(1)
      if(icode .eq. 17) then
        do 314 m=1,kmax
        space(m) = space(m+kmax)
  314   continue
      endif
      GO TO 8900
C
C     SINGLE PARTICLE ORBITAL  OPTION 1
C
  320 CONTINUE
      CALL KINEX(AKIN,SPACE(1),ECMT,DRT,0,KMAX,ICON(10),icon(19),HBARC)
      DO 330 M=1,KMAX
      SPACE(M+kmax  )=0.0
  330 CONTINUE
      CALL POTENT(AKIN,SPACE(1),SPACE(kmax+1),KT,KMAX,ICODE,0,0
     1           ,0.0,JOUT,icon(19))
c
      GO TO 8900
C
C     MICROSCOPIC MODEL FORM FACTOR             OPTION  2
C     Two Nucleon Transfer off-shell correction option 10
C
  340 CONTINUE
      DO 350 M=1,KMAX
      space(M)=0.0
  350 CONTINUE
      DR=DRT
      CALL CATHEN(LAMBDA,ISPIN,JSPIN,KT,KMAX,SPACE(kmax+1)
     1     ,SPACE(3*kmax+1),space(1),DR 
     2     ,ICON(10),icon(19),ICON(4),JOUT,HBARC)
      AKIN(16)=DR
      IF(ABS(FMA(J)-FMA(I)).GT.1.2.and.icode.ne.10) ILK(LK)=1
c
      GO TO 8900
C
C     E=0.0 FORM FACTOR OPTIONS FOR PARTICLE TRANSFER  OPTION 4
C
  360 CONTINUE
      DO 365 M=1,KMAX
      space(M)=0.0
  365 CONTINUE
      CALL KINEX(AKIN,SPACE(kmax+1),ECMT,DRT,0,KMAX
     1          ,ICON(10),icon(19),HBARC)
      AKIN(20)=1.0
      CALL POTENT(AKIN,space(1),SPACE(kmax+1),KT,KMAX,ICODE
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
c
      GO TO 8900
  380 CONTINUE
C
C     RESCALE PREVIOUS FORM FACTOR  OPTION 5
C
c
      call storexc(space(1), bfact, kmax, xc1(1,lk))
      ILK(LK)=ILK(LK-1)
      GO TO 8900
C
C     STRONG COUPLING COLLECTIVE MODEL
C     SPECTROSCOPIC FACTOR ALGEBRA      OPTION 6
C
  400 CONTINUE
      JT=JSPIN
      IF(FMA(J).lt.FMA(I)+0.2) then
C     STRIPPING
        MK=KLAM(I)-KLAM(J)
        BFACT=BFACT*SQRT(FLOAT(JTRT(J)+1)/FLOAT(JTRT(I)+1))
     1       *VCC(JTRT(J),JT,JTRT(I),KLAM(J),MK)
      else
C     PICKUP
        MK=KLAM(J)-KLAM(I)
        BFACT=BFACT*SQRT(FLOAT(JTRT(I)+1)/FLOAT(JTRT(J)+1))
     1       *VCC(JTRT(I),JT,JTRT(J),KLAM(I),MK)
      endif
      IF(MK.LT.0) BFACT=BFACT*PHASEF((JT-MK)/2)
      ILK(LK)=1
      GO TO 320
C
C     (2*IS) * (2*I) AND TENSOR FORCE  OPTION 7 and 8
C
C     IS is projectile spin  and  I is target spin
C     Lambda = 0, Ispin = 0, Jspin = 0 --> SCALAR
C     Lambda = 0, Ispin = 2, Jspin = 2 --> (2*IS) * (2*I)
C     Lambda = 2, Ispin = 2, Jspin = 2 --> TENSOR
C
  420 CONTINUE
      IF(RCX.GT.0.0) RCX=    RCX * AFACT(J)
      IF(RCX.LT.0.0) RCX=ABS(RCX)*(AFACT(J)+PFACT(J))
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 430 M=1,KMAX
      space(m) =0.0
  430 CONTINUE
C
      CALL POTENT(AKIN,space(1),SPACE(kmax+1),KT,KMAX,ICODE
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
      IF(LTRT(I).EQ.LTRT(J).AND.IS(I).EQ.IS(J)) THEN
      if(ippbar .and. icode.eq.8) then
c
        if(lambda.eq.0) then
          if(ispin .eq.0) then
            temp1=-abeta(1)*0.50
            temp2= abeta(1)*0.50
          else
            temp1=-abeta(1)*0.50
            temp2=-abeta(1)*1.50
          endif
        endif
c
      else
            temp1=abeta(1)
            temp2=0.0
      endif
c
      bfact = temp1
      call storexc(space(1), bfact, kmax, xc1(1,lk))
c
        if(ippbar.and.icode.eq.8) then
c
          if(icon(19).eq.0) then
          write(ioutp,9013)
          endif
          lk=lk+1
          ilk(lk)=icode
          NCUP=NCUP+1
          ICUP(NCUP)=I
          JCUP(NCUP)=J
          LKTAB(NCUP)=LK
          INN(J,I)=1
          IF(J.NE.I.AND.JJ.GT.0) then
            NCUP=NCUP+1
            ICUP(NCUP)=J
            JCUP(NCUP)=I
            LKTAB(NCUP)=LK
            INN(I,J)=1
C
          ENDIF
        if(ispin.eq.0) then
          lam(lk)=0
          isp(lk)=2
          jsp(lk)=2
        else
          LAM(LK)=0
          ISP(LK)=0
          JSP(LK)=0
        endif
        if(icon(19).eq.0) then
        WRITE(ioutp,9037)LAM(LK),ISP(LK),JSP(LK),ILK(LK),RCX,FNRNG(LK)
        endif
c
        bfact = temp2
        call storexc(space(1), bfact, kmax, xc1(1,lk))
        endif
      ENDIF
      GO TO 8950
C
C     FINITE RANGE OFF SHELL CORRECTION  OPTIONS 11 AND 12
C
C     Option 11 is for sequential particle transfer, zero   range
C     Option 12 is for sequential particle transfer, finite range
C
 1100 CONTINUE
 1200 CONTINUE
      DO 1220 M=1,KMAX
      space(M)=0.0
 1220 CONTINUE
C
      IT=IABS(II)
      JT=IABS(JJ)
      LKI=0
      LKJ=0
      DO 1250 K1=1,NLTR
      IF(IT.EQ.K1.OR.JT.EQ.K1) go to 1250
      DO 1240 N1=1,NCUP
      DO 1230 N2=1,NCUP
c      WRITE(0,7780)IT,JT,K1,N2,ICUP(N2),JCUP(N2),N1,ICUP(N1),JCUP(N1)
c      WRITE(ioutp,7780)IT,JT,K1,N2,ICUP(N2),JCUP(N2),N1,ICUP(N1),JCUP(N1)
c 7780 FORMAT('0IT =',I3,'  JT =',I3,'  KK =' ,I3
c     1      ,'  NJ =',I3,'  ICUP(NJ) =',I3,'  JCUP(NJ) =',I3
c     2      ,'  NI =',I3,'  ICUP(NI) =',I3,'  JCUP(NI) =',I3)
      IF( JT.eq.JCUP(N2).and.K1.eq.ICUP(N2) .and.
     1    IT.eq.ICUP(N1).and.K1.eq.JCUP(N1)) then
C
      kk=k1
      ni=n1
      nj=n2
      LKI=LKTAB(NI)
      LKJ=LKTAB(NJ)
      endif
C
 1230 CONTINUE
 1240 CONTINUE
 1250 CONTINUE
      IF(LKI*LKJ.ne.0) then
      FRI=FNRNG(LKI)
      FRJ=FNRNG(LKJ)
C
      XI=FM(IT)-FM(KK)
      XJ=FM(JT)-FM(KK)
      L = 2*LAM(LK)
      IZ=   ISP(LK)
      J =   JSP(LK)
      L1 =2*LAM(LKI)
      L2 =2*LAM(LKJ)
      IS1=  ISP(LKI)
      IS2=  ISP(LKJ)
      J1 =  JSP(LKI)
      J2 =  JSP(LKJ)
      TEMP1=( MIN1(FM(IT),FM(KK))*XI*FRI**2/ MAX1(FM(IT),FM(KT))
     1     +  MIN1(FM(JT),FM(KK))*XJ*FRJ**2/ MAX1(FM(JT),FM(KT)))
C
c      WRITE(ioutp,7782)L1,IS1,J1,L2,IS2,J2,L,IZ,J
 7782 FORMAT(20I6)
      TEMP2 =   SF(IZ)*SF(JTRT(IT))*SF(IS(JT))*SF(IS(KK))
     1         *RACAH(IS(IT),IS1,IS(JT),IS2,IS(KK),IZ)
     2         *PHASEF((IS1+IS2-IZ+J1+J2-J+JTRT(IT)-JTRT(JT))/2)
      temp=temp1*temp2
c      WRITE(ioutp,7782)IS(IT),IS1,IS(JT),IS2,IS(KK),IZ
c      WRITE(20,7783)LKI,LKJ,KK,IT,JT,temp1,temp2,temp
      if(icon(19).eq.0) then
      WRITE(ioutp,7783)LKI,LKJ,KK,IT,JT,temp1,temp2,temp
 7783 format(' lki =',i3,'  lkj =',i3,'  kk =',i3,'  it =',i3
     1,'  it =',i3,'   TEMPi =',1p,4e12.4)
      endif
C
      dr=drt
      call cathen(lambda,ispin,jspin,kt,kmax,space(kmax+1)
     1     ,space(3*kmax+1),space(1),dr
     2     ,icon(10),icon(19),icon(4),jout,hbarc)
      akin(16)=dr
      ilk(lk)=1
c
      t1=-temp*abeta(1)*amfact**2/2.0
c
        bfact = t1
        call storexc(space(1), bfact, kmax, xc1(1,lk))
      else
        WRITE(ioutp,9057)
      endif
      GO TO 8950
c
c     Option 13  Spin orbit, projectile
c     L = 1, S = 1, J = 0
c
 1300 CONTINUE
      IF(RCX.GT.0.0) RCX=    RCX * AFACT(J)
      IF(RCX.LT.0.0) RCX=ABS(RCX)*(AFACT(J)+PFACT(J))
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 1320 M=1,KMAX
      space(m) =0.0
 1320 CONTINUE
C
      CALL POTENT(AKIN,space(1),SPACE(kmax+1),KT,KMAX,ICODE
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
c
        bfact = sqrt(3.0)*abeta(1)
        ifnloc = .false.
      go to 8900
c
c     Option 14  Spin orbit, target
c     L = 1, S = 0, J = 1
c
 1400 CONTINUE
      IF(RCX.GT.0.0) RCX=    RCX * AFACT(J)
      IF(RCX.LT.0.0) RCX=ABS(RCX)*(AFACT(J)+PFACT(J))
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 1420 M=1,KMAX
      space(m) =0.0
 1420 CONTINUE
C
      CALL POTENT(AKIN,space(1),SPACE(kmax+1),KT,KMAX,ICODE
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
c
      bfact = sqrt(3.0)*abeta(1)
      ifnloc = .false.
      go to 8900
c
c     Option 15  Spin orbit, projectile and target
c     L = 1, S = 1, J = 0
c     L = 1, S = 0, J = 1
c
 1500 CONTINUE
      IF(RCX.GT.0.0) RCX=    RCX * AFACT(J)
      IF(RCX.LT.0.0) RCX=ABS(RCX)*(AFACT(J)+PFACT(J))
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 1520 M=1,KMAX
      space(m) =0.0
 1520 CONTINUE
C
      CALL POTENT(AKIN,space(1),SPACE(kmax+1),KT,KMAX,ICODE
     1,LAMBDA,LDFRM,ABETA,JOUT,icon(19))
c
          bfact = sqrt(3.0)*abeta(1)
      call storexc(space(1), bfact, kmax, xc1(1,lk))
      ilk(lk)=13
      lk=lk+1
      ilk(lk)=14
      ncup=ncup+1
      icup(ncup)=i
      jcup(ncup)=j
      lktab(ncup)=lk
      inn(i,j)=1
      if(j.ne.i.and.jj.gt.0) then
        ncup=ncup+1
        icup(ncup)=j
        jcup(ncup)=i
        lktab(ncup)=lk
        inn(i,j)=1
      endif
      lam(lk)=lsj(1)
      isp(lk)=lsj(2)
      jsp(lk)=lsj(3)
c
      bfact = sqrt(3.0)*abeta(1)
      call storexc(space(1), bfact, kmax, xc1(1,lk))
      if(icon(19).eq.0) then
      WRITE(ioutp,9037)LAM(LK),ISP(LK),JSP(LK),ILK(LK),RCX,FNRNG(LK)
      endif
      go to 8950
c
 1600 continue
c
c     (p,gamma) form factor
c
      call kinex(akin,space(1),ecmt,drt,0,kmax,icon(10),icon(19),hbarc)
      do 1620 m=1,kmax
      space(mk+kmax  )=0.0
 1620 continue
      icx=1
      call potent(akin,space(1),space(kmax+1),kt,kmax,icx,0,0
     1           ,0.0,jout,icon(19))
c
c	write(20,'(1p,10e12.4)')(REAL(space(m)),m=1,kmax)
      call gamma(ii,jj,lk,ncup,icode,ippbar,xc1(1,1)
     1          ,space,gf,w,abeta(1))
c
      go to 8900
c
c     Derivative coupling
c     P-P_bar option
c
 2100 continue
      AKIN(20)=AMFACT
      AKIN(14)=AFACT(I)
      AKIN(15)=PFACT(I)
      AKIN(16)=DRF(I)
      DO 2010 M=1,KMAX
      space(M)=0.0
 2010 CONTINUE
      call potent(akin,space(1),space(kmax+1),kt,kmax,icode
     1           ,lambda,ldfrm,abeta,jout,icon(19))
c
      call ppbar(ii,jj,lk,ncup,icode,ippbar,xc1(1,1)
     1          ,space,gf,w,abeta(1))
c
      go to 8950
c
 8900 CONTINUE
      call storexc(space(1), bfact, kmax, xc1(1,lk))
      if(ifnloc) then
        i1 = iabs(ii)
        i2 = iabs(jj)
        IJ(1)=i1
        IJ(2)=i2
        CALL FNLOC(W(1,i1),W(1,i2),V(1,i1),V(1,i2),XC1(1,lk)
     1          ,SPACE(kmax+1),space(2*kmax+1),LAMBDA,BKIN
     2          ,FNRNG(LK),KT,IJ,AKIN,nlev)
      endif
 8950 CONTINUE
C
C     WRITE OUT Non-Diagonal  K(I,J)**2 ELEMENTS
C
      IF(ICON(12).NE.0) then
      DR=AKIN(16)
      kt2=2*kt
      idel = icon(12)
      mdel = 5*idel
      n1=nlsj
      if(icode.eq.21) n1=1
      if(icode.eq. 8.and.ippbar) n1=nlsj-1
      if(icode.eq.20.and.ippbar) n1=nlsj-1
      if(icode.eq.15) n1=nlsj-1
      if(icode.eq.16) n1=nlsj-1
c
      if(icon(19).eq.0) then

      do 8980 n=n1,nlsj
      ilk_add1= lk+n-nlsj
      WRITE(ioutp,9902)JJ,II,ilk(ilk_add1),ilk_add1
      IND=idel - 1
      DO 8970 M=1,KT,mdel
      INC=IND+1
      IND=MIN0(INC+mdel-1,KT)
      r=dr*float(inc)
        WRITE(ioutp,9900)R,(XC1(K  ,ilk_add1), K=INC,IND,idel)
 8970 CONTINUE
 8980 continue
      endif
      endif
      GO TO 220
c
 8990 CONTINUE
      REWIND 3
      NLI(1)=LK
      NLI(2)=NCUP
      IF(RMAX.LT.0.0) KT=MIN0(KMAX,KTMIN)
      L=LMAX-1
      if(icon(19).eq.0) then
      WRITE(ioutp,9021)L,KT
      endif
C     TERMINATE CASE HERE IF ICON(20) .NE. 0
      IF(ICON(20).NE.0) then
        JOUT=1
        write(ioutp,9009)
      endif
      RETURN
C
 9004 FORMAT(26I3)
 9006 FORMAT(18x,'   LAM  =',I4,'        BETA =',F9.3
     1  ,'   LDFRM=',I4)
 9007 FORMAT(18x,'   LAM  =',I4,'        BETA =',F9.4
     1  ,'   LDFRM=',I4)
 9008 FORMAT(10F8.4)
 9009 format('0Program terminated by icon(20) .ne. 0  ',50(1H#))
 9010 FORMAT(18H0ANGLE DATA       ,9H   THETN=,F9.4,9H   THET1=,F9.4
     1,9H   DTHET=,F9.4)
 9011 FORMAT('0CHANNEL ',I3,8X,9H   ISPIN=,I3,A3,10X,81(1H*))
 9013 format('0Particle-hole projection enabled')
 9016 FORMAT( '0CHANNEL ',I3,' <====> CHANNEL ',I3,' COUPLING '
     1, 5X,60(1H*),'   ICOUX=',I4 )
 9017 FORMAT( '0CHANNEL ',I3,' <====  CHANNEL ',I3,' COUPLING '
     1, 5X,60(1H*),'   ICOUX=',I4 )
 9018 FORMAT(8I3,5F8.4)
 9019 FORMAT(I1,17X,15A4,I4,2(1H/,I2.2),I4,2(1H/,I2.2))
 9021 FORMAT(1H0,17X,9H   LMAX =,I4,5X,9H   NSTEP=,I4)
 9026 FORMAT('0ANG MOM DATA     ',9H   LMAX =,I4,'        2*LTR=',12I4)
 9027 FORMAT('                  ',9H   NLTR =,I4,'        2*KLM=',12I4)
 9028 FORMAT('0CARD SET 4 DATA  ',9H   DRF  =,F9.4,9H   RMAX =,F9.4 )
 9029 FORMAT(31X,14H          PAR=,12I4)
 9037 FORMAT('                  ',9H   LAM  =,I4,14H        2*STR=,I4
     1,14H        2*JTR=,I4,14H        ICODE=,I4,9H   RCOUL=,F9.4
     2,9H   FNRNG=,F9.4)
 9051 FORMAT('0PARTICLE SPINS DO NOT SATISFY PROPER STATISTICS *'
     1,10H  2*IS(I)=,I3,10H  2*IS(J)=,I3,8H  2*STR=,I3,3X,40(1H^))
 9052 FORMAT('0CHANNEL  SPINS DO NOT SATISFY PROPER RELATIONS  *'
     1,10H  2*I (I)=,I3,10H  2*I (J)=,I3,8H  2*JTR=,I3,3X,40(1H^))
 9053 FORMAT(22H0PARITY DOES NOT CHECK ,10H  IPAR(I)=,I3,10H  IPAR(J)=
     1,I3,10H   LAMBDA=,I3,3X,60(1H^))
 9054 FORMAT('0TOO MANY CHANNEL COUPLINGS   ',90(1H^))
 9055 FORMAT('0COUPLING.GT.NO. OF CHANNELS  ')
 9056 FORMAT('0Illegal ICODE, ICODE= ',I2)
 9057 FORMAT('0NO MATCH FOUND ON FF''S FOR OFF-SHELL FR CORRECTION ')
 9060 FORMAT('0**** ERROR ****  TOO MANY STATES, NLTR = ',I2)
 9901 FORMAT('0',a,'  Channel',I3,'  DIAGONAL K**2')
 9902 FORMAT('0Channel',I3,' - Channel',I3,'  Coupling',' icode =',i3
     1,'  lk =',i3)
 9900 FORMAT(F6.2,1p,10E12.3)
      END

c***********************************************************************
      subroutine storexc(space, scale, kmax, xc1)
c
c     Subroutine to store off diagonal coupling potentials
c     
c***********************************************************************
c
      parameter( istore = 3*2**13)
      complex space(*), xc1(istore)
c
        do 100 m=1,kmax
        xc1(m)=scale*space(m)
  100   continue
c
      end


