c***********************************************************************
      SUBROUTINE BDWUCK4
c
c     Control program for second part of DWUCK4 which integrates the 
c     distorted waves, calculates radial integrals, inelastic
c     amplitudes and the crossections.
c     
c***********************************************************************
c
      parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
      IMPLICIT REAL*8(A-H,O-Z)
      logical i_sym(2)
      COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
     1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
     2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
     3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
     4,KC,IBUFF,IWORD,ILINE,JLINE
      Common/array0/space0(ispc0)
      Common/array1/space1(ispc1)
      Common/array2/space2(ispc2)

      DIMENSION D(8000),sigplt(200,2),plm(2000), dtemp(2000), F(800)
     1,         FLL(8000), UB(800), FF(10)
      Equivalence (space1(   1), D), (space2(  1), FLL)
     1,           (space0(   1), F), (space0(   1), plm(1))
     2,           (space0(1601), sigplt(1,1)), (space0(3201), UB)
     3,           (space0(4001), FF) ,(space1(1001), dtemp)
      DATA FOURPI/12.5663706/
c
      do 40 i=1,2
c
      if(fm(i).eq.fma(i).and.z(i).eq.za(i)) then
        i_sym(i)=.true.
      else
        i_sym(i)=.false.
      endif
   40 continue
C
      IBUF=IBF(1)
      write(*,'(a)')'   Subroutine INTEG  entered'
      CALL INTEG4(i_sym)
C
C     PRINT OUT ELASTIC CROSS-SECTIONS 
C
      IF(ICON(6).ne.0.or.ICON(16).ne.0) then
        WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
        WRITE(6,9904)
C
        CALL ELSIG(dtemp,d,plm,sigplt,angle,fk,eta,rsig,alpha
     1            ,idat,is,icon,lplus,i_sym)
C
      else
        WRITE(6,9002)(RSIG(N),N=1,2)
      endif
      IF(ICON(12).NE.0) then
c
c     print out radial wave functions
c
c     skip over form factors
      DO 72 M=1,NLTR
      READ(4)
   72 CONTINUE
      WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
C
      CALL TAPED
C
      endif
c
      RZ=FLOAT(KZ)*DRF
      RMAX=FLOAT(K)*DRF
      JR=NS(1)
      JS=NS(2)
      DO 101 II=1,NLTR
      LTR=LTRT(II)
      MPLUS=LTR+1
C
C     SPACE TO PROPER FORM FACTOR FOR THIS L-TRANSFER
C
      DO 70 IJ=1,NLTR
      IF(IJ.EQ.II) then
        READ (4)UB,FF
      else
        READ (4)
      endif
   70 continue
C
      write(*,'(a)')'   Subroutine RADINT entered'
      CALL RADINT(F, FLL, UB, FF, LTR)
C
      IF(ICON(7).ne.0) then
C
C     WRITE( RADIAL MATRIX ELEMENTS IF ICON(7).NE.0
C
      INCR=LPL2*LTR
      INC=1
      IS1=-IS(1)

      DO 100 I=1,JR
      IS2=-IS(2)
      DO  98 J=1,JS
      WRITE(6,9999)ALPHA,(IDAT(M),M=1,3)
      WRITE(6,9900)IS1,IS2
      WRITE(6,9901)
      DO 90 LL=1,LPLUS
      LM=LL-1
      IND=INC+INCR
      WRITE(6,9902)LM,(FLL(IT),FLL(IT+1),IT=INC,IND,LPL2)
      INC=INC+2
   90 CONTINUE
      INC=INC+INCR
      IS2=IS2+2
   98 CONTINUE
      IS1=IS1+2
  100 CONTINUE
      endif
  101 CONTINUE
      END FILE 2
      REWIND 2
C
C     RESTORE SPIN STORAGE
C
      IS(1)=IBF(7)
      FS(1)=FLOAT(IBF(7))/2.0
      NS(1)=IBF(7)+1
      JR=NS(1)
      IS(2)=IBF(8)
      FS(2)=FLOAT(IBF(8))/2.0
      NS(2)=IBF(8)+1
      JS=NS(2)
      DO 300 II=1,NLTR
      LTR=LTRT(II)
      JTR=JTRT(II)
      IS(3)=ISTRT(II)
C
C     CALCULATE NORMALIZATION FACTOR
C
c     fact normalizes the cross section
c     flfact normalizes the amplitudes
c
      flfact=1.0
C
c     Photo-capture
      if    (fm(2).eq.0.0.and.is(2).eq.2) then
c       (p,gamma) reaction normalization
        fact=     2.0*fmu(1)*amu/(hbarc*fk(1))**2
     1            *chsq/fk(2)**2
        flfact=sqrt(float(2*ltr+1))
c
c     Photo-disintegration
      elseif(fm(1).eq.0.0.and.is(1).eq.2) then
c       (gamma,p) reaction normalization 
        fact=     2.0*fmu(2)*amu/(hbarc*fk(2))**2
     1            *chsq/fk(1)**2
      else
          FACT=     2.0*FMU(1)/(HBARC*FK(1))**2
     1             *2.0*FMU(2)/(HBARC*FK(2))**2
     2             *AMU**2/FOURPI
        if(abs(fm(1)-fm(2)).GT.0.1) then
C         Stripping normalization factors
          flfact=100.0*SQRT(FLOAT(2*LTR+1)/FLOAT(JTR+1))
          fact=fact*float(jtr+1)
        endif
      endif
c
      FACT=FACT*FK(2)/FK(1)
      FN=(II-1)*ICON(3)*(ICON(3)-1)
C
      CALL BETAFN(FLL, D, LTR,JTR,flfact,i_sym)
C
      MPLUS=JTR/2+1
      IF(icon(3).le.1.or.(icon(3).eq.2.and.II.eq.NLTR)) then
      IF(ICON(8).ne.0) then
C
C     WRITE BETA TABLES IF ICON(8).NE.0
C
      I1=MPLUS+MPLUS
      IFACT=I1     *NS(1)*NS(2)
      KT=1
      IS1=-IS(1)
      DO 120 I=1,JR
      IS2=-IS(2)
      DO 116 J=1,JS
      WRITE(6,9999)ALPHA,(IDAT(M),M=1,3)
      WRITE(6,9905)IS2,IS1
      WRITE(6,9903)
      DO 114 LL=1,LPLUS
      LM=LL-1
      IND=KT+LM*IFACT
      INDF=IND+I1-1
      WRITE(6,9902)LM,(D(INDEX),INDEX=IND,INDF)
  114 CONTINUE
      KT=KT+I1
      IS2=IS2+2
  116 CONTINUE
      IS1=IS1+2
  120 CONTINUE
      endif
C
C     SET HEADINGS FOR INELASTIC SIGMA
C
      WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
      WRITE(6,9507)DRF,RZ,RMAX,VCE,FS(1)
      WRITE(6,9508)FNRNG,PNLOC,FS(2)
      TEMP=ECM(2)-ECM(1)
      do 280 jj=1,nltr
      if((icon(3).le.1.and.jj.eq.ii).or.
     1   (icon(3).eq.2.and.ii.eq.nltr)) then
        WRITE(6,9505)LTRT(jj),JTRT(jj),IS(3),TEMP
      endif
  280 continue
C
        write(*,'(a)')'   Subroutine INSIG  entered'
        CALL INSIG(D, plm, JTR,FACT)
C
      endif
  300 CONTINUE
      REWIND 2
      RETURN

 9002 FORMAT(1H0,'REACSIG 1',1PE14.5,45X,'REACSIG 2',1PE14.5)
 9505 FORMAT(18H ANG MOM TRANSFER ,9H   LTR  =,I4,14H.       2*JTR=,I4
     1,14H.       2*STR=,I4,14H.       Q    =,F9.4)
 9507 FORMAT(18H0BASIC DATA       ,9H   DR   =,F9.4,9H   RMIN =,F9.4
     1,                            9H   RMAX =,F9.4,9H   COUEX=,F9.4
     2,                            9H     IS1=,F9.4)
 9508 FORMAT(18X,9H   FNRNG=,F9.4,9H   PNLC1=,F9.4,9H   PNLC2=,F9.4
     1,                           9H   PNLC3=,F9.4,9H     IS2=,F9.4)
 9900 FORMAT(24H0 RADIAL MATRIX ELEMENTS ,9H,  J1=L1+,I2,2H/2
     1,                                   9H,  J2=L2+,I2,2H/2 )
 9901 FORMAT('0 L2  F(L2,/L2-LTR/  )    F(L2,/L2-LTR/+2)'
     1,        '    F(L2,/L2-LTR/+4)    F(L2,/L2-LTR/+6)')
 9902 FORMAT(I4,1P10E10.3/(4X,1P10E10.3))
 9903 FORMAT('0 L2  BETA(L2,0)          BETA(L2,1)          BETA(L2,2)'
     1,  '          BETA(L2,3)          BETA(L2,4)')
 9904 FORMAT(1H0,32HELASTIC SCATTERING CROSS-SECTION )
 9905 FORMAT(1H0,8H    MS2=,I2,2H/2,8H    MS1=,I2,2H/2)
 9999 FORMAT(1H1,15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
      END

c***********************************************************************
      SUBROUTINE INTEG4(isym)
C
c     Subroutine to integrate radial differential equations for the
c     distorted waves.
c
c***********************************************************************
      parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
      IMPLICIT REAL*8(A-H,O-Z)
      logical isym(2)
      COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
     1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
     2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
     3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
     4,KC,IBUFF,IWORD,ILINE,JLINE
      Common/array0/space0(ispc0)
      Common/array1/space1(ispc1)
      Common/array2/space2(ispc2)
      DIMENSION U(800,2), V(800,2)
     1         ,F (400),FP(400),G (400),GP(400),S(400)
     2         ,F1(800),F2(800),Q1(800),Q2(800),C(800)
     3         ,D (800),X(800),DTEMP(3200)
     4         ,E (12),Q(4),A(2),B(2),CTEMP(2),LM(6)
     5         ,DRR2(2),DR2(2),R(2)
      EQUIVALENCE (space0(   1), U), (space0(1601), V)
     1           ,(U,DTEMP)
     2           ,(space1(   1),Q1),(space1( 801),Q2),(space1(1601),F1)
     3           ,(space1(2401),F2),(space1( 801),X ),(space1(   1),D )
     4           ,(DTEMP(   1),F ),(DTEMP( 401),FP),(DTEMP( 801),G )
     5           ,(DTEMP(1201),GP),(DTEMP(1601),S ),(DTEMP(2001),C )
      DATA ETA3/10.E+00/
C

      IWORD=0
      JT=NS(1)+NS(2) ! NS(1) is number of J-state in incoming channel, similar for NS(2), for (d,p), JT = 5
      NP=LPL2*JT  ! LPLUS = LMAX + 1, LPL2 = 2*LPLUS, NP = 2*(LMAX+1)*JT, for LMAX = 15 (d,p) NP = 160, NP= number of partial wave, real + imag
      I=0
c-------------------------------------- loop incoming and outgoing channel
      DO 30 N=1,2  !N = 1 : incoming channel, 2 : outgoing
      DR2(N)=DR(N)**2/12.0 ! this is for the Numerov method
      R(N)=0.0
      JS=NS(N) ! number of J-state in N-channel
c------------------------------- loop all J-state
      DO 29 ISS=1,JS ! loop all J-state
      I=I+1 
      LM(I)=0  ! all LM(I) = 0
   29 CONTINUE
c------------------------------- end of J_state loop
   30 CONTINUE  ! end of loop N
c---------------------------------------- end of channel loop
c     Nemerov method
c     y''(r) = g(r) y(r)
c     k(n+1)y(n+1) = (12 - 10*k(n))*y(n+1) - k(n-1)*y(n-1)
c     k(n) = 1 + dr^2/12 * g(n)
c     F2 = distorted wave = y(n)
c     Q2 = k(n)*y(n)
      DO 40 IQ=1,NP ! initial distorted wave, have NP partial wave 
      F1(IQ)=0.0 ! 
      F2(IQ)=0.0 ! F1 is n-1 of F2
      Q1(IQ)=0.0
      Q2(IQ)=0.0 ! Q1 is n-1 of Q2
   40 CONTINUE
C

      WRITE(6,*) 'Debug:  K=', K, ', NP=', NP
c============================================== loop radial grids
      DO 100 M=1,K ! K = ABS(RMAX)/DRF + 1.0E-08
      MK=M+M-1 ! 2*M-1, odd number from 1 to K, odd for real, even for imag
      IX=0 ! loop from 1 to 128, step 32 = 2*LPLUS, each group of 32 is all L-states for a J-state
      I=0 ! loop from 1 to 5, total J-state in incoming and outgoing channel
c------------------------------------ loop channels      
      DO 90 N=1,2  ! looping incoming and outgoing channel
      R(N)=R(N)+DR(N)
      DRR2(N)=DR2(N)/R(N)**2 ! for L(L+1)/r^2 term in the potential
      Q(1)=1.0+DR2(N)*U(MK  ,N)  ! for real part , seem to be the Numerov k_n
      Q(2)=    DR2(N)*U(MK+1,N)  ! for imag part
      LTEMP=2.0*FK(N)*R(N)+ETA3  ! ETA3 = 10, this is the theoritic maximum L
      LTEMP=MIN0(LTEMP,LPLUS) ! set the maximum acceptable L
      FI=-FS(N) ! s-state of S of channle-N, N=1 for incoming, =2 for outgoing
      JS=NS(N) ! number of J-state of S
      SFACT=FS(N)**2+FS(N) ! s * (s+1) 
c-------------------------- loop J-state
      DO 89 ISS=1,JS ! loop the J-state
      I=I+1 ! I is the id of J-state
      FL=0.0 ! FL runs from 0 to LMAX
c---------------- loop the L-state
      DO 80 LL=1,LPLUS ! loop all L, fortan start index is 1, so need to run from 1 to LMAX + 1
      FJ=FL+FI ! J = L + S, looping possible J-state
      IX1=IX+LL+LL-1 ! index in memomry, loop from 1 to 159 odd, odd for real? even for imag?
      FLFACT=FL**2+FL 
      FACT=DR2(N)*(FJ**2+FJ-FLFACT-SFACT)*0.5 ! for L(L+1)/r^2 
      Q(3     )=Q(1)+FACT*V(MK  ,N)-DRR2(N)*FLFACT
      Q(4     )=Q(2)+FACT*V(MK+1,N)
      IF(LL.LE.LM(I)) GO TO 70
      IF(LTEMP.LT.LL) GO TO 72
      LM(I)=LM(I)+1 !this control the calculateing of start value, weird but work.
      IF(FJ-ABS(FL-FS(N)).LT.0.0) GO TO 72 ! j < ||l-s|, increase FL by 1
c........... calculate approximate starting value
c     for FL < 9, R=0.1 is set
c     for FL = 10, R=0.5 is set
c         FL = 11, R=0.89 is set
c         FL = 12, R=1.3
c         FL = 13, R=1.7
c         FL = 14, R=2.1
c         FL = 15, R=2.5
        f2(ix1  )=1.0
        do 50 ii=1,ll
        f2(ix1  )=f2(ix1  )*(fk(n)*r(n))/float(2*ii-1)
   50   continue

c      IF(N.EQ.1 ) THEN
c      WRITE(6,*) R(N), FL, FJ, IX, IX1, f2(ix1), M
c      ENDIF

c      IF(N.EQ.1 .AND.  FL.EQ.1 .AND. FJ.EQ.1) THEN
c      WRITE(6,5678) 
c     1'Debug:',R(N),Q1(IX1),Q2(IX1),F2(IX1),
c     2              Q1(IX1+1),Q2(IX1+1),F2(IX1+1),
c     3              Q(3), Q(4)
c      ENDIF

      F2(IX1+1)=0.0
      Q2(IX1  )=Q(3)*f2(ix1  )
      Q2(IX1+1)=Q(4)*f2(ix1  )
C
C     EVALUATE Q AT ORIGIN FOR L=1
C
      IF(LL.EQ.2) Q1(IX+3)=-f2(ix1  )/6.0 ! when LL is 2 or FL = 1
      GO TO 72
c........... end of starting value
   70 CONTINUE
c
c     Step equations forward by dr(n) via Numerov-Fox-Goodwin-Milne method
c

c      IF(N.EQ.1 .AND.  FL.EQ.1 .AND. FJ.EQ.1) THEN
c      WRITE(6,5678) 
c     1'Debug:',R(N),Q1(IX1),Q2(IX1),F2(IX1),
c     2              Q1(IX1+1),Q2(IX1+1),F2(IX1+1),
c     3              Q(3), Q(4)
c 5678 FORMAT(A, F7.3, F10.6, F10.6, F10.6, F10.6, 
c     1          F10.6, F10.6, F10.6, F10.6)
c      ENDIF
c
c    Q2 (n+1) = 12 * y (n) - 10 * Q2 (n) - Q2 (n-1) for real 
c    Q2'(n+1) = 12 * y'(n) - 10 * Q2'(n) - Q2'(n-1) for imag
c        a(n) = Q(3) = k(n) for real ?
c        b(n) = Q(4) = k(n) for imag ?
c     y (n+1) = [  Q2(n+1)*a(n) + Q2'(n+1)*b(n) ] / (a(n)^2 + b(n)^2)
c     y'(n+1) = [ -Q2(n+1)*b(n) + Q2'(n+1)*a(n) ] / (a(n)^2 + b(n)^2)
c
      CTEMP(1)=12.*F2(IX1  )-10.*Q2(IX1  )-Q1(IX1  ) ! k(n+1)y(n+1) = (12 - 10*k(n))*y(n+1) - k(n-1)*y(n-1)
      CTEMP(2)=12.*F2(IX1+1)-10.*Q2(IX1+1)-Q1(IX1+1)
      F1(IX1  )=F2(IX1  )  ! save the old f2 to f1
      F1(IX1+1)=F2(IX1+1)
      DET=Q(3)**2+Q(4)**2   ! real^2 + imag^2
      F2(IX1  )=(CTEMP(1)*Q(3     )+CTEMP(2)*Q(4     ))/DET ! new f2 = 
      F2(IX1+1)=(CTEMP(2)*Q(3     )-CTEMP(1)*Q(4     ))/DET
      Q1(IX1  )=Q2(IX1  )
      Q1(IX1+1)=Q2(IX1+1)
      Q2(IX1  )=CTEMP(1)
      Q2(IX1+1)=CTEMP(2)

c      IF(N.EQ.1 .AND.  FL.EQ.1 .AND. FJ.EQ.1) THEN
c      WRITE(6,'(A, F7.3, F10.6, F10.6, F10.6, F10.6, F10.6, F10.6)') 
c     1'Debug:',R(N),Q1(IX1),Q2(IX1),F2(IX1),
c     2              Q1(IX1+1),Q2(IX1+1),F2(IX1+1)
c      ENDIF
      
   72 CONTINUE
      FL=FL+1.0
   80 CONTINUE
c---------------- end of loop the L-state
      FI=FI+1.0
      IX=IX+LPL2 ! after L-state loop, go to next index
   89 CONTINUE
c-------------------------- end of loop J-state
   90 CONTINUE
c------------------------------------ end of loop channels    
C
C     WRITE RADIAL WAVE FUNCTIONS ON TAPE 4
C
      WRITE(4)(F2(J),J=1,NP)
  100 CONTINUE
c============================================== end of loop radial grids

      LX=1
      drrc = 0.1

      DO 120 N=1,2
      R2=FK(N)*R(N)
      R1=R2-DR(N)*FK(N)
      CALL COU(R1,R2,ETA(N),LPLUS,drrc,F(LX),FP(LX),G(LX),GP(LX),S(LX))
      RSIG(N)=0.0
      LX=LX+LPLUS
  120 CONTINUE
C
      IF(ICON(5).ne.0) then
        WRITE(6,9999)ALPHA,(IDAT(I),I=1,3)
        WRITE(6,9600)
        WRITE(6,9601)
      endif
c
c     Match solutions to asymptotic form
c
      DO 300 LL=1,LPLUS
      FL=FLOAT(LL-1)
      LX=LL
      I=0
      IX1=LL+LL-1
      DO 200 N=1,2
      JS=NS(N)
      FI=-FS(N)
      ARG=S(LX)-S(LX-LL+1) ! Coulomb phase shift ?
      Q(1)=COS(ARG) 
      Q(2)=SIN(ARG)
      Q(3)=Q(1)**2-Q(2)**2
      Q(4)=2.0*Q(1)*Q(2)
      DO 199 ISS=1,JS
      FJ=FL+FI
      I=I+1
      DET=F(LX)*GP(LX)-FP(LX)*G(LX)
      A(1)=(F1(IX1  )*GP(LX)-F2(IX1  )*G (LX))/DET  ! real part of F 
      A(2)=(F1(IX1+1)*GP(LX)-F2(IX1+1)*G (LX))/DET  ! imag part of F
      B(1)=(F2(IX1  )*F (LX)-F1(IX1  )*FP(LX))/DET  ! real part of G
      B(2)=(F2(IX1+1)*F (LX)-F1(IX1+1)*FP(LX))/DET  ! imag part of G
      IF(LL.LE.LM(I).and.FJ-ABS(FL-FS(N)).ge.0.0) then
        DET=(A(1)+B(2))**2+(A(2)-B(1))**2 ! this is the normalization
        CTEMP(1)=(A(1)+B(2))/DET  ! CTEMP(1) = cos(sigma)/sqrt(DET)
        CTEMP(2)=(B(1)-A(2))/DET  ! = - sin(sigma)/sqrt(DET)
      else
          CTEMP(1)=0.0
          CTEMP(2)=0.0
      endif
C
C     C=NORMALIZATION CONSTANTS
C
      C(IX1  )=Q(1)*CTEMP(1)-Q(2)*CTEMP(2) ! cos(sigma)^2 + sin(sigma)^2 = 1/ sqrt(DET)
      C(IX1+1)=Q(1)*CTEMP(2)+Q(2)*CTEMP(1) ! 0 ?

C
C     E=PARTIAL WAVE SCATTERING AMPLITUDES, ScatAmp = (S-1)/2i
C
      E(2*I-1)=B(1)*CTEMP(1)-B(2)*CTEMP(2) ! real part of ScatAmp = s2/2
      E(2*I  )=B(1)*CTEMP(2)+B(2)*CTEMP(1) ! image = (1-s1)/2

c      IF(N.EQ.1) THEN
c      WRITE(6,*) 'Norm ', FL, FJ, A(1), A(2), B(1), B(2),
c     1   CTEMP(1), CTEMP(2),
c     2                    ARG, C(IX1), C(IX1+1), 1./DET,
c     3                    E(2*I-1), E(2*I)
c      ENDIF

      T1 = E(2*I-1)
      T2 = E(2*I  )
      if(isym(N) .and. is(N).eq.0 ) then
        if(Phasef(lx-1).lt.0.0) then
        T1 = 0.0
        T2 = 0.0
        E(2*I-1) = 0.0
        E(2*I  ) = 0.0
        else
        T1 = 2.0*T1
        T2 = 2.0*T2
        endif
      endif
C
C     D=PARTIAL WAVE SCATTERING AMPLITUDES* COULOMB PHASE / WAVE NUMBER
C
      D(IX1  )=(Q(3)*T1 - Q(4)*T2)/FK(N)
      D(IX1+1)=(Q(3)*T2 + Q(4)*T1)/FK(N)
      X(IX1  )=E(2*I-1)
      X(IX1+1)=E(2*I  )
C
C     CALCULATE REACTION SIGMA
C
      T1 = E(2*I  ) - E(2*I-1)**2-E(2*I  )**2 
      if(isym(N) .and. is(N).eq. 0) T1 = 4.0*T1 
      RSIG(N)=RSIG(N)+(2.0*FJ+1.0)*T1
      FI=FI+1.0
      IX1=IX1+LPL2
  199 CONTINUE
      LX=LX+LPLUS
  200 CONTINUE
      IF(ICON(5).ne.0) then
C
C     WRITE ELASTIC PARTIAL WAVE SCATTERING AMPLITUDES
C
        IX=LL-1
        I1=1
        I2=NS(1)*2
        WRITE(6,9602)IX,(E(INDEX  ),INDEX=I1,I2)
        I1=I2+1
        I2=I2+NS(2)*2
        WRITE(6,9603)IX,(E(INDEX  ),INDEX=I1,I2)
      endif
  300 CONTINUE
      DO 310 N=1,2
      RSIG(N)=RSIG(N)*12.566371 /((2.0*FS(N)+1.0)*FK(N)**2)
  310 CONTINUE
C
C     WRITE NORMALIZATION CONSTANTS ON TAPE 4
C
      WRITE(4)(C(I),I=1,NP)
C
C     WRITE END POINT FUNCTIONS FOR UNBOUND STATE STRIPPING
C
C     ILINE IS SET IN ADWUCK FORM FACTOR LOOP
      IF(ILINE.EQ.0) GO TO 400
      WRITE(4)(X(I),I=1,NP),(GP(I),FP(I),I=1,LPL2),(S(I),I=1,LPL2)
  400 CONTINUE
      END FILE 4
      REWIND 4
      RETURN
 9600 FORMAT(1H0,35HPARTIAL WAVE SCATTERING AMPLITUDES )
 9601 FORMAT(4H   L,20H   REAL D1   IMAG D1 ,20H   REAL D2   IMAG D2
     1,             20H   REAL D3   IMAG D3
     2,   4X,4H   L,20H   REAL D1   IMAG D1 ,20H   REAL D2   IMAG D2
     3,             20H   REAL D3   IMAG D3 )
 9602 FORMAT(1H ,    I3,6F10.6)
 9603 FORMAT(1H+,68X,I3,6F10.6)
 9999 FORMAT(1H1,15A4,I4,2(1H/,I2.2),I4,2(1H.,I2.2))
      END

c***********************************************************************
      SUBROUTINE TAPED
C
c     Subroutine writes out radial wave functions,
c     spaced icon(12) points apart
c***********************************************************************
c
      parameter(ispc0 = 4010, ispc1 = 8000, ispc2 = 8000)
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON ALPHA(15),IDAT(6),ICON(20),ANGLE(5),HBARC,AMU,AMASS,CHSQ,AA
     1,DRF,Z(3),ZA(3),FM(3),FMA(3),RC(3),AC(3),PNLOC(3),FS(3),ECM(3)
     2,FK(3),FK2(3),ETA(3),DR(3),FMU(3),FN,FL,FJ2,FSS,VCE,FNRNG,RSIG(2)
     3,K,KZ,LPLUS,LPL2,IS(3),NS(3),NLTR,LTRT(8),JTRT(8),ISTRT(8),IBF(8)
     4,KC,IBUFF,IWORD,ILINE,JLINE
      Common/array0/space0(ispc0)
      Common/array1/space1(ispc1)
      Common/array2/space2(ispc2)

      DIMENSION C(800),FR(800),R(2),CTEMP(2)
      EQUIVALENCE  (space0(2001), C(1)), (space0( 801), FR(1))
c
      IK=ICON(12)
      JT=NS(1)+NS(2)
      NP=LPL2*JT
      R(1)=0.0
      R(2)=0.0
      IKTEMP=0
      DO 50 M=1,K
      IKTEMP=IKTEMP+1
C
C     READ IN DISTORTED WAVE RADIAL FUNCTIONS
C
      READ (4)(FR(J),J=1,NP)
      IF(IKTEMP.NE.IK) GO TO 50
      IKTEMP=0
      IX=0
      DO 40 N=1,2
      R(N)=R(N)+DR(N)*FLOAT(IK)
      JX=NS(N)
      DO 39 J=1,JX
      DO 30 LL=1,LPLUS
      LK=LL+LL-1
      IX1=LK+IX
      IX2=IX1+1
C
C     NORMALIZE RADIAL FUNCTIONS
C
      CTEMP(1)=FR(IX1)*C(IX1)-FR(IX2)*C(IX2)
      CTEMP(2)=FR(IX1)*C(IX2)+FR(IX2)*C(IX1)
      FR(IX1)=CTEMP(1) ! real
      FR(IX2)=CTEMP(2) ! complex
   30 CONTINUE
      IX=IX+LPL2
   39 CONTINUE
   40 CONTINUE
      WRITE(6,9001)R(1),R(2)
      WRITE(6,9601)
      DO 45 LL=1,LPLUS
      LM=LL-1
      LK1=LM+LL
      LK2=LPL2*(NS(1)-1)+LK1
      WRITE(6,9602)LM,(FR(LK),FR(LK+1),LK=LK1,LK2,LPL2)
      LK1=LK2+LPL2
      LK2=LPL2*(NS(2)-1)+LK1
      WRITE(6,9603)LM,(FR(LK),FR(LK+1),LK=LK1,LK2,LPL2)
   45 CONTINUE
   50 CONTINUE
      REWIND 4
      RETURN
 9001 FORMAT(1H0,3HR1=,F8.4,57X,3HR2=,F8.4)
 9601 FORMAT(4H   L,20H  REAL D1   IMAG D1 ,20H  REAL D2   IMAG D2 ,20H
     1 REAL D3   IMAG D3 ,4X,4H   L,20H  REAL D1   IMAG D1 ,20H  REAL D2
     2   IMAG D2 ,20H  REAL D3   IMAG D3 )
 9602 FORMAT(1H ,    I3,6F10.7)
 9603 FORMAT(1H+,68X,I3,6F10.7)
      END